如何通过Excel宏复制工作表嵌入文件并与生成的PDF同目录保存？

问题分析 #

原代码仅实现了PDF导出功能，未处理工作表中的嵌入文件提取与复制，且存在路径不一致问题（创建的目录是C:\test\Excel，但PDF保存到C:\Excel），同时未结合选择窗口的勾选状态动态调整PDF内容和需复制的嵌入文件。

实现步骤与代码 #

以下是修改后的完整代码，包含动态生成含选中内容的PDF、提取并复制嵌入文件、路径容错处理三个核心功能：

Sub Schaltfläche6_Klicken()
    Dim saveDir As String
    Dim pdfPath As String
    Dim selectedSheets() As Variant
    Dim obj As OLEObject
    Dim tempPath As String
    Dim i As Integer
    
    ' 显示选择窗口
    UserForm1.Show
    
    ' 统一目标目录，避免路径不一致
    saveDir = "C:\test\Excel\"
    ' 确保目录存在，不存在则创建
    If Dir(saveDir, vbDirectory) = "" Then
        MkDir saveDir
    End If
    
    ' PDF保存路径
    pdfPath = saveDir & "Dummy.pdf"
    
    ' --------------------------
    ' 步骤1：根据选择窗口的勾选状态，确定要导出的内容
    ' 示例：假设UserForm有CheckBox1、CheckBox2，对应不同工作表
    ' 请根据实际控件名称和逻辑调整
    ReDim selectedSheets(0 To 0)
    If UserForm1.CheckBox1.Value = True Then
        selectedSheets(UBound(selectedSheets)) = "Sheet1"
        ReDim Preserve selectedSheets(UBound(selectedSheets) + 1)
    End If
    If UserForm1.CheckBox2.Value = True Then
        selectedSheets(UBound(selectedSheets)) = "Dummy"
        ReDim Preserve selectedSheets(UBound(selectedSheets) + 1)
    End If
    ' 移除最后一个空元素
    If UBound(selectedSheets) > 0 Then
        ReDim Preserve selectedSheets(0 To UBound(selectedSheets) - 1)
    End If
    
    ' 导出选中内容为PDF
    If UBound(selectedSheets) >= 0 Then
        Worksheets(selectedSheets).ExportAsFixedFormat _
            Type:=xlTypePDF, _
            Filename:=pdfPath, _
            Quality:=xlQualityStandard
    Else
        ' 若未勾选任何选项，默认导出Dummy工作表
        Worksheets("Dummy").ExportAsFixedFormat _
            Type:=xlTypePDF, _
            Filename:=pdfPath, _
            Quality:=xlQualityStandard
    End If
    
    ' --------------------------
    ' 步骤2：提取并复制工作表中的嵌入文件到目标目录
    ' 遍历Dummy工作表中的所有OLE嵌入对象
    For Each obj In Worksheets("Dummy").OLEObjects
        ' 判断是否是嵌入的文件（如Word、Excel、PDF等）
        If obj.progID Like "*Document*" Or obj.progID Like "*Worksheet*" Or obj.progID Like "*AcroExch*" Then
            ' 生成临时路径保存嵌入文件
            tempPath = Environ("TEMP") & "\" & obj.Name & "." & Split(obj.progID, ".")(1)
            obj.Verb xlVerbOpen ' 打开嵌入对象
            ' 保存嵌入文件到临时路径
            Select Case obj.progID
                Case "Word.Document.8", "Word.Document.12"
                    obj.Object.SaveAs tempPath
                    obj.Object.Close
                Case "Excel.Sheet.8", "Excel.Sheet.12"
                    obj.Object.SaveAs tempPath
                    obj.Object.Close
                Case "AcroExch.Document"
                    obj.Object.Save tempPath
                    obj.Object.Close
                ' 可根据需要添加更多嵌入文件类型
            End Select
            ' 复制临时文件到目标目录
            FileCopy tempPath, saveDir & obj.Name & "." & Split(obj.progID, ".")(1)
            ' 删除临时文件
            Kill tempPath
        End If
    Next obj
    
    MsgBox "PDF生成与嵌入文件复制完成！", vbInformation
End Sub

关键说明 #

• 路径处理：统一使用C:\test\Excel\作为目标目录，添加目录存在性判断，避免MkDir执行报错。
• 动态PDF内容：根据UserForm复选框的勾选状态，动态收集要导出的工作表；若未勾选任何选项，默认导出原Dummy工作表。
• 嵌入文件提取：遍历工作表中的OLE对象，针对Word、Excel、PDF等常见嵌入文件进行提取，通过临时文件中转后复制到目标目录，可根据实际嵌入类型扩展Select Case分支。
• 注意事项：需确保Excel启用了对应嵌入文件类型的应用程序（如Word、Adobe Acrobat），否则无法正常保存嵌入文件。

内容的提问来源于stack exchange，提问作者Cooler Mann