excel - For循环在多列中输出

Question

我正在尝试将 Outlook 电子邮件解析为 Excel 电子表格。

所有“vText”都在 B 列而不是 B 到 E 列中输出。

原始电子邮件文本：

Caller: First Last
Phone: [phone]
For: Company Name - Address
City: Metropolis
MSGID: 3068749608

我很好地提取了 Caller、Phone 和 MSGID 字段，但解析公司名称并没有奏效。它会将电话或 MSGID 值随机粘贴到该列中。

Option Explicit
 Private Const xlUp As Long = -4162

Sub CopyAllMessagesToExcel()
 Dim objOL As Outlook.Application
 Dim objItems As Outlook.Items
 Dim objFolder As Outlook.MAPIFolder
 Dim olItem As Outlook.MailItem
 Dim xlApp As Object
 Dim xlWB As Object
 Dim xlSheet As Object
 Dim vText, vText2, vText3, vText4, vText5 As Variant
 Dim sText As String
 Dim rCount As Long
 Dim bXStarted As Boolean
 Dim enviro As String
 Dim strPath As String
 Dim Reg1 As Object
 Dim M1 As Object
 Dim M As Object
 Dim OutlookNamespace As NameSpace
              

enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
 strPath = enviro & "file path"
     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")

    'Find the next empty line of the worksheet
    'rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row 'original code
    rCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(xlUp).Row
     rCount = rCount + 1
     
    Set objOL = Outlook.Application
    Set OutlookNamespace = objOL.GetNamespace("MAPI")
    Set objFolder = OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders("SubFolder").Folders("SubSubFolder")
    Set objItems = objFolder.Items
 
    For Each olItem In objItems
 
      On Error Resume Next

     With olItem
     
     sText = olItem.Body

     Set Reg1 = CreateObject("VBScript.RegExp")
    ' \s* = invisible spaces
    ' \d* = match digits
    ' \w* = match alphanumeric
     
    
    Dim i As Integer
        
    For i = 1 To 4
    
    With Reg1
    '.IgnoreCase = True
    Select Case i   'each Case = one specific string parsed
    Case 1
    'pull everything after Caller (separated by :), and stop at line end \n
        .Pattern = "(Caller[:]([\w-\s]*)\s*)\n"
        
    Case 2
       .Pattern = "(Phone[:]([\d-\s]*)\s*)\n"
       
'#### CASE 3 NOT WORKING
    Case 3
    'pull everything after For (separated by :), and stop at the dash [-]
    .Pattern = "(For[:]([\w-\s]*)\s*)[-]"
     
    Case 4
    'pull everything after MSGID, and stop at the dash [-]
        .Pattern = "(MSGID[:]([\w-\s]*)\s*)[-]"
    End Select
    End With
    
    If Reg1.Test(sText) Then
    
' each "(\w*)" and the "(\s)" are assigned a vText variable
        Set M1 = Reg1.Execute(sText)
        For Each M In M1
           vText = Trim(M.SubMatches(1))
           vText2 = Trim(M.SubMatches(2))
           vText3 = Trim(M.SubMatches(3))
           vText4 = Trim(M.SubMatches(4))
        Next
  
  xlSheet.Range("a" & rCount) = .ReceivedTime
  xlSheet.Range("b" & rCount) = vText
  xlSheet.Range("c" & rCount) = vText2
  xlSheet.Range("d" & rCount) = vText3
  xlSheet.Range("e" & rCount) = vText4
  'xlSheet.Range("D" & rCount) = .Subject
  'xlSheet.Range("f" & rCount) = vText5

'##Checking on output per iteration:
'MsgBox ("inputting data in row #" & rCount)

' next line
 rCount = rCount + 1

    End If
    
Next i
    
      ' do whatever
       Debug.Print .Subject
     
    End With
    
    Next
     'xlWB.Close 1
     'If bXStarted Then
     '    xlApp.Quit
     'End If
     Set M = Nothing
     Set M1 = Nothing
     Set Reg1 = Nothing
     Set xlApp = Nothing
     Set xlWB = Nothing
     Set xlSheet = Nothing
     
    Set objItems = Nothing
    Set objFolder = Nothing
    Set objOL = Nothing

End Sub

标签： excelvbaoutlook

Answer 1

我会将正则表达式移动到一个单独的函数中：

Function ExtractText(txt As String, patt As String)
    Static reg As Object
    Dim matches, rv As String  'EDIT: moved from Static line
    If reg Is Nothing Then
        Set reg = CreateObject("VBScript.RegExp")
        'set up IgnoreCase etc here...
    End If
    reg.Pattern = patt
    If reg.Test(txt) Then
        Set matches = reg.Execute(txt)
        rv = matches(0).submatches(1)
    End If
    ExtractText = rv
End Function

然后你的主要代码的核心变成这样：

Set objOL = Outlook.Application
Set OutlookNamespace = objOL.GetNamespace("MAPI")
Set objFolder = OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders("SubFolder").Folders("SubSubFolder")
Set objItems = objFolder.Items
 
For Each olItem In objItems
    sText = olItem.Body
    xlSheet.Range("a" & rCount) = .ReceivedTime
    xlSheet.Range("b" & rCount) = ExtractText(sText, "(Caller[:]([\w-\s]*)\s*)\n")
    xlSheet.Range("c" & rCount) = ExtractText(sText, "(Phone[:]([\d-\s]*)\s*)\n")
    xlSheet.Range("d" & rCount) = ExtractText(sText, "(For[:]([\w-\s]*)\s*)[-]")
    xlSheet.Range("e" & rCount) = ExtractText(sText, "(MSGID:\s?(\d{1,})-)")'<<edit
    'xlSheet.Range("D" & rCount) = .Subject
    'xlSheet.Range("f" & rCount) = vText5
    'MsgBox ("inputting data in row #" & rCount)
    rCount = rCount + 1
Next olItem