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

　　

转载于:https://www.cnblogs.com/nextseven/p/7484221.html