PHP User Warning: fetch_template() calls should be replaced by the vB_Template class. Template name: bbcode_highlight in ..../includes/functions.php on line 4197
[RESOLVED] Long color to RGB-VBForums
Results 1 to 30 of 30

Thread: [RESOLVED] Long color to RGB

  1. #1

    Thread Starter
    Addicted Member
    Join Date
    Mar 2017
    Posts
    136

    Resolved [RESOLVED] Long color to RGB

    How do I convert a long color value to RGB values

    I think VB has a RGB to Long, like

    lngColorValue = RGB(nnn,nnn,nnn)

    but I need the opposite

  2. #2
    Lively Member
    Join Date
    Apr 2014
    Location
    Munich, Germany
    Posts
    127

    Re: Long color to RGB

    Quote Originally Posted by Ordinary Guy View Post
    How do I convert a long color value to RGB values
    One way (of many I can think of):

    Code:
    Option Explicit
    
    Declare Sub vbaCopyBytes Lib "msvbvm60.dll" Alias "__vbaCopyBytes" (ByVal length As Long, dst As Any, src As Any)
    
    Public Sub LongToRGB(ByVal l As Long, ByRef r As Byte, ByRef g As Byte, ByRef b As Byte)
    Dim bt(0 To 3) As Byte
    vbaCopyBytes 4, bt(0), l
    r = bt(0)
    g = bt(1)
    b = bt(2)
    End Sub
    
    Sub Main()
    Dim l As Long
    Dim r As Byte
    Dim g As Byte
    Dim b As Byte
    l = RGB(1, 2, 3)
    LongToRGB l, r, g, b
    Debug.Assert r = 1
    Debug.Assert g = 2
    Debug.Assert b = 3
    End Sub
    Wolfgang

  3. #3
    VB-aholic & Lovin' It LaVolpe's Avatar
    Join Date
    Oct 2007
    Location
    Beside Waldo
    Posts
    18,392

    Re: Long color to RGB

    The simplest method is to use bit shifting, without consideration for Alpha/Transparency byte
    R,G,B from low byte to high byte: R=low byte, G=2nd byte, B=3rd byte
    So, RGB(1,2,3) in hex is &H030201

    To reverse it
    R = lColor And &HFF ' mask the low byte
    G = (lColor And &HFF00&) \ &H100 ' mask the 2nd byte and shift it to the low byte
    B = (lColor And &HFF0000) \ &H10000 ' mask the 3rd byte and shift it to the low byte
    Insomnia is just a byproduct of, "It can't be done"

    Classics Enthusiast? Here's my 1969 Mustang Mach I Fastback. Her sister '67 Coupe has been adopted

    Newbie? Novice? Bored? Spend a few minutes browsing the FAQ section of the forum.
    Read the HitchHiker's Guide to Getting Help on the Forums.
    Here is the list of TAGs you can use to format your posts
    Here are VB6 Help Files online


    {Alpha Image Control} {Memory Leak FAQ} {Unicode Open/Save Dialog} {Resource Image Viewer/Extractor}
    {VB and DPI Tutorial} {Manifest Creator} {UserControl Button Template} {stdPicture Render Usage}

  4. #4
    PowerPoster Elroy's Avatar
    Join Date
    Jun 2014
    Location
    Near Nashville TN
    Posts
    5,701

    Re: Long color to RGB

    Using a UDT also does a pretty nice job of it:

    Code:
    
    Option Explicit
    
    Private Declare Function GetMem4 Lib "msvbvm60" (ByRef Source As Any, ByRef Dest As Any) As Long ' Always ignore the returned value, it's useless.
    
    Private Type RGBAtype
        r As Byte
        g As Byte
        b As Byte
        a As Byte
    End Type
    
    
    Private Sub Form_Load()
        Dim rgba As RGBAtype
        Dim SomeColor As Long
    
        SomeColor = &H1010FF
    
        GetMem4 SomeColor, rgba
    
        Debug.Print rgba.r, rgba.g, rgba.b, rgba.a
    
    End Sub
    
    

    Or, without any API, we could basically perfectly reverse the RGB function with three cute little procedures:

    Code:
    
    Option Explicit
    
    Private Type RGBAtype
        r As Byte
        g As Byte
        b As Byte
        a As Byte
    End Type
    Private Type LongType
        l As Long
    End Type
    
    
    Private Sub Form_Load()
        Dim SomeColor As Long
    
        SomeColor = &H1010FF
    
        Debug.Print Red(SomeColor), Green(SomeColor), Blue(SomeColor)
    
    End Sub
    
    Private Property Get Red(lTheColor As Long) As Byte
        Dim l As LongType, rgba As RGBAtype
        l.l = lTheColor: LSet rgba = l: Red = rgba.r
    End Property
    
    Private Property Get Green(lTheColor As Long) As Byte
        Dim l As LongType, rgba As RGBAtype
        l.l = lTheColor: LSet rgba = l: Green = rgba.g
    End Property
    
    Private Property Get Blue(lTheColor As Long) As Byte
        Dim l As LongType, rgba As RGBAtype
        l.l = lTheColor: LSet rgba = l: Blue = rgba.b
    End Property
    
    
    Last edited by Elroy; Oct 6th, 2019 at 08:47 PM.
    Any software I post in these forums written by me is provided “AS IS” without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. Please understand that I’ve been programming since the mid-1970s and still have some of that code. My contemporary VB6 project is approaching 1,000 modules. In addition, I have a “VB6 random code folder” that is overflowing. I’ve been at this long enough to truly not know with absolute certainty from whence every single line of my code has come, with much of it coming from programmers under my employ who signed intellectual property transfers. I have not deliberately attempted to remove any licenses and/or attributions from any software. If someone finds that I have inadvertently done so, I sincerely apologize, and, upon notice and reasonable proof, will re-attach those licenses and/or attributions. To all, peace and happiness.

  5. #5
    Member
    Join Date
    Oct 2019
    Posts
    35

    Re: Long color to RGB

    Hi,
    Or convert the Long value in a binary array :
    Code:
    Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
    
    Private Type tRGB
        R As Byte
        G As Byte
        B As Byte
        a As Byte
    End Type
    
    Private Sub Form_Load()
    Dim MyRGB As tRGB
    MyRGB = GetRGB(RGB(1, 2, 3))
    Debug.Print MyRGB.R, MyRGB.G, MyRGB.B, MyRGB.a
    End Sub
    
    Private Function GetRGB(color As Long) As tRGB
    Dim tmprgb(3) As Byte
    CopyMemory tmprgb(0), color, 4
    GetRGB.R = tmprgb(0): GetRGB.G = tmprgb(1): GetRGB.B = tmprgb(2): GetRGB.a = tmprgb(3)
    End Function
    [edit] Elroy code is better, it use "CopyMemory GetRGB.R, color, 4" !

    Code:
    Private Function GetRGB(color As Long) As tRGB
    CopyMemory GetRGB, color, 4
    End Function
    Thanks Elroy !
    Last edited by XavSnap; Oct 8th, 2019 at 10:58 AM.

  6. #6
    Hyperactive Member
    Join Date
    Feb 2019
    Posts
    400

    Re: Long color to RGB

    LaVolpe code snippet in post #3 is faster than CopyMemory approaches, because VB6 compiler uses shift bit or shift byte instead of dividing when you use \ for integer division. The result is 11 instructions, each taking a clock or two to execute. CopyMemory takes longer. Here is the source code, followed by the assembly. However, you can just do a loop test to see which method is faster instead of looking at the assembly code:

    VB Code:
    1. Dim R As Long
    2. Dim G As Long
    3. Dim B As Long
    4. Dim lColor As Long
    5.  
    6. Private Sub Form_Click()
    7.     R = lColor And &HFF ' mask the low byte
    8.     G = (lColor And &HFF00&) \ &H100 ' mask the 2nd byte and shift it to the low byte
    9.     B = (lColor And &HFF0000) \ &H10000 ' mask the 3rd byte and shift it to the low byte
    10. End Sub

    Code:
    27:   Dim R As Long
    28:   Dim G As Long
    29:   Dim B As Long
    30:   Dim lColor As Long
    31:
    32:   Private Sub Form_Click() ' Setup error handler first
    00401E30   push        ebp
    00401E31   mov         ebp,esp
    00401E33   sub         esp,0Ch
    00401E36   push        offset ___vbaExceptHandler (004010f6)
    00401E3B   mov         eax,fs:[00000000]
    00401E41   push        eax
    00401E42   mov         dword ptr fs:[0],esp
    00401E49   sub         esp,0Ch
    00401E4C   push        ebx
    00401E4D   push        esi
    00401E4E   push        edi
    00401E4F   mov         dword ptr [ebp-0Ch],esp
    00401E52   mov         dword ptr [ebp-8],offset __imp___CIexp+30h (004010b0)
    00401E59   mov         esi,dword ptr [Me]
    00401E5C   mov         eax,esi
    00401E5E   and         eax,1
    00401E61   mov         dword ptr [ebp-4],eax
    00401E64   and         esi,0FFFFFFFEh
    00401E67   push        esi
    00401E68   mov         dword ptr [Me],esi
    00401E6B   mov         ecx,dword ptr [esi]
    00401E6D   call        dword ptr [ecx+4]
    33:       R = lColor And &HFF ' mask the low byte
    00401E70   mov         eax,dword ptr [esi+48h]
    34:       G = (lColor And &HFF00&) \ &H100 ' mask the 2nd byte and shift it to the low byte
    00401E73   xor         ecx,ecx
    00401E75   mov         edx,eax
    00401E77   mov         dword ptr [ebp-20h],eax
    00401E7A   and         edx,0FFh              <-- And &HFF
    00401E80   mov         cl,ah                 <-- Extract the second byte
    00401E82   mov         dword ptr [esi+3Ch],edx
    35:       B = (lColor And &HFF0000) \ &H10000 ' mask the 3rd byte and shift it to the low byte
    00401E85   xor         edx,edx
    00401E87   mov         dl,byte ptr [ebp-1Eh] <-- Extract the third byte
    00401E8A   mov         dword ptr [esi+40h],ecx
    00401E8D   mov         dword ptr [esi+44h],edx
    36:   End Sub
    00401E90   mov         dword ptr [ebp-4],0
    $L22:
    00401E97   mov         eax,dword ptr [Me]
    00401E9A   push        eax
    00401E9B   mov         ecx,dword ptr [eax]
    00401E9D   call        dword ptr [ecx+8]
    00401EA0   mov         eax,dword ptr [ebp-4]
    00401EA3   mov         ecx,dword ptr [ebp-14h]
    00401EA6   pop         edi
    00401EA7   pop         esi
    00401EA8   mov         dword ptr fs:[0],ecx
    00401EAF   pop         ebx
    00401EB0   mov         esp,ebp
    00401EB2   pop         ebp
    00401EB3   ret         4

  7. #7
    PowerPoster Elroy's Avatar
    Join Date
    Jun 2014
    Location
    Near Nashville TN
    Posts
    5,701

    Re: Long color to RGB

    XavSnap,

    Use GetMem4 rather than CopyMemory. It's faster. I'm not up for doing any timing, but I'd be surprised if much of anything is faster than copying 4 bytes a couple of times. You're pushing 4 bytes onto the stack when you make the GetRGB call (but LaVolpe would need to do that too to turn it into a function), you're explicitly copying 4 bytes, and then you're copying them again upon return (which a bit-shifting function would also have to do). You could save on those last four bytes if you passed in an output argument, but that's always a pain (at least IMHO), and may not save anything in this case because the return is only 4 bytes.

    Code:
    
    Option Explicit
    
    Private Declare Function GetMem4 Lib "msvbvm60" (ByRef Source As Any, ByRef Dest As Any) As Long ' Always ignore the returned value, it's useless.
    
    Private Type tRGB
        R As Byte
        G As Byte
        B As Byte
        a As Byte
    End Type
    
    Private Function GetRGB(color As Long) As tRGB
        GetMem4 color, GetRGB
    End Function
    
    
    
    Private Sub Form_Load()
        Dim MyRGB As tRGB
        MyRGB = GetRGB(RGB(1, 2, 3))
        Debug.Print MyRGB.R, MyRGB.G, MyRGB.B, MyRGB.a
    End Sub
    
    
    Any software I post in these forums written by me is provided “AS IS” without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. Please understand that I’ve been programming since the mid-1970s and still have some of that code. My contemporary VB6 project is approaching 1,000 modules. In addition, I have a “VB6 random code folder” that is overflowing. I’ve been at this long enough to truly not know with absolute certainty from whence every single line of my code has come, with much of it coming from programmers under my employ who signed intellectual property transfers. I have not deliberately attempted to remove any licenses and/or attributions from any software. If someone finds that I have inadvertently done so, I sincerely apologize, and, upon notice and reasonable proof, will re-attach those licenses and/or attributions. To all, peace and happiness.

  8. #8
    Member
    Join Date
    Oct 2019
    Posts
    35

    Re: Long color to RGB

    Hi Elroy,
    Private Declare Function GetMem4 Lib "msvbvm50" (ByRef Source As Any, ByRef Dest As Any) As Long
    Is right too !
    (VB5 runtimes installed in system path)
    Thanks again, Elroy.

  9. #9
    PowerPoster
    Join Date
    Feb 2006
    Posts
    20,549

    Re: Long color to RGB

    Another option, covers system color values. Also somewhat "cute" in its implementation as a Property Let.

    Code:
    Option Explicit
    
    Private Declare Function OleTranslateColor Lib "oleaut32" ( _
      ByVal OleColor As Long, _
      ByVal hPal As OLE_HANDLE, _
      ByRef ColorRef As Long) As Long
    
    Private Property Let ToRGB( _
        ByRef R As Byte, _
        ByRef G As Byte, _
        ByRef B As Byte, _
        ByVal RHS As OLE_COLOR)
    
        OleTranslateColor RHS, 0, RHS
        R = RHS And &HFF&
        G = RHS \ &H100& And &HFF&
        B = RHS \ &H10000 And &HFF&
    End Property
    
    Private Sub Form_Load()
        Dim R As Byte, B As Byte, G As Byte
    
        ToRGB(R, G, B) = vbBlue
        Debug.Print "R="; R, "G="; G, "B="; B
    
        ToRGB(R, G, B) = vbHighlight
        Debug.Print "R="; R, "G="; G, "B="; B
    
        ToRGB(R, G, B) = Me.BackColor
        Debug.Print "R="; R, "G="; G, "B="; B
    End Sub

  10. #10
    Member
    Join Date
    Oct 2019
    Posts
    35

    Re: Long color to RGB

    And the winner is :

    Name:  speedtest.JPG
Views: 104
Size:  18.7 KB

    Dilettante? Dilettante… Dilettante!
    … with the Property Let routine.

    2 nd : AND (LaVolpe)
    3 rd : CopyMemory (Xav)
    4 th: GetMem4 ??? (from Elroy)




    Code:
    Option Explicit
    
    Private Declare Function GetMem4 Lib "msvbvm60" (ByRef Source As Any, ByRef Dest As Any) As Long ' Always ignore the returned value, it's useless.
    
    Private Type tRGB
        R As Byte
        G As Byte
        B As Byte
        a As Byte
    End Type
    
    Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
    
    Private Declare Function OleTranslateColor Lib "oleaut32" ( _
      ByVal OleColor As Long, _
      ByVal hPal As OLE_HANDLE, _
      ByRef ColorRef As Long) As Long
      
    Private Declare Function QueryPerformanceFrequencyAny Lib "kernel32" Alias _
        "QueryPerformanceFrequency" (lpFrequency As Any) As Long
    Private Declare Function QueryPerformanceCounterAny Lib "kernel32" Alias _
        "QueryPerformanceCounter" (lpPerformanceCount As Any) As Long
    
    Private Property Let ToRGB( _
        ByRef R As Byte, _
        ByRef G As Byte, _
        ByRef B As Byte, _
        ByVal RHS As OLE_COLOR)
    
        OleTranslateColor RHS, 0, RHS
        R = RHS And &HFF&
        G = RHS \ &H100& And &HFF&
        B = RHS \ &H10000 And &HFF&
    End Property
    
    Private Function GetRGB1(color As Long) As tRGB
        GetMem4 color, GetRGB1
    End Function
    
    Private Function GetRGB2(color As Long) As tRGB
        CopyMemory GetRGB2, color, 4
    End Function
    
    Private Function GetRGB3(lColor As Long, R As Byte, G As Byte, B As Byte)
    R = lColor And &HFF ' mask the low byte
    G = (lColor And &HFF00&) \ &H100 ' mask the 2nd byte and shift it to the low byte
    B = (lColor And &HFF0000) \ &H10000 ' mask the 3rd byte and shift it to the low byte
    End Function
    
    Private Sub Form_Load()
    Dim cnt As Integer
        Dim frequency As Currency
        Dim startTime As Currency
        Dim endTime As Currency
        Dim result As Double
        
         ' get the frequency counter
        ' return zero if hardware doesn't support high-res performance counters
        If QueryPerformanceFrequencyAny(frequency) = 0 Then
            MsgBox "This computer doesn't support high-res timers", vbCritical
            Exit Sub
        End If
        
    '
    Dim MyColor As Long
    
    MyColor = &H112233
    
        Dim MyRGB As tRGB
    '
        ' start timing
        QueryPerformanceCounterAny startTime
        
        For cnt = 0 To 30000
        MyRGB = GetRGB1(MyColor)
        Next
    
       ' end timing
        QueryPerformanceCounterAny endTime
        DoEvents
        result = (endTime - startTime) / frequency
    Text1 = Text1 & "GetMem4:" & vbTab & Format$(result, "0.000000") & vbTab & vbTab & MyRGB.R & ":" & MyRGB.G & ":" & MyRGB.B & vbCrLf: DoEvents
    
    '
    '
    ' start timing
        QueryPerformanceCounterAny startTime
        For cnt = 0 To 30000
        MyRGB = GetRGB2(MyColor)
        Next
        
       ' end timing
        QueryPerformanceCounterAny endTime
        DoEvents
        result = (endTime - startTime) / frequency
    Text1 = Text1 & "CopyMemory:" & vbTab & Format$(result, "0.000000") & vbTab & vbTab & MyRGB.R & ":" & MyRGB.G & ":" & MyRGB.B & vbCrLf: DoEvents
    
        
    '
    '
        ' start timing
        Dim R As Byte, B As Byte, G As Byte
        
        QueryPerformanceCounterAny startTime
        For cnt = 0 To 30000
        ToRGB(R, G, B) = MyColor
        Next
       ' end timing
        QueryPerformanceCounterAny endTime
        DoEvents
        result = (endTime - startTime) / frequency
    Text1 = Text1 & "Property:  " & vbTab & Format$(result, "0.000000") & vbTab & vbTab & R & ":" & G & ":" & B & vbCrLf: DoEvents
      
      
        ' start timing
        
        QueryPerformanceCounterAny startTime
        For cnt = 0 To 30000
        GetRGB3 MyColor, R, G, B
        Next
       ' end timing
        QueryPerformanceCounterAny endTime
        DoEvents
        result = (endTime - startTime) / frequency
    Text1 = Text1 & "AND :      " & vbTab & Format$(result, "0.000000") & vbTab & vbTab & R & ":" & G & ":" & B & vbCrLf: DoEvents
    
    End Sub
    Last edited by XavSnap; Oct 8th, 2019 at 03:37 PM.

  11. #11
    PowerPoster
    Join Date
    Feb 2006
    Posts
    20,549

    Re: Long color to RGB

    No fair! Take out the OleTranslateColor () call since the others skip it.

  12. #12
    VB-aholic & Lovin' It LaVolpe's Avatar
    Join Date
    Oct 2007
    Location
    Beside Waldo
    Posts
    18,392

    Re: Long color to RGB

    @XavSnap, I will let you validate your findings, but they don't seem to make sense when comparing the "Property" version with "GetRGB3". Why? Because the "Property" version does exactly what "GetRGB3" does but it also makes an API call, 30K times. There is no way that can be faster because there are extra things being done.
    Insomnia is just a byproduct of, "It can't be done"

    Classics Enthusiast? Here's my 1969 Mustang Mach I Fastback. Her sister '67 Coupe has been adopted

    Newbie? Novice? Bored? Spend a few minutes browsing the FAQ section of the forum.
    Read the HitchHiker's Guide to Getting Help on the Forums.
    Here is the list of TAGs you can use to format your posts
    Here are VB6 Help Files online


    {Alpha Image Control} {Memory Leak FAQ} {Unicode Open/Save Dialog} {Resource Image Viewer/Extractor}
    {VB and DPI Tutorial} {Manifest Creator} {UserControl Button Template} {stdPicture Render Usage}

  13. #13
    Hyperactive Member
    Join Date
    Sep 2010
    Location
    Italy
    Posts
    453

    Re: Long color to RGB

    my results:
    Dilettante without OleTranslateColor ()
    Code:
    GetMem4:	0,021552		51:34:17
    CopyMemory:	0,030057		51:34:17
    Property:  	0,003906		51:34:17
    AND :      	0,016933		51:34:17
    Code:
    Private Property Let ToRGB( _
            ByRef R As Byte, _
            ByRef G As Byte, _
            ByRef B As Byte, _
            ByVal RHS As Long)
            'ByVal RHS As OLE_COLOR)
    
    '    OleTranslateColor RHS, 0, RHS
        R = RHS And &HFF&
        G = RHS \ &H100& And &HFF&
        B = RHS \ &H10000 And &HFF&
    End Property
    ( count = 900000 [ cnt as long] )

    me too, I can't explain it to myself, the operations are the same of LaVolpe

  14. #14
    Member
    Join Date
    Oct 2019
    Posts
    35

    Re: Long color to RGB

    Hoop!
    Sorry, LaVolpe… the "GetRGB3" is yours… [Ghost edit: No one seen it !]
    "Property" version with "GetRGB3"
    No, no … you are the second best … Be fair player !

    … an API can be slower than a pretty little routine.

  15. #15
    Member
    Join Date
    Oct 2019
    Posts
    35

    Re: Long color to RGB

    Hi reexre,
    The copymemory is down while using a 90000 loop length!
    Hummm…

    I'm the looser now…

  16. #16
    Hyperactive Member
    Join Date
    Sep 2010
    Location
    Italy
    Posts
    453

    Re: Long color to RGB

    I discovered why!

    LaVolpe MUST be a Sub not a Function!
    Result with
    Private Sub GetRGB3(ByVal lColor As Long, R As Byte, G As Byte, B As Byte)
    and Dilettante without OleTranslateColor ()
    Code:
    GetMem4:	0,024127		51:34:17
    CopyMemory:	0,030544		51:34:17
    Property:  	0,003408		51:34:17
    AND :      	0,003181		51:34:17

  17. #17
    Member
    Join Date
    Oct 2019
    Posts
    35

    Re: Long color to RGB

    Seem to be better to use a "Property Let" instead of a "Function" sub…


    …. 24 years after my first Visual Basic program !

    LaVolpe MUST be a Sub not a function!
    Well done reexre
    Last edited by XavSnap; Oct 8th, 2019 at 04:06 PM.

  18. #18
    Hyperactive Member
    Join Date
    Sep 2010
    Location
    Italy
    Posts
    453

    Re: Long color to RGB

    Quote Originally Posted by XavSnap View Post
    Seem to be better to use a "Property Let" instead of a "Function" sub…


    …. 24 years after my first Visual Basic program !
    me too thought it, but it is not true, you have to declare LaVolpe GetRGB3 as a SUB not a Function .. and things return to normal
    see post #16

    Edit 1:

    moreover it seems slightly better LaVolpe:
    Code:
    R = lColor And &HFF&    ' mask the low byte
    G = (lColor And &HFF00&) \ &H100&    ' mask the 2nd byte and shift it to the low byte
    B = (lColor And &HFF0000) \ &H10000       ' mask the 3rd byte and shift it to the low byte
    than dilettante:
    Code:
    R = RHS And &HFF&
    G = RHS \ &H100& And &HFF&
    B = RHS \ &H10000 And &HFF&
    Edit 2:
    Code use for my latest test (post#16)
    Code:
    Option Explicit
    
    Private Declare Function GetMem4 Lib "msvbvm60" (ByRef Source As Any, ByRef Dest As Any) As Long    ' Always ignore the returned value, it's useless.
    
    Private Type tRGB
        R             As Byte
        G             As Byte
        B             As Byte
        a             As Byte
    End Type
    
    Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
    
    Private Declare Function OleTranslateColor Lib "oleaut32" ( _
                                               ByVal OleColor As Long, _
                                               ByVal hPal As OLE_HANDLE, _
                                               ByRef ColorRef As Long) As Long
    
    Private Declare Function QueryPerformanceFrequencyAny Lib "kernel32" Alias _
                                                          "QueryPerformanceFrequency" (lpFrequency As Any) As Long
    Private Declare Function QueryPerformanceCounterAny Lib "kernel32" Alias _
                                                        "QueryPerformanceCounter" (lpPerformanceCount As Any) As Long
    
    Private Property Let ToRGB( _
            ByRef R As Byte, _
            ByRef G As Byte, _
            ByRef B As Byte, _
            ByVal RHS As Long)
    'ByVal RHS As OLE_COLOR)
    
    '    OleTranslateColor RHS, 0, RHS
        R = RHS And &HFF&
        G = RHS \ &H100& And &HFF&
        B = RHS \ &H10000 And &HFF&
    End Property
    
    Private Function GetRGB1(ByVal color As Long) As tRGB
        GetMem4 color, GetRGB1
    End Function
    
    Private Function GetRGB2(ByVal color As Long) As tRGB
        CopyMemory GetRGB2, color, 4
    End Function
    
    Private Sub GetRGB3(ByVal lColor As Long, R As Byte, G As Byte, B As Byte)
        R = lColor And &HFF&    ' mask the low byte
        G = (lColor And &HFF00&) \ &H100&    ' mask the 2nd byte and shift it to the low byte
        B = (lColor And &HFF0000) \ &H10000       ' mask the 3rd byte and shift it to the low byte
    '    R = lColor And &HFF&
    '    G = lColor \ &H100& And &HFF&
    '    B = lColor \ &H10000 And &HFF&
    End Sub
    
    Private Sub Form_Load()
        Dim cnt       As Long
        Dim frequency As Currency
        Dim startTime As Currency
        Dim endTime   As Currency
        Dim result    As Double
    
        Const NTests  As Long = 900000
    
    
        ' get the frequency counter
        ' return zero if hardware doesn't support high-res performance counters
        If QueryPerformanceFrequencyAny(frequency) = 0 Then
            MsgBox "This computer doesn't support high-res timers", vbCritical
            Exit Sub
        End If
    
        '
        Dim MyColor   As Long
    
        MyColor = &H112233
    
        Dim MyRGB     As tRGB
    
    
        '--------------------------------------------------GetMem4    GetRGB1
        ' start timing
        QueryPerformanceCounterAny startTime
    
        For cnt = 0 To NTests
            MyRGB = GetRGB1(MyColor)
        Next
    
        ' end timing
        QueryPerformanceCounterAny endTime
        'doevents
        result = (endTime - startTime) / frequency
        Text1 = Text1 & "GetMem4:" & vbTab & Format$(result, "0.000000") & vbTab & vbTab & MyRGB.R & ":" & MyRGB.G & ":" & MyRGB.B & vbCrLf:    'doevents
    
    
        '--------------------------------------------------CopyMemory    GetRGB2
        ' start timing
        QueryPerformanceCounterAny startTime
        For cnt = 0 To NTests
            MyRGB = GetRGB2(MyColor)
        Next
    
        ' end timing
        QueryPerformanceCounterAny endTime
        'doevents
        result = (endTime - startTime) / frequency
        Text1 = Text1 & "CopyMemory:" & vbTab & Format$(result, "0.000000") & vbTab & vbTab & MyRGB.R & ":" & MyRGB.G & ":" & MyRGB.B & vbCrLf:    'doevents
    
    
        '--------------------------------------------------Property    ToRGB
        ' start timing
        Dim R As Byte, B As Byte, G As Byte
    
        QueryPerformanceCounterAny startTime
        For cnt = 0 To NTests
            ToRGB(R, G, B) = MyColor
        Next
        ' end timing
        QueryPerformanceCounterAny endTime
        'doevents
        result = (endTime - startTime) / frequency
        Text1 = Text1 & "Property:  " & vbTab & Format$(result, "0.000000") & vbTab & vbTab & R & ":" & G & ":" & B & vbCrLf:    'doevents
    
    
        '--------------------------------------------------AND    GetRGB3
        ' start timing
    
        QueryPerformanceCounterAny startTime
        For cnt = 0 To NTests
            GetRGB3 MyColor, R, G, B
        Next
        ' end timing
        QueryPerformanceCounterAny endTime
        'doevents
        result = (endTime - startTime) / frequency
        Text1 = Text1 & "AND :      " & vbTab & Format$(result, "0.000000") & vbTab & vbTab & R & ":" & G & ":" & B & vbCrLf:    'doevents
    
    End Sub

  19. #19
    Member
    Join Date
    Oct 2019
    Posts
    35

    Re: Long color to RGB

    Hi,
    Private Sub GetRGB3(lColor As Long, R As Byte, G As Byte, B As Byte)
    R = lColor And &HFF ' mask the low byte
    G = (lColor And &HFF00&) \ &H100 ' mask the 2nd byte and shift it to the low byte
    B = (lColor And &HFF0000) \ &H10000 ' mask the 3rd byte and shift it to the low byte
    End Function
    Thanks !

    But, there's two winners now !
    LaVolpe and Dilettante…

    But, Dilettante is the less winner.

    lol
    Last edited by XavSnap; Oct 8th, 2019 at 04:20 PM.

  20. #20

    Thread Starter
    Addicted Member
    Join Date
    Mar 2017
    Posts
    136

    Re: Long color to RGB

    For all it's worth I decided to use LaVolpe's code from post 3. It, to me, is the most simplest and straight forward approach

  21. #21
    Hyperactive Member
    Join Date
    Sep 2010
    Location
    Italy
    Posts
    453

    Re: Long color to RGB

    Quote Originally Posted by Ordinary Guy View Post
    For all it's worth I decided to use LaVolpe's code from post 3. It, to me, is the most simplest and straight forward approach
    and, according to the tests, even the fastest

  22. #22
    Member
    Join Date
    Oct 2019
    Posts
    35

    Re: Long color to RGB

    All other post are very useful to optimize a code, thank you all.
    There's no simple codes!

    [edit] Wolfgang? we forgot Wolfgang in our tests ! (=copymemory?)
    Last edited by XavSnap; Oct 8th, 2019 at 04:44 PM.

  23. #23
    Hyperactive Member
    Join Date
    Feb 2019
    Posts
    400

    Re: [RESOLVED] Long color to RGB

    In my post(#6 above), I declared R, G, B As Long. Declaring them As Byte made VB make a function call to the runtime, so using As Long would be faster than As Byte!

  24. #24
    Member
    Join Date
    Oct 2019
    Posts
    35

    Re: [RESOLVED] Long color to RGB

    Hi Qvb6,

    Forgot you too !!!
    Sorry…

    Thanks, … all the best.

  25. #25
    PowerPoster
    Join Date
    Jun 2013
    Posts
    4,379

    Re: [RESOLVED] Long color to RGB

    All such "high-frequently" called procedures will generally gain a bit in VB6,
    when they are placed as Public Routines in a *.bas-Module ...
    (this way avoiding COM-calling-conventions, as they apply in Class-, Form- or UserControl-modules).

    With that in mind - reducing the number of arguments to pass, is generally a good idea -
    and thus in my tests (native compiled, all options) the fastest routine (about 50% gain) was this one:

    Code:
    Sub GetRGB4(ByVal Color As Long, RGB As tRGB)
        RGB.R = (Color And &HFF&)
        RGB.G = (Color And &HFF00&) \ &H100&
        RGB.B = (Color And &HFF0000) \ &H10000
    End Sub
    So, the passing of a (now Public defined in a *.bas) UDT was not a bad idea to start with -
    one just has to avoid calling external functions within the routine to fill it.

    HTH

    Olaf

  26. #26
    Member
    Join Date
    Oct 2019
    Posts
    35

    Re: [RESOLVED] Long color to RGB

    Hi Olaf,

    Yes, impressive…
    I reduce the arguments ! (Type of RGB2)

    But, steel in the Form. (not a *.bas file)
    Get 50% gain between AND/ your suggestion (And-1 arg).
    With only 30000 loops.

    Code:
    Private Type tRGB2
        Val As Long
        R As Byte
        G As Byte
        B As Byte
        a As Byte
    End Type
    
    Private Sub GetRGB4(RGB As tRGB2)
        RGB.R = (Color And &HFF&)
        RGB.G = (Color And &HFF00&) \ &H100&
        RGB.B = (Color And &HFF0000) \ &H10000
    End Sub
    
    '____________________________________________
    
        ' start timing
     Dim RGB As tRGB2
    
        QueryPerformanceCounterAny startTime
        RGB.Val = MyColor
        For cnt = 0 To 30000
        GetRGB4 RGB
        Next
       ' end timing
        QueryPerformanceCounterAny endTime
        DoEvents
        result = (endTime - startTime) / frequency
    Text1 = Text1 & "AND/1Arg :      " & vbTab & Format$(result, "0.000000") & vbTab & vbTab & R & ":" & G & ":" & B & vbCrLf: DoEvents
    Last edited by XavSnap; Oct 8th, 2019 at 10:25 PM.

  27. #27
    Member
    Join Date
    Oct 2019
    Posts
    35

    Re: [RESOLVED] Long color to RGB

    Code:
    vbaCopyBytes:	0,282894		51:34:17
    GetMem4 f:	0,067097		51:34:17
    GetMem4 s:	0,057638		51:34:17
    CopyMem f:	0,075391		51:34:17
    CopyMe sub:	0,064044		51:34:17
    Property:  	0,067276		51:34:17
    AND fn:    	0,102901		51:34:17
    AND sub:   	0,083324		51:34:17
    AND/1Arg:       0,066923		51:34:17
    AND/1bas:       0,059796		51:34:17
    Form1:
    Code:
    Option Explicit
    
    Private Declare Function GetMem4 Lib "msvbvm60" (ByRef Source As Any, ByRef Dest As Any) As Long ' Always ignore the returned value, it's useless.
    Private Declare Sub vbaCopyBytes Lib "msvbvm60" Alias "__vbaCopyBytes" (ByVal length As Long, dst As Any, src As Any)
    
    Private Type tRGB
        r As Byte
        g As Byte
        b As Byte
        a As Byte
    End Type
    
    Private Type tRGB2
        r As Byte
        g As Byte
        b As Byte
        a As Byte
        Val As Long
    End Type
    
    Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal length As Long)
    
    Private Declare Function OleTranslateColor Lib "oleaut32" ( _
      ByVal OleColor As Long, _
      ByVal hPal As OLE_HANDLE, _
      ByRef ColorRef As Long) As Long
      
    Private Declare Function QueryPerformanceFrequencyAny Lib "kernel32" Alias _
        "QueryPerformanceFrequency" (lpFrequency As Any) As Long
    Private Declare Function QueryPerformanceCounterAny Lib "kernel32" Alias _
        "QueryPerformanceCounter" (lpPerformanceCount As Any) As Long
    
    Public Sub LongToRGB(ByVal l As Long, ByRef r As Byte, ByRef g As Byte, ByRef b As Byte)
    Dim bt(0 To 3) As Byte
    vbaCopyBytes 4, bt(0), l
    r = bt(0)
    g = bt(1)
    b = bt(2)
    End Sub
    
    Private Property Let ToRGB( _
        ByRef r As Byte, _
        ByRef g As Byte, _
        ByRef b As Byte, _
        ByVal RHS As OLE_COLOR)
    
        'OleTranslateColor RHS, 0, RHS
        r = RHS And &HFF&
        g = RHS \ &H100& And &HFF&
        b = RHS \ &H10000 And &HFF&
    End Property
    
    Private Function GetRGB1(Color As Long) As tRGB
        GetMem4 Color, GetRGB1
    End Function
    
    Private Sub GetRGB11(Color As Long, RGB As tRGB)
        GetMem4 Color, RGB
    End Sub
    
    Private Function GetRGB2(Color As Long) As tRGB
        CopyMemory GetRGB2, Color, 4
    End Function
    
    Private Sub GetRGB21(Color As Long, sRGB As tRGB)
        CopyMemory sRGB, Color, 4
    End Sub
    
    
    Private Function GetRGB3(lColor As Long, r As Byte, g As Byte, b As Byte)
    r = lColor And &HFF ' mask the low byte
    g = (lColor And &HFF00&) \ &H100 ' mask the 2nd byte and shift it to the low byte
    b = (lColor And &HFF0000) \ &H10000 ' mask the 3rd byte and shift it to the low byte
    End Function
    
    Private Sub GetRGB31(lColor As Long, r As Byte, g As Byte, b As Byte)
    r = lColor And &HFF ' mask the low byte
    g = (lColor And &HFF00&) \ &H100 ' mask the 2nd byte and shift it to the low byte
    b = (lColor And &HFF0000) \ &H10000 ' mask the 3rd byte and shift it to the low byte
    End Sub
    
    
    Private Sub GetRGB4(RGB As tRGB2)
        RGB.r = (RGB.Val And &HFF&)
        RGB.g = (RGB.Val And &HFF00&) \ &H100&
        RGB.b = (RGB.Val And &HFF0000) \ &H10000
    End Sub
    
    
    Private Sub Form_Load()
    
        Dim cnt As Long
        Dim frequency As Currency
        Dim startTime As Currency
        Dim endTime As Currency
        Dim result As Double
        
        
        
         ' get the frequency counter
        ' return zero if hardware doesn't support high-res performance counters
        If QueryPerformanceFrequencyAny(frequency) = 0 Then
            MsgBox "This computer doesn't support high-res timers", vbCritical
            Exit Sub
        End If
        
    '
    Dim MyColor As Long
    Dim r As Byte
    Dim g As Byte
    Dim b As Byte
    
    MyColor = &H112233
    
    
    
        Dim MyRGB As tRGB
        Dim RGB As tRGB2
        
        
        ' start timing
        QueryPerformanceCounterAny startTime
        For cnt = 0 To 900000
        LongToRGB MyColor, r, g, b
        Next
    
       ' end timing
        QueryPerformanceCounterAny endTime
        DoEvents
        result = (endTime - startTime) / frequency
    Text1 = Text1 & "vbaCopyBytes:" & vbTab & Format$(result, "0.000000") & vbTab & vbTab & r & ":" & g & ":" & b & vbCrLf: DoEvents
        
      
    '
        ' start timing
        QueryPerformanceCounterAny startTime
        
        For cnt = 0 To 900000
        MyRGB = GetRGB1(MyColor)
        Next
    
       ' end timing
        QueryPerformanceCounterAny endTime
        DoEvents
        result = (endTime - startTime) / frequency
    Text1 = Text1 & "GetMem4 f:" & vbTab & Format$(result, "0.000000") & vbTab & vbTab & MyRGB.r & ":" & MyRGB.g & ":" & MyRGB.b & vbCrLf: DoEvents
    
    '
    '
        ' start timing
        QueryPerformanceCounterAny startTime
        
        For cnt = 0 To 900000
        GetRGB11 MyColor, MyRGB
        Next
    
       ' end timing
        QueryPerformanceCounterAny endTime
        DoEvents
        result = (endTime - startTime) / frequency
    Text1 = Text1 & "GetMem4 s:" & vbTab & Format$(result, "0.000000") & vbTab & vbTab & MyRGB.r & ":" & MyRGB.g & ":" & MyRGB.b & vbCrLf: DoEvents
    
    
    
    
    ' start timing
        QueryPerformanceCounterAny startTime
        For cnt = 0 To 900000
        MyRGB = GetRGB2(MyColor)
        Next
        
       ' end timing
        QueryPerformanceCounterAny endTime
        DoEvents
        result = (endTime - startTime) / frequency
    Text1 = Text1 & "CopyMem f:" & vbTab & Format$(result, "0.000000") & vbTab & vbTab & MyRGB.r & ":" & MyRGB.g & ":" & MyRGB.b & vbCrLf: DoEvents
    
    ' start timing
        QueryPerformanceCounterAny startTime
        For cnt = 0 To 900000
        GetRGB21 MyColor, MyRGB
        Next
        
       ' end timing
        QueryPerformanceCounterAny endTime
        DoEvents
        result = (endTime - startTime) / frequency
    Text1 = Text1 & "CopyMe sub:" & vbTab & Format$(result, "0.000000") & vbTab & vbTab & MyRGB.r & ":" & MyRGB.g & ":" & MyRGB.b & vbCrLf: DoEvents
        
    '
    '
        ' start timing
        
        QueryPerformanceCounterAny startTime
        For cnt = 0 To 900000
        ToRGB(r, g, b) = MyColor
        Next
       ' end timing
        QueryPerformanceCounterAny endTime
        DoEvents
        result = (endTime - startTime) / frequency
    Text1 = Text1 & "Property:  " & vbTab & Format$(result, "0.000000") & vbTab & vbTab & r & ":" & g & ":" & b & vbCrLf: DoEvents
      
      
        ' start timing
        
        QueryPerformanceCounterAny startTime
        For cnt = 0 To 900000
        GetRGB3 MyColor, r, g, b
        Next
       ' end timing
        QueryPerformanceCounterAny endTime
        DoEvents
        result = (endTime - startTime) / frequency
    
    Text1 = Text1 & "AND fn:    " & vbTab & Format$(result, "0.000000") & vbTab & vbTab & r & ":" & g & ":" & b & vbCrLf: DoEvents
        ' start timing
        
        QueryPerformanceCounterAny startTime
        For cnt = 0 To 900000
        GetRGB31 MyColor, r, g, b
        Next
       ' end timing
        QueryPerformanceCounterAny endTime
        DoEvents
        result = (endTime - startTime) / frequency
    Text1 = Text1 & "AND sub:   " & vbTab & Format$(result, "0.000000") & vbTab & vbTab & r & ":" & g & ":" & b & vbCrLf: DoEvents
        
        ' start timing
    
        QueryPerformanceCounterAny startTime
        RGB.Val = MyColor
        For cnt = 0 To 900000
        GetRGB4 RGB
        Next
       ' end timing
        QueryPerformanceCounterAny endTime
        DoEvents
        result = (endTime - startTime) / frequency
    Text1 = Text1 & "AND/1Arg :      " & vbTab & Format$(result, "0.000000") & vbTab & vbTab & RGB.r & ":" & RGB.g & ":" & RGB.b & vbCrLf: DoEvents
        
        r = 0: g = 0: b = 0
        ' start timing
        QueryPerformanceCounterAny startTime
        For cnt = 0 To 900000
        GetRGB5 MyColor, r, g, b
        Next
       ' end timing
        QueryPerformanceCounterAny endTime
        DoEvents
        result = (endTime - startTime) / frequency
    Text1 = Text1 & "AND/1bas :      " & vbTab & Format$(result, "0.000000") & vbTab & vbTab & r & ":" & g & ":" & b & vbCrLf: DoEvents
    
    End Sub
    Mod.bas:
    Code:
    Public Sub GetRGB5(ByVal Color As Long, ByRef r As Byte, ByRef g As Byte, ByRef b As Byte)
        r = Color And &HFF&
        g = (Color And &HFF00&) \ &H100&
        b = (Color And &HFF0000) \ &H10000
    End Sub
    Last edited by XavSnap; Oct 9th, 2019 at 12:11 AM.

  28. #28
    Hyperactive Member
    Join Date
    Feb 2019
    Posts
    400

    Re: [RESOLVED] Long color to RGB

    Fascinating! Using Long instead of Byte makes Olaf's method 2.4x faster!(without advanced optimization). I increased the number of loops 10x because I don't trust short loops. Here are the results in a compiled EXE(With the advanced optimization at the default))

    Code:
    vbaCopyBytes:	1.715366		51:34:17
    GetMem4 f:	0.171852		51:34:17
    GetMem4 s:	0.069137		51:34:17
    CopyMem f:	0.239424		51:34:17
    CopyMe sub:	0.133378		51:34:17
    Property:  	0.050060		51:34:17
    AND fn:    	0.144651		51:34:17
    AND sub:   	0.051740		51:34:17
    AND/1Arg :      0.048039		51:34:17
    AND/1bas :      0.045444		51:34:17
    AND/1basLong:   0.018802		51:34:17
    Result with all advanced optimization turned on:
    Code:
    vbaCopyBytes:	1.721844		51:34:17
    GetMem4 f:	0.166796		51:34:17
    GetMem4 s:	0.073337		51:34:17
    CopyMem f:	0.241224		51:34:17
    CopyMe sub:	0.132578		51:34:17
    Property:  	0.024296		51:34:17
    AND fn:    	0.130353		51:34:17
    AND sub:   	0.022010		51:34:17
    AND/1Arg :      0.017275		51:34:17
    AND/1bas :      0.017776		51:34:17
    AND/1basLong:   0.017848		51:34:17
    Here is the modified code:

    Form1:

    Code:
    Option Explicit
    
    Private Declare Function GetMem4 Lib "msvbvm60" (ByRef Source As Any, ByRef Dest As Any) As Long ' Always ignore the returned value, it's useless.
    Private Declare Sub vbaCopyBytes Lib "msvbvm60" Alias "__vbaCopyBytes" (ByVal length As Long, dst As Any, src As Any)
    
    Private Type tRGB
        r As Byte
        g As Byte
        b As Byte
        a As Byte
    End Type
    
    Private Type tRGB2
        r As Byte
        g As Byte
        b As Byte
        a As Byte
        Val As Long
    End Type
    
    Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal length As Long)
    
    Private Declare Function OleTranslateColor Lib "oleaut32" ( _
      ByVal OleColor As Long, _
      ByVal hPal As OLE_HANDLE, _
      ByRef ColorRef As Long) As Long
      
    Private Declare Function QueryPerformanceFrequencyAny Lib "kernel32" Alias _
        "QueryPerformanceFrequency" (lpFrequency As Any) As Long
    Private Declare Function QueryPerformanceCounterAny Lib "kernel32" Alias _
        "QueryPerformanceCounter" (lpPerformanceCount As Any) As Long
    
    Public Sub LongToRGB(ByVal l As Long, ByRef r As Byte, ByRef g As Byte, ByRef b As Byte)
    Dim bt(0 To 3) As Byte
    vbaCopyBytes 4, bt(0), l
    r = bt(0)
    g = bt(1)
    b = bt(2)
    End Sub
    
    Private Property Let ToRGB( _
        ByRef r As Byte, _
        ByRef g As Byte, _
        ByRef b As Byte, _
        ByVal RHS As OLE_COLOR)
    
        'OleTranslateColor RHS, 0, RHS
        r = RHS And &HFF&
        g = RHS \ &H100& And &HFF&
        b = RHS \ &H10000 And &HFF&
    End Property
    
    Private Function GetRGB1(Color As Long) As tRGB
        GetMem4 Color, GetRGB1
    End Function
    
    Private Sub GetRGB11(Color As Long, RGB As tRGB)
        GetMem4 Color, RGB
    End Sub
    
    Private Function GetRGB2(Color As Long) As tRGB
        CopyMemory GetRGB2, Color, 4
    End Function
    
    Private Sub GetRGB21(Color As Long, sRGB As tRGB)
        CopyMemory sRGB, Color, 4
    End Sub
    
    
    Private Function GetRGB3(lColor As Long, r As Byte, g As Byte, b As Byte)
    r = lColor And &HFF ' mask the low byte
    g = (lColor And &HFF00&) \ &H100 ' mask the 2nd byte and shift it to the low byte
    b = (lColor And &HFF0000) \ &H10000 ' mask the 3rd byte and shift it to the low byte
    End Function
    
    Private Sub GetRGB31(lColor As Long, r As Byte, g As Byte, b As Byte)
    r = lColor And &HFF ' mask the low byte
    g = (lColor And &HFF00&) \ &H100 ' mask the 2nd byte and shift it to the low byte
    b = (lColor And &HFF0000) \ &H10000 ' mask the 3rd byte and shift it to the low byte
    End Sub
    
    
    Private Sub GetRGB4(RGB As tRGB2)
        RGB.r = (RGB.Val And &HFF&)
        RGB.g = (RGB.Val And &HFF00&) \ &H100&
        RGB.b = (RGB.Val And &HFF0000) \ &H10000
    End Sub
    
    
    Private Sub Form_Load()
    Const nLoops As Long = 9000000
        Dim cnt As Long
        Dim frequency As Currency
        Dim startTime As Currency
        Dim endTime As Currency
        Dim result As Double
        
        
        
         ' get the frequency counter
        ' return zero if hardware doesn't support high-res performance counters
        If QueryPerformanceFrequencyAny(frequency) = 0 Then
            MsgBox "This computer doesn't support high-res timers", vbCritical
            Exit Sub
        End If
        
    '
    Dim MyColor As Long
    Dim r As Byte
    Dim g As Byte
    Dim b As Byte
    Dim lngR As Long
    Dim lngG As Long
    Dim lngB As Long
    
    MyColor = &H112233
    
    
    
        Dim MyRGB As tRGB
        Dim RGB As tRGB2
        
        
        ' start timing
        QueryPerformanceCounterAny startTime
        For cnt = 0 To nLoops
        LongToRGB MyColor, r, g, b
        Next
    
       ' end timing
        QueryPerformanceCounterAny endTime
        DoEvents
        result = (endTime - startTime) / frequency
    Text1 = Text1 & "vbaCopyBytes:" & vbTab & Format$(result, "0.000000") & vbTab & vbTab & r & ":" & g & ":" & b & vbCrLf: DoEvents
        
      
    '
        ' start timing
        QueryPerformanceCounterAny startTime
        
        For cnt = 0 To nLoops
        MyRGB = GetRGB1(MyColor)
        Next
    
       ' end timing
        QueryPerformanceCounterAny endTime
        DoEvents
        result = (endTime - startTime) / frequency
    Text1 = Text1 & "GetMem4 f:" & vbTab & Format$(result, "0.000000") & vbTab & vbTab & MyRGB.r & ":" & MyRGB.g & ":" & MyRGB.b & vbCrLf: DoEvents
    
    '
    '
        ' start timing
        QueryPerformanceCounterAny startTime
        
        For cnt = 0 To nLoops
        GetRGB11 MyColor, MyRGB
        Next
    
       ' end timing
        QueryPerformanceCounterAny endTime
        DoEvents
        result = (endTime - startTime) / frequency
    Text1 = Text1 & "GetMem4 s:" & vbTab & Format$(result, "0.000000") & vbTab & vbTab & MyRGB.r & ":" & MyRGB.g & ":" & MyRGB.b & vbCrLf: DoEvents
    
    
    
    
    ' start timing
        QueryPerformanceCounterAny startTime
        For cnt = 0 To nLoops
        MyRGB = GetRGB2(MyColor)
        Next
        
       ' end timing
        QueryPerformanceCounterAny endTime
        DoEvents
        result = (endTime - startTime) / frequency
    Text1 = Text1 & "CopyMem f:" & vbTab & Format$(result, "0.000000") & vbTab & vbTab & MyRGB.r & ":" & MyRGB.g & ":" & MyRGB.b & vbCrLf: DoEvents
    
    ' start timing
        QueryPerformanceCounterAny startTime
        For cnt = 0 To nLoops
        GetRGB21 MyColor, MyRGB
        Next
        
       ' end timing
        QueryPerformanceCounterAny endTime
        DoEvents
        result = (endTime - startTime) / frequency
    Text1 = Text1 & "CopyMe sub:" & vbTab & Format$(result, "0.000000") & vbTab & vbTab & MyRGB.r & ":" & MyRGB.g & ":" & MyRGB.b & vbCrLf: DoEvents
        
    '
    '
        ' start timing
        
        QueryPerformanceCounterAny startTime
        For cnt = 0 To nLoops
        ToRGB(r, g, b) = MyColor
        Next
       ' end timing
        QueryPerformanceCounterAny endTime
        DoEvents
        result = (endTime - startTime) / frequency
    Text1 = Text1 & "Property:  " & vbTab & vbTab & Format$(result, "0.000000") & vbTab & vbTab & r & ":" & g & ":" & b & vbCrLf: DoEvents
      
      
        ' start timing
        
        QueryPerformanceCounterAny startTime
        For cnt = 0 To nLoops
        GetRGB3 MyColor, r, g, b
        Next
       ' end timing
        QueryPerformanceCounterAny endTime
        DoEvents
        result = (endTime - startTime) / frequency
    
    Text1 = Text1 & "AND fn:    " & vbTab & Format$(result, "0.000000") & vbTab & vbTab & r & ":" & g & ":" & b & vbCrLf: DoEvents
        ' start timing
        
        QueryPerformanceCounterAny startTime
        For cnt = 0 To nLoops
        GetRGB31 MyColor, r, g, b
        Next
       ' end timing
        QueryPerformanceCounterAny endTime
        DoEvents
        result = (endTime - startTime) / frequency
    Text1 = Text1 & "AND sub:   " & vbTab & Format$(result, "0.000000") & vbTab & vbTab & r & ":" & g & ":" & b & vbCrLf: DoEvents
        
        ' start timing
    
        QueryPerformanceCounterAny startTime
        RGB.Val = MyColor
        For cnt = 0 To nLoops
        GetRGB4 RGB
        Next
       ' end timing
        QueryPerformanceCounterAny endTime
        DoEvents
        result = (endTime - startTime) / frequency
    Text1 = Text1 & "AND/1Arg :      " & vbTab & Format$(result, "0.000000") & vbTab & vbTab & RGB.r & ":" & RGB.g & ":" & RGB.b & vbCrLf: DoEvents
        
        r = 0: g = 0: b = 0
        ' start timing
        QueryPerformanceCounterAny startTime
        For cnt = 0 To nLoops
        GetRGB5 MyColor, r, g, b
        Next
       ' end timing
        QueryPerformanceCounterAny endTime
        DoEvents
        result = (endTime - startTime) / frequency
    Text1 = Text1 & "AND/1bas :      " & vbTab & Format$(result, "0.000000") & vbTab & vbTab & r & ":" & g & ":" & b & vbCrLf: DoEvents
    
        lngR = 0: lngG = 0: lngB = 0
        ' start timing
        QueryPerformanceCounterAny startTime
        For cnt = 0 To nLoops
        GetRGB6 MyColor, lngR, lngG, lngB
        Next
       ' end timing
        QueryPerformanceCounterAny endTime
        DoEvents
        result = (endTime - startTime) / frequency
    Text1 = Text1 & "AND/1basLong :      " & vbTab & Format$(result, "0.000000") & vbTab & vbTab & lngR & ":" & lngG & ":" & lngB & vbCrLf: DoEvents
    End Sub
    Module1:
    Code:
    Option Explicit
    
    Public Sub GetRGB5(ByVal Color As Long, ByRef r As Byte, ByRef g As Byte, ByRef b As Byte)
        r = Color And &HFF&
        g = (Color And &HFF00&) \ &H100&
        b = (Color And &HFF0000) \ &H10000
    End Sub
    
    Public Sub GetRGB6(ByVal Color As Long, ByRef r As Long, ByRef g As Long, ByRef b As Long)
        r = Color And &HFF&
        g = (Color And &HFF00&) \ &H100&
        b = (Color And &HFF0000) \ &H10000
    End Sub

  29. #29
    PowerPoster
    Join Date
    Feb 2006
    Posts
    20,549

    Re: [RESOLVED] Long color to RGB

    Quote Originally Posted by qvb6 View Post
    Fascinating! Using Long instead of Byte makes Olaf's method 2.4x faster!(without advanced optimization).
    I'm sure that seems clever but it fails to take context into consideration.

    Many scenarios I can think of where you might need to perform this operation and do it very many times rapidly... the results need to be converted to Byte values anyway. Sure, I can think of exceptions, and in those cases if you have converted to Byte only to turn around and convert R, G, and B back to Long (DWORD) to use them it would just be silly. I can even think of cases where you need Integer (WORD) values.

    If masking before shifting produces more optimal code by all means go with that. But if you are concerned about performance you probably should perform these operations inline at the point of use rather than creating a procedure to call at all.

    Sometimes isolating the Alpha channel will matter. Other times you might have OLE_COLOR values instead of bonehead COLORREFs. Sometimes you need Long results, sometimes Bytes.


    These threads counting how many angels you can dance on the head of a pin probably leave many readers taking away a lot of bad advice.

  30. #30
    Hyperactive Member
    Join Date
    Sep 2010
    Location
    Italy
    Posts
    453

    Re: [RESOLVED] Long color to RGB

    @qvb6 to me Bytes are 4-6 % faster than Longs using your code with Optimization
    AND/1bas : 0,025705
    AND/1basLong : 0,027242


    BASLong / BASBytes: 105,98%
    BASBytes / BASLong: 94,36%

    BTW if 1 Put 1Arg to BAS (like Olaf said) it's
    AND/1Arg : 0,021253

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Featured


Click Here to Expand Forum to Full Width