VBA對話框自動回答解決方案

Question

我爲Outlook 2011編譯和編寫了一個宏。該宏用於將所有郵件保存爲Word文件。

問題是我無法自動關閉對話框，我有這麼多簽名的消息我無法解決這個問題。

這是消息的對話框：

和代碼：

Function StripIllegalChar(StrInput) 
    Dim RegX   As Object 

    Set RegX = CreateObject("vbscript.regexp") 

    RegX.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]" 
    RegX.IgnoreCase = True 
    RegX.Global = True 

    StripIllegalChar = RegX.Replace(StrInput, "") 

ExitFunction: 
    Set RegX = Nothing 

End Function 

Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, Fld As MAPIFolder) 
    Dim SubFolder  As MAPIFolder 

    Folders.Add Fld.FolderPath 
    EntryID.Add Fld.EntryID 
    StoreID.Add Fld.StoreID 
    For Each SubFolder In Fld.Folders 
     GetFolder Folders, EntryID, StoreID, SubFolder 
    Next SubFolder 

ExitSub: 

    Set SubFolder = Nothing 

End Sub 

：

Option Explicit 
     Dim StrSavePath  As String 

Sub SaveAllEmails_ProcessAllSubFolders() 

    Dim i    As Long 
    Dim j    As Long 
    Dim n    As Long 
    Dim strSubject  As String 
    Dim StrName   As String 
    Dim StrFile   As String 
    Dim StrReceived  As String 
    Dim StrFolder  As String 
    Dim StrSaveFolder As String 
    Dim StrFolderPath As String 
    Dim iNameSpace  As NameSpace 
    Dim myOlApp   As Outlook.Application 
    Dim SubFolder  As MAPIFolder 
    Dim mItem   As Object 
    Dim docItem   As Object 
    Dim FSO    As Object 
    Dim ChosenFolder As Object 
    Dim Folders   As New Collection 
    Dim EntryID   As New Collection 
    Dim StoreID   As New Collection 
    Dim checkIfDigitallySigned As Long 




    Set FSO = CreateObject("Scripting.FileSystemObject") 
    Set myOlApp = Outlook.Application 

    Dim OLIns As Outlook.Inspector 
    Set iNameSpace = myOlApp.GetNamespace("MAPI") 
    Set ChosenFolder = iNameSpace.PickFolder 


    Const olAlertsNone = 0 
    If ChosenFolder Is Nothing Then 
     GoTo ExitSub: 
    End If 

    Set docItem = Application.CreateItem(olMailItem) 
    docItem.BodyFormat = olFormatRichText 





    BrowseForFolder StrSavePath 

    Call GetFolder(Folders, EntryID, StoreID, ChosenFolder) 

    For i = 1 To Folders.Count 
     StrFolder = StripIllegalChar(Folders(i)) 
     n = InStr(3, StrFolder, "\") + 1 
     StrFolder = Mid(StrFolder, n, 256) 
     StrFolderPath = StrSavePath & "\" & StrFolder & "\" 
     StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\" 
     If Not FSO.FolderExists(StrFolderPath) Then 
      FSO.CreateFolder (StrFolderPath) 
     End If 

     Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i)) 
     On Error Resume Next 
     For j = 1 To SubFolder.Items.Count 
      Set mItem = SubFolder.Items(j) 
      StrReceived = Format(mItem.ReceivedTime, "YYYYMMDD-hhmm") 
      strSubject = mItem.Subject 
      StrName = StripIllegalChar(strSubject) 
      StrFile = StrSaveFolder & StrReceived & "_" & StrName & ".doc" 


      StrFile = Left(StrFile, 256) 
      mItem.SaveAs StrFile, olRTF 


     Next j 
     On Error GoTo 0 
    Next i 
ExitSub: 

End Sub 

由宏使用的一些實用功能

Function BrowseForFolder(StrSavePath As String, Optional OpenAt As String) As String 
     Dim objShell As Object 
     Dim objFolder ' As Folder 
    Dim enviro 
    enviro = CStr(Environ("USERPROFILE")) 
    Set objShell = CreateObject("Shell.Application") 
    Set objFolder = objShell.BrowseForFolder(0, "Please choose a folder", 0, enviro & "\Documents\") 
    StrSavePath = objFolder.self.Path 
     On Error Resume Next 
     On Error GoTo 0 

ExitFunction: 


    Set objShell = Nothing 

End Function 

Answer 1

無法關閉該提示。您可以嘗試使用Redemption來繞過提示。請注意，簽名/加密的郵件是分開處理的，因爲它們需要首先解密。

set rSession = CreateObject("Redemption.RDOSession") 
    rSession.MAPIOBJECT = myOlApp.Session.MAPIOBJECT 
    set rFolder = rSession.GetRDOFolderFromOutlookObject(SubFolder) 
    ser rItems = rFolder.Items 
    For j = 1 To rItems.Count 
     Set mItem = rItems(j) 
     if TypeName(mItem) = "RDOEncryptedMessage" Then 
     'process encrypted/signed messages separately 
     mItem = mItem.GetDecryptedMessage 
     Enf If 
     StrReceived = Format(mItem.ReceivedTime, "YYYYMMDD-hhmm") 
     strSubject = mItem.Subject 
     StrName = StripIllegalChar(strSubject) 
     StrFile = StrSaveFolder & StrReceived & "_" & StrName & ".doc" 

     StrFile = Left(StrFile, 256) 
     mItem.SaveAs StrFile, olRTF 
    Next j