The Longest Code - Lotus Notes and Domino and VB: September 2025

Sub AKDeleteEmptyRows_AllTables()

Dim oTable As Table

Dim oRow As Row

Dim intRowCount As Integer

For Each oTable In ActiveDocument.Tables

'Check whether row is empty - delete if it is

'ATK 1/6/2024 what does * 2 + 2 mean??????

'first fo any nested tables

For Each nestedTable In oTable.Tables

intRowCount = nestedTable.Rows.Count

For Each nestedRow In nestedTable.Rows

If Len(nestedRow.Range.Text) = nestedRow.Cells.Count * 2 + 2 Then

nestedRow.Delete

End If

Next nestedRow

Next nestedTable

For Each oRow In oTable.Rows

oRow.Select

intRowCount = oTable.Rows.Count

oRow.Select

If Len(oRow.Range.Text) = oRow.Cells.Count * 2 + 2 Then

oRow.Delete

End If

Next oRow

Next oTable

Exit Sub

End Sub 'AKDeleteEmptyRows_AllTables()

Sub AKRemoveSpacesAndLines()

' AKRemoveSpacesAndLines Macro

Selection.Find.ClearFormatting

Selection.Find.Replacement.ClearFormatting

With Selection.Find

.Text = "2024-??-*:??:??"

.Replacement.Text = " "

.Forward = True

.Wrap = wdFindContinue

.Format = False

.MatchCase = False

.MatchWholeWord = False

.MatchWildcards = False

.MatchSoundsLike = False

.MatchAllWordForms = False

End With

Selection.Find.Execute Replace:=wdReplaceAll

Selection.Find.ClearFormatting

Selection.Find.Replacement.ClearFormatting

With Selection.Find

.Text = "2024-??-*:??:??"

.Replacement.Text = " "

.Forward = True

.Wrap = wdFindContinue

.Format = False

.MatchCase = False

.MatchWholeWord = False

.MatchAllWordForms = False

.MatchSoundsLike = False

.MatchWildcards = True

End With

Selection.Find.Execute Replace:=wdReplaceAll

Selection.Copy

Selection.Find.ClearFormatting

Selection.Find.Replacement.ClearFormatting

With Selection.Find

.Text = "________________________________________"

.Replacement.Text = " "

.Forward = True

.Wrap = wdFindContinue

.Format = False

.MatchCase = False

.MatchWholeWord = False

.MatchAllWordForms = False

.MatchSoundsLike = False

.MatchWildcards = True

End With

Selection.Find.Execute Replace:=wdReplaceAll

Selection.Find.ClearFormatting

Selection.Find.Replacement.ClearFormatting

With Selection.Find

.Text = "^p^p"

.Replacement.Text = "~!@#"

.Forward = True

.Wrap = wdFindContinue

.Format = False

.MatchCase = False

.MatchWholeWord = False

.MatchWildcards = False

.MatchSoundsLike = False

.MatchAllWordForms = False

End With

Selection.Find.Execute Replace:=wdReplaceAll

ActiveWindow.ActivePane.View.ShowAll = Not ActiveWindow.ActivePane.View. _

ShowAll

Selection.Find.ClearFormatting

Selection.Find.Replacement.ClearFormatting

With Selection.Find

.Text = "^p ^p"

.Replacement.Text = "~!@#"

.Forward = True

.Wrap = wdFindContinue

.Format = False

.MatchCase = False

.MatchWholeWord = False

.MatchWildcards = False

.MatchSoundsLike = False

.MatchAllWordForms = False

End With

Selection.Find.Execute Replace:=wdReplaceAll

With Selection.Find

.Text = "^p"

.Replacement.Text = " "

.Forward = True

.Wrap = wdFindContinue

.Format = False

.MatchCase = False

.MatchWholeWord = False

.MatchWildcards = False

.MatchSoundsLike = False

.MatchAllWordForms = False

End With

Selection.Find.Execute Replace:=wdReplaceAll

With Selection.Find

.Text = "~!@#"

.Replacement.Text = "^p^p"

.Forward = True

.Wrap = wdFindContinue

.Format = False

.MatchCase = False

.MatchWholeWord = False

.MatchWildcards = False

.MatchSoundsLike = False

.MatchAllWordForms = False

End With

Selection.Find.Execute Replace:=wdReplaceAll

End Sub

Sub AKMakeTrueTitleCaseHeading1s()

' AKMakeTrueTitleCaseHeading1- Ones -

' was called Sub Heading1MakeTitle()

' Calls TitleCase procedure

' Paul Edstein

' http://www.msofficeforums.com/word/24807-how-do-i-convert-line-text-title.html#post78192

' Makes all Heading 1 text title case ' I think I have to select all text....

Application.ScreenUpdating = False

Dim StrTmp As String

With ActiveDocument.Range

With .Find

Let .MatchWildcards = True

.ClearFormatting

.Replacement.ClearFormatting

Let .Format = True

Let .Wrap = wdFindStop

.Execute Replace:=wdReplaceAll

Let .Style = "Heading 1"

Let .Text = "[!^13]{1,}"

Let .Replacement.Text = ""

.Execute

End With

Do While .Find.Found

StrTmp = Trim(.Text)

While Right(StrTmp, 1) = "."

Let StrTmp = Left(StrTmp, Len(StrTmp) - 1)

Wend

While InStr(StrTmp, " ") > 0

Let StrTmp = Replace(StrTmp, " ", " ")

Wend

StrTmp = TitleCase(StrTmp, bCaps:=False, blExcludeCertainWords:=True)

Let .Text = StrTmp

.Collapse wdCollapseEnd

.Find.Execute

Loop

End With

Application.ScreenUpdating = True

End Sub ' AK make all headings 1s true title case

Sub MakeTitle()

' Calls TitleCase procedure

' Paul Edstein

' http://www.msofficeforums.com/word/24807-how-do-i-convert-line-text-title.html#post78192

' Converts selected text to true Title Case

Application.ScreenUpdating = False

Dim StrTmp As String

With Selection.Range

Let StrTmp = Trim(.Text)

While Right(StrTmp, 1) = "."

Let StrTmp = Left(StrTmp, Len(StrTmp) - 1)

Wend

While InStr(StrTmp, " ") > 0

Let StrTmp = Replace(StrTmp, " ", " ")

Wend

Let StrTmp = TitleCase(StrTmp, bCaps:=False, blExcludeCertainWords:=True)

.Text = StrTmp

End With

Let Application.ScreenUpdating = True

End Sub

Private Function TitleCase(StrTxt As String, Optional bCaps As Boolean, Optional bClos As Boolean, Optional blExcludeCertainWords As Boolean) As String

' Paul Edstein

' http://www.msofficeforums.com/word/24807-how-do-i-convert-line-text-title.html#post78192

' December 2016

' Goes with MakeTitle and HeadingMakeTitle macros

' Added Let to beginning of variable definitions CKK 2018-10-07

'Convert an input string to proper-case.

'Surnames like O', Mc & Mac and hyphenated names are converted to title case also.

'If bCaps = True, then upper-case strings like ABC are preserved; otherwise they're converted.

'If bClos = False, words in the exclusion list after closing characters are retained as lower-case; otherwise they're converted.

'If blExcludeCertainWords = True, words in the exclusion list are retained as lower-case, unless after specified punctuation marks.

Dim i As Long, j As Long, k As Long, l As Long, bFnd As Boolean

Dim StrChr As String, StrExcl As String, StrMac As String, StrPunct As String, StrTmpA As String, StrTmpB As String

'General exclusion list.

Let StrExcl = "(a),a,am,an,and,are,as,at,(b),be,but,by,(c),can,cm,(d),did,do,does,(e),eg,en,eq,etc,(f),for," & _

"(g),get,go,got,(h),has,have,he,her,him,how,(i),ie,if,in,into,is,it,its,(j),(k),(l),(m),me,mi," & _

"mm,my,(n),na,nb,no,not,(o),of,off,ok,on,one,or,our,out,(p),(q),(r),re,(s),she,so,(t),the," & _

"their,them,they,this,to,(u),(v),via,vs,(w),was,we,were,who,will,with,would,(x),(y),yd,you,your,(z)"

'Mac name lower-case list.

Let StrMac = "Macad,Macau,Macaq,Macaro,Macass,Macaw,Maccabee,Macedon,Macerate,Mach,Mack,Macle,Macrame,Macro,Macul,Macumb"

Let StrPunct = "!,;,:,.,?,/,(,{,[,<,“,"""

If bClos = True Then StrPunct = StrPunct & ",),},],>,”"

If blExcludeCertainWords = False Then

Let StrExcl = ""

Let StrPunct = ""

Else

Let StrExcl = " " & Replace(Trim(StrExcl), ",", " , ") & " "

End If

If Len(Trim(StrTxt)) = 0 Then

Let TitleCase = StrTxt

Exit Function

End If

If bCaps = False Then StrTxt = LCase(StrTxt)

StrTxt = " " & StrTxt & " "

For i = 1 To UBound(Split(StrTxt, " ")) - 1

Let StrTmpA = Split(StrTxt, " ")(i)

'Check for a double-quote before the word

If Left(StrTmpA, 1) Like "[""“”]" Then

Let StrTmpB = UCase(Left(StrTmpA, 2)) & Right(StrTmpA, Len(StrTmpA) - 2)

Else

Let StrTmpB = UCase(Left(StrTmpA, 1)) & Right(StrTmpA, Len(StrTmpA) - 1)

End If

Let StrTmpB = " " & StrTmpB & " "

Let StrTmpA = " " & StrTmpA & " "

Let StrTxt = Replace(StrTxt, StrTmpA, StrTmpB)

'Code for handling hyphenated words

For i = 1 To UBound(Split(StrTxt, "-"))

Let StrTmpA = Split(StrTxt, "-")(i)

Let StrTmpB = UCase(Left(StrTmpA, 1)) & Right(StrTmpA, Len(StrTmpA) - 1)

Let StrTxt = Replace(StrTxt, StrTmpA, StrTmpB)

'Code for handling family names starting with O'

For i = 1 To UBound(Split(StrTxt, "'"))

If InStr(Right(Split(StrTxt, "'")(i - 1), 2), " ") = 1 Or _

Right(Split(StrTxt, "'")(i - 1), 2) = Right(Split(StrTxt, "'")(i - 1), 1) Then

Let StrTmpA = Split(StrTxt, "'")(i)

Let StrTmpB = UCase(Left(StrTmpA, 1)) & Right(StrTmpA, Len(StrTmpA) - 1)

Let StrTxt = Replace(StrTxt, StrTmpA, StrTmpB)

End If

'Code for handling family names starting with Mc

If Left(StrTxt, 2) = "Mc" Then

Let Mid(StrTxt, 3, 1) = UCase(Mid(StrTxt, 3, 1))

End If

Let i = InStr(StrTxt, " Mc") + InStr(StrTxt, """Mc")

If i > 0 Then

Let Mid(StrTxt, i + 3, 1) = UCase(Mid(StrTxt, i + 3, 1))

End If

'Code for handling family names starting with Mac

If InStr(1, StrTxt, "Mac", vbBinaryCompare) > 0 Then

For i = 1 To UBound(Split(StrTxt, " "))

Let StrTmpA = Split(StrTxt, " ")(i)

If InStr(1, StrTmpA, "Mac", vbBinaryCompare) > 0 Then

Let StrTmpA = Left(StrTmpA, Len(StrTmpA) - InStr(1, StrTmpA, "Mac", vbBinaryCompare) + 1)

Let bFnd = False

For j = 0 To UBound(Split(StrMac, ","))

Let StrTmpB = Split(StrMac, ",")(j)

If Left(StrTmpA, Len(StrTmpB)) = StrTmpB Then

Let bFnd = True

Exit For

End If

If bFnd = False Then

If Len(Split(Trim(StrTmpA), " ")(0)) > 4 Then

Let StrTmpB = StrTmpA

Let Mid(StrTmpB, 4, 1) = UCase(Mid(StrTmpB, 4, 1))

Let StrTxt = Replace(StrTxt, StrTmpA, StrTmpB)

End If

'Code to restore excluded words to lower case

If StrExcl <> "" Then

For i = 0 To UBound(Split(StrExcl, ","))

Let StrTmpA = Split(StrExcl, ",")(i)

Let StrTmpB = UCase(Left(StrTmpA, 2)) & Right(StrTmpA, Len(StrTmpA) - 2)

If InStr(StrTxt, StrTmpB) > 0 Then

Let StrTxt = Replace(StrTxt, StrTmpB, StrTmpA)

'Make sure an excluded words following punctution marks are given proper case anyway

For j = 0 To UBound(Split(StrPunct, ","))

Let StrChr = Split(StrPunct, ",")(j)

Let StrTxt = Replace(StrTxt, StrChr & StrTmpA, StrChr & StrTmpB)

End If

Let TitleCase = Trim(StrTxt)

End Function ' TitleCase

Sub ConvertURLsToHyperlinks()

Dim rng As Range

Dim i As Long

Dim urlPattern As String

Dim urlMatch As Object

Dim url As String

Dim para As Paragraph

' Regular expression pattern to match URLs

urlPattern = "(http|https)://[a-zA-Z0-9./?=_-]+"

' Loop through each paragraph in the document

For Each para In ActiveDocument.Paragraphs

Set rng = para.Range

Set urlMatch = Nothing

' Use Regular Expressions to find URLs

With CreateObject("VBScript.RegExp")

.Pattern = urlPattern

.Global = True

If .Test(rng.Text) Then

Set urlMatch = .Execute(rng.Text)

' Loop through all matches

For i = 0 To urlMatch.Count - 1

url = urlMatch(i).Value

rng.Hyperlinks.Add Anchor:=rng, Address:=url, TextToDisplay:=url

Next i

End If

End With

Next para

End Sub ' createallhyperlinks

The Longest Code - Lotus Notes and Domino and VB

Friday, 12 September 2025

Microsoft word VBA functions 2025

Blog Archive