Question

我是一个完整的编码新手，我正在努力将数据从电子邮件正文中提取到Excel 2010工作表中。

电子邮件的格式为;

表格回复

名字John

史密斯姓名

电子邮件john.smith@test.com.au

今天的代码字test1

我一直在尝试运行我在网上找到的各种VBA代码但是当它到达电子邮件正文时最终会出现Subscript超出范围错误;

Option Explicit

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 = "c:\test\test1.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
For Each olItem In Application.ActiveExplorer.Selection
sText = olItem.Body
vText = Split(sText, Chr(13))
'Find the next empty line of the worksheet
   rCount = xlSheet.UsedRange.Rows.Count

'Check each line of text in the message body
For i = UBound(vText) To 0 Step -1
  rCount = rCount + 1
  If InStr(1, vText(i), "First name ") > 0 Then
        vItem = Split(vText(i), Chr(58))
        xlSheet.Range("A" & rCount) = Trim(vItem(1))
    End If

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

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

    If InStr(1, vText(i), "Today's code word ") > 0 Then
        vItem = Split(vText(i), Chr(58))
        xlSheet.Range("D" & rCount) = Trim(vItem(1))
    End If


Next i
xlWB.Save
Next olItem
xlWB.Close SaveChanges:=True
If bXStarted Then
xlApp.Quit
End If
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set olItem = Nothing
End Sub

任何人都可以提供任何帮助吗？

感谢。

Answer 1

我认为问题是由使用拆分功能引起的。

试试这个：你还需要拳头

dim mystart as integer
dim myend as integer

并使用“vtext”删除所有内容并改变您的代码：

  If InStr(1, sText, "First name ") > 0 Then
        mystart = InStr(1, sText, "First name ") + 11
        myend =  InStr(mystart, sText, Chr(10)) - mystart - 1
        vItem = mid(sText, mystart, myend)
        xlSheet.Range("A" & rCount) = Trim(vItem)
    End If

希望这有帮助，最大

Answer 2

什么行代码抛出异常？您是否尝试调试代码？

我建议从Getting Started with VBA in Outlook 2010文章开始。另请注意，索引从1开始，而不是0。

需要从电子邮件正文中提取数据到Excel中

2 个答案: