Kevyt testiversio Pdf lukijasta LibreOffice Writer ympäristössä toteutettuna puhtaasti [Star]Basic koodilla käyttäen hyväksi piilotettua LibreOffice Draw (proxy) instanssia.
Ohjeet:
Avaa uusi LibreOffice Writer projekti.
Tallenna projekti esim. niellä WriterPdfLukija
Avaa valikkoriviltä Työkalut -> Makrot -> Makrojen hallinta -> Basic
Etsi vasemmanpuoleisesta laatikosta projktsi nimi, laajeena puu
valitse Standard, klikkaa oikealla Uusi ja hyväksy tarjottu Module1
klikkaamalla OK ja tallenna jälleen projektisi. Avaa jälleen valikkoriviltä
Työkalut -> Makrot -> Muokkaa makroja, etsi vasemmalta projktsi mimi, laajenna
ja klikkaa Module1. Korvaa kaikki sisältö kopioimalla tämän viestin koodi
Module1 sisällöksi ja klikkaa OK.
Avaa valikkoriviltä Työkalut -> Mukauta -> Valikot välilehti.
Valitse oikealla (ylhäällä) Rajaus alasvetovalikosta projektisi nimi
valitse sen alla olevan Kohde alasvetovalikon oikealta puolelta täppä
(kolme viivaa alekkain), valitse Lisää, kirjoita Valikon nimi laatikkoon:
PDF Lukija, klikkaa (alhaalla) OK. Valitse vasemmalta (ylhäältä) Luokka
alasvetovalikosta Makrot. Valitse alapuolisesta laatikosta
Saatavilla olevat komennot -> etsi projektisi nimi, laajenna puu ja etsi Module1
haarasta OpenPDF tuplaklikkaa nimeä jolloin makron nimi ilmetyy oikeanpuoleiseen
laatikkoon. Aktivoi nimi klikkaamalla, klikkaa (alhaalla) Muuta -> nimeä uudelleen, kirjoita Uusi nimi laatikkoon Avaa pdf tiedosto, klikkaa OK, klikkaa OK ja tallenna jälleen projektisi. Avaa valikkoriviltä Työkalut -> Mukauta -> Tapahtumat välilehti. Valitse vasemmasta laatikosta Näkymää ollaan sulkemassa, klikkaa oikealta (ylhäällä) Makro, valitse vasemmalta Kirjasto laatikosta projektisi nimi, laajenna puu, klikkaa Module1 ja tupla klikkaa laatikossa oikealla OnClose, Klikkaa OK ja tallenna projektisi.
REM ***** BASIC *****
REM LICENCE: DWYFW (tee mitä v****a ikinä haluat)
Type PdfItem
IsImage As Boolean
HasTextBeside As Boolean
IsLine As Boolean
sText As String
X As Long
Y As Long
W As Long
H As Long
gGraphic As Variant
ImageAlign As String
FontName As String
FontSize As Double
FontWeight As Long
FontPosture As Long
FontUnderline As Long
FontStrikeout As Long
ParaAdjust As Long
Side As String
End Type
Private PdfData() As PdfItem
Private gPageWidth As Long
Private ProxyRunning As Boolean
' ============================================================
' AVAA PDF
' ============================================================
Sub OpenPDF
If ProxyRunning Then Exit Sub
Dim fp As Object, arr, file As String
fp = createUnoService("com.sun.star.ui.dialogs.FilePicker")
fp.appendFilter("PDF", "*.pdf")
fp.setDisplayDirectory(Left(ThisComponent.URL, InStrReverse(ThisComponent.URL, "/") - 1))
fp.setMultiSelectionMode(False)
If fp.Execute() <> 1 Then Exit Sub
arr = fp.getFiles()
file = arr(0)
ClearDocument
GetPdfInfo file
End Sub
' ============================================================
' PDF → WRITERILLE
' ============================================================
Sub GetPdfInfo(pdfUrl As String)
Dim args(1) As New com.sun.star.beans.PropertyValue
args(0).Name = "Hidden" : args(0).Value = True
args(1).Name = "ReadOnly" : args(1).Value = True
Dim pdf As Object
pdf = StarDesktop.loadComponentFromURL(pdfUrl, "_blank", 0, args())
ProxyRunning = True
Dim pages As Object
pages = pdf.getDrawPages()
gPageWidth = pages(0).Width
Dim count As Long
ScanPdfShapesCount pages, count
ReDim PdfData(count)
ScanPdfShapesFill pages, PdfData()
DetectUnderlineStrikeout PdfData()
DetectParagraphAlignments PdfData(), gPageWidth
DetectTextBesideImages PdfData()
DetectImageAlignment PdfData(), gPageWidth
pdf.dispose
ProxyRunning = False
WriteToWriter PdfData()
End Sub
' ============================================================
' WRITERIIN TULOSTUS
' ============================================================
Sub WriteToWriter(data() As Variant)
Dim doc As Object, txt As Object
doc = ThisComponent
txt = doc.getText()
Dim cur As Object, imgcur As Object
cur = txt.createTextCursor()
doc.lockControllers
Dim i As Long
For i = 0 To UBound(data)
r = PdfData(i)
' ohita viivat, ne tulkitaan jo alleviivauksiksi/yliviivauksiksi
If r.IsLine Then
GoTo NextI
End If
' -----------------------------
' NORMAALI TEKSTI
' -----------------------------
If Not r.IsImage And r.sText <> "" Then
If i > 0 Then
Dim factor1, factor2
On Error Resume Next
factor1 = Cint(PdfData(i).Y / PdfData(i).FontSize)
factor2 = Cint(PdfData(i-1).Y / PdfData(i-1).FontSize)
If factor1 - factor2 < 0 Or factor1 - factor2 > 41 And factor1 - factor2 < 150 Then
txt.insertControlCharacter(cur, _
com.sun.star.text.ControlCharacter.PARAGRAPH_BREAK, False)
End If
If Err <> 0 Then Err.Clear
End If
cur.CharHeight = r.FontSize
cur.CharFontName = r.FontName
cur.CharWeight = r.FontWeight
cur.CharPosture = r.FontPosture
cur.CharUnderline = r.FontUnderline
cur.CharStrikeout = r.FontStrikeout
cur.ParaAdjust = r.ParaAdjust
txt.insertString cur, r.sText & Chr(13), False
' -----------------------------
' KUVA
' -----------------------------
ElseIf r.IsImage And Not r.HasTextBeside Then
If i < Ubound(PdfData) Then
txt.insertString cur, PdfData(i+1).sText, False
End If
txt.insertString cur, Chr(13) & Chr(10) , False
img = doc.createInstance("com.sun.star.text.TextGraphicObject")
img.Graphic = r.gGraphic
img.AnchorType = 1
img.Width = r.W
img.Height = r.H
img.Surround = com.sun.star.text.WrapTextMode.NONE
Select Case r.ImageAlign
Case "LEFT"
cur.ParaAdjust = com.sun.star.style.ParagraphAdjust.LEFT
Case "CENTER"
cur.ParaAdjust = com.sun.star.style.ParagraphAdjust.CENTER
Case "RIGHT"
cur.ParaAdjust = com.sun.star.style.ParagraphAdjust.RIGHT
Case Else
End Select
imgcur = cur.getText().createTextCursorByRange(cur)
txt.insertTextContent(imgcur, img, False)
txt.insertString cur, Chr(13), False
txt.insertControlCharacter(cur, _
com.sun.star.text.ControlCharacter.PARAGRAPH_BREAK, False)
imgcur = Nothing
If i < Ubound(PdfData) Then i = i + 1
' -----------------------------
' TEKSTI KUVAN VIERESSÄ
' -----------------------------
ElseIf r.IsImage And r.HasTextBeside Then
If i < Ubound(PdfData) Then
txt.insertString cur, PdfData(i+1).sText, False
End If
txt.insertString cur, Chr(13) & Chr(10) , False
img = doc.createInstance("com.sun.star.text.GraphicObject")
img.Graphic = PdfData(i).gGraphic
img.AnchorType = 1
img.Width = PdfData(i).W
img.Height = PdfData(i).H
img.Surround = com.sun.star.text.WrapTextMode.NONE
If PdfData(i).Side = "LEFT" Then
img.HoriOrient = com.sun.star.text.HoriOrientation.LEFT
ElseIf PdfData(i).Side = "RIGHT" Then
img.HoriOrient = com.sun.star.text.HoriOrientation.RIGHT
End If
imgcur = cur.getText().createTextCursorByRange(cur)
txt.insertTextContent(imgcur, img, False)
txt.insertString(imgcur, " " , False) ' duct tape woodoo fix (purkkaviritys)
Dim j As Long, frame As Object, inner As Object, started As Boolean
imgcur = Nothing
For j = 0 To UBound(data)
If Not data(j).IsImage And Not data(j).IsLine And data(j).Side <> "" Then
If data(j).Y + data(j).H >= r.Y And data(j).Y <= r.Y + r.H Then
If Not started Then
started = True
frame = doc.createInstance("com.sun.star.text.TextFrame")
frame.AnchorType = 1
frame.Width = data(j).W * 1.04
If data(j).Side = "LEFT" Then
frame.HoriOrient = 0
Else
frame.HoriOrient = 2
End If
Dim fc As Object
fc = txt.createTextCursor()
fc.gotoEnd(False)
txt.insertTextContent fc, frame, False
inner = frame.getText().createTextCursor()
End If
inner.CharHeight = data(j).FontSize
inner.CharFontName = data(j).FontName
inner.CharWeight = data(j).FontWeight
inner.CharPosture = data(j).FontPosture
inner.CharUnderline = data(j).FontUnderline
inner.CharStrikeout = data(j).FontStrikeout
inner.ParaAdjust = data(j).ParaAdjust
If j < UBound(data) Then
frame.getText().insertString inner, data(j).sText & Chr(10), False
Else
frame.getText().insertString inner, data(j).sText, False
End If
data(j).sText = ""
End If
End If
Next j
txt.insertString cur, Chr(13) & Chr(10) , False
If i < Ubound(PdfData) Then = i + 1
inner = Nothing
img.Width = frame.Width
txt.insertControlCharacter cur, 0, False
End If
NextI:
Next i
Erase PdfData
ThisComponent.setModified(False)
doc.unlockControllers
End Sub
' ============================================================
' SKANNAUS 1: Laske elementit
' ============================================================
Sub ScanPdfShapesCount(pages As Object, ByRef count As Long)
Dim i As Long, j As Long
count = -1
For i = 0 To pages.getCount() - 1
Dim p As Object
p = pages(i)
For j = 0 To p.getCount() - 1
Dim s As Object
s = p(j)
If s.supportsService("com.sun.star.drawing.TextShape") _
Or s.supportsService("com.sun.star.drawing.GraphicObjectShape") _
Or s.supportsService("com.sun.star.drawing.LineShape") _
Or s.supportsService("com.sun.star.drawing.RectangleShape") Then
count = count + 1
End If
Next j
Next i
End Sub
' ============================================================
' SKANNAUS 2: Täytä PdfData taulukko
' ============================================================
Sub ScanPdfShapesFill(pages As Object, ByRef data() As Variant)
Dim i As Long, j As Long, idx As Long
For i = 0 To pages.getCount() - 1
Dim p As Object
p = pages(i)
For j = 0 To p.getCount() - 1
Dim s As Object
s = p(j)
' -----------------------------
' TEKSTI (TextShape)
' -----------------------------
If s.supportsService("com.sun.star.drawing.TextShape") Then
With data(idx)
.IsImage = False
.IsLine = False
.sText = s.getText().getString()
.X = s.getPosition().X
.Y = s.getPosition().Y
.W = s.getSize().Width
.H = s.getSize().Height
.Side = ""
End With
ReadTextProps s, data(idx)
idx = idx + 1
' -----------------------------
' KUVA (GraphicShape)
' -----------------------------
ElseIf s.supportsService("com.sun.star.drawing.GraphicObjectShape") Then
With data(idx)
.IsImage = True
.IsLine = False
.sText = ""
.X = s.getPosition().X
.Y = s.getPosition().Y
.W = s.getSize().Width
.H = s.getSize().Height
.Side = ""
.gGraphic = s.Graphic ' ← DIRECT XGraphic
End With
idx = idx + 1
' -----------------------------
' KUVA (Rectangle muoto + Bittikartan täyttö)
' -----------------------------
ElseIf s.supportsService("com.sun.star.drawing.RectangleShape") Then
With data(idx)
.IsImage = True
.IsLine = False
.sText = ""
.X = s.getPosition().X
.Y = s.getPosition().Y
.W = s.getSize().Width
.H = s.getSize().Height
.Side = ""
If Not IsNull(s.FillBitmap) Then
Dim prov As Object
prov = createUnoService("com.sun.star.graphic.GraphicProvider")
Dim pr(0) As New com.sun.star.beans.PropertyValue
pr(0).Name = "Bitmap"
pr(0).Value = s.FillBitmap
.gGraphic = prov.queryGraphic(pr())
End If
End With
idx = idx + 1
' -----------------------------
' VIIVAOBJEKTI (alleviivaus/yliviivaus)
' -----------------------------
ElseIf s.supportsService("com.sun.star.drawing.LineShape") Then
With data(idx)
.IsImage = False
.IsLine = True
.sText = ""
.X = s.getPosition().X
.Y = s.getPosition().Y
.W = s.getSize().Width
.H = s.getSize().Height
End With
idx = idx + 1
End If
Next j
Next i
End Sub
' ============================================================
' TEKSTIN FONTIT
' ============================================================
Sub ReadTextProps(s As Object, ByRef it As Variant)
Dim e As Object, p As Object, pe As Object, po As Object
e = s.getText().createEnumeration()
While e.hasMoreElements()
p = e.nextElement()
it.ParaAdjust = p.ParaAdjust
pe = p.createEnumeration()
If pe.hasMoreElements() Then
po = pe.nextElement()
it.FontName = po.CharFontName
it.FontSize = po.CharHeight
it.FontWeight = po.CharWeight
it.FontPosture = po.CharPosture
End If
Wend
End Sub
' ============================================================
' Alleviivaus / Yliviivaus
' ============================================================
Sub DetectUnderlineStrikeout(data() As Variant)
Dim i As Long, j As Long, txtBase As Long, txtMid As Long, tol As Long
tol = 80
For i = 0 To UBound(data)
If Not data(i).IsImage And Not data(i).IsLine Then
txtBase = data(i).Y + data(i).H
txtMid = data(i).Y + data(i).H \ 2
For j = 0 To UBound(data)
If data(j).IsLine Then
If Abs(data(j).Y - txtBase) <= tol Then
data(i).FontUnderline = 1
End If
If Abs(data(j).Y - txtMid) <= tol Then
data(i).FontStrikeout = 1
End If
End If
Next j
End If
Next i
End Sub
' ============================================================
' TASAUS X-KOORDINAATTEISTA
' ============================================================
Sub DetectParagraphAlignments(data() As Variant, pw As Long)
Dim i As Long, L As Long, R As Long
L = pw * 0.33
R = pw * 0.66
For i = 0 To UBound(data)
If Not data(i).IsImage And Not data(i).IsLine Then
If data(i).X < L Then
data(i).ParaAdjust = 0
ElseIf data(i).X > R Then
data(i).ParaAdjust = 2
Else
data(i).ParaAdjust = 3
End If
End If
Next i
End Sub
Sub DetectImageAlignment(data() As Variant, gPageWidth As Long)
Dim i As Long
Dim midX As Double
For i = 0 To UBound(data)
If data(i).IsImage Then
' Kuvan keskikohta
midX = data(i).X + data(i).W / 2
' Suhteellinen sijainti
If midX < gPageWidth * 0.33 Then
data(i).ImageAlign = "LEFT"
ElseIf midX > gPageWidth * 0.66 Then
data(i).ImageAlign = "RIGHT"
Else
data(i).ImageAlign = "CENTER"
End If
End If
Next i
End Sub
' ============================================================
' TEKSTI KUVAN VIERESSÄ
' ============================================================
Sub DetectTextBesideImages(data() As Variant)
Dim i As Long, j As Long
For i = 0 To UBound(data)
If data(i).IsImage Then
Dim top As Long, bot As Long, left As Long, right As Long
top = data(i).Y
bot = data(i).Y + data(i).H
left = data(i).X
right = data(i).X + data(i).W
For j = 0 To UBound(data)
If Not data(j).IsImage And Not data(j).IsLine Then
Dim t As Long, b As Long, lx As Long, rx As Long
t = data(j).Y
b = data(j).Y + data(j).H
lx = data(j).X
rx = data(j).X + data(j).W
If b >= top And t <= bot Then
If rx < left Then
data(j).Side = "LEFT"
data(i).HasTextBeside = True ' ← LIPPU KUVALLA
ElseIf lx > right Then
data(j).Side = "RIGHT"
data(i).HasTextBeside = True ' ← LIPPU KUVALLA
End If
End If
End If
Next j
End If
Next i
End Sub
' ============================================================
' MUUT
' ============================================================
Sub ClearDocument
Dim t As Object
t = ThisComponent.getText()
t.String = ""
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
Sub OnClose
ProxyRunning = False
Erase PdfData
ThisComponent.setModified(False)
End Sub
REM NO WARRANTY 😎Käyttö selviää tsiikaamalla tämän
Halutessaan valmiin testiprojektin voi imaista täältä
HV (hyvää vappua jo etukäteen)
