Keskustelu: Koodit: LibreOffice upotettu kuva .pdf tiedostosta

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

Sub OpenPDF

    Dim oDoc As Object

    oDoc = thisComponent

    Dim filepicker As Object, localFile As String, sFileArray As Variant
    filepicker = createUnoService("com.sun.star.ui.dialogs.FilePicker")

    filepicker.setDisplayDirectory(Left(thisComponent.URL, InStrReverse(thisComponent.URL, "/") - 1))
    filepicker.appendFilter("Portable Document Format", "*.pdf")
    filepicker.setMultiSelectionMode(False)

    If filepicker.Execute() Then
        sFileArray = filepicker.getFiles()
        localFile = sFileArray(0)
    End If

    filepicker = Nothing

    If localFile = "" Then
         MsgBox "Operation aborted by user", "48", "Open" : Exit Sub
    End If

    Dim sfa As Object, sResult As String
    Dim inpStream As Object, inBytes() As Byte, i As Integer
    sfa = CreateUnoService("com.sun.star.ucb.SimpleFileAccess")
    inpStream = CreateUnoService("com.sun.star.io.DataInputStream")
    inpStream = sfa.OpenFileRead(localFile)
    inpStream.readSomeBytes(inBytes, 1000)
    inpStream.CloseInput()
    inpStream = Nothing
    sResult = DumpBytes(inBytes, Ubound(inBytes))
    Erase inBytes

    Dim ext_mtype() As String

    ext_mtype = Split(DetectImageType(sResult), "|")

jmp:
    sResult = ""

    If ext_mtype(1) = "application/octet-stream" Then
        MsgBox "No supported image found", "48", "System"
        Exit Sub
    End If

    Dim args(0) As New com.sun.star.beans.PropertyValue
    args(0).Name = "Hidden"
    args(0).Value =True

    Dim pdfDoc As Object
    pdfDoc = StarDesktop.loadComponentFromURL(localFile, "_blank", 0, args())
    Dim oPages As Object, oPage As Object, oShape As Object

    oPages = pdfDoc.getDrawPages()

    If oPages.getCount() - 1 > 0 Then
        MsgBox "Cannot handle multipage .pdf data", "48", "Sytem"
        oPages = Nothing : pdfDoc.setModified(False)
        args = Nothing : pdfDoc.dispose() : Exit Sub
    End If

    Dim j As Integer, oGraphic As Object

    For i = 0 To oPages.getCount() - 1

        oPage = oPages.getByIndex(i)

        For j = 0 To oPage.getCount() - 1

            oShape = oPage.getByIndex(j)

            If oShape.supportsService("com.sun.star.drawing.GraphicObjectShape") Then
                oGraphic = oShape.Graphic : Exit For
            End IF

        Next j

    Next i

    pdfDoc.setModified(False)
    pdfDoc.dispose()
    oDoc.setModified(False)

    If IsNull(oGraphic) Then
        MsgBox "No supported image found", "48", "System"
        Exit Sub
    End If

    Dim baseUrl As String, destUrl As String

    Select Case OSName
        Case "WIN"
             baseUrl = Environ("userprofile") & "\Desktop\"
        Case "LINUX", "MACOSX"
            baseUrl =  Environ("HOME") & "/Desktop/"
    End Select

    destUrl = ConvertToUrl(baseUrl & "embedded_image_from_pdf" & ext_mtype(0))

    If sfa.Exists(destUrl) Then
        sfa.Kill(destUrl)
    End If

    Dim gPovider As Object
    gPovider = CreateUnoService("com.sun.star.graphic.GraphicProvider")

    Dim props(1) As New com.sun.star.beans.PropertyValue
    Props(0).Name = "URL"
    Props(0).Value = destUrl
    Props(1).Name = "MimeType"
    Props(1).Value = ext_mtype(1)
    gPovider.storeGraphic(oGraphic, props)
    props = Nothing
    Erase ext_mtype
    sfa = Nothing
    gPovider = Nothing
    oGraphic = Nothing

    Dim oShellExec As Object
    oShellExec = CreateUnoService("com.sun.star.system.SystemShellExecute")
    oShellExec.execute(destURL, "", 0)
    oShellExec = Nothing

End Sub

Function InStrReverse(sText As String, search As String) As Long

    If sText = "" Or search = "" Or Len(search) > Len(sText) Then
        InStrReverse = 0
        Exit Function
    End If

    Dim i As Long

    For i = Len(sText) To 1 Step -1
        If Mid(sText, i, Len(search)) = search Then
            InStrReverse = i : Exit Function
        End If
    Next i

End Function

Function DumpBytes(inBytes As Variant, count As Long) As String

    Dim aBytes(Ubound(inBytes)) As Byte

    Dim i As Long, line As String

    For i = 0 To count -1
        aBytes(i) = IIf(inBytes(i) < 0, 256 + inBytes(i), IIf(inBytes(i) = 0 And inBytes(i+1) = 0, 10, inBytes(i)))
        sResult = sResult &  ByteToChar(aBytes(i))
    Next i

    Erase aBytes
    DumpBytes = sResult
    sResult = ""

End Function

Function ByteToChar(b As Integer) As String
    ByteToChar = Chr(b)
End Function

Function DetectImageType(sResult As String) As String

    If InStr(sResult, "ÿØÿà") > 0 Or InStr(sResult, "ÿØÿÛ") > 0 Then
        DetectImageType = ".jpg|image/jpeg"
    ElseIf InStr(sResult, "‰PNG") > 0 Then
        DetectImageType = ".png|image/png"
    ElseIf InStr(sResult, "GIF8") > 0 Then
        DetectImageType = ".gif|image/gif"
    ElseIf InStr(sResult, "BM") > 0 Then
        DetectImageType = ".bmp|image/bmp"
    ElseIf InStr(sResult, "II*") > 0 Or InStr(sResult, "MM") > 0 Then
        DetectImageType = ".tiff|image/tiff"
    ElseIf InStr(sResult, "RIFF") > 0 Then
        DetectImageType = ".webp|image/webp"
    ElseIf InStr(sResult, "<svg") > 0 Then
        DetectImageType = ".svg|image/svg+xml"
    Else
        DetectImageType = ".bin|application/octet-stream"
    End If

End Function

Function OSName As String

    With GlobalScope.Basiclibraries
        If Not .IsLibraryLoaded("Tools") Then .LoadLibrary("Tools")
    End With

    Dim keyNode As Object
    keyNode = Tools.Misc.GetRegistryKeyContent("org.openoffice.Office.Common/Help")
    OSName = keyNode.GetByName("System")

End Function

Sub OnClose
    thisComponent.setModified(False)
End Sub