Vba 等待发送到打印机（shellexecute），然后继续

我想打印Outlook文件夹的所有电子邮件和附件。我想打印excel、word和pfd文件

这是可行的，但顺序不对。打印附件的电子邮件会混淆。所以我想同步打印。进程必须等待打印作业发送完毕。问题可能是

ShellExecute

命令从VBA异步工作

那么，如何让VBA等待

ShellExecute

完成呢。我在MSDN上读到，我必须使用

CreateProcess

，但我不知道如何在这上面使用print命令。它只运行一个应用程序

我还尝试在VBA中使用Sleep方法来给打印一些时间，但它似乎不是正确的解决方案，也不是很好的工作方式。请问有人有什么建议吗

Private Declare Function ShellExecute Lib "shell32.dll" Alias _
      "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
      ByVal lpFile As String, ByVal lpParameters As String, _
      ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

      Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As LongPtr)



    Sub SaveBijlageArgumenten()

    SaveEmailAttachmentsToFolder "Postvak IN", "Account...", "xlsx", "xls", "pdf", "doc", "docx", "C:\....."

    End Sub



    Sub SaveEmailAttachmentsToFolder(OutlookInbox As String, OutlookAccount As String, _
                                    ExtString As String, ExtString2 As String, ExtString6 As String, ExtString3 As String, ExtString4 As String, _
                                    ExtString5 As String, DestFolder As String)

    Dim ns As NameSpace
    Dim Inbox As MAPIFolder
    Dim SubFolder As MAPIFolder
    Dim Item As Object
    Dim Atmt As Attachment
    Dim FileName As String
    Dim MyDocPath As String
    Dim I As Integer
    Dim wsh As Object
    Dim fs As Object
    Dim xlApp As Object
    Dim myBook As Object



    ' Create Excel Application
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = False 'Visible is False by default, so this isn't necessary

    On Error GoTo ThisMacro_err

    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.Folders(OutlookAccount)
    Set SubFolder = Inbox.Folders(OutlookInbox)



    I = 0

    ' Check subfolder for messages and exit of none found
    If SubFolder.Items.Count = 0 Then
        MsgBox "There are no messages in this folder : " &    OutlookFolderInInbox, _
               vbInformation, "Nothing Found"
        Set SubFolder = Nothing
        Set Inbox = Nothing
        Set ns = Nothing
        Exit Sub
    End If

    'Create DestFolder if DestFolder = ""
    Set fs = CreateObject("Scripting.FileSystemObject")
    If DestFolder = "" Then
        Set wsh = CreateObject("WScript.Shell")
        Set fs = CreateObject("Scripting.FileSystemObject")
        MyDocPath = wsh.SpecialFolders.Item("mydocuments")
        DestFolder = MyDocPath & "\" & Format(Now, "dd-mmm-yyyy hh-mm-ss")
        If Not fs.FolderExists(DestFolder) Then
            fs.CreateFolder DestFolder
        End If
    Else
        DestFolder = DestFolder & "\" & Format(Now, "dd-mmm-yyyy hh-mm-ss")
        If Not fs.FolderExists(DestFolder) Then
            fs.CreateFolder DestFolder
        End If
    End If

    If Right(DestFolder, 1) <> "\" Then
        DestFolder = DestFolder & "\"
    End If

    'On Error Resume Next
    ' Check each message for attachments and extensions

    For Each Item In SubFolder.Items
        Item.PrintOut Background:=False
        Item.UnRead = False

        Sleep 500

        For Each Atmt In Item.Attachments
            If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Or _
        LCase(Right(Atmt.FileName, Len(ExtString2))) = LCase(ExtString2) Then
                FileName = DestFolder & Item.SenderName & " " & Atmt.FileName
                Atmt.SaveAsFile FileName

                Set myBook = xlApp.Workbooks.Open(FileName, UpdateLinks:=0)

                myBook.PrintOut Background:=False
                myBook.Close SaveChanges:=False

                I = I + 1

            ElseIf LCase(Right(Atmt.FileName, Len(ExtString3))) = LCase(ExtString3) Or LCase(Right(Atmt.FileName, Len(ExtString4))) = LCase(ExtString4) _
                    Or LCase(Right(Atmt.FileName, Len(ExtString5))) = LCase(ExtString5) Then

                FileName = DestFolder & Item.SenderName & " " & Atmt.FileName
                Atmt.SaveAsFile FileName

                ShellExecute 0, "print", FileName, vbNullString, vbNullString, 0

                Sleep 3000

                I = I + 1

            End If



        Next Atmt

    Next Item

    On Error GoTo ThisMacro_err


    ' Show this message when Finished
    If I > 0 Then
        MsgBox "De bestanden in de bijlage zijn opgeslagen op onderstaande locatie: " _
             & DestFolder, vbInformation, "Klaar!"
    Else
        MsgBox "Er bevonden zich geen bijlagen bij de emails", vbInformation, "Klaar!"
    End If

    ' Clear memory
    ThisMacro_exit:
    Set SubFolder = Nothing
    Set Inbox = Nothing
    Set ns = Nothing
    Set fs = Nothing
    Set wsh = Nothing
    Set xlApp = Nothing
    Set myBook = Nothing
    Set AcroExchApp = Nothing
    Set AcroExchAVDoc = Nothing
    Exit Sub

    ' Error information
      ThisMacro_err:
    MsgBox "An unexpected error has occurred." _
         & vbCrLf & "Please note and report the following information." _
         & vbCrLf & "Macro Name: SaveEmailAttachmentsToFolder" _
         & vbCrLf & "Error Number: " & Err.Number _
         & vbCrLf & "Error Description: " & Err.Description _
         , vbCritical, "Error!"
    Resume ThisMacro_exit

End Sub

Private声明函数ShellExecute Lib“shell32.dll”别名_
“ShellExecuteA”（ByVal hwnd为长，ByVal lpOperation为字符串_
ByVal lpFile作为字符串，ByVal lpParameters作为字符串_
ByVal lpDirectory为字符串，ByVal nShowCmd为长）为长
公共声明PtrSafe子睡眠库“kernel32”（ByVal毫秒为LongPtr）
子存储bijlageargumenten（）
SaveEmailAttachmentsToFolder“Postvak IN”、“Account…”、“xlsx”、“xls”、“pdf”、“doc”、“docx”、“C:\…”
端接头
子SaveEmailAttachmentsToFolder（OutlookInbox为字符串，OutlookAccount为字符串_
ExtString作为字符串，ExtString2作为字符串，ExtString6作为字符串，ExtString3作为字符串，ExtString4作为字符串_
ExtString5作为字符串，DestFolder作为字符串）
Dim ns作为名称空间
将收件箱设置为MAPI文件夹
将子文件夹变暗为MAPIFolder
将项目变暗为对象
作为附件的Dim Atmt
将文件名设置为字符串
将MyDocPath设置为字符串
作为整数的Dim I
将wsh设置为对象
作为对象的Dim fs
将xlApp作为对象
将我的书作为对象
'创建Excel应用程序
设置xlApp=CreateObject（“Excel.Application”）
xlApp.Visible=False“Visible在默认情况下为False，因此不需要这样做
错误时转到此宏\u错误
设置ns=GetNamespace（“MAPI”）
设置收件箱=ns.文件夹（OutlookAccount）
设置子文件夹=收件箱。文件夹（OutlookInbox）
I=0
'检查子文件夹中是否有消息，并退出“未找到”
如果子文件夹.Items.Count=0，则
MsgBox“此文件夹中没有邮件：”&OutlookFolderInBox_
VBA信息，“未找到任何内容”
设置子文件夹=无
设置收件箱=无
设置ns=无
出口接头
如果结束
'如果DestFolder=“”则创建DestFolder“”
设置fs=CreateObject（“Scripting.FileSystemObject”）
如果DestFolder=“”，则
设置wsh=CreateObject（“WScript.Shell”）
设置fs=CreateObject（“Scripting.FileSystemObject”）
MyDocPath=wsh.SpecialFolders.Item（“mydocuments”）
DestFolder=MyDocPath&“\”格式（现在为“dd-mmm-yyy-hh-mm-ss”）
如果不是fs.FolderExists（DestFolder），则
fs.CreateFolder DestFolder
如果结束
其他的
DestFolder=DestFolder&“\”格式（现在为“dd-mmm-yyy-hh-mm-ss”）
如果不是fs.FolderExists（DestFolder），则
fs.CreateFolder DestFolder
如果结束
如果结束
如果正确（DestFolder，1）“\”则
DestFolder=DestFolder&“\”
如果结束
'出现错误时，请继续下一步
'检查每封邮件的附件和扩展名
对于子文件夹中的每个项。项
Item.PrintOut后台：=False
Item.UnRead=False
睡500
对于项目附件中的每个Atmt
如果LCase（Right（Atmt.FileName，Len（ExtString））=LCase（ExtString）或_
LCase（右（Atmt.FileName，Len（ExtString2））=LCase（ExtString2）然后
FileName=DestFolder&Item.SenderName&“”&Atmt.FileName
Atmt.SaveAsFile文件名
设置myBook=xlApp.Workbooks.Open（文件名，UpdateLinks:=0）
myBook.PrintOut背景：=False
myBook.Close SaveChanges:=False
I=I+1
ElseIf LCase（右（Atmt.FileName，Len（ExtString3））=LCase（ExtString3）或LCase（右（Atmt.FileName，Len（ExtString4））=LCase（ExtString4）_
或LCase（右（Atmt.FileName，Len（ExtString5））=LCase（ExtString5），然后
FileName=DestFolder&Item.SenderName&“”&Atmt.FileName
Atmt.SaveAsFile文件名
ShellExecute 0，“打印”，文件名，vbNullString，vbNullString，0
睡3000
I=I+1
如果结束
下一个Atmt
下一项
错误时转到此宏\u错误
'完成后显示此消息
如果I>0，那么
MsgBox“bijlage zijn opgeslagen op-onderstaande地点的bestanden：_
&DestFolder，vbInformation，“Klaar！”
其他的
MsgBox“Er bevonden zich geen bijlagen bij de emails”，vbInformation，“Klaar！”
如果结束
“清除内存
此宏_退出：
设置子文件夹=无
设置收件箱=无
设置ns=无
设置fs=Nothing
设置wsh=Nothing
设置xlApp=Nothing
设置myBook=Nothing
设置AcroExchap=Nothing
设置AcroExchAVDoc=Nothing
出口接头
'错误信息
此宏错误：
MsgBox“发生意外错误。”_
&vbCrLf&“请注意并报告以下信息。”_
&vbCrLf&“宏名称：SaveEmailAttachmentsToFolder”_
&vbCrLf&“错误编号：”&错误编号_
&vbCrLf&“错误描述：”&错误描述_
，vbCritical，“错误！”
继续此宏。\u退出
端接头

对象提供的方法具有

bWaitOnReturn

可选参数。它指示脚本是否应等待程序完成执行，然后再继续执行脚本中的下一条语句。如果设置为true，则为scrip