從電子郵件正文提取URL

我是VBA代碼的初學者，也是使用Outlook的最初階段。我有大量的數據添加到Excel中。搜索Google後，我發現我們可以通過Outlook VBA來實現。內容來自於以下格式：從電子郵件正文提取URL

標題：本科生

性別：男

國家：阿爾巴尼亞

關鍵字：

1.Environment

人口

名字：約翰

電話號碼：0532432444

用戶名：[email protected]

文件上傳：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」。

來源

2017-07-07 James Bond

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/aut umns-evening-sun_513398.html

所以爲了獲得你想要的完整鏈接，你必須連接vItem。

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

來源

2017-07-07 02:01:32 Keenlearner

感謝Keenlearner，它的工作原理正確

工作。 :) –

-1

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

來源

2017-07-07 02:04:22

謝謝蒂姆，Awsome代碼。 –

請將解釋添加到您的答案。回答沒有解釋是沒用的。 –

有關附加參數的評論涵蓋了它：OP自己編寫了其餘代碼，所以它們應該遵循正在發生的事情... –

我試過你的代碼。有一個與尋找下一個可用的電池，當工作表是空白的問題（公式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

來源

2017-07-09 05:07:40 jsotola

從電子郵件正文提取URL

回答

相關問題