Question

我工作的公司每天都会向数百人发送电子邮件。字母模板会有所不同，我想要的数据字母中的位置也会有所不同。我已经拥有处理用户大部分步骤的VBA代码，包括将信件作为PDF附加到Outlook电子邮件中并填充主题和正文。目前，问题在于，当用户键入该字母要发送到的电子邮件地址时，人为错误会导致拼写错误和误导。所以我试图在此代码中添加一个部分，在文档中搜索电子邮件地址（文档中始终只有一个电子邮件地址，但可能位于不同的位置），然后复制该电子邮件并将其放入Outlook电子邮件的TO行。这是我正在使用的代码：

Sub EmailDocumentAsPDFfinal()


Dim SourceDoc As Document
Dim OutlookApp As Object
Dim OutlookMessage As Object
Dim TempFileName As Variant
Dim TempFilePath As String
Dim DefaultName As String
Dim UserAnswer As Long
Dim x As Long

  Set SourceDoc = ActiveDocument

  TempFilePath = Environ$("temp") & "\"

  If SourceDoc.Path <> "" Then
    DefaultName = Left(SourceDoc.Name, InStrRev(SourceDoc.Name, ".") - 1)
  Else
    DefaultName = SourceDoc.Name
  End If

TempFileName = "DocName"

  ActiveDocument.ExportAsFixedFormat _
   OutputFileName:=TempFilePath & TempFileName & ".pdf", _
   ExportFormat:=wdExportFormatPDF

  On Error Resume Next
    Set OutlookApp = GetObject(class:="Outlook.Application") 'Handles if Outlook is already open
  Err.Clear
    If OutlookApp Is Nothing Then Set OutlookApp = CreateObject(class:="Outlook.Application") 'If not, open Outlook

    If Err.Number = 429 Then
      MsgBox "Outlook could not be found, aborting.", 16, "Outlook Not Found"
      Exit Sub
    End If
  On Error GoTo 0

  Set OutlookMessage = OutlookApp.CreateItem(0)

  On Error Resume Next
    With OutlookMessage
     .To = ""
     .CC = ""
     .BCC = ""
     .Subject = "This is the letter you requested"
     .Body = "Please let us know if you have any questions."
     .Attachments.Add TempFilePath & TempFileName & ".pdf"
     .Display
    End With
  On Error GoTo 0

  Kill TempFilePath & TempFileName & ".pdf"

  Set OutlookMessage = Nothing
  Set OutlookApp = Nothing

End Sub

Answer 1

尝试将以下块添加到您的代码中（最好在定义SourceDoc后开头） - 它使用通配符查找电子邮件并将完整字符串返回到EmAdr变量，您可以在Outlook发送者代码的.To行中使用

Dim rng as Range
Dim EmAdr as String

Set rng = SourceDoc.Content

    With Rng.Find
        .Text = "*@*.*"
        .Wrap = wdFindAsk
        .Forward = True
        .MatchWildcards = True

        If .Execute Then
           EmAdr = rng.Text
        Else
          MsgBox "Email not found"
        End If
    End With

如果这有帮助，请将答案标记为已接受。

从Word文档中提取单个电子邮件地址并将其应用于Outlook电子邮件的{TO：}字段

1 个答案: