VBA对话框自动回答解决方案 [英] VBA dialog boxes automatically answer solution

问题描述

我为Outlook 2011编译并编写了一个宏.为此，该宏将所有邮件另存为word文件.

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.

这是消息对话框:

和代码:

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

推荐答案

无法关闭该提示.您可以尝试使用兑换绕过提示.请注意，已签名/已加密的消息是分别处理的，因为它们需要先被解密.

There is no way to turn that prompt off. You can try to use Redemption 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

这篇关于VBA对话框自动回答解决方案的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！