VBA MACRO - 엑셀로 전자 메일 주소 내보내기

Question

여기에 선택한 하위 폴더의 전자 메일 주소를 Excel 파일로 내보내는 VBA 코드가 있습니다. 내 문제는 그것이 내 폴더 중 하나에서만 작동한다는 것입니다.

다른 폴더에이 매크로를 사용하려고하면 "런타임 오류 13 TYPE MISMATCH"오류가 발생합니다. 왜이 오류가 발생하는지 알 수는 없습니다. 누군가가 문제가 어디에서 왔는지 감지 할 수 있기를 바랍니다.

여기 내 코드입니다 :

Sub ExportToExcel() 


Dim appExcel As Excel.Application 
Dim wkb As Excel.Workbook 
Dim wks As Excel.Worksheet 
Dim rng As Excel.Range 
Dim strSheet As String 
Dim strPath As String 
Dim intRowCounter As Integer 
Dim intColumnCounter As Integer 
Dim msg As Outlook.MailItem 
Dim nms As Outlook.NameSpace 
Dim fld As Outlook.MAPIFolder 
Dim itm As Object 
strSheet = "OutlookItems.xlsx" 
strPath = "C:\Users\Gabriel.Alejandro\Desktop\" 
strSheet = strPath & strSheet 


Debug.Print strSheet 
    'Select export folder 
Set nms = Application.GetNamespace("MAPI") 
Set fld = nms.PickFolder 
    'Handle potential errors with Select Folder dialog box. 


    'Open and activate Excel workbook. 
Set appExcel = CreateObject("Excel.Application") 
appExcel.Workbooks.Open (strSheet) 


Set wkb = appExcel.ActiveWorkbook 
Set wks = wkb.Sheets(1) 
wks.Activate 


appExcel.Application.Visible = True 

    'Copy field items in mail folder. 
For Each itm In fld.Items 
intColumnCounter = 1 

Set msg = itm 'The part where I am getting the ERROR 

intRowCounter = intRowCounter + 1 
Set rng = wks.Cells(intRowCounter, intColumnCounter) 
rng.Value = msg.To 
intColumnCounter = intColumnCounter + 1 
Set rng = wks.Cells(intRowCounter, intColumnCounter) 
rng.Value = msg.SenderEmailAddress 


Next itm 

Set appExcel = Nothing 
Set wkb = Nothing 
Set wks = Nothing 
Set rng = Nothing 
Set msg = Nothing 
Set nms = Nothing 
Set fld = Nothing 
Set itm = Nothing 

Exit Sub 

Set appExcel = Nothing 
Set wkb = Nothing 
Set wks = Nothing 
Set rng = Nothing 
Set msg = Nothing 
Set nms = Nothing 
Set fld = Nothing 
Set itm = Nothing 


End Sub 

Answer 1

당신은 ITM이는 MailItem있는 모든 가정합니다. 그것은는 MailItem가 아닌 경우

당신은 항목을 건너 뛸 수 :

For Each itm In fld.items 

    intColumnCounter = 1 

    If itm.Class = olMail Then 

     Set msg = itm 

     intRowCounter = intRowCounter + 1 
     Set rng = wks.Cells(intRowCounter, intColumnCounter) 
     rng.Value = msg.To 

     intColumnCounter = intColumnCounter + 1 
     Set rng = wks.Cells(intRowCounter, intColumnCounter) 
     rng.Value = msg.senderemailaddress 

    Else 

     Debug.Print " Item is not a mailitem." 

    End If 

Next itm 

당신이 수 대신에 바이 패스 오류 항목이 원하는 속성이없는 경우.

For Each itm In fld.items 

    intColumnCounter = 1 

    intRowCounter = intRowCounter + 1 
    Set rng = wks.Cells(intRowCounter, intColumnCounter) 
    On Error Resume Next 
    rng.Value = itm.To 
    On Error GoTo 0 

    intColumnCounter = intColumnCounter + 1 
    Set rng = wks.Cells(intRowCounter, intColumnCounter) 
    On Error Resume Next 
    rng.Value = itm.senderemailaddress 
    On Error GoTo 0 

Next itm