将 Outlook 邮件正文传递给字符串

Question

我正在尝试从对电子邮件爆炸的不良响应中收集电子邮件地址。

代码分为两部分，搜索部分，它在电子邮件中搜索一个字符并返回其前后的字符串，以及过程部分，它对 Outlook 文件夹中的每封电子邮件运行搜索。

我已经在复制到 Excel 中的电子邮件上测试了搜索，它可以正常工作。

我遇到的问题是我无法将作为对象的电子邮件正文传递给字符串变量。

Sub Extract()
On Error Resume Next

'specify the folder to pull emails from
Set myOlApp = Outlook.Application
Set mynamespace = myOlApp.GetNamespace("mapi")
Set myfolder = myOlApp.ActiveExplorer.CurrentFolder
Dim myitem As Outlook.MailItem

'start excel and open spreadsheet
Set xlobj = CreateObject("excel.application")
xlobj.Visible = True
xlobj.Workbooks.Add

'Set Heading on spreadsheet
xlobj.Range("a" & 1).Value = "Email"

'for loop passing email body to search code
For i = 1 To myfolder.Items.Count
Set myitem = myfolder.Items(i)
extractStr = myitem.Body

'search for specific text
CheckStr = "[A-Za-z0-9._-]"
OutStr = ""
Index = 1
Index1 = VBA.InStr(Index, extractStr, "@")
getStr = ""
If Index1 > 0 Then
    For p = Index1 - 1 To 1 Step -1
        If Mid(extractStr, p, 1) Like CheckStr Then
            getStr = Mid(extractStr, p, 1) & getStr
        Else
            Exit For
        End If
    Next
    getStr = getStr & "@"
    For p = Index1 + 1 To Len(extractStr)
        If Mid(extractStr, p, 1) Like CheckStr Then
            getStr = getStr & Mid(extractStr, p, 1)
        Else
            Exit For
        End If
    Next
    Index = Index1 + 1
    If OutStr = "" Then
        OutStr = getStr
    Else
        OutStr = OutStr & Chr(10) & getStr
    End If
Else
    GoTo 20
End If


'write to excel
20 xlobj.Range("a" & i + 1).Value = OutStr

Next
End Sub

更新：我想我已经弄明白了。为了测试这个脚本，我放置了一两封电子邮件，以便将电子邮件地址从测试文件夹中提取出来。我选择的电子邮件是 html 格式的！我放了以下代码行来将当前的电子邮件正文（myitem）转换为纯文本。

myitem.BodyFormat = olFormatPlain

我已将 myitem 变量声明为对象和邮件项。当我以 myitem 作为对象运行脚本时，在以下行中出现“对象不支持此属性或方法”错误：

myitem.BodyFormat = olFormatPlain

但是，当我将它作为邮件项目运行时，我在此行收到类型不匹配错误：

For Each myitem In myfolder

以下是我在两种不同场景中声明 myitem 变量的方式：

Dim myitem as MailItem
Dim myitem as Object

这是我更新的代码。

Option Explicit
Sub Extract()
'On Error Resume Next

'Variable declaration
Dim myOlApp As Outlook.Application
Dim mynamespace As Outlook.NameSpace
Dim myfolder As Selection
Dim myitem As MailItem
Dim i As Integer
Dim extractStr As String
Dim CheckStr As String
Dim OutStr As String
Dim Index As Integer
Dim Index1 As Integer
Dim getStr As String
Dim p As Integer

'start excel and open spreadsheet
Dim xlobj As Object
Set xlobj = CreateObject("excel.application")
xlobj.Visible = True
xlobj.Workbooks.Add

'Set Heading on spreadsheet
xlobj.Range("a" & 1).Value = "Email"

'Set reference to the Selection.
Set myOlApp = Outlook.Application
Set mynamespace = myOlApp.GetNamespace("mapi")
Set myfolder = ActiveExplorer.Selection

'for loop passing email body to search code
For Each myitem In myfolder
    myitem.BodyFormat = olFormatPlain
    extractStr = myitem.Body
    MsgBox (extractStr)

'search for specific text
    CheckStr = "[A-Za-z0-9._-]"
    OutStr = ""
    Index = 1
    Index1 = VBA.InStr(Index, extractStr, "@")
    getStr = ""
    If Index1 > 0 Then
        For p = Index1 - 1 To 1 Step -1
            If Mid(extractStr, p, 1) Like CheckStr Then
                getStr = Mid(extractStr, p, 1) & getStr
            Else
                Exit For
            End If
        Next
        getStr = getStr & "@"
        For p = Index1 + 1 To Len(extractStr)
            If Mid(extractStr, p, 1) Like CheckStr Then
                getStr = getStr & Mid(extractStr, p, 1)
            Else
                Exit For
            End If
        Next
        Index = Index1 + 1
        If OutStr = "" Then
            OutStr = getStr
        Else
            OutStr = OutStr & Chr(10) & getStr
        End If
    Else
        GoTo 20
    End If


'write to excel
20     xlobj.Range("a" & i + 1).Value = OutStr

Next
End Sub

Answer 1

标准方法是声明为 Object，而不是特定的数据类型，然后使用 Class 或 Typename 检查项目是否为该数据类型。

When is a MailItem not a MailItem?

Option Explicit
Sub Extract()

'Variable declaration
Dim myOlApp As Outlook.Application
Dim mynamespace As Outlook.NameSpace
Dim myfolder As Selection
'Dim myitem As MailItem
Dim myitem As Object

Dim extractStr As String

'Set reference to the Selection.
Set myOlApp = Outlook.Application
Set mynamespace = myOlApp.GetNamespace("mapi")
Set myfolder = ActiveExplorer.Selection

'for loop passing email body to search code

For Each myitem In myfolder

    if myitem.class = olmail then
        myitem.BodyFormat = olFormatPlain
        extractStr = myitem.Body
        MsgBox extractStr
    else
        extractStr = myitem.Body
        Msgbox "Not a mailitem " & extractStr
    end if

Next

End Sub

ReportItem 对象类似于 MailItem 对象，它包含一个报告（通常是未送达报告）。

注意 Reportitem 没有 BodyFormat 属性。

Answer 2

我有两个问题需要解决。首先是选择要为其提取电子邮件的正确文件夹。因为我在默认文件夹中使用子文件夹，所以我需要单独声明每个子文件夹，类似于在 Linux 系统中的文件夹之间移动。

'Set reference to the Selection.
Set myOlApp = Outlook.Application
Set mynamespace = myOlApp.GetNamespace("mapi")
Set myfolder = mynamespace.GetDefaultFolder(olFolderInbox)
Set myfolder = myfolder.Folders.Item("2/19 Training Email Blast")
Set myfolder = myfolder.Folders.Item("bad emails")

第二个问题是将我的电子邮件正文传递给字符串变量。当我这样做时，正文将被转换为我无法识别的内容。我使用 StrConv 函数将其转换回 unicode。

extractStr = StrConv(myitem.Body, vbUnicode)

我要做的最后一件事就是把它清理一下。感谢@niton，我将能够解析实际是报告的电子邮件和邮件项目的电子邮件，以便以不同的方式处理它们。

感谢所有评论并提供答案的人！

这是整个代码的副本：

Option Explicit
Sub Extract()
On Error Resume Next

'Variable declaration
Dim myOlApp As Outlook.Application
Dim mynamespace As Outlook.NameSpace
Dim myfolder As Object
Dim myitem As Object
Dim i As Integer
Dim extractStr As String
Dim CheckStr As String
Dim OutStr As String
Dim Index As Integer
Dim Index1 As Integer
Dim getStr As String
Dim p As Integer
Dim xlobj As Object

'start excel and open spreadsheet
Set xlobj = CreateObject("excel.application")
xlobj.Visible = True
xlobj.Workbooks.Add

'Set Heading on spreadsheet
xlobj.Range("a" & 1).Value = "Email"

'Set reference to the Selection.
Set myOlApp = Outlook.Application
Set mynamespace = myOlApp.GetNamespace("mapi")
Set myfolder = mynamespace.GetDefaultFolder(olFolderInbox)
Set myfolder = myfolder.Folders.Item("2/19 Training Email Blast")
Set myfolder = myfolder.Folders.Item("bad emails")

'for loop passing email body to search code
For i = 1 To myfolder.Items.Count
    Set myitem = myfolder.Items(i)
    extractStr = StrConv(myitem.Body, vbUnicode)
    myitem.Body = extractStr

'search for specific text
    CheckStr = "[A-Za-z0-9._-]"
    OutStr = ""
    Index = 1
    Index1 = InStr(Index, extractStr, "@")

    getStr = ""
    If Index1 > 0 Then
        For p = Index1 - 1 To 1 Step -1
            If Mid(extractStr, p, 1) Like CheckStr Then
                getStr = Mid(extractStr, p, 1) & getStr
            Else
                Exit For
            End If
        Next
        getStr = getStr & "@"
        For p = Index1 + 1 To Len(extractStr)
            If Mid(extractStr, p, 1) Like CheckStr Then
                getStr = getStr & Mid(extractStr, p, 1)
            Else
                Exit For
            End If
        Next
        Index = Index1 + 1
        If OutStr = "" Then
            OutStr = getStr
        Else
            OutStr = OutStr & Chr(10) & getStr
        End If
    Else
        GoTo 20
    End If


'write to excel
20     xlobj.Range("a" & i + 1).Value = OutStr

Next
End Sub