Private Sub Command1_Click()
  fChooseColorDlg Me, vbBlue, Me
End Sub

Private Declare Function ChooseColor Lib "comdlg32.dll" _
                        Alias "ChooseColorA" _
                        (pChoosecolor As ChooseColor) _
                        As Long
 
Private Declare Sub MemoryCopy Lib "kernel32" _
                        Alias "RtlMoveMemory" _
                        (lpDest As Any, _
                        lpSource As Any, _
                        ByVal dwBytes As Long)
 
Private Declare Function GlobalAlloc Lib "kernel32" _
                        (ByVal wFlags As Long, _
                        ByVal dwBytes As Long) _
                        As Long
 
Private Declare Function GlobalLock Lib "kernel32" _
                        (ByVal hMem As Long) _
                        As Long
 
Private Declare Function GlobalFree Lib "kernel32" _
                        (ByVal hMem As Long) _
                        As Long
 
Private Declare Function GlobalUnlock Lib "kernel32" _
                        (ByVal hMem As Long) _
                        As Long
 
Private Const CC_ARRCOLOR = 15
Private Const CC_MAXCOLOR = 16
Private Const CC_FULLOPEN = &H2
Private Const CC_RGBINIT = &H1
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_ZEROINIT = &H40
Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)
 
Private Type ChooseColor
        lStructSize         As Long
        hwndOwner           As Long
        hInstance           As Long
        rgbResult           As Long
        lpCustColors        As Long
        flags               As Long
        lCustData           As Long
        lpfnHook            As Long
        lpTemplateName      As String
End Type
 
Public Function fChooseColorDlg(ByVal frm As Form, ByVal lHandingColour As _
  Long, _
                                                    ByVal obj As Object) _
                                                    As Integer
 
    Dim cc As ChooseColor
 
    ReDim larrColour(CC_ARRCOLOR) As Long
    Dim N                         As Long
    Dim lRetTargetAdress          As Long
    Dim lHandleToMemory           As Long
    Dim larrSize                  As Long
    Dim lRet                      As Long
    Dim lgUnlock                  As Long
    Dim lgFree                    As Long
 
    larrSize = Len(larrColour(0)) * CC_MAXCOLOR
    lHandleToMemory = GlobalAlloc(GHND, larrSize)
 
    If lHandleToMemory = 0 Then
        fChooseColorDlg = False
        Exit Function
    End If
 
        lRetTargetAdress = GlobalLock(lHandleToMemory)
 
    For N = 0 To UBound(larrColour)
        larrColour(N) = vbWhite
    Next
 
    Call MemoryCopy(ByVal lRetTargetAdress, larrColour(0), larrSize)
 
    With cc
        .lStructSize = Len(cc)
        .hwndOwner = frm.hWnd
        .lpCustColors = lRetTargetAdress
        .rgbResult = lHandingColour
        .flags = CC_RGBINIT Or CC_FULLOPEN
 
        lRet = ChooseColor(cc)
 
        Call MemoryCopy(larrColour(0), ByVal lRetTargetAdress, larrSize)
 
        lgUnlock = GlobalUnlock(lHandleToMemory)
        lgFree = GlobalFree(lHandleToMemory)
 
        If lRet = 0 Then
            fChooseColorDlg = False
            Exit Function
        End If
    End With
 
    lHandingColour = cc.rgbResult
    obj.BackColor = lHandingColour
    fChooseColorDlg = True
End Function