BITTE helfen Sie uns HEUTE mit einer SPENDE
Helfen Sie das LibreOffice Forum zu erhalten!
> KEINE WERBUNG FÜR REGISTRIERTE BENUTZER!<
Ihre Spende wird für die Deckung der laufenden Kosten sowie den Erhalt und Ausbau 🌱 des LibreOffice Forums verwendet.
🤗 Als Dankeschön werden Sie im Forum als LO-SUPPORTER gekennzeichnet. 🤗
Alles zur Programmierung im LibreOffice.
-
tmp
- Beiträge: 13
- Registriert: Sa 27. Aug 2022, 12:41
Beitrag
von tmp » Sa 10. Sep 2022, 13:02
Ich habe mal noch etwas herumprobiert. Solange sich die Ausführung in der While-Schleife befindet, ist ein Löschen der Zeile mit dem Cursor nicht möglich. Außerhalb der While-Schleife funktioniert es.
Daher habe ich den Code wie folgt abgwandelt:
Code: Alles auswählen
Option VbaSupport 1
Option Explicit
'===========================================
Sub remove_empty_paragraphs
Dim Doc As Object
Dim Enum1 As Object
Dim Enum2 As Object
Dim TextElement As Object
Dim TextPortion As Object
Dim ViewCursor As Object
Dim TextCursor As Object
Dim Document As Object
Dim Dispatcher As Object
Dim i As Integer, j As Integer, k As Integer
Dim a As Variant
Doc = ThisComponent
Enum1 = Doc.Text.createEnumeration()
ViewCursor = ThisComponent.getCurrentController().getViewCursor()
Document = Doc.CurrentController.Frame
Dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")
Call replace_whitespaces
i = 0 'counts the paragraphs
j = 0 'counts the sub-paragraphs; used for debugging
k = 0 'counts the empty paragraphs; if k > 1, the paragraph will be deleted; if a paragraph is not empty, k will be resetted to 0
ReDim a(0)
'loop over all paragraphs
While Enum1.hasMoreElements
TextElement = Enum1.nextElement
ViewCursor.gotoRange(TextElement, false)
i = i + 1
ReDim Preserve a(i)
a(i) = 0
If TextElement.supportsService("com.sun.star.text.Paragraph") Then
Enum2 = TextElement.createEnumeration
'loop over all sub-paragraphs
Do While Enum2.hasMoreElements
TextPortion = Enum2.nextElement
j = j + 1
If TextPortion.String = "" Then
If TextPortion.BreakType = 0 Then 'no break
k = k + 1
ElseIf TextPortion.BreakType = 4 Then 'break before
k = 0
a(i - 1) = 0
Exit Do
ElseIf TextPortion.BreakType = 5 Then 'break after
k = 0
Exit Do
End If
Else
k = 0
Exit do
End If
Loop
If k >= 2 Then
a(i) = 1
End If
j = 0
End If
Wend
TextCursor = Doc.getText().createTextCursor()
For i = 1 to UBound(a)
If a(i) = 1 Then
Dispatcher.executeDispatch(Document, ".uno:Delete", "", 0, Array())
'Call delete_paragraph
Else
TextCursor.gotoNextParagraph(false)
ViewCursor.gotoRange(TextCursor, false)
End if
Next i
End Sub
'===========================================
Sub replace_whitespaces
Dim Doc As Object
Dim Replace As Object
Doc = ThisComponent
Replace = Doc.createReplaceDescriptor
Replace.SearchRegularExpression = True
Replace.SearchString = "^\s*$"
Replace.ReplaceString = ""
Doc.replaceAll(Replace)
End Sub
Damit wird aus diesem Text...:
¶ (An dieser Position ist ein Bild eingefügt, das im Hintergrund liegt. Der Text ist also über dem Bild.)
¶
¶
Lorem ipsum¶
Lorem ipsum dolor sit amet, consectetur adipisici elit, sed eiusmod tempor incidunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquid ex ea commodi consequat.¶
¶
¶
¶
Quis aute iure reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur.¶
¶
¶
¶
¶
Excepteur sint obcaecat cupiditat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.¶
¶
¶
¶ (An dieser Position befindet sich ein Seitenumbruch)
...jetzt dieser Text:
¶ (An dieser Position ist ein Bild eingefügt, das im Hintergrund liegt.)
Lorem ipsum¶
Lorem ipsum dolor sit amet, consectetur adipisici elit, sed eiusmod tempor incidunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquid ex ea commodi consequat.¶
¶
Quis aute iure reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur.¶
¶
Excepteur sint obcaecat cupiditat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.¶
¶
¶ (An dieser Position befindet sich ein Seitenumbruch)
Damit kann ich leben.
Ich danke euch für eure Hilfe.
-
musikai
- Beiträge: 262
- Registriert: Do 14. Mai 2015, 17:53
Beitrag
von musikai » Sa 10. Sep 2022, 18:09
Wunderbar,
hätte hier noch einen Ansatz zum Ausbauen gehabt:
Code: Alles auswählen
rem lösche leere Zeilen, die kein bild oder umbruch haben
Sub delete_empty_paras
Call replace_whitespaces
oText = ThisComponent.Text
oTextEnumeration = oText.createEnumeration
do while oTextEnumeration.hasmoreelements
oPar = oTextEnumeration.nextelement
If len(oPar.getString()) = 0 and pic_or_break(oPar)= 0 then
oPar.dispose()
end if
loop
End Sub
function pic_or_break (oPar)
pic_or_break=0
If oPar.supportsService("com.sun.star.text.Paragraph") Then
TextEnum = oPar.createEnumeration
Do While TextEnum.hasMoreElements
TextPortion = TextEnum.nextElement
If TextPortion.BreakType <> 0 or TextPortion.TextPortionType="Frame" Then
pic_or_break=1
end if
Loop
End If
end function
'===========================================
Sub replace_whitespaces
Dim Doc As Object
Dim Replace As Object
Doc = ThisComponent
Replace = Doc.createReplaceDescriptor
Replace.SearchRegularExpression = True
Replace.SearchString = "^\s*$"
Replace.ReplaceString = ""
Doc.replaceAll(Replace)
End Sub
Zuletzt geändert von
musikai am So 11. Sep 2022, 19:37, insgesamt 3-mal geändert.
-
tmp
- Beiträge: 13
- Registriert: Sa 27. Aug 2022, 12:41
Beitrag
von tmp » Sa 10. Sep 2022, 21:18
Hallo musikai,
dein Code funktioniert auch problemlos.
Danke.
-
musikai
- Beiträge: 262
- Registriert: Do 14. Mai 2015, 17:53
Beitrag
von musikai » So 11. Sep 2022, 16:05
Hab noch kurz meinen obigen code vereinfacht.
Wenn ich Dein letztes Beispiel an Deinem Test-Text anwende, wird stets eins der 2 Bilder gelöscht. (edit: passiert wohl nur auf meinem alten, langsamem Rechner, auf meinem modernerem System geht's ohne Probleme)
Leider liess mir das keine Ruhe und so habe ich dies zusammengestöpselt:
Code: Alles auswählen
rem lösche leere Zeilen, die kein bild oder umbruch haben, läßt aber eine leere Zeile stehen
Sub delete_empty_paras2
Dim a(0)
Call replace_whitespaces
oText = ThisComponent.Text
i=-1
countup=1
oTextEnumeration = oText.createEnumeration
rem disable Layout-update
rem ThisComponent.LockControllers()
do while oTextEnumeration.hasmoreelements
oPar = oTextEnumeration.nextelement
If len(oPar.getString()) = 0 and pic_or_break(oPar)= 0 then
if countup=1 then
i=i+1
ReDim Preserve a(i)
countup=0
end if
a(i)=a(i)+1
else
i=i+1
ReDim Preserve a(i)
countup=1
a(i)=0
end if
loop
oTextEnumeration2 = oText.createEnumeration
i=0
for i=0 to ubound(a)
k=1
if a(i)>0 then
for k=1 to a(i)-1
oPar = oTextEnumeration2.nextelement
oPar.dispose()
next k
oPar = oTextEnumeration2.nextelement
else
oPar = oTextEnumeration2.nextelement
end if
next i
rem enable Layout-update
rem ThisComponent.UnLockControllers()
End Sub
function pic_or_break (oPar)
pic_or_break=0
If oPar.supportsService("com.sun.star.text.Paragraph") Then
TextEnum = oPar.createEnumeration
Do While TextEnum.hasMoreElements
TextPortion = TextEnum.nextElement
If TextPortion.BreakType <> 0 or TextPortion.TextPortionType="Frame" Then
pic_or_break=1
end if
Loop
End If
end function
'===========================================
Sub replace_whitespaces
Dim Doc As Object
Dim Replace As Object
Doc = ThisComponent
Replace = Doc.createReplaceDescriptor
Replace.SearchRegularExpression = True
Replace.SearchString = "^\s*$"
Replace.ReplaceString = ""
Doc.replaceAll(Replace)
End Sub
An alle, die das LibreOffice-Forum nutzen:
Bitte beteiligen Sie sich mit 7 Euro pro Monat und helfen uns bei unserem Budget für das Jahr 2024.
Einfach per Kreditkarte oder PayPal.
Als Dankeschön werden Sie im Forum als LO-SUPPORTER gekennzeichnet.
❤️ Vielen lieben Dank für Ihre Unterstützung ❤️