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