Convert Long Color to nearest Websafe Color

Hello there ...
Is there a way to convert a Color Like &H123456 to the nearest Websafe Color (one of the 216 or 256 color)
Thank you ...
LVL 7
OHDev2004Asked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

EDDYKTCommented:
function GetRed(color)
      
    On Error Resume Next
      GetRed = ((color And &HFF0000) / &H10000) And &HFF
end Function

function GetGreen(color)
      
    On Error Resume Next
      GetGreen = ((color And &HFF00) / &H100) And &HFF
end Function

function GetBlue(color)
      
    On Error Resume Next
      GetBlue = color And &HFF
end Function
0
OHDev2004Author Commented:
Hello EDDYKT ....
Thank you very much for your Help ... But it didn't work ...
Try it with the Following Color  &HAEAEAE

It should return the nearest Websafe Color ...

I Modified ur three Functions in one Function to return the websafe color ... tell me if i did it wrong:

Private Function Get256TransparentColor(Clr As Long) As Long
Dim FinalColor As Long, ClrRed, ClrBlue, ClrGreen
 On Error Resume Next
 ClrRed = ((Clr And &HFF0000) / &H10000) And &HFF
 ClrBlue = ((Clr And &HFF00) / &H100) And &HFF
 ClrGreen = Clr And &HFF
 Get256TransparentColor = RGB(ClrRed, ClrBlue, ClrGreen)
End Function

0
Erick37Commented:
I believe this is what you want:


Option Explicit

Private Type COLORCOMPONENT
    r As Byte
    g As Byte
    b As Byte
End Type
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
   (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)


Private Function GetNearestWebsafeColor(ByVal color As Long) As Long
    '
    'Returns the nearest Netscape "Websafe" 216 color
    '
    Dim cc As COLORCOMPONENT
   
    'Split out the colors
    Call CopyMemory(cc, ByVal VarPtr(color), 3)
    Debug.Print Hex(cc.r), Hex(cc.g), Hex(cc.b)
   
    GetNearestWebsafeColor = RGB(WebsafeByte(cc.r), WebsafeByte(cc.g), WebsafeByte(cc.b))
   
End Function

Private Function WebsafeByte(ByVal color As Byte) As Byte
    'This is a helper function for GetNearestWebsafeColor
    Dim result As Byte
    result = color Mod &H33
    If result <= 25 Then
        WebsafeByte = color - result
    Else
        WebsafeByte = color + (&H33 - result)
    End If
   
End Function

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Call it like this:

Me.BackColor = GetNearestWebsafeColor(&H123456)
0
Ultimate Tool Kit for Technology Solution Provider

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy now.

OHDev2004Author Commented:
Please try this Color ... &HFFFFC0 when i use ur method It returns a 0 which means Black ...
Im Using this with Code that Saves GIF so i need to specify the Transparent Color ... But the Transparant color must follow the 256 Pallet ... So I hope you understand what i mean
0
OHDev2004Author Commented:
Thank you Eric Glad to hear ur voice again :P...
 Will test it and let you know asap ...
0
OHDev2004Author Commented:
Wow ... It seems to be working Great ,,,, Will test it again and let you know ...
Thank you ...
0
OHDev2004Author Commented:
Ok ... here's what I cameup with...
It works about 90% right ... But ...

Look at this Color and try to convert it : BFA3AC it Returns a Nonsafe color by the Method ... I don't know why ... Am i missing something or doing something wrong ??
Thanks
0
Erick37Commented:
This is what I get:

Debug.Print Hex(GetNearestWebsafeColor(&HBFA3AC)) '= CC9999
0
jimbobmcgeeCommented:
Try this routine.  It is a brute-force method that should do it for you (I'd do the proper math, but I'm too tired today!!):

    Sub GetWebSafeColorCode()
   
        Dim inColor, outColor, r, g, b, rd, gd, bd, rr, gr, br
       
        Do Until Len(inColor) = 7 And Left(inColor, 1) = "#"
            inColor = InputBox("Actual colour code (#xxxxxx):") 'GET COLOR TO CONVERT
            If inColor = "" Then Exit Sub                       'IF BLANK QUIT
        Loop
       
        inColor = UCase(Right(inColor, 6))
       
        r = "&H" & Left(inColor, 2)                             'GET HEX OF RED PART
        g = "&H" & Mid(inColor, 3, 2)                           'GET HEX OF GREEN PART
        b = "&H" & Right(inColor, 2)                            'GET HEX OF BLUE PART
       
        Do
       
            rd = r Mod &H33                                     'GET REMAINDERS OF
            gd = g Mod &H33                                     'DIVISION BY WEBSAFE
            bd = b Mod &H33                                     'COLOR STEP
       
            Select Case rd                                      'IF REMAINDERS ARE LESS
                                                                'THAN HALF OF STEP MOVE
                Case 0:                 r = r                   'DOWN; MORE THAN HALF,
                Case Is < &H33 \ 2:     r = r - 1               'MOVE UP; NO REMAINDER,
                Case Is > &H33 \ 2:     r = r + 1               'LEAVE COLOR PART AS IS
               
            End Select
   
            Select Case gd                                      'REPEAT FOR GREEN
       
                Case 0:                 g = g
                Case Is < &H33 \ 2:     g = g - 1
                Case Is > &H33 \ 2:     g = g + 1
               
            End Select
   
            Select Case bd                                      'REPEAT FOR BLUE
       
                Case 0:                 b = b
                Case Is < &H33 \ 2:     b = b - 1
                Case Is > &H33 \ 2:     b = b + 1
               
            End Select
   
        Loop Until rd = 0 And gd = 0 And bd = 0                 'REPEAT UNTIL NO REMAINDER
       
        outColor = "#"
        If Len(Hex(r)) = 1 Then outColor = outColor & "0"
        outColor = outColor & Hex(r)
        If Len(Hex(g)) = 1 Then outColor = outColor & "0"
        outColor = outColor & Hex(g)
        If Len(Hex(b)) = 1 Then outColor = outColor & "0"
        outColor = outColor & Hex(b)                            'COMPILE COLOR CODE
       
        MsgBox "Nearest WebSafe color: " & outColor             'SHOW COLOR CODE
       
    End Sub

HTH

J.
0
OHDev2004Author Commented:
thank you HTH for your Help ...
But I found out that Erick37's method is the best one here ...
Although the Bug i was getting was because of the way the GIF was Outputted ... Nevermind everything is Great now :)

Thanks to all of you really ...
OHDev
0
OHDev2004Author Commented:
Hey Erick37 ...

What do I need to change in the code to get the nearestHalftone color ??

the currenlty code Im using is to get the NearestWebsafe color using your Method ...

Private Function GetNearestWebsafeColor(ByVal color As Long) As Long
 Dim cc As COLORCOMPONENT
 Call CopyMemory(cc, ByVal VarPtr(color), 3)
 GetNearestWebsafeColor = RGB(WebsafeByte(cc.r), WebsafeByte(cc.g), WebsafeByte(cc.b))
End Function

Private Function WebsafeByte(ByVal color As Byte) As Byte
Dim result As Byte
result = color Mod &H33
If result <= 25 Then WebsafeByte = color - result Else: WebsafeByte = color + (&H33 - result)
End Function

So I want to change this to get the nearest HalfTone Color ,,, Any Idea ??

I would be happy to post this in a New Question but I posted here first so you know it ...
OHDev
0
Erick37Commented:
Here ya go:

Private Function GetNearestHalftoneColor(ByVal color As Long) As Long
    '
    'Returns the nearest Halftone color
    '
    Dim cc As COLORCOMPONENT
   
    'Split out the colors
    Call CopyMemory(cc, ByVal VarPtr(color), 3)
    'Debug.Print Hex(cc.b), Hex(cc.g), Hex(cc.r)
   
    GetNearestHalftoneColor = RGB(HalftoneByte(cc.r), HalftoneByte(cc.g), HalftoneByte(cc.b))
   
End Function

Private Function HalftoneByte(ByVal color As Byte) As Byte
    'This is a helper function for GetNearestHalftoneColor
    Dim result As Long
    Dim newcolor As Long
   
    result = color Mod &H40
   
    If result < &H20 Then
        newcolor = color - result
    Else
        newcolor = color + (&H40 - result)
        If newcolor > &HFF Then newcolor = &HFF
    End If
   
    HalftoneByte = CByte(newcolor)
   
End Function
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
OHDev2004Author Commented:
Wow !!!
I really Can't Express How much this helped me :)
Please Accept those Little Points :) ...
http://www.experts-exchange.com/Programming/Programming_Languages/Visual_Basic/Q_21217770.html

Before you posted this I was playing with the code and knew i should  Mod the Color with &H40 ... But i didn't knew the &H20 (32 decimal) so i putted many Numbers as a Guess :P LOL ...

Thank you again for ur Great Help ! ..
OHDev
0
OHDev2004Author Commented:
Lunchy ... thank you very much ...
If you'll do that ;then I'll Appreciate it ...
so what's about the other Question I opened ... ??will that be deleted :)
Thank you for Making Experts Exchange Even Better :)
OHDev
0
OHDev2004Author Commented:
Thank you Very much ...
I didn't Know about Reopening A Question ... It may be a new Addition to EE or it was already there and I didn't Know about it :)

Anyway Thank you again for your Support :)
OHDev
0
Erick37Commented:
Thanks OHDev!
0
OHDev2004Author Commented:
your the One Who should be thanked :) ..
I Learned a Lot from this Post :) Thank you ...

By the way If you know any Page on the Web Which Includes Usefull Information I May Learn from then Please Let me Know ... Although I know I won't Learn Anything :P LOL ...
Cheers
OHDev
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Visual Basic Classic

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.