从电子邮件正文中提取 URL

Question

我有数据要添加到 Excel。我发现我们可以通过 Outlook VBA 做到这一点。内容采用以下格式：

职称：本科生

性别：男

国家：阿尔巴尼亚

关键字：
1.环境
2. 人口

名字：约翰

电话号码：0532432444

用户名：test@dda.com

文件上传：http://all-free-download.com/free-photos/download/autumns-evening-sun_513398.html

---

我根据一篇旧文章创建了这段代码：

Sub CopyToExcel()
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object

    Dim olItem As Outlook.MailItem
    Dim vText As Variant
    Dim sText As String
    Dim vItem As Variant

    Dim i As Long
    Dim rCount As Long
    Dim bXStarted As Boolean

    Const strPath As String = "E:\Project\Test oulook.xlsx"   ' the path of the workbook

    If Application.ActiveExplorer.Selection.Count = 0 Then
        MsgBox "No Items selected!", vbCritical, "Error"
        Exit Sub
    End If

    On Error Resume Next

    Set xlApp = GetObject(, "Excel.Application")
    If Err <> 0 Then
        Application.StatusBar = "Please wait while Excel source is opened ... "
        Set xlApp = CreateObject("Excel.Application")
        bXStarted = True
    End If

    On Error GoTo 0

    ' Open the workbook to input the data
    Set xlWB = xlApp.Workbooks.Open(strPath)
    Set xlSheet = xlWB.Sheets("Sheet1")

    ' Process each selected record
    rCount = xlSheet.UsedRange.Rows.Count
    For Each olItem In Application.ActiveExplorer.Selection
        sText = olItem.Body
        vText = Split(sText, Chr(13))

        ' Find the next empty line of the worksheet
        rCount = rCount + 1

        ' Check each line of text in the message body
        For i = UBound(vText) To 0 Step -1

            If InStr(1, vText(i), "title: ") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("A" & rCount) = Trim(vItem(1))
            End If

            If InStr(1, vText(i), "gender: ") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("B" & rCount) = Trim(vItem(1))
            End If

            If InStr(1, vText(i), "country: ") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("C" & rCount) = Trim(vItem(1))
            End If

            If InStr(1, vText(i), "keyword: ") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("E" & rCount) = Trim(vItem(1))
            End If

            If InStr(1, vText(i), "first_name: ") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("G" & rCount) = Trim(vItem(1))
            End If

            If InStr(1, vText(i), "phone_number: ") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("I" & rCount) = Trim(vItem(1))
            End If

            If InStr(1, vText(i), "username: ") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("F" & rCount) = Trim(vItem(1))
            End If

            If InStr(1, vText(i), "upload: ") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("O" & rCount) = Trim(vItem(1))
            End If

        Next i
        xlWB.Save

    Next olItem
    xlWB.Close SaveChanges:=True
        
    If bXStarted Then
        xlApp.Quit
    End If

    Set olItem = Nothing
    Set xlSheet = Nothing
    Set xlWB = Nothing
    Set xlApp = Nothing
End Sub

上传字段显示“http”而不是“http://all-free-download.com/free-photos/download/autumns-evening-sun_513398.html”。

Answer 1

Chr(58) 是冒号

通过Split(vText(i), Chr(58))，您将获取原始字符串并用分隔符冒号拆分

例如：文件上传：http://all-free-download.com/free-photos/download/autumns-evening-sun_513398.html

vItem(0)= 文件上传

vItem(1)=http

vItem(2)= //all-free-download.com/free-photos/download/autumns-evening-sun_513398.html

因此，为了获得您想要的完整链接，您必须连接 vItem。

例如。 vItem(1) & ":" & vItem(2)

Answer 2

我试过你的代码。当工作表为空白时，查找下一个可用单元格存在问题（公式 xlSheet.UsedRange.Rows.Count 两者均返回 1，未使用任何行，仅使用一行）

这是一个似乎可以正常工作的重写

if-then 例程已被 case 语句替换

Sub CopyToExcel()
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object

    Dim olItem As Outlook.mailItem
    Dim vText As Variant
    Dim rCount As Long

    Dim vItem As Variant
    Dim i As Long
    Dim bXStarted As Boolean
    Const strPath As String = "E:\Project\Test outlook.xlsx"      ' the path of the workbook


    If Application.ActiveExplorer.Selection.Count = 0 Then
         MsgBox "No Items selected!", vbCritical, "Error"
         Exit Sub
    End If

    On Error Resume Next

    Set xlApp = GetObject(, "Excel.Application")

    If Err <> 0 Then
        Application.StatusBar = "Please wait while Excel source is opened ... "
        Set xlApp = CreateObject("Excel.Application")
        bXStarted = True
    End If

'   xlApp.Visible = True                                          ' show worksheet (for debugging)

    On Error GoTo 0

    Set xlWB = xlApp.Workbooks.Open(strPath)                      ' Open the workbook to input the data
    Set xlSheet = xlWB.Sheets("Sheet1")

'   rCount = xlSheet.UsedRange.Rows.Count                         ' does not work (returns 1 when no data on worksheet)

    Dim formula As String                                         '
    formula = "MATCH(TRUE, INDEX(ISBLANK(A:A), 0, 0), 0)"         ' cell formula: =MATCH(TRUE, INDEX(ISBLANK(A:A), 0, 0), 0)

    rCount = xlApp.Evaluate(formula)                              ' find next empty line on worksheet using a cell formula

    For Each olItem In Application.ActiveExplorer.Selection       ' Process each selected email

        vText = Split(olItem.body, vbCrLf)                        ' convert email body to an array of text lines
        For i = 0 To UBound(vText)                                ' Check each line of text in the message body

            vItem = Split(":" & vText(i), ":", 3)                 ' split line into max 3 parts (leading ":" added to prevent fail on blank lines)

            Select Case LCase(vItem(1))                           ' LCase for case insensitive comparison
                Case "title"
                    xlSheet.Range("A" & rCount) = Trim(vItem(2))
                Case "gender"
                    xlSheet.Range("B" & rCount) = Trim(vItem(2))
                Case "country"
                    xlSheet.Range("C" & rCount) = Trim(vItem(2))
                Case "keyword"
                    xlSheet.Range("E" & rCount) = Trim(vItem(2))
                Case "first name"
                    xlSheet.Range("G" & rCount) = Trim(vItem(2))
                Case "phone number"
                    xlSheet.Range("I" & rCount) = Trim(vItem(2))
                Case "username"
                    xlSheet.Range("F" & rCount) = Trim(vItem(2))
                Case "file upload"
                    xlSheet.Range("O" & rCount) = Trim(vItem(2))
'               Case Else
'                   do something else here
            End Select

        Next i
        xlWB.Save

        rCount = rCount + 1                                       ' point to next empty line of the worksheet

    Next olItem
    Set olItem = Nothing

    xlWB.Close SaveChanges:=True

    If bXStarted Then
        xlApp.Quit
    End If

    Set xlSheet = Nothing
    Set xlWB = Nothing
    Set xlApp = Nothing
End Sub

Answer 3

If InStr(1, vText(i), "upload: ") > 0 Then
    vItem = Split(vText(i), Chr(58), 2) '<< optional parameter controls how many splits...
    xlSheet.Range("O" & rCount) = Trim(vItem(1))
End If