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

# Thread: [RESOLVED] Long color to RGB

1. ## [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. ## Re: Long color to RGB

Originally Posted by Ordinary Guy
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. ## 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

4. ## 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

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

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

```

5. ## 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

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

6. ## 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:
`Dim R As LongDim G As LongDim B As LongDim lColor As Long Private Sub Form_Click()    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 byteEnd 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. ## 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

Dim MyRGB As tRGB
MyRGB = GetRGB(RGB(1, 2, 3))
Debug.Print MyRGB.R, MyRGB.G, MyRGB.B, MyRGB.a
End Sub

```

8. ## 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. ## 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

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. ## Re: Long color to RGB

And the winner is :

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

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

11. ## Re: Long color to RGB

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

12. ## 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.

13. ## 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. ## 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. ## Re: Long color to RGB

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

I'm the looser now…

16. ## 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. ## 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

18. ## Re: Long color to RGB

Originally Posted by XavSnap
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

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

20. ## 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. ## Re: Long color to RGB

Originally Posted by Ordinary Guy
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. ## Re: Long color to RGB

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

 Wolfgang? we forgot Wolfgang in our tests ! (=copymemory?)

23. ## 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. ## Re: [RESOLVED] Long color to RGB

Hi Qvb6,

Forgot you too !!!
Sorry…

Thanks, … all the best.

25. ## 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. ## 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```

27. ## 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

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

28. ## 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

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. ## Re: [RESOLVED] Long color to RGB

Originally Posted by qvb6
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.

30. ## 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