이메일 주소에 대한 이메일 본문을 구문 분석하고 Excel에 쓰는 VBA 기능

Outlook (2010) 폴더의 모든 전자 메일을 반복하고 전자 메일 본문에서 전자 메일 주소를 가져 오는 기능이 필요하다는 요구 사항이 있습니다. 이메일은Inbox \ Online Applicants \ TEST CB FOLDER

본문에는 하나의 이메일 주소 만 있습니다. 이 전자 메일 email_output.xls은 바탕 화면에 있는 Excel 파일로 작성해야합니다 .

에서 이 포럼 스레드 나는 발견하고 약간 나는 (단지 VBA의 피상적 지식을 가지고) 할 수 최고로 내 요구에 맞게 최종 매크로를 변경 한 :

Option Explicit 
Sub badAddress() 
    Dim olApp As Outlook.Application 
    Dim olNS As Outlook.NameSpace 
    Dim olFolder As Outlook.MAPIFolder 
    Dim Item As Object 
    Dim regEx As Object 
    Dim olMatches As Object 
    Dim strBody As String 
    Dim bcount As String 
    Dim badAddresses As Variant 
    Dim i As Long 
    Dim xlApp As Object 'Excel.Application
    Dim xlwkbk As Object 'Excel.Workbook
    Dim xlwksht As Object 'Excel.Worksheet
    Dim xlRng As Object 'Excel.Range
    Set olApp = Outlook.Application 
    Set olNS = olApp.GetNamespace("MAPI") 
    Set olFolder = olNS.GetDefaultFolder(olFolderInbox).Folders("Online Applicants").Folders("TEST CB FOLDER")
    Set regEx = CreateObject("VBScript.RegExp") 
     'define regular expression
    regEx.Pattern = "\b[A-Z0-9._%-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b" 
    regEx.IgnoreCase = True 
    regEx.Multiline = True 
     ' set up size of variant
    bcount = olFolder.Items.Count 
    ReDim badAddresses(1 To bcount) As String 
     ' initialize variant position counter
    i = 0
    ' parse each message in the folder holding the bounced emails
    For Each Item In olFolder.Items 
        i = i + 1 
        strBody = olFolder.Items(i).Body 
        Set olMatches = regEx.Execute(strBody) 
        If olMatches.Count >= 1 Then 
            badAddresses(i) = olMatches(0) 
            Item.UnRead = False 
        End If 
    Next Item
     ' write everything to Excel
    Set xlApp = GetExcelApp 
    If xlApp Is Nothing Then GoTo ExitProc 
    If Not IsFileOpen(Environ("USERPROFILE") & "\Desktop\email_output.xls") Then 
    Set xlwkbk = xlApp.workbooks.Open(Environ("USERPROFILE") & "\Desktop\email_output.xls") 
    End If      
    Set xlwksht = xlwkbk.Sheets(1) 
    Set xlRng = xlwksht.Range("A1") 
    xlApp.ScreenUpdating = False 
    xlRng.Value = "Bounced email addresses" 
    ' resize version
    xlRng.Offset(1, 0).Resize(UBound(badAddresses) + 1).Value = xlApp.Transpose(badAddresses) 
    xlApp.Visible = True 
    xlApp.ScreenUpdating = True 
ExitProc: 
    Set xlRng = Nothing 
    Set xlwksht = Nothing 
    Set xlwkbk = Nothing 
    Set xlApp = Nothing 
    Set olFolder = Nothing 
    Set olNS = Nothing 
    Set olApp = Nothing 
    Set badAddresses = Nothing 
End Sub 
Function GetExcelApp() As Object 
     ' always create new instance
    On Error Resume Next 
    Set GetExcelApp = CreateObject("Excel.Application") 
    On Error GoTo 0 
End Function 
Function IsFileOpen(FileName As String) 
    Dim iFilenum As Long 
    Dim iErr As Long      
    On Error Resume Next 
    iFilenum = FreeFile() 
    Open FileName For Input Lock Read As #iFilenum 
    Close iFilenum 
    iErr = Err 
    On Error GoTo 0      
    Select Case iErr 
    Case 0: IsFileOpen = False 
    Case 70: IsFileOpen = True 
    Case Else: Error iErr 
    End Select      
End Function 

내가 관리 할 수있는 몇 가지 다른 오류를 처리 한 후 (46 행) 오류 object variable or with block variable not set가 발생합니다 Set xlwksht = xlwkbk.Sheets(1). 변수가 올바르게 할당 된 것으로 보이며 스프레드 시트는 데스크탑에 올바르게 이름이 지정되어 있습니다.

xlwkbk설정이 보장되지는 않습니다 : File is Not (Not Open) 인 경우에만 개체를 ​​설정합니다. "else 절"이 필요합니다.

FileIsOpen()테스트 를 무시하는 대신 결과를 직접 사용하십시오. 같은 :

If FileIsOpen() then
   'Do stuff for when file is open, such as test for the proper worksheet being active
   set worksheet to active sheet
else
   'Open the worksheet like you have in example
   set worksheet by opening worksheet
endif