#1
|
|||
|
|||
Scripture Index
Good day,
Has anyone written Word Macro to pick up all Bible references (e.g. Genesis 5, Genesis 6:3, Ge. 5:1, Ps. 51:3, etc.) and to generate an automatic index for the document? Regards, Willem Swanepoel |
#2
|
||||
|
||||
Try the Prepare_Bible_Refs and Tabulate_Bible_Refs macros below.
The first thing to note is that the code looks for Bible book references in a specific format (e.g. Gen. for Genesis), as defined in 'StrBks'. If yours are different, you can edit the definitions in 'StrBks' to suit. The code also requires books beginning with numerals (e.g. 1 Ki.) to have a non-breaking space between the numeral and the book's (abbreviated) name. If your document doesn't already use non-breaking spaces there, you can correct that before running the macros via a wildcard Find/Replace, where: Find = (<[1-3]) ([CJKPST][a-z]@>) Replace = \1^s\2 This also has the advantage of ensuring book references like '1 Ki.', '2|Tim.', etc., are kept together on the same line. The next thing to note is that the Tabulate_Bible_Refs macro, which actually builds the index table, doesn't handle the second & subsequent references in sequences like Gen. 1:1, 5; 3:7, etc. That's where the Prepare_Bible_Refs macro comes in. The Prepare_Bible_Refs turns sequences like Gen. 1:1, 5; 3:7 into Gen. 1:1, Gen. 1:5; Gen. 3:7, but with the red text formatted as hidden so it doesn't compromise the existing layout. Finally, by default, the output is sent to a single-column table at the end of the document. If you want it to appear somewhere else, select that location and apply a bookmark named '_Bible_Refs' to it. And, if you want a multi-column layout, format that portion of your document with as many columns as you need. On Letter/A4 paper, a 3-column layout works well for this. Although you need them, you don't need to run the MakeDupes, HideDupes, & ApplyStyle macros in the last code block below - they're called automatically as needed. Code:
Option Explicit Dim StrBks As String Sub Prepare_Bible_Refs() Application.ScreenUpdating = False ' This macro checks the body of a document for biblical verses ' and applies a custom 'Ref' character Style to them. It is ' assumed books beginning with numerals have a non-breaking ' space between the numeral and the book's (abbreviated) name. ' ' Consecutive verse refs are all fully expressed (e.g. ' Acts 1:1; 2:3, 14 becomes Acts 1:1; Acts 2:3, Acts 2:14). ' The macro then formats the added text as hidden, so it can ' be suppressed for display & print purposes. ' It is also coloured red for an added visual queue. ' ' After running the macro, you may want to remove the 'Ref' Style ' from some verses (e.g. in quoted text where the book names are ' not abbreviated) before running the tabulation macro. StrBks = Replace(",Gen.,Ex.,Lev.,Num.,Deut.,Josh.,Judges,Ruth,1|Sam.,2|Sam.," & _ "1|Ki.,2|Ki.,1|Chr.,2|Chr.,Ezra,Neh.,Esth.,Job,Ps.,Prov.,Eccl.,Song,Is.,Jer.,Lam.," & _ "Ezek.,Dan.,Hos.,Joel,Amos,Obad.,Jonah,Mic.,Nah.,Hab.,Zeph.,Hagg.,Zech.,Mal.,Matt.," & _ "Mark,Luke,John,Acts,Rom.,1|Cor.,2|Cor.,Gal.,Eph.,Phil.,Col.,1|Thess.,2|Thess.," & _ "1|Tim.,2|Tim.,Tit.,Phlm.,Heb.,Jas.,1|Pet.,2|Pet.,1|John,2|John,3|John,Jude,Rev.,", "|", Chr(160)) Dim Doc As Document, FNt As Footnote, ENt As Endnote Set Doc = ActiveDocument ' Add the 'Ref' Style if not already present On Error Resume Next Doc.Styles.Add Name:="Ref", Type:=wdStyleTypeCharacter On Error GoTo 0 ' Duplicate book/chapter refs for repeated bible verses. Call MakeDupes(Doc, Replace("<[1-3]^s[A-Z][a-z.]{2|5} [0-9]{1|}:[! .,;”\)]{1|}[;,]", "|", Application.International(wdListSeparator))) Call MakeDupes(Doc, Replace("<[A-Z][a-z.]{2|5} [0-9]{1|}:[!^s .,;”\)]{1|}[;,]", "|", Application.International(wdListSeparator))) ' Apply the 'Ref' Style to all bible verses. Call ApplyStyle(Doc, Replace("<[1-3]^s[A-Z][a-z.]{2|5} [0-9]{1|}:[!^s .,;\:”'’\)]{1|}", "|", Application.International(wdListSeparator))) Call ApplyStyle(Doc, Replace("<[A-Z][a-z.]{2|5} [0-9]{1|}:[! .,;\:”'’\)]{1|}", "|", Application.International(wdListSeparator))) ' Hide book/chapter refs for repeated bible verses. Call HideDupes(Doc, Replace("(<[1-3]^s[A-Z][a-z.]{2|5}) [0-9]{1|}:[!^s .,;”\)]{1|}[;,] \1", "|", Application.International(wdListSeparator))) Call HideDupes(Doc, Replace("(<[A-Z][a-z.]{2|5}) [0-9]{1|}:[!^s .,;”\)]{1|}[;,] \1", "|", Application.International(wdListSeparator))) ' Repair footnote & endnote references For Each FNt In Doc.Footnotes FNt.Reference.Style = "Footnote Reference" Next For Each ENt In Doc.Endnotes ENt.Reference.Style = "Endnote Reference" Next End Sub Code:
Sub Tabulate_Bible_Refs() Application.ScreenUpdating = False ' This macro checks the body of a document for biblical verses ' formatted in the custom 'Ref' character Style. These refs are ' then tallied and their page references output to a table at the ' end of the document, showing the page #s on which they occur. Dim Doc As Document, RngStry As Range, Rng As Range, Tbl As Table, Pg As Page, Rct As Rectangle Dim StrTerms As String, StrFnd As String, StrPages As String, ArrPgs() As String Dim StrOut As String, StrTmp As String, ColWdth As Single Dim i As Long, j As Long, k As Long, p As Long, bHid As Boolean, bFnd As Boolean Const StrBkMk As String = "_Bible_Refs" ColWdth = CentimetersToPoints(5.25) StrPages = "": StrPages = "": StrTerms = vbCr bHid = ActiveWindow.View.ShowHiddenText ActiveWindow.View.ShowHiddenText = True Set Doc = ActiveDocument 'Go through the document looking for biblical verse refs. With Doc 'Check whether our table exists. If so, delete it. With .Range If .Bookmarks.Exists(StrBkMk) Then Set Rng = .Bookmarks(StrBkMk).Range If Rng.Tables.Count > 0 Then Rng.Tables(1).Delete Else Set Rng = .Characters.Last End If End With .Bookmarks.Add StrBkMk, Rng For Each RngStry In .StoryRanges Select Case RngStry.StoryType Case wdEndnotesStory, wdFootnotesStory, wdMainTextStory With RngStry With .Find .ClearFormatting .Replacement.ClearFormatting .Format = True .MatchWildcards = True .Text = "" .Replacement.Text = "" .Style = "Ref" .Wrap = wdFindStop .MatchWildcards = True .Execute End With Do While .Find.Found = True StrTmp = .Text ' Pad small Chapter & Verse #s with leading 0s If Split(StrTmp, " ")(0) = "Ps." Then If Len(Split(Split(StrTmp, " ")(1), ":")(0)) = 1 Then StrTmp = Split(StrTmp, " ")(0) & " 00" & Split(StrTmp, " ")(1) ElseIf Len(Split(Split(StrTmp, " ")(1), ":")(0)) = 2 Then StrTmp = Split(StrTmp, " ")(0) & " 0" & Split(StrTmp, " ")(1) End If If Len(Split(Split(StrTmp, ":")(1), "-")(0)) = 1 Then StrTmp = Split(StrTmp, ":")(0) & ":0" & Split(StrTmp, ":")(1) ElseIf Len(Split(Split(StrTmp, ":")(1), "-")(0)) = 2 Then StrTmp = Split(StrTmp, ":")(0) & ":00" & Split(StrTmp, ":")(1) End If ElseIf Len(Split(Split(StrTmp, " ")(1), ":")(0)) = 1 Then StrTmp = Split(StrTmp, " ")(0) & " 0" & Split(StrTmp, " ")(1) End If If Len(Split(Split(StrTmp, ":")(1), "-")(0)) = 1 Then StrTmp = Split(StrTmp, ":")(0) & ":0" & Split(StrTmp, ":")(1) End If 'If it's not in the StrTerms list, add it. If InStr(StrTerms, vbCr & StrTmp & vbCr) = 0 Then StrTerms = StrTerms & StrTmp & vbCr .Collapse wdCollapseEnd .Find.Execute Loop End With End Select Next 'Exit if no biblical verse refs have been found. If StrTerms = vbCr Then MsgBox "No defined terms found." & vbCr & "Aborting.", vbExclamation, "Defined Terms Error" GoTo ErrExit End If 'Sort the biblical verse refs Set Rng = .Range.Characters.Last With Rng .Collapse wdCollapseEnd .InsertBefore vbCr .InsertAfter StrTerms .Sort ExcludeHeader:=True, FieldNumber:=1, SortFieldType:=wdSortFieldAlphanumeric, _ SortOrder:=wdSortOrderAscending StrTerms = .Text .Text = vbNullString While Left(StrTerms, 1) = vbCr StrTerms = Mid(StrTerms, 2, Len(StrTerms) - 1) Wend End With 'Build the page records for all biblical verse refs in the StrTerms list. For i = 0 To UBound(Split(StrTerms, vbCr)) - 1 StrFnd = Trim(Split(StrTerms, vbCr)(i)): StrPages = " " For Each RngStry In .StoryRanges Select Case RngStry.StoryType Case wdEndnotesStory, wdFootnotesStory, wdMainTextStory With RngStry With .Find .ClearFormatting .Replacement.ClearFormatting .Format = False .Text = Replace(Replace(Replace(Replace(StrFnd, " 0", " "), " 0", " "), ":0", ":"), ":0", ":") .Wrap = wdFindStop .MatchWholeWord = True .MatchWildcards = False .MatchCase = True .Execute End With Do While .Find.Found = True 'If we haven't already found this ref on this page, add it to the list. Doc.ActiveWindow.View.ShowHiddenText = False Select Case RngStry.StoryType Case wdMainTextStory j = .Information(wdActiveEndAdjustedPageNumber) If InStr(StrPages, " " & j & " ") = 0 Then StrPages = StrPages & j & " " End If Case wdEndnotesStory bFnd = False For p = .Endnotes(1).Reference.Information(wdActiveEndPageNumber) To Doc.ComputeStatistics(wdStatisticPages) Set Pg = Doc.ActiveWindow.Panes(1).Pages(p) For Each Rct In Pg.Rectangles If .InRange(Rct.Range) Then j = Rct.Range.Information(wdActiveEndAdjustedPageNumber) bFnd = True: Exit For End If Next If bFnd = True Then Exit For Next If InStr(StrPages, " " & j & " ") = 0 Then StrPages = StrPages & j & " " End If Case wdFootnotesStory bFnd = False For p = .Footnotes(1).Reference.Information(wdActiveEndPageNumber) To Doc.ComputeStatistics(wdStatisticPages) Set Pg = Doc.ActiveWindow.Panes(1).Pages(p) For Each Rct In Pg.Rectangles If .InRange(Rct.Range) Then j = Rct.Range.Information(wdActiveEndAdjustedPageNumber) bFnd = True: Exit For End If Next If bFnd = True Then Exit For Next If InStr(StrPages, " " & j & " ") = 0 Then StrPages = StrPages & j & " " End If End Select Doc.ActiveWindow.View.ShowHiddenText = True .Find.Execute Loop End With End Select Next If StrPages <> " " Then ArrPgs() = Split(Trim(StrPages), " ") WordBasic.SortArray ArrPgs() 'Add the current record to the output list (StrOut) StrOut = StrOut & StrFnd & vbTab & Join(ArrPgs(), ", ") & vbCr End If Next With .Range If .Bookmarks.Exists(StrBkMk) Then Set Rng = .Bookmarks(StrBkMk).Range End With 'Output the found biblical verse refs as a table at the end of the document. With Rng 'Calculate the number of table lines for the data. j = UBound(Split(StrOut, vbCr)) Set Tbl = .Tables.Add(Range:=.Duplicate, NumRows:=j + 1, NumColumns:=1) With Tbl .AllowAutoFit = False .LeftPadding = 0 .RightPadding = 0 'Define the overall table layout. With .Range.ParagraphFormat .Style = wdStyleNormal .RightIndent = 0 With .TabStops .ClearAll .Add Position:=ColWdth, Alignment:=wdAlignTabRight, Leader:=wdTabLeaderDots End With .SpaceBefore = 0 .SpaceAfter = 0 End With 'Populate & format the header row. With .Cell(1, 1).Range .Text = "Passage" & vbTab & "Pages" .ParagraphFormat.KeepWithNext = True End With With .Rows.First 'Apply the heading row attribute so that the table header repeats after a page break. .HeadingFormat = True 'Delete the header row's tab leaders. With .Range With .ParagraphFormat.TabStops .ClearAll .Add Position:=ColWdth, Alignment:=wdAlignTabRight, Leader:=wdTabLeaderSpaces End With .Font.Bold = True End With End With For i = 0 To j - 1 ' Populate the data rows .Cell(i + 2, 1).Range.Text = Split(StrOut, vbCr)(i) Next .Columns.Add .Columns(1) ' Bookmark the table. Doc.Bookmarks.Add Name:=StrBkMk, Range:=Tbl.Range StrFnd = "": k = 0 For i = 2 To .Rows.Count StrTmp = Split(.Cell(i, 2).Range.Text, " ")(0) If StrFnd <> StrTmp Then For j = 1 To UBound(Split(StrBks, ",")) - 1 If Split(StrBks, ",")(j) = StrTmp Then StrFnd = StrTmp: k = j: Exit For End If Next End If .Cell(i, 1).Range.Text = j Next ' Sort the table .Sort ExcludeHeader:=True, FieldNumber:=1, SortFieldType:=wdSortFieldNumeric, SortOrder:=wdSortOrderAscending j = CLng(Split(.Cell(.Rows.Count, 1).Range.Text, vbCr)(0)) For i = .Rows.Count To 2 Step -1 If j <> CLng(Split(.Cell(i, 1).Range.Text, vbCr)(0)) Then j = CLng(Split(.Cell(i, 1).Range.Text, vbCr)(0)) .Rows.Add .Rows(i + 1) End If Next .Columns(1).Delete ' Delete leading 0s from small Chapter & Verse #s With .Range.Find .MatchWildcards = True .Text = Replace("([ :])[0]{1|2}", "|", Application.International(wdListSeparator)) .Replacement.Text = "\1" .Wrap = wdFindStop .Execute Replace:=wdReplaceAll End With ' Finalize table formatting .PreferredWidthType = wdPreferredWidthPoints .PreferredWidth = ColWdth .Rows.Alignment = wdAlignRowCenter End With End With End With 'Clean up and exit. ErrExit: Set RngStry = Nothing: Set Rct = Nothing: Set Rng = Nothing: Set Tbl = Nothing: Set Doc = Nothing ActiveWindow.View.ShowHiddenText = bHid Application.ScreenUpdating = True End Sub Code:
Sub MakeDupes(Doc As Document, StrFnd As String) Dim RngStry As Range, Rng As Range, StrBk As String, StrCh As String For Each RngStry In Doc.StoryRanges Select Case RngStry.StoryType Case wdEndnotesStory, wdFootnotesStory, wdMainTextStory With RngStry With .Find .ClearFormatting .Wrap = wdFindStop .MatchWildcards = True .Text = StrFnd .Execute End With Do While .Find.Found = True Set Rng = .Duplicate.Words.First With Rng If .Characters.Last <> " " Then .MoveEndUntil " ", wdForward .End = .End + 1 End If StrBk = .Text .Collapse wdCollapseEnd .MoveEndUntil ":", wdForward .End = .End + 1 StrCh = .Text End With Set Rng = .Duplicate.Characters.Last With Rng .End = .End + 2 If .Characters.Last Like "[0-9]" Then .MoveEndWhile "[0-9]", wdForward If Not .Characters.Last.Next Like "[ A-Za-z]" Then If .Characters.First = "," Then .Characters(2).InsertAfter StrBk & StrCh Else .Characters(2).InsertAfter StrBk End If End If End If End With .Collapse wdCollapseStart .Start = .Words.First.End .Find.Execute Loop End With End Select Next End Sub Sub ApplyStyle(Doc As Document, StrFnd As String) Dim RngStry As Range For Each RngStry In Doc.StoryRanges Select Case RngStry.StoryType Case wdEndnotesStory, wdFootnotesStory, wdMainTextStory With RngStry With .Find .ClearFormatting .Wrap = wdFindStop .MatchWildcards = True .Text = StrFnd .Execute End With Do While .Find.Found = True If InStr(StrBks, "," & Split(.Text, " ")(0) & ",") > 0 Then .Style = "Ref" .Collapse wdCollapseEnd .Find.Execute Loop End With End Select Next End Sub Sub HideDupes(Doc As Document, StrFnd As String) Dim RngStry As Range, Rng As Range, StrBk As String, StrCh As String, i As Long For Each RngStry In Doc.StoryRanges Select Case RngStry.StoryType Case wdEndnotesStory, wdFootnotesStory, wdMainTextStory With RngStry With .Find .ClearFormatting .Wrap = wdFindStop .MatchWildcards = True .Text = StrFnd .Execute End With Do While .Find.Found = True Set Rng = .Duplicate.Words.First With Rng If .Characters.Last <> " " Then .MoveEndUntil " ", wdForward .End = .End + 1 End If StrBk = .Text .Collapse wdCollapseEnd .MoveEndUntil ":", wdForward .End = .End + 1 StrCh = .Text .Collapse wdCollapseEnd .MoveStartUntil StrBk, wdForward .Start = .Start + 1 .End = .Start + Len(StrBk) .Font.Hidden = True .Font.ColorIndex = wdRed With .Duplicate .Collapse wdCollapseEnd .End = .Start + Len(StrCh) If .Text = StrCh Then .Font.Hidden = True .Font.ColorIndex = wdRed End If End With End With .Collapse wdCollapseStart .Start = .Words.First.End .Find.Execute Loop End With End Select Next End Sub For PC macro installation & usage instructions, see: Installing Macros For Mac macro installation & usage instructions, see: Word:mac - Install a Macro
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#3
|
|||
|
|||
Thanks
Thank you very much, I will give it a go.
Regards, Willem |
#4
|
|||
|
|||
Solved first problem
Good afternoon,
It seems to not work correctly: 1 Joh. 2:1; 3:1 Is changed to 1 Joh. 2:1; Joh. 1 Joh.3:1 Regards, Willem |
#5
|
||||
|
||||
I've used the code I posted to produce an index with over 550 entries spanning nearly 500 verses without encountering anything like that. Provided the non-breaking spaces are implemented as described in post #2, I can't see how the result you've posted would be possible. Starting out with:
1 Joh. 2:1; 3:1 I would expect to see: 1 Joh. 2:1; 1 Joh. 3:1 after the processing has been done.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#6
|
|||
|
|||
Thank you Paul, much appreciated!!
|
Tags |
bible, index, scripture |
Thread Tools | |
Display Modes | |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Can a I create an index in a word document where index entries control sections of the document? | pfriorda | Word | 3 | 12-28-2017 08:02 PM |
Updating font in index without updating style of index | Nick B | Word | 4 | 11-28-2016 02:00 AM |
Get Paragraph index from bookmark starting index | vince692 | Word VBA | 6 | 05-13-2016 04:51 AM |
Formatting a second index | Lebber | Word | 3 | 08-05-2013 02:13 AM |
Find and Index | cksm4 | Word | 1 | 01-03-2011 11:33 AM |