VBA对话框自动回答解决方案

Question

我为Outlook 2011编译并编写了一个宏。这个宏可以将所有邮件保存为word文件。

问题是我无法自动关闭对话框，我有这么多签名的消息我无法解决这个问题。

这是消息对话框：

代码：

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 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

       

    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