#1
|
||||
|
||||
Need help in assigning color codes to each generation in a genealogy
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.
|
#2
|
|||
|
|||
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 Last edited by gmaxey; 06-07-2019 at 07:48 PM. |
#3
|
||||
|
||||
Thank you Greg Maxey for the quick reply. I will get to it once I get home from a trip.
|
#4
|
||||
|
||||
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.
|
#5
|
|||
|
|||
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 |
#6
|
||||
|
||||
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.
|
#7
|
|||
|
|||
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 |
#8
|
||||
|
||||
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.
|
#9
|
||||
|
||||
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.
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#10
|
||||
|
||||
Quote:
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. |
#11
|
|||
|
|||
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 |
#12
|
||||
|
||||
[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. |
#13
|
||||
|
||||
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.
|
#14
|
||||
|
||||
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
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#15
|
||||
|
||||
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 |