zoukankan      html  css  js  c++  java
  • 20170906xlVBA_GetEMailFromDocument

    Public Sub GetDataFromWord()
        AppSettings
        'On Error GoTo ErrHandler
        Dim StartTime, UsedTime As Variant
        StartTime = VBA.Timer
        'Input code here
        
        Dim Wb As Workbook
        Dim Sht As Worksheet
        Dim oSht As Worksheet
        Dim Rng As Range
        Dim Arr As Variant
        
        Dim Dic As Object
        Set Dic = CreateObject("Scripting.Dictionary")
        
        
        'Dim wdApp As Word.Application
        'Dim wdDoc As Word.Document
        Dim wdApp As Object
        Dim wdDoc As Object
        
        'Const SHEET_NAME As String = "提取信息"
        Set Wb = Application.ThisWorkbook
        Set Sht = Wb.Worksheets(1)
        
        
        On Error Resume Next
        Set wdApp = GetObject(, "Word.Application")
        If wdApp Is Nothing Then
            Set wdApp = CreateObject("Word.Application")
        End If
        On Error GoTo 0
        
        'Set wdApp = New Word.Application
        
        
        Filename = Dir(Wb.Path & "*.doc*")
        Do While Filename <> ""
            Debug.Print Filename
            FilePath = Wb.Path & "" & Filename
            Set wdDoc = wdApp.Documents.Open(FilePath)
            Text = wdDoc.Content.Text
            
            If RegTest(Text, "(w+([-+.]w+)*@w+([-.]w+)*.w+([-.]w+)*)") Then
                Arr = RegGetArray("(w+([-+.]w+)*@w+([-.]w+)*.w+([-.]w+)*)", Text)
                For i = LBound(Arr) To UBound(Arr)
                    Key = CStr(Arr(i))
                    Debug.Print Key
                    If Not Dic.Exists(Key) Then
                        Dic(Key) = Dic.Count + 1
                    End If
                Next i
                
            End If
            
            
            Filename = Dir
        Loop
        
        
        Application.StatusBar = ">>>>>>>>Regexpress Getting array >>>>>>>>"
        wdDoc.Close False    '关闭doc
        wdApp.Quit    '退出app
        Set wdApp = Nothing
        Set wdDoc = Nothing
        
        
        With Sht
            .Cells.ClearContents
            .Range("A1:B1").Value = Array("序号", "邮箱")
            Set Rng = .Range("A2")
            Set Rng = Rng.Resize(Dic.Count, 2)
            Rng.Value = Application.WorksheetFunction.Transpose(Array(Dic.Items, Dic.keys))
        End With
        UsedTime = VBA.Timer - StartTime
        Debug.Print "UsedTime:" & Format(UsedTime, "0.000 Seconds")
        'MsgBox "UsedTime:" & Format(UsedTime, "0.000 Seconds"), vbOKOnly, "QQ "
    ErrorExit:
        Set Wb = Nothing
        Set Sht = Nothing
        Set Rng = Nothing
        
        Set Dic = Nothing
        
        
        AppSettings False
        
        On Error Resume Next
        wdApp.Quit
        
        Exit Sub
    ErrHandler:
        If Err.Number <> 0 Then
            MsgBox Err.Description & "!", vbCritical, "QQ "
            Debug.Print Err.Description
            Err.Clear
            Resume ErrorExit
        End If
    End Sub
    Public Sub AppSettings(Optional IsStart As Boolean = True)
        If IsStart Then
            Application.ScreenUpdating = False
            Application.DisplayAlerts = False
            Application.Calculation = xlCalculationManual
            Application.StatusBar = ">>>>>>>>Macro Is Running>>>>>>>>"
        Else
            Application.ScreenUpdating = True
            Application.DisplayAlerts = True
            Application.Calculation = xlCalculationAutomatic
            Application.StatusBar = False
        End If
    End Sub
    Public Function RegGetArray(ByVal Pattern As String, ByVal OrgText As String) As String()
        Dim Reg As Object, Mh As Object, OneMh As Object
        Dim Arr() As String, Index As Long
        Dim Elm As String
        Set Reg = CreateObject("Vbscript.Regexp")
        With Reg
            .MultiLine = True
            .Global = True
            .Ignorecase = False
            .Pattern = Pattern
            Set Mh = .Execute(OrgText)
            
            Index = 0
            ReDim Arr(1 To 1)
            For Each OneMh In Mh
                Index = Index + 1
                ReDim Preserve Arr(1 To Index)
                'If OneMh.submatches(0) <> "" Then Elm = OneMh.submatches(0)
                Arr(Index) = OneMh.submatches(0)
            
            Next OneMh
        End With
        RegGetArray = Arr
        Set Reg = Nothing
        Set Mh = Nothing
    End Function
    Public Function RegTest(ByVal OrgText As String, ByVal Pattern As String) As Boolean
    '传递参数 :原字符串, 匹配模式
        Dim Regex As Object
        Set Regex = CreateObject("VBScript.RegExp")
        With Regex
            .Global = True
            .Pattern = Pattern
        End With
        RegTest = Regex.TEST(OrgText)
        Set Regex = Nothing
    End Function
    

      

  • 相关阅读:
    配置JAVA环境
    Sun Java认证
    JAVA中去掉空格
    2011年百度新闻热搜榜十大互联网人物
    23 设计模式
    HTML编辑器FCKeditor使用详解 [转]
    Linux 系统目录结构
    DotNet程序员是不是最不幸福?
    VS2005(c#)项目调试问题解决方案集锦 转
    详细介绍有关于.NET的委托
  • 原文地址:https://www.cnblogs.com/nextseven/p/7484221.html
Copyright © 2011-2022 走看看