问使用VBA将嵌入式文件保存到某个位置(从excel导出文件)

EN

   Public ExpArr()

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