VERSION 5.00
Begin VB.Form Form1
   Caption         =   "Form1"
   ClientHeight    =   8010
   ClientLeft      =   120
   ClientTop       =   465
   ClientWidth     =   10080
   LinkTopic       =   "Form1"
   ScaleHeight     =   8010
   ScaleWidth      =   10080
   StartUpPosition =   3  'Windows Default
   Begin VB.TextBox Output
      Height          =   6495
      Left            =   360
      MultiLine       =   -1  'True
      TabIndex        =   2
      Text            =   "Form1.frx":0000
      Top             =   720
      Width           =   6855
   End
   Begin VB.TextBox Text1
      Height          =   285
      Left            =   1920
      TabIndex        =   1
      Text            =   "Text1"
      Top             =   240
      Width           =   5295
   End
   Begin VB.CommandButton Command1
      Caption         =   "Command1"
      Height          =   375
      Left            =   360
      TabIndex        =   0
      Top             =   240
      Width           =   1455
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
            (destination As Any, source As Any, ByVal length As Long)

Private Type LongBytes
    Byte1 As Byte
    Byte2 As Byte
    Byte3 As Byte
    Byte4 As Byte
End Type

Private Type Struct_Color
    Color As Long
End Type

Private Type Struct_RGBABytes
    R As Byte
    G As Byte
    B As Byte
    A As Byte
End Type

Private Type Struct_RGBALongs
    R As Long
    G As Long
    B As Long
    A As Long
End Type

Private Type Struct_FixedString6
    FixedLenStr As String * 6
End Type

Function RgbToHex_Original(l As Long) As String
Dim R As Long
Dim G As Long
Dim B As Long
    R = l And ColorConstants.vbRed
    G = (l And ColorConstants.vbGreen) / (2 ^ 8)
    B = (l And ColorConstants.vbBlue) / (2 ^ 16)
    RgbToHex_Original = Right$("0" & Hex(R), 2) _
                      & Right$("0" & Hex(G), 2) _
                      & Right$("0" & Hex(B), 2)
End Function


Public Function RgbToHex_CodyGray(ByVal Color As Long) As String
    ' On little-endian architectures, "RGB" color values are actually stored in memory
    ' in an AABBGGRR format. However, web-style hex colors are always formatted in an
    ' AARRGGBB format. Neither Windows nor HTML care about the alpha-channel value
    ' (always the upper, most-significant bit), so we are going to simply ignore it.
    ' Otherwise, we have to do some bit-twiddling to swap the red and blue color channels.

    ' Extract the individual red, green, and blue color channels.
    ' (Although they are only bytes, continue to store these intermediate values
    ' as 32-bit integers for maximum speed.)
    Dim R As Long
    Dim G As Long
    Dim B As Long
    R = (Color And &HFF)
    G = ((Color \ &H100) And &HFF)
    B = ((Color \ &H10000) And &HFF)

    ' Now, arrange these byte values in the correct order (RRGGBB).
    Color = ((R * &H10000) + (G * &H100) + B)

    ' And finally, format it as a hexadecimal string, left-padding with zeros as necessary.
    ' Note that if the red component value is large enough, padding does not need to be
    ' done, which allows us to skip an expensive string operation.
    If (R >= &H10) Then
        RgbToHex_CodyGray = Hex$(Color)
    Else
        RgbToHex_CodyGray = Right$("00000" & Hex$(Color), 6)
    End If
End Function

Public Function RgbToHex_GrayIllig(ByVal Color As Long) As String
    ' On little-endian architectures, "RGB" color values are actually stored in memory
    ' in an AABBGGRR format. However, web-style hex colors are always formatted in an
    ' AARRGGBB format. Neither Windows nor HTML care about the alpha-channel value
    ' (always the upper, most-significant bit), so we are going to simply ignore it.
    ' Otherwise, we have to do some bit-twiddling to swap the red and blue color channels.

    ' Extract the individual red, green, and blue color channels.
    ' (Although they are only bytes, continue to store these intermediate values
    ' as 32-bit integers for maximum speed.)
    Dim R As Long
    Dim G As Long
    Dim B As Long
    R = (Color And &HFF)
    G = ((Color \ &H100) And &HFF)
    B = ((Color \ &H10000) And &HFF)

    ' Now, arrange these byte values in the correct order (RRGGBB).
    Color = ((R * &H10000) + (G * &H100) + B)

    ' And finally, format it as a hexadecimal string, left-padding with zeros as necessary.
    RgbToHex_GrayIllig = Right$(Hex$(&H1000000 Or Color), 6)
End Function


Public Function RgbToHex2_Comintern(inVal As Long) As String
    Dim bytes As LongBytes, swapped As LongBytes

    CopyMemory bytes, inVal, 4
    swapped.Byte1 = bytes.Byte3
    swapped.Byte2 = bytes.Byte2
    swapped.Byte3 = bytes.Byte1
    swapped.Byte4 = bytes.Byte4

    Dim retVal As Long
    CopyMemory retVal, swapped, 4

    RgbToHex2_Comintern = Right$("0" & Hex$(retVal), 6)    '<--1 call each to Right$ and Hex$
End Function

Public Function RgbToHex_MatsMug(ByVal rgbValue As Long) As String
Const gOffSet As Long = 2 ^ 8
Const bOffSet As Long = 2 ^ 16

Dim rValue As Long
rValue = rgbValue And ColorConstants.vbRed

Dim gValue As Long
gValue = (rgbValue And ColorConstants.vbGreen) / gOffSet

Dim bValue As Long
bValue = (rgbValue And ColorConstants.vbBlue) / bOffSet

RgbToHex_MatsMug = Right$("0" & Hex$(rValue), 2) _
                 & Right$("0" & Hex$(gValue), 2) _
                 & Right$("0" & Hex$(bValue), 2)
End Function

Function RgbToHex_RolandIllig(Color As Long) As String
    Dim R As Long, G As Long, B As Long
    R = Color And &HFF
    G = (Color / &H100) And &HFF
    B = (Color / &H10000) And &HFF
    RgbToHex_RolandIllig = Right$(Hex$(&H1000000 + &H10000 * R + &H100 * G + B), 6)
End Function


Function RgbToHex_Thunderframe(l As Long) As String
Dim R As Long
Dim G As Long
Dim B As Long
    R = l And ColorConstants.vbRed
    G = (l And ColorConstants.vbGreen) / (2 ^ 8)
    B = (l And ColorConstants.vbBlue) / (2 ^ 16)
    RgbToHex_Thunderframe = Right$(Hex$(256 Or R), 2) _
                          & Right$(Hex$(256 Or G), 2) _
                          & Right$(Hex$(256 Or B), 2)
End Function

Public Function RgbToHex_UnknownUser(ByVal ColorRGB As Long) As String

    Dim InputColor                      As Struct_Color
    Dim InputRGBAccessor                As Struct_RGBABytes
    Dim OutputRGBAccessor               As Struct_RGBALongs
    Dim IntermediateOutput              As Struct_FixedString6

    Const LowerCaseHex                  As Boolean = False
    Const AsciiZero                     As Long = 48                        ' Asc("0")
    Const AsciiTenToAOffset             As Long = 7 + (LowerCaseHex * -32)  ' Asc("A") - (Asc("9") + 1) = 7
    Const HalfByteDivider               As Long = 16                        ' divider to do right shift by 4 bits
    Const LowerToUpperWordMultiplier    As Long = &H10000

    InputColor.Color = ColorRGB                                 ' copy the RGB Long value to a simple struct container
    LSet InputRGBAccessor = InputColor                          ' memory copy of struct to allow access to the individual R/G/B values

    ' convert each R/G/B value to a DWORD/Long containing the equivalent of 2 unicode characters (the high and low bits of each byte, each converted to hex)
    OutputRGBAccessor.R = AsciiZero + (InputRGBAccessor.R \ HalfByteDivider) + (((InputRGBAccessor.R \ HalfByteDivider) \ 10) * AsciiTenToAOffset) + _
                            (AsciiZero + (InputRGBAccessor.R Mod HalfByteDivider) + (((InputRGBAccessor.R Mod HalfByteDivider) \ 10) * AsciiTenToAOffset)) * LowerToUpperWordMultiplier
    OutputRGBAccessor.G = AsciiZero + (InputRGBAccessor.G \ HalfByteDivider) + (((InputRGBAccessor.G \ HalfByteDivider) \ 10) * AsciiTenToAOffset) + _
                            (AsciiZero + (InputRGBAccessor.G Mod HalfByteDivider) + (((InputRGBAccessor.G Mod HalfByteDivider) \ 10) * AsciiTenToAOffset)) * LowerToUpperWordMultiplier
    OutputRGBAccessor.B = AsciiZero + (InputRGBAccessor.B \ HalfByteDivider) + (((InputRGBAccessor.B \ HalfByteDivider) \ 10) * AsciiTenToAOffset) + _
                            (AsciiZero + (InputRGBAccessor.B Mod HalfByteDivider) + (((InputRGBAccessor.B Mod HalfByteDivider) \ 10) * AsciiTenToAOffset)) * LowerToUpperWordMultiplier

    LSet IntermediateOutput = OutputRGBAccessor                 ' copy the unicode equivalent struct over into a fixed-length string
    RgbToHex_UnknownUser = IntermediateOutput.FixedLenStr       ' convert the fixed-length string on the stack into a real BSTR.

End Function

Private Sub Command1_Click()
' flags currently unused
Dim testorig As Boolean: testorig = True
Dim testcody As Boolean: testcody = True
Dim testmats As Boolean: testmats = True
Dim testillig As Boolean: testillig = True
Dim testthunder As Boolean: testthunder = True
Dim testcom As Boolean: testcom = True
Dim testunknown As Boolean: testunknown = True

Dim i As Long
Dim hexstr As String
Dim time As Double

    time = Timer
    For i = 0 To &HFFFFFF
        hexstr = RgbToHex_Original(i)
    Next
    Text1.Text = i
    time = Timer - time
    Output.Text = Output.Text & "Original: " & Round(time, 3) & " s" & vbCrLf

    DoEvents

    time = Timer
    For i = 0 To &HFFFFFF
        hexstr = RgbToHex_CodyGray(i)
    Next
    Text1.Text = i
    time = Timer - time
    Output.Text = Output.Text & "Cody Gray: " & Round(time, 3) & " s" & vbCrLf

    DoEvents

    time = Timer
    For i = 0 To &HFFFFFF
        hexstr = RgbToHex_GrayIllig(i)
    Next
    Text1.Text = i
    time = Timer - time
    Output.Text = Output.Text & "Cody Gray/Roland Illig: " & Round(time, 3) & " s" & vbCrLf

    DoEvents

    time = Timer
    For i = 0 To &HFFFFFF
        hexstr = RgbToHex_MatsMug(i)
    Next
    Text1.Text = i
    time = Timer - time
    Output.Text = Output.Text & "Mat's Mug: " & Round(time, 3) & " s" & vbCrLf

    DoEvents

    time = Timer
    For i = 0 To &HFFFFFF
        hexstr = RgbToHex_RolandIllig(i)
    Next
    Text1.Text = i
    time = Timer - time
    Output.Text = Output.Text & "Roland Illig: " & Round(time, 3) & " s" & vbCrLf

    DoEvents

    time = Timer
    For i = 0 To &HFFFFFF
        hexstr = RgbToHex_Thunderframe(i)
    Next
    Text1.Text = i
    time = Timer - time
    Output.Text = Output.Text & "Thunderframe: " & Round(time, 3) & " s" & vbCrLf

    DoEvents

    time = Timer
    For i = 0 To &HFFFFFF
        hexstr = RgbToHex2_Comintern(i)
    Next
    Text1.Text = i
    time = Timer - time
    Output.Text = Output.Text & "Comintern: " & Round(time, 3) & " s" & vbCrLf

    DoEvents

    time = Timer
    For i = 0 To &HFFFFFF
        hexstr = RgbToHex_UnknownUser(i)
    Next
    Text1.Text = i
    time = Timer - time
    Output.Text = Output.Text & "Unknown user: " & Round(time, 3) & " s" & vbCrLf
End Sub