The following wrappers allow to easily change one or more characteristics of a font, individually. They will be added to AfxWin.inc.
' ========================================================================================
' 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
' ========================================================================================
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
Yes, they do. The following program produces the attached picture.
' ########################################################################################
' 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
' ========================================================================================
Sorry, if you mean the control's child month calendar control, then not. It will work will all controls that accept WM_SETFONT.
But there is solution for all. This one will do:
#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
' ========================================================================================
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.
If I remove the WM_SETFONT instruction...
' ========================================================================================
' 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.
#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
' ========================================================================================
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.
Well, I think that I have finally got the best.
#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.
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.
' ========================================================================================
' 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
' ========================================================================================
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
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.
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
Quote from: Richard Kelly on March 01, 2012, 12:24:48 AM
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.
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
Thanks for the link. However, I only need the headers and the M$ SDK installers force you to install the latest version of .NET, install a lot of crap and many times spoil your current SDK installation.
Anyway, PBer's aren't yet using the new technologies of Windows 7...
Quote from: TechSupport on March 01, 2012, 11:01:13 AM
Quote from: Richard Kelly on March 01, 2012, 12:24:48 AM
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.
You da man! I just want to focus on my application presentations and process flow and have the smart guys like you keep me from hurting myself:-)
The following functions load and convert icons in .png, .jpg, .gif., .tiff format to Windows icons or bitmaps suitable to be used in controls, toolbars, etc. The ones embedded in a resource file must be done as raw data, e.g.
UpFolder RCDATA "up_folder_24_h.png"
' ========================================================================================
' Loads an image from a file using GDI+, converts it to an icon and returns the icon handle.
' Parameter:
' - bstrFileName = [in] Path of the image to load and convert.
' Return Value:
' If the function succeeds, the return value is the handle of the created icon.
' If the function fails, the return value is NULL.
' ========================================================================================
FUNCTION GdiPlusCreateHICONFromFile (BYVAL bstrFileName AS WSTRING) AS DWORD
LOCAL hStatus AS LONG ' // Status
LOCAL token AS DWORD ' // Token to shutdown GDI+
LOCAL StartupInput AS GdiplusStartupInput ' // Structure to initialize GDI+
LOCAL pImage AS DWORD ' // Image handle
LOCAL hIcon AS DWORD ' // Icon handle
StartupInput.GdiplusVersion = 1
hStatus = GdiplusStartup(token, StartupInput, BYVAL %NULL)
IF hStatus <> %StatusOk THEN EXIT FUNCTION
hStatus = GdipLoadImageFromFile(BYCOPY bstrFileName, pImage)
IF hStatus = %StatusOk THEN
hStatus = GdipCreateHICONFromBitmap(pImage, hIcon)
GdipDisposeImage pImage
END IF
GdiplusShutdown token
FUNCTION = hIcon
END FUNCTION
' ========================================================================================
' ========================================================================================
' Loads an image from a resource using GDI+, converts it to an icon and returns the icon handle.
' Parameter:
' - hInstance = [in] Handle to the instance that contains the resource.
' - bstrImage = [in] Name of the image in the resource file (.RES). If the image resource uses
' an integral identifier, bstrImage should begin with a number symbol (#)
' followed by the identifier in an ASCII format, e.g., "#998". Otherwise,
' use the text identifier name for the image. Only images embedded as raw data
' (type RCDATA) are valid. These must be icons in format .png, .jpg, .gif, .tiff.
' Return Value:
' If the function succeeds, the return value is the handle of the created icon.
' If the function fails, the return value is NULL.
' Call GetLasrError to retrieve the error code.
' ========================================================================================
FUNCTION GdiPlusCreateHICONFromResource (BYVAL hInstance AS DWORD, BYVAL bstrImage AS WSTRING) AS DWORD
LOCAL hStatus AS LONG ' // Status
LOCAL token AS DWORD ' // Token to shutdown GDI+
LOCAL StartupInput AS GdiplusStartupInput ' // Structure to initialize GDI+
LOCAL pImage AS DWORD ' // Image handle
LOCAL hIcon AS DWORD ' // Icon handle
LOCAL hResource AS DWORD ' // Resource handle
LOCAL pResourceData AS DWORD ' // Pointer to the resoruce data
LOCAL hGlobal AS DWORD ' // Global memory handle
LOCAL pGlobalBuffer AS DWORD ' // Pointer to global memory buffer
LOCAL pImageStream AS IStream ' // IStream interface pointer
LOCAL imageSize AS DWORD ' // Image size
LOCAL wID AS WORD
LOCAL dwID AS DWORD
IF hInstance = 0 THEN EXIT FUNCTION
StartupInput.GdiplusVersion = 1
hStatus = GdiplusStartup(token, StartupInput, BYVAL %NULL)
IF hStatus <> %S_OK THEN EXIT FUNCTION
' // Find the resource and lock it
IF LEFT$(bstrImage, 1) = "#" THEN
wID = VAL(MID$(bstrImage, 2))
dwID = MAK(DWORD, wID, 0)
hResource = FindResourceW(hInstance, BYVAL dwID, BYVAL %RT_RCDATA)
ELSE
hResource = FindResourceW(hInstance, BYCOPY bstrImage, BYVAL %RT_RCDATA)
END IF
IF hResource = %NULL THEN SetLastError(%E_INVALIDARG) : GOTO LExit
imageSize = SizeofResource(hInstance, hResource)
IF imageSize = 0 THEN SetLastError(%E_INVALIDARG) : GOTO LExit
pResourceData = LockResource(LoadResource(hInstance, hResource))
IF pResourceData = %NULL THEN SetLastError(%E_INVALIDARG) : GOTO LExit
' // Allocate memory to hold the image
hGlobal = GlobalAlloc(%GMEM_MOVEABLE, imageSize)
IF hGlobal THEN
' // Lock the memory
pGlobalBuffer = GlobalLock(hGlobal)
IF pGlobalBuffer THEN
' // Copy the image from the resource file to global memory
CopyMemory pGlobalBuffer, pResourceData, imageSize
' // Create an stream in global memory
IF CreateStreamOnHGlobal(hGlobal, %FALSE, pImageStream) = %S_OK THEN
' // Create a bitmap from the data contained in the stream
hStatus = GdipCreateBitmapFromStream(pImageStream, pImage)
IF hStatus = %StatusOk THEN
IF pImage THEN
hStatus = GdipCreateHICONFromBitmap(pImage, hIcon)
GdipDisposeImage pImage
END IF
END IF
END IF
' // Unlock the memory
GlobalUnlock pGlobalBuffer
END IF
' // Free the memory
GlobalFree hGlobal
END IF
LExit:
GdiplusShutdown token
FUNCTION = hIcon
END FUNCTION
' ========================================================================================
' ========================================================================================
' Loads an image from a file using GDI+, converts it to an icon and returns the icon handle.
' Parameters:
' - bstrFileName = [in] Path of the image to load and convert.
' - clrBackground = [in] The background color. This parameter is ignored if the bitmap is totally opaque.
' Return Value:
' If the function succeeds, the return value is the handle of the created icon.
' If the function fails, the return value is NULL.
' ========================================================================================
FUNCTION GdiPlusCreateHBITMAPFromFile (BYVAL bstrFileName AS WSTRING, BYVAL clrBackground AS DWORD) AS DWORD
LOCAL hStatus AS LONG ' // Status
LOCAL token AS DWORD ' // Token to shutdown GDI+
LOCAL StartupInput AS GdiplusStartupInput ' // Structure to initialize GDI+
LOCAL pImage AS DWORD ' // Image handle
LOCAL hBitmap AS DWORD ' // Bitmap handle
StartupInput.GdiplusVersion = 1
hStatus = GdiplusStartup(token, StartupInput, BYVAL %NULL)
IF hStatus <> %StatusOk THEN EXIT FUNCTION
hStatus = GdipLoadImageFromFile(BYCOPY bstrFileName, pImage)
IF hStatus = %StatusOk THEN
hStatus = GdipCreateHBITMAPFromBitmap(pImage, hBitmap, clrBackground)
GdipDisposeImage pImage
END IF
GdiplusShutdown token
FUNCTION = hBitmap
END FUNCTION
' ========================================================================================
' ========================================================================================
' Loads an image from a resource using GDI+, converts it to an icon and returns the icon handle.
' Parameters:
' - hInstance = [in] Handle to the instance that contains the resource.
' - bstrImage = [in] Name of the image in the resource file (.RES). If the image resource uses
' an integral identifier, bstrImage should begin with a number symbol (#)
' followed by the identifier in an ASCII format, e.g., "#998". Otherwise,
' use the text identifier name for the image. Only images embedded as raw data
' (type RCDATA) are valid. These must be icons in format .png, .jpg, .gif, .tiff.
' - clrBackground = [in] The background color. This parameter is ignored if the bitmap is totally opaque.
' Return Value:
' If the function succeeds, the return value is the handle of the created icon.
' If the function fails, the return value is NULL.
' Call GetLasrError to retrieve the error code.
' ========================================================================================
FUNCTION GdiPlusCreateHBITMAPFromResource (BYVAL hInstance AS DWORD, BYVAL bstrImage AS WSTRING, BYVAL clrBackground AS DWORD) AS DWORD
LOCAL hStatus AS LONG ' // Status
LOCAL token AS DWORD ' // Token to shutdown GDI+
LOCAL StartupInput AS GdiplusStartupInput ' // Structure to initialize GDI+
LOCAL pImage AS DWORD ' // Image handle
LOCAL hBitmap AS DWORD ' // Bitmap handle
LOCAL hResource AS DWORD ' // Resource handle
LOCAL pResourceData AS DWORD ' // Pointer to the resoruce data
LOCAL hGlobal AS DWORD ' // Global memory handle
LOCAL pGlobalBuffer AS DWORD ' // Pointer to global memory buffer
LOCAL pImageStream AS IStream ' // IStream interface pointer
LOCAL imageSize AS DWORD ' // Image size
LOCAL wID AS WORD
LOCAL dwID AS DWORD
IF hInstance = 0 THEN EXIT FUNCTION
StartupInput.GdiplusVersion = 1
hStatus = GdiplusStartup(token, StartupInput, BYVAL %NULL)
IF hStatus <> %S_OK THEN EXIT FUNCTION
' // Find the resource and lock it
IF LEFT$(bstrImage, 1) = "#" THEN
wID = VAL(MID$(bstrImage, 2))
dwID = MAK(DWORD, wID, 0)
hResource = FindResourceW(hInstance, BYVAL dwID, BYVAL %RT_RCDATA)
ELSE
hResource = FindResourceW(hInstance, BYCOPY bstrImage, BYVAL %RT_RCDATA)
END IF
IF hResource = %NULL THEN SetLastError(%E_INVALIDARG) : GOTO LExit
imageSize = SizeofResource(hInstance, hResource)
IF imageSize = 0 THEN SetLastError(%E_INVALIDARG) : GOTO LExit
pResourceData = LockResource(LoadResource(hInstance, hResource))
IF pResourceData = %NULL THEN SetLastError(%E_INVALIDARG) : GOTO LExit
' // Allocate memory to hold the image
hGlobal = GlobalAlloc(%GMEM_MOVEABLE, imageSize)
IF hGlobal THEN
' // Lock the memory
pGlobalBuffer = GlobalLock(hGlobal)
IF pGlobalBuffer THEN
' // Copy the image from the resource file to global memory
CopyMemory pGlobalBuffer, pResourceData, imageSize
' // Create an stream in global memory
IF CreateStreamOnHGlobal(hGlobal, %FALSE, pImageStream) = %S_OK THEN
' // Create a bitmap from the data contained in the stream
hStatus = GdipCreateBitmapFromStream(pImageStream, pImage)
IF hStatus = %StatusOk THEN
IF pImage THEN
hStatus = GdipCreateHBITMAPFromBitmap(pImage, hBitmap, clrBackground)
GdipDisposeImage pImage
END IF
END IF
END IF
' // Unlock the memory
GlobalUnlock pGlobalBuffer
END IF
' // Free the memory
GlobalFree hGlobal
END IF
LExit:
GdiplusShutdown token
FUNCTION = hBitmap
END FUNCTION
' ========================================================================================