SCALC: Convert Bold text to HTML

Ich stand vor der Aufgabe Texte die in einer Spalte teilweise fett geschrieben waren HTML-konform zu machen, also den fett geschriebenen Text mit <b> …</b> zu umklammern.

Fündig wurde ich in diesem Forenbeitrag: https://forum.openoffice.org/en/forum/viewtopic.php?f=9&t=85034#

Man fügt in SCALC ein Makro ein (s.u.) und gibt in einer Hilffspalte bspw. A2 diese Befehl ein:

=CONVERTBOLDTOTAGS(SPALTE(A1);ZEILE(AH2);TABELLE(A1);“„;“„)

Wobei in A1 der teilweise fett geschriebene Text enthalten ist. In A2 erscheint dann der konvertierte Text.

Hier das Makro:

Option Explicit
Function convert_Bold_Italic_Strike_Under_Link_To_Tags(ByVal pX As Long, ByVal pY As Long, ByVal pZ As Long) As String
'To pass the cell to work on by position should be an easy and reliable way.
'The inline tags for striking through and for underscoring were deprecated with V5 of html.
'I suppose the rendering of most browsers still supports them.
'A few lines of code are repeated (essentially) to avoid helper functions most likely not usable in a different context.
   Dim theDoc As Object
theDoc = ThisComponent
If   NOT theDoc.SupportsService("com.sun.star.sheet.SpreadsheetDocument") Then
   convert_Bold_Italic_Strike_Under_Link_To_Tags = "Need Calc Document!"
   Exit Function
End If
Dim theSheets As Object, sheetTally As Long
theSheets = theDoc.Sheets
sheetTally = theSheets.GetCount()
If   (pZ < 1) OR (pZ > sheetTally) Then
   convert_Bold_Italic_Strike_Under_Link_To_Tags = "Inacceptable SheetNumber!"
   Exit Function
End If
   Dim theSheet As Object
theSheet = theDoc.Sheets(pZ - 1)
If   (pX < 1) OR (pY < 1) or (pX > theSheet.RangeAddress.EndColumn + 1) OR (pY > theSheet.RangeAddress.EndRow + 1) Then
   convertBoldItalicStrikeUnderLinkToTags = "No cell with that position!"
   Exit Function
End If
   Dim theCell As Object, rText As String
theCell = theSheet.GetCellByPosition(pX - 1, pY - 1)
If   theCell.Type <> 2 Then
   rText = theCell.String
   If   theCell.CharWeight >= com.sun.star.awt.FontWeight.BOLD Then
      rText = "<b>" & rText & "</b>"
   End If
   If   theCell.CharPosture >= 1 Then
      rText = "<i>" & rText & "</i>"
   End If
   If   theCell.CharStrikeOut >= 1 Then
      rText = "<strike>" & rText & "</strike>"
   End If
   If   theCell.CharUnderline >= 1 Then
      rText = "<u>" & rText & "</u>"
   End If
   convert_Bold_Italic_Strike_Under_Link_To_Tags = rText
   Exit Function
End If
rText = ""
   Dim theParEnum As Object, theParElement As Object
   Dim theSubEnum As Object, theSubElement As Object
   Dim textSlice
theParEnum = theCell.GetText().CreateEnumeration
Do   While   theParEnum.HasMoreElements
   theParElement = theParEnum.NextElement
   theSubEnum = theParElement.CreateEnumeration
   Do   While   theSubEnum.HasMoreElements
      textSlice = ""
      theSubElement = theSubEnum.NextElement
      textSlice = theSubElement.String
      If   theSubElement.CharWeight >= com.sun.star.awt.FontWeight.BOLD Then
         textSlice = "<b>" & textSlice & "</b>"
      End If
      If   theSubElement.CharPosture >= 1 Then
         textSlice = "<i>" & textSlice & "</i>"
      End If
      If   theSubElement.CharStrikeOut >= 1 Then
         textSlice = "<strike>" & textSlice & "</strike>"
      End If
      If   theSubElement.CharUnderline >= 1 Then
         textSlice = "<u>" & textSlice & "</u>"
      End If
      If   theSubElement.TextPortionType = "TextField" Then
         If   theSubElement.TextField.SupportsService("com.sun.star.text.TextField.URL") Then
            textSlice = "<a href=" & Chr(34) & theSubElement.TextField.URL & Chr(34) & ">" & textSlice & "</a>"
         End If
      End If
      rText = rText & textSlice
   Loop
Loop
convert_Bold_Italic_Strike_Under_Link_To_Tags = rText
End Function