Bonjour,
Je vous propose cette solution ci-dessous et le lien en vidéo pour montrer comment ça fonctionne :
Extraire TOUS les hyperliens d’une cellule LibreOffice Calc (Macro & RegEx)
Sub ExtraireHyperliensSelection
Dim oDoc As Object
Dim oSelection As Object
Dim i As Long, j As Long
Dim nColCount As Long, nRowCount As Long
Dim oCell As Object
oDoc = ThisComponent
oSelection = oDoc.CurrentSelection
' Vérifier si la sélection est une cellule unique
If oSelection.supportsService("com.sun.star.sheet.SheetCell") Then
TraiterUneCellule(oSelection)
' Vérifier si la sélection est une plage de cellules (Rectangulaire)
ElseIf oSelection.supportsService("com.sun.star.sheet.SheetCellRange") Then
nColCount = oSelection.Columns.Count
nRowCount = oSelection.Rows.Count
' Boucle à travers toutes les cellules de la plage sélectionnée
For i = 0 To nColCount - 1
For j = 0 To nRowCount - 1
oCell = oSelection.getCellByPosition(i, j)
TraiterUneCellule(oCell)
Next j
Next i
Else
MsgBox "Veuillez sélectionner une cellule ou une plage de cellules valide.", 48, "Erreur de sélection"
End If
End Sub
Sub TraiterUneCellule(oCell As Object)
Dim oTextFields As Object
Dim oField As Object
Dim sLinks As String
Dim k As Integer
Dim oSheet As Object
Dim nCol As Long, nRow As Long
Dim oTargetCell As Object
' Accéder aux champs de texte de la cellule
oTextFields = oCell.TextFields
sLinks = ""
' Parcourir tous les champs pour trouver les URLs
If oTextFields.Count > 0 Then
For k = 0 To oTextFields.Count - 1
oField = oTextFields.getByIndex(k)
' Vérifier si le champ possède une propriété URL
If HasProperty(oField, "URL") Then
' Ajouter l'URL au cumul
If sLinks <> "" Then
sLinks = sLinks & " " ' Espace temporaire
End If
sLinks = sLinks & oField.URL
End If
Next k
End If
' Application de la logique "Regex" : Saut de ligne avant chaque http
' On s'assure que chaque lien commence sur une nouvelle ligne
If sLinks <> "" Then
' On remplace "http" par "Saut de ligne + http"
' Note : On nettoie d'abord les éventuels doubles sauts créés
sLinks = Replace(sLinks, "http", Chr(10) & "http")
' Nettoyage : si la chaîne commence par un saut de ligne, on l'enlève
If Left(sLinks, 1) = Chr(10) Then
sLinks = Mid(sLinks, 2)
End If
oSheet = oCell.getSpreadsheet()
nCol = oCell.CellAddress.Column
nRow = oCell.CellAddress.Row
' On cible la cellule à droite (Column + 1)
oTargetCell = oSheet.getCellByPosition(nCol + 1, nRow)
oTargetCell.String = sLinks
' Activer le renvoi à la ligne automatique
oTargetCell.IsTextWrapped = True
End If
End Sub
' Fonction utilitaire pour vérifier l'existence d'une propriété sans générer d'erreur
Function HasProperty(oObj As Object, sPropName As String) As Boolean
HasProperty = False
On Error Resume Next
HasProperty = Not IsNull(oObj.getPropertyValue(sPropName))
On Error GoTo 0
End Function
