VBA: 多份Excel文件的批量顺序打印（3）

Option Explicit

Option Base 1
' 消息框，无需手动点击关闭Declare PtrSafe Function MessageBoxTimeout Lib "user32" _    Alias "MessageBoxTimeoutA" (ByVal hwnd As Long, _                                ByVal lpText As String, _                                ByVal lpCaption As String, _                                ByVal wType As Long, _                                ByVal wlange As Long, _                                ByVal dwTimeout As Long) As Long
Sub PrintSelectedFiles()

    '按文件名称（数字大小）的顺序打印


    Dim fd As FileDialog
    Dim strFilePath As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim fileList() As Variant
    Dim i As Integer
    
    Application.ScreenUpdating = False
    
    '获取默认路径
    ChDrive ThisWorkbook.Worksheets("报告").Range("B3").Value2
    ChDir ThisWorkbook.Worksheets("报告").Range("B4").Value2

    ' 创建一个文件对话框对象
    Set fd = Application.FileDialog(msoFileDialogFilePicker)

    ' 设置文件对话框的属性
    With fd
    
        .AllowMultiSelect = True
        
        .Title = "请选择需要打印的Excel文件！"
        
        .Filters.Clear
        
        '.Filters.Add "Excel文件", "*.xls; *.xlsx"
        .Filters.Add "Excel文件", "*.xls"

        ' 显示文件对话框，如果用户点击了“确定”，则执行后续操作
        If .Show = -1 Then
        
            ' 将文件列表存储到数组中
            ReDim fileList(1 To .SelectedItems.Count)
            
            For i = 1 To .SelectedItems.Count
            
                fileList(i) = .SelectedItems(i)
                
            Next i

            ' 对文件列表进行排序
            Call QuickSort(fileList, LBound(fileList), UBound(fileList))
             
            ' 遍历排序后的文件列表
            
            For i = LBound(fileList) To UBound(fileList)
            
                ' 打开选定的文件
                strFilePath = fileList(i)
                
                Set wb = Workbooks.Open(strFilePath)

                ' 获取第一个工作表
                Set ws = wb.Worksheets(1)

                ' 打印当前工作表
                ws.PrintOut

                ' 关闭工作簿，不保存更改
                wb.Close SaveChanges:=False
                
            Next i
            
        Else
        
            Set fd = Nothing
        
            'MsgBox "没有选择任何文件！"
            MessageBoxTimeout 0, "没有选择任何文件！", "打印报告", 0, 0, 1000
            
            Application.ScreenUpdating = True
            
            Exit Sub
            
        End If
        
    End With
    
    'Set the object variable to Nothing.
    
    Set fd = Nothing
    
    'MsgBox "打印结束！"
    MessageBoxTimeout 0, "打印结束！", "打印报告", 0, 0, 2000
    
    Application.ScreenUpdating = True
    
    Exit Sub
    
End Sub

' 快速排序算法（用于对文件列表进行排序）
Sub QuickSort(arr As Variant, ByVal first As Long, ByVal last As Long)

    Dim pivot As Variant, temp As Variant
    
    Dim i As Long, j As Long

    If first < last Then
    
        'Initial
        pivot = arr(first)
        
        i = first
        
        j = last

        While i < j
        
            While Val(arr(j)) >= Val(pivot) And j > first
            
                j = j - 1
                
            Wend

            While Val(arr(i)) <= Val(pivot) And i < last
            
                i = i + 1
                
            Wend

            If i < j Then
            
                temp = arr(i)
                
                arr(i) = arr(j)
                
                arr(j) = temp
                
                j = j - 1
                
                i = i + 1
                
            End If
            
        Wend

        arr(first) = arr(j)
        
        arr(j) = pivot

        QuickSort arr, first, j - 1
        
        QuickSort arr, j + 1, last
        
    End If
    
End Sub