>source

Outlook 이메일을 Excel 스프레드 시트로 구문 분석하고 다른 소스의 다음 코드를 모 으려고합니다.

내 문제는 다음과 같습니다. 1- 모든 "vText"가 하나의 단일 열 (정확히 B)에 출력되고 B부터 E까지 출력되지 않습니다. ==>해결됨

2- 아래에 원래 이메일 텍스트를 붙여 넣었습니다.

Caller: First Last
Phone: 123-456-7890
For: Company Name - Address
City: Metropolis
MSGID: 3068749608

발신자, 전화 및 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
    
    
    

관련 자료

  • 이전 html - column-count 및 column-rule을 사용하는 동안 열 채우기
  • 다음 swift - SwiftUI는 프레임 및 항목으로 사용자 정의 메뉴를 만듭니다