Скачать встроенный PDF-файл в Excel

Question

Вопрос : Как загрузить файл PDF, встроенный в Excel?

Этот вопрос задавался много раз, но я нигде не видел ни одного рабочего ответа.

Итак, вот попытка самостоятельно ответить на вопрос.Этот код работает и не зависит от ненадежного метода .Verb Verb:=xlPrimary.

Answer 1

Примечание: это будет работать только для PDF-файлов.Если есть смесь встроенных файлов, то это не будет работать.

Основные приготовления:

1. Допустим, наш файл Excel C:\Users\routs\Desktop\Sample.xlsx имеет2 PDF-файла, встроенные, как показано ниже.

   

2. В целях тестирования мы создадим временную папку на нашем рабочем столе C:\Users\routs\Desktop\Temp.

Логика:

1. Файл Excel по сути представляет собой просто ZIP-файл

2. Excel сохраняетoleObjects в папке \xl\embeddings\.Если вы переименуете файл Excel в zip и откроете его, скажем, в Winzip, вы увидите следующее

   

3. Если вы извлечетефайлы bin и переименуйте его в pdf, тогда вы сможете открыть pdf в Microsoft Edge, но не в любом другом приложении для просмотра PDF.Чтобы сделать его совместимым с любым другим средством просмотра PDF, нам нужно будет выполнить чтение и редактирование Binary.

4. Если вы откроете файл bin в любом Hex Editor, вы увидите нижеприведенное.Я использовал онлайн-редактор шестнадцатеричных https://hexed.it/

   

   Мы должны удалить все перед словом %PDF

   Мы попробуеми найдите 8-битные значения без знака %PDF ... или, более конкретно, %, P, D и F

   Если вы прокрутите вниз в шестнадцатеричном редакторе, вы увидитеполучить эти четыре значения

   значение %

   значение P

   Значение D

   Значение F

   Теперь все, что нам нужно сделать, это прочитать двоичный файл и удалить все до %PDF и сохранить файл с расширением .Pdf.

Код:

Option Explicit

Const TmpPath As String = "C:\Users\routs\Desktop\Temp"
Const ExcelFile As String = "C:\Users\routs\Desktop\Sample.xlsx"
Const ZipName As String = "C:\Users\routs\Desktop\Sample.zip"

Sub ExtractPDF()
    Dim tmpPdf As String
    Dim oApp As Object
    Dim i As Long

    '~~> Deleting any previously created files. This is
    '~~> usually helpful from 2nd run onwards
    On Error Resume Next
    Kill ZipName
    Kill TmpPath & "\*.*"
    On Error GoTo 0

    '~~> Copy and rename the Excel file as zip file
    FileCopy ExcelFile, ZipName

    Set oApp = CreateObject("Shell.Application")

    '~~> Extract the bin file from xl\embeddings\
    For i = 1 To oApp.Namespace(ZipName).items.Count
        oApp.Namespace(TmpPath).CopyHere oApp.Namespace(ZipName).items.Item("xl\embeddings\oleObject" & i & ".bin")

        tmpPdf = TmpPath & "\oleObject" & i & ".bin"

        '~~> Read and Edit the Bin File
        If Dir(tmpPdf) <> "" Then ReadAndWriteExtractedBinFile tmpPdf
    Next i

    MsgBox "Done"
End Sub

'~~> Read and ReWrite Bin File
Sub ReadAndWriteExtractedBinFile(s As String)
    Dim intFileNum As Long, bytTemp As Byte
    Dim MyAr() As Long, NewAr() As Long
    Dim fileName As String
    Dim i As Long, j As Long, k As Long

    j = 1

    intFileNum = FreeFile

    '~~> Open the bing file
    Open s For Binary Access Read As intFileNum
    '~~> Get the number of lines in the bin file
    Do While Not EOF(intFileNum)
        Get intFileNum, , bytTemp
        j = j + 1
    Loop

    '~~> Create an array to store the filtered results of the bin file
    '~~> We will use this to recreate the bin file
    ReDim MyAr(1 To j)
    j = 1

    '~~> Go to first record
    If EOF(intFileNum) Then Seek intFileNum, 1

    '~~> Store the contents of bin file in an array
    Do While Not EOF(intFileNum)
        Get intFileNum, , bytTemp
        MyAr(j) = bytTemp
        j = j + 1
    Loop
    Close intFileNum

    '~~> Check for the #PDF and Filter out rest of the data
    For i = LBound(MyAr) To UBound(MyAr)
        If i = UBound(MyAr) - 4 Then Exit For
        If Val(MyAr(i)) = 37 And Val(MyAr(i + 1)) = 80 And _
        Val(MyAr(i + 2)) = 68 And Val(MyAr(i + 3)) = 70 Then
            ReDim NewAr(1 To j - i + 2)

            k = 1
            For j = i To UBound(MyAr)
                NewAr(k) = MyAr(j)
                k = k + 1
            Next j

            Exit For
        End If
    Next i

    intFileNum = FreeFile

    '~~> Decide on the new name of the pdf file
    '~~> Format(Now, "ddmmyyhhmmss")  This method will awlays ensure that
    '~~> you will get a unique filename
    fileName = TmpPath & "\" & Format(Now, "ddmmyyhhmmss") & ".pdf"

    '~~> Write the new binary file
    Open fileName For Binary Lock Read Write As #intFileNum
    For i = LBound(NewAr) To UBound(NewAr)
        Put #intFileNum, , CByte(NewAr(i))
    Next i

    Close #intFileNum
End Sub

Выход