ACC: Sample Function to Use the COMMDLG Color Dialog Box

MORE INFORMATION

   '********************************************************************
   ' MODULE DECLARATION SECTION
   '********************************************************************
   Option Explicit

   '
   ' Required COMMDLG Declarations
   '
   Type ChooseColor
      lStructSize As Long
      hwndOwner As Integer
      hInstance  As Integer
      RgbResult As Long
      lpCustColors As Long
      Flags As Long
      lCustData As Long
      lpfnHook As Long
      lpTemplateName As Long
   End Type

   Global Const CC_RGBINIT = &H1
   Global Const CC_FULLOPEN = &H2

   Declare Function ChooseColor_API Lib "COMMDLG.DLL" Alias _
      "ChooseColor" (pCHOOSECOLOR As ChooseColor) As Integer
   Declare Function CommDlgExtendedError Lib "COMMDLG.DLL" () As Long

   '
   ' Global Memory Declarations
   '
   Declare Function GlobalAlloc Lib "Kernel" _
      (ByVal wFlags As Integer, ByVal dwBytes As Long) As Integer
   Declare Function GlobalFree Lib "Kernel" _
      (ByVal hMem As Integer) As Integer
   Declare Function GlobalLock Lib "Kernel" _
      (ByVal hMem As Integer) As Long
   Declare Function GlobalUnlock Lib "Kernel" _
      (ByVal hMem As Integer) As Integer

   Global Const GMEM_MOVEABLE = &H2
   Global Const GMEM_ZEROINIT = &H40
   Global Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)

   Declare Sub hmemcpy Lib "Kernel" _
      (lpDest As Any, lpSource As Any, ByVal dwBytes As Long)

   '********************************************************************
   ' FUNCTION: ChooseColor
   '
   ' PURPOSE:
   '   Uses the standard Windows Color dialog box in COMMDLG.DLL to get
   '   a 256-color RGB value for use in Microsoft Access. The returned
   '   value can be used in the BackColor, ForeColor, or BorderColor
   '   properties.
   '
   ' ARGUMENTS:
   '   DefaultColor - The default RGB color to be selected.
   '                  Black, 0, is usually the default.
   '
   ' RETURN VALUE:
   '   >=0  The user-selected RGB value
   '   -1   Couldn't allocate global memory
   '   -2   Couldn't lock global memory
   '   -3   COMMDLG error occurred. A message box will display the
   '        number prior to this function exiting.
   '
   ' ********************************************************************
   Function ChooseColor (ByVal DefaultColor As Long) As Long
      Dim C As ChooseColor
      Dim MemHandle As Long
      Dim Result As Integer, i As Integer

      ' Define CustomColor array, address, size variables
      ReDim CustomColors(15) As Long
      Dim CustomColorsAddress As Long
      Dim CustomColorsSize As Integer

      ' Fill custom colors array with all white
      For i = 0 To UBound(CustomColors)
         CustomColors(i) = &HFFFFFF
      Next

      ' Get size of global memory needed for custom colors
      CustomColorsSize = Len(CustomColors(0)) * 16

      ' Get a global memory block to hold a copy of the custom colors
      MemHandle = GlobalAlloc(GHND, CustomColorsSize)
      If MemHandle = 0 Then
         ChooseColor = -1
         Exit Function
      End If

      ' Lock the custom color's global memory block
      CustomColorsAddress = GlobalLock(MemHandle)
      If CustomColorsAddress = 0 Then
         ChooseColor = -2
         Exit Function
      End If

      ' Copy custom colors to the global memory block
      Call hmemcpy(ByVal CustomColorsAddress, _
         CustomColors(0), CustomColorsSize)

      ' Initialize Choose Color structure
      C.lStructSize = Len(C)
      C.hwndOwner = 0&
      C.lpCustColors = CustomColorsAddress
      C.RgbResult = DefaultColor
      C.Flags = CC_RGBINIT Or CC_FULLOPEN

      ' Call the Choose Color COMMDLG routine
      Result = ChooseColor_API(C)

      ' Did an error occur?
      If Result = 0 And CommDlgExtendedError() <> 0 Then
         ChooseColor = -3
         MsgBox Str$(CommDlgExtendedError()), 16, "Choose Color Error"
      End If

      ' Copy the new custom colors to the CustomColors address locally
      ' .. CustomColor array will now contain list of new custom colors
      Call hmemcpy(CustomColors(0), _
         ByVal CustomColorsAddress, CustomColorsSize)

      ' Unlock and free the global memory block
      Result = GlobalUnlock(MemHandle)
      Result = GlobalFree(MemHandle)

      ' Return the selected color
      ChooseColor = C.RgbResult

   End Function
				

How to Use the ChooseColor() Function

   Function GetColor()
      MsgBox Str$(ChooseColor(0))
   End Function
				

   =GetColor()