如何使用VBA从Word文档中提取电子邮件地址 [英] How extract email address from Word document using vba

问题描述

我的目标是从Word.ActiveDocument中提取所有电子邮件地址，并将它们放入Excel工作表中的单个单元格中.

My goal is to extract all email addresses from the Word.ActiveDocument and put them into one single cell in the Excel Sheet.

该代码从Excel VBA编辑器运行.它需要搜索电子邮件地址，从文档中提取它们并填写Excel单元格Activesheet.Range("C31").无论找到多少个电子邮件地址，都只能使用一个单元格.

The code is run from Excel VBA editor. It needs to search for email addresses, extract them from the document and fill the Excel cell Activesheet.Range("C31"). Only one cell is available, no matter how many email addresses have been found.

需要使用", "逗号和空格来分隔找到的地址.

The addresses found need to be delimited using ", " the coma and the space.

我正在尝试通过在文档中找到@来实现此目的，然后向前和向后建立范围，以使所有电子邮件地址都在range变量中.使用rng.MoveEndUntil Cset:=","在右侧建立地址非常容易，因为在我的文档中，电子邮件地址后总是有一个逗号.

I'm trying to do this by finding @ in the document and then building up the range forward and backwards to have all the email address in the range variable. Building the address to the right was quite easy using rng.MoveEndUntil Cset:="," because in my document there is always a coma after the email address.

但是如何使电子邮件地址左侧缺少的部分进入range变量呢? 我用过rng.MoveStart Unit:=wdWord, Count:=-1，但是如果电子邮件是[e-mail]或[e-mail]，该怎么办呢?

But how to get the missing left side of the email address into the range variable?? I've used rng.MoveStart Unit:=wdWord, Count:=-1 but what if the email will be [e-mail] or [e-mail] It will not work.

这就是我现在拥有的.

Sub FindEmail035()         '[0-9;A-z;,._-]{1;}\@[0-9;A-z;._-]{1;}
                           '[0-9;A-z;,._-]{1;}\@[0-9;A-z;._-]{1;}
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Dim ExcelApp As Excel.Application

Dim rng As Word.Range
Dim emailAdr As String
Dim ws As Worksheet

Set WordApp = GetObject(, "Word.Application")
Set ExcelApp = GetObject(, "Excel.Application")
Set WordDoc = WordApp.ActiveDocument
Set rng = WordApp.ActiveDocument.Content
Set ws = ExcelApp.ActiveSheet

ExcelApp.Application.Visible = True

    With rng.Find
        .Text = "@"
        .Wrap = wdFindAsk
        .Forward = True
        .MatchWildcards = False
        .Execute

        Debug.Print rng.Text
        If .Found = True Then
            'rng.Expand (wdWord)
            'Debug.Print rng.Text
            rng.MoveStart Unit:=wdWord, Count:=-1
            Debug.Print rng.Text
            rng.MoveEndUntil Cset:=","
            'rng.MoveEnd Unit:=wdWord, Count:=1
            'rng.MoveEndUntil Cset:=" ", Count:=wdBackward
        End If
   End With     'how to create loop that will extract all the email addresses in the document??
   ws.Range("C31").Value = rng

End Sub

我应该使用哪个循环来获取文档中存在的邮件数量，然后在内部使用电子邮件地址建立范围?

What loop should I use to get the number of mails present in the document and later build up the ranges with email addresses inside?

这是文档中邮件地址所在的位置.

This is the place in the document where the mail addresses reside.

推荐答案

您处在正确的轨道上.此处最简单的方法是使用.MoveStartUntil Cset:=" " Count:=wdBackward移动范围的开头，以便您在范围内移动，直到在电子邮件地址前的空格处打上.当然，这是假设格式一致且没有任何空格.

You're on the right track. The easiest thing here is to move the start of the range with .MoveStartUntil Cset:=" " Count:=wdBackward so that you move back through the range until you hit the space before the email address. That is of course assuming consistent formatting and no arbitrary spaces.

我也只搜索ActiveDocument.Content，然后每次.Found = True，然后搜索Set rng，因为您不希望它覆盖您的范围(在搜索范围时会如此).或Dim新范围srchRng或其他内容，然后将其设置为找到的结果.

I would also just search through the ActiveDocument.Content and then Set rng every time .Found = True because you don't want it overriding your range (which it does when searching a range). Or Dim a new range srchRng or something and then set that to the found results.

 With rng.Find
        .Text = "@"
        .Wrap = wdFindAsk
        .Forward = True
        .MatchWildcards = False
        .Execute

        Debug.Print rng.Text
        If .Found = True Then
            rng.MoveStartUntil Cset:=" ", Count:=wdBackward
            rng.MoveEndUntil Cset:=","
        End If

这篇关于如何使用VBA从Word文档中提取电子邮件地址的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！