vba - 在继续之前等待发送到打印机（shellexecute）

问题描述

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

这有效，但顺序不正确。电子邮件和打印的附件会混淆。所以我想同步打印。该过程必须等到打印作业发送完毕。问题可能是该ShellExecute命令与 VBA 异步工作。

那么我怎样才能让 VBA 等到ShellExecute完成。我在 MSDN 上读过我必须使用CreateProcess但我不知道如何在此使用打印命令。它只运行一个应用程序。

我还尝试使用 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

标签： vbapowershelloutlook

vba - 在继续之前等待发送到打印机（shellexecute）

问题描述

解决方案

推荐阅读