我是VBA代码的初学者，也是使用Outlook的最开始。我有大量的数据要添加到Excel。搜索谷歌后，我发现我们可以通过Outlook VBA实现这一目标。内容采用以下格式：
标题：本科生
性别：男性
国家：阿尔巴尼亚
关键字：
1.Environment
名字：约翰
电话号码：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
有效。但上传字段显示＆＃34; http＆＃34;不是＆＃34; http://all-free-download.com/free-photos/download/autumns-evening-sun_513398.html＆＃34;。
答案 0 :(得分：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)
答案 1 :(得分：0)
我尝试了你的代码。当工作表为空时找到下一个可用单元格存在问题（公式 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
答案 2 :(得分：-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