[Last Call] Learn how to a build a cloud-first strategyRegister Now

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 598
  • Last Modified:

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 ...
0
OHDev2004
Asked:
OHDev2004
1 Solution
 
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
Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

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

Featured Post

Free Tool: Subnet Calculator

The subnet calculator helps you design networks by taking an IP address and network mask and returning information such as network, broadcast address, and host range.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

Tackle projects and never again get stuck behind a technical roadblock.
Join Now