Darin sollen die Startseite und die Zielseite ausgegeben werden.
Zur Erklärung hänge ich Dateien an,
Wer ändert mir den Code?
Martin
ich hatte noch eine Idee.
REM *******************************************************************************
REM Autor des ursprünglichen Codes:
REM Winfried/ Komma4
REM Quelle des ursprünglichen Codes:
REM https://www.libreoffice-forum.de/viewtopic.php?t=15252
REM Sub LO_5_37115
REM 20150803
REM Printing writer's cross references
REM *******************************************************************************
' Properties of a TextField / Type: Cross-Reference
' Anchor .text.XTextRange -INTERFACE- Pseud Read_Only
' AnchorType .text.TextContentAnchorType AS_CHARACTER Read_Only 22271
' AnchorTypes [].text.TextContentAnchorType -Sequence- Read_Only 22265
' CurrentPresentation string "" 12
' ImplementationId []byte -SEQUENCE- Pseud Read_Only
' ImplementationName string SwXTextField Pseud Read_Only
' IsFieldDisplayed short True Read_Only 33
' IsFieldUsed float True Read_Only 32
' PropertySetInfo .beans.XPropertySetInfo -INTERFACE- Pseud Read_Only
' ReferenceFieldPart short 1 18
' ReferenceFieldSource short 2 19
' SequenceNumber short 0 24
' SourceName string __RefHeading___... 10
' SupportedServiceNames []string -Sequence- Pseud Read_Only
' TextFieldMaster .beans.XPropertySet -INTERFACE- Pseud Read_Only
' TextWrap .text.WrapTextMode NONE Read_Only 22270
' Types []type -Sequence- Pseud Read_Only
Option Explicit
Dim oDocW as Object ' Writer
Dim oDocC as Object ' Calc
Dim oSheet as Object ' Tabellenblatt
Dim oRange1 as Object ' Calc Zellbereich
Dim oRange2 as Object ' Calc Zellbereich
Dim mArr() as Variant ' Array
REM =========================================================================================
REM Startroutine
REM =========================================================================================
Sub StartVerweisExport
Dim oFieldService as Object
Dim oTextFields as Object
Dim oField as Object
Dim oField2 as Object
Dim oParEnum as Object
Dim oPar as Object
Dim oAnchor as Object
Dim oTxt as Object
Dim oCur as Object
Dim oCursor as Object
Dim oAddress as Object
Dim oCol as Object
Dim oColA as Object
Dim oColB as Object
Dim StyleFamilies as Object
Dim PageStyles as Object
Dim DefPage as Object
Dim FContent as Object
Dim HText as Object
Dim mBorders() as Variant
Dim mStyles as Variant
Dim eTextFields
Dim i%, nCol%, nRow%
Dim sText as String
' Hier in der Basic-IDE -> Objektkatalog
' LibreOffice Makros & Dialoge -> Tools
Globalscope.BasicLibraries.LoadLibrary ( "Tools")
oDocW = ThisComponent
'mri oDocw
Msgbox "Die Texte in Spalte C wird absichtlich gekürzt ausgegeben." & chr(10) & _
"Der Text in Spalte C ist ursprünglich so lang," & chr(10) & _
"dass Libreoffice abstürzen kann, wenn der gesamte Text ausgegeben wird.", 48, "Ausgabe der Texte in gekürzter Fassung!"
' Öffnen eines Calc-Dokuments
oDocC = StarDesktop.loadComponentFromURL("private:factory/scalc","_blank", 0, Array())
' Referenzierung der "Tabelle 1"
oSheet = oDocC.Sheets(0)
' mri oSheet
' Referenz Range-Objekt (Zellbereich)
'( [in] long nLeft, [in] long nTop, [in] long nRight, [in] long nBottom )
oRange1=osheet.getcellrangebyposition(0,1,20,1001)
' Zellbereich A2:C501 zur Dimensionierung des Array's in das Array schreiben
mArr()=oRange1.getDataArray
sText = "com.sun.star.text.TextField.GetReference"
'mri oService
oTextFields = oDocW.getTextFields()
'mri oTextFields
eTextFields = oTextFields.createEnumeration()
Do While eTextFields.hasMoreElements()
oField = eTextFields.nextElement()
oParEnum = oField.Anchor.createEnumeration()
Do While oParEnum.hasMoreElements()
oPar = oParEnum.nextElement()
' If oField.supportsService(oFieldService) Then
If oField.supportsService(sText) Then
' mri oField
' Wenn der Inhalt des Textfeldes nummerisch ist , dann
If isNumeric(oField.CurrentPresentation) then
'contains the current content of the text field.
mArr(i)(0)= int(oField.CurrentPresentation)
Else
' Wenn der Inhalt des Textfeldes NICHT nummerisch ist , dann
'contains the current content of the text field.
mArr(i)(0)= oField.CurrentPresentation
End If
REM -------------------------------------------------------------
REM Prüfung: Ist Anker im Fließtext oder in einer Tabelle
oAnchor=oField.anchor
If isempty(oAnchor.cell) Then
'im normalen Text
oTxt=oAnchor.text
Else
'in einer Tabellenzelle
oTxt=oAnchor.cell
End If
oCur=oTxt.createtextcursorbyrange(oAnchor)
oCur.collapsetostart
oCur.gotostartofparagraph(true)
REM Ausgabe des Absatzes in Arrayfeld
mArr(i)(1) = oCur.string
REM -------------------------------------------------------------
' Wenn "oField.getAnchor.getText.String" aktiviert wird, dann stürzt LO u.U. ab.
' Grund: Es wird eine sehr große Menge an Text verarbeitet, welcher dann
' in eine Calc-Zelle geschrieben werden muss.
' mArr(i)(2)= oField.getAnchor.getText.String
' Hier wird der überlange Text auf 60 Zeichen gekürzt.
' Dadurch erfolgt kein Absturz mehr.
mArr(i)(2)= Left(oField.getAnchor.getText.String,50) 'Right(oField.getAnchor.getText.String,20)
REM ListID
REM specifies the id of the list to which the paragraph belongs
mArr(i)(3)= oField.Anchor.ListID
REM ListLabelString
mArr(i)(4)= oField.Anchor.ListLabelString
REM ReferenceFieldSource
mArr(i)(5)= oField.Anchor.Textfield.ReferenceFieldSource
' Konstanten
'0 = REFERENCE_MARK The source is a reference mark.
'1 = SEQUENCE_FIELD The source is a number sequence field.
'2 = BOOKMARK The source is a bookmark.
'3 = FOOTNOTE The source is a footnote.
'4 = ENDNOTE The source is an endnote.
Select case mArr(i)(5)
case 0
mArr(i)(5)=mArr(i)(5) & " = " & "REFERENCE_MARK"
case 1
mArr(i)(5)=mArr(i)(5) & " = " & "SEQUENCE_FIELD"
case 2
mArr(i)(5)=mArr(i)(5) & " = " & "BOOKMARK"
case 3
mArr(i)(5)=mArr(i)(5) & " = " & "FOOTNOTE"
case 4
mArr(i)(5)=mArr(i)(5) & " = " & "ENDNOTE"
End Select
' Rsid
mArr(i)(6)= CStr(oField.Anchor.Rsid)
mArr(i)(7)= oField.SourceName
End If
' Array-Zähler
i = i+1
Loop
Loop
'mri oField
REM ----------------------------------------------
REM Spalten-Überschriften: Inhalt und Formatierung
With oSheet.getCellRangeByName("A1")
.String="CurrentPresentation"
.CharWeight = com.sun.star.awt.FontWeight.BOLD
.charcolor = &HFF0000
End With
With oSheet.getCellRangeByName("B1")
.String="oField.Anchor.GetString"
.CharWeight = com.sun.star.awt.FontWeight.BOLD
.charcolor = &HFF0000
End With
With oSheet.getCellRangeByName("C1")
.String="String"
.CharWeight = com.sun.star.awt.FontWeight.BOLD
.charcolor = &HFF0000
End With
With oSheet.getCellRangeByName("D1")
.String="ListID"
.CharWeight = com.sun.star.awt.FontWeight.BOLD
.charcolor = &HFF0000
End With
With oSheet.getCellRangeByName("E1")
.String="ListLabelString"
.CharWeight = com.sun.star.awt.FontWeight.BOLD
.charcolor = &HFF0000
End With
With oSheet.getCellRangeByName("F1")
.String="ReferenceFieldSource"
.CharWeight = com.sun.star.awt.FontWeight.BOLD
.charcolor = &HFF0000
End With
With oSheet.getCellRangeByName("G1")
.String="Rsid"
.CharWeight = com.sun.star.awt.FontWeight.BOLD
.charcolor = &HFF0000
End With
With oSheet.getCellRangeByName("H1")
.String="SourceName"
.CharWeight = com.sun.star.awt.FontWeight.BOLD
.charcolor = &HFF0000
End With
REM-----------------------------------------------
REM Array in Zellbereich schreiben
oRange1.setDataArray(mArr())
REM ----------------------------------------------
REM Zellbereich sortieren
Call SortiereBereich
REM ----------------------------------------------
' optimale Breite aller Zellen
oCol = oSheet.getColumns()
oCol.optimalWidth = true
REM ----------------------------------------------
' Spalte A zentriert ausrichten
oColA=oSheet.getCellRangeByName("A1:A700")
oColA.HoriJustify= com.sun.star.table.CellHoriJustify.CENTER
REM ----------------------------------------------
'Spalte B Breite anpassen
oCol = oSheet.getColumns()
' Refrenz Spalte "B"
oColB = oCol.getbyname("B")
' Spaltenbreite 14,0cm
oColB.Width=14000
' Zeilenumbruch einstellen
oColB.IsTextWrapped= True
REM ----------------------------------------------
REM vertikale Zentrierung des gesamten Inhalts
oRange1.VertJustify= com.sun.star.table.CellVertJustify.CENTER
REM ----------------------------------------------
REM Zellumrandung zeichnen
' ausgefüllten Zellbereich ermitteln
oCur = oSheet.createCursor()
oCur.gotoStart()
oCur.gotoEndofUsedArea(false) 'letzte Zelle des Bereiches
nCol = oCur.getRangeAddress.endColumn 'index letzte Spalte des Bereichs
nRow = oCur.getRangeAddress.endRow 'index letzte Zeile des Bereichs
' Referenz des ausgefüllten Zellbereichs
'( [in] long nLeft, [in] long nTop, [in] long nRight, [in] long nBottom )
oRange2=osheet.getcellrangebyposition(0,0,nCol,nRow)
Dim aLinestyle as new com.sun.star.table.BorderLine
aLinestyle.Color = RGB(0, 0, 0)
aLinestyle.OuterLineWidth = 40
mBorders = array("TopBorder", "LeftBorder", "RightBorder", "BottomBorder")
mStyles = array(aLinestyle,aLinestyle,aLinestyle,aLinestyle)
oRange2.setPropertyValues(mBorders , mStyles)
REM ----------------------------------------------
REM Querformat und Seitenränder festlegen
StyleFamilies = oDocC.StyleFamilies
PageStyles = StyleFamilies.getByName("PageStyles")
DefPage = PageStyles.getByName("Standard")
'mri defpage
With Defpage
.IsLandscape = True
.Width = 29700
.Height = 21000
.TopMargin=1000
.BottomMargin=500
.LeftMargin=500
.RightMargin=500
.HeaderIsOn=True
.HeaderIsShared = True
End With
REM ----------------------------------------------
REM Druckbereich: Wiederholungszeile festlegen
oRange2 = oSheet.getCellRangeByPosition(0,0,7,0)
oAddress = oRange2.getRangeAddress()
oSheet.setTitleRows(oAddress)
REM ----------------------------------------------
REM >>> Inhalt Fußzeile zuweisen <<<
FContent = Defpage.RightPageFooterContent
'Fußzeile links >>> Datei- und Pfadangabe
'HText = FContent.LeftText
'HText.setstring(sPath)
'Fußzeile zentriert >>> leer
HText = FContent.CenterText
HText.setstring("")
'Fußzeile rechts >>> Seitenzahl
HText = FContent.RightText
oField2 = oDocC.createInstance("com.sun.star.text.TextField.PageNumber")
oCursor = HText.createTextCursor()
HText.insertTextContent(oCursor, oField2, False)
' rechte Seite
Defpage.rightPageFooterContent = FContent
' linke Seite
Defpage.LeftPageFooterContent=FContent
End Sub
REM =========================================================================================
REM Sortieren des Zellbereichs
REM =========================================================================================
Sub SortiereBereich
Dim SortProps(2) As new com.sun.star.beans.PropertyValue
Dim SortFeld(1) As new com.sun.star.table.TableSortField
'Sortiere erst Spalte A
SortFeld(0).Field = 0
SortFeld(0).IsAscending = True
SortFeld(0).FieldType = com.sun.star.util.SortFieldType.NUMERIC
' SortFeld(0).FieldType = com.sun.star.util.SortFieldType.AUTOMATIC
' 'dann sortiere Spalte B
' SortFeld(1).Field = 1
' SortFeld(1).IsAscending = True
'' SortFeld(1).FieldType = com.sun.star.util.SortFieldType.ALPHANUMERIC
' SortFeld(1).FieldType = com.sun.star.util.SortFieldType.AUTOMATIC
' Sortier-Eigenschaften
SortProps(0).Name = "SortFields"
SortProps(0).Value = SortFeld()
SortProps(1).Name = "SortColumns"
SortProps(1).Value = False
SortProps(2).Name = "ContainsHeader"
SortProps(2).Value = true
' Zellbereich auf Basis der Sortier-Eigenschaften sortieren
oRange1.Sort(SortProps())
End Sub