Ошибка несоответствия типа vba при попытке запуска макроса

Question

Я сталкиваюсь с всплывающей ошибкой «Тип несоответствия» при попытке запуска кода ниже.

Мой код используется для сохранения входящих писем от разных получателей в виде файлов .txt в определенном месте.

Компьютер был перезапущен, и до перезапуска я мог выполнить без проблем.

В чем может быть проблема?

Sub SaveEmail(msg As Outlook.MailItem) 
    ' save as text 
    If InStr(msg.Subject, "OBW cell status") > 0 Then 
    msg.SaveAs "C:\Users\emirmot\Desktop\Tag Tool\obw\email" & Format(msg.CreationTime, "YYYYMMDDHHMMSS") & ".txt", olTXT 
    End If 

    If InStr(msg.Subject, "Yoigo Cells Down Report") > 0 Then 
    msg.SaveAs "C:\Users\emirmot\Desktop\Tag Tool\yoigo\email" & Format(msg.CreationTime, "YYYYMMDDHHMMSS") & ".txt", olTXT 
    End If 

    If InStr(msg.Subject, "KPN 3G") > 0 Then 
    msg.SaveAs "C:\Users\emirmot\Desktop\Tag Tool\kpn\3gemail" & Format(msg.CreationTime, "YYYYMMDDHHMMSS") & ".txt", olTXT 
    End If 

    If InStr(msg.Subject, "KPN 2G") > 0 Then 
    msg.SaveAs "C:\Users\emirmot\Desktop\Tag Tool\kpn\2gemail" & Format(msg.CreationTime, "YYYYMMDDHHMMSS") & ".txt", olTXT 
    End If 

    If InStr(msg.Subject, "KPN 4G") > 0 Then 
    msg.SaveAs "C:\Users\emirmot\Desktop\Tag Tool\kpn\4gemail" & Format(msg.CreationTime, "YYYYMMDDHHMMSS") & ".txt", olTXT 
    End If 

    If InStr(msg.Sender, "GAUSS.ADMIN@dcn.h3g.it") > 0 Then 
    msg.SaveAs "C:\Users\emirmot\Desktop\Tag Tool\h3g\gauss\" & Replace(msg.Subject, ":", "") & ".txt", olTXT 
    End If 

    Dim objAtt As Outlook.Attachment 
    Dim saveFolder As String 
    saveFolder = "C:\Users\emirmot\Desktop\Tag Tool\h3g\" 

    Dim saveFoldersiu As String 
    saveFoldersiu = "C:\Users\emirmot\Desktop\Tag Tool\yoigo\siu\" 

    Dim saveFoldernodata As String 
    saveFoldernodata = "C:\Users\emirmot\Desktop\Tag Tool\yoigo\" 

    Dim saveFoldermobistar As String 
    saveFoldermobistar = "C:\Users\emirmot\Desktop\Tag Tool\mobistar\" 

    Dim saveFolderip_sa_tools As String 
    saveFolderip_sa_tools = "C:\Users\emirmot\Desktop\Tag Tool\yoigo\ip_sa_tools\" 

    Dim saveFolder_yoigoreport As String 
    saveFolder_yoigoreport = "C:\wamp\www\cell_avail_report\uploads\" 

    Dim saveFolder_h3gtn As String 
    saveFolder_h3gtn = "C:\Users\emirmot\Desktop\Tag Tool\h3g\tn_temp\" 

    If InStr(msg.Subject, "H3G IT") > 0 Then 
    For Each objAtt In msg.Attachments 
      objAtt.SaveAsFile saveFolder & "\" & Format(msg.ReceivedTime, "YYYYMMDDHHMMSS") & objAtt.DisplayName 
      Set objAtt = Nothing 
    Next 
    End If 

    If InStr(msg.Subject, "All RNC Hourly Iublink State") > 0 Then 
    For Each objAtt In msg.Attachments 
      objAtt.SaveAsFile saveFoldernodata & "\" & Format(msg.ReceivedTime, "YYYYMMDDHHMMSS") & objAtt.DisplayName 
      Set objAtt = Nothing 
    Next 
    End If 

    If InStr(msg.Subject, "SIU") > 0 Then 
    For Each objAtt In msg.Attachments 
      objAtt.SaveAsFile saveFoldersiu & "\" & objAtt.DisplayName 
      Set objAtt = Nothing 
    Next 
    End If 

    If InStr(msg.Subject, "CELLS STATUS") > 0 Then 
    For Each objAtt In msg.Attachments 
      objAtt.SaveAsFile saveFoldermobistar & "\" & Format(msg.ReceivedTime, "YYYYMMDDHHMMSS") & objAtt.DisplayName 
      Set objAtt = Nothing 
    Next 
    End If 

    If InStr(msg.Subject, "OneFM Alarms - Generic message") > 0 Then 
    For Each objAtt In msg.Attachments 
      objAtt.SaveAsFile saveFolderip_sa_tools & "\" & Format(msg.ReceivedTime, "YYYYMMDDHHMMSS") & objAtt.DisplayName 
      Set objAtt = Nothing 
    Next 
    End If 

    If InStr(msg.Sender, "bis4g@report.com") > 0 Then 
    For Each objAtt In msg.Attachments 
      objAtt.SaveAsFile saveFolder_yoigoreport & "\" & objAtt.DisplayName 
      Set objAtt = Nothing 
    Next 
    End If 

    If InStr(msg.Sender, "eradior@miuo1adm2.dns.miuoss") > 0 Then 
    For Each objAtt In msg.Attachments 
      objAtt.SaveAsFile saveFolder_h3gtn & "\" & objAtt.DisplayName 
      Set objAtt = Nothing 
    Next 
    End If 

End Sub 

Sub TestSaveEmail() 
    Call SaveEmail(ActiveExplorer.Application) 
End Sub 

Answer 1

Это может быть проблема. Вы передаете объект приложения в подсистему SaveEmail, когда он ожидает объект MailItem. Попробуйте передать сообщение процедуре SaveEmail вместо ActiveExplorer.Application.

Sub SaveEmail(msg As Outlook.MailItem) 

Call SaveEmail(ActiveExplorer.Application) 

Answer 2

J Гарт правильно идентифицирует первую ошибку, которая будет произойти, если вы попытаетесь запустить TestSaveEmail но не предлагает коррекцию. Вы пытались использовать Explorer? Если это так, попробуйте это:

Sub TestSaveEmail() 
    Dim Exp As Outlook.Explorer 
    Dim ItemCrnt As MailItem 

    If Exp.Selection.Count = 0 Then 
    Debug.Print "No emails selected" 
    Else 
    For Each ItemCrnt In Exp.Selection 
     Call SaveEmail(ItemCrnt) 
    Next 
    End If 
End Sub 

Если ваш код встречает другую ошибку, вам нужно прочитать комментарий R3uK и скажите нам, какая линия дает ошибку.

Обновлено от моего комментария

Вы должны проверить, что выбран по крайней мере один элемент сообщения, но, если вы действительно хотите только сохранить один адрес электронной почты, выполните следующие действия:

Sub TestSaveEmail() 
    Dim Exp As Outlook.Explorer 

    If Exp.Selection.Count = 0 Then 
    Debug.Print "No emails selected" 
    Else 
    Call SaveEmail(Exp.Selection(1)) 
    Next 
    End If 
End Sub