Excel VBA结合用户表单复选框实现选中工作表导出PDF并发送到Outlook

实现逻辑说明 #

• 从UserForm2的复选框（编号100~113）中提取所有勾选的工作表名称，替换原代码中硬编码的工作表数组
• 完整保留原有PDF导出、重名自动加数字后缀、工作表存在校验、Outlook邮件生成的成熟逻辑
• 新增未勾选任何工作表的前置校验，避免程序空跑
• 保留选中工作表的确认提示，方便用户操作校验

完整整合代码 #

直接替换原有CommandButton100_Click的代码即可，不需要额外修改表单配置：

Private Sub CommandButton100_Click()
    Dim xSht As Worksheet
    Dim xFileDlg As FileDialog
    Dim xFolder As String
    Dim xYesorNo, I, xNum As Integer
    Dim xOutlookObj As Object
    Dim xEmailObj As Object
    Dim xUsedRng As Range
    Dim xArrShetts As Variant
    Dim xStr As String
    Dim i As Integer, cnt As Integer, a As Integer, k As Integer, b As String
    
    ' 第一步：收集选中的工作表名称
    cnt = 0
    a = 0
    ReDim xArrShetts(0 To 13) ' 适配100~113共14个复选框的最大数量
    For i = 100 To 113
        If UserForm2.Controls("CheckBox" & i).Value = True Then
            xArrShetts(cnt) = UserForm2.Controls("CheckBox" & i).Caption
            cnt = cnt + 1
            a = a + 1
        End If
    Next i
    
    ' 空选校验
    If a = 0 Then
        MsgBox "请至少选择一个工作表后再操作", vbInformation
        Exit Sub
    End If
    ReDim Preserve xArrShetts(0 To cnt - 1) ' 裁剪数组到实际选中数量
    
    ' 原有选中项提示逻辑
    k = 1
    For i = 100 To 113
        If UserForm2.Controls("CheckBox" & i).Value = True And a = 1 Then
            b = UserForm2.Controls("CheckBox" & i).Caption & "."
        ElseIf UserForm2.Controls("CheckBox" & i).Value = True And k <> a Then
            b = b & UserForm2.Controls("CheckBox" & i).Caption & ", "
            k = k + 1
        ElseIf UserForm2.Controls("CheckBox" & i).Value = True And k = a Then
            b = b & "and " & UserForm2.Controls("CheckBox" & i).Caption & "."
        End If
    Next i
    MsgBox ("You have selected " & b)
    
    ' 第二步：校验选中工作表是否存在
    For I = 0 To UBound(xArrShetts)
        On Error Resume Next
        Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
        If xSht.Name <> xArrShetts(I) Then
            MsgBox "未找到对应工作表，操作终止：" & vbCrLf & vbCrLf & xArrShetts(I), vbInformation
            Exit Sub
        End If
    Next

    ' 第三步：选择PDF保存路径
    Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    If xFileDlg.Show = True Then
        xFolder = xFileDlg.SelectedItems(1)
    Else
        MsgBox "你必须指定一个PDF保存文件夹。" & vbCrLf & vbCrLf & "点击OK退出程序。", vbCritical, "未指定保存路径"
        Exit Sub
    End If
    
    ' 重名文件提示
    xYesorNo = MsgBox("如果目标文件夹存在同名文件，将自动为文件名添加数字后缀区分重复文件" & vbCrLf & vbCrLf & "点击Yes继续，点击No取消", _
    vbYesNo + vbQuestion, "文件重名提示")
    If xYesorNo <> vbYes Then Exit Sub
    
    ' 第四步：批量导出PDF
    For I = 0 To UBound(xArrShetts)
        Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
        xStr = xFolder & "\" & xSht.Name & ".pdf"
        xNum = 1
        While Not (Dir(xStr, vbDirectory) = vbNullString)
            xStr = xFolder & "\" & xSht.Name & "_" & xNum & ".pdf"
            xNum = xNum + 1
        Wend
        Set xUsedRng = xSht.UsedRange
        If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
            xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xStr, Quality:=xlQualityStandard
        End If
        xArrShetts(I) = xStr
    Next

    ' 第五步：生成Outlook邮件并添加附件
    Set xOutlookObj = CreateObject("Outlook.Application")
    Set xEmailObj = xOutlookObj.CreateItem(0)
    With xEmailObj
        .Display
        .To = ""
        .CC = ""
        .Subject = "请替换为实际邮件主题"
        For I = 0 To UBound(xArrShetts)
            .Attachments.Add xArrShetts(I)
        Next
        ' 不需要手动显示邮件的话，取消下面.Send的注释即可自动发送
        '.Send
    End With
End Sub

代码调整说明 #

• 如果你复选框的Caption不是直接对应工作表名称，可以自行修改xArrShetts(cnt) = UserForm2.Controls("CheckBox" & i).Caption这一行的赋值逻辑，改为实际的工作表名称映射规则
• 代码保留了原有两段代码的所有功能，逻辑分层清晰，后续调整对应模块即可
• 默认保留了选中工作表的提示弹窗，不需要的话可以删除对应代码段

内容的提问来源于stack exchange，提问作者Thom Haasert