ChooseFont Dialog subclass

Windows specific questions.
ring0
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.

OPERATION

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
CLASS "DLGCLASS"
STYLE 0x10CA0000
BEGIN
  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
END   


here fontSelect.bi

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 "windows.bi"
#Include Once "win/winnt.bi"
#Include Once "win/commdlg.bi"
#Include Once "win/commctrl.bi"
                                                                                                             
#Include Once "FontSelect.bi"
                                                                                                           
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
                                                                                                             
      Case WM_INITDIALOG
                                                                                                            
         ''' 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))
          SetWindowLongPtr(hEnhanced,GWLP_USERDATA,EnhancedProcOrg)
                                                                                                             
      Case WM_CTLCOLORSTATIC   
         ''' 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   
               SetBkColor(Cast(HDC,wParam),crLblBack)
               SetTextColor(Cast(HDC,wParam),crLblText)
               ''' 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)
            EndIf
         EndIf   
                                                                                                           
      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
                     SendMessage(hWin,WM_Close,0,0)
                                                                                                             
               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)
         DestroyWindow(hWin)
                                                                                                             
      Case WM_DESTROY
         PostQuitMessage(NULL)
                                                                                                             
   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
                                                                                                                                     
   Dim As WNDCLASSEX wc
   wc.cbSize        = SizeOf(WNDCLASSEX)
   wc.style         = 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)
   RegisterClassEx(@wc)
                                                                                                                   
   Dim As HWND hWin = CreateDialogParam(hInstance,Cast(ZString Ptr,frmLabels),NULL,@WndProc,NULL)   
   ShowWindow(hWin,SW_SHOWNORMAL)
   UpdateWindow(hWin)
                                                                                                                   
   Dim msg As MSG
   While (GetMessage(@msg,NULL,0,0) <> FALSE)
      TranslateMessage(@msg)
      DispatchMessage(@msg)
   Wend
   Return msg.wParam
                                                                                                                   
End Function
                                                                                                                   
''' Program start ----------------------------------------------------------
hInstance=GetModuleHandle(NULL)
CommandLine=GetCommandLine
InitCommonControls
WinMain(hInstance,NULL,CommandLine,SW_SHOWDEFAULT)
ExitProcess(0)
End
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
                                                                                                           
      Case WM_RBUTTONDOWN
                                                                                                                             
         ''' 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)
            SetBkColor(staticHDC,crLblBack)
            SetTextColor(staticHDC,crLblText)                                             
                                                               
            Dim As LOGFONT Ptr pLF = pCF -> lpLogFont
            Dim As hFont hUserFont = CreateFontIndirect(pLF)
            SendMessage(hWin,WM_SETFONT,hUserFont,TRUE)
                                                                                                             
         EndIf
                                                                                                             
      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                                 
   GetObject(FontHandle,SizeOf(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.Flags          = CF_SCREENFONTS Or CF_ENABLEHOOK Or CF_EFFECTS Or CF_INITTOLOGFONTSTRUCT
                              ' 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
                                                                                                             
   ChooseFont(@cf)
   If cf.iPointSize Then      
      Return @cf   
   Else
      Return 0
   EndIf
                                                                                                             
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
                                                                                                             
      Case WM_INITDIALOG
                                                                                                           
         ''' 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)
         SetWindowLong(hFore,GWL_USERDATA,Cast(Long,crFore))
                                                                                                             
         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)
         SetWindowLong(hBack,GWL_USERDATA,Cast(Long,crBack))
                                                                                                             
         SendDlgItemMessage(hWin,1501,WM_SETFONT,hFont,TRUE)
         SendDlgItemMessage(hWin,1502,WM_SETFONT,hFont,TRUE)
         SendDlgItemMessage(hWin,1503,WM_SETFONT,hFont,TRUE)
         SendDlgItemMessage(hWin,1504,WM_SETFONT,hFont,TRUE)
                                                                                                             
         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
                                                                                                             
      Case WM_ERASEBKGND
         ''' sent for example when the window must be resized.
         ''' is NOT sent prior to a BitBlt
                                                                                                            
      Case WM_CTLCOLORDLG
         ''' sent to a dialog box before windows draws the dialog box
         ''' allow user to set the background color of the dialog box   
                                                                                                             
      Case WM_CTLCOLORSTATIC   
         ''' 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)
         EndIf
                                                                                                             
      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)                               
            SendDlgItemMessage(hWin,1136,CB_GETLBTEXT,iResult,pszFace)
                                                                                                             
         '''   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))
            SendDlgItemMessage(hWin,1137,CB_GETLBTEXT,iResult,pszAttr)
                                                                                                             
            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
                  EndIf
                  If pszAttr[1] = 111 Then            ''' Bold
                       iWeight = 700     
                     bItalic = FALSE
                  EndIf
                  If iLength > 6 Then                 ''' Bold Oblique
                     iWeight = 700
                     bItalic = TRUE
                  EndIf           
                                                                                                             
               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
                  Else   
                     If iLength > 6 Then              ''' Narrow Italic
                        If pszAttr[7] = 73 Then       
                           iWeight = 400
                           bItalic = TRUE
                        EndIf
                        If pszAttr[7] = 66 Then       ''' Narrow Bold
                           iWeight = 700
                           bItalic = FALSE
                        EndIf
                     Else
                        iWeight = 400
                        bItalic = FALSE
                     EndIf   
                  EndIf
                                                                                                             
               Case 79                                ''' Oblique
                  iWeight = 400
                  bItalic = TRUE
                                                                                                             
               Case 82                                ''' Regular
                  iWeight = 400
                  bItalic = FALSE
                                                                                                             
            End Select
                                                                                                           
         PostMessage(hWin,WM_APP,0,0)                                                                                               
                                                                                                           
      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
               SendMessage(hWin,WM_COMMAND,MAKEWPARAM(2,BN_CLICKED),GetDlgItem(hWin,2))
               Return 1
                                                                                                             
            Case 2                  ''' CANCEL
               If bOK = FALSE Then  ''' we really do cancel
                  pCF -> iPointSize = 0
               EndIf
                                                                                                             
            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)
            SendDlgItemMessage(hWin,1138,CB_GETLBTEXT,iResult,psd->pointa)
            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
                  SetWindowLong(GetDlgItem(hWin,1502),GWL_USERDATA,Cast(Long,iResult))
                  setStaticColor(GetDlgItem(hWin,1502),iResult)
                  crFore = iResult
                  GoTo showSample
               EndIf   
                                                                                                             
            Case 1503,1504:         ''' back color
               iResult = selectColor(hWin,crBack)
               If iResult <> -1 Then
                  SetWindowLong(GetDlgItem(hWin,1504),GWL_USERDATA,Cast(Long,iResult))
                  setStaticColor(GetDlgItem(hWin,1504),iResult)
                  crBack = iResult
                  GoTo showSample
               EndIf             
                                                                                                             
         End Select                                                                                 
                                                                                                           
      Case WM_APP
         GoTo showSample
                                                                                                           
                                                                                                           
   End Select
   Return 0
                                                                                                           
showSample:
      If hFontSample Then DeleteObject(hFontSample)
         hFontSample = CreateFont(iHeight,0,0,0,_
                                  iWeight,bItalic,bUnder,bStrike,_
                                  ANSI_CHARSET,OUT_DEFAULT_PRECIS,CLIP_DEFAULT_PRECIS,_
                                  DEFAULT_QUALITY,DEFAULT_PITCH or FF_DONTCARE,pszFace)                                                                                                     
         drawSampleText(CF_HDC,hfontSample,crBack,crFore)                                               
      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
   Else
      Return -1
   EndIf
                                                                                                             
End Function
Function setStaticColor(hWin As HWND,BGcolor As INT32) As BOOLEAN
                                                                                                             
   Dim As HDC  staticDC = GetDC(hWin)
   Dim As RECT staticRECT
               
   GetClientRect(hWin,@staticRECT)
   Dim As HBRUSH newBrush = CreateSolidBrush(BGcolor)
   Dim As HBRUSH oldBrush = SelectObject(staticDC,newBrush)
   ''' by filling the rect we brush over any text
   FillRect(staticDC,@staticRect,newBrush)
   SelectObject(staticDC,oldBrush)
   DeleteObject(newBrush)
   ReleaseDC(hWin,staticDC)
   ''' set MSB so we know a color has been set - even if the color is zero!!
   BGcolor = BGcolor Or &H80000000
   SetWindowLong(hWin,GWL_USERDATA,Cast(Long,BGcolor)) 
   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
      DeleteDC(hdcMemSample)      
      DeleteObject(bmpMemSample)      
   EndIf
                                                                                                           
   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)           
      DeleteObject(hdcMemFont)
     
      ''' 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
      GetTextExtentPoint32(hdcMemSample,pSampleData->pointa,textLong,@newSize)     
      Dim As UINT32 bmpSizeX, bmpSizeY
      Dim As UINT32 bmpDrawX, bmpDrawY
      If newSize.cx < 157 Then
         bmpSizeX = 157
         bmpDrawX = (157 - newSize.cx)\2
      Else
         bmpSizeX = newSize.cx
         bmpDrawX = 0
      EndIf
      If newSize.cy < 48 Then
         bmpSizeY = 48
         bmpDrawY = (48 - newSize.cy)\2 
      Else
         bmpSizeY = newSize.cy
         bmpDrawY = 0                                                                                                             
      EndIf
      bmpMemSample = CreateBitmap(bmpSizeX,bmpSizeY,1,32,NULL)                                                                                                                     
      Dim As HBITMAP bmpMemFirst = SelectObject(hdcMemSample,bmpMemSample)
      DeleteObject(bmpMemFirst)                                                                                                     
                                                                                                           
      ''' 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)
      DeleteObject(oldPen)
      Dim As HBRUSH oldBrush = SelectObject(hdcMemSample,CreateSolidBrush(BGcolor And &HFFFFFF))
      DeleteObject(oldBrush)           
      Rectangle(hdcMemSample,0,0,bmpSizeX,bmpSizeY)
                                                                                                             
      ''' 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.
      TextOut(hdcMemSample,bmpDrawX,bmpDrawY,pSampleData->pointa,textLong)
                                                                                                             
      ''' if the new bitmap is larger than the size of the sample box then only show the centre
      Dim As UINT32 xSource = 0
      If newSize.cx > 157 Then xSource = (newSize.cx - 157)\2 
      Dim As UINT32 ySource = 0
      If newSize.cy > 48  Then ySource = (newSize.cy - 48)\2   

      BitBlt(fHDC,173,173,157,48,hdcMemSample,xSource,ySource,SRCCOPY)                                                                                                         
      Return TRUE
   EndIf               
   Return FALSE
                                                                                                                                                                                                                       
End Function

Return to “Windows”

Who is online

Users browsing this forum: No registered users and 1 guest