如何使用vba从Word文档中提取电子邮件地址

Sub ExtractEmailAddresses()
    Dim doc As Document
    Dim content As Range
    Dim regex As Object
    Dim matches As Object
    Dim email As String
    Dim emails As Collection
    
    ' 打开Word文档
    Set doc = Documents.Open("C:\Path\To\Your\Document.docx")
    
    ' 获取文档内容
    Set content = doc.Content
    
    ' 创建正则表达式对象
    Set regex = CreateObject("VBScript.RegExp")
    regex.Pattern = "\b[A-Za-z0-9._%+-]+@[A-Za-z0-9.-]+\.[A-Za-z]{2,}\b"
    
    ' 创建集合来存储电子邮件地址
    Set emails = New Collection
    
    ' 遍历文档内容并提取电子邮件地址
    For Each match In regex.Execute(content.Text)
        email = match.Value
        ' 检查是否已经存在相同的电子邮件地址
        On Error Resume Next
        emails.Add email, CStr(email)
        On Error GoTo 0
    Next match
    
    ' 输出结果
    For Each email In emails
        Debug.Print email
    Next email
    
    ' 关闭Word文档
    doc.Close
End Sub