bugfix> excel > 投稿

Outlookの電子メールをExcelスプレッドシートに解析しようとしていますが、他のソースからの次のコードをまとめました。

私の問題は次のとおりです。 1-すべての「vText」は1つの列(正確にはB)に出力されており、BからEまでは出力されていません。 ==>解決済み

2-元のメールテキストを以下に貼り付けています。

Caller: First Last
Phone: 123-456-7890
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

回答 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
    
    
    

あなたの答え