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