ChooseFont Dialog subclass

Windows specific questions.
Posts: 13
Joined: Dec 26, 2012 6:33
Location: Oz

ChooseFont Dialog subclass

Postby ring0 » Jan 02, 2019 5:01

People are still posting their own GUI and owner drawn widgets but so far I did not see any alternative to the Windows ChooseFont dialog.

And one of my pet peeves is the humble LABEL widget. Microsoft does not call this widget a label, instead using the name STATIC, perhaps
because you can left and right click on it all day long and nothing will ever happen. I find this user operation incongruous since the
programmer can set the font face, attributes, size, text color, background color, border style, position and size of this widget at
both compile and run times but the poor user can effect no change at all.

Consider a user with vision impairment - would it not be beneficial for that user to be able to change the font face, size and color?
And what about the user who is sometimes operating in bright sunshine and sometimes in a darkened room - for example the bridge
of a ship at night. Would the ability to change colors of a label control not be beneficial?

The attached code demonstrates that it is indeed possible for the USER to select and set the font face, size, attributes and the text
and background colors. Other LABEL features such as the border style, size and position of the widget could also be changed by the
user but are not demonstrated in the supplied code.

Another of my pet peeves is the CHOOSEFONT dialog, specifically the text color is limited to just 16 options and the background color
cannot be selected at all. I have sub-classed the ChooseFont dialog so that both text and background colors can be selected by calling
the Windows standard ChooseColor dialog and the ChooseFont sample text is then presented in those colors.

In order to achieve this the rgbColors member of the ChooseFont structure has been re-purposed as a pointer to a UDT that holds two
integers in order to accommodate the text and background colors.


The code creates a small window with two labels (Standard and Enhanced). Right Click on the Enhanced Label and the ** NEW **
ChooseFont dialog will open allowing the font face, attributes, size, text and background colors for the label to be selected and set.
The code can be improved lots, it is still a work in progress - just thought I would share - maybe others have better ideas.

here fontSelect.rc

Code: Select all

#define frmLabels 1000
#define lblStandard 1001
#define lblEnhanced 1002
#define cmdExit 1004
#define cmdHelp 1003

frmLabels DIALOGEX 10,10,144,54
CAPTION "FontSelect Demo"
FONT 8,"MS Sans Serif",0,0,0
STYLE 0x10CA0000
  CONTROL "Windows standard label",lblStandard,"Static",0x50001300,5,6,134,12
  CONTROL "ring0 Enhanced label",lblEnhanced,"Static",0x50001300,5,22,134,12
  CONTROL "EXIT",cmdExit,"Button",0x50010000,78,39,60,12
  CONTROL "ABOUT",cmdHelp,"Button",0x50010000,6,39,60,12


Code: Select all

#Define  frmLabels       1000
#Define  lblStandard     1001
#Define  lblEnhanced     1002
#Define  cmdHelp         1003
#Define  cmdExit         1004
Type ToColor                                       ''' used with CHOOSEFONT structure
     fore As DWORD32                         ''' to SET and GET both
   back As DWORD32                        ''' TEXT and BACK color
End Type
Type textSize                                      ''' used with GetTextExtentPoint32
   As Long cx                                   ''' to determine pixel size of
   As Long cy                                   ''' specified text string
End Type 
Type StringDesc                                    ''' used in drawSampleText
   pointa As Zstring Ptr                          ''' actual string address
   length As Integer                               ''' actual length of string 
   memory As Integer                             ''' amount of memory allocated for string
End Type             
Dim Shared As ZString Ptr     CommandLine          ''' required by windoze
Dim Shared As HMODULE       hInstance                ''' required by windoze
Dim Shared As UINT32          iResult                     '''
Dim Shared As HWND            hWinMain                '''
Dim Shared As HWND            hWin                       '''
Dim Shared As HWND            hEnhanced              '''
Dim Shared As HDC               staticHDC                '''                                                         
Dim Shared As HBRUSH          bgBrush                 '''
Dim Shared As COLORREF      crLblText               '''
Dim Shared As COLORREF      crLblBack               '''
Dim Shared As ChooseFont Ptr  pCF                    '''
Const ClassName="DLGCLASS"                            ''' required by windoze
Const AppName="Dialog as main"                       ''' required by windoze

here FontSelect.bas

Code: Select all

#Include Once ""
#Include Once "win/"
#Include Once "win/"
#Include Once "win/"
#Include Once ""
Declare Function EnhancedSubClass(ByVal hWin As HWND,ByVal uMsg As UINT,ByVal wParam As INT32,ByVal lParam As UINT32) As INT32
Declare Function selectFont(hWin As HWND,FontHandle As HFONT,BGcolor As INT32,FGcolor As INT32) As Any Ptr
Declare Function cfHookProc(ByVal hWin As HWND,ByVal uMsg As UINT,ByVal wParam As Integer,ByVal lParam As Integer) As Integer
Declare Function selectColor(hWin As HWND,oldColor As COLORREF) As INT32                                                                                                             
Declare Function setStaticColor(hWin As HWND,BGcolor As INT32) As BOOLEAN
Declare Function drawSampleText(fHDC As HDC,FontHandle As HFONT,BGcolor As UINT32,FGcolor As UINT32) As BOOL
Function WndProc(ByVal hWin As HWND,ByVal uMsg As UINT,ByVal wParam As WPARAM,ByVal lParam As LPARAM) As Integer
   ''' procedure for main window
   Select Case uMsg
         ''' definitions
         hWinMain = hWin                                 
         hEnhanced = GetDlgItem(hWin,lblEnhanced)                                                                                                               
         staticHDC = GetDC(hEnhanced)
         ''' sub-class Enhanced static control to capture WM_RBUTTONDOWN                                       
          Dim As Long EnhancedProcOrg = SetWindowLong(hEnhanced,GWL_WNDPROC,Cast(DWORD,@EnhancedSubClass))
         ''' Wparam = HDC of static
         ''' Lparam = HWND of static           
         Dim As COLORREF  bgKolor
         If lParam = hEnhanced Then             
            If pCF Then
              ''' we only want to set the colors here IF the user has actually selected colors   
               ''' if the application returns a brush that it created,
               ''' then the application must free that brush!   
               If bgBrush Then DeleteObject(bgBrush)
                  bgBrush = CreateSolidBrush(crLblBack)                                                                                                           
                  Return Cast(Long,bgBrush)
      Case WM_PAINT
      Case WM_COMMAND                 
         Select Case HiWord(wParam)           
            Case BN_CLICKED,1                                                   
               Select Case LoWord(wParam)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        
                  Case lblStandard
                     ''' nothing to see here, move along!
                  Case lblEnhanced
                     ''' ignore left mouse button
                     ''' right mouse button is captured and handled at EnhancedSubClass proc                                                                                       
                  Case cmdHelp
                     MessageBox(hWin,"Windows ChooseFont subclass demonstration by ring0","FontSelect",MB_ICONINFORMATION Or MB_OK)
                  Case cmdExit
               End Select               
         End Select                                                                                                                                                                                                                         
      Case WM_CLOSE
         ''' The application should call the DeleteObject function to delete any font 
         ''' when it is no longer needed; for example, after it destroys the control.
         If bgBrush Then DeleteObject(bgBrush)
      Case WM_DESTROY
   End Select
   ''' NB: if we don't do the following then CPU load = 50% for this process in Task Manager
   Function = DefWindowProc(hWin,uMsg,wParam,lParam)
End Function
Function WinMain(ByVal hInst As HINSTANCE,ByVal hPrevInst As HINSTANCE,ByVal CmdLine As ZString ptr,ByVal CmdShow As Integer) As Integer
   wc.cbSize        = SizeOf(WNDCLASSEX)         = CS_HREDRAW or CS_VREDRAW Or CS_PARENTDC
   wc.lpfnWndProc   = @WndProc
   wc.cbClsExtra    = 0
   wc.cbWndExtra    = DLGWINDOWEXTRA
   wc.hInstance     = hInst
   wc.hbrBackground = Cast(HBRUSH,COLOR_BTNFACE+1)
   wc.lpszMenuName  = NULL
   wc.lpszClassName = @ClassName
   wc.hIcon         = LoadIcon(NULL,IDI_APPLICATION)
   wc.hIconSm       = wc.hIcon
   wc.hCursor       = LoadCursor(NULL,IDC_ARROW)
   Dim As HWND hWin = CreateDialogParam(hInstance,Cast(ZString Ptr,frmLabels),NULL,@WndProc,NULL)   
   Dim msg As MSG
   While (GetMessage(@msg,NULL,0,0) <> FALSE)
   Return msg.wParam
End Function
''' Program start ----------------------------------------------------------
Function EnhancedSubClass(ByVal hWin As HWND,ByVal uMsg As UINT,ByVal wParam As INT32,ByVal lParam As UINT32) As INT32
   ''' SubClass procedure for Enhanced Label - trap mouse right click and call SelectFont,
   '''                                       - on return set : Enhanced Label font and color attributes
   '''                                                       : display selected font attributes at FormMain
   Select Case uMsg
         ''' parse the font, size, attributes, fore and back colors to Windoze ChooseFont dialog
         Dim As HFONT labelFont = SendMessage(hWin,WM_GETFONT,0,0)
         Dim As INT32 labelFore = GetTextColor(staticHDC)
         Dim As INT32 labelBack = GetPixel(GetDC(hWin),1,1)                                                                                                                                                                                                                                                                         
                            pCF = selectFont(hWin,labelFont,labelBack,labelFore)
         If pCF Then
            Dim As ToColor Ptr p2C = Cast(ToColor Ptr,pCF -> rgbColors)
            crLblBack = Cast(COLORREF,p2C -> back)
            crLblText = Cast(COLORREF,p2C -> fore)
            Dim As LOGFONT Ptr pLF = pCF -> lpLogFont
            Dim As hFont hUserFont = CreateFontIndirect(pLF)
      Case Else
         Dim As Any Ptr EnhancedProcOrg = Cast(UInteger Ptr,GetWindowLongPtr(hWin,GWLP_USERDATA))
         Return CallWindowProc(EnhancedProcOrg,hWin,uMsg,wParam,lParam)
   End Select
End Function

Function selectFont(hWin As HWND,FontHandle As HFONT,BGcolor As INT32,FGcolor As INT32) As Any Ptr
   ''' this function is a wrapper for the Windoze ChooseFont dialog
   ''' in particular cf.RGBcolors is now a pointer to UDT color type
   Static As LOGFONT lf                                 
   Dim cfColor As ToColor
   cfColor.fore = FGcolor
   cfColor.back = BGcolor
   Static As ChooseFont cf
                        cf.lStructSize    = SizeOf(cf)
                        cf.hwndOwner      = hWin
                        cf.hDC            = NULL                  '' used for printers
                        cf.lpLogFont      = @lf
                        cf.iPointSize     = 0                     '' size of selected font on exit
                              ' CF_EFFECTS causes Strikethru, Underline and text color options to be displayed
                              ' CF_FIXEDPITCHONLY                               
                        cf.rgbColors      = Cast(DWORD,@cfColor)  '' selected color value
                        cf.lCustData      = Cast(DWORD,@cf)       '' lParam data passed to hook proc
                        cf.lpfnHook       = @cfHookProc
                        cf.lpTemplateName = NULL
                        cf.hInstance      = NULL
                        cf.lpszStyle      = NULL                  '' required if CF_USESTYLE flag is specified
                        cf.nFontType      = SCREEN_FONTTYPE                     
                        cf.nSizeMin       = 0                     '' required if CF_LIMITSIZE flag is specified
                        cf.nSizeMax       = 0                     '' required if CF_LIMITSIZE flag is specified
   If cf.iPointSize Then      
      Return @cf   
      Return 0
End Function
Function cfHookProc(ByVal hWin As HWND,_     
                    ByVal uMsg As UINT,_
                    ByVal wParam As Integer,_
                    ByVal lParam As Integer) As Integer
   ''' this function is the hook procedure for Windoze ChooseFont dialog
   ''' if this hook procedure returns zero, the default dialog box procedure processes the message.
        ''' if this hook procedure returns a nonzero value, the default dialog box procedure ignores the message.
   Static As ZString Ptr pszFace
   Static As ChooseFont Ptr pCF
   Static As LOGFONT Ptr pLF
   Static As COLORREF crBack
   Static As COLORREF crFore
   Static As UINT32 iHeight
   Static As UINT32 iWeight
   Static As HFONT hFontSample
   Static As HWND hWinCF
   Static As HDC  CF_HDC
   Static As BOOL bStrike
   Static As BOOL bItalic
   Static As BOOL bUnder
   Static As BOOL bOK
   Select Case uMsg
         ''' LPARAM = pointer to CHOOSEFONT structure
         pCF = Cast(ChooseFont Ptr,lParam)
         pLF = pCF -> lpLogFont
         iHeight = pLF -> lfHeight                       
         bOK = FALSE                                                                                                   
         hWinCF = hWin
         CF_HDC = GetDC(hWin)                                                          
         Dim As ToColor Ptr pMyColors = Cast(ToColor Ptr,pCF -> rgbColors)
         crBack = pMyColors -> back Or &H80000000
         crFore = pMyColors -> fore Or &H80000000
         Dim As handle hFont = SendDlgItemMessage(hWin,1136,WM_GETFONT,0,0)                                                                                                                     
         pszFace = Callocate(33,SizeOf(Byte))            ''' face name string
         ShowWindow(GetDlgItem(hWin,&H473),SW_HIDE)      ''' Color label
         ShowWindow(GetDlgItem(hWin,&H443),SW_HIDE)      ''' Color combo   
         CreateWindow("Button","Set Text Color",WS_CHILD Or WS_VISIBLE,18,223,100,18,hWin,1501,GetModuleHandle(0),0)
         Dim As HWND hFore = CreateWindow("STATIC","",WS_CHILD Or WS_VISIBLE Or SS_SUNKEN Or SS_NOTIFY,128,224,20,17,hWin,1502,0,NULL)
         CreateWindow("Button","Set Back Color",WS_CHILD Or WS_VISIBLE,18,245,100,18,hWin,1503,GetModuleHandle(0),0)                                                                                                             
         Dim As HWND hBack = CreateWindow("STATIC","",WS_CHILD Or WS_VISIBLE Or SS_SUNKEN Or SS_NOTIFY,128,245,20,17,hWin,1504,0,NULL)
         SetWindowPos(GetDlgItem(hWin,1),HWND_TOP,210,285,0,0,SWP_NOZORDER Or SWP_NOSIZE)    ''' OK
         SetWindowPos(GetDlgItem(hWin,2),HWND_TOP,100,285,0,0,SWP_NOZORDER Or SWP_NOSIZE)    ''' CANCEL
         SetWindowPos(hWin,HWND_TOP,0,0,350,346,SWP_NOMOVE Or SWP_NOZORDER)                  ''' FORM
         ''' sent for example when the window must be resized.
         ''' is NOT sent prior to a BitBlt
         ''' sent to a dialog box before windows draws the dialog box
         ''' allow user to set the background color of the dialog box   
         ''' Wparam = HDC static
         ''' Lparam = HWND static         
         Static As HBRUSH bgBrush
         Dim As COLORREF bgKolor
         bgKolor = Cast(COLORREF,GetWindowLong(Cast(HWND,lParam),GWLP_USERDATA))     
         If bgKolor Then
            If bgBrush Then DeleteObject(bgBrush)
            bgBrush = CreateSolidBrush(bgKolor And &HFFFFFF)                                                                                                           
            Return Cast(Long,bgBrush)
      Case WM_PAINT
         ''' Wparam = HDC   
         ''' always arrives here with WPARAM = 0 when Sample Text is to be re-drawn
         ''' we capture all the font parameters and post a message to ourself, then
         ''' allow the ChooseFont dialog default code to execute.
         ''' After that is complete we receive the message we sent and can then
         ''' process and display the full color version of sample text.
         '''   Case 1136:              ''' font face name combo box
            iResult = SendDlgItemMessage(hWin,1136,CB_GETCURSEL,0,0)                               
         '''   Case 1137:              ''' font attribute combo box
            iResult = SendDlgItemMessage(hWin,1137,CB_GETCURSEL,0,0)
            Dim As UINT32 iLength = SendDlgItemMessage(hWin,1137,CB_GETLBTEXTLEN,iResult,0)
            Dim As ZString Ptr pszAttr = Callocate(iLength+1,SizeOf(Byte))
            Dim As UByte iByte = pszAttr[0]
            Select Case iByte
               Case 66                                ''' Black / Bold / Bold Oblique
                  If pszAttr[1] = 108 Then            ''' Black
                     iWeight = 900                           
                     bItalic = FALSE
                  If pszAttr[1] = 111 Then            ''' Bold
                       iWeight = 700     
                     bItalic = FALSE
                  If iLength > 6 Then                 ''' Bold Oblique
                     iWeight = 700
                     bItalic = TRUE
               Case 73                                ''' Italic
                  bItalic = TRUE
               Case 78                                ''' Narrow / Narrow Italic / Narrow Bold / Narrow Bold Italic
                  If iLength > 13 Then                ''' Narrow Bold Italic
                     iWeight = 700
                     bItalic = TRUE
                     If iLength > 6 Then              ''' Narrow Italic
                        If pszAttr[7] = 73 Then       
                           iWeight = 400
                           bItalic = TRUE
                        If pszAttr[7] = 66 Then       ''' Narrow Bold
                           iWeight = 700
                           bItalic = FALSE
                        iWeight = 400
                        bItalic = FALSE
               Case 79                                ''' Oblique
                  iWeight = 400
                  bItalic = TRUE
               Case 82                                ''' Regular
                  iWeight = 400
                  bItalic = FALSE
            End Select
      Case WM_COMMAND                                                                                                             
         Select Case LoWord(wParam)
            Case 1                  ''' OK             
               pCF -> iPointSize = iHeight               
               Dim As ToColor Ptr pToColor = pCF -> rgbColors
                                  pToColor -> back = crBack
                                  pToColor -> fore = crFore   
               pLF -> lfHeight = iHeight
               pLF -> lfWeight = iWeight
               pLF -> lfItalic = bItalic
               pLF -> lfUnderline = bUnder
               pLF -> lfStrikeOut = bStrike
               bOK  = TRUE
               Return 1
            Case 2                  ''' CANCEL
               If bOK = FALSE Then  ''' we really do cancel
                  pCF -> iPointSize = 0
            Case 1138:              ''' font size combo box
            iResult = SendDlgItemMessage(hWin,1138,CB_GETCURSEL,0,0)
            Dim As String sSize = " "  ''' allocate space
            Dim As StringDesc Ptr psd = CPtr(StringDesc Ptr,@sSize)
            iHeight = ValUInt(sSize)
            Case 1040:              ''' font strikeout check box
            bStrike = SendDlgItemMessage(hWin,1040,BM_GETCHECK,0,0)
            Case 1041:              ''' font underline check box
            bUnder = SendDlgItemMessage(hWin,1041,BM_GETCHECK,0,0)                             
            Case 1501, 1502:        ''' text color
               Dim As INT32 iResult = selectColor(hWin,crFore)
               If iResult <> -1 Then
                  crFore = iResult
                  GoTo showSample
            Case 1503,1504:         ''' back color
               iResult = selectColor(hWin,crBack)
               If iResult <> -1 Then
                  crBack = iResult
                  GoTo showSample
         End Select                                                                                 
      Case WM_APP
         GoTo showSample
   End Select
   Return 0
      If hFontSample Then DeleteObject(hFontSample)
         hFontSample = CreateFont(iHeight,0,0,0,_
                                  DEFAULT_QUALITY,DEFAULT_PITCH or FF_DONTCARE,pszFace)                                                                                                     
      Return 0
End Function
Function selectColor(hWin As HWND,oldColor As COLORREF) As INT32
   ''' wrapper for Windoze chooseColor dialog
   ''' return value is INT32 so that we can return -1 if user selects CANCEL
   Static As COLORREF customColor(0 To 15)
   Dim As ChooseColor cc
                      cc.lStructSize    = SizeOf(cc)
                      cc.hwndOwner      = hWin
                      cc.hInstance      = NULL
                      cc.rgbResult      = oldColor
                      cc.lpCustColors   = @customColor(0)
                      cc.Flags          = CC_FULLOPEN Or CC_RGBINIT
                      cc.lCustData      = NULL
                      cc.lpfnHook       = NULL
                      cc.lpTemplateName = NULL
   If ChooseColor(@cc) Then
      Return cc.rgbResult
      Return -1
End Function
Function setStaticColor(hWin As HWND,BGcolor As INT32) As BOOLEAN
   Dim As HDC  staticDC = GetDC(hWin)
   Dim As RECT staticRECT
   Dim As HBRUSH newBrush = CreateSolidBrush(BGcolor)
   Dim As HBRUSH oldBrush = SelectObject(staticDC,newBrush)
   ''' by filling the rect we brush over any text
   ''' set MSB so we know a color has been set - even if the color is zero!!
   BGcolor = BGcolor Or &H80000000
   Return TRUE
End Function
Function drawSampleText(fHDC As HDC,FontHandle As HFONT,BGcolor As UINT32,FGcolor As UINT32) As BOOL
   Static As HDC      hdcMemSample
   Static As HBITMAP  bmpMemSample   
   Static As COLORREF fHDC_Color
   If hdcMemSample Then
   If FontHandle Then
      fHDC_Color   = GetBkColor(fHDC)
      hdcMemSample = CreateCompatibleDC(NULL)     
      Dim As String sSample = "aAbByYzZ"
      Dim As StringDesc Ptr pSampleData = CPtr(StringDesc Ptr,@sSample)                     
      Dim As UINT32 textLong = pSampleData->length                      ''' number of characters in string                                                                                                                                   
      Dim As HFONT hdcMemFont = SelectObject(hdcMemSample,FontHandle)           
      ''' we always make the bitmap at least large enough to accomodate the sample text
      ''' but never smaller than the size of the sample text display area so that we 
      ''' will always cover whatever was there before. 
      Dim As textSize newSize
      Dim As UINT32 bmpSizeX, bmpSizeY
      Dim As UINT32 bmpDrawX, bmpDrawY
      If < 157 Then
         bmpSizeX = 157
         bmpDrawX = (157 -\2
         bmpSizeX =
         bmpDrawX = 0
      If < 48 Then
         bmpSizeY = 48
         bmpDrawY = (48 -\2 
         bmpSizeY =
         bmpDrawY = 0                                                                                                             
      bmpMemSample = CreateBitmap(bmpSizeX,bmpSizeY,1,32,NULL)                                                                                                                     
      Dim As HBITMAP bmpMemFirst = SelectObject(hdcMemSample,bmpMemSample)
      ''' flood fill the bitmap with backgound color
      Dim As HPEN newPen = CreatePen(PS_SOLID,1,Cast(COLORREF,BGcolor And &HFFFFFF))
      Dim As HPEN oldPen = SelectObject(hdcMemSample,newPen)
      Dim As HBRUSH oldBrush = SelectObject(hdcMemSample,CreateSolidBrush(BGcolor And &HFFFFFF))
      ''' write the text to memory bitmap
      SetBkColor(hdcMemSample,Cast(COLORREF,BGcolor And &HFFFFFF))
      SetTextColor(hdcMemSample,Cast(COLORREF,FGcolor And &HFFFFFF))           
      ''' TextOut is 3.6x faster than DrawText even after using Len function and DT_NOCLIP flag.
      ''' if the new bitmap is larger than the size of the sample box then only show the centre
      Dim As UINT32 xSource = 0
      If > 157 Then xSource = ( - 157)\2 
      Dim As UINT32 ySource = 0
      If > 48  Then ySource = ( - 48)\2   

      Return TRUE
   Return FALSE
End Function

Return to “Windows”

Who is online

Users browsing this forum: No registered users and 1 guest