find colors then ....

bnyamin · #1 04-29-2017, 04:48 AM

excuse me
i cannot writ english good !
i need a code for :
find all colors in body text in word
then:
insert cood (for exampel ("code color is green/start/")) at start color
insert cood (for exampel ("code color is green/end/")) at end color

Sample

macropod · #2 04-29-2017, 06:17 AM

Word supports 2^24 (i.e. 16,777,216) colours, of which only 2^4 (i.e. 16) have named constants. How do you want the other 16,777,200 colours reported?

bnyamin · #3 04-29-2017, 10:25 AM

yes
Insert the code instead of the color name
is This a good way?

You have proposed ؟ or Your suggestions?

macropod · #4 04-29-2017, 04:47 PM

Try the following macro. It will generate output like:
< R: 0 G: 176 B: 80 - Green>the social sciences can be found at </ R: 0 G: 176 B: 80 - Green>

Code:

Sub Demo()
Application.ScreenUpdating = False
Dim StrClr As String
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Replacement.Text = ""
    .Format = True
    .Forward = True
    .Wrap = wdFindContinue
    .Font.ColorIndex = wdAuto
    .Replacement.Font.Hidden = True
    .Execute Replace:=wdReplaceAll
    .ClearFormatting
    .Replacement.ClearFormatting
    .Wrap = wdFindStop
    .Font.Hidden = False
    .Execute
  End With
  Do While .Find.Found
    StrClr = GetClr(.Characters.First.Font.Color, .Characters.First.Font.ColorIndex)
    If .Font.ColorIndex <> wdAuto Then
      With .Duplicate
        .Collapse wdCollapseStart
        .Text = "<" & StrClr & ">"
        .Font.ColorIndex = wdAuto
      End With
      With .Duplicate
        .Collapse wdCollapseEnd
        If .Characters.Last.Previous = vbCr Then .End = .End - 1
        .Text = "</" & StrClr & ">"
        .Font.ColorIndex = wdAuto
      End With
    End If
    .Collapse wdCollapseEnd
    If .End >= ActiveDocument.Range.End - 1 Then Exit Do
    .Find.Execute
  Loop
End With
ActiveDocument.Range.Font.Hidden = False
Application.ScreenUpdating = True
End Sub

Function GetClr(RGB_Val As Long, Optional i As Long) As String
Dim StrTmp As String
If RGB_Val < 0 Or RGB_Val > 16777215 Then RGB_Val = 0
StrTmp = StrTmp & " R: " & RGB_Val \ 256 ^ 0 Mod 256
StrTmp = StrTmp & " G: " & RGB_Val \ 256 ^ 1 Mod 256
StrTmp = StrTmp & " B: " & RGB_Val \ 256 ^ 2 Mod 256
Select Case i
  Case 0: StrTmp = StrTmp & " - Auto (Default)"
  Case 1: StrTmp = StrTmp & " - Black"
  Case 2: StrTmp = StrTmp & " - Blue"
  Case 3: StrTmp = StrTmp & " - Turquoise"
  Case 4: StrTmp = StrTmp & " - Bright Green"
  Case 5: StrTmp = StrTmp & " - Pink"
  Case 6: StrTmp = StrTmp & " - Red"
  Case 7: StrTmp = StrTmp & " - Yellow"
  Case 8: StrTmp = StrTmp & " - White"
  Case 9: StrTmp = StrTmp & " - Dark Blue"
  Case 10: StrTmp = StrTmp & " - Teal"
  Case 11: StrTmp = StrTmp & " - Green"
  Case 12: StrTmp = StrTmp & " - Violet"
  Case 13: StrTmp = StrTmp & " - Dark Red"
  Case 14: StrTmp = StrTmp & " - Dark Yellow"
  Case 15: StrTmp = StrTmp & " - 50% Gray"
  Case 16: StrTmp = StrTmp & " - 25% Gray"
  Case Else:  StrTmp = StrTmp & " - User Defined"
End Select
GetClr = StrTmp
End Function

bnyamin · #5 04-29-2017, 07:14 PM

Thank you
This method is very good
But after running this code
The product ....

After pasting the code

Two macro you've written?
But a macro is executed!!!

macropod · #6 04-29-2017, 08:40 PM

I don't get an output anything like your latest attachment. See attached.

There is only one macro (named 'Demo') which calls a Function (named 'GetClr').

bnyamin · #7 04-29-2017, 10:30 PM

Quote:

Originally Posted by macropod

I don't get an output anything like your latest attachment. See attached.

There is only one macro (named 'Demo') which calls a Function (named 'GetClr').

This file is absolutely true!
But
When I run Yours macro
I see error !!

macropod · #8 04-29-2017, 11:00 PM

Did you do what the message suggested?

Please don't keep posting large screenshots; either resize/crop them to fit; or, better still, post just the relevant messages, where applicable.

gmaxey · #9 04-30-2017, 06:44 AM

Paul,

I like your function! As you know, your use of "Find.Found" shivers my timbers so I try to avoid it. Tinkering with your code, I did notice that it can hiccup if there are color adjacent to each other. This can probably be refined but seems to work:

Code:

Sub Demo()
Application.ScreenUpdating = False
Dim StrClr As String
Dim i As Long, oRng As Range, oRngCompare As Range
  Set oRng = ActiveDocument.Range
  With oRng.Find
    .Format = True
    .Wrap = wdFindContinue
    .Font.ColorIndex = wdAuto
    .Replacement.Font.Hidden = True
    .Execute Replace:=wdReplaceAll
    .ClearFormatting
    .Wrap = wdFindStop
    .Font.Hidden = False
    Do While .Execute
      With oRng
        StrClr = GetClr(.Characters.First.Font.Color, .Characters.First.Font.ColorIndex)
        If .Font.ColorIndex <> wdAuto Then
          Set oRngCompare = oRng.Duplicate
          With oRngCompare
            .Collapse wdCollapseStart
            .Text = "<" & StrClr & ">"
            .Font.ColorIndex = wdAuto
          End With
          .Start = oRngCompare.End
          Set oRngCompare = .Duplicate
          oRngCompare.Collapse wdCollapseStart
          If Asc(.Characters.Last) = 13 Then
            Do While .Characters.Last.Font.Color = .Characters.Last.Next.Font.Color
              .End = .End + 1
            Loop
          End If
          With .Duplicate
            For i = 1 To .Characters.Count
            If .Characters(i).Font.Color = .Characters(1).Font.Color Then
              oRngCompare.End = oRngCompare.End + 1
              oRngCompare.Select
            Else
              Exit For
            End If
            Next i
          End With
          .End = oRngCompare.End
          .Select
          .Collapse wdCollapseEnd
        .Text = "</" & StrClr & ">"
        .Font.ColorIndex = wdAuto
        End If
        .Collapse wdCollapseEnd
        If .End >= ActiveDocument.Range.End - 1 Then Exit Do
      End With
    Loop
  End With
  ActiveDocument.Range.Font.Hidden = False
  Application.ScreenUpdating = True
End Sub

bnyamin · #10 04-30-2017, 01:37 PM

Quote:

Originally Posted by gmaxey

Paul,

I like your function! As you know, your use of "Find.Found" shivers my timbers so I try to avoid it. Tinkering with your code, I did notice that it can hiccup if there are color adjacent to each other. This can probably be refined but seems to work:

Code:

Sub Demo()
Application.ScreenUpdating = False
Dim StrClr As String
Dim i As Long, oRng As Range, oRngCompare As Range
  Set oRng = ActiveDocument.Range
  With oRng.Find
    .Format = True
    .Wrap = wdFindContinue
    .Font.ColorIndex = wdAuto
    .Replacement.Font.Hidden = True
    .Execute Replace:=wdReplaceAll
    .ClearFormatting
    .Wrap = wdFindStop
    .Font.Hidden = False
    Do While .Execute
      With oRng
        StrClr = GetClr(.Characters.First.Font.Color, .Characters.First.Font.ColorIndex)
        If .Font.ColorIndex <> wdAuto Then
          Set oRngCompare = oRng.Duplicate
          With oRngCompare
            .Collapse wdCollapseStart
            .Text = "<" & StrClr & ">"
            .Font.ColorIndex = wdAuto
          End With
          .Start = oRngCompare.End
          Set oRngCompare = .Duplicate
          oRngCompare.Collapse wdCollapseStart
          If Asc(.Characters.Last) = 13 Then
            Do While .Characters.Last.Font.Color = .Characters.Last.Next.Font.Color
              .End = .End + 1
            Loop
          End If
          With .Duplicate
            For i = 1 To .Characters.Count
            If .Characters(i).Font.Color = .Characters(1).Font.Color Then
              oRngCompare.End = oRngCompare.End + 1
              oRngCompare.Select
            Else
              Exit For
            End If
            Next i
          End With
          .End = oRngCompare.End
          .Select
          .Collapse wdCollapseEnd
        .Text = "</" & StrClr & ">"
        .Font.ColorIndex = wdAuto
        End If
        .Collapse wdCollapseEnd
        If .End >= ActiveDocument.Range.End - 1 Then Exit Do
      End With
    Loop
  End With
  ActiveDocument.Range.Font.Hidden = False
  Application.ScreenUpdating = True
End Sub

I would like to thank all friends
After running the code ...
Error message comes ...»»»

macropod · #11 04-30-2017, 03:16 PM

Quote:

Originally Posted by gmaxey

I like your function! As you know, your use of "Find.Found" shivers my timbers so I try to avoid it.

Thanks Greg,
Yes, I know my .Find.Found loops trouble you, but they work for me!

Quote:

Originally Posted by gmaxey

Tinkering with your code, I did notice that it can hiccup if there are color adjacent to each other. This can probably be refined

I was aware of the likely limitation re adjacent colours, but looking at the OP's sample there weren't any, so I wasn't going to further complicate the code unless it was an issue. ATM I'm more interested in why the code works for me but not, apparently, for the OP.

bnyamin · #12 04-30-2017, 07:04 PM

Quote:

Originally Posted by macropod

I don't get an output anything like your latest attachment. See attached.

There is only one macro (named 'Demo') which calls a Function (named 'GetClr').

After the implementation and runing of the Code
we see
deferent error

macropod · #13 04-30-2017, 07:21 PM

I removed the colour tags in your document, then ran the macro that's already in it and it produced the correct results. See attached. I have no idea what you're doing...

bnyamin · #14 05-01-2017, 01:18 AM

I did it
https://youtu.be/1qZIOX79JhA

macropod · #15 05-01-2017, 01:28 AM

It might have helped had you said you were using an RTL language format for the basic document. Nowhere is that evident from anything you posted but it may account for the behaviour you're seeing. Try using it on a document using a LTR language format, then copying the annotated content into your other document.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Customization of colors	marif300	Project	3	02-23-2015 07:48 AM
Bar colors	ketanco	Project	1	03-30-2013 08:24 AM
Unable to change font colors from theme colors	choy	Word	3	08-01-2012 09:12 PM
Counting Colors	g48dd	Excel	2	03-13-2011 09:28 PM
Hyperlink colors	pamm13	Word	2	02-18-2011 08:51 AM