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变量声明为对象和mailitem。当我使用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?

TextView

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

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

2 个答案: