Solved: Adding Bookmarks based on Style

[janaboo13]

Greetings all!
I have a macro that searches my document for a Style called "Heading 2" and in doing that, highlights the text (including the paragraph marker) which I then use for the bookmark name. I found the code for the latter part of the routine in the forum (thanks to Greg Maxey)!

As you can see in the code below, when I move the cursor over one character, I can omit the paragraph marker. It works except for a heading that has a ":" at the end of the text. So I need to include code to exclude that character when the text is highlighted.

Next, because our documents are published from a content management system, some column and page breaks are already inserted. Because of this, some of my headings, when selected, include the column or page break. In final cleanup, there may be an occasion to delete these breaks which would delete the bookmark, too. Obviously I don't want that to happen.

Ideally, I want just the Heading 2 text to be selected and the bookmark made with this text (excluding the para marker and breaks).

Next, I need search all Heading 2 styles and do the same thing. I'm assuming that I need code for a loop?

Any help would be appreciated!
Jan

Sub AddBookmarks()
'
' Macro1 Macro
'
'
Selection.Find.ClearFormatting
Selection.Find.Style = ActiveDocument.Styles("Heading 2")
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.CorrectHangulEndings = True
.HanjaPhoneticHangul = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = False
End With
Selection.Find.Execute
With Selection
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Call BookmarkSelectedText
Selection.Collapse Direction:=wdCollapseEnd
End With

End Sub
Sub BookmarkSelectedText()
Dim oStr As String
ActiveDocument.Bookmarks.Add MakeValidBMName(Selection.Range.Text), Selection.Range
End Sub
Function MakeValidBMName(strIn As String)
Dim pFirstChr As String
Dim i As Long
Dim tempStr As String
strIn = Trim(strIn)
pFirstChr = Left(strIn, 1)
If Not pFirstChr Like "[A-Za-z]" Then
strIn = "A_" & strIn
End If
For i = 1 To Len(strIn)
Select Case Asc(Mid$(strIn, i, 1))
Case 49 To 58, 65 To 90, 97 To 122
tempStr = tempStr & Mid$(strIn, i, 1)
Case Else
tempStr = tempStr & "_"
End Select
Next i
tempStr = Replace(tempStr, " ", " ")
MakeValidBMName = tempStr
End Function

[gmaxey]

Try:

Option Explicit
Sub AddBookmarks()
Dim oRng As Word.Range
Set oRng = ActiveDocument.Range
With oRng.Find
.ClearFormatting
.Text = ""
.Format = True
.Style = "Heading 2"
While .Execute
If .Found Then
If oRng.End = ActiveDocument.Range.End And Len(oRng.Text) < Len(ActiveDocument.Paragraphs.Last.Range.Text) Then
Exit Sub
End If
Do
Select Case Asc(oRng.Characters.Last)
Case "13", "58"
oRng.MoveEnd Unit:=wdCharacter, Count:=-1
Case Else
Exit Do
End Select
Loop
BookmarkoRngText oRng
oRng.Collapse Direction:=wdCollapseEnd
End If

Wend
End With
End Sub
Sub BookmarkoRngText(ByRef oRngBM As Word.Range)
ActiveDocument.Bookmarks.Add MakeValidBMName(oRngBM.Text), oRngBM
End Sub
Function MakeValidBMName(strIn As String) As String
Dim pFirstChr As String
Dim i As Long
Dim tempStr As String
strIn = Trim(strIn)
pFirstChr = Left(strIn, 1)
If Not pFirstChr Like "[A-Za-z]" Then
strIn = "A_" & strIn
End If
For i = 1 To Len(strIn)
Debug.Print Asc(Mid$(strIn, i, 1))
Select Case Asc(Mid$(strIn, i, 1))

Case 49 To 57, 65 To 90, 97 To 122
tempStr = tempStr & Mid$(strIn, i, 1)
Case Else
tempStr = tempStr & "_"
End Select
Next i
tempStr = Replace(tempStr, " ", " ")
MakeValidBMName = tempStr
End Function

[janaboo13]

Hi Greg!
Thanks soooo much for this. Works great, except for one thing...for the Heading 2s that include a column or page break, I'd like to exclude those breaks from the Bookmark and haven't a clue how to do that!

And actually, is it possible to find the Heading 2 style, copy the text, and then insert the bookmark either after the text or at the start of the text? Clearly out of my realm of expertise, here, so if you can help with that, it would awesome!

Now, for the next hurdle...I have four other Heading styles that I would like to create bookmarks for and don't know if I need a seperate macro for each style or is there a way to do "if, then" code to handle that in the current macro. Any ideas?

Thanks, again...Jan

[gmaxey]

I don't follow the issue with column/page breaks. Why would they be contained in your heading text?

As for the other issues, try:

Option Explicit
Sub AddBookmarks()
Dim i As Long
Dim oRng As Word.Range
For i = 1 To 4
Set oRng = ActiveDocument.Range
With oRng.Find
.ClearFormatting
.Text = ""
.Format = True
.Style = Choose(i, "Heading 1", "Heading 2", "Heading 3", "Heading 4")
While .Execute
If .Found Then
If oRng.End = ActiveDocument.Range.End And Len(oRng.Text) < Len(ActiveDocument.Paragraphs.Last.Range.Text) Then
Exit Sub
End If
Do
oRng.Select
Select Case Asc(oRng.Characters.Last)
Case "13", "58"
oRng.MoveEnd Unit:=wdCharacter, Count:=-1
Case Else
Exit Do
End Select
Loop
BookmarkoRngText oRng
oRng.Collapse Direction:=wdCollapseEnd
End If

Wend
End With
Next i
End Sub
Sub BookmarkoRngText(ByRef oRngBM As Word.Range)
Dim strBMName As String
Dim oRngToBM As Word.Range
strBMName = MakeValidBMName(oRngBM.Text)
Set oRngToBM = oRngBM.Duplicate
oRngToBM.Collapse wdCollapseStart
ActiveDocument.Bookmarks.Add strBMName, oRngToBM
End Sub
Function MakeValidBMName(strIn As String) As String
Dim pFirstChr As String
Dim i As Long
Dim tempStr As String
strIn = Trim(strIn)
pFirstChr = Left(strIn, 1)
If Not pFirstChr Like "[A-Za-z]" Then
strIn = "A_" & strIn
End If
For i = 1 To Len(strIn)
Select Case Asc(Mid$(strIn, i, 1))

Case 49 To 57, 65 To 90, 97 To 122
tempStr = tempStr & Mid$(strIn, i, 1)
Case Else
tempStr = tempStr & "_"
End Select
Next i
tempStr = Replace(tempStr, " ", " ")
MakeValidBMName = tempStr
End Function

[janaboo13]

Greg, you rock! Thanks so much for solving this for me. The only thing I changed was the placement of the bookmark (at the end of the text), which has made my issue with the breaks go away! I inserted all the heading styles I needed, changed the i = 1 to 8 and voila!

The only thing I noticed was one Heading 3 that it didn't mark. I think it's because it's the same name as a previous one in a different section...could that be right? Is there a way to fix that?

:bow:
Jan

[gmaxey]

Jan,

Since each bookmark has to have a unique name, you might modify your MakeValidBMName procedure to ensure a unique name. See if you can work it out using this little demo (hint, the "key" is key to the whole thing):

Option Explicit
Dim colBMNames As Collection
Sub Demo()
Dim i As Long
Set colBMNames = New Collection
On Error GoTo Err_Duplicate
For i = 1 To 10
colBMNames.Add "Test", "Test"
Err_ReEntry:
Next i
For i = 1 To colBMNames.Count
Debug.Print colBMNames(i)
Next i
lbl_Exit:
Exit Sub
Err_Duplicate:
colBMNames.Add "Test " & i, "Test " & i
Resume Err_ReEntry
End Sub

[janaboo13]

Hi Greg!

OK...I'm totally lost..could be it's Monday morning! If I had some comments explaining what each section of the code was doing, I might be able to figure it out. I sort of get what's going on, but I'm not sure how to modify the MakeValidBMName function code to incorporate this....help!

Jan

[gmaxey]

Since a bookmark must have a unique name you can't have two or more with the same name. Since your MakeValidBMName is already doing part of the work just modify it detect any attempt to create a duplicate name. You can use a collection to do that because if you set the key then it will error if you try to duplicate the key:

Option Explicit
Private colNames As Collection
Sub InitializeCol()
Set colNames = New Collection
End Sub
Sub Test()
Dim lngCount As Long
For lngCount = 1 To 5
MsgBox MakeValidBMName("Test")
Next lngCount
End Sub
Function MakeValidBMName(strIn As String) As String
Dim pFirstChr As String
Dim i As Long
Dim tempStr As String
strIn = Trim(strIn)
pFirstChr = Left(strIn, 1)
If Not pFirstChr Like "[A-Za-z]" Then
strIn = "A_" & strIn
End If
For i = 1 To Len(strIn)
Select Case Asc(Mid$(strIn, i, 1))
Case 49 To 57, 65 To 90, 97 To 122
tempStr = tempStr & Mid$(strIn, i, 1)
Case Else
tempStr = tempStr & "_"
End Select
Next i
tempStr = Replace(tempStr, " ", " ")
On Error GoTo Err_Duplicate
colNames.Add tempStr, tempStr
MakeValidBMName = tempStr
Err_ReEntry:
Exit Function
Err_Duplicate:
MakeValidBMName = tempStr & " " & Rnd
Resume Err_ReEntry
End Function

[janaboo13]

Hi Greg,

Well, I'm more lost than I was...here's my code so far with your most recent enhancement:

Option Explicit
Sub AddBookmarks()
Dim i As Long
Dim oRng As Word.Range
For i = 1 To 8
Set oRng = ActiveDocument.Range
With oRng.Find
.ClearFormatting
.Text = ""
.Format = True
.Style = Choose(i, "Heading 2", "Heading 2 - Caution", "Heading 2 - Continue Step Numbering", "Heading 2 In Table", "Heading 2 Line Below", "Heading 3", "Heading 3 - Caution", "Heading 3 - Continue Step Numbering")
While .Execute
If .Found Then
If oRng.End = ActiveDocument.Range.End And Len(oRng.Text) < Len(ActiveDocument.Paragraphs.Last.Range.Text) Then
Exit Sub
End If
Do
oRng.Select
Select Case Asc(oRng.Characters.Last)
Case "13", "58"
oRng.MoveEnd Unit:=wdCharacter, Count:=-1
Case Else
Exit Do
End Select
Loop
BookmarkoRngText oRng
oRng.Collapse Direction:=wdCollapseEnd
End If

Wend
End With
Next i
End Sub
Sub BookmarkoRngText(ByRef oRngBM As Word.Range)
Dim strBMName As String
Dim oRngToBM As Word.Range
strBMName = MakeValidBMName(oRngBM.Text)
Set oRngToBM = oRngBM.Duplicate
oRngToBM.Collapse wdCollapseEnd
ActiveDocument.Bookmarks.Add strBMName, oRngToBM
End Sub

Private colNames As Collection
Sub InitializeCol()
Set colNames = New Collection
End Sub
Sub Test()
Dim lngCount As Long
For lngCount = 1 To 5
MsgBox MakeValidBMName("Test")
Next lngCount
End Sub
Function MakeValidBMName(strIn As String) As String
Dim pFirstChr As String
Dim i As Long
Dim tempStr As String
strIn = Trim(strIn)
pFirstChr = Left(strIn, 1)
If Not pFirstChr Like "[A-Za-z]" Then
strIn = "A_" & strIn
End If
For i = 1 To Len(strIn)
Select Case Asc(Mid$(strIn, i, 1))
Case 49 To 57, 65 To 90, 97 To 122
tempStr = tempStr & Mid$(strIn, i, 1)
Case Else
tempStr = tempStr & "_"
End Select
Next i
tempStr = Replace(tempStr, " ", " ")
On Error GoTo Err_Duplicate
colNames.Add tempStr, tempStr
MakeValidBMName = tempStr
Err_ReEntry:
Exit Function
Err_Duplicate:
MakeValidBMName = tempStr & " " & Rnd
Resume Err_ReEntry
End Function


Every time I run this, I get an error message and "Private colNames As Collection" is highlighted:

Compile error:
Only comments may apear after End Sub, End Function, or End Property

I also removed Option Explicit as it was causing an error, too.

Do I have everything in the right place?

While I get (at a basic level) what you're trying to do, I'm at a loss on how to fix it...sigh.

Suggestions?

Thanks so much! Jan

[gmaxey]

Jan,

I may not be able to get back to this again for a few days. Hopefully this will clear is up:

Option Explicit
Private colNames As Collection
Sub AddBookmarks()

Dim i As Long
Dim oRng As Word.Range
InitializeCol
For i = 1 To 8
Set oRng = ActiveDocument.Range
With oRng.Find
.ClearFormatting
.Text = ""
.Format = True
.Style = Choose(i, "Heading 2", "Heading 2 - Caution", "Heading 2 - Continue Step Numbering", "Heading 2 In Table", "Heading 2 Line Below", "Heading 3", "Heading 3 - Caution", "Heading 3 - Continue Step Numbering")
While .Execute
If .Found Then
If oRng.End = ActiveDocument.Range.End And Len(oRng.Text) < Len(ActiveDocument.Paragraphs.Last.Range.Text) Then
Exit Sub
End If
Do
oRng.Select
Select Case Asc(oRng.Characters.Last)
Case "13", "58"
oRng.MoveEnd Unit:=wdCharacter, Count:=-1
Case Else
Exit Do
End Select
Loop
BookmarkoRngText oRng
oRng.Collapse Direction:=wdCollapseEnd
End If

Wend
End With
Next i
End Sub
Sub BookmarkoRngText(ByRef oRngBM As Word.Range)
Dim strBMName As String
Dim oRngToBM As Word.Range
strBMName = MakeValidBMName(oRngBM.Text)
Set oRngToBM = oRngBM.Duplicate
oRngToBM.Collapse wdCollapseEnd
ActiveDocument.Bookmarks.Add strBMName, oRngToBM
End Sub

Sub InitializeCol()
Set colNames = New Collection
End Sub
Function MakeValidBMName(strIn As String) As String
Dim pFirstChr As String
Dim i As Long
Dim tempStr As String
strIn = Trim(strIn)
pFirstChr = Left(strIn, 1)
If Not pFirstChr Like "[A-Za-z]" Then
strIn = "A_" & strIn
End If
For i = 1 To Len(strIn)
Select Case Asc(Mid$(strIn, i, 1))
Case 49 To 57, 65 To 90, 97 To 122
tempStr = tempStr & Mid$(strIn, i, 1)
Case Else
tempStr = tempStr & "_"
End Select
Next i
Err_ReEntry:
tempStr = Replace(tempStr, " ", "_")
tempStr = Replace(tempStr, ".", "_")
On Error GoTo Err_Duplicate
colNames.Add tempStr, tempStr
MakeValidBMName = tempStr
Exit Function
Err_Duplicate:
tempStr = tempStr & "_" & Rnd
Resume Err_ReEntry
End Function

[janaboo13]

No worries, Greg....I'm off for a week beginning Friday.

I'll be testing this tomorrow and I'll let you know what happens.

Thanks so much for all your help!

Jan

[janaboo13]

Hi Greg!
Couldn't wait to tell you that it works like a charm...now I just need to study it to understand how to do that in the future.

Can't tell you how much I appreciate your time and hard work!
Jan :bow: :bow:

[gmaxey]

Jan,

When you use the "key" attribute (I guess that is what is is called) with a collection then when you try to add something that is already in the collection it throws and error. So, trap the error and change that something to something else. Then add the new something to the collection. Voila.