Keskustelu: Koodit: LibreOffice upotetettu rasterikuva/vektorigrafiikka (.pdf)

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

Private baseUrl As String

Sub StartProcessing

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

    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
    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)
    Erase inBytes

    Dim ext_mtype() As String
    ext_mtype = Split(DetectImageType(sResult), "|")
    sResult = ""

    If ext_mtype(1) = "" 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", "System"
        oPages = Nothing : pdfDoc.setModified(False)
        args = Nothing : pdfDoc.dispose() : Exit Sub
    End If

    Dim j As Integer, oGraphic As Object, fColor As String, svg As String, boxW, boxH

    oPage = oPages.getByIndex(0)
    oShape = oPage.getByIndex(0)

    For i = 0 To oPage.getCount() - 1
        oShape = oPage.getByIndex(i)
        If oShape.supportsService("com.sun.star.drawing.GraphicObjectShape") Then
            oGraphic = oShape.Graphic : Exit For
        ElseIf oShape.supportsService("com.sun.star.drawing.ClosedBezierShape") Then
            svg = svg  & ClosedBezierShapeToSvgPath(oShape)
        End If
    Next i

    If svg <> "" Then

        ssvg = "<svg xmlns=""http://www.w3.org/2000/svg"" version=""1.1"">" & Chr(13) & Chr(10) & svg  & Chr(13) & Chr(10) & "</svg>"

        Dim aBytes() As Byte

        ReDim aBytes(Len(svg) -1)
        For i = 1 To Len(svg)
            aBytes(i - 1) = Asc(Mid(svg, i, 1))
        Next

        Dim  oInstream As Object
        oInstream = com.sun.star.io.SequenceInputStream.createStreamFromSequence(aBytes)
        Erase aBytes

        Dim oProvider As Object
        Dim props(0) As New com.sun.star.beans.PropertyValue
        oProvider=createUnoService("com.sun.star.graphic.GraphicProvider")
        props(0).Name="InputStream" : props(0).Value = oInstream
        oGraphic = oProvider.queryGraphic(props)
        oInstream.CloseInput()
        oInstream = Nothing
        oProvider = Nothing

    End If

    pdfDoc.setModified(False)
    pdfDoc.dispose()
    oDoc.setModified(False)
    If Not IsNull(oGraphic) And Not IsEmpty(oGraphic) Then
        CopyToFile oGraphic, ext_mtype
        oGraphic = Nothing
    Else
        MsgBox "No supported graphic found", "48", "System"
        Exit Sub
    End If

End Sub

Function DumpBytes(inBytes As Variant) As String

    Dim aBytes(Ubound(inBytes)) As Byte
    aBytes = inBytes
    Dim i As Long, val As Long, sResult As String

    For i = Lbound(aBytes) To Ubound(aBytes)
        val = (aBytes(i) And &HFF)
        sResult = sResult & Chr(val)
    Next i

    Erase aBytes : DumpBytes = sResult : sResult = ""

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, "GIF8") > 0 Or InStr(sResult, "<0000") > 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 Or InStr(sResult, "]ݱ") > 0 Then
        DetectImageType = ".tiff|image/tiff"
    ElseIf InStr(sResult, "RIFF") > 0 Then
        DetectImageType = ".webp|image/webp"
    ElseIf InStr(sResult, "<svg") > 0 Or  InStr(sResult, "W1") OR Instr(sResult, "$M") > 0 Or  Instr(sResult, "M¯") > 0 Or  Instr(sResult, "½K") > 0Then
        DetectImageType = ".svg|image/svg+xml"
    Else
        DetectImageType = ".png|image/png"
    End If

End Function

Function ClosedBezierShapeToSvgPath(oShape As Variant) As String

    Dim oPolyBez, aCoords, aFlags
    Dim polyIdx As Long, ptIdx As Long
    Dim pts, flg
    Dim d As String
    Dim x As Double, y As Double
    Dim fillCol As String, strokeCol As String
    Dim hasFill As Boolean, hasStroke As Boolean

    oPolyBez = oShape.PolyPolygonBezier
    aCoords = oPolyBez.Coordinates
    aFlags  = oPolyBez.Flags

    d = ""

    For polyIdx = LBound(aCoords) To UBound(aCoords)
        pts = aCoords(polyIdx)
        flg = aFlags(polyIdx)

        If UBound(pts) < 0 Then GoTo NextPoly

        x = pts(0).X
        y = pts(0).Y
        d = d & "M " & UnoToSvg(x) & " " & UnoToSvg(y) & " "

        ptIdx = 1
        Do While ptIdx <= UBound(pts)
            Select Case flg(ptIdx)
                Case 0
                    x = pts(ptIdx).X
                    y = pts(ptIdx).Y
                    d = d & "L " & UnoToSvg(x) & " " & UnoToSvg(y) & " "
                    ptIdx = ptIdx + 1

                Case Else
                    If ptIdx + 2 <= UBound(pts) Then
                        Dim x1 As Double, y1 As Double
                        Dim x2 As Double, y2 As Double
                        Dim x3 As Double, y3 As Double

                        x1 = pts(ptIdx).X
                        y1 = pts(ptIdx).Y
                        x2 = pts(ptIdx + 1).X
                        y2 = pts(ptIdx + 1).Y
                        x3 = pts(ptIdx + 2).X
                        y3 = pts(ptIdx + 2).Y

                        d = d & "C " & UnoToSvg(x1) & " " & UnoToSvg(y1) & " " & _
                                    UnoToSvg(x2) & " " & UnoToSvg(y2) & " " & _
                                    UnoToSvg(x3) & " " & UnoToSvg(y3) & " "
                        ptIdx = ptIdx + 3
                    Else
                        x = pts(ptIdx).X
                        y = pts(ptIdx).Y
                        d = d & "L " & UnoToSvg(x) & " " & UnoToSvg(y) & " "
                        ptIdx = ptIdx + 1
                    End If
            End Select
        Loop

        d = d & "Z "
NextPoly:
    Next polyIdx

    hasFill = (oShape.FillStyle <> com.sun.star.drawing.FillStyle.NONE)
    hasStroke = (oShape.LineStyle <> com.sun.star.drawing.LineStyle.NONE)

    If hasFill Then
        fillCol = ColorToHex(oShape.FillColor)
    Else
        fillCol = "none"
    End If

    If hasStroke Then
        strokeCol = ColorToHex(oShape.LineColor)
    Else
        strokeCol = "none"
    End If

    ClosedBezierShapeToSvgPath = "<path d=""" & Trim(d) & """ fill=""" & fillCol & _
                                 """ stroke=""" & strokeCol & """ />"

End Function

Private Function UnoToSvg(ByVal n As Double) As String

    Dim factor As Double
    factor = 0.03779527559   ' 1/ (100 / 25.4 * 96)
    UnoToSvg = Replace(CStr(n * factor), ",", ".")
End Function

Function ColorToHex(ByVal col As Long) As String

    Dim r As Long, g As Long, b As Long
    r = (col And &HFF0000) \ &H10000
    g = (col And &H00FF00) \ &H100
    b = (col And &H0000FF)
    ColorToHex = "#" & Right("0" & Hex(r), 2) & _
                      Right("0" & Hex(g), 2) & _
                      Right("0" & Hex(b), 2)

End Function

Sub CopyToFile(oGraphic As Object, ext_mtype() As String)

    destUrl = ConvertToUrl(baseUrl & "test" & UCase(Replace(ext_mtype(0), ".", "")) & ext_mtype(0))

    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 : 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 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