Print

Please login or register.
1 Hour 1 Day 1 Week 1 Month Forever
Login with username, password and session length

[Paul Squires]

Happens with SelectFont as well. I bet it happens with all the HFONT macros.

[Paul Squires]

I posted over on the FB forum regarding the DeleteFont sysntax error.
http://www.freebasic.net/forum/viewtopic.php?f=6&t=24663

[José Roca]

I have adapted another old control by Börje to FreeBasic, making it DPI and Unicode aware.

Demonstrates how to make a custom control subclassing an existing one.

Code: [Select]

' ########################################################################################
' Microsoft Windows
' File: CbColor.inc
' Contents: Combobox color list
' Based on the CBCOLOR control originally written by Börje Hagsten in 2001.
' Compiler: FreeBasic 32 & 64-bit
' Freeware. Use at your own risk.
' Copyright (c) 2016 Jose Roca. All Rights Reserved.
' THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
' EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE IMPLIED WARRANTIES OF
' MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
' ########################################################################################

#pragma once

#include once "windows.bi"
#include once "Afx/CWindow.inc"
#include once "win/commdlg.bi"

USING Afx.CWindowClass

NAMESPACE Afx.CCbColorClass

CONST CBCOL_SETAUTOCOLOR = WM_USER + 100
CONST CBCOL_SETUSERCOLOR = WM_USER + 101
CONST CBCOL_SETCOLORNAME = WM_USER + 102
CONST CBCOL_GETAUTOCOLOR = WM_USER + 200
CONST CBCOL_GETUSERCOLOR = WM_USER + 201
CONST CBCOL_GETSELCOLOR  = WM_USER + 202

' ========================================================================================
' CCbColor class
' ========================================================================================
TYPE CCbColor

   Protected:
      m_hCtl  AS HWND           ' // Button handle
      m_hFont AS HFONT          ' // Font handle
      m_oldProc AS WNDPROC      ' // Subclass procedure

   Public:
      m_autoColor AS COLORREF   ' // Auto color
      m_userColor AS COLORREF   ' // User color
      m_ratio AS SINGLE         ' // DPI ratio - width
      DIM m_rgColors(15) AS COLORREF
      DIM m_rgNames (17) AS WSTRING * 20 = {"Auto", "Black", "Blue", "Green", "Cyan", "Red", _
         "Magenta", "Brown", "Light Gray", "Gray", "Light Blue", "Light Green", "Light Cyan", _
         "Light Red", "Light Magenta", "Yellow", "Bright White", "User selected..."}

      DECLARE CONSTRUCTOR (BYVAL pWindow AS CWindow PTR, BYVAL cID AS INTEGER,  _
         BYVAL x AS LONG = 0, BYVAL y AS LONG = 0, BYVAL nWidth AS LONG = 0, BYVAL nHeight AS LONG = 0, _
         BYVAL dwAutoColor AS COLORREF = 0, BYVAL dwUserColor AS COLORREF = 0)
      DECLARE DESTRUCTOR
      DECLARE FUNCTION hWindow () AS HWND
      DECLARE FUNCTION GetQBColor (BYVAL hWnd AS HWND, BYVAL c AS LONG, BYVAL dlg AS LONG) AS COLORREF
      DECLARE PROPERTY AutoColor (BYVAL nColor AS COLORREF)
      DECLARE PROPERTY AutoColor () AS COLORREF
      DECLARE PROPERTY UserColor (BYVAL nColor AS COLORREF)
      DECLARE PROPERTY UserColor () AS COLORREF
      DECLARE PROPERTY SelColor () AS COLORREF

END TYPE
' ========================================================================================

' ========================================================================================
' Window procedure
' ========================================================================================
FUNCTION CCbColorProc (BYVAL hwnd AS HWND, BYVAL uMsg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM) AS LRESULT

   DIM pCbColor AS CCbColor PTR

   SELECT CASE uMsg

      CASE WM_CREATE
         EXIT FUNCTION

      CASE WM_DESTROY
         ' // Remove the subclassing
         SetWindowLongPtrW hwnd, GWLP_WNDPROC, CAST(LONG_PTR, RemovePropW(hwnd, "OLDWNDPROC"))
         ' // Remove the property
         .RemovePropW(hwnd, "CBCOLORPTR")
         EXIT FUNCTION

      CASE WM_DRAWITEM
         ' // Get a pointer to the class
         pCbColor = CAST(CCbColor PTR, .GetPropW(hwnd, "CBCOLORPTR"))
         IF pCbColor = NULL THEN EXIT FUNCTION
         SCOPE
         DIM hBrush AS HBRUSH, wszText AS WSTRING * 80
         DIM lpdis AS DRAWITEMSTRUCT PTR, rc AS RECT
         lpdis = CAST(DRAWITEMSTRUCT PTR, lParam)
         IF lpdis->itemID = &hFFFFFFFF THEN EXIT FUNCTION
         SELECT CASE lpdis->itemAction
            CASE ODA_DRAWENTIRE, ODA_SELECT
               ' // Clear background
               FillRect lpdis->hDC, @lpdis->rcItem, .GetSysColorBrush(COLOR_WINDOW)
               ' // Get/draw text
               .SendMessageW hwnd, CB_GETLBTEXT, lpdis->itemID, CAST(.LPARAM, @wszText)
               .SetBkColor lpdis->hDC, GetSysColor(COLOR_WINDOW)
               .SetTextColor lpdis->hDC, GetSysColor(COLOR_WINDOWTEXT)
               rc = lpdis->rcItem
               rc.Left = 28 * (pCbColor->m_ratio * 0.72)
               .DrawTextW lpdis->hDC, @wszText, LEN(wszText), @rc, DT_SINGLELINE OR DT_LEFT OR DT_VCENTER
               ' // If selected item...
               IF (lpdis->itemState AND ODS_SELECTED) THEN
                  ' // If not ODS_COMBOBOXEDIT...
                  IF (lpdis->itemState AND ODS_COMBOBOXEDIT) = 0 THEN
                     ' // Set coordinates
                     rc.Left = 26 * (pCbColor->m_ratio * 0.72)
                     rc.Right = lpdis->rcItem.Right
                     rc.Top = lpdis->rcItem.Top
                     rc.Bottom = lpdis->rcItem.Bottom
                     ' // Invert area around text only
                     .InvertRect lpdis->hDC, @rc
                  END IF
                  ' // and draw a focus rectangle around all
                  .DrawFocusRect lpdis->hDC, @lpdis->rcItem
               END IF
               ' // Paint color rectangle using RoundRect for nicer looks
               ' /// If ODS_COMBOBOXEDIT...
               IF (lpdis->itemState AND ODS_COMBOBOXEDIT) THEN
                  ' // Set coordinates
                  rc.Left = 4 * (pCbColor->m_ratio * 0.72)
                  rc.Right = 24 * (pCbColor->m_ratio * 0.72)
               ELSE
                  ' // A tiny bit to the left in list...
                  rc.Left = 3 * (pCbColor->m_ratio * 0.72)
                  rc.Right = 23 * (pCbColor->m_ratio * 0.72)
               END IF
               rc.Top    = (lpdis->rcItem.Top + (2 * pCbColor->m_ratio))
               rc.Bottom = (lpdis->rcItem.Bottom - (2 * pCbColor->m_ratio))
               ' // Create brush with the appropriate color
               hBrush = .CreateSolidBrush(pCbColor->GetQBColor(hWnd, lpdis->itemID, FALSE))
               ' // Select brush into device context
               hBrush = .SelectObject(lpdis->hDC, hBrush)
               ' // Draw the rectangle
               DIM nCorner AS LONG = pCbColor->m_ratio * 0.72
               .RoundRect(lpdis->hDC, rc.Left, rc.Top, rc.Right, rc.Bottom, nCorner, nCorner)
               ' // Select old brush back and delete new one
               .DeleteObject .SelectObject(lpdis->hDC, hBrush)
            END SELECT
         END SCOPE
         FUNCTION = CTRUE
         EXIT FUNCTION

      ' // Set auto color
      CASE CBCOL_SETAUTOCOLOR
         pCbColor = CAST(CCbColor PTR, .GetPropW(hwnd, "CBCOLORPTR"))
         IF pCbColor = NULL THEN EXIT FUNCTION
         pCbColor->m_AutoColor = wParam
         EXIT FUNCTION

      ' // Set auto color
      CASE CBCOL_GETAUTOCOLOR
         pCbColor = CAST(CCbColor PTR, .GetPropW(hwnd, "CBCOLORPTR"))
         IF pCbColor = NULL THEN EXIT FUNCTION
         FUNCTION = pCbColor->m_AutoColor
         EXIT FUNCTION

      ' // Set user color
      CASE CBCOL_SETUSERCOLOR
         pCbColor = CAST(CCbColor PTR, .GetPropW(hwnd, "CBCOLORPTR"))
         IF pCbColor = NULL THEN EXIT FUNCTION
         FUNCTION = pCbColor->m_UserColor
         EXIT FUNCTION

      ' // Get user color
      CASE CBCOL_GETUSERCOLOR
         pCbColor = CAST(CCbColor PTR, .GetPropW(hwnd, "CBCOLORPTR"))
         IF pCbColor = NULL THEN EXIT FUNCTION
         FUNCTION = pCbColor->m_UserColor
         EXIT FUNCTION

      ' // Return selected color
      CASE CBCOL_GETSELCOLOR
         DIM nRes AS LONG
         nRes = SendMessageW(hwnd, CB_GETCURSEL, 0, 0)
         pCbColor = CAST(CCbColor PTR, .GetPropW(hwnd, "CBCOLORPTR"))
         IF pCbColor = NULL THEN EXIT FUNCTION
         IF nRes > CB_ERR THEN
            FUNCTION = pCbColor->GetQBColor(hwnd, nRes, CTRUE)
         END IF
         EXIT FUNCTION


   END SELECT

   ' // Default processing for other messages.
   FUNCTION = CallWindowProcW(GetPropW(hwnd, "OLDWNDPROC"), hwnd, uMsg, wParam, lParam)

END FUNCTION
' ========================================================================================

' ========================================================================================
' CPgBar3D class constructor
' ========================================================================================
CONSTRUCTOR CCbColor (BYVAL pWindow AS CWindow PTR, BYVAL cID AS INTEGER,  _
   BYVAL x AS LONG = 0, BYVAL y AS LONG = 0, BYVAL nWidth AS LONG = 0, BYVAL nHeight AS LONG = 0, _
   BYVAL dwAutoColor AS COLORREF = 0, BYVAL dwUserColor AS COLORREF = 0)

   ' // Create the control
   IF pWindow THEN
      m_hCtl = pWindow->AddControl("COMBOBOX", pWindow->hWindow, cID, "", _
      x, y, nWidth, nHeight, WS_CHILD OR WS_VISIBLE OR CBS_OWNERDRAWFIXED OR CBS_HASSTRINGS OR _
      CBS_DROPDOWNLIST OR WS_TABSTOP OR CBS_DISABLENOSCROLL OR WS_VSCROLL, WS_EX_CLIENTEDGE, _
      NULL, CAST(WNDPROC, @CCbColorProc))
      m_ratio = pWindow->rxRatio
   END IF
   IF m_hCtl THEN
      ' // Set the same font used by the parent
      DIM lfw AS LOGFONTW
      IF pWindow->Font THEN
         IF GetObjectW(pWindow->Font, SIZEOF(lfw), @lfw) THEN m_hFont = CreateFontIndirect(@lfw)
      END IF
      ' // Store a pointer to the class as a property
      .SetPropW(m_hCtl, "CBCOLORPTR", CAST(HANDLE, @this))
      DIM i AS LONG
      FOR i = 0 TO UBOUND(m_rgNames)
         SendMessageW m_hCtl, CB_ADDSTRING, 0, CAST(LPARAM, @m_rgNames(i))
      NEXT
      ' // Store default values (usually COLOR_WINDOW or COLOR_WINDOWTEXT)
      m_AutoColor = dwAutoColor
      m_UserColor = dwUserColor
      ' // Create initial colormap for the ChooseColor dialog
      DIM cl AS LONG
      FOR i = 1 TO 16
         cl = i * 16 - 1
         m_rgColors(16 - i) = BGR(cl, cl, cl)
      NEXT
   END IF

END CONSTRUCTOR
' ========================================================================================

' ========================================================================================
' CPgBar3D class destructor
' ========================================================================================
DESTRUCTOR CCbColor
   ' // Free resources
   IF m_hFont THEN DeleteObject m_hFont
END DESTRUCTOR
' ========================================================================================

' ========================================================================================
' Returns the handle of the button
' ========================================================================================
FUNCTION CCbColor.hWindow () AS HWND
   FUNCTION = m_hCtl
END FUNCTION
' ========================================================================================

' ========================================================================================
' Basic QB color function.
' ========================================================================================
FUNCTION CCbColor.GetQBColor (BYVAL hwnd AS HWND, BYVAL c AS LONG, BYVAL dlg AS LONG) AS COLORREF

   SELECT CASE c
      CASE  0 : FUNCTION = m_AutoColor          ' // Pre-set system color, like COLOR_WINDOW or COLOR_WINDOWTEXT
      CASE  1 : FUNCTION = BGR(0,     0,   0)   ' // Black
      CASE  2 : FUNCTION = BGR(0,     0, 128)   ' // Blue
      CASE  3 : FUNCTION = BGR(0,   128,   0)   ' // Green
      CASE  4 : FUNCTION = BGR(0,   128, 128)   ' // Cyan
      CASE  5 : FUNCTION = BGR(196,   0,   0)   ' // Red
      CASE  6 : FUNCTION = BGR(128,   0, 128)   ' // Magenta
      CASE  7 : FUNCTION = BGR(128,  64,   0)   ' // Brown
      CASE  8 : FUNCTION = BGR(196, 196, 196)   ' // Light Gray
      CASE  9 : FUNCTION = BGR(128, 128, 128)   ' // Gray
      CASE 10 : FUNCTION = BGR(0,     0, 255)   ' // Light Blue
      CASE 11 : FUNCTION = BGR(0,   255,   0)   ' // Light Green
      CASE 12 : FUNCTION = BGR(0,   255, 255)   ' // Light Cyan
      CASE 13 : FUNCTION = BGR(255,   0,   0)   ' // Light Red
      CASE 14 : FUNCTION = BGR(255,   0, 255)   ' // Light Magenta
      CASE 15 : FUNCTION = BGR(255, 255,   0)   ' // Yellow
      CASE 16 : FUNCTION = BGR(255, 255, 255)   ' // White
      CASE 17
         ' // Display the ChooseColor dialog
         IF dlg THEN
            DIM cc AS CHOOSECOLORW
            ' // Size of the structure
            cc.lStructSize  = SIZEOF(cc)
            ' // Pointer to the custom defined gray color array
            cc.lpCustColors = @m_rgColors(0)
            cc.Flags        = CC_RGBINIT OR CC_FULLOPEN
            cc.hwndowner    = hwnd
            ' // Allow the dialog to "auto-select" previously selected color
            ' // (only works for base colors, but still better than nothing)
            cc.rgbResult    = m_UserColor
            IF .ChooseColorW(@cc) THEN
               m_UserColor = cc.rgbResult
              .InvalidateRect hwnd, NULL, 0
              .UpdateWindow hWnd
            END IF
         END IF
         ' // Return the user selected color
         FUNCTION = m_UserColor
   END SELECT

END FUNCTION
' ========================================================================================

' ========================================================================================
' Gets/sets the RGB auto color
' ========================================================================================
PROPERTY CCbColor.AutoColor (BYVAL nColor AS COLORREF)
   m_autoColor = nColor
END PROPERTY
' ========================================================================================
' ========================================================================================
PROPERTY CCbColor.AutoColor () AS COLORREF
   PROPERTY = m_autoColor
END PROPERTY

' ========================================================================================
' Gets/sets the RGB user color
' ========================================================================================
PROPERTY CCbColor.UserColor (BYVAL nColor AS COLORREF)
   m_autoColor = nColor
END PROPERTY
' ========================================================================================
' ========================================================================================
PROPERTY CCbColor.UserColor () AS COLORREF
   PROPERTY = m_autoColor
END PROPERTY
' ========================================================================================

' ========================================================================================
' Get the selected color
' ========================================================================================
PROPERTY CCbColor.SelColor () AS COLORREF
   DIM nSel AS LRESULT
   nSel = SendMessageW(m_hCtl, CB_GETCURSEL, 0, 0)
   IF nSel > CB_ERR THEN PROPERTY = this.GetQBColor(m_hCtl, nSel, 1)
END PROPERTY
' ========================================================================================

END NAMESPACE


[José Roca]

Example:

Code: [Select]

' ########################################################################################
' Microsoft Windows
' File: CW_CbColor.fbtpl - Template
' Contents: Demonstrates the use of the Combobox color list control
' Compiler: FreeBasic 32 & 64 bit
' Copyright (c) 2016 Jose Roca. Freeware. Use at your own risk.
' THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
' EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE IMPLIED WARRANTIES OF
' MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
' ########################################################################################

#define unicode
#INCLUDE ONCE "windows.bi"
#INCLUDE ONCE "Afx/CWindow.inc"
#INCLUDE ONCE "Afx/CCbColor.inc"
' $FB_RESPATH = "FBRES.rc"

USING Afx.CWindowClass
USING Afx.CCbColorClass

CONST IDC_CBCOLOR = 1001

DECLARE FUNCTION WinMain (BYVAL hInstance AS HINSTANCE, _
                          BYVAL hPrevInstance AS HINSTANCE, _
                          BYVAL szCmdLine AS ZSTRING PTR, _
                          BYVAL nCmdShow AS LONG) AS LONG

   END WinMain(GetModuleHandleW(""), NULL, COMMAND(), SW_NORMAL)

' ========================================================================================
' Window procedure
' ========================================================================================
FUNCTION WndProc (BYVAL hWnd AS HWND, BYVAL uMsg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM) AS LRESULT

   SELECT CASE uMsg

      CASE WM_COMMAND
         SELECT CASE LOWORD(wParam)
            ' // If ESC key pressed, close the application sending an WM_CLOSE message
            CASE IDCANCEL
               IF HIWORD(wParam) = BN_CLICKED THEN
                  SendMessageW hwnd, WM_CLOSE, 0, 0
                  EXIT FUNCTION
               END IF
            CASE IDC_CBCOLOR
               ' // Get selected color
               IF HIWORD(wParam) = CBN_SELENDOK THEN
                  SCOPE
                  DIM dwColor AS COLORREF
                  dwColor = SendMessageW(CAST(HWND, lParam), CBCOL_GETSELCOLOR, 0, 0)
                  ' Alternate way
'                  DIM pCbColor AS CCbColor PTR = CAST(CCbColor PTR, GetPropW(CAST(HWND, lParam), "CBCOLORPTR"))
'                  IF pCbColor <> NULL THEN dwColor = pCbColor->SelColor
                  END SCOPE
               END IF
         END SELECT

     ' // Can't pass this message to the control because at the time
     ' // it is sent, the control has not yet been subclassed.
     CASE WM_MEASUREITEM
         SCOPE
         IF wParam = IDC_CBCOLOR THEN
            DIM pWindow AS CWindow PTR = CAST(CWindow PTR, GetWindowLongPtr(hwnd, 0))
            DIM pMeasureItem AS MEASUREITEMSTRUCT PTR = CAST(MEASUREITEMSTRUCT PTR, lParam)
            OutputDebugString "itemwidth = " & STR$(pMeasureItem->itemWidth)
            OutputDebugString "itemheight = " & STR$(pMeasureItem->itemHeight)
            pMeasureItem->itemHeight = pMeasureItem->itemHeight * (pWindow->rxRatio * 0.72)
            FUNCTION = CTRUE
            EXIT FUNCTION
         END IF
         END SCOPE

     ' // Must pass this one to the ownerdrawn combobox
     CASE WM_DRAWITEM
         IF wParam = IDC_CBCOLOR THEN
            SendMessageW GetDlgItem(hwnd, wParam), uMsg, wParam, lParam
            FUNCTION = CTRUE
            EXIT FUNCTION
         END IF

    CASE WM_DESTROY
         PostQuitMessage(0)
         EXIT FUNCTION

   END SELECT

   FUNCTION = DefWindowProcW(hWnd, uMsg, wParam, lParam)

END FUNCTION
' ========================================================================================

' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS HINSTANCE, _
                  BYVAL hPrevInstance AS HINSTANCE, _
                  BYVAL szCmdLine AS ZSTRING PTR, _
                  BYVAL nCmdShow AS LONG) AS LONG

   ' // Set process DPI aware
   AfxSetProcessDPIAware

   DIM pWindow AS CWindow
   pWindow.Create(NULL, "ComboBox color list", @WndProc, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT)
   pWindow.Center

   ' // Add a color combobox control
   DIM pCbColor AS CCbColor =  CCbColor(@pWindow, IDC_CBCOLOR, 80, 30, 190, 100, _
      GetSysColor(COLOR_WINDOWTEXT), GetSysColor(COLOR_WINDOWTEXT))

   ' // Select a color
   SendMessageW pCbColor.hWindow, CB_SETCURSEL, 5, 0

   FUNCTION = pWindow.DoEvents(nCmdShow)

END FUNCTION
' ========================================================================================


[José Roca]

This version uses SetWindowClass for subclassing, which makes life easier as it allows to pass a pointer ro reference data to the subclass procedure. Here I'm passing a pointe to the class; thereforem no need to SET/GET properties.

Code: [Select]

' ########################################################################################
' Microsoft Windows
' File: CbColor.inc
' Contents: Combobox color list
' Based on the CBCOLOR control originally written by Börje Hagsten in 2001.
' Compiler: FreeBasic 32 & 64-bit
' Freeware. Use at your own risk.
' Copyright (c) 2016 Jose Roca. All Rights Reserved.
' THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
' EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE IMPLIED WARRANTIES OF
' MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
' ########################################################################################

#pragma once

#include once "windows.bi"
#include once "Afx/CWindow.inc"
#include once "win/commdlg.bi"

USING Afx.CWindowClass

NAMESPACE Afx.CCbColorClass

CONST CBCOL_SETAUTOCOLOR = WM_USER + 100
CONST CBCOL_SETUSERCOLOR = WM_USER + 101
CONST CBCOL_SETCOLORNAME = WM_USER + 102
CONST CBCOL_GETAUTOCOLOR = WM_USER + 200
CONST CBCOL_GETUSERCOLOR = WM_USER + 201
CONST CBCOL_GETSELCOLOR  = WM_USER + 202
CONST CBCOL_GETCLASSPTR  = WM_USER + 203

' ========================================================================================
' CCbColor class
' ========================================================================================
TYPE CCbColor

   Protected:
      m_hCtl  AS HWND           ' // Button handle
      m_hFont AS HFONT          ' // Font handle

   Public:
      m_autoColor AS COLORREF   ' // Auto color
      m_userColor AS COLORREF   ' // User color
      m_ratio AS SINGLE         ' // DPI ratio - width
      DIM m_rgColors(15) AS COLORREF
      DIM m_rgNames (17) AS WSTRING * 20 = {"Auto", "Black", "Blue", "Green", "Cyan", "Red", _
         "Magenta", "Brown", "Light Gray", "Gray", "Light Blue", "Light Green", "Light Cyan", _
         "Light Red", "Light Magenta", "Yellow", "Bright White", "User selected..."}

      DECLARE CONSTRUCTOR (BYVAL pWindow AS CWindow PTR, BYVAL cID AS INTEGER,  _
         BYVAL x AS LONG = 0, BYVAL y AS LONG = 0, BYVAL nWidth AS LONG = 0, BYVAL nHeight AS LONG = 0, _
         BYVAL dwAutoColor AS COLORREF = 0, BYVAL dwUserColor AS COLORREF = 0)
      DECLARE DESTRUCTOR
      DECLARE FUNCTION hWindow () AS HWND
      DECLARE FUNCTION GetQBColor (BYVAL hWnd AS HWND, BYVAL c AS LONG, BYVAL dlg AS LONG) AS COLORREF
      DECLARE PROPERTY AutoColor (BYVAL nColor AS COLORREF)
      DECLARE PROPERTY AutoColor () AS COLORREF
      DECLARE PROPERTY UserColor (BYVAL nColor AS COLORREF)
      DECLARE PROPERTY UserColor () AS COLORREF
      DECLARE PROPERTY SelColor () AS COLORREF

END TYPE
' ========================================================================================

' ========================================================================================
' Subclassed window procedure
' ========================================================================================
FUNCTION CCbColorProc ( _
   BYVAL hwnd   AS HWND, _                 ' // Control window handle
   BYVAL uMsg   AS UINT, _                 ' // Type of message
   BYVAL wParam AS WPARAM, _               ' // First message parameter
   BYVAL lParam AS LPARAM, _               ' // Second message parameter
   BYVAL uIdSubclass AS UINT_PTR, _        ' // The subclass ID
   BYVAL dwRefData AS DWORD_PTR _          ' // Pointer to reference data
   ) AS LRESULT

   DIM pCbColor AS CCbColor PTR

   SELECT CASE uMsg

      CASE WM_CREATE
         EXIT FUNCTION

      CASE WM_DESTROY
         ' // REQUIRED: Remove control subclassing
         RemoveWindowSubclass hwnd, @CCbColorProc, uIdSubclass
         EXIT FUNCTION

      CASE WM_DRAWITEM
         ' // Get a pointer to the class
         pCbColor = CAST(CCbColor PTR, dwRefData)
         IF pCbColor = NULL THEN EXIT FUNCTION
         SCOPE
         DIM hBrush AS HBRUSH, wszText AS WSTRING * 80
         DIM lpdis AS DRAWITEMSTRUCT PTR, rc AS RECT
         lpdis = CAST(DRAWITEMSTRUCT PTR, lParam)
         IF lpdis->itemID = &hFFFFFFFF THEN EXIT FUNCTION
         SELECT CASE lpdis->itemAction
            CASE ODA_DRAWENTIRE, ODA_SELECT
               ' // Clear background
               FillRect lpdis->hDC, @lpdis->rcItem, .GetSysColorBrush(COLOR_WINDOW)
               ' // Get/draw text
               .SendMessageW hwnd, CB_GETLBTEXT, lpdis->itemID, CAST(.LPARAM, @wszText)
               .SetBkColor lpdis->hDC, GetSysColor(COLOR_WINDOW)
               .SetTextColor lpdis->hDC, GetSysColor(COLOR_WINDOWTEXT)
               rc = lpdis->rcItem
               rc.Left = 28 * (pCbColor->m_ratio * 0.72)
               .DrawTextW lpdis->hDC, @wszText, LEN(wszText), @rc, DT_SINGLELINE OR DT_LEFT OR DT_VCENTER
               ' // If selected item...
               IF (lpdis->itemState AND ODS_SELECTED) THEN
                  ' // If not ODS_COMBOBOXEDIT...
                  IF (lpdis->itemState AND ODS_COMBOBOXEDIT) = 0 THEN
                     ' // Set coordinates
                     rc.Left = 26 * (pCbColor->m_ratio * 0.72)
                     rc.Right = lpdis->rcItem.Right
                     rc.Top = lpdis->rcItem.Top
                     rc.Bottom = lpdis->rcItem.Bottom
                     ' // Invert area around text only
                     .InvertRect lpdis->hDC, @rc
                  END IF
                  ' // and draw a focus rectangle around all
                  .DrawFocusRect lpdis->hDC, @lpdis->rcItem
               END IF
               ' // Paint color rectangle using RoundRect for nicer looks
               ' /// If ODS_COMBOBOXEDIT...
               IF (lpdis->itemState AND ODS_COMBOBOXEDIT) THEN
                  ' // Set coordinates
                  rc.Left = 4 * (pCbColor->m_ratio * 0.72)
                  rc.Right = 24 * (pCbColor->m_ratio * 0.72)
               ELSE
                  ' // A tiny bit to the left in list...
                  rc.Left = 3 * (pCbColor->m_ratio * 0.72)
                  rc.Right = 23 * (pCbColor->m_ratio * 0.72)
               END IF
               rc.Top    = (lpdis->rcItem.Top + (2 * pCbColor->m_ratio))
               rc.Bottom = (lpdis->rcItem.Bottom - (2 * pCbColor->m_ratio))
               ' // Create brush with the appropriate color
               hBrush = .CreateSolidBrush(pCbColor->GetQBColor(hWnd, lpdis->itemID, FALSE))
               ' // Select brush into device context
               hBrush = .SelectObject(lpdis->hDC, hBrush)
               ' // Draw the rectangle
               DIM nCorner AS LONG = pCbColor->m_ratio * 0.72
               .RoundRect(lpdis->hDC, rc.Left, rc.Top, rc.Right, rc.Bottom, nCorner, nCorner)
               ' // Select old brush back and delete new one
               .DeleteObject .SelectObject(lpdis->hDC, hBrush)
            END SELECT
         END SCOPE
         FUNCTION = CTRUE
         EXIT FUNCTION

      ' // Returns the class pointer
      CASE CBCOL_GETCLASSPTR
         FUNCTION = dwRefData
         EXIT FUNCTION

      ' // Set auto color
      CASE CBCOL_SETAUTOCOLOR
         pCbColor = CAST(CCbColor PTR, dwRefData)
         IF pCbColor = NULL THEN EXIT FUNCTION
         pCbColor->m_AutoColor = wParam
         EXIT FUNCTION

      ' // Set auto color
      CASE CBCOL_GETAUTOCOLOR
         pCbColor = CAST(CCbColor PTR, dwRefData)
         IF pCbColor = NULL THEN EXIT FUNCTION
         FUNCTION = pCbColor->m_AutoColor
         EXIT FUNCTION

      ' // Set user color
      CASE CBCOL_SETUSERCOLOR
         pCbColor = CAST(CCbColor PTR, dwRefData)
         IF pCbColor = NULL THEN EXIT FUNCTION
         FUNCTION = pCbColor->m_UserColor
         EXIT FUNCTION

      ' // Get user color
      CASE CBCOL_GETUSERCOLOR
         pCbColor = CAST(CCbColor PTR, dwRefData)
         IF pCbColor = NULL THEN EXIT FUNCTION
         FUNCTION = pCbColor->m_UserColor
         EXIT FUNCTION

      ' // Return selected color
      CASE CBCOL_GETSELCOLOR
         DIM nRes AS LONG
         nRes = SendMessageW(hwnd, CB_GETCURSEL, 0, 0)
         pCbColor = CAST(CCbColor PTR, dwRefData)
         IF pCbColor = NULL THEN EXIT FUNCTION
         IF nRes > CB_ERR THEN
            FUNCTION = pCbColor->GetQBColor(hwnd, nRes, CTRUE)
         END IF
         EXIT FUNCTION

   END SELECT

   ' // Default processing for other messages
   FUNCTION = DefSubclassProc(hwnd, uMsg, wParam, lParam)

END FUNCTION
' ========================================================================================

' ========================================================================================
' CPgBar3D class constructor
' ========================================================================================
CONSTRUCTOR CCbColor (BYVAL pWindow AS CWindow PTR, BYVAL cID AS INTEGER,  _
   BYVAL x AS LONG = 0, BYVAL y AS LONG = 0, BYVAL nWidth AS LONG = 0, BYVAL nHeight AS LONG = 0, _
   BYVAL dwAutoColor AS COLORREF = 0, BYVAL dwUserColor AS COLORREF = 0)

   ' // Create the control
   IF pWindow THEN
      m_hCtl = pWindow->AddControl("COMBOBOX", pWindow->hWindow, cID, "", _
      x, y, nWidth, nHeight, WS_CHILD OR WS_VISIBLE OR CBS_OWNERDRAWFIXED OR CBS_HASSTRINGS OR _
      CBS_DROPDOWNLIST OR WS_TABSTOP OR CBS_DISABLENOSCROLL OR WS_VSCROLL, WS_EX_CLIENTEDGE, _
      NULL, CAST(WNDPROC, @CCbColorProc), cID, CAST(DWORD_PTR, @this))
      m_ratio = pWindow->rxRatio
   END IF
   IF m_hCtl THEN
      ' // Set the same font used by the parent
      DIM lfw AS LOGFONTW
      IF pWindow->Font THEN
         IF GetObjectW(pWindow->Font, SIZEOF(lfw), @lfw) THEN m_hFont = CreateFontIndirect(@lfw)
      END IF
      ' // Add the strings
      DIM i AS LONG
      FOR i = 0 TO UBOUND(m_rgNames)
         SendMessageW m_hCtl, CB_ADDSTRING, 0, CAST(LPARAM, @m_rgNames(i))
      NEXT
      ' // Store default values (usually COLOR_WINDOW or COLOR_WINDOWTEXT)
      m_AutoColor = dwAutoColor
      m_UserColor = dwUserColor
      ' // Create initial colormap for the ChooseColor dialog
      DIM cl AS LONG
      FOR i = 1 TO 16
         cl = i * 16 - 1
         m_rgColors(16 - i) = BGR(cl, cl, cl)
      NEXT
   END IF

END CONSTRUCTOR
' ========================================================================================

' ========================================================================================
' CPgBar3D class destructor
' ========================================================================================
DESTRUCTOR CCbColor
   ' // Free resources
   IF m_hFont THEN DeleteObject m_hFont
END DESTRUCTOR
' ========================================================================================

' ========================================================================================
' Returns the handle of the button
' ========================================================================================
FUNCTION CCbColor.hWindow () AS HWND
   FUNCTION = m_hCtl
END FUNCTION
' ========================================================================================

' ========================================================================================
' Basic QB color function.
' ========================================================================================
FUNCTION CCbColor.GetQBColor (BYVAL hwnd AS HWND, BYVAL c AS LONG, BYVAL dlg AS LONG) AS COLORREF

   SELECT CASE c
      CASE  0 : FUNCTION = m_AutoColor          ' // Pre-set system color, like COLOR_WINDOW or COLOR_WINDOWTEXT
      CASE  1 : FUNCTION = BGR(0,     0,   0)   ' // Black
      CASE  2 : FUNCTION = BGR(0,     0, 128)   ' // Blue
      CASE  3 : FUNCTION = BGR(0,   128,   0)   ' // Green
      CASE  4 : FUNCTION = BGR(0,   128, 128)   ' // Cyan
      CASE  5 : FUNCTION = BGR(196,   0,   0)   ' // Red
      CASE  6 : FUNCTION = BGR(128,   0, 128)   ' // Magenta
      CASE  7 : FUNCTION = BGR(128,  64,   0)   ' // Brown
      CASE  8 : FUNCTION = BGR(196, 196, 196)   ' // Light Gray
      CASE  9 : FUNCTION = BGR(128, 128, 128)   ' // Gray
      CASE 10 : FUNCTION = BGR(0,     0, 255)   ' // Light Blue
      CASE 11 : FUNCTION = BGR(0,   255,   0)   ' // Light Green
      CASE 12 : FUNCTION = BGR(0,   255, 255)   ' // Light Cyan
      CASE 13 : FUNCTION = BGR(255,   0,   0)   ' // Light Red
      CASE 14 : FUNCTION = BGR(255,   0, 255)   ' // Light Magenta
      CASE 15 : FUNCTION = BGR(255, 255,   0)   ' // Yellow
      CASE 16 : FUNCTION = BGR(255, 255, 255)   ' // White
      CASE 17
         ' // Display the ChooseColor dialog
         IF dlg THEN
            DIM cc AS CHOOSECOLORW
            ' // Size of the structure
            cc.lStructSize  = SIZEOF(cc)
            ' // Pointer to the custom defined gray color array
            cc.lpCustColors = @m_rgColors(0)
            cc.Flags        = CC_RGBINIT OR CC_FULLOPEN
            cc.hwndowner    = hwnd
            ' // Allow the dialog to "auto-select" previously selected color
            ' // (only works for base colors, but still better than nothing)
            cc.rgbResult    = m_UserColor
            IF .ChooseColorW(@cc) THEN
               m_UserColor = cc.rgbResult
              .InvalidateRect hwnd, NULL, 0
              .UpdateWindow hWnd
            END IF
         END IF
         ' // Return the user selected color
         FUNCTION = m_UserColor
   END SELECT

END FUNCTION
' ========================================================================================

' ========================================================================================
' Gets/sets the RGB auto color
' ========================================================================================
PROPERTY CCbColor.AutoColor (BYVAL nColor AS COLORREF)
   m_autoColor = nColor
END PROPERTY
' ========================================================================================
' ========================================================================================
PROPERTY CCbColor.AutoColor () AS COLORREF
   PROPERTY = m_autoColor
END PROPERTY

' ========================================================================================
' Gets/sets the RGB user color
' ========================================================================================
PROPERTY CCbColor.UserColor (BYVAL nColor AS COLORREF)
   m_autoColor = nColor
END PROPERTY
' ========================================================================================
' ========================================================================================
PROPERTY CCbColor.UserColor () AS COLORREF
   PROPERTY = m_autoColor
END PROPERTY
' ========================================================================================

' ========================================================================================
' Get the selected color
' ========================================================================================
PROPERTY CCbColor.SelColor () AS COLORREF
   DIM nSel AS LRESULT
   nSel = SendMessageW(m_hCtl, CB_GETCURSEL, 0, 0)
   IF nSel > CB_ERR THEN PROPERTY = this.GetQBColor(m_hCtl, nSel, 1)
END PROPERTY
' ========================================================================================

END NAMESPACE


[José Roca]

This example demonstrates the use of the CbColorEx control.

Code: [Select]

' ########################################################################################
' Microsoft Windows
' File: CW_CbColorEx.fbtpl - Template
' Contents: Demonstrates the use of the Combobox color list control
' Compiler: FreeBasic 32 & 64 bit
' Copyright (c) 2016 Jose Roca. Freeware. Use at your own risk.
' THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
' EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE IMPLIED WARRANTIES OF
' MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
' ########################################################################################

#define unicode
#INCLUDE ONCE "windows.bi"
#INCLUDE ONCE "Afx/CWindow.inc"
#INCLUDE ONCE "Afx/CCbColorEx.inc"
' $FB_RESPATH = "FBRES.rc"

USING Afx.CWindowClass
USING Afx.CCbColorClass

CONST IDC_CBCOLOR = 1001

DECLARE FUNCTION WinMain (BYVAL hInstance AS HINSTANCE, _
                          BYVAL hPrevInstance AS HINSTANCE, _
                          BYVAL szCmdLine AS ZSTRING PTR, _
                          BYVAL nCmdShow AS LONG) AS LONG

   END WinMain(GetModuleHandleW(""), NULL, COMMAND(), SW_NORMAL)

' ========================================================================================
' Window procedure
' ========================================================================================
FUNCTION WndProc (BYVAL hWnd AS HWND, BYVAL uMsg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM) AS LRESULT

   SELECT CASE uMsg

      CASE WM_COMMAND
         SELECT CASE LOWORD(wParam)
            ' // If ESC key pressed, close the application sending an WM_CLOSE message
            CASE IDCANCEL
               IF HIWORD(wParam) = BN_CLICKED THEN
                  SendMessageW hwnd, WM_CLOSE, 0, 0
                  EXIT FUNCTION
               END IF
            CASE IDC_CBCOLOR
               ' // Get selected color
               IF HIWORD(wParam) = CBN_SELENDOK THEN
                  SCOPE
                  DIM dwColor AS COLORREF
                  dwColor = SendMessageW(CAST(HWND, lParam), CBCOL_GETSELCOLOR, 0, 0)
                  ' Alternate way
'                  DIM pCbColor AS CCbColor PTR = CAST(CCbColor PTR, SendMessageW(CAST(HWND, lParam), CBCOL_GETCLASSPTR, 0, 0))
'                  IF pCbColor <> NULL THEN dwColor = pCbColor->SelColor
                  END SCOPE
               END IF
         END SELECT

     ' // Can't pass this message to the control because at the time
     ' // it is sent, the control has not yet been subclassed.
     CASE WM_MEASUREITEM
         SCOPE
         IF wParam = IDC_CBCOLOR THEN
            DIM pWindow AS CWindow PTR = CAST(CWindow PTR, GetWindowLongPtr(hwnd, 0))
            DIM pMeasureItem AS MEASUREITEMSTRUCT PTR = CAST(MEASUREITEMSTRUCT PTR, lParam)
            pMeasureItem->itemHeight = pMeasureItem->itemHeight * (pWindow->rxRatio * 0.72)
            FUNCTION = CTRUE
            EXIT FUNCTION
         END IF
         END SCOPE

     ' // Must pass this one to the ownerdrawn combobox
     CASE WM_DRAWITEM
         IF wParam = IDC_CBCOLOR THEN
            SendMessageW GetDlgItem(hwnd, wParam), uMsg, wParam, lParam
            FUNCTION = CTRUE
            EXIT FUNCTION
         END IF

    CASE WM_DESTROY
         PostQuitMessage(0)
         EXIT FUNCTION

   END SELECT

   FUNCTION = DefWindowProcW(hWnd, uMsg, wParam, lParam)

END FUNCTION
' ========================================================================================

' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS HINSTANCE, _
                  BYVAL hPrevInstance AS HINSTANCE, _
                  BYVAL szCmdLine AS ZSTRING PTR, _
                  BYVAL nCmdShow AS LONG) AS LONG

   ' // Set process DPI aware
   AfxSetProcessDPIAware

   DIM pWindow AS CWindow
   pWindow.Create(NULL, "ComboBox color list", @WndProc, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT)
   pWindow.Center

   ' // Add a color combobox control
   DIM pCbColor AS CCbColor =  CCbColor(@pWindow, IDC_CBCOLOR, 80, 30, 190, 100, _
      GetSysColor(COLOR_WINDOWTEXT), GetSysColor(COLOR_WINDOWTEXT))

   ' // Select a color
   SendMessageW pCbColor.hWindow, CB_SETCURSEL, 5, 0

   FUNCTION = pWindow.DoEvents(nCmdShow)

END FUNCTION
' ========================================================================================


[Paul Squires]

Hi Jose,

I expect dkl to fix the problems in the windowsx.bi soon as he has already replied to my posting in the FB forum. I have been working with other macros in that file and I have noticed a fair number of problems with the translation. I have manually made the changes to my copy of windowsx.bi for now as I await a new official copy. I have also been testing the use of message crackers and dedicated message handlers. I realize that you are not overly fond of that approach but I do like it especially for very large applications where it better promotes modularity. Just for fun, below is working code shows how your splitbutton.bas code can be modified to use the crackers. It gives me more of a feel of how Firefly separates messages into individual handlers.

Code: [Select]

' //
' //  Process WM_CREATE message for window/dialog: main
' //
Function main_OnCreate(ByVal HWnd As HWnd, ByVal lpCreateStructPtr As LPCREATESTRUCT) As BOOLEAN

   ' Message cracker macro expects a True to be returned for a successful
   ' OnCreate handler even though returning -1 from a standard WM_CREATE
   ' call would stop creating the window. This is just one of those Windows
   ' inconsistencies.
   Return True
End Function


' //
' //  Process WM_SIZE message for window/dialog: main
' //
Function main_OnSize(ByVal HWnd As HWnd, ByVal state As UINT, ByVal cx As Long, ByVal cy As Long) As LRESULT
   Dim pWindow As CWindow Ptr
   If state <> SIZE_MINIMIZED Then
      ' // Resize the button
      pWindow = Cast(CWindow Ptr, GetWindowLongPtr(HWnd, 0))
      pWindow->MoveWindow GetDlgItem(HWnd, IDCANCEL), pWindow->ClientWidth - 200, pWindow->ClientHeight - 90, 110, 23, CTRUE
   End If   
   Function = 0
End Function


' //
' //  Process WM_COMMAND message for window/dialog: main
' //
Function main_OnCommand(ByVal HWnd As HWnd, ByVal id As Long, ByVal hwndCtl As HWnd, ByVal codeNotify As UINT) As LRESULT

   Select Case id
      Case IDCANCEL
         ' If ESC key pressed, close the application sending an WM_CLOSE message
         If codeNotify = BN_CLICKED Then
            SendMessage HWnd, WM_CLOSE, 0, 0
         End If   
   End Select
   
   Function = 0
End Function


' //
' //  Process WM_NOTIFY message for window/dialog: main
' //
Function main_OnNotify(ByVal HWnd As HWnd, ByVal id As Long, ByVal pNMHDR As NMHDR Ptr) As LRESULT

   ' Processs notify messages sent by the split button
   'Dim pNmh As NMHDR Ptr = Cast(NMHDR Ptr, lParam)
   If pNMHDR->idFrom = IDCANCEL And pNMHDR->code = BCN_DROPDOWN Then
      Dim pDropDown As NMBCDROPDOWN Ptr = Cast(NMBCDROPDOWN Ptr, pNMHDR)
      ' // Get screen coordinates of the button
      Dim pt As Point = (pDropdown->rcButton.Left, pDropDown->rcButton.bottom)
      ClientToScreen(pNMHDR->hwndFrom, @pt)
      ' // Create a menu and add items
      Dim hSplitMenu As HMENU = CreatePopupMenu
      AppendMenuW(hSplitMenu, MF_BYPOSITION, IDC_MENUCOMMAND1, "Menu item 1")
      AppendMenuW(hSplitMenu, MF_BYPOSITION, IDC_MENUCOMMAND2, "Menu item 2")
      ' // Display the menu
      TrackPopupMenu(hSplitMenu, TPM_LEFTALIGN Or TPM_TOPALIGN, pt.x, pt.y, 0, HWnd, Null)
      Return CTRUE
      Exit Function
   End If
   
   Function = 0
End Function


' //
' //  Process WM_DESTROY message for window/dialog: main
' //
Function main_OnDestroy(HWnd As HWnd) As LRESULT
   ImageList_Destroy Cast(HIMAGELIST, SendMessageW(GetDlgItem(HWnd, IDCANCEL), TB_SETIMAGELIST, 0, 0))
   PostQuitMessage(0)
   Function = 0
End Function


' ========================================================================================
' Window procedure
' ========================================================================================
Function WndProc (ByVal HWnd As HWnd, ByVal uMsg As UINT, ByVal wParam As WPARAM, ByVal lParam As LPARAM) As LRESULT

   Select Case uMsg
      HANDLE_MSG (HWnd, WM_CREATE,   main_OnCreate)
      HANDLE_MSG (HWnd, WM_SIZE,     main_OnSize)
      HANDLE_MSG (HWnd, WM_DESTROY,  main_OnDestroy)
      HANDLE_MSG (HWnd, WM_COMMAND,  main_OnCommand)
      HANDLE_MSG (HWnd, WM_NOTIFY,   main_OnNotify)
   End Select

   ' for messages that we don't deal with
   Function = DefWindowProcW(HWnd, uMsg, wParam, lParam)

End Function
' ========================================================================================
     


[Paul Squires]

Hi Jose,

I am also curious as to why you are specifically using the "W" version of the api calls? From what I can see, once you define UNICODE then the "W" version of the message will be used.

For example, in winuser.bi for SendMessage:

Code: [Select]

declare function SendMessageA(byval hWnd as HWND, byval Msg as UINT, byval wParam as WPARAM, byval lParam as LPARAM) as LRESULT

#ifndef UNICODE
declare function SendMessage alias "SendMessageA"(byval hWnd as HWND, byval Msg as UINT, byval wParam as WPARAM, byval lParam as LPARAM) as LRESULT
#endif

declare function SendMessageW(byval hWnd as HWND, byval Msg as UINT, byval wParam as WPARAM, byval lParam as LPARAM) as LRESULT

#ifdef UNICODE
declare function SendMessage alias "SendMessageW"(byval hWnd as HWND, byval Msg as UINT, byval wParam as WPARAM, byval lParam as LPARAM) as LRESULT
#endif

Maybe it is just your personal preference?

[José Roca]

It is a way to make sure that the code will work even if the user does not define UNICODE, since all the code I'm writing is unicode aware.

The existence of the "A" and "W" functions was to ease the transition to unicode while keeping support for legacy applications. The version 6 of the common controls is unicode only. If you use SendMessageA instead of SendMessageW, Windows has to check if the target window is Unicode aware, convert the strings to unicode and call SendMessageW.

I would be happy removing all the "A" stuff from the headers.

[José Roca]

Hi Paul,

I'm having a problem.

If I have a global array, pass a pointer of a similar array to a procedure, how can I copy the contents of the passed array to the global array?

Code: [Select]

DIM m_rgNames (17) AS WSTRING * 20 = {"Auto", "Black", "Blue", "Green", "Cyan", "Red", _
   "Magenta", "Brown", "Light Gray", "Gray", "Light Blue", "Light Green", "Light Cyan", _
   "Light Red", "Light Magenta", "Yellow", "Bright White", "User selected..."}

SUB Foo2 (BYVAL prgNames AS WSTRING PTR, BYVAL numElements AS DWORD)

   DIM i AS LONG
   
   FOR i = 0 TO numElements - 1
   
      ... How to copy the contents of the array pointed by prgNames to m_rgNames

   NEXT

END SUB

SUB Foo

   DIM rgNames (17) AS WSTRING * 20 = {"Auto", "Negro", "Azul", "Verde", "Cian", "Rojo", _
      "Magenta", "Marrón", "Gris claro", "Gris", "Azul claro", "Verde claro", "Cian claro", _
      "Rojo claro", "Magenta claro", "Amarillo", "Blanco", "Selección libre..."}

   Foo @rgNames(0), 18

END SUB


[Paul Squires]

That is an interesting problem. I thought that it would be as simple as passing the array into Foo2 and have it copy to the global array element by element but when I print out the results the data is incorrect. You pass arrays to subs/functions without using BYVAL or BYREF. That is just a historical quirk in FB.

Not sure why it is not working. I will keep trying.

Code: [Select]


Dim Shared m_rgNames(17) As WString * 20 => {"Auto", "Black", "Blue", "Green", "Cyan", "Red", _
   "Magenta", "Brown", "Light Gray", "Gray", "Light Blue", "Light Green", "Light Cyan", _
   "Light Red", "Light Magenta", "Yellow", "Bright White", "User selected..."}

Sub Foo2 ( prgNames() As WString * 20, ByVal numElements As Long)

   Dim i As Long
   
   For i = 0 To numElements - 1
   
      '... How To copy the contents of the array pointed by prgNames To m_rgNames
      m_rgNames(i) = prgNames(i)
     
   Next

End Sub

Sub Foo

   Dim rgNames(17) As WString * 20 => {"Auto", "Negro", "Azul", "Verde", "Cian", "Rojo", _
      "Magenta", "Marrón", "Gris claro", "Gris", "Azul claro", "Verde claro", "Cian claro", _
      "Rojo claro", "Magenta claro", "Amarillo", "Blanco", "Selección libre..."}

   Foo2( rgNames(), 18 )

End Sub           


' call Foo to initiate the copying of rgNames to global array via sub Foo2
Foo

Dim i As Long
For i = 0 To 17
   Print m_rgNames(i)
Next

Sleep
   

[José Roca]

> I have also been testing the use of message crackers and dedicated message handlers.

For what I see, these aren't needed in CWindow or the custom controls. You can freely use them in your code if you like. Am I right?

[José Roca]

Well, of course there are other ways, even faster, for the array problem. Just wanted to know how to do it using FB statements.

I have changed the numElements parameter for numBytes and use:

Code: [Select]

   ' // Color names
   IF prgNames <> NULL AND numBytes < (18 * 20 * 2) + 1 THEN
      .memcpy @m_rgNames(0), prgNames, numBytes
   END IF

When calling it, I pass:

Code: [Select]

@rgNames(0), 18 * 20 * 2

With pointers we can do everything, but little error checking.

[José Roca]

I needed that to be able to use languages other than English for the color names. Being an optional parameter, I have to use a pointer.

Code: [Select]

' ########################################################################################
' Microsoft Windows
' File: CW_CbColorEx.fbtpl - Template
' Contents: Demonstrates the use of the Combobox color list control
' Compiler: FreeBasic 32 & 64 bit
' Copyright (c) 2016 Jose Roca. Freeware. Use at your own risk.
' THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
' EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE IMPLIED WARRANTIES OF
' MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
' ########################################################################################

#define unicode
#INCLUDE ONCE "windows.bi"
#INCLUDE ONCE "Afx/CWindow.inc"
#INCLUDE ONCE "Afx/CCbColorEx.inc"
' $FB_RESPATH = "FBRES.rc"

USING Afx.CWindowClass
USING Afx.CCbColorClass

CONST IDC_CBCOLOR = 1001

DECLARE FUNCTION WinMain (BYVAL hInstance AS HINSTANCE, _
                          BYVAL hPrevInstance AS HINSTANCE, _
                          BYVAL szCmdLine AS ZSTRING PTR, _
                          BYVAL nCmdShow AS LONG) AS LONG

   END WinMain(GetModuleHandleW(""), NULL, COMMAND(), SW_NORMAL)

' ========================================================================================
' Window procedure
' ========================================================================================
FUNCTION WndProc (BYVAL hWnd AS HWND, BYVAL uMsg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM) AS LRESULT

   SELECT CASE uMsg

      CASE WM_COMMAND
         SELECT CASE LOWORD(wParam)
            ' // If ESC key pressed, close the application sending an WM_CLOSE message
            CASE IDCANCEL
               IF HIWORD(wParam) = BN_CLICKED THEN
                  SendMessageW hwnd, WM_CLOSE, 0, 0
                  EXIT FUNCTION
               END IF
            CASE IDC_CBCOLOR
               ' // Get selected color
               IF HIWORD(wParam) = CBN_SELENDOK THEN
                  SCOPE
                  DIM dwColor AS COLORREF
                  dwColor = SendMessageW(CAST(HWND, lParam), CBCOL_GETSELCOLOR, 0, 0)
                  ' Alternate way
'                  DIM pCbColor AS CCbColor PTR = CAST(CCbColor PTR, SendMessageW(CAST(HWND, lParam), CBCOL_GETCLASSPTR, 0, 0))
'                  IF pCbColor <> NULL THEN dwColor = pCbColor->SelColor
                  END SCOPE
               END IF
         END SELECT

     ' // Can't pass this message to the control because at the time
     ' // it is sent, the control has not yet been subclassed.
     CASE WM_MEASUREITEM
         SCOPE
         IF wParam = IDC_CBCOLOR THEN
            DIM pWindow AS CWindow PTR = CAST(CWindow PTR, GetWindowLongPtr(hwnd, 0))
            DIM pMeasureItem AS MEASUREITEMSTRUCT PTR = CAST(MEASUREITEMSTRUCT PTR, lParam)
            pMeasureItem->itemHeight = pMeasureItem->itemHeight * (pWindow->rxRatio * 0.72)
            FUNCTION = CTRUE
            EXIT FUNCTION
         END IF
         END SCOPE

     ' // Must pass this one to the ownerdrawn combobox
     CASE WM_DRAWITEM
         IF wParam = IDC_CBCOLOR THEN
            SendMessageW GetDlgItem(hwnd, wParam), uMsg, wParam, lParam
            FUNCTION = CTRUE
            EXIT FUNCTION
         END IF

    CASE WM_DESTROY
         PostQuitMessage(0)
         EXIT FUNCTION

   END SELECT

   FUNCTION = DefWindowProcW(hWnd, uMsg, wParam, lParam)

END FUNCTION
' ========================================================================================

' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS HINSTANCE, _
                  BYVAL hPrevInstance AS HINSTANCE, _
                  BYVAL szCmdLine AS ZSTRING PTR, _
                  BYVAL nCmdShow AS LONG) AS LONG

   ' // Set process DPI aware
   AfxSetProcessDPIAware

   DIM pWindow AS CWindow
   pWindow.Create(NULL, "ComboBox color list", @WndProc, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT)
   pWindow.Center

   DIM rgNames (17) AS WSTRING * 20 = {"Auto", "Negro", "Azul", "Verde", "Cian", "Rojo", _
      "Magenta", "Marrón", "Gris claro", "Gris", "Azul claro", "Verde claro", "Cian claro", _
      "Rojo claro", "Magenta claro", "Amarillo", "Blanco", "Selección libre..."}

   ' // Add a color combobox control
   DIM pCbColor AS CCbColor =  CCbColor(@pWindow, IDC_CBCOLOR, 80, 30, 190, 100, _
      GetSysColor(COLOR_WINDOWTEXT), GetSysColor(COLOR_WINDOWTEXT), @rgNames(0), 18 * 20 * 2)

   ' // Select a color
   SendMessageW pCbColor.hWindow, CB_SETCURSEL, 5, 0

   FUNCTION = pWindow.DoEvents(nCmdShow)

END FUNCTION
' ========================================================================================


[Paul Squires]

Yeah, there must be a way to do it with traditional FB statements rather than pointers and copying memory. I will keep plugging away at it. If i can't figure it out then I will post over on FB forum.