Clear UTM references in MS Word
Attribute VB_Name = "DOC_Links"
' Module: UTM_Cleaner.bas
Option Explicit
Option Compare Text
Public Sub CleanUTM()
Dim doc As Document: Set doc = ActiveDocument
Dim sr As Range, rng As Range
Dim hl As Hyperlink
Dim ils As InlineShape
Dim shp As Shape
Dim sec As Section, hf As headerFooter
Dim fixed As Long
Application.ScreenUpdating = False
' All story ranges
For Each sr In doc.StoryRanges
Set rng = sr
Do
For Each hl In rng.Hyperlinks
fixed = fixed + CleanOneHyperlink(hl)
Next hl
For Each ils In rng.InlineShapes
On Error Resume Next
If Not ils.Hyperlink Is Nothing Then fixed = fixed + CleanOneHyperlink(ils.Hyperlink)
On Error GoTo 0
Next ils
Set rng = rng.NextStoryRange
Loop Until rng Is Nothing
Next sr
' Top-level shapes in main doc
For Each shp In doc.Shapes
CleanShapeLinks shp, fixed
Next shp
' Shapes in headers and footers
For Each sec In doc.Sections
For Each hf In sec.Headers
For Each shp In hf.Shapes
CleanShapeLinks shp, fixed
Next shp
Next hf
For Each hf In sec.Footers
For Each shp In hf.Shapes
CleanShapeLinks shp, fixed
Next shp
Next hf
Next sec
Application.ScreenUpdating = True
MsgBox "Hyperlinks updated: " & fixed, vbInformation, "UTM cleanup"
End Sub
Private Sub CleanShapeLinks(ByVal shp As Shape, ByRef fixed As Long)
On Error Resume Next
If Not shp Is Nothing Then
If Not shp.Hyperlink Is Nothing Then fixed = fixed + CleanOneHyperlink(shp.Hyperlink)
If shp.TextFrame.HasText Then
Dim hl As Hyperlink
For Each hl In shp.TextFrame.TextRange.Hyperlinks
fixed = fixed + CleanOneHyperlink(hl)
Next hl
End If
End If
On Error GoTo 0
End Sub
'--- Regex-based cleaner for utm_source in any position.
Private Function CleanOneHyperlink(ByRef hl As Hyperlink) As Long
Dim addrOld As String, addrNew As String
If hl Is Nothing Then Exit Function
addrOld = NzStr(hl.Address)
If Len(addrOld) = 0 Then Exit Function ' Why: non-web links can store only SubAddress.
addrNew = RemoveUtmSource(addrOld)
If StrComp(addrOld, addrNew, vbBinaryCompare) <> 0 Then
hl.Address = addrNew
CleanOneHyperlink = 1
End If
End Function
'--- Removes utm_source and normalizes delimiters. Uses a *local* RegExp to avoid the error you hit.
Private Function RemoveUtmSource(ByVal url As String) As String
Dim s As String: s = url
Dim rx As Object ' VBScript_RegExp_55.RegExp or VBScript.RegExp
Set rx = CreateRegex()
If rx Is Nothing Then
RemoveUtmSource = url
Exit Function
End If
rx.Global = True
rx.Multiline = False
rx.IgnoreCase = True
' First param, followed by others: "?utm_source=...&" -> "?"
rx.pattern = "\?utm_source=[^&#]*&"
s = rx.Replace(s, "?")
' Middle param: "&utm_source=...&" -> "&"
rx.pattern = "&utm_source=[^&#]*&"
s = rx.Replace(s, "&")
' Trailing param: "&utm_source=...$" -> ""
rx.pattern = "&utm_source=[^&#]*$"
s = rx.Replace(s, "")
' Only/last (first position): "?utm_source=...$" -> ""
rx.pattern = "\?utm_source=[^&#]*$"
s = rx.Replace(s, "")
' Cleanup leftovers
rx.IgnoreCase = False
rx.pattern = "\?\&": s = rx.Replace(s, "?")
rx.pattern = "\&{2,}": s = rx.Replace(s, "&")
rx.pattern = "[\?\&]$": s = rx.Replace(s, "")
RemoveUtmSource = s
End Function
'--- Late-bound creator with fallback ProgIDs.
Private Function CreateRegex() As Object
On Error Resume Next
Set CreateRegex = CreateObject("VBScript.RegExp")
If CreateRegex Is Nothing Then
Set CreateRegex = CreateObject("VBScript_RegExp_55.RegExp")
End If
On Error GoTo 0
End Function
Private Function NzStr(ByVal v As Variant) As String
If IsNull(v) Or IsEmpty(v) Then
NzStr = ""
Else
NzStr = CStr(v)
End If
End Function
Comments
Post a Comment