Microsoft Office Forums - View Single Post - [Solved] Need help in assigning color codes to each generation in a genealogy

gmaxey · 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