Need help in assigning color codes to each generation in a genealogy

Marcia · #1 06-07-2019, 04:40 AM

Hi all. In a family reunion, we were given a genealogy book that is about 150 pages thick. The format is such that we find it hard to trace the generation to which a name belongs. Please help provide the code that assigns colors to each generation. Say, if the number before the name is 1. or 1 digit, the font color of the name is black, if the number is 2 digits like 1.1 or 2.1, the color of the name is red and so on. Sample page attached, thank you.

gmaxey · #2 06-07-2019, 12:32 PM

For what you have shown, something like this:

Code:

Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim oPar As Paragraph
Dim oRng As Range
  For Each oPar In ActiveDocument.Range.Paragraphs
    Select Case oPar.Range.ListFormat.ListLevelNumber
      Case 1: PaintFont oPar.Range, 1
      Case 2: PaintFont oPar.Range, 6
      Case 3: PaintFont oPar.Range, 12
      Case 4: PaintFont oPar.Range, 7
      Case 5: PaintFont oPar.Range, 11
      Case 6: PaintFont oPar.Range, 2
      Case 7: PaintFont oPar.Range, 3
      Case 8: PaintFont oPar.Range, 10
      Case 9: PaintFont oPar.Range, 13
    End Select
  Next
lbl_Exit:
  Exit Sub
End Sub

Sub PaintFont(oRng As Range, lngColorIndex As Long)
  If InStr(oRng.Text, ChrW(8211)) > 0 Then
    oRng.MoveEndUntil ChrW(8211), wdBackward
    oRng.End = oRng.End - 2
  Else
    oRng.End = oRng.End - 1
  End If
  oRng.Font.ColorIndex = lngColorIndex
End Sub

Note the numbers passed to PaintFont correspond to various wdColorIndexes e.g., 1 is black, 6 is red etc.

Marcia · #3 06-07-2019, 01:55 PM

Thank you Greg Maxey for the quick reply. I will get to it once I get home from a trip.

Marcia · #4 06-08-2019, 07:52 PM

Hi Greg, the code is working great but could you please check the line that I added. I added case 10 to represent the 10th generation but when I ran the macro, the font color remained black instead of color no. 30. Also, the auto numbering and auto font painting were lost when I added new members, see 1.2, 1.2.1 and 1.2.1.1. I thought that the short cut key to run a macro is F5 but it jumped to GoTo when pressed. I am so ignorant of vba/macro. Thank you.

gmaxey · #5 06-09-2019, 06:33 AM

Marcia,

Your paragraphs are styled using the ListParagraph Style which only has nine levels. In your original document you had used ListNumbering. In the new file you have manually added the 10th level and the new levels. Also you have to be consistent with formatting. There has to be a tab between the number and text. Try:

Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim oPar As Paragraph
Dim oRng As Range
Dim arrParts() As String
Dim arrParts2() As String
For Each oPar In ActiveDocument.Range.Paragraphs
Select Case oPar.Range.ListFormat.ListLevelNumber And oPar.Range.ListFormat.ListString <> vbNullString
Case 1: PaintFont oPar.Range, 1
Case 2: PaintFont oPar.Range, 6
Case 3: PaintFont oPar.Range, 12
Case 4: PaintFont oPar.Range, 7
Case 5: PaintFont oPar.Range, 11
Case 6: PaintFont oPar.Range, 2
Case 7: PaintFont oPar.Range, 3
Case 8: PaintFont oPar.Range, 10
Case 9: PaintFont oPar.Range, 13
Case Else
arrParts = Split(oPar.Range.Text, Chr(9))
Select Case Len(arrParts(0))
Case 19
Set oRng = oPar.Range
oRng.MoveStart wdCharacter, 20
PaintFont oRng, 6 '30 is not a valid colorindes (there are only 15).
End Select
End Select
Next
lbl_Exit:
Exit Sub
End Sub

Sub PaintFont(oRng As Range, lngColorIndex As Long)
If InStr(oRng.Text, ChrW(8211)) > 0 Then
oRng.MoveEndUntil ChrW(8211), wdBackward
oRng.End = oRng.End - 2
Else
oRng.End = oRng.End - 1
End If
oRng.Font.ColorIndex = lngColorIndex
End Sub

Marcia · #6 06-09-2019, 07:18 AM

Thank you Greg, the code is amazing. Re the color indeces, I downloaded a color palette that has more than 50 numbers so I thought that would work. I don't need that many colors anyway. I am struggling with Word so thank you for pointing out the inconsistencies. God bless you.

gmaxey · #7 06-09-2019, 07:30 AM

Marcia,

Font color can be defined using a colorindex or just a long value or the three color components Red, Green, Blue (you just have to figure out what to pass). E.g., for your tenth element:

Code:

Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim oPar As Paragraph
Dim oRng As Range
Dim arrParts() As String
  For Each oPar In ActiveDocument.Range.Paragraphs
    Select Case oPar.Range.ListFormat.ListLevelNumber And oPar.Range.ListFormat.ListString <> vbNullString
      'Uses a standard ColorIndex value.
      Case 1: PaintFont oPar.Range, 1
      Case 2: PaintFont oPar.Range, 6
      Case 3: PaintFont oPar.Range, 12
      Case 4: PaintFont oPar.Range, 7
      Case 5: PaintFont oPar.Range, 11
      Case 6: PaintFont oPar.Range, 2
      Case 7: PaintFont oPar.Range, 3
      Case 8: PaintFont oPar.Range, 10
      Case 9: PaintFont oPar.Range, 13
    Case Else
      arrParts = Split(oPar.Range.Text, Chr(9))
      Select Case Len(arrParts(0))
        Case 19
          Set oRng = oPar.Range
          oRng.MoveStart wdCharacter, 19
          'Uses Red, Green, Blue color components.
          PaintFont oRng, 0, 155, 233
      End Select
    End Select
  Next
lbl_Exit:
Exit Sub
End Sub

Sub PaintFont(oRng As Range, lngColorIndex As Long, _
              Optional lngG As Long = -1, Optional lngB As Long = -1)
  If InStr(oRng.Text, ChrW(8211)) > 0 Then
    oRng.MoveEndUntil ChrW(8211), wdBackward
    oRng.End = oRng.End - 2
  Else
    oRng.End = oRng.End - 1
  End If
  If lngB = -1 Then
    oRng.Font.ColorIndex = lngColorIndex
  Else
    oRng.Font.Color = RGB(lngColorIndex, lngG, lngB)
  End If
End Sub

Marcia · #8 06-13-2019, 08:20 PM

Hi, I must go back to this thread about adding code for generation 11 onwards. When I added a newly born 11th generation in the genealogy and ran the macro, the color retained the color of the 10th gen of 0,155,233. How do I change the color of 11th generation? Thank you.

Guessed · #9 06-13-2019, 09:14 PM

You can't the way the code is written. It is based on the outline level and Word has a hard limit of 9 outline levels for any outline list. The code gets to a 10th level by using 'no outline list' as the tenth level.

You would need a completely different approach to go beyond the constraints of using the outline lists. Create your own custom styles and forget the outline levels. For instance: Gen01, Gen02, ... , Gen09, Gen10, Gen11, Gen12 etc.
Once the styles are created, the code could be altered to correspond with that method of applying a hierarchy.

Marcia · #10 06-14-2019, 12:56 AM

Quote:

Originally Posted by Guessed

Create your own custom styles and forget the outline levels. For instance: Gen01, Gen02, ... , Gen09, Gen10, Gen11, Gen12 etc.
Once the styles are created, the code could be altered to correspond with that method of applying a hierarchy.

On a scale of 1 to 10 with 10 as the highest rating, I can say that my working knowledge of codes and MS Word is 1 and 4 respectively. I feel nervous creating a new hierarchical encoding other than the built in paragraph and line numbering but I'll give it a shot. I will again ask help in the code adjustments. Thank you Guessed.

Attached is the revised hierarchy style. I don't know how the code above by Mr. Maxey could be altered to generate the desired color coding. I retained the original numbering but deleted the auto-outline. Please help.

gmaxey · #11 06-14-2019, 04:33 PM

If you don't stick to a consistent format then hardly nothing would work.

Code:

Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim oPar As Paragraph
Dim oRng As Range
Dim arrParts() As String
  For Each oPar In ActiveDocument.Range.Paragraphs
    arrParts = Split(oPar.Range.Text, Chr(9))
    Set oRng = oPar.Range
    Select Case Len(arrParts(0))
      Case 1: oRng.MoveStart wdCharacter, 2: PaintFont oRng, 1
      Case 3: oRng.MoveStart wdCharacter, 4: PaintFont oRng, 6
      Case 5: oRng.MoveStart wdCharacter, 6: PaintFont oRng, 12
      Case 7: oRng.MoveStart wdCharacter, 8: PaintFont oRng, 7
      Case 9: oRng.MoveStart wdCharacter, 10: PaintFont oRng, 11
      Case 11: oRng.MoveStart wdCharacter, 12: PaintFont oRng, 2
      Case 13: oRng.MoveStart wdCharacter, 14: PaintFont oRng, 3
      Case 15: oRng.MoveStart wdCharacter, 16: PaintFont oRng, 10
      Case 17: oRng.MoveStart wdCharacter, 18: PaintFont oRng, 13
      Case 19: oRng.MoveStart wdCharacter, 20: PaintFont oRng, 0, 255, 0
      Case 21: oRng.MoveStart wdCharacter, 22: PaintFont oRng, 127, 255, 123
      Case 23: oRng.MoveStart wdCharacter, 24: PaintFont oRng, 127, 0, 123
    End Select
  Next
lbl_Exit:
Exit Sub
End Sub
Sub PaintFont(oRng As Range, lngColorIndex As Long, _
              Optional lngG As Long = -1, Optional lngB As Long = -1)
  If InStr(oRng.Text, ChrW(8211)) > 0 Then
    oRng.MoveEndUntil ChrW(8211), wdBackward
    oRng.End = oRng.End - 2
  Else
    oRng.End = oRng.End - 1
  End If
  If lngB = -1 Then
    oRng.Font.ColorIndex = lngColorIndex
  Else
    oRng.Font.Color = RGB(lngColorIndex, lngG, lngB)
  End If
End Sub

Marcia · #12 06-14-2019, 05:56 PM

[QUOTE=gmaxey;142495]If you don't stick to a consistent format then hardly nothing would work.
Big thanks Mr. Maxey. The first format worked perfectly for my own project but I shared your code to a friend who belongs to a family that spans so many generations and she became stuck on the 11th. I told her to paint the fonts manually but applying the macro was so fascinating to her that she nagged me to seek SOS in this forum again.

Marcia · #13 06-16-2019, 08:41 PM

I would like to share the codes above to my facebook friends but I don't know how to locate and directly copy the link from this thread. Please help, step by step because my knowledge is only limited to hyperlinks in my data files. Thank you.

Guessed · #14 06-16-2019, 11:23 PM

I don't know if non-members can download files from this site so your friend may need to sign up (its free) in order to download the file.

To get the URL for this page, copy the address from the top line of the browser (near the tabs) where it says https://www.msofficeforums.com/word-...tml#post142550

Marcia · #15 06-16-2019, 11:42 PM

Thank you Mr. Lockton. One reason I wanted to direct them to this site is because this is one amazing forum full of good Samaritans.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Change Color (Being provided between the two codes)	bnyamin	Word VBA	4	05-16-2017 10:55 PM
RGB color codes?	regwitt	Excel Programming	2	01-06-2015 04:51 PM
Color codes as background	Anderso	Excel	1	12-19-2014 11:53 PM
Converting color codes in VBA	Ulodesk	Word VBA	7	11-24-2014 04:15 AM
Codes for Word Textbox Font Color?	tinfanide	Word VBA	7	10-23-2012 03:13 PM