我是VBA代码的初学者,也是使用Outlook的最初阶段。我有大量的数据添加到Excel中。搜索Google后,我发现我们可以通过Outlook VBA来实现。内容来自于以下格式:从电子邮件正文提取URL
标题:本科生
性别:男
国家:阿尔巴尼亚
关键字:
1.Environment
- 人口
名字:约翰
电话号码:0532432444
文件上传: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”。
感谢Keenlearner, 它的工作原理正确
工作。 :) –