Possibly there are a few visitors interested in the code.
I will also attach a demonstrating .odt.
Note (1): The currently fresh LibO version 24.2.1 has a bug thwaiting the way to get position info for annotation anchors.
===Edit 2024-03-30 about 14:50 UTC===
With V 24.2.2.2 the bug seems to be fixed.
See https://bugs.documentfoundation.org/sho ... ?id=160138
===/Edit===
Note (2): AOO and very old versions of LibO dont't support non-empty text ranges as anchors for annotations. The info 'AnchorString' will then be empty even if the document was made with a newer version.
Code: Select all
Sub collectWriterAnnotationsInfo(Optional pDoc)
Dim annoStripes As New Collection
If IsMissing(pDoc) Then pDoc = ThisComponent
currCtrl = pDoc.CurrentController
foundSel = currCtrl.Selection
viewCur = currCtrl.ViewCursor
textFields = pDoc.TextFields
For Each field In textFields
If NOT field.supportsService("com.sun.star.text.textfield.Annotation") _
Then Goto nextField
With field
REM Get positionalInformation. This requires to select the anchor.
REM This is currently (2024-03-11) not working for me in LibO V 24.2.
REM It works in all my older Portable versions an also in AOO 4.1.7.
currCtrl.select(.Anchor)
With viewCur
page = .Page
With .Position
posY = .Y
posX = .X
End With
End With
annoDate = .Date
With annoDate
isoDate = Join(Array(Format(.Year, "0000"), _
Format(.Month, "00") , _
Format(.Day,"00")) , "-")
End With
annoStripe = Array(page, posY, posX, . Anchor.String, _
isoDate, .Author, .Content)
annoStripes.add(annoStripe)
End With
nextField:
Next field
currCtrl.select(foundSel)
Call annotationInfoToSheet(annoStripes)
fail:
End Sub
Sub annotationInfoToSheet(pCollection, Optional pSheet)
If IsMissing(pSheet) Then
calcDoc = StarDesktop.loadComponentFromURL("private:factory/scalc", "_blank", 0, Array())
pSheet = calcDoc.Sheets(0)
Else
calcDoc = pSheet.DrawPage.Forms.Parent
EndIf
headers = Array("Page", _
"AnchorPos.Y", "AnchorPos.X", _
"AnchorString", "Date", "Author", "ContentString")
uH = Ubound(headers)
headersRg = pSheet.getCellRangeByPosition(0, 0, uH, 0)
headersRg.setDataArray(Array(headers))
workCursor = pSheet.createCursorByRange(headersRg)
For Each annoStripe In pCollection
workCursor.gotoOffset(0, 1)
workCursor.setDataArray(Array(annoStripe))
Next annoStripe
tally = pCollection.Count
workCursor.gotoOffset(0, -tally + 1)
workCursor.collapseToSize(Ubound(headers) + 1, tally)
Dim sortDescr(2) As New com.sun.star.beans.PropertyValue' = workCursor.createSortDescriptor()
Dim sortFields(1) As New com.sun.star.util.SortField
sortFields(0).SortAscending = True : sortFields(0).Field = 1
sortFields(1).SortAscending = True : sortFields(1).Field = 2
sortDescr(0).Name = "ContainsHeader" : sortDescr(0).Value = False
sortDescr(1).Name = "SortFields" : sortDescr(1).Value = sortFields
sortDescr(2).Name = "BindFormatsToContent" : sortDescr(0).Value = False
workCursor.sort(sortDescr)
calcDoc.currentController.select(workCursor)
End Sub