Proposed new wrapper functions

[José Roca]

The following wrappers allow to easily change one or more characteristics of a font, individually. They will be added to AfxWin.inc.

Code Select Expand



' ========================================================================================
' Modifies the point size of the font of a window or control.
' Parameters:
' - hwnd = Handle of the window or control.
' - Percent = The base is 100. To increase the font a 20% pass 120; to reduce it a 20% pass 80%.
' Return Value: 1 = success; 0 = failure.
' ========================================================================================
FUNCTION AfxFontModifyPointSize (BYVAL hwnd AS DWORD, BYVAL Percent AS SINGLE) AS LONG

   LOCAL hCurFont AS DWORD
   LOCAL hNewFont AS DWORD
   LOCAL lf AS LOGFONT
   LOCAL lPointSize AS LONG

   IF hwnd = 0 OR Percent = 0 THEN EXIT FUNCTION

   ' // Get the handle of the font used by the header
   hCurFont = SendMessage(hwnd, %WM_GETFONT, 0, 0)
   IF hCurFont = 0 THEN EXIT FUNCTION

   ' // Get the LOGFONT structure
   IF GetObject(hCurFont, SIZEOF(lf), lf) = 0 THEN EXIT FUNCTION

   ' // Change the point size
   lPointSize = AfxGetFontPointSize(lf.lfHeight)
   lPointSize = lPointSize * (Percent / 100)
   lf.lfHeight = -MulDiv(lPointSize, AfxGetLogPixelsY, 72)

   ' // Create a new font
   hNewFont = CreateFontIndirect(lf)
   IF hNewFont = 0 THEN EXIT FUNCTION

   ' // Select the new font and delete the old one
   DeleteObject(SelectObject(hwnd, hNewFont))
   SendMessage hwnd, %WM_SETFONT, hNewFont, %TRUE

   FUNCTION = 1

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

' ========================================================================================
' Modifies the face name of the font of a window or control.
' Parameters:
' - hwnd = Handle of the window or control.
' - strNewFaceName = The new face name of the font
' Return Value: 1 = success; 0 = failure.
' ========================================================================================
#IF NOT %DEF(%UNICODE)
FUNCTION AfxFontModifyFontFaceName (BYVAL hwnd AS DWORD, BYVAL strNewFaceName AS STRING) AS LONG
#ELSE
FUNCTION AfxFontModifyFontFaceName (BYVAL hwnd AS DWORD, BYVAL strNewFaceName AS WSTRING) AS LONG
#ENDIF

   LOCAL hCurFont AS DWORD
   LOCAL hNewFont AS DWORD
   LOCAL lf AS LOGFONT

   IF hwnd = 0 OR strNewFaceName = "" THEN EXIT FUNCTION

   ' // Get the handle of the font used by the header
   hCurFont = SendMessage(hwnd, %WM_GETFONT, 0, 0)
   IF hCurFont = 0 THEN EXIT FUNCTION

   ' // Get the LOGFONT structure
   IF GetObject(hCurFont, SIZEOF(lf), lf) = 0 THEN EXIT FUNCTION

   ' // Change the face name
   lf.lfFaceName = strNewFaceName

   ' // Create a new font
   hNewFont = CreateFontIndirect(lf)
   IF hNewFont = 0 THEN EXIT FUNCTION

   ' // Select the new font and delete the old one
   DeleteObject(SelectObject(hwnd, hNewFont))
   SendMessage hwnd, %WM_SETFONT, hNewFont, %TRUE

   FUNCTION = 1

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

' ========================================================================================
' Modifies the weight of the font of a window or control.
' Parameters:
' - hwnd = Handle of the window or control.
' - nWeight = The weight of the font in the range 0 through 1000. For example, 400 is normal
'   and 700 is bold. If this value is zero, a default weight is used.
'   The following values are defined for convenience.
'   FW_DONTCARE   0
'   FW_THIN       100
'   FW_EXTRALIGHT 200
'   FW_ULTRALIGHT 200
'   FW_LIGHT      300
'   FW_NORMAL     400
'   FW_REGULAR    400
'   FW_MEDIUM     500
'   FW_SEMIBOLD   600
'   FW_DEMIBOLD   600
'   FW_BOLD       700
'   FW_EXTRABOLD  800
'   FW_ULTRABOLD  800
'   FW_HEAVY      900
'   FW_BLACK      900
' Return Value: 1 = success; 0 = failure.
' ========================================================================================
FUNCTION AfxFontSetWeight (BYVAL hwnd AS DWORD, BYVAL nWeight AS LONG) AS LONG

   LOCAL hCurFont AS DWORD
   LOCAL hNewFont AS DWORD
   LOCAL lf AS LOGFONT

   IF hwnd = 0 THEN EXIT FUNCTION

   ' // Get the handle of the font used by the header
   hCurFont = SendMessage(hwnd, %WM_GETFONT, 0, 0)
   IF hCurFont = 0 THEN EXIT FUNCTION

   ' // Get the LOGFONT structure
   IF GetObject(hCurFont, SIZEOF(lf), lf) = 0 THEN EXIT FUNCTION

   ' // Change the face name
   lf.lfWeight = nWeight

   ' // Create a new font
   hNewFont = CreateFontIndirect(lf)
   IF hNewFont = 0 THEN EXIT FUNCTION

   ' // Select the new font and delete the old one
   DeleteObject(SelectObject(hwnd, hNewFont))
   SendMessage hwnd, %WM_SETFONT, hNewFont, %TRUE

   FUNCTION = 1

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

' ========================================================================================
' Sets the italic flag.
' Parameters:
' - hwnd = Handle of the window or control.
' - bFlag = %TRUE or %FALSE
' Return Value: 1 = success; 0 = failure.
' ========================================================================================
FUNCTION AfxFontSetItalic (BYVAL hwnd AS DWORD, BYVAL bFlag AS BYTE) AS LONG

   LOCAL hCurFont AS DWORD
   LOCAL hNewFont AS DWORD
   LOCAL lf AS LOGFONT
   LOCAL lPointSize AS LONG

   IF hwnd = 0 THEN EXIT FUNCTION
   IF bFlag <> 0 THEN bFlag = 1

   ' // Get the handle of the font used by the header
   hCurFont = SendMessage(hwnd, %WM_GETFONT, 0, 0)
   IF hCurFont = 0 THEN EXIT FUNCTION

   ' // Get the LOGFONT structure
   IF GetObject(hCurFont, SIZEOF(lf), lf) = 0 THEN EXIT FUNCTION

   ' // Change the flag
   lf.lfItalic = bFlag

   ' // Create a new font
   hNewFont = CreateFontIndirect(lf)
   IF hNewFont = 0 THEN EXIT FUNCTION

   ' // Select the new font and delete the old one
   DeleteObject(SelectObject(hwnd, hNewFont))
   SendMessage hwnd, %WM_SETFONT, hNewFont, %TRUE

   FUNCTION = 1

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

' ========================================================================================
' Sets the underline flag.
' Parameters:
' - hwnd = Handle of the window or control.
' - bFlag = %TRUE or %FALSE
' Return Value: 1 = success; 0 = failure.
' ========================================================================================
FUNCTION AfxFontSetUnderline (BYVAL hwnd AS DWORD, BYVAL bFlag AS BYTE) AS LONG

   LOCAL hCurFont AS DWORD
   LOCAL hNewFont AS DWORD
   LOCAL lf AS LOGFONT
   LOCAL lPointSize AS LONG

   IF hwnd = 0 THEN EXIT FUNCTION
   IF bFlag <> 0 THEN bFlag = 1

   ' // Get the handle of the font used by the header
   hCurFont = SendMessage(hwnd, %WM_GETFONT, 0, 0)
   IF hCurFont = 0 THEN EXIT FUNCTION

   ' // Get the LOGFONT structure
   IF GetObject(hCurFont, SIZEOF(lf), lf) = 0 THEN EXIT FUNCTION

   ' // Change the flag
   lf.lfUnderline = bFlag

   ' // Create a new font
   hNewFont = CreateFontIndirect(lf)
   IF hNewFont = 0 THEN EXIT FUNCTION

   ' // Select the new font and delete the old one
   DeleteObject(SelectObject(hwnd, hNewFont))
   SendMessage hwnd, %WM_SETFONT, hNewFont, %TRUE

   FUNCTION = 1

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

' ========================================================================================
' Sets the strike out flag.
' Parameters:
' - hwnd = Handle of the window or control.
' - bFlag = %TRUE or %FALSE
' Return Value: 1 = success; 0 = failure.
' ========================================================================================
FUNCTION AfxFontSetStrikeOut (BYVAL hwnd AS DWORD, BYVAL bFlag AS BYTE) AS LONG

   LOCAL hCurFont AS DWORD
   LOCAL hNewFont AS DWORD
   LOCAL lf AS LOGFONT
   LOCAL lPointSize AS LONG

   IF hwnd = 0 THEN EXIT FUNCTION
   IF bFlag <> 0 THEN bFlag = 1

   ' // Get the handle of the font used by the header
   hCurFont = SendMessage(hwnd, %WM_GETFONT, 0, 0)
   IF hCurFont = 0 THEN EXIT FUNCTION

   ' // Get the LOGFONT structure
   IF GetObject(hCurFont, SIZEOF(lf), lf) = 0 THEN EXIT FUNCTION

   ' // Change the flag
   lf.lfStrikeOut = bFlag

   ' // Create a new font
   hNewFont = CreateFontIndirect(lf)
   IF hNewFont = 0 THEN EXIT FUNCTION

   ' // Select the new font and delete the old one
   DeleteObject(SelectObject(hwnd, hNewFont))
   SendMessage hwnd, %WM_SETFONT, hNewFont, %TRUE

   FUNCTION = 1

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

' ========================================================================================
' Changes the charset.
' Parameters:
' - hwnd = Handle of the window or control.
' - bCharset = The following values are predefined.
'    ANSI_CHARSET
'    BALTIC_CHARSET
'    CHINESEBIG5_CHARSET
'    DEFAULT_CHARSET
'    EASTEUROPE_CHARSET
'    GB2312_CHARSET
'    GREEK_CHARSET
'    HANGUL_CHARSET
'    MAC_CHARSET
'    OEM_CHARSET
'    RUSSIAN_CHARSET
'    SHIFTJIS_CHARSET
'    SYMBOL_CHARSET
'    TURKISH_CHARSET
'    VIETNAMESE_CHARSET

' Korean language edition of Windows:

'    JOHAB_CHARSET

' Middle East language edition of Windows:

'    ARABIC_CHARSET
'    HEBREW_CHARSET

' Thai language edition of Windows:

'    THAI_CHARSET

' The OEM_CHARSET value specifies a character set that is operating-system dependent.

' DEFAULT_CHARSET is set to a value based on the current system locale. For example, when
' the system locale is English (United States), it is set as ANSI_CHARSET.

' Fonts with other character sets may exist in the operating system. If an application uses
' a font with an unknown character set, it should not attempt to translate or interpret
' strings that are rendered with that font.

' This parameter is important in the font mapping process. To ensure consistent results,
' specify a specific character set. If you specify a typeface name in the lfFaceName member,
' make sure that the lfCharSet value matches the character set of the typeface specified in lfFaceName.

' Return Value: 1 = success; 0 = failure.
' ========================================================================================
FUNCTION AfxFontSetCharset (BYVAL hwnd AS DWORD, BYVAL bCharset AS BYTE) AS LONG

   LOCAL hCurFont AS DWORD
   LOCAL hNewFont AS DWORD
   LOCAL lf AS LOGFONT
   LOCAL lPointSize AS LONG

   IF hwnd = 0 THEN EXIT FUNCTION

   ' // Get the handle of the font used by the header
   hCurFont = SendMessage(hwnd, %WM_GETFONT, 0, 0)
   IF hCurFont = 0 THEN EXIT FUNCTION

   ' // Get the LOGFONT structure
   IF GetObject(hCurFont, SIZEOF(lf), lf) = 0 THEN EXIT FUNCTION

   ' // Change the charset
   lf.lfCharset = bCharset

   ' // Create a new font
   hNewFont = CreateFontIndirect(lf)
   IF hNewFont = 0 THEN EXIT FUNCTION

   ' // Select the new font and delete the old one
   DeleteObject(SelectObject(hwnd, hNewFont))
   SendMessage hwnd, %WM_SETFONT, hNewFont, %TRUE

   FUNCTION = 1

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


[Paul Squires]

Cool. Does WM_GETFONT and WM_SETFONT work with "SYSDATETIMEPICK32" ? I had to build logic into FireFly to handle setting the font of that control separately.

                SendMessage hWndControl, %DTM_SETMCFONT, hFont, %TRUE

[José Roca]

Yes, they do. The following program produces the attached picture.

Code Select Expand


' ########################################################################################
' Microsoft Windows
' File: CW_Button.pbtpl
' Contents: Template - CWindow with a button
' Compilers: PBWIN 10.02+, PBCC 6.02+
' Headers: Windows API headers 2.03+
' Copyright (c) 2011 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.
' ########################################################################################
#COMPILE EXE
#DIM ALL
%UNICODE = 1

' // Include files for external files
#INCLUDE ONCE "CWindow.inc"   ' // CWindow class

' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, BYVAL lpszCmdLine AS WSTRINGZ PTR, BYVAL nCmdShow AS LONG) AS LONG

   ' // Set process DPI aware
   SetProcessDPIAware

   ' // Create an instance of the class
   LOCAL pWindow AS IWindow
   pWindow = CLASS "CWindow"
   IF ISNOTHING(pWindow) THEN EXIT FUNCTION

   ' // Create the main window
   ' // Note: CW_USEDEFAULT is used as the default value When passing 0's as the width and height
   pWindow.CreateWindow(%NULL, "CWindow with a button", 0, 0, 0, 0, 0, 0, CODEPTR(WindowProc))
   ' // Set the client size
   pWindow.SetClientSize 500, 320
   ' // Center the window
   pWindow.CenterWindow

   LOCAL hCtl AS DWORD
   hCtl = pWindow.AddDateTimePicker(pWindow.hwnd, 101, "", 100, 100, 100, 25)
   AfxFontSetWeight HCtl, %FW_BOLD
   AfxFontSetUnderline hCtl, %TRUE
   AfxFontSetStrikeOut hCtl, %TRUE

   ' // Add a button
   pWindow.AddButton(pWindow.hwnd, %IDCANCEL, "&Close", 350, 250, 75, 23)

   

   ' // Default message pump (you can replace it with your own)
   pWindow.DoEvents(nCmdShow)

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

' ========================================================================================
' Main callback function.
' ========================================================================================
FUNCTION WindowProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG

   ' // Process window mesages
   SELECT CASE uMsg

      CASE %WM_COMMAND
         SELECT CASE LO(WORD, wParam)
            CASE %IDCANCEL
               ' // If the Escape key has been pressed...
               IF HI(WORD, wParam) = %BN_CLICKED THEN
                  ' // ... close the application by sending a WM_CLOSE message
                  SendMessage hwnd, %WM_CLOSE, 0, 0
                  EXIT FUNCTION
               END IF
         END SELECT

      CASE %WM_DESTROY
         ' // End the application
         PostQuitMessage 0
         EXIT FUNCTION

   END SELECT

   ' // Pass unprocessed messages to Windows
   FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)

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


[José Roca]

Sorry, if you mean the control's child month calendar control, then not. It will work will all controls that accept WM_SETFONT.

[José Roca]

But there is solution for all. This one will do:

Code Select Expand


#COMPILE EXE
#DIM ALL
%UNICODE = 1

' // Include files for external files
#INCLUDE ONCE "CWindow.inc"   ' // CWindow class
#INCLUDE ONCE "DateTimeCtrl.inc"   ' // CWindow class

' ========================================================================================
' Sets the italic flag of a DateTimePicker control.
' Parameters:
' - hwnd = Handle of the window or control.
' - bFlag = %TRUE or %FALSE
' Return Value: 1 = success; 0 = failure.
' ========================================================================================
FUNCTION AfxFontDTPSetItalic (BYVAL hwnd AS DWORD, BYVAL bFlag AS BYTE) AS LONG

   LOCAL hCurFont AS DWORD
   LOCAL hNewFont AS DWORD
   LOCAL lf AS LOGFONT
   LOCAL lPointSize AS LONG

   IF hwnd = 0 THEN EXIT FUNCTION
   IF bFlag <> 0 THEN bFlag = 1

   ' // Get the handle of the font used by the header
   hCurFont = SendMessage(hwnd, %WM_GETFONT, 0, 0)
   IF hCurFont = 0 THEN EXIT FUNCTION

   ' // Get the LOGFONT structure
   IF GetObject(hCurFont, SIZEOF(lf), lf) = 0 THEN EXIT FUNCTION

   ' // Change the flag
   lf.lfItalic = bFlag

   ' // Create a new font
   hNewFont = CreateFontIndirect(lf)
   IF hNewFont = 0 THEN EXIT FUNCTION

   ' // Select the new font and delete the old one
   DeleteObject(SelectObject(hwnd, hNewFont))
   SendMessage hwnd, %WM_SETFONT, hNewFont, %TRUE
   SendMessage hwnd, %DTM_SETMCFONT, hNewFont, %TRUE

   FUNCTION = 1

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

' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, BYVAL lpszCmdLine AS WSTRINGZ PTR, BYVAL nCmdShow AS LONG) AS LONG

   ' // Set process DPI aware
   SetProcessDPIAware

   ' // Create an instance of the class
   LOCAL pWindow AS IWindow
   pWindow = CLASS "CWindow"
   IF ISNOTHING(pWindow) THEN EXIT FUNCTION

   ' // Create the main window
   ' // Note: CW_USEDEFAULT is used as the default value When passing 0's as the width and height
   pWindow.CreateWindow(%NULL, "CWindow with a button", 0, 0, 0, 0, 0, 0, CODEPTR(WindowProc))
   ' // Set the client size
   pWindow.SetClientSize 500, 320
   ' // Center the window
   pWindow.CenterWindow

   LOCAL hCtl AS DWORD
   hCtl = pWindow.AddDateTimePicker(pWindow.hwnd, 101, "", 100, 100, 100, 25)
   AfxFontDTPSetItalic hCtl, %TRUE

   ' // Add a button
   pWindow.AddButton(pWindow.hwnd, %IDCANCEL, "&Close", 350, 250, 75, 23)

   

   ' // Default message pump (you can replace it with your own)
   pWindow.DoEvents(nCmdShow)

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

' ========================================================================================
' Main callback function.
' ========================================================================================
FUNCTION WindowProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG

   ' // Process window mesages
   SELECT CASE uMsg

      CASE %WM_COMMAND
         SELECT CASE LO(WORD, wParam)
            CASE %IDCANCEL
               ' // If the Escape key has been pressed...
               IF HI(WORD, wParam) = %BN_CLICKED THEN
                  ' // ... close the application by sending a WM_CLOSE message
                  SendMessage hwnd, %WM_CLOSE, 0, 0
                  EXIT FUNCTION
               END IF
         END SELECT

      CASE %WM_DESTROY
         ' // End the application
         PostQuitMessage 0
         EXIT FUNCTION

   END SELECT

   ' // Pass unprocessed messages to Windows
   FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)

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


[José Roca]

So I will add equivalent functions to DateTimeCtrl.inc. I already did that with the Rich Edit control, where RichEditCtrl.inc has functions to set the fonts.

Now that we have dead code removal, we can extend the language as much as we wish.

[José Roca]

If I remove the WM_SETFONT instruction...

Code Select Expand


' ========================================================================================
' Sets the italic flag of a DateTimePicker control.
' Parameters:
' - hwnd = Handle of the window or control.
' - bFlag = %TRUE or %FALSE
' Return Value: 1 = success; 0 = failure.
' ========================================================================================
FUNCTION AfxFontDTPSetItalic (BYVAL hwnd AS DWORD, BYVAL bFlag AS BYTE) AS LONG

   LOCAL hCurFont AS DWORD
   LOCAL hNewFont AS DWORD
   LOCAL lf AS LOGFONT
   LOCAL lPointSize AS LONG

   IF hwnd = 0 THEN EXIT FUNCTION
   IF bFlag <> 0 THEN bFlag = 1

   ' // Get the handle of the font used by the header
   hCurFont = SendMessage(hwnd, %WM_GETFONT, 0, 0)
   IF hCurFont = 0 THEN EXIT FUNCTION

   ' // Get the LOGFONT structure
   IF GetObject(hCurFont, SIZEOF(lf), lf) = 0 THEN EXIT FUNCTION

   ' // Change the flag
   lf.lfItalic = bFlag

   ' // Create a new font
   hNewFont = CreateFontIndirect(lf)
   IF hNewFont = 0 THEN EXIT FUNCTION

   ' // Select the new font and delete the old one
   DeleteObject(SelectObject(hwnd, hNewFont))
   SendMessage hwnd, %DTM_SETMCFONT, hNewFont, %TRUE

   FUNCTION = 1

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


Then we can have completely different fonts if we alter the font of the Date Time Picker Child control BEFORE the one of the edit control part.

Code Select Expand


#COMPILE EXE
#DIM ALL
%UNICODE = 1

' // Include files for external files
#INCLUDE ONCE "CWindow.inc"   ' // CWindow class
#INCLUDE ONCE "DateTimeCtrl.inc"   ' // CWindow class

' ========================================================================================
' Sets the italic flag of a DateTimePicker control.
' Parameters:
' - hwnd = Handle of the window or control.
' - bFlag = %TRUE or %FALSE
' Return Value: 1 = success; 0 = failure.
' ========================================================================================
FUNCTION AfxFontDTPSetItalic (BYVAL hwnd AS DWORD, BYVAL bFlag AS BYTE) AS LONG

   LOCAL hCurFont AS DWORD
   LOCAL hNewFont AS DWORD
   LOCAL lf AS LOGFONT
   LOCAL lPointSize AS LONG

   IF hwnd = 0 THEN EXIT FUNCTION
   IF bFlag <> 0 THEN bFlag = 1

   ' // Get the handle of the font used by the header
   hCurFont = SendMessage(hwnd, %WM_GETFONT, 0, 0)
   IF hCurFont = 0 THEN EXIT FUNCTION

   ' // Get the LOGFONT structure
   IF GetObject(hCurFont, SIZEOF(lf), lf) = 0 THEN EXIT FUNCTION

   ' // Change the flag
   lf.lfItalic = bFlag

   ' // Create a new font
   hNewFont = CreateFontIndirect(lf)
   IF hNewFont = 0 THEN EXIT FUNCTION

   ' // Select the new font and delete the old one
   DeleteObject(SelectObject(hwnd, hNewFont))
   SendMessage hwnd, %DTM_SETMCFONT, hNewFont, %TRUE

   FUNCTION = 1

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

' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, BYVAL lpszCmdLine AS WSTRINGZ PTR, BYVAL nCmdShow AS LONG) AS LONG

   ' // Set process DPI aware
   SetProcessDPIAware

   ' // Create an instance of the class
   LOCAL pWindow AS IWindow
   pWindow = CLASS "CWindow"
   IF ISNOTHING(pWindow) THEN EXIT FUNCTION

   ' // Create the main window
   ' // Note: CW_USEDEFAULT is used as the default value When passing 0's as the width and height
   pWindow.CreateWindow(%NULL, "CWindow with a button", 0, 0, 0, 0, 0, 0, CODEPTR(WindowProc))
   ' // Set the client size
   pWindow.SetClientSize 500, 320
   ' // Center the window
   pWindow.CenterWindow

   LOCAL hCtl AS DWORD
   hCtl = pWindow.AddDateTimePicker(pWindow.hwnd, 101, "", 100, 100, 100, 25)
   AfxFontDTPSetItalic hCtl, %TRUE
   AfxFontSetWeight hCtl, %FW_BOLD
   AfxFontSetStrikeOut hCtl, %TRUE

   ' // Add a button
   pWindow.AddButton(pWindow.hwnd, %IDCANCEL, "&Close", 350, 250, 75, 23)

   

   ' // Default message pump (you can replace it with your own)
   pWindow.DoEvents(nCmdShow)

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

' ========================================================================================
' Main callback function.
' ========================================================================================
FUNCTION WindowProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG

   ' // Process window mesages
   SELECT CASE uMsg

      CASE %WM_COMMAND
         SELECT CASE LO(WORD, wParam)
            CASE %IDCANCEL
               ' // If the Escape key has been pressed...
               IF HI(WORD, wParam) = %BN_CLICKED THEN
                  ' // ... close the application by sending a WM_CLOSE message
                  SendMessage hwnd, %WM_CLOSE, 0, 0
                  EXIT FUNCTION
               END IF
         END SELECT

      CASE %WM_DESTROY
         ' // End the application
         PostQuitMessage 0
         EXIT FUNCTION

   END SELECT

   ' // Pass unprocessed messages to Windows
   FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)

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


[José Roca]

Or we can have an additional parameter indicating if it has to change both fonts at the same time or not. If yes, it will also use WM_SETFONT; if not, you will have to set the font of the child month calendar control first and then the one of the edit control.

[José Roca]

Well, I think that I have finally got the best.

Code Select Expand


#COMPILE EXE
#DIM ALL
%UNICODE = 1

' // Include files for external files
#INCLUDE ONCE "CWindow.inc"   ' // CWindow class
#INCLUDE ONCE "DateTimeCtrl.inc"   ' // CWindow class

' ========================================================================================
' Sets the italic flag of a DateTimePicker control.
' Parameters:
' - hwnd = Handle of the window or control.
' - bFlag = %TRUE or %FALSE
' Return Value: 1 = success; 0 = failure.
' ========================================================================================
FUNCTION DateTime_SetItalic (BYVAL hwnd AS DWORD, BYVAL bFlag AS BYTE) AS LONG

   LOCAL hCurFont AS DWORD
   LOCAL hNewFont AS DWORD
   LOCAL lf AS LOGFONT
   LOCAL lPointSize AS LONG

   IF hwnd = 0 THEN EXIT FUNCTION
   IF bFlag <> 0 THEN bFlag = 1

   ' // Get the handle of the font used by the header
   hCurFont = SendMessage(hwnd, %DTM_GETMCFONT, 0, 0)
   IF hCurFont = 0 THEN EXIT FUNCTION

   ' // Get the LOGFONT structure
   IF GetObject(hCurFont, SIZEOF(lf), lf) = 0 THEN EXIT FUNCTION

   ' // Change the flag
   lf.lfItalic = bFlag

   ' // Create a new font
   hNewFont = CreateFontIndirect(lf)
   IF hNewFont = 0 THEN EXIT FUNCTION

   ' // Select the new font and delete the old one
   DeleteObject(SelectObject(hwnd, hNewFont))
   SendMessage hwnd, %DTM_SETMCFONT, hNewFont, %TRUE

   FUNCTION = 1

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

' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, BYVAL lpszCmdLine AS WSTRINGZ PTR, BYVAL nCmdShow AS LONG) AS LONG

   ' // Set process DPI aware
   SetProcessDPIAware

   ' // Create an instance of the class
   LOCAL pWindow AS IWindow
   pWindow = CLASS "CWindow"
   IF ISNOTHING(pWindow) THEN EXIT FUNCTION

   ' // Create the main window
   ' // Note: CW_USEDEFAULT is used as the default value When passing 0's as the width and height
   pWindow.CreateWindow(%NULL, "CWindow with a button", 0, 0, 0, 0, 0, 0, CODEPTR(WindowProc))
   ' // Set the client size
   pWindow.SetClientSize 500, 320
   ' // Center the window
   pWindow.CenterWindow

   LOCAL hCtl AS DWORD
   hCtl = pWindow.AddDateTimePicker(pWindow.hwnd, 101, "", 100, 100, 100, 25)
   AfxFontSetWeight hCtl, %FW_BOLD
   AfxFontSetStrikeOut hCtl, %TRUE
   DateTime_SetItalic hCtl, %TRUE

   ' // Add a button
   pWindow.AddButton(pWindow.hwnd, %IDCANCEL, "&Close", 350, 250, 75, 23)



   ' // Default message pump (you can replace it with your own)
   pWindow.DoEvents(nCmdShow)

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

' ========================================================================================
' Main callback function.
' ========================================================================================
FUNCTION WindowProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG

   ' // Process window mesages
   SELECT CASE uMsg

      CASE %WM_COMMAND
         SELECT CASE LO(WORD, wParam)
            CASE %IDCANCEL
               ' // If the Escape key has been pressed...
               IF HI(WORD, wParam) = %BN_CLICKED THEN
                  ' // ... close the application by sending a WM_CLOSE message
                  SendMessage hwnd, %WM_CLOSE, 0, 0
                  EXIT FUNCTION
               END IF
         END SELECT

      CASE %WM_DESTROY
         ' // End the application
         PostQuitMessage 0
         EXIT FUNCTION

   END SELECT

   ' // Pass unprocessed messages to Windows
   FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)

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


Now it doesn't matter the order in which you change the fonts.

I will use DateTime_SetItalic, etc., to match the other functions in DateTimeCtrl.inc.

[José Roca]

These are the new functions that esily allow to change the characteristics of the Date Time Picker month child calendar control. They have been included in DateTimeCtrl.inc.

Code Select Expand


' ========================================================================================
' Modifies the point size of the font of the month calendar child control.
' Parameters:
' - hwnd = Handle of the control.
' - Percent = The base is 100. To increase the font a 20% pass 120; to reduce it a 20% pass 80%.
' Return Value: 1 = success; 0 = failure.
' ========================================================================================
FUNCTION DateTimeFont_ModifyPointSize (BYVAL hwnd AS DWORD, BYVAL Percent AS SINGLE) AS LONG

   LOCAL hCurFont AS DWORD
   LOCAL hNewFont AS DWORD
   LOCAL lf AS LOGFONT
   LOCAL lPointSize AS LONG

   IF hwnd = 0 OR Percent = 0 THEN EXIT FUNCTION

   ' // Get the handle of the font used by the header
   hCurFont = SendMessage(hwnd, %DTM_GETMCFONT, 0, 0)
   IF hCurFont = 0 THEN EXIT FUNCTION

   ' // Get the LOGFONT structure
   IF GetObject(hCurFont, SIZEOF(lf), lf) = 0 THEN EXIT FUNCTION

   ' // Change the point size
   lPointSize = AfxGetFontPointSize(lf.lfHeight)
   lPointSize = lPointSize * (Percent / 100)
   lf.lfHeight = -MulDiv(lPointSize, AfxGetLogPixelsY, 72)

   ' // Create a new font
   hNewFont = CreateFontIndirect(lf)
   IF hNewFont = 0 THEN EXIT FUNCTION

   ' // Select the new font and delete the old one
   DeleteObject(SelectObject(hwnd, hNewFont))
   SendMessage hwnd, %DTM_SETMCFONT, hNewFont, %TRUE

   FUNCTION = 1

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

' ========================================================================================
' Modifies the font face name of font of the month calendar child control.
' Parameters:
' - hwnd = Handle of the control.
' - strNewFaceName = The new face name of the font
' Return Value: 1 = success; 0 = failure.
' ========================================================================================
#IF NOT %DEF(%UNICODE)
FUNCTION DateTimeFont_ModifyFontFaceName (BYVAL hwnd AS DWORD, BYVAL strNewFaceName AS STRING) AS LONG
#ELSE
FUNCTION DateTimeFont_ModifyFontFaceName (BYVAL hwnd AS DWORD, BYVAL strNewFaceName AS WSTRING) AS LONG
#ENDIF

   LOCAL hCurFont AS DWORD
   LOCAL hNewFont AS DWORD
   LOCAL lf AS LOGFONT

   IF hwnd = 0 OR strNewFaceName = "" THEN EXIT FUNCTION

   ' // Get the handle of the font used by the header
   hCurFont = SendMessage(hwnd, %DTM_GETMCFONT, 0, 0)
   IF hCurFont = 0 THEN EXIT FUNCTION

   ' // Get the LOGFONT structure
   IF GetObject(hCurFont, SIZEOF(lf), lf) = 0 THEN EXIT FUNCTION

   ' // Change the face name
   lf.lfFaceName = strNewFaceName

   ' // Create a new font
   hNewFont = CreateFontIndirect(lf)
   IF hNewFont = 0 THEN EXIT FUNCTION

   ' // Select the new font and delete the old one
   DeleteObject(SelectObject(hwnd, hNewFont))
   SendMessage hwnd, %DTM_SETMCFONT, hNewFont, %TRUE

   FUNCTION = 1

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

' ========================================================================================
' Modifies the weight of font of the month calendar child control.
' Parameters:
' - hwnd = Handle of the control.
' - nWeight = The weight of the font in the range 0 through 1000. For example, 400 is normal
'   and 700 is bold. If this value is zero, a default weight is used.
'   The following values are defined for convenience.
'   FW_DONTCARE   0
'   FW_THIN       100
'   FW_EXTRALIGHT 200
'   FW_ULTRALIGHT 200
'   FW_LIGHT      300
'   FW_NORMAL     400
'   FW_REGULAR    400
'   FW_MEDIUM     500
'   FW_SEMIBOLD   600
'   FW_DEMIBOLD   600
'   FW_BOLD       700
'   FW_EXTRABOLD  800
'   FW_ULTRABOLD  800
'   FW_HEAVY      900
'   FW_BLACK      900
' Return Value: 1 = success; 0 = failure.
' ========================================================================================
FUNCTION DateTimeFont_SetWeight (BYVAL hwnd AS DWORD, BYVAL nWeight AS LONG) AS LONG

   LOCAL hCurFont AS DWORD
   LOCAL hNewFont AS DWORD
   LOCAL lf AS LOGFONT

   IF hwnd = 0 THEN EXIT FUNCTION

   ' // Get the handle of the font used by the header
   hCurFont = SendMessage(hwnd, %DTM_GETMCFONT, 0, 0)
   IF hCurFont = 0 THEN EXIT FUNCTION

   ' // Get the LOGFONT structure
   IF GetObject(hCurFont, SIZEOF(lf), lf) = 0 THEN EXIT FUNCTION

   ' // Change the face name
   lf.lfWeight = nWeight

   ' // Create a new font
   hNewFont = CreateFontIndirect(lf)
   IF hNewFont = 0 THEN EXIT FUNCTION

   ' // Select the new font and delete the old one
   DeleteObject(SelectObject(hwnd, hNewFont))
   SendMessage hwnd, %DTM_SETMCFONT, hNewFont, %TRUE

   FUNCTION = 1

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

' ========================================================================================
' Sets the italic flag of font of the month calendar child control.
' Parameters:
' - hwnd = Handle of the window or control.
' - bFlag = %TRUE or %FALSE
' Return Value: 1 = success; 0 = failure.
' ========================================================================================
FUNCTION DateTimeFont_SetItalic (BYVAL hwnd AS DWORD, BYVAL bFlag AS BYTE) AS LONG

   LOCAL hCurFont AS DWORD
   LOCAL hNewFont AS DWORD
   LOCAL lf AS LOGFONT

   IF hwnd = 0 THEN EXIT FUNCTION
   IF bFlag <> 0 THEN bFlag = 1

   ' // Get the handle of the font used by the header
   hCurFont = SendMessage(hwnd, %DTM_GETMCFONT, 0, 0)
   IF hCurFont = 0 THEN EXIT FUNCTION

   ' // Get the LOGFONT structure
   IF GetObject(hCurFont, SIZEOF(lf), lf) = 0 THEN EXIT FUNCTION

   ' // Change the flag
   lf.lfItalic = bFlag

   ' // Create a new font
   hNewFont = CreateFontIndirect(lf)
   IF hNewFont = 0 THEN EXIT FUNCTION

   ' // Select the new font and delete the old one
   DeleteObject(SelectObject(hwnd, hNewFont))
   SendMessage hwnd, %DTM_SETMCFONT, hNewFont, %TRUE

   FUNCTION = 1

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

' ========================================================================================
' Sets the underline flag of font of the month calendar child control.
' Parameters:
' - hwnd = Handle of the control.
' - bFlag = %TRUE or %FALSE
' Return Value: 1 = success; 0 = failure.
' ========================================================================================
FUNCTION DateTimeFont_SetUnderline (BYVAL hwnd AS DWORD, BYVAL bFlag AS BYTE) AS LONG

   LOCAL hCurFont AS DWORD
   LOCAL hNewFont AS DWORD
   LOCAL lf AS LOGFONT

   IF hwnd = 0 THEN EXIT FUNCTION
   IF bFlag <> 0 THEN bFlag = 1

   ' // Get the handle of the font used by the header
   hCurFont = SendMessage(hwnd, %DTM_GETMCFONT, 0, 0)
   IF hCurFont = 0 THEN EXIT FUNCTION

   ' // Get the LOGFONT structure
   IF GetObject(hCurFont, SIZEOF(lf), lf) = 0 THEN EXIT FUNCTION

   ' // Change the flag
   lf.lfUnderline = bFlag

   ' // Create a new font
   hNewFont = CreateFontIndirect(lf)
   IF hNewFont = 0 THEN EXIT FUNCTION

   ' // Select the new font and delete the old one
   DeleteObject(SelectObject(hwnd, hNewFont))
   SendMessage hwnd, %DTM_SETMCFONT, hNewFont, %TRUE

   FUNCTION = 1

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

' ========================================================================================
' Sets the strike out flag of font of the month calendar child control.
' Parameters:
' - hwnd = Handle of the control.
' - bFlag = %TRUE or %FALSE
' Return Value: 1 = success; 0 = failure.
' ========================================================================================
FUNCTION DateTimeFont_SetStrikeOut (BYVAL hwnd AS DWORD, BYVAL bFlag AS BYTE) AS LONG

   LOCAL hCurFont AS DWORD
   LOCAL hNewFont AS DWORD
   LOCAL lf AS LOGFONT

   IF hwnd = 0 THEN EXIT FUNCTION
   IF bFlag <> 0 THEN bFlag = 1

   ' // Get the handle of the font used by the header
   hCurFont = SendMessage(hwnd, %DTM_GETMCFONT, 0, 0)
   IF hCurFont = 0 THEN EXIT FUNCTION

   ' // Get the LOGFONT structure
   IF GetObject(hCurFont, SIZEOF(lf), lf) = 0 THEN EXIT FUNCTION

   ' // Change the flag
   lf.lfStrikeOut = bFlag

   ' // Create a new font
   hNewFont = CreateFontIndirect(lf)
   IF hNewFont = 0 THEN EXIT FUNCTION

   ' // Select the new font and delete the old one
   DeleteObject(SelectObject(hwnd, hNewFont))
   SendMessage hwnd, %DTM_SETMCFONT, hNewFont, %TRUE

   FUNCTION = 1

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

' ========================================================================================
' Changes the charset of font of the month calendar child control.
' Parameters:
' - hwnd = Handle of the control.
' - bCharset = The following values are predefined.
'    ANSI_CHARSET
'    BALTIC_CHARSET
'    CHINESEBIG5_CHARSET
'    DEFAULT_CHARSET
'    EASTEUROPE_CHARSET
'    GB2312_CHARSET
'    GREEK_CHARSET
'    HANGUL_CHARSET
'    MAC_CHARSET
'    OEM_CHARSET
'    RUSSIAN_CHARSET
'    SHIFTJIS_CHARSET
'    SYMBOL_CHARSET
'    TURKISH_CHARSET
'    VIETNAMESE_CHARSET

' Korean language edition of Windows:

'    JOHAB_CHARSET

' Middle East language edition of Windows:

'    ARABIC_CHARSET
'    HEBREW_CHARSET

' Thai language edition of Windows:

'    THAI_CHARSET

' The OEM_CHARSET value specifies a character set that is operating-system dependent.

' DEFAULT_CHARSET is set to a value based on the current system locale. For example, when
' the system locale is English (United States), it is set as ANSI_CHARSET.

' Fonts with other character sets may exist in the operating system. If an application uses
' a font with an unknown character set, it should not attempt to translate or interpret
' strings that are rendered with that font.

' This parameter is important in the font mapping process. To ensure consistent results,
' specify a specific character set. If you specify a typeface name in the lfFaceName member,
' make sure that the lfCharSet value matches the character set of the typeface specified in lfFaceName.

' Return Value: 1 = success; 0 = failure.
' ========================================================================================
FUNCTION DateTimeFont_SetCharset (BYVAL hwnd AS DWORD, BYVAL bCharset AS BYTE) AS LONG

   LOCAL hCurFont AS DWORD
   LOCAL hNewFont AS DWORD
   LOCAL lf AS LOGFONT

   IF hwnd = 0 THEN EXIT FUNCTION

   ' // Get the handle of the font used by the header
   hCurFont = SendMessage(hwnd, %DTM_GETMCFONT, 0, 0)
   IF hCurFont = 0 THEN EXIT FUNCTION

   ' // Get the LOGFONT structure
   IF GetObject(hCurFont, SIZEOF(lf), lf) = 0 THEN EXIT FUNCTION

   ' // Change the charset
   lf.lfCharset = bCharset

   ' // Create a new font
   hNewFont = CreateFontIndirect(lf)
   IF hNewFont = 0 THEN EXIT FUNCTION

   ' // Select the new font and delete the old one
   DeleteObject(SelectObject(hwnd, hNewFont))
   SendMessage hwnd, %DTM_SETMCFONT, hNewFont, %TRUE

   FUNCTION = 1

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


[Richard Kelly]

My head is getting dizzy wrapping around all the high dpi issues. If, using FF, and I either have the high dpi manifest in use or activated via the API call, is it correct that when my form and all it's controls are created, all are scaled with cWindow?

Is everything still proportionally positioned relative to each other? Do I have to handle font scaling or even changing the fonts to the system default?

Is there any merit is FF having a standard procedure call either just before a window create or immediately after so whatever cleanup adjustments can be made? My first thought was to change the font in use to the system default which would likely either be Tahoma or Segoe. I can design with 9 pt size.

Rick Kelly

[José Roca]

In a DPI enabled application, Windows, controls and fonts created using the methods provided by CWindow will scale automatically according the DPI of the computer that you are using, and positioned proportionally.

If you create controls using CreateWindowExn then you will have to scale them by yourself, since CWindow won't be aware of them.

The attached picture shows the output of the same program run with a DPI of 140: The first image, running it virtualized (i.e. non DPI aware) and the second being DPI aware. As you can see, the size and position of the window and controls are the same. The one running virtualized uses Tahoma 8 points and the DPI aware Segoe UI 9 points. These are the default fonts, but you can use others. The third image is from the same application running DPI aware but not scaled. The proportions are the same but the sizes smaller.

[José Roca]

In that simple application you may think that there is no much difference and maybe it is not worth the trouble, but in more complex applications you may experience several kinds of problems. Besides, virtualized programs and DPI aware programs don't work well together.

Read this article: http://msdn.microsoft.com/en-us/library/windows/desktop/dd464660%28v=vs.85%29.aspx

[Paul Squires]

Is there any merit is FF having a standard procedure call either just before a window create or immediately after so whatever cleanup adjustments can be made?

The goal with the redesign of FF's DPI awareness is to ensure that you don't have to think about these types of issues. FF will automatically scale Forms/Controls/Fonts for you during code generation. Everything should be proportional. The only problem occurs if you go outside the norm and manually create controls via CreateControlEx or Fonts via CreateFont(Indirect). In those case you will need to do the scaling yourself. FF's built in FF_MakeFontEx function has already been modified to create and return scaled fonts.

[Jim Dunn]

Jose, I saw the link for the Windows 8 SDK, now available:

http://msdn.microsoft.com/en-us/windows/apps/br229516

(half way down the page "Get the Live SDK")

http://connect.microsoft.com/site1226/SelfNomination.aspx?ProgramID=7546&pageType=1%20%E2%80%93