VBA dialog boxes automatically answer solution - vba

Question

I compiled and coded a macro for Outlook 2011. This macro for that it saves all the mails as word file.
The problem is that I couldn't close the dialog box automatically, I have so much signed message I couldn't solve this problem.
This is the message dialog:
And the code:
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
Some utility functions used by the macro:
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

There is no way to turn that prompt off. You can try to use Redemption (I am its author) to bypass the prompts. Note that signed/encrypted messages are processed separately since they need to be decrypted first.
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