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