Get hex code for color of text character to display in message box or Excel

marrick13
marrick13 used Ask the Experts™
on
I am trying to adapt a macro I found online (‘Get_Hex1’ in the attached) that displays the colors of a selected character in hex form and writes the results to the immediate window (‘Get_Hex2’). My desire was originally to have the results display in a message box in the same way they appear in the immediate window. I couldn’t get that to work, so I changed the output to an Excel sheet.

That works fine, except that the loop creates two extra rows with redundant data. I couldn’t figure out how to prevent that from happening, so I then focused on just deleting the two extra rows from the worksheet. That works fine the first time I run the macro ‘Get_Hex2’, but in each successive run, the extra rows are not removed. Only if I close the document and reload it will ‘Get_Hex2’ remove the two extra rows.

I’ve run out of ideas for making this work, either by preventing the macro from creating the two extra rows in the first place, or by removing those extra rows in the Excel sheet. Can someone give me an assist here?
Get-Hex-Color-from-Font.docm
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Analyst Assistant
Commented:
Why are you repeating the same code three times?

It's not really clear where you want the results but this code will give you 3 rows with 3 columns in Excel.

The first column will have the hex value of the color repeated, the second column will have the hex RGB values and the third column will have the decimal RGB values.
Sub Get_Hex2()
'Jan 6 2020 - adapted from https://www.tek-tips.com/viewthread.cfm?qid=1583217
Dim i As Integer, sString1 As String, sString2 As String, sString3 As String, sString4 As String
Dim appXl As Excel.Application
Dim wbk As Excel.Workbook
Dim wst As Excel.Worksheet
Dim CharCount As Long, LastRow As Long
Dim strHex As String

    'Test for selection
    If Selection.Start = Selection.End Then
        MsgBox "Nothing selected. Please select a single character.", vbOKOnly, "Selection check"
        Exit Sub
    End If

    CharCount = Selection.Range.Characters.Count    'Count characters in selection

    'Test for number of characters in selection
    If CharCount > 1 Then    'One character is allowed because multiple characters can have multiple colors, and getting their font colors will not make any sense.
        MsgBox "You have selected " & CharCount & " characters (this includes spaces). Please select a single character.", vbOKOnly, "Selection check"
        Exit Sub
    End If

    Set appXl = CreateObject("Excel.Application")
    With appXl
        .Visible = True
        Set wbk = .Workbooks.Add
        Set wst = wbk.Worksheets(1)
    End With

    'select the heading
    For i = 0 To 2
        'write results to Excel workbook
        sString1 = Hex(Selection.Range.Font.Color)
        wst.Cells(1 + i, 1) = "'" & sString1

        sString2 = Mid(sString1, i * 2 + 1, 2)
        wst.Cells(1 + i, 2) = "'" & sString2

        sString3 = Hex2Dec(Mid(sString1, i * 2 + 1, 2))
        wst.Cells(1 + i, 3) = "'" & sString3

    Next

    wst.UsedRange.Columns.AutoFit

    Set appXl = Nothing
    Set wbk = Nothing
    Set wst = Nothing
    
End Sub

Open in new window

Author

Commented:
Thanks again for the solution and quick response.

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial