The WinOps Blog

Sub ExtractUrlsFormatAndRemoveHyperlinks()
    Dim doc As Document
    Set doc = ActiveDocument
    Dim hyperlink As Hyperlink
    Dim rng As Range
    Dim fullAddress As String

    ' Parcourir chaque hyperlien dans le document pour insérer l'URL complète au début du paragraphe et changer la mise en forme
    For Each hyperlink In doc.Hyperlinks
        ' Construire l'adresse complète avec le SubAddress si disponible
        fullAddress = fullAddress & "#" & hyperlink.SubAddress
        If Len(hyperlink.SubAddress) > 0 Then
            fullAddress = fullAddress & "#" & hyperlink.SubAddress
        End If
        
        ' Insérer l'URL complète au début du paragraphe contenant l'hyperlien
        Set rng = hyperlink.Range.Paragraphs(1).Range
        rng.InsertBefore fullAddress & ": "
        
        ' Conserver le texte et changer la mise en forme pour du texte bleu et souligné
        With rng
            .Text = .Text
            .Font.Color = wdColorBlue
            .Font.Underline = wdUnderlineSingle
        End With
    Next hyperlink

    ' Supprimer tous les hyperliens dans le document après modification
    While doc.Hyperlinks.Count > 0
        doc.Hyperlinks(1).Delete
    Wend

    ' Réinitialiser la mise en forme du texte pour l'ensemble du document
    For Each para In doc.Paragraphs
        With para.Range
            .Font.Color = wdColorAutomatic
            .Font.Underline = wdUnderlineNone
        End With
    Next para
End Sub