我有一个小宏，它会打开一个表单，您可以在其中输入详细信息， 当您单击按钮时，您将创建一个包含所有条目的列表，并保存嵌入到另一个工作表中的选定 pdf 文件。 当您不将代码嵌入为符号时，该代码将起作用。它基本上用 pdf 创建一个“屏幕截图”。但我只是想将嵌入的对象保存在固定路径中 `
Sub Schaltfläche6_Klicken()
Dim saveLocation As String
Dim sFolderPath As String
UserForm1.Show
sFolderPath = "C:\test\Excel"
saveLocation = "C:\test\Excel\Dummy.pdf"
If Dir(sFolderPath) <> "" Then
MkDir "C:\test\Excel"
End If
Worksheets("Dummy").ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=saveLocation
End Sub
`
希望您能找到解决问题的方法
我尝试在互联网上找到一些解决方案，但并没有真正帮助。对于我真正想要的东西来说，它看起来有点太复杂了
请使用下一个场景。这不可能是一个简单的问题，正如我在上面的评论中尝试建议的那样：
嵌入 pdf 文件，但使用“替代文本”放置 pdf 文件名。如果您以这种方式嵌入文件，可以通过右键单击 OLE 对象 -
Format Object...Alt Text从中提取嵌入 pdf 文件 (WBPdf) 的工作簿必须关闭。
由于如上所述，WBPdf 应关闭，因此必须将下一个代码复制到
xlsmxml\xl\worksheetsbin\xl\embeddingsxmlbina.在标准模块顶部创建一个
Public Public ExpArr()
它将保留
binb.将以下代码复制到标准模块中：
Sub ExtractEmbeddedPDFs() 'it does NOT work if the workbook to be processed is Open!
Dim pdfFolder As String, embWB As String, zipName As String, oShell As Object, arrO, i As Long
pdfFolder = ThisWorkbook.Path & "\Extracted PDF"
embWB = ThisWorkbook.Path & "\Embedded pdf.xlsx"
zipName = left(embWB, InStrRev(embWB, ".")) & "zip"
If Dir(pdfFolder, vbDirectory) = "" Then 'if the folder where to save pdf files does not exist
MkDir pdfFolder 'it is created
End If
'Deleting any previously created files, if any:
On Error Resume Next
Kill zipName
Kill pdfFolder & "\*.*"
Kill pdfFolder & "\_rels\*.*"
RmDir pdfFolder & "\_rels\"
On Error GoTo 0
'Copy/rename the Excel file changing extension to zip:
On Error Resume Next
FileCopy embWB, zipName
If err.Number = 70 Then 'error in case of workbook being open:
err.Clear: On Error GoTo 0
MsgBox "Please, close the workbook where from the embedded pdf files should be extracted." & vbCrLf & _
"A zipped copy cannot be created...", vbInformation, "Need to close the workbook": Exit Sub
End If
On Error GoTo 0
Dim flsWsh As Object, fileNameInZip As Variant
Set oShell = CreateObject("Shell.Application")
Set flsWsh = oShell.NameSpace(oShell.NameSpace((zipName)).Items.Item(("xl\worksheets")))
For Each fileNameInZip In oShell.NameSpace(flsWsh).Items
oShell.NameSpace((pdfFolder)).CopyHere _
oShell.NameSpace(flsWsh).Items.Item(CStr(fileNameInZip))
Next
getOLEObjSheetsREL pdfFolder 'build the array which matches any .bin oleObject with the extracted pdf name
For i = 0 To UBound(ExpArr)
arrO = Split(ExpArr(i), "|") 'split the matching array elements by "|" to extract bin name in relation with pdf name
oShell.NameSpace((pdfFolder)).CopyHere oShell.NameSpace((zipName)).Items.Item("xl\embeddings\" & arrO(0))
ReadAndWriteExtractedBinFile pdfFolder & "\" & arrO(0), pdfFolder, CStr(arrO(1))
Next i
On Error Resume Next
Kill zipName
Kill pdfFolder & "\*.bin"
Kill pdfFolder & "\*.xml"
Kill pdfFolder & "\_rels\*.*"
RmDir pdfFolder & "\_rels\"
On Error GoTo 0
MsgBox "Ready..."
Shell "explorer.exe" & " " & pdfFolder, vbNormalFocus 'open the folder keeping extracted files
End Sub
'Eliminate specific characters from binary file to make it pdf compatible:
'see here a good process explanation:
'https://stackoverflow.com/questions/52778729/download-embedded-pdf-file
Sub ReadAndWriteExtractedBinFile(s As String, TmpPath, Optional pdfName As String = "")
Dim byteFile As Long, byt As Byte, fileName As String
Dim MyAr() As Byte, NewAr() As Byte, i As Long, j As Long, k As Long
byteFile = FreeFile: j = 1
Open s For Binary Access Read As byteFile 'Open the bin file
Do While Not EOF(byteFile) 'loop untill the last line (count the file bytes)
Get byteFile, , byt: j = j + 1
Loop
'create the (correct) pdf byte file, removing some bytes (characters) from the bin byte one:___
ReDim MyAr(1 To j - 1) 'initially reDim it to have the same dimension as byteFile
j = 1
If EOF(byteFile) Then Seek byteFile, 1 'set first byte position for the next iteration
Do While Not EOF(byteFile) 'place the content of bin byteFile in MyAr:
Get byteFile, , byt
MyAr(j) = byt: j = j + 1
Loop
Close byteFile
'build the correct byte array without bytes existing up to %PDF:
For i = LBound(MyAr) To UBound(MyAr)
If i = UBound(MyAr) - 4 Then Exit For 'eliminate the not necessary last 4 bytes
If val(MyAr(i)) = 37 And val(MyAr(i + 1)) = 80 And _
val(MyAr(i + 2)) = 68 And val(MyAr(i + 3)) = 70 Then 'when find %PDF
ReDim NewAr(1 To j - i + 1) 'reDim the array to eliminate everything before it
k = 1
For j = i To UBound(MyAr)
NewAr(k) = MyAr(j): k = k + 1
Next j
Exit For 'exits the loop (after finding %PDF bytes)
End If
Next i
byteFile = FreeFile
'Set the pdf to be saved name:
If pdfName = "" Then 'if no pdfName parameter, it builds a unique name:
fileName = TmpPath & "\" & Format(Now, "ddmmyyhhmmss") & ".pdf"
Else
fileName = TmpPath & "\" & pdfName 'this solution uses only the extracted (from OLEObject) name
End If
'Write the new (pdf) binary file:
If isArrLoaded(NewAr()) Then 'only for PDF (bin) embedded files:
Open fileName For Binary Lock Read Write As #byteFile
For i = LBound(NewAr) To UBound(NewAr)
Put #byteFile, , CByte(NewAr(i))
Next i
Close #byteFile
Else
'If by mistake a not appropriate bin file has been choosen:
Debug.Print "The object is not of pdf type..." 'theoretically, this line should never be reached
End If
End Sub
Private Sub getOLEObjSheetsREL(strPath As String)
Dim patt As String: patt = "oleObject\d{1,3}.bin"
Dim strFold As String, strFile As String, strText As String
Dim fso As Object, ts As Object, arrOLE, arrOLEC(1), arrTot, i As Long
strFold = strPath & "\_rels\" 'copied folder (from archive) keeping sheets keeping OLEObjects
ReDim arrTot(0)
strFile = Dir(strFold & "*.rels")
Do While strFile <> "" 'iterate between all existing files
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.getFile(strFold & strFile).OpenAsTextStream(1, -2)
strText = ts.ReadAll 'read their content
ts.Close
arrOLE = getOLEObj(strText, patt) 'extract an array linking OLEObject to pdf file name
If arrOLE(0) <> "" Then
arrOLEC(0) = left(strFile, Len(strFile) - 5): arrOLEC(1) = arrOLE
BubbleSort arrOLEC(1) 'sort the array
arrTot(i) = arrOLEC: i = i + 1: ReDim Preserve arrTot(i)
End If
strFile = Dir()
Loop
ReDim Preserve arrTot(i - 1)
getOLEObjects arrTot, strPath 'returning an array linking the bin object to pdf to be saved file name
End Sub
Private Sub BubbleSort(arr)
Dim i As Long, j As Long, temp
For i = LBound(arr) To UBound(arr) - 1
For j = i + 1 To UBound(arr)
If arr(i) > arr(j) Then
temp = arr(i): arr(i) = arr(j)
arr(j) = temp
End If
Next j
Next i
End Sub
Private Sub getOLEObjects(arrOLE As Variant, strPath As String)
Dim strFile As String, strText As String
Dim fso As Object, ts As Object, j As Long
Dim arr, frstTxt As String, El, i As Long, strName As String, PrID As String
Dim k As Long: ReDim ExpArr(100)
Const strObj As String = "oleObject"
For j = 0 To UBound(arrOLE)
strFile = strPath & "\" & arrOLE(j)(0)
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.getFile(strFile).OpenAsTextStream(1, -2)
strText = ts.ReadAll
ts.Close
arr = extractBetweenChars(strText, "<oleObject progId=", "<\/mc:Fallback>")
For Each El In arr
strName = "": PrID = ""
strName = extractBetweenChars(CStr(El), "altText=""", """ r:id")(0)
PrID = extractBetweenChars(CStr(El), """", """")(0)
If PrID = "Acrobat Document" Or PrID = "Packager Shell Object" Then i = i + 1
If strName <> "" Then
If InStr(strName, ".pdf") > 0 Then
ExpArr(k) = strObj & i & ".bin" & "|" & strName: k = k + 1
End If
End If
Next
Next j
'keep only the elements keeping values:
If k > 0 Then
ReDim Preserve ExpArr(k - 1)
Else
Erase ExpArr
End If
End Sub
保留嵌入 pdf 文件的工作簿，还可以包含嵌入的 csv、xls、txt、jpg 文件。该代码能够区分它们并仅用于提取适当的
bin请在测试后发送一些反馈。
我发现它很有用，但代码没有这个函数“getOLEObj(strText, patt)”