我在我们的网站上有一个表格，它会生成一封如下所示的电子邮件：
First Name: test
Last Name: test
Address1: test
Address2:
City: test
State: CA
Zip Code: 90032
Email: test@yahoo.com
Telephone:
Date of Birth: -Month- -Day- -Year-
Marital Status:
Purchase Month: April
Purchase Day: -Day-
Purchase Year: 2004
Purchase Place: test
Purchase Place Other:
Product type: test
Other Product Type:
Product size: test
Other Product Size:
Product color: test
Did you buy this for yourself or received as a gift? self
Which of the following product types do you own or intend to own?
• Skillets & Grills
• Specialty
• Stockpots
• Cast Iron Ovens & Braisers
• Kettles
• Bakeware
• Kitchen Tools
• Wine Tools
Is this your first product? no
What do you like to cook?
• Slow Cooking
• Kid Friendly Meals
• Quick and Easy
Would you like to receive email updates and special offers? yes
comments:
我正在尝试将电子邮件内容放入 excel 中，以便每一行都是一个列标题，并且用户提交的信息将进入标题下的行。有时一个字段可能会留空（并非所有字段都是必需的）。我找到了这篇文章并更新了表单字段以匹配我自己的表单和电子表格的路径。当我运行它时，电子表格会打开，但我收到“运行时错误 9，下标超出范围消息。如果我单击“调试”>“切换断点”，它会突出显示第一行。
这是我正在使用的脚本。任何人都可以审查并帮助完成这项工作吗？我以前从未使用过宏或 VBA，所以这对我来说都是陌生的。我在网上搜索过这个错误，但我发现的所有内容都非常具体，对我没有帮助。 这里、这里和这里是我看过的几个例子。
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:\Users\llantz\Desktop\prod-reg.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
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), "First Name:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("B" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Last Name:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("C" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Address1:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("D" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Address2:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("E" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "City:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("F" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "State:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("G" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Zip Code:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("H" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Email:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("I" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Telephone:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("J" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Date of Birth:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("K" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Marital Status:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("L" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Purchase Month:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("M" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Purchase Day:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("N" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Purchase Year:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("O" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Purchase Place:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("P" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Purchase Place Other:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("P" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Product type:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("P" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Other Product Type:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("P" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Product size:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("P" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Other Product Size:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("P" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Product color:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("P" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Did you buy this for yourself or received as a gift?") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("P" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Which of the following product types do you own or intend to own?") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("Q" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Is this your first Le Creuset product?") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("Q" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "What do you like to cook?") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("Q" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Would you like to receive email updates and special offers from Le Creuset?") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("Q" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "comments:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("Q" & 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