Keskustelu: Koodit: Kuvadatan haku pdf tiedostosta ja tallennus (multiplatform)

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

Private sResult As String

Sub GetImageDataFromPdf

    Dim fileStr() As String, srcURL As String, sfa As Object
    srcURL = Left(thisComponent.URL, InStrReverse(thisComponent.URL, "/")) & "ImgTest.pdf"
    Dim inpStream As Object, inBytes() As Byte, i As Long
    sfa = CreateUnoService("com.sun.star.ucb.SimpleFileAccess")
    inpStream = CreateUnoService("com.sun.star.io.DataInputStream")
    inpStream = sfa.OpenFileRead(srcURL)
    inpStream.readBytes(inBytes, inpStream.available)
    inpStream.CloseInput()
    inpStream = Nothing
    sResult = ""

    DumpBytes inBytes, Ubound(inBytes)
    Dim outBytes() As Variant, ext As String
    Dim IsSvg As Boolean, xmltag As String
    Dim pos As Long, epos As Long

    If Len(sResult) > 100 Then

        Dim dlmext() As String
        dlmext = GetDelimAndExt(sResult)
        ext = dlmext(1)
        Dim temp As String
        pos = InStr(sResult, dlmext(0)) - 1
        temp = Left(sResult, pos)
        sResult = Replace(sResult, temp, "")
        Select Case dlmext(0)
            Case "<svg"
                epos =  InStr(sResult, "</svg") + Len("</svg") + 1
                IsSvg = True : xmltag = "<?xml version=""1.0"" encoding=""UTF-8""?>"
            Case Else
                IsSvg = False
                epos = InStr(sResult, "endstream") - 1
        End Select

        sResult = Left(sResult, epos)
        If Not IsSvg Then
            For i = pos To epos
                Redim Preserve outBytes(Ubound(outBytes) + 1)
                outBytes(Ubound(outBytes)) = inBytes(i)
            Next i
            sResult = "" : Erase inBytes
        End If

        If IsSvg Then
            sResult = xmltag &  chr(10) & sResult
        End If

    End If

    Dim destUrl As String, baseUrl As String

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

    destUrl = ConvertToUrl(baseUrl & "test" & ext)

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

    Dim oStream As Object

    Select Case IsSvg
        Case True
            oStream = createUNOService("com.sun.star.io.TextOutputStream")
            oStream.setEncoding("UTF-8")
            oStream.setOutputStream(sfa.openFileWrite(destUrl))
            oStream.writeString(sResult)
            sResult = ""
        Case False
            oStream = createUNOService("com.sun.star.io.DataOutputStream")
            oStream.setOutputStream(sfa.openFileWrite(destUrl))
            oStream.writeBytes(outBytes)
	End Select

    oStream.flush
    oStream.CloseOutput
    oStream = Nothing

End Sub

Function GetDelimAndExt(sData As String) As Variant

    Dim dlmext(1) As String

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

    ' JPG
    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

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

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

    GetDelimAndExt = dlmext

End Function

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 ByteToChar(b As Integer) As String
    ByteToChar = Chr(b)
End Function

Sub DumpBytes(inBytes As Variant, count As Long)

    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

End Sub

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