Keskustelu: Koodit: Kuvadatan haku pdf tiedostosta ja tallennus

REM  *****  BASIC  *****

Option VBASupport 1

Sub GetImageFromPdf

    Dim fileStr() As String, i As Long, srcPath As String, pos As Integer
    pos = InStrRev(ConvertFromUrl(Replace(thisComponent.URL, "file///", "")), "\")
    srcPath = Left(ConvertFromUrl(Replace(thisComponent.URL, "file///", "")), pos) & "ImgTest.pdf"
    Open srcPath For Binary As #1
    Redim fileStr(LOF(1))
    Get #1, , fileStr : CLose #1
    Dim spos As Long, epos As Long, sFile As String, dlmext() As String

    For i = Lbound(fileStr) To Ubound(fileStr)
        sFile = sFile & fileStr(i)
    Next i

    dlmext = GetDelimAndExt(sFile)

    If dlmext(0) = "" Then
        MsgBox "No matching image data available", "48", "System"
        Exit Sub
    End If

    spos = InStr(sFile, dlmext(0)) - 1
    sFile = Replace(sFile, Left(sFile, spos), "")

    Select Case dlmext(0)
        Case "<svg"
            epos =  InStr(sFile, "</svg") - 1
        Case Else
            epos = InStr(sFile, "endstream") - 1
    End Select

    sFile = Left(sFile, epos)

    Dim destPath As String
    destPath = Environ("userprofile") & "\Desktop\test" & dlmext(1)
    If Dir(destPath) <> "" Then Kill destPath
    Open destPath For Binary As #1
    Put #1, , sFile : Close #1

End Sub

Function GetDelimAndExt(sData As String) As Variant

    Dim dlmext(1) As String

    If InStr(sData, "ÿØÿà") > 0 Then
    	dlmext(0) = "ÿØÿà"
    	dlmext(1) = ".jpg"
    	GetDelimAndExt = dlmext
        Exit Function
    End If

    If  InStr(sData, "ÿØÿÛ") > 0 Then
        dlmext(0) = "ÿØÿÛ"
    	dlmext(1) = ".jpg"
    	GetDelimAndExt = dlmext
        Exit Function
    End If

    ' PNG
    If InStr(sData, "‰PNG") > 0 Then
        dlmext(0) = "‰PNG"
    	dlmext(1) = ".png"
    	GetDelimAndExt = dlmext
        Exit Function
    End If

    ' GIF
    If InStr(sData, "GIF8") > 0 Then
        dlmext(0) = "GIF8"
    	dlmext(1) = ".gif"
    	GetDelimAndExt = dlmext
        Exit Function
    End If

    ' BMP
    If InStr(sData, "BM") > 0 Then
        dlmext(0) = "BM"
    	dlmext(1) = ".bmp"
    	GetDelimAndExt = dlmext
        Exit Function
    End If

    ' TIFF
    If InStr(sData, "II*") > 0 Then
        dlmext(0) = "II*"
    	dlmext(1) = ".tiff"
    	GetDelimAndExt = dlmext
        Exit Function
    End If

    If InStr(sData, "MM") > 0 Then
        dlmext(0) = "MM"
    	dlmext(1) = ".tiff"
    	GetDelimAndExt = dlmext
        Exit Function
    End If

    ' SVG (tekstimuotoinen)
    If InStr(LCase(sData), "<svg") > 0 Then
    	dlmext(0) = "<svg"
    	dlmext(1) = ".svg"
    	GetDelimAndExt = dlmext
        Exit Function
    End If

    GetDelimAndExt = dlmext

End Function