I have modified CWindow, CXpButton and CPgBar3D to store the pointer to the class in the window extra bytes instead of as a property.
Therefore, instead of using something like
pWindow = CAST(CWindow PTR, GetPropW(hwnd, "CWINDOWPTR"))
that had the inconvenience of having to remember the name of the property ("CWINDOWPTR", etc.), we now will always use something line
pWindow = CAST(CWindow PTR, GetWindowLongPtr(hwnd, 0))
And these are the modified OOP versions of the progress bar sample programs.
A split button is a button with a drop down arrow. It is available with Windows Vista+ and needs the use of a manifest because we need to use version 6 of the Windows Common Controls. It also supports the use of an imagelist to display icons.
To make the size of the icon DPI aware, I have used this formula:
' // Calculate an appropriate icon size
DIM cx AS LONG = 16 * pWindow.DPI \ 96
based in that 16 pixels is the normal icon size for 96 DPI.
Remember to link a resource file that includes a manifest and remember also to change the path and name of the icon.
' ########################################################################################
' Microsoft Windows
' File: CW_SplitButton.fbtpl
' Contents: CWindow with a split button
' Compiler: FreeBasic 32 & 64 bit
' Copyright (c) 2016 Jose Roca. Freeware. Use at your own risk.
' THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
' EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE IMPLIED WARRANTIES OF
' MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
' ########################################################################################
#define unicode
#define _WIN32_WINNT &h0602
#INCLUDE ONCE "windows.bi"
#INCLUDE ONCE "Afx/CWindow.inc"
#INCLUDE ONCE "Afx/AfxGdiplus.inc"
' // You must link a resource file that includes a manifest
' $FB_RESPATH = "FBRES.rc"
USING Afx.CWindowClass
USING Afx.Gdiplus
CONST IDC_MENUCOMMAND1 = 28000
CONST IDC_MENUCOMMAND2 = 28001
DECLARE FUNCTION WinMain (BYVAL hInstance AS HINSTANCE, _
BYVAL hPrevInstance AS HINSTANCE, _
BYVAL szCmdLine AS ZSTRING PTR, _
BYVAL nCmdShow AS LONG) AS LONG
END WinMain(GetModuleHandleW(""), NULL, COMMAND(), SW_NORMAL)
' ========================================================================================
' Window procedure
' ========================================================================================
FUNCTION WndProc (BYVAL hWnd AS HWND, BYVAL uMsg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM) AS LRESULT
DIM hDC AS HDC
DIM pPaint AS PAINTSTRUCT
DIM rc AS RECT
DIM pWindow AS CWindow PTR
SELECT CASE uMsg
CASE WM_CREATE
EXIT FUNCTION
CASE WM_COMMAND
' // If ESC key pressed, close the application sending an WM_CLOSE message
SELECT CASE LOWORD(wParam)
CASE IDCANCEL
IF HIWORD(wParam) = BN_CLICKED THEN
SendMessageW hwnd, WM_CLOSE, 0, 0
EXIT FUNCTION
END IF
END SELECT
CASE WM_NOTIFY
' // Processs notify messages sent by the split button
DIM pNmh AS NMHDR PTR = CAST(NMHDR PTR, lParam)
IF pNmh->idFrom = IDCANCEL AND pNmh->code = BCN_DROPDOWN THEN
DIM pDropDown AS NMBCDROPDOWN PTR = CAST(NMBCDROPDOWN PTR, lParam)
' // Get screen coordinates of the button
DIM pt AS POINT = (pDropdown->rcButton.left, pDropDown->rcButton.bottom)
ClientToScreen(pNmh->hwndFrom, @pt)
' // Create a menu and add items
DIM hSplitMenu AS HMENU = CreatePopupMenu
AppendMenuW(hSplitMenu, MF_BYPOSITION, IDC_MENUCOMMAND1, "Menu item 1")
AppendMenuW(hSplitMenu, MF_BYPOSITION, IDC_MENUCOMMAND2, "Menu item 2")
' // Display the menu
TrackPopupMenu(hSplitMenu, TPM_LEFTALIGN OR TPM_TOPALIGN, pt.x, pt.y, 0, hwnd, NULL)
FUNCTION = CTRUE
EXIT FUNCTION
END IF
CASE WM_SIZE
IF wParam <> SIZE_MINIMIZED THEN
' // Resize the button
pWindow = CAST(CWindow PTR, GetWindowLongPtr(hwnd, 0))
pWindow->MoveWindow GetDlgItem(hwnd, IDCANCEL), pWindow->ClientWidth - 200, pWindow->ClientHeight - 90, 110, 23, CTRUE
END IF
CASE WM_DESTROY
ImageList_Destroy CAST(HIMAGELIST, SendMessageW(GetDlgItem(hwnd, IDCANCEL), TB_SETIMAGELIST, 0, 0))
PostQuitMessage(0)
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProcW(hWnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS HINSTANCE, _
BYVAL hPrevInstance AS HINSTANCE, _
BYVAL szCmdLine AS ZSTRING PTR, _
BYVAL nCmdShow AS LONG) AS LONG
' // Set process DPI aware
AfxSetProcessDPIAware
DIM pWindow AS CWindow
pWindow.Create(NULL, "CWindow with a split button", @WndProc)
pWindow.SetClientSize(300, 150)
pWindow.Center
' // Add a button without position or size (it will be resized in the WM_SIZE message).
DIM hSplitButton AS HWND = pWindow.AddControl("Button", pWindow.hWindow, IDCANCEL, _
"&Shutdown", , , , , WS_CHILD OR WS_VISIBLE OR WS_TABSTOP OR BS_CENTER OR BS_VCENTER OR BS_SPLITBUTTON)
' // Calculate an appropriate icon size
DIM cx AS LONG = 16 * pWindow.DPI \ 96
' // Create an image list for the button
DIM hImageList AS HIMAGELIST = ImageList_Create(cx, cx, ILC_COLOR32 OR ILC_MASK, 1, 0)
' // Remember to change the path and name of the icon
IF hImageList THEN ImageList_ReplaceIcon(hImageList, -1, AfxGdipImageFromFile(ExePath & "\Shutdown_48.png"))
' // Fill a BUTTON_IMAGELIST structure and set the image list
DIM bi AS BUTTON_IMAGELIST = (hImageList, (3, 3, 3, 3), BUTTON_IMAGELIST_ALIGN_LEFT)
SendMessageW hSplitButton, BCM_SETIMAGELIST, 0, CAST(LPARAM, @bi)
' // Process windows events
FUNCTION = pWindow.DoEvents(nCmdShow)
END FUNCTION
' ========================================================================================
Thanks to the functions included in AfxGdiplus.inc, we don't need to have a set of different icon sizes for each DPI setting. We can have a 48 or 64 icon and create the image list with the appropriate width and height using the formula: DIM cx AS LONG = 16 * pWindow.DPI \ 96.
Note that, unlike LoadImage, you don't have to specify the wanted dimensions of the icon when using the AfxGdipxxx functions that create the icon from a .png file, only when calling ImageList_Create.
By using a manifest, the alpha channel is preserved; otherwise, it is lost, because versions of the common controls library below 6 don't support the alpha channel.
I also like this FreeBasic shortcut to fill structures:
DIM bi AS BUTTON_IMAGELIST = (hImageList, (3, 3, 3, 3), BUTTON_IMAGELIST_ALIGN_LEFT)
The structure is as follows:
type BUTTON_IMAGELIST
himl as HIMAGELIST
margin as RECT
uAlign as UINT
end type
The (3, 3, 3, 3) in the assignment allows to fill the embedded RECT structure. Nice.
The new cWindow class is looking awesome! Finally a great new Windows based framework for FreeBASIC.
I am just thinking out loud at this point, but I can see new users having no trouble creating windows and adding controls, however, I can see users having trouble dealing with the notifications/events from those windows/controls. Just as PowerBASIC users do not take the time to learn the meanings of wParam and lParam values for notifications, I can see FreeBASIC users having the same lack of interest. I wonder if eventually you might want to consider creating message crackers similar to how the old style C programmers used to deal with the WinAPI. It would also ensure that messages are cracked correctly between 32 and 64 bit.
Basically, maybe start creating examples using the handlers found in windowsx.bi
Then have separate functions setup to respond to those macros: like, OnCreate, OnSize, OnDestroy, etc...
It would help hide all of the messy CAST, LOWORD, HIWORD, stuff, and make the code much more "approachable" and structured for newbies.
Just a thought.
I never have liked to use message crackers. But the main reason is that, since FB doesn't remove dead code, I want to keep the class as lightweight as possible. Even some of the auxiliary code will eventually end in separate include files.
But these classes are not like PB classes. You can simply extend it and do wathever you like.
MyClsWindow EXTENDS CWindow
and pass to it a pointer to your new window procedure, and replace the DoEvents procedure with your own, and/or override methods, etc.
This way, CWindow will provide the basic stuff and you can add all the bloat you like.
BTW many of these messy CAST, LOWORD, HIWORD, stuff can be solved with defines or macros. windowsx.bi already has many of them, such GET_X_LPARAM, GET_Y_LPARAM, etc. I will try to learn more about FB macros. Until now I have mainly written test code.
I think that the last version of CWindow can already be used for production code. It does a lot of things with little overhead. DPI and Unicode aware, MDI support, works with 32 and 64 bit without changes, etc. And see how easily I have extended it in the CTabPage class to provide support for tab pages.
There are convenient defines in windowsx.bi that I will begin to use, such DeleteFont or SelectFont.
Therefore, instead of
DeleteObject(CAST(HGDIOBJ, hNewFont))
I will use
DeleteFont(hNewFont)
or instead of
SelectObject(hDC, CAST(HGDIOBJ, CAST(HFONT, hOldFont)))
I will use
SelectFont(hDC, hOldFont)
They're convenient because they hide these nasty casts.
But using defines for Windows messages can be more problematic, because the MSDN documentation talks about HIWORD of wParam, not about GET_WM_COMMAND_CMD or something like that.
Don't undestand.
If I try to replace
IF hNewFont THEN DeleteObject(CAST(HGDIOBJ, hNewFont))
with
IF hNewFont THEN DeleteFont(hNewFont)
I get a syntax error.
Error 17: Syntax error. Found 'hNewFont' in 'IF hNewFont THEN DeleteFont(hNewFont)'.
DeleteFont is defined as
#define DeleteFont(hfont) DeleteObject(cast(HGDIOBJ, cast(HFONT, (hfont))))
in windowsx.bi
Jose,
It probably isn't this but I NEVER use single line IF THEN statements.
James
If doesn't matter if I use one line or
IF hNewFont NULL THEN
DeleteFont(hNewFont)
END IF
or
IF hNewFont <> NULL THEN
DeleteFont(hNewFont)
END IF
Where is the syntax error?
The easier way to avoid that casting mess would be, of course, to remove that irritant strict type checking from the compiler. It is impossible to write a couple of lines of API code without having to use CAST. I wonder if the writers of the compiler use it to write applications. Probably they use C++.
I think it has to do with the #define using the hfont variable as part of the expansion. Maybe because hfont is a defined structure in FB.
I changed the declare to the following and it worked:
#Define DeleteFont(_hfont) DeleteObject(Cast(HGDIOBJ, Cast(HFONT, (_hfont)) ))
If this is the case then I can post on the FB forum to get a more definitive answer.
Something frequently asked. How to make a modal popup window?
' ########################################################################################
' Microsoft Windows
' File: CW_PopupWindow.fbtpl
' Contents: CWindow with a modal popup window
' Compiler: FreeBasic 32 & 64 bit
' Copyright (c) 2016 Jose Roca. Freeware. Use at your own risk.
' THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
' EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE IMPLIED WARRANTIES OF
' MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
' ########################################################################################
#define unicode
#INCLUDE ONCE "windows.bi"
#INCLUDE ONCE "Afx/CWindow.inc"
USING Afx.CWindowClass
CONST IDC_POPUP = 1001
DECLARE FUNCTION WinMain (BYVAL hInstance AS HINSTANCE, _
BYVAL hPrevInstance AS HINSTANCE, _
BYVAL szCmdLine AS ZSTRING PTR, _
BYVAL nCmdShow AS LONG) AS LONG
END WinMain(GetModuleHandleW(""), NULL, COMMAND(), SW_NORMAL)
DECLARE FUNCTION WndProc (BYVAL hWnd AS HWND, BYVAL uMsg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM) AS LRESULT
DECLARE FUNCTION PopupWindow (BYVAL hParent AS HWND) AS LONG
DECLARE FUNCTION PopupWndProc (BYVAL hWnd AS HWND, BYVAL uMsg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM) AS LRESULT
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS HINSTANCE, _
BYVAL hPrevInstance AS HINSTANCE, _
BYVAL szCmdLine AS ZSTRING PTR, _
BYVAL nCmdShow AS LONG) AS LONG
' // Set process DPI aware
AfxSetProcessDPIAware
DIM pWindow AS CWindow
pWindow.Create(NULL, "CWindow with a popup window", @WndProc)
pWindow.SetClientSize(500, 320)
pWindow.Center
' // Add a button without position or size (it will be resized in the WM_SIZE message).
pWindow.AddControl("Button", pWindow.hWindow, IDC_POPUP, "&Popup", 350, 250, 75, 23)
FUNCTION = pWindow.DoEvents(nCmdShow)
END FUNCTION
' ========================================================================================
' ========================================================================================
' Window procedure
' ========================================================================================
FUNCTION WndProc (BYVAL hWnd AS HWND, BYVAL uMsg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM) AS LRESULT
DIM hDC AS HDC
DIM pPaint AS PAINTSTRUCT
DIM rc AS RECT
DIM pWindow AS CWindow PTR
SELECT CASE uMsg
CASE WM_CREATE
EXIT FUNCTION
CASE WM_COMMAND
' // If ESC key pressed, close the application sending an WM_CLOSE message
SELECT CASE LOWORD(wParam)
CASE IDCANCEL
IF HIWORD(wParam) = BN_CLICKED THEN
SendMessageW hwnd, WM_CLOSE, 0, 0
EXIT FUNCTION
END IF
CASE IDC_POPUP
IF HIWORD(wParam) = BN_CLICKED THEN
PopupWindow(hwnd)
EXIT FUNCTION
END IF
END SELECT
CASE WM_SIZE
IF wParam <> SIZE_MINIMIZED THEN
' // Resize the buttons
pWindow = CAST(CWindow PTR, GetWindowLongPtr(hwnd, 0))
pWindow->MoveWindow GetDlgItem(hwnd, IDCANCEL), pWindow->ClientWidth - 120, pWindow->ClientHeight - 50, 75, 23, CTRUE
END IF
CASE WM_DESTROY
PostQuitMessage(0)
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProcW(hWnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
' ========================================================================================
' Popup window procedure
' ========================================================================================
FUNCTION PopupWindow (BYVAL hParent AS HWND) AS LONG
DIM pWindow AS CWindow
pWindow.Create(hParent, "Popup window", @PopupWndProc, , , , , _
WS_VISIBLE OR WS_CAPTION OR WS_POPUPWINDOW OR WS_THICKFRAME, WS_EX_WINDOWEDGE)
pWindow.Brush = GetStockObject(WHITE_BRUSH)
pWindow.SetClientSize(300, 200)
pWindow.Center(pWindow.hWindow, hParent)
' / Process Windows messages
FUNCTION = pWindow.DoEvents
END FUNCTION
' ========================================================================================
' ========================================================================================
' Popup window procedure
' ========================================================================================
FUNCTION PopupWndProc (BYVAL hWnd AS HWND, BYVAL uMsg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM) AS LRESULT
DIM hOldFont AS HFONT
STATIC hNewFont AS HFONT
SELECT CASE uMsg
CASE WM_CREATE
' // Get a pointer to the CWindow class from the CREATESTRUCT structure
DIM pCreateStruct AS CREATESTRUCT PTR = CAST(CREATESTRUCT PTR, lParam)
DIM pWindow AS CWindow PTR = CAST(CWindow PTR, pCreateStruct->lpCreateParams)
' // Create a new font scaled according the DPI ratio
IF pWindow->DPI <> 96 THEN hNewFont = pWindow->CreateFont("Tahoma", 9)
' Disable parent window to make popup window modal
EnableWindow GetParent(hwnd), FALSE
EXIT FUNCTION
CASE WM_COMMAND
SELECT CASE LOWORD(wParam)
' // If ESC key pressed, close the application sending an WM_CLOSE message
CASE IDCANCEL
IF HIWORD(wParam) = BN_CLICKED THEN
SendMessageW hwnd, WM_CLOSE, 0, 0
EXIT FUNCTION
END IF
END SELECT
CASE WM_PAINT
DIM rc AS RECT, ps AS PAINTSTRUCT, hDC AS HANDLE
hDC = BeginPaint(hWnd, @ps)
IF hNewFont THEN hOldFont = CAST(HFONT, SelectObject(hDC, CAST(HGDIOBJ, hNewFont)))
GetClientRect(hWnd, @rc)
DrawTextW(hDC, "Hello, World!", -1, @rc, DT_SINGLELINE or DT_CENTER or DT_VCENTER)
IF hNewFont THEN SelectObject(hDC, CAST(HGDIOBJ, CAST(HFONT, hOldFont)))
EndPaint(hWnd, @ps)
EXIT FUNCTION
CASE WM_CLOSE
' // Enables parent window keeping parent's zorder
EnableWindow GetParent(hwnd), CTRUE
' // Don't exit; let DefWindowProcW perform the default action
CASE WM_DESTROY
' // Destroy the new font
IF hNewFont THEN DeleteObject(CAST(HGDIOBJ, hNewFont))
' // End the application by sending an WM_QUIT message
PostQuitMessage(0)
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProcW(hWnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
Quote from: TechSupport on May 03, 2016, 06:18:24 PM
I think it has to do with the #define using the hfont variable as part of the expansion. Maybe because hfont is a defined structure in FB.
I changed the declare to the following and it worked:
#Define DeleteFont(_hfont) DeleteObject(Cast(HGDIOBJ, Cast(HFONT, (_hfont)) ))
If this is the case then I can post on the FB forum to get a more definitive answer.
That is. As always, macros are a can of worms.
Happens with SelectFont as well. I bet it happens with all the HFONT macros.
I posted over on the FB forum regarding the DeleteFont sysntax error.
http://www.freebasic.net/forum/viewtopic.php?f=6&t=24663
I have adapted another old control by Börje to FreeBasic, making it DPI and Unicode aware.
Demonstrates how to make a custom control subclassing an existing one.
' ########################################################################################
' Microsoft Windows
' File: CbColor.inc
' Contents: Combobox color list
' Based on the CBCOLOR control originally written by Börje Hagsten in 2001.
' Compiler: FreeBasic 32 & 64-bit
' Freeware. Use at your own risk.
' Copyright (c) 2016 Jose Roca. All Rights Reserved.
' THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
' EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE IMPLIED WARRANTIES OF
' MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
' ########################################################################################
#pragma once
#include once "windows.bi"
#include once "Afx/CWindow.inc"
#include once "win/commdlg.bi"
USING Afx.CWindowClass
NAMESPACE Afx.CCbColorClass
CONST CBCOL_SETAUTOCOLOR = WM_USER + 100
CONST CBCOL_SETUSERCOLOR = WM_USER + 101
CONST CBCOL_SETCOLORNAME = WM_USER + 102
CONST CBCOL_GETAUTOCOLOR = WM_USER + 200
CONST CBCOL_GETUSERCOLOR = WM_USER + 201
CONST CBCOL_GETSELCOLOR = WM_USER + 202
' ========================================================================================
' CCbColor class
' ========================================================================================
TYPE CCbColor
Protected:
m_hCtl AS HWND ' // Button handle
m_hFont AS HFONT ' // Font handle
m_oldProc AS WNDPROC ' // Subclass procedure
Public:
m_autoColor AS COLORREF ' // Auto color
m_userColor AS COLORREF ' // User color
m_ratio AS SINGLE ' // DPI ratio - width
DIM m_rgColors(15) AS COLORREF
DIM m_rgNames (17) AS WSTRING * 20 = {"Auto", "Black", "Blue", "Green", "Cyan", "Red", _
"Magenta", "Brown", "Light Gray", "Gray", "Light Blue", "Light Green", "Light Cyan", _
"Light Red", "Light Magenta", "Yellow", "Bright White", "User selected..."}
DECLARE CONSTRUCTOR (BYVAL pWindow AS CWindow PTR, BYVAL cID AS INTEGER, _
BYVAL x AS LONG = 0, BYVAL y AS LONG = 0, BYVAL nWidth AS LONG = 0, BYVAL nHeight AS LONG = 0, _
BYVAL dwAutoColor AS COLORREF = 0, BYVAL dwUserColor AS COLORREF = 0)
DECLARE DESTRUCTOR
DECLARE FUNCTION hWindow () AS HWND
DECLARE FUNCTION GetQBColor (BYVAL hWnd AS HWND, BYVAL c AS LONG, BYVAL dlg AS LONG) AS COLORREF
DECLARE PROPERTY AutoColor (BYVAL nColor AS COLORREF)
DECLARE PROPERTY AutoColor () AS COLORREF
DECLARE PROPERTY UserColor (BYVAL nColor AS COLORREF)
DECLARE PROPERTY UserColor () AS COLORREF
DECLARE PROPERTY SelColor () AS COLORREF
END TYPE
' ========================================================================================
' ========================================================================================
' Window procedure
' ========================================================================================
FUNCTION CCbColorProc (BYVAL hwnd AS HWND, BYVAL uMsg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM) AS LRESULT
DIM pCbColor AS CCbColor PTR
SELECT CASE uMsg
CASE WM_CREATE
EXIT FUNCTION
CASE WM_DESTROY
' // Remove the subclassing
SetWindowLongPtrW hwnd, GWLP_WNDPROC, CAST(LONG_PTR, RemovePropW(hwnd, "OLDWNDPROC"))
' // Remove the property
.RemovePropW(hwnd, "CBCOLORPTR")
EXIT FUNCTION
CASE WM_DRAWITEM
' // Get a pointer to the class
pCbColor = CAST(CCbColor PTR, .GetPropW(hwnd, "CBCOLORPTR"))
IF pCbColor = NULL THEN EXIT FUNCTION
SCOPE
DIM hBrush AS HBRUSH, wszText AS WSTRING * 80
DIM lpdis AS DRAWITEMSTRUCT PTR, rc AS RECT
lpdis = CAST(DRAWITEMSTRUCT PTR, lParam)
IF lpdis->itemID = &hFFFFFFFF THEN EXIT FUNCTION
SELECT CASE lpdis->itemAction
CASE ODA_DRAWENTIRE, ODA_SELECT
' // Clear background
FillRect lpdis->hDC, @lpdis->rcItem, .GetSysColorBrush(COLOR_WINDOW)
' // Get/draw text
.SendMessageW hwnd, CB_GETLBTEXT, lpdis->itemID, CAST(.LPARAM, @wszText)
.SetBkColor lpdis->hDC, GetSysColor(COLOR_WINDOW)
.SetTextColor lpdis->hDC, GetSysColor(COLOR_WINDOWTEXT)
rc = lpdis->rcItem
rc.Left = 28 * (pCbColor->m_ratio * 0.72)
.DrawTextW lpdis->hDC, @wszText, LEN(wszText), @rc, DT_SINGLELINE OR DT_LEFT OR DT_VCENTER
' // If selected item...
IF (lpdis->itemState AND ODS_SELECTED) THEN
' // If not ODS_COMBOBOXEDIT...
IF (lpdis->itemState AND ODS_COMBOBOXEDIT) = 0 THEN
' // Set coordinates
rc.Left = 26 * (pCbColor->m_ratio * 0.72)
rc.Right = lpdis->rcItem.Right
rc.Top = lpdis->rcItem.Top
rc.Bottom = lpdis->rcItem.Bottom
' // Invert area around text only
.InvertRect lpdis->hDC, @rc
END IF
' // and draw a focus rectangle around all
.DrawFocusRect lpdis->hDC, @lpdis->rcItem
END IF
' // Paint color rectangle using RoundRect for nicer looks
' /// If ODS_COMBOBOXEDIT...
IF (lpdis->itemState AND ODS_COMBOBOXEDIT) THEN
' // Set coordinates
rc.Left = 4 * (pCbColor->m_ratio * 0.72)
rc.Right = 24 * (pCbColor->m_ratio * 0.72)
ELSE
' // A tiny bit to the left in list...
rc.Left = 3 * (pCbColor->m_ratio * 0.72)
rc.Right = 23 * (pCbColor->m_ratio * 0.72)
END IF
rc.Top = (lpdis->rcItem.Top + (2 * pCbColor->m_ratio))
rc.Bottom = (lpdis->rcItem.Bottom - (2 * pCbColor->m_ratio))
' // Create brush with the appropriate color
hBrush = .CreateSolidBrush(pCbColor->GetQBColor(hWnd, lpdis->itemID, FALSE))
' // Select brush into device context
hBrush = .SelectObject(lpdis->hDC, hBrush)
' // Draw the rectangle
DIM nCorner AS LONG = pCbColor->m_ratio * 0.72
.RoundRect(lpdis->hDC, rc.Left, rc.Top, rc.Right, rc.Bottom, nCorner, nCorner)
' // Select old brush back and delete new one
.DeleteObject .SelectObject(lpdis->hDC, hBrush)
END SELECT
END SCOPE
FUNCTION = CTRUE
EXIT FUNCTION
' // Set auto color
CASE CBCOL_SETAUTOCOLOR
pCbColor = CAST(CCbColor PTR, .GetPropW(hwnd, "CBCOLORPTR"))
IF pCbColor = NULL THEN EXIT FUNCTION
pCbColor->m_AutoColor = wParam
EXIT FUNCTION
' // Set auto color
CASE CBCOL_GETAUTOCOLOR
pCbColor = CAST(CCbColor PTR, .GetPropW(hwnd, "CBCOLORPTR"))
IF pCbColor = NULL THEN EXIT FUNCTION
FUNCTION = pCbColor->m_AutoColor
EXIT FUNCTION
' // Set user color
CASE CBCOL_SETUSERCOLOR
pCbColor = CAST(CCbColor PTR, .GetPropW(hwnd, "CBCOLORPTR"))
IF pCbColor = NULL THEN EXIT FUNCTION
FUNCTION = pCbColor->m_UserColor
EXIT FUNCTION
' // Get user color
CASE CBCOL_GETUSERCOLOR
pCbColor = CAST(CCbColor PTR, .GetPropW(hwnd, "CBCOLORPTR"))
IF pCbColor = NULL THEN EXIT FUNCTION
FUNCTION = pCbColor->m_UserColor
EXIT FUNCTION
' // Return selected color
CASE CBCOL_GETSELCOLOR
DIM nRes AS LONG
nRes = SendMessageW(hwnd, CB_GETCURSEL, 0, 0)
pCbColor = CAST(CCbColor PTR, .GetPropW(hwnd, "CBCOLORPTR"))
IF pCbColor = NULL THEN EXIT FUNCTION
IF nRes > CB_ERR THEN
FUNCTION = pCbColor->GetQBColor(hwnd, nRes, CTRUE)
END IF
EXIT FUNCTION
END SELECT
' // Default processing for other messages.
FUNCTION = CallWindowProcW(GetPropW(hwnd, "OLDWNDPROC"), hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
' ========================================================================================
' CPgBar3D class constructor
' ========================================================================================
CONSTRUCTOR CCbColor (BYVAL pWindow AS CWindow PTR, BYVAL cID AS INTEGER, _
BYVAL x AS LONG = 0, BYVAL y AS LONG = 0, BYVAL nWidth AS LONG = 0, BYVAL nHeight AS LONG = 0, _
BYVAL dwAutoColor AS COLORREF = 0, BYVAL dwUserColor AS COLORREF = 0)
' // Create the control
IF pWindow THEN
m_hCtl = pWindow->AddControl("COMBOBOX", pWindow->hWindow, cID, "", _
x, y, nWidth, nHeight, WS_CHILD OR WS_VISIBLE OR CBS_OWNERDRAWFIXED OR CBS_HASSTRINGS OR _
CBS_DROPDOWNLIST OR WS_TABSTOP OR CBS_DISABLENOSCROLL OR WS_VSCROLL, WS_EX_CLIENTEDGE, _
NULL, CAST(WNDPROC, @CCbColorProc))
m_ratio = pWindow->rxRatio
END IF
IF m_hCtl THEN
' // Set the same font used by the parent
DIM lfw AS LOGFONTW
IF pWindow->Font THEN
IF GetObjectW(pWindow->Font, SIZEOF(lfw), @lfw) THEN m_hFont = CreateFontIndirect(@lfw)
END IF
' // Store a pointer to the class as a property
.SetPropW(m_hCtl, "CBCOLORPTR", CAST(HANDLE, @this))
DIM i AS LONG
FOR i = 0 TO UBOUND(m_rgNames)
SendMessageW m_hCtl, CB_ADDSTRING, 0, CAST(LPARAM, @m_rgNames(i))
NEXT
' // Store default values (usually COLOR_WINDOW or COLOR_WINDOWTEXT)
m_AutoColor = dwAutoColor
m_UserColor = dwUserColor
' // Create initial colormap for the ChooseColor dialog
DIM cl AS LONG
FOR i = 1 TO 16
cl = i * 16 - 1
m_rgColors(16 - i) = BGR(cl, cl, cl)
NEXT
END IF
END CONSTRUCTOR
' ========================================================================================
' ========================================================================================
' CPgBar3D class destructor
' ========================================================================================
DESTRUCTOR CCbColor
' // Free resources
IF m_hFont THEN DeleteObject m_hFont
END DESTRUCTOR
' ========================================================================================
' ========================================================================================
' Returns the handle of the button
' ========================================================================================
FUNCTION CCbColor.hWindow () AS HWND
FUNCTION = m_hCtl
END FUNCTION
' ========================================================================================
' ========================================================================================
' Basic QB color function.
' ========================================================================================
FUNCTION CCbColor.GetQBColor (BYVAL hwnd AS HWND, BYVAL c AS LONG, BYVAL dlg AS LONG) AS COLORREF
SELECT CASE c
CASE 0 : FUNCTION = m_AutoColor ' // Pre-set system color, like COLOR_WINDOW or COLOR_WINDOWTEXT
CASE 1 : FUNCTION = BGR(0, 0, 0) ' // Black
CASE 2 : FUNCTION = BGR(0, 0, 128) ' // Blue
CASE 3 : FUNCTION = BGR(0, 128, 0) ' // Green
CASE 4 : FUNCTION = BGR(0, 128, 128) ' // Cyan
CASE 5 : FUNCTION = BGR(196, 0, 0) ' // Red
CASE 6 : FUNCTION = BGR(128, 0, 128) ' // Magenta
CASE 7 : FUNCTION = BGR(128, 64, 0) ' // Brown
CASE 8 : FUNCTION = BGR(196, 196, 196) ' // Light Gray
CASE 9 : FUNCTION = BGR(128, 128, 128) ' // Gray
CASE 10 : FUNCTION = BGR(0, 0, 255) ' // Light Blue
CASE 11 : FUNCTION = BGR(0, 255, 0) ' // Light Green
CASE 12 : FUNCTION = BGR(0, 255, 255) ' // Light Cyan
CASE 13 : FUNCTION = BGR(255, 0, 0) ' // Light Red
CASE 14 : FUNCTION = BGR(255, 0, 255) ' // Light Magenta
CASE 15 : FUNCTION = BGR(255, 255, 0) ' // Yellow
CASE 16 : FUNCTION = BGR(255, 255, 255) ' // White
CASE 17
' // Display the ChooseColor dialog
IF dlg THEN
DIM cc AS CHOOSECOLORW
' // Size of the structure
cc.lStructSize = SIZEOF(cc)
' // Pointer to the custom defined gray color array
cc.lpCustColors = @m_rgColors(0)
cc.Flags = CC_RGBINIT OR CC_FULLOPEN
cc.hwndowner = hwnd
' // Allow the dialog to "auto-select" previously selected color
' // (only works for base colors, but still better than nothing)
cc.rgbResult = m_UserColor
IF .ChooseColorW(@cc) THEN
m_UserColor = cc.rgbResult
.InvalidateRect hwnd, NULL, 0
.UpdateWindow hWnd
END IF
END IF
' // Return the user selected color
FUNCTION = m_UserColor
END SELECT
END FUNCTION
' ========================================================================================
' ========================================================================================
' Gets/sets the RGB auto color
' ========================================================================================
PROPERTY CCbColor.AutoColor (BYVAL nColor AS COLORREF)
m_autoColor = nColor
END PROPERTY
' ========================================================================================
' ========================================================================================
PROPERTY CCbColor.AutoColor () AS COLORREF
PROPERTY = m_autoColor
END PROPERTY
' ========================================================================================
' Gets/sets the RGB user color
' ========================================================================================
PROPERTY CCbColor.UserColor (BYVAL nColor AS COLORREF)
m_autoColor = nColor
END PROPERTY
' ========================================================================================
' ========================================================================================
PROPERTY CCbColor.UserColor () AS COLORREF
PROPERTY = m_autoColor
END PROPERTY
' ========================================================================================
' ========================================================================================
' Get the selected color
' ========================================================================================
PROPERTY CCbColor.SelColor () AS COLORREF
DIM nSel AS LRESULT
nSel = SendMessageW(m_hCtl, CB_GETCURSEL, 0, 0)
IF nSel > CB_ERR THEN PROPERTY = this.GetQBColor(m_hCtl, nSel, 1)
END PROPERTY
' ========================================================================================
END NAMESPACE
Example:
' ########################################################################################
' Microsoft Windows
' File: CW_CbColor.fbtpl - Template
' Contents: Demonstrates the use of the Combobox color list control
' Compiler: FreeBasic 32 & 64 bit
' Copyright (c) 2016 Jose Roca. Freeware. Use at your own risk.
' THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
' EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE IMPLIED WARRANTIES OF
' MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
' ########################################################################################
#define unicode
#INCLUDE ONCE "windows.bi"
#INCLUDE ONCE "Afx/CWindow.inc"
#INCLUDE ONCE "Afx/CCbColor.inc"
' $FB_RESPATH = "FBRES.rc"
USING Afx.CWindowClass
USING Afx.CCbColorClass
CONST IDC_CBCOLOR = 1001
DECLARE FUNCTION WinMain (BYVAL hInstance AS HINSTANCE, _
BYVAL hPrevInstance AS HINSTANCE, _
BYVAL szCmdLine AS ZSTRING PTR, _
BYVAL nCmdShow AS LONG) AS LONG
END WinMain(GetModuleHandleW(""), NULL, COMMAND(), SW_NORMAL)
' ========================================================================================
' Window procedure
' ========================================================================================
FUNCTION WndProc (BYVAL hWnd AS HWND, BYVAL uMsg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM) AS LRESULT
SELECT CASE uMsg
CASE WM_COMMAND
SELECT CASE LOWORD(wParam)
' // If ESC key pressed, close the application sending an WM_CLOSE message
CASE IDCANCEL
IF HIWORD(wParam) = BN_CLICKED THEN
SendMessageW hwnd, WM_CLOSE, 0, 0
EXIT FUNCTION
END IF
CASE IDC_CBCOLOR
' // Get selected color
IF HIWORD(wParam) = CBN_SELENDOK THEN
SCOPE
DIM dwColor AS COLORREF
dwColor = SendMessageW(CAST(HWND, lParam), CBCOL_GETSELCOLOR, 0, 0)
' Alternate way
' DIM pCbColor AS CCbColor PTR = CAST(CCbColor PTR, GetPropW(CAST(HWND, lParam), "CBCOLORPTR"))
' IF pCbColor <> NULL THEN dwColor = pCbColor->SelColor
END SCOPE
END IF
END SELECT
' // Can't pass this message to the control because at the time
' // it is sent, the control has not yet been subclassed.
CASE WM_MEASUREITEM
SCOPE
IF wParam = IDC_CBCOLOR THEN
DIM pWindow AS CWindow PTR = CAST(CWindow PTR, GetWindowLongPtr(hwnd, 0))
DIM pMeasureItem AS MEASUREITEMSTRUCT PTR = CAST(MEASUREITEMSTRUCT PTR, lParam)
OutputDebugString "itemwidth = " & STR$(pMeasureItem->itemWidth)
OutputDebugString "itemheight = " & STR$(pMeasureItem->itemHeight)
pMeasureItem->itemHeight = pMeasureItem->itemHeight * (pWindow->rxRatio * 0.72)
FUNCTION = CTRUE
EXIT FUNCTION
END IF
END SCOPE
' // Must pass this one to the ownerdrawn combobox
CASE WM_DRAWITEM
IF wParam = IDC_CBCOLOR THEN
SendMessageW GetDlgItem(hwnd, wParam), uMsg, wParam, lParam
FUNCTION = CTRUE
EXIT FUNCTION
END IF
CASE WM_DESTROY
PostQuitMessage(0)
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProcW(hWnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS HINSTANCE, _
BYVAL hPrevInstance AS HINSTANCE, _
BYVAL szCmdLine AS ZSTRING PTR, _
BYVAL nCmdShow AS LONG) AS LONG
' // Set process DPI aware
AfxSetProcessDPIAware
DIM pWindow AS CWindow
pWindow.Create(NULL, "ComboBox color list", @WndProc, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT)
pWindow.Center
' // Add a color combobox control
DIM pCbColor AS CCbColor = CCbColor(@pWindow, IDC_CBCOLOR, 80, 30, 190, 100, _
GetSysColor(COLOR_WINDOWTEXT), GetSysColor(COLOR_WINDOWTEXT))
' // Select a color
SendMessageW pCbColor.hWindow, CB_SETCURSEL, 5, 0
FUNCTION = pWindow.DoEvents(nCmdShow)
END FUNCTION
' ========================================================================================
This version uses SetWindowClass for subclassing, which makes life easier as it allows to pass a pointer ro reference data to the subclass procedure. Here I'm passing a pointe to the class; thereforem no need to SET/GET properties.
' ########################################################################################
' Microsoft Windows
' File: CbColor.inc
' Contents: Combobox color list
' Based on the CBCOLOR control originally written by Börje Hagsten in 2001.
' Compiler: FreeBasic 32 & 64-bit
' Freeware. Use at your own risk.
' Copyright (c) 2016 Jose Roca. All Rights Reserved.
' THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
' EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE IMPLIED WARRANTIES OF
' MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
' ########################################################################################
#pragma once
#include once "windows.bi"
#include once "Afx/CWindow.inc"
#include once "win/commdlg.bi"
USING Afx.CWindowClass
NAMESPACE Afx.CCbColorClass
CONST CBCOL_SETAUTOCOLOR = WM_USER + 100
CONST CBCOL_SETUSERCOLOR = WM_USER + 101
CONST CBCOL_SETCOLORNAME = WM_USER + 102
CONST CBCOL_GETAUTOCOLOR = WM_USER + 200
CONST CBCOL_GETUSERCOLOR = WM_USER + 201
CONST CBCOL_GETSELCOLOR = WM_USER + 202
CONST CBCOL_GETCLASSPTR = WM_USER + 203
' ========================================================================================
' CCbColor class
' ========================================================================================
TYPE CCbColor
Protected:
m_hCtl AS HWND ' // Button handle
m_hFont AS HFONT ' // Font handle
Public:
m_autoColor AS COLORREF ' // Auto color
m_userColor AS COLORREF ' // User color
m_ratio AS SINGLE ' // DPI ratio - width
DIM m_rgColors(15) AS COLORREF
DIM m_rgNames (17) AS WSTRING * 20 = {"Auto", "Black", "Blue", "Green", "Cyan", "Red", _
"Magenta", "Brown", "Light Gray", "Gray", "Light Blue", "Light Green", "Light Cyan", _
"Light Red", "Light Magenta", "Yellow", "Bright White", "User selected..."}
DECLARE CONSTRUCTOR (BYVAL pWindow AS CWindow PTR, BYVAL cID AS INTEGER, _
BYVAL x AS LONG = 0, BYVAL y AS LONG = 0, BYVAL nWidth AS LONG = 0, BYVAL nHeight AS LONG = 0, _
BYVAL dwAutoColor AS COLORREF = 0, BYVAL dwUserColor AS COLORREF = 0)
DECLARE DESTRUCTOR
DECLARE FUNCTION hWindow () AS HWND
DECLARE FUNCTION GetQBColor (BYVAL hWnd AS HWND, BYVAL c AS LONG, BYVAL dlg AS LONG) AS COLORREF
DECLARE PROPERTY AutoColor (BYVAL nColor AS COLORREF)
DECLARE PROPERTY AutoColor () AS COLORREF
DECLARE PROPERTY UserColor (BYVAL nColor AS COLORREF)
DECLARE PROPERTY UserColor () AS COLORREF
DECLARE PROPERTY SelColor () AS COLORREF
END TYPE
' ========================================================================================
' ========================================================================================
' Subclassed window procedure
' ========================================================================================
FUNCTION CCbColorProc ( _
BYVAL hwnd AS HWND, _ ' // Control window handle
BYVAL uMsg AS UINT, _ ' // Type of message
BYVAL wParam AS WPARAM, _ ' // First message parameter
BYVAL lParam AS LPARAM, _ ' // Second message parameter
BYVAL uIdSubclass AS UINT_PTR, _ ' // The subclass ID
BYVAL dwRefData AS DWORD_PTR _ ' // Pointer to reference data
) AS LRESULT
DIM pCbColor AS CCbColor PTR
SELECT CASE uMsg
CASE WM_CREATE
EXIT FUNCTION
CASE WM_DESTROY
' // REQUIRED: Remove control subclassing
RemoveWindowSubclass hwnd, @CCbColorProc, uIdSubclass
EXIT FUNCTION
CASE WM_DRAWITEM
' // Get a pointer to the class
pCbColor = CAST(CCbColor PTR, dwRefData)
IF pCbColor = NULL THEN EXIT FUNCTION
SCOPE
DIM hBrush AS HBRUSH, wszText AS WSTRING * 80
DIM lpdis AS DRAWITEMSTRUCT PTR, rc AS RECT
lpdis = CAST(DRAWITEMSTRUCT PTR, lParam)
IF lpdis->itemID = &hFFFFFFFF THEN EXIT FUNCTION
SELECT CASE lpdis->itemAction
CASE ODA_DRAWENTIRE, ODA_SELECT
' // Clear background
FillRect lpdis->hDC, @lpdis->rcItem, .GetSysColorBrush(COLOR_WINDOW)
' // Get/draw text
.SendMessageW hwnd, CB_GETLBTEXT, lpdis->itemID, CAST(.LPARAM, @wszText)
.SetBkColor lpdis->hDC, GetSysColor(COLOR_WINDOW)
.SetTextColor lpdis->hDC, GetSysColor(COLOR_WINDOWTEXT)
rc = lpdis->rcItem
rc.Left = 28 * (pCbColor->m_ratio * 0.72)
.DrawTextW lpdis->hDC, @wszText, LEN(wszText), @rc, DT_SINGLELINE OR DT_LEFT OR DT_VCENTER
' // If selected item...
IF (lpdis->itemState AND ODS_SELECTED) THEN
' // If not ODS_COMBOBOXEDIT...
IF (lpdis->itemState AND ODS_COMBOBOXEDIT) = 0 THEN
' // Set coordinates
rc.Left = 26 * (pCbColor->m_ratio * 0.72)
rc.Right = lpdis->rcItem.Right
rc.Top = lpdis->rcItem.Top
rc.Bottom = lpdis->rcItem.Bottom
' // Invert area around text only
.InvertRect lpdis->hDC, @rc
END IF
' // and draw a focus rectangle around all
.DrawFocusRect lpdis->hDC, @lpdis->rcItem
END IF
' // Paint color rectangle using RoundRect for nicer looks
' /// If ODS_COMBOBOXEDIT...
IF (lpdis->itemState AND ODS_COMBOBOXEDIT) THEN
' // Set coordinates
rc.Left = 4 * (pCbColor->m_ratio * 0.72)
rc.Right = 24 * (pCbColor->m_ratio * 0.72)
ELSE
' // A tiny bit to the left in list...
rc.Left = 3 * (pCbColor->m_ratio * 0.72)
rc.Right = 23 * (pCbColor->m_ratio * 0.72)
END IF
rc.Top = (lpdis->rcItem.Top + (2 * pCbColor->m_ratio))
rc.Bottom = (lpdis->rcItem.Bottom - (2 * pCbColor->m_ratio))
' // Create brush with the appropriate color
hBrush = .CreateSolidBrush(pCbColor->GetQBColor(hWnd, lpdis->itemID, FALSE))
' // Select brush into device context
hBrush = .SelectObject(lpdis->hDC, hBrush)
' // Draw the rectangle
DIM nCorner AS LONG = pCbColor->m_ratio * 0.72
.RoundRect(lpdis->hDC, rc.Left, rc.Top, rc.Right, rc.Bottom, nCorner, nCorner)
' // Select old brush back and delete new one
.DeleteObject .SelectObject(lpdis->hDC, hBrush)
END SELECT
END SCOPE
FUNCTION = CTRUE
EXIT FUNCTION
' // Returns the class pointer
CASE CBCOL_GETCLASSPTR
FUNCTION = dwRefData
EXIT FUNCTION
' // Set auto color
CASE CBCOL_SETAUTOCOLOR
pCbColor = CAST(CCbColor PTR, dwRefData)
IF pCbColor = NULL THEN EXIT FUNCTION
pCbColor->m_AutoColor = wParam
EXIT FUNCTION
' // Set auto color
CASE CBCOL_GETAUTOCOLOR
pCbColor = CAST(CCbColor PTR, dwRefData)
IF pCbColor = NULL THEN EXIT FUNCTION
FUNCTION = pCbColor->m_AutoColor
EXIT FUNCTION
' // Set user color
CASE CBCOL_SETUSERCOLOR
pCbColor = CAST(CCbColor PTR, dwRefData)
IF pCbColor = NULL THEN EXIT FUNCTION
FUNCTION = pCbColor->m_UserColor
EXIT FUNCTION
' // Get user color
CASE CBCOL_GETUSERCOLOR
pCbColor = CAST(CCbColor PTR, dwRefData)
IF pCbColor = NULL THEN EXIT FUNCTION
FUNCTION = pCbColor->m_UserColor
EXIT FUNCTION
' // Return selected color
CASE CBCOL_GETSELCOLOR
DIM nRes AS LONG
nRes = SendMessageW(hwnd, CB_GETCURSEL, 0, 0)
pCbColor = CAST(CCbColor PTR, dwRefData)
IF pCbColor = NULL THEN EXIT FUNCTION
IF nRes > CB_ERR THEN
FUNCTION = pCbColor->GetQBColor(hwnd, nRes, CTRUE)
END IF
EXIT FUNCTION
END SELECT
' // Default processing for other messages
FUNCTION = DefSubclassProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
' ========================================================================================
' CPgBar3D class constructor
' ========================================================================================
CONSTRUCTOR CCbColor (BYVAL pWindow AS CWindow PTR, BYVAL cID AS INTEGER, _
BYVAL x AS LONG = 0, BYVAL y AS LONG = 0, BYVAL nWidth AS LONG = 0, BYVAL nHeight AS LONG = 0, _
BYVAL dwAutoColor AS COLORREF = 0, BYVAL dwUserColor AS COLORREF = 0)
' // Create the control
IF pWindow THEN
m_hCtl = pWindow->AddControl("COMBOBOX", pWindow->hWindow, cID, "", _
x, y, nWidth, nHeight, WS_CHILD OR WS_VISIBLE OR CBS_OWNERDRAWFIXED OR CBS_HASSTRINGS OR _
CBS_DROPDOWNLIST OR WS_TABSTOP OR CBS_DISABLENOSCROLL OR WS_VSCROLL, WS_EX_CLIENTEDGE, _
NULL, CAST(WNDPROC, @CCbColorProc), cID, CAST(DWORD_PTR, @this))
m_ratio = pWindow->rxRatio
END IF
IF m_hCtl THEN
' // Set the same font used by the parent
DIM lfw AS LOGFONTW
IF pWindow->Font THEN
IF GetObjectW(pWindow->Font, SIZEOF(lfw), @lfw) THEN m_hFont = CreateFontIndirect(@lfw)
END IF
' // Add the strings
DIM i AS LONG
FOR i = 0 TO UBOUND(m_rgNames)
SendMessageW m_hCtl, CB_ADDSTRING, 0, CAST(LPARAM, @m_rgNames(i))
NEXT
' // Store default values (usually COLOR_WINDOW or COLOR_WINDOWTEXT)
m_AutoColor = dwAutoColor
m_UserColor = dwUserColor
' // Create initial colormap for the ChooseColor dialog
DIM cl AS LONG
FOR i = 1 TO 16
cl = i * 16 - 1
m_rgColors(16 - i) = BGR(cl, cl, cl)
NEXT
END IF
END CONSTRUCTOR
' ========================================================================================
' ========================================================================================
' CPgBar3D class destructor
' ========================================================================================
DESTRUCTOR CCbColor
' // Free resources
IF m_hFont THEN DeleteObject m_hFont
END DESTRUCTOR
' ========================================================================================
' ========================================================================================
' Returns the handle of the button
' ========================================================================================
FUNCTION CCbColor.hWindow () AS HWND
FUNCTION = m_hCtl
END FUNCTION
' ========================================================================================
' ========================================================================================
' Basic QB color function.
' ========================================================================================
FUNCTION CCbColor.GetQBColor (BYVAL hwnd AS HWND, BYVAL c AS LONG, BYVAL dlg AS LONG) AS COLORREF
SELECT CASE c
CASE 0 : FUNCTION = m_AutoColor ' // Pre-set system color, like COLOR_WINDOW or COLOR_WINDOWTEXT
CASE 1 : FUNCTION = BGR(0, 0, 0) ' // Black
CASE 2 : FUNCTION = BGR(0, 0, 128) ' // Blue
CASE 3 : FUNCTION = BGR(0, 128, 0) ' // Green
CASE 4 : FUNCTION = BGR(0, 128, 128) ' // Cyan
CASE 5 : FUNCTION = BGR(196, 0, 0) ' // Red
CASE 6 : FUNCTION = BGR(128, 0, 128) ' // Magenta
CASE 7 : FUNCTION = BGR(128, 64, 0) ' // Brown
CASE 8 : FUNCTION = BGR(196, 196, 196) ' // Light Gray
CASE 9 : FUNCTION = BGR(128, 128, 128) ' // Gray
CASE 10 : FUNCTION = BGR(0, 0, 255) ' // Light Blue
CASE 11 : FUNCTION = BGR(0, 255, 0) ' // Light Green
CASE 12 : FUNCTION = BGR(0, 255, 255) ' // Light Cyan
CASE 13 : FUNCTION = BGR(255, 0, 0) ' // Light Red
CASE 14 : FUNCTION = BGR(255, 0, 255) ' // Light Magenta
CASE 15 : FUNCTION = BGR(255, 255, 0) ' // Yellow
CASE 16 : FUNCTION = BGR(255, 255, 255) ' // White
CASE 17
' // Display the ChooseColor dialog
IF dlg THEN
DIM cc AS CHOOSECOLORW
' // Size of the structure
cc.lStructSize = SIZEOF(cc)
' // Pointer to the custom defined gray color array
cc.lpCustColors = @m_rgColors(0)
cc.Flags = CC_RGBINIT OR CC_FULLOPEN
cc.hwndowner = hwnd
' // Allow the dialog to "auto-select" previously selected color
' // (only works for base colors, but still better than nothing)
cc.rgbResult = m_UserColor
IF .ChooseColorW(@cc) THEN
m_UserColor = cc.rgbResult
.InvalidateRect hwnd, NULL, 0
.UpdateWindow hWnd
END IF
END IF
' // Return the user selected color
FUNCTION = m_UserColor
END SELECT
END FUNCTION
' ========================================================================================
' ========================================================================================
' Gets/sets the RGB auto color
' ========================================================================================
PROPERTY CCbColor.AutoColor (BYVAL nColor AS COLORREF)
m_autoColor = nColor
END PROPERTY
' ========================================================================================
' ========================================================================================
PROPERTY CCbColor.AutoColor () AS COLORREF
PROPERTY = m_autoColor
END PROPERTY
' ========================================================================================
' Gets/sets the RGB user color
' ========================================================================================
PROPERTY CCbColor.UserColor (BYVAL nColor AS COLORREF)
m_autoColor = nColor
END PROPERTY
' ========================================================================================
' ========================================================================================
PROPERTY CCbColor.UserColor () AS COLORREF
PROPERTY = m_autoColor
END PROPERTY
' ========================================================================================
' ========================================================================================
' Get the selected color
' ========================================================================================
PROPERTY CCbColor.SelColor () AS COLORREF
DIM nSel AS LRESULT
nSel = SendMessageW(m_hCtl, CB_GETCURSEL, 0, 0)
IF nSel > CB_ERR THEN PROPERTY = this.GetQBColor(m_hCtl, nSel, 1)
END PROPERTY
' ========================================================================================
END NAMESPACE
This example demonstrates the use of the CbColorEx control.
' ########################################################################################
' Microsoft Windows
' File: CW_CbColorEx.fbtpl - Template
' Contents: Demonstrates the use of the Combobox color list control
' Compiler: FreeBasic 32 & 64 bit
' Copyright (c) 2016 Jose Roca. Freeware. Use at your own risk.
' THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
' EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE IMPLIED WARRANTIES OF
' MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
' ########################################################################################
#define unicode
#INCLUDE ONCE "windows.bi"
#INCLUDE ONCE "Afx/CWindow.inc"
#INCLUDE ONCE "Afx/CCbColorEx.inc"
' $FB_RESPATH = "FBRES.rc"
USING Afx.CWindowClass
USING Afx.CCbColorClass
CONST IDC_CBCOLOR = 1001
DECLARE FUNCTION WinMain (BYVAL hInstance AS HINSTANCE, _
BYVAL hPrevInstance AS HINSTANCE, _
BYVAL szCmdLine AS ZSTRING PTR, _
BYVAL nCmdShow AS LONG) AS LONG
END WinMain(GetModuleHandleW(""), NULL, COMMAND(), SW_NORMAL)
' ========================================================================================
' Window procedure
' ========================================================================================
FUNCTION WndProc (BYVAL hWnd AS HWND, BYVAL uMsg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM) AS LRESULT
SELECT CASE uMsg
CASE WM_COMMAND
SELECT CASE LOWORD(wParam)
' // If ESC key pressed, close the application sending an WM_CLOSE message
CASE IDCANCEL
IF HIWORD(wParam) = BN_CLICKED THEN
SendMessageW hwnd, WM_CLOSE, 0, 0
EXIT FUNCTION
END IF
CASE IDC_CBCOLOR
' // Get selected color
IF HIWORD(wParam) = CBN_SELENDOK THEN
SCOPE
DIM dwColor AS COLORREF
dwColor = SendMessageW(CAST(HWND, lParam), CBCOL_GETSELCOLOR, 0, 0)
' Alternate way
' DIM pCbColor AS CCbColor PTR = CAST(CCbColor PTR, SendMessageW(CAST(HWND, lParam), CBCOL_GETCLASSPTR, 0, 0))
' IF pCbColor <> NULL THEN dwColor = pCbColor->SelColor
END SCOPE
END IF
END SELECT
' // Can't pass this message to the control because at the time
' // it is sent, the control has not yet been subclassed.
CASE WM_MEASUREITEM
SCOPE
IF wParam = IDC_CBCOLOR THEN
DIM pWindow AS CWindow PTR = CAST(CWindow PTR, GetWindowLongPtr(hwnd, 0))
DIM pMeasureItem AS MEASUREITEMSTRUCT PTR = CAST(MEASUREITEMSTRUCT PTR, lParam)
pMeasureItem->itemHeight = pMeasureItem->itemHeight * (pWindow->rxRatio * 0.72)
FUNCTION = CTRUE
EXIT FUNCTION
END IF
END SCOPE
' // Must pass this one to the ownerdrawn combobox
CASE WM_DRAWITEM
IF wParam = IDC_CBCOLOR THEN
SendMessageW GetDlgItem(hwnd, wParam), uMsg, wParam, lParam
FUNCTION = CTRUE
EXIT FUNCTION
END IF
CASE WM_DESTROY
PostQuitMessage(0)
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProcW(hWnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS HINSTANCE, _
BYVAL hPrevInstance AS HINSTANCE, _
BYVAL szCmdLine AS ZSTRING PTR, _
BYVAL nCmdShow AS LONG) AS LONG
' // Set process DPI aware
AfxSetProcessDPIAware
DIM pWindow AS CWindow
pWindow.Create(NULL, "ComboBox color list", @WndProc, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT)
pWindow.Center
' // Add a color combobox control
DIM pCbColor AS CCbColor = CCbColor(@pWindow, IDC_CBCOLOR, 80, 30, 190, 100, _
GetSysColor(COLOR_WINDOWTEXT), GetSysColor(COLOR_WINDOWTEXT))
' // Select a color
SendMessageW pCbColor.hWindow, CB_SETCURSEL, 5, 0
FUNCTION = pWindow.DoEvents(nCmdShow)
END FUNCTION
' ========================================================================================
Hi Jose,
I expect dkl to fix the problems in the windowsx.bi soon as he has already replied to my posting in the FB forum. I have been working with other macros in that file and I have noticed a fair number of problems with the translation. I have manually made the changes to my copy of windowsx.bi for now as I await a new official copy. I have also been testing the use of message crackers and dedicated message handlers. I realize that you are not overly fond of that approach but I do like it especially for very large applications where it better promotes modularity. Just for fun, below is working code shows how your splitbutton.bas code can be modified to use the crackers. It gives me more of a feel of how Firefly separates messages into individual handlers.
' //
' // Process WM_CREATE message for window/dialog: main
' //
Function main_OnCreate(ByVal HWnd As HWnd, ByVal lpCreateStructPtr As LPCREATESTRUCT) As BOOLEAN
' Message cracker macro expects a True to be returned for a successful
' OnCreate handler even though returning -1 from a standard WM_CREATE
' call would stop creating the window. This is just one of those Windows
' inconsistencies.
Return True
End Function
' //
' // Process WM_SIZE message for window/dialog: main
' //
Function main_OnSize(ByVal HWnd As HWnd, ByVal state As UINT, ByVal cx As Long, ByVal cy As Long) As LRESULT
Dim pWindow As CWindow Ptr
If state <> SIZE_MINIMIZED Then
' // Resize the button
pWindow = Cast(CWindow Ptr, GetWindowLongPtr(HWnd, 0))
pWindow->MoveWindow GetDlgItem(HWnd, IDCANCEL), pWindow->ClientWidth - 200, pWindow->ClientHeight - 90, 110, 23, CTRUE
End If
Function = 0
End Function
' //
' // Process WM_COMMAND message for window/dialog: main
' //
Function main_OnCommand(ByVal HWnd As HWnd, ByVal id As Long, ByVal hwndCtl As HWnd, ByVal codeNotify As UINT) As LRESULT
Select Case id
Case IDCANCEL
' If ESC key pressed, close the application sending an WM_CLOSE message
If codeNotify = BN_CLICKED Then
SendMessage HWnd, WM_CLOSE, 0, 0
End If
End Select
Function = 0
End Function
' //
' // Process WM_NOTIFY message for window/dialog: main
' //
Function main_OnNotify(ByVal HWnd As HWnd, ByVal id As Long, ByVal pNMHDR As NMHDR Ptr) As LRESULT
' Processs notify messages sent by the split button
'Dim pNmh As NMHDR Ptr = Cast(NMHDR Ptr, lParam)
If pNMHDR->idFrom = IDCANCEL And pNMHDR->code = BCN_DROPDOWN Then
Dim pDropDown As NMBCDROPDOWN Ptr = Cast(NMBCDROPDOWN Ptr, pNMHDR)
' // Get screen coordinates of the button
Dim pt As Point = (pDropdown->rcButton.Left, pDropDown->rcButton.bottom)
ClientToScreen(pNMHDR->hwndFrom, @pt)
' // Create a menu and add items
Dim hSplitMenu As HMENU = CreatePopupMenu
AppendMenuW(hSplitMenu, MF_BYPOSITION, IDC_MENUCOMMAND1, "Menu item 1")
AppendMenuW(hSplitMenu, MF_BYPOSITION, IDC_MENUCOMMAND2, "Menu item 2")
' // Display the menu
TrackPopupMenu(hSplitMenu, TPM_LEFTALIGN Or TPM_TOPALIGN, pt.x, pt.y, 0, HWnd, Null)
Return CTRUE
Exit Function
End If
Function = 0
End Function
' //
' // Process WM_DESTROY message for window/dialog: main
' //
Function main_OnDestroy(HWnd As HWnd) As LRESULT
ImageList_Destroy Cast(HIMAGELIST, SendMessageW(GetDlgItem(HWnd, IDCANCEL), TB_SETIMAGELIST, 0, 0))
PostQuitMessage(0)
Function = 0
End Function
' ========================================================================================
' Window procedure
' ========================================================================================
Function WndProc (ByVal HWnd As HWnd, ByVal uMsg As UINT, ByVal wParam As WPARAM, ByVal lParam As LPARAM) As LRESULT
Select Case uMsg
HANDLE_MSG (HWnd, WM_CREATE, main_OnCreate)
HANDLE_MSG (HWnd, WM_SIZE, main_OnSize)
HANDLE_MSG (HWnd, WM_DESTROY, main_OnDestroy)
HANDLE_MSG (HWnd, WM_COMMAND, main_OnCommand)
HANDLE_MSG (HWnd, WM_NOTIFY, main_OnNotify)
End Select
' for messages that we don't deal with
Function = DefWindowProcW(HWnd, uMsg, wParam, lParam)
End Function
' ========================================================================================
Hi Jose,
I am also curious as to why you are specifically using the "W" version of the api calls? From what I can see, once you define UNICODE then the "W" version of the message will be used.
For example, in winuser.bi for SendMessage:
declare function SendMessageA(byval hWnd as HWND, byval Msg as UINT, byval wParam as WPARAM, byval lParam as LPARAM) as LRESULT
#ifndef UNICODE
declare function SendMessage alias "SendMessageA"(byval hWnd as HWND, byval Msg as UINT, byval wParam as WPARAM, byval lParam as LPARAM) as LRESULT
#endif
declare function SendMessageW(byval hWnd as HWND, byval Msg as UINT, byval wParam as WPARAM, byval lParam as LPARAM) as LRESULT
#ifdef UNICODE
declare function SendMessage alias "SendMessageW"(byval hWnd as HWND, byval Msg as UINT, byval wParam as WPARAM, byval lParam as LPARAM) as LRESULT
#endif
Maybe it is just your personal preference?
It is a way to make sure that the code will work even if the user does not define UNICODE, since all the code I'm writing is unicode aware.
The existence of the "A" and "W" functions was to ease the transition to unicode while keeping support for legacy applications. The version 6 of the common controls is unicode only. If you use SendMessageA instead of SendMessageW, Windows has to check if the target window is Unicode aware, convert the strings to unicode and call SendMessageW.
I would be happy removing all the "A" stuff from the headers.
Hi Paul,
I'm having a problem.
If I have a global array, pass a pointer of a similar array to a procedure, how can I copy the contents of the passed array to the global array?
DIM m_rgNames (17) AS WSTRING * 20 = {"Auto", "Black", "Blue", "Green", "Cyan", "Red", _
"Magenta", "Brown", "Light Gray", "Gray", "Light Blue", "Light Green", "Light Cyan", _
"Light Red", "Light Magenta", "Yellow", "Bright White", "User selected..."}
SUB Foo2 (BYVAL prgNames AS WSTRING PTR, BYVAL numElements AS DWORD)
DIM i AS LONG
FOR i = 0 TO numElements - 1
... How to copy the contents of the array pointed by prgNames to m_rgNames
NEXT
END SUB
SUB Foo
DIM rgNames (17) AS WSTRING * 20 = {"Auto", "Negro", "Azul", "Verde", "Cian", "Rojo", _
"Magenta", "Marrón", "Gris claro", "Gris", "Azul claro", "Verde claro", "Cian claro", _
"Rojo claro", "Magenta claro", "Amarillo", "Blanco", "Selección libre..."}
Foo @rgNames(0), 18
END SUB
That is an interesting problem. I thought that it would be as simple as passing the array into Foo2 and have it copy to the global array element by element but when I print out the results the data is incorrect. You pass arrays to subs/functions without using BYVAL or BYREF. That is just a historical quirk in FB.
Not sure why it is not working. I will keep trying.
Dim Shared m_rgNames(17) As WString * 20 => {"Auto", "Black", "Blue", "Green", "Cyan", "Red", _
"Magenta", "Brown", "Light Gray", "Gray", "Light Blue", "Light Green", "Light Cyan", _
"Light Red", "Light Magenta", "Yellow", "Bright White", "User selected..."}
Sub Foo2 ( prgNames() As WString * 20, ByVal numElements As Long)
Dim i As Long
For i = 0 To numElements - 1
'... How To copy the contents of the array pointed by prgNames To m_rgNames
m_rgNames(i) = prgNames(i)
Next
End Sub
Sub Foo
Dim rgNames(17) As WString * 20 => {"Auto", "Negro", "Azul", "Verde", "Cian", "Rojo", _
"Magenta", "Marrón", "Gris claro", "Gris", "Azul claro", "Verde claro", "Cian claro", _
"Rojo claro", "Magenta claro", "Amarillo", "Blanco", "Selección libre..."}
Foo2( rgNames(), 18 )
End Sub
' call Foo to initiate the copying of rgNames to global array via sub Foo2
Foo
Dim i As Long
For i = 0 To 17
Print m_rgNames(i)
Next
Sleep
> I have also been testing the use of message crackers and dedicated message handlers.
For what I see, these aren't needed in CWindow or the custom controls. You can freely use them in your code if you like. Am I right?
Well, of course there are other ways, even faster, for the array problem. Just wanted to know how to do it using FB statements.
I have changed the numElements parameter for numBytes and use:
' // Color names
IF prgNames <> NULL AND numBytes < (18 * 20 * 2) + 1 THEN
.memcpy @m_rgNames(0), prgNames, numBytes
END IF
When calling it, I pass:
@rgNames(0), 18 * 20 * 2
With pointers we can do everything, but little error checking.
I needed that to be able to use languages other than English for the color names. Being an optional parameter, I have to use a pointer.
' ########################################################################################
' Microsoft Windows
' File: CW_CbColorEx.fbtpl - Template
' Contents: Demonstrates the use of the Combobox color list control
' Compiler: FreeBasic 32 & 64 bit
' Copyright (c) 2016 Jose Roca. Freeware. Use at your own risk.
' THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
' EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE IMPLIED WARRANTIES OF
' MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
' ########################################################################################
#define unicode
#INCLUDE ONCE "windows.bi"
#INCLUDE ONCE "Afx/CWindow.inc"
#INCLUDE ONCE "Afx/CCbColorEx.inc"
' $FB_RESPATH = "FBRES.rc"
USING Afx.CWindowClass
USING Afx.CCbColorClass
CONST IDC_CBCOLOR = 1001
DECLARE FUNCTION WinMain (BYVAL hInstance AS HINSTANCE, _
BYVAL hPrevInstance AS HINSTANCE, _
BYVAL szCmdLine AS ZSTRING PTR, _
BYVAL nCmdShow AS LONG) AS LONG
END WinMain(GetModuleHandleW(""), NULL, COMMAND(), SW_NORMAL)
' ========================================================================================
' Window procedure
' ========================================================================================
FUNCTION WndProc (BYVAL hWnd AS HWND, BYVAL uMsg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM) AS LRESULT
SELECT CASE uMsg
CASE WM_COMMAND
SELECT CASE LOWORD(wParam)
' // If ESC key pressed, close the application sending an WM_CLOSE message
CASE IDCANCEL
IF HIWORD(wParam) = BN_CLICKED THEN
SendMessageW hwnd, WM_CLOSE, 0, 0
EXIT FUNCTION
END IF
CASE IDC_CBCOLOR
' // Get selected color
IF HIWORD(wParam) = CBN_SELENDOK THEN
SCOPE
DIM dwColor AS COLORREF
dwColor = SendMessageW(CAST(HWND, lParam), CBCOL_GETSELCOLOR, 0, 0)
' Alternate way
' DIM pCbColor AS CCbColor PTR = CAST(CCbColor PTR, SendMessageW(CAST(HWND, lParam), CBCOL_GETCLASSPTR, 0, 0))
' IF pCbColor <> NULL THEN dwColor = pCbColor->SelColor
END SCOPE
END IF
END SELECT
' // Can't pass this message to the control because at the time
' // it is sent, the control has not yet been subclassed.
CASE WM_MEASUREITEM
SCOPE
IF wParam = IDC_CBCOLOR THEN
DIM pWindow AS CWindow PTR = CAST(CWindow PTR, GetWindowLongPtr(hwnd, 0))
DIM pMeasureItem AS MEASUREITEMSTRUCT PTR = CAST(MEASUREITEMSTRUCT PTR, lParam)
pMeasureItem->itemHeight = pMeasureItem->itemHeight * (pWindow->rxRatio * 0.72)
FUNCTION = CTRUE
EXIT FUNCTION
END IF
END SCOPE
' // Must pass this one to the ownerdrawn combobox
CASE WM_DRAWITEM
IF wParam = IDC_CBCOLOR THEN
SendMessageW GetDlgItem(hwnd, wParam), uMsg, wParam, lParam
FUNCTION = CTRUE
EXIT FUNCTION
END IF
CASE WM_DESTROY
PostQuitMessage(0)
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProcW(hWnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS HINSTANCE, _
BYVAL hPrevInstance AS HINSTANCE, _
BYVAL szCmdLine AS ZSTRING PTR, _
BYVAL nCmdShow AS LONG) AS LONG
' // Set process DPI aware
AfxSetProcessDPIAware
DIM pWindow AS CWindow
pWindow.Create(NULL, "ComboBox color list", @WndProc, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT)
pWindow.Center
DIM rgNames (17) AS WSTRING * 20 = {"Auto", "Negro", "Azul", "Verde", "Cian", "Rojo", _
"Magenta", "Marrón", "Gris claro", "Gris", "Azul claro", "Verde claro", "Cian claro", _
"Rojo claro", "Magenta claro", "Amarillo", "Blanco", "Selección libre..."}
' // Add a color combobox control
DIM pCbColor AS CCbColor = CCbColor(@pWindow, IDC_CBCOLOR, 80, 30, 190, 100, _
GetSysColor(COLOR_WINDOWTEXT), GetSysColor(COLOR_WINDOWTEXT), @rgNames(0), 18 * 20 * 2)
' // Select a color
SendMessageW pCbColor.hWindow, CB_SETCURSEL, 5, 0
FUNCTION = pWindow.DoEvents(nCmdShow)
END FUNCTION
' ========================================================================================
Yeah, there must be a way to do it with traditional FB statements rather than pointers and copying memory. I will keep plugging away at it. If i can't figure it out then I will post over on FB forum.
Quote from: Jose Roca on May 04, 2016, 06:55:27 PM
> I have also been testing the use of message crackers and dedicated message handlers.
For what I see, these aren't needed in CWindow or the custom controls. You can freely use them in your code if you like. Am I right?
Yes, you are right.
No problem then. I understand is usefulness for a visual designer, to no overwrite the message processing in the window procedure, but when coding by hand as I always do, when there is code that is going to be too long you simply put it in a procedure and call it. A manual and selective way of message cracking.
I have to recheck all the code removing #define unicode. Even calling the W function, something like this LoadCursorW(NULL, IDC_ARROW) compiles fine using #define unicode and reports an error if not. I will have to add more CASTs.
Well, looks like that one was the only that needed a change.
Just a little FYI for you in case you don't know.... In FB if you ever want to see the exact code that will be compile (macros expanded, etc) then just pass -pp to the compiler. It will create an intermediate file with ".pp" appended to it. It can be quite useful sometimes.
I posted that array passing and copying issue over on the FB forum. I am very curious as to why it does not work.
http://www.freebasic.net/forum/viewtopic.php?f=6&t=24667
Thanks for the tip and the support. I have run several test programs removing the unicode define and the only problems that have found are LoadCursorW in CWindows, and a CreateFontIndirect (I forgot to add the "W") in the XpButton and PgBar3D controls.
Will write all the upcoming code without #define unicode to avoid these failures.
FYI,
fxm responded to the fixed WSTRING array issue: http://www.freebasic.net/forum/viewtopic.php?f=6&t=24667#p219838
It is a known problem.
Hi Jose,
Looking at the examples that you have posted, I see that you use GetModuleHandle with an empty string for the parameter. This seems to always return 0 indicating an error. I read the api docs and I think you are better off using Null instead of an empty string?
https://msdn.microsoft.com/en-us/library/windows/desktop/ms683199(v=vs.85).aspx
End WinMain(GetModuleHandleW(Null), Null, Command(), SW_NORMAL)
Using Null, I am getting a value returned for the hInstance.
Thanks very much. I will remember it.
Hi Paul,
I have read that unused Private procedures are removed by the compiler.
> fbc already removes unused private procedures/variables, but that's pretty much it.
See: http://www.freebasic.net/forum/viewtopic.php?t=23405
Could be this a solution to write wrapper procedures without adding bloat?
It works!
I wonder why they don't explain it in the documentation.
Another oddity.
This works:
DIM tbb AS TBBUTTON = (idxBitmap, idCommand, fsState, fsStyle, {0, 0, 0, 0, 0, 0}, dwData, idxString)
But this one gives Error 7: Expected ')'
DIM tbb AS TBBUTTON
tbb = (idxBitmap, idCommand, fsState, fsStyle, {0, 0, 0, 0, 0, 0}, dwData, idxString)
Quote from: Jose Roca on May 05, 2016, 04:48:57 PM
Another oddity.
This works:
DIM tbb AS TBBUTTON = (idxBitmap, idCommand, fsState, fsStyle, {0, 0, 0, 0, 0, 0}, dwData, idxString)
But this one gives Error 7: Expected ')'
DIM tbb AS TBBUTTON
tbb = (idxBitmap, idCommand, fsState, fsStyle, {0, 0, 0, 0, 0, 0}, dwData, idxString)
More than likely it has to do with the code generation of each compiler version. By default, FBC 32bit outputs ASM code that is then compiled by the GNU assembler. FBC 64bit defaults to outputting C code that is then compiled with gcc (llvm eventually will be fully supported).
You can see the intermediate code generated (ASM or C) when you specify the -r command line option for the compiler.
Sorry, but you have misunderstood me.
This one works both in 32 and 64 bit:
#ifdef __FB_64BIT__
DIM tbb AS TBBUTTON = (idxBitmap, idCommand, fsState, fsStyle, {0, 0, 0, 0, 0, 0}, dwData, idxString)
#else
DIM tbb AS TBBUTTON = (idxBitmap, idCommand, fsState, fsStyle, {0, 0}, dwData, idxString)
#endif
But if I dim tbb separately and then I try to do the assignment, it fails:
#ifdef __FB_64BIT__
DIM tbb AS TBBUTTON
tbb = (idxBitmap, idCommand, fsState, fsStyle, {0, 0, 0, 0, 0, 0}, dwData, idxString)
#else
DIM tbb AS TBBUTTON
tbb = (idxBitmap, idCommand, fsState, fsStyle, {0, 0}, dwData, idxString)
#endif
Ah yes, probably because in the first case it is treated as a type/class initializer (constructor) whereas in the second case it is just a simple assignment.
Is RC5 good enough now to create a full application with? Tomorrow I was going to try to create a new application somewhat similar to this one: http://www.codeproject.com/Articles/4948/Message-Cracker-Wizard-for-Win-SDK-Developers
I was going to use that application to see if I encounter any issues with RC5.
Yes, it is.
Anyway, the attached file contains the latest version. I only have removed a couple of auxiliary functions to add toolbar buttons because now that I have discovered that declaring the procedure PRIVATE unused procedures are not included in the code. Therefore, I'm going to adapt my PowerBASIC wrappers to FB.
Jose, have you tried creating an accelerator table yet? I tried but it looks like there may be a problem.
' Create the accelerator table for the menu
pWindow->AddAccelerator( FNOINVERT Or FVIRTKEY Or FALT, VK_F4, IDM_EXIT )
pWindow->AddAccelerator( FNOINVERT Or FVIRTKEY Or FCONTROL, VK_M, IDM_COPYMACRO )
pWindow->AddAccelerator( FNOINVERT Or FVIRTKEY Or FCONTROL, VK_F, IDM_COPYFUNCTION )
pWindow->AddAccelerator( FNOINVERT Or FVIRTKEY Or FCONTROL, VK_L, IDM_MSGFILTERS )
pWindow->CreateAcceleratorTable()
I think that it might have to do with ReDim'ing of the m_rgAccelEntries() type array. The ubound does not increase between calls to AddAccelerator.
I am investigating the code now.
Looks you made a typo in your Type definition for the m_rgAccelEntries array in the CWindow definition (CWindow.inc)
You used HACCEL and it should be ACCEL
Dim m_rgAccelEntries(Any) As ACCEL
You're right. The only features that I haven't yet tested are accelerator keys and the BITMAP/ICON LABEL, BITMAP/ICON BUTTON.
Now that I know that unused private procedures aren't included in the code, I'm going to begin to write useful wrappers. For Common Controls, since there are already a lot of defines in Windowsx.bi and commctrl.bi, I will only write the ones that require lenghty code instead of a call to SendMessage.
I have begin with the ones related with DPI:
' ########################################################################################
' *** DPI RELATED PROCEDURES ***
' ########################################################################################
' ========================================================================================
' Sets the current process as dots per inch (dpi) aware.
' Note: SetProcessDPIAware is subject to a possible race condition if a DLL caches dpi
' settings during initialization. For this reason, it is recommended that dpi-aware be set
' through the application (.exe) manifest rather than by calling SetProcessDPIAware.
' Return value: TRUE on success; FALSE on failure.
' ========================================================================================
PRIVATE FUNCTION AfxSetProcessDPIAware () AS BOOLEAN
DIM AS ANY PTR pLib = DyLibLoad("user32.dll")
IF pLib = 0 THEN EXIT FUNCTION
DIM pProc AS FUNCTION () AS LONG
pProc = DyLibSymbol(pLib, "SetProcessDPIAware")
IF pProc = 0 THEN EXIT FUNCTION
FUNCTION = pProc()
DyLibFree(pLib)
END FUNCTION
' ========================================================================================
' ========================================================================================
' Determines whether the current process is dots per inch (dpi) aware such that it adjusts
' the sizes of UI elements to compensate for the dpi setting.
' Return value: TRUE or FALSE
' ========================================================================================
PRIVATE FUNCTION AfxIsProcessDPIAware () AS BOOLEAN
DIM AS ANY PTR pLib = DyLibLoad("user32.dll")
IF pLib = 0 THEN EXIT FUNCTION
DIM pProc AS FUNCTION () AS LONG
pProc = DyLibSymbol(pLib, "IsProcessDPIAware")
IF pProc = 0 THEN EXIT FUNCTION
FUNCTION = pProc()
DyLibFree(pLib)
END FUNCTION
' ========================================================================================
' ========================================================================================
' Retrieves the value of the UseDpiScaling setting (Vista/Windows 7+).
' Returns TRUE if the OS uses DPI scaling; FALSE otherwise.
' ========================================================================================
PRIVATE FUNCTION AfxUseDpiScaling () AS BOOLEAN
DIM hkRes AS HKEY, dwType AS DWORD, dwData AS DWORD, cbData AS DWORD
IF RegOpenKeyExW(HKEY_CURRENT_USER, "Software\Microsoft\Windows\DWM", 0, KEY_QUERY_VALUE, @hkRes) = ERROR_SUCCESS THEN
IF hkRes THEN
cbData = SIZEOF(cbData)
DIM hr AS LONG = RegQueryValueExW(hkRes, "UseDpiScaling", 0, @dwType, CPTR(BYTE PTR, @dwData), @cbData)
RegCloseKey hkRes
IF hr = ERROR_SUCCESS THEN FUNCTION = (dwData <> 0)
END IF
END IF
END FUNCTION
' ========================================================================================
' ========================================================================================
' Retrieves the number of pixels per logical inch along the screen width of the desktop
' window. In a system with multiple display monitors, this value is the same for all monitors.
' ========================================================================================
PRIVATE FUNCTION AfxLogPixelsX () AS LONG
DIM hDC AS HDC = GetDC(HWND_DESKTOP)
DIM dpiX AS LONG = GetDeviceCaps(hDC, LOGPIXELSX)
ReleaseDC HWND_DESKTOP, hDC
FUNCTION = dpiX
END FUNCTION
' ========================================================================================
' ========================================================================================
' Retrieves the number of pixels per logical inch along the screen height of the desktop
' window. In a system with multiple display monitors, this value is the same for all monitors.
' ========================================================================================
PRIVATE FUNCTION AfxLogPixelsY () AS LONG
DIM hDC AS HDC = GetDC(HWND_DESKTOP)
DIM dpiY AS LONG = GetDeviceCaps(hDC, LOGPIXELSY)
ReleaseDC HWND_DESKTOP, hDC
FUNCTION = dpiY
END FUNCTION
' ========================================================================================
' ========================================================================================
' Retrieves the desktop horizontal scaling ratio.
' ========================================================================================
PRIVATE FUNCTION AfxScaleRatioX () AS SINGLE
DIM hDC AS HDC = GetDC(HWND_DESKTOP)
DIM rxRatio AS SINGLE = (GetDeviceCaps(hDC, LOGPIXELSX) / 96)
ReleaseDC HWND_DESKTOP, hDC
FUNCTION = rxRatio
END FUNCTION
' ========================================================================================
' ========================================================================================
' Retrieves the desktop vertical scaling ratio.
' ========================================================================================
PRIVATE FUNCTION AfxScaleRatioY () AS SINGLE
DIM hDC AS HDC = GetDC(HWND_DESKTOP)
DIM ryRatio AS SINGLE = (GetDeviceCaps(hDC, LOGPIXELSY) / 96)
ReleaseDC HWND_DESKTOP, hDC
FUNCTION = ryRatio
END FUNCTION
' ========================================================================================
' ========================================================================================
' Scales an horizontal coordinate according the DPI (dots per pixel) being used by the desktop.
' ========================================================================================
PRIVATE FUNCTION AfxScaleX (BYVAL cx AS SINGLE) AS SINGLE
DIM hDC AS HDC = GetDC(HWND_DESKTOP)
FUNCTION = cx * (GetDeviceCaps(hDC, LOGPIXELSX) / 96)
ReleaseDC HWND_DESKTOP, hDC
END FUNCTION
' ========================================================================================
' ========================================================================================
' Scales a vertical coordinate according the DPI (dots per pixel) being used by the desktop.
' ========================================================================================
PRIVATE FUNCTION AfxScaleY (BYVAL cy AS SINGLE) AS SINGLE
DIM hDC AS HDC = GetDC(HWND_DESKTOP)
FUNCTION = cy * (GetDeviceCaps(hDC, LOGPIXELSY) / 96)
ReleaseDC HWND_DESKTOP, hDC
END FUNCTION
' ========================================================================================
' ========================================================================================
' Unscales an horizontal coordinate according the DPI (dots per pixel) being used by the desktop.
' ========================================================================================
PRIVATE FUNCTION AfxUnscaleX (BYVAL cx AS SINGLE) AS SINGLE
DIM hDC AS HDC = GetDC(HWND_DESKTOP)
FUNCTION = cx / (GetDeviceCaps(hDC, LOGPIXELSX) / 96)
ReleaseDC HWND_DESKTOP, hDC
END FUNCTION
' ========================================================================================
' ========================================================================================
' Unscales a vertical coordinate according the DPI (dots per pixel) being used by the desktop.
' ========================================================================================
PRIVATE FUNCTION AfxUnscaleY (BYVAL cy AS SINGLE) AS SINGLE
DIM hDC AS HDC = GetDC(HWND_DESKTOP)
FUNCTION = cy / (GetDeviceCaps(hDC, LOGPIXELSY) / 96)
ReleaseDC HWND_DESKTOP, hDC
END FUNCTION
' ========================================================================================
' ========================================================================================
' Determines if screen resolution meets minimum requirements.
' Parameters:
' - cxMin = Minimum screen resolution width in pixels.
' - cxMin = Minimum screen resolution height in pixels.
' Return value: TRUE or FALSE.
' ========================================================================================
PRIVATE FUNCTION AfxIsResolutionAtLeast (BYVAL cxMin AS LONG, BYVAL cyMin AS LONG) AS BOOLEAN
DIM ScreenWidth AS LONG = GetSystemMetrics(SM_CXSCREEN)
DIM ScreenHeight AS LONG = GetSystemMetrics(SM_CYSCREEN)
IF (cxMin <= ScreenWidth) AND (cyMin <= ScreenHeight) THEN FUNCTION = TRUE
END FUNCTION
' ========================================================================================
' ========================================================================================
' Determines if screen resolution meets minimum requirements in relative pixels,
' e.g. for a screen resolution of 1920x1080 pixels and a DPI of 192 (scaling ratio = 2),
' the maximum relative pixels for a DPI aware application is 960x540.
' - cxMin = Minimum screen resolution width in relative pixels.
' - cxMin = Minimum screen resolution height in relative pixels.
' Return value: TRUE or FALSE.
' ========================================================================================
PRIVATE FUNCTION AfxIsDPIResolutionAtLeast (BYVAL cxMin AS LONG, BYVAL cyMin AS LONG) AS BOOLEAN
' // Get de DPI values used by the desktop window
DIM hDC AS HDC = GetDC(HWND_DESKTOP)
DIM dpiX AS LONG = GetDeviceCaps(hDC, LOGPIXELSX)
DIM dpiY AS LONG = GetDeviceCaps(hDC, LOGPIXELSY)
ReleaseDC HWND_DESKTOP, hDC
' // Scale the values
cxMin = cxMin * dpiX / 96
cyMin = cyMin * dpiX / 96
' // Calculate the width and height of the primary display monitor, in pixels
DIM ScreenWidth AS LONG = GetSystemMetrics(SM_CXSCREEN)
DIM ScreenHeight AS LONG = GetSystemMetrics(SM_CYSCREEN)
IF (cxMin <= ScreenWidth) AND (cyMin <= ScreenHeight) THEN FUNCTION = TRUE
END FUNCTION
' ========================================================================================
For GDI+, I will add functions that deal with bitmaps and a function that loads textures suitable to be used with OPENGL.
For the ones that need COM, i first have to translate some headers.
We could do it faster it we had betatesters.
Metric conversions.
' ########################################################################################
' *** METRIC CONVERSIONS ***
' ########################################################################################
' ========================================================================================
' Converts from HiMetric to Pixels
' Note: HiMetric is a scaling unit similar to twips used in computing. It is one
' thousandth of a centimeter and is independent of the screen resolution.
' HiMetric per inch = 2540 ' 1 inch = 2.54 mm
' ========================================================================================
' Horizontal resolution
PRIVATE FUNCTION AfxHiMetricToPixelsX (BYVAL hm AS LONG) AS LONG
DIM hDC AS HDC = GetDC(HWND_DESKTOP)
DIM nPixelsPerLogicalInchX AS LONG = GetDeviceCaps(hDC, LOGPIXELSX)
ReleaseDC(HWND_DESKTOP, hDC)
FUNCTION = MulDiv(hm, nPixelsPerLogicalInchX, 2540)
END FUNCTION
' ========================================================================================
' Vertical resolution
PRIVATE FUNCTION AfxHiMetricToPixelsY (BYVAL hm AS LONG) AS LONG
DIM hDC AS HDC = GetDC(HWND_DESKTOP)
DIM nPixelsPerLogicalInchY AS LONG = GetDeviceCaps(hDC, LOGPIXELSY)
ReleaseDC(HWND_DESKTOP, hDC)
FUNCTION = MulDiv(hm, nPixelsPerLogicalInchY, 2540)
END FUNCTION
' ========================================================================================
' ========================================================================================
' Converts from Pixels to HiMetric
' Note: HiMetric is a scaling unit similar to twips used in computing. It is one
' thousandth of a centimeter and is independent of the screen resolution.
' HiMetric per inch = 2540 ' 1 inch = 2.54 mm
' ========================================================================================
' Horizontal resolution
PRIVATE FUNCTION AfxPixelsToHiMetricX (BYVAL cx AS LONG) AS LONG
DIM hDC AS HDC = GetDC(HWND_DESKTOP)
DIM nPixelsPerLogicalInchX AS LONG = GetDeviceCaps(hDC, LOGPIXELSX)
ReleaseDC(HWND_DESKTOP, hDC)
FUNCTION = MulDiv(cx, 2540, nPixelsPerLogicalInchX)
END FUNCTION
' ========================================================================================
' Vertical resolution
PRIVATE FUNCTION AfxPixelsToHiMetricY (BYVAL cy AS LONG) AS LONG
DIM hDC AS HDC = GetDC(HWND_DESKTOP)
DIM nPixelsPerLogicalInchY AS LONG = GetDeviceCaps(hDC, LOGPIXELSY)
ReleaseDC(HWND_DESKTOP, hDC)
FUNCTION = MulDiv(cy, 2540, nPixelsPerLogicalInchY)
END FUNCTION
' ========================================================================================
' ========================================================================================
' Converts pixels to point size (1/72 of an inch).
' ========================================================================================
' Horizontal resolution
PRIVATE FUNCTION AfxPixelsToPointsX (BYVAL pix AS LONG) AS LONG
DIM hDC AS HDC = GetDC(HWND_DESKTOP)
DIM LPX AS LONG = GetDeviceCaps(hDC, LOGPIXELSX)
ReleaseDC(HWND_DESKTOP, hDC)
FUNCTION = pix * 72 / LPX
END FUNCTION
' ========================================================================================
' Vertical resolution
PRIVATE FUNCTION AfxPixelsToPointsY (BYVAL pix AS LONG) AS LONG
DIM hDC AS HDC = GetDC(HWND_DESKTOP)
DIM LPY AS LONG = GetDeviceCaps(hDC, LOGPIXELSY)
ReleaseDC(HWND_DESKTOP, hDC)
FUNCTION = pix * 72 / LPY
END FUNCTION
' ========================================================================================
' ========================================================================================
' Converts a point size (1/72 of an inch) to pixels. Horizontal resolution.
' ========================================================================================
' Horizontal resolution
PRIVATE FUNCTION AfxPointsToPixelsX (BYVAL pts AS LONG) AS LONG
DIM hDC AS HDC = GetDC(HWND_DESKTOP)
DIM LPX AS LONG = GetDeviceCaps(hDC, LOGPIXELSX)
ReleaseDC(HWND_DESKTOP, hDC)
FUNCTION = MulDiv(pts, LPX, 72)
END FUNCTION
' ========================================================================================
' Vertical resolution
PRIVATE FUNCTION AfxPointsToPixelsY (BYVAL pts AS LONG) AS LONG
DIM hDC AS HDC = GetDC(HWND_DESKTOP)
DIM LPY AS LONG = GetDeviceCaps(hDC, LOGPIXELSY)
ReleaseDC(HWND_DESKTOP, hDC)
FUNCTION = MulDiv(pts, LPY, 72)
END FUNCTION
' ========================================================================================
' ========================================================================================
' Converts pixels to twips.
' Twips are screen-independent units to ensure that the proportion of screen elements are
' the same on all display systems. A twip is defined as being 1/1440 of an inch.
' ========================================================================================
' Horizontal resolution
PRIVATE FUNCTION AfxPixelsToTwipsX (BYVAL nPixels AS LONG) AS LONG
DIM hDC AS HDC = GetDC(HWND_DESKTOP)
DIM LPX AS LONG = GetDeviceCaps(hDC, LOGPIXELSX)
ReleaseDC(HWND_DESKTOP, hDC)
FUNCTION = (nPixels * 1440) / LPX
END FUNCTION
' ========================================================================================
' Vertical resolution.
PRIVATE FUNCTION AfxPixelsToTwipsY (BYVAL nPixels AS LONG) AS LONG
DIM hDC AS HDC = GetDC(HWND_DESKTOP)
DIM LPY AS LONG = GetDeviceCaps(hDC, LOGPIXELSY)
ReleaseDC(HWND_DESKTOP, hDC)
FUNCTION = (nPixels * 1440) / LPY
END FUNCTION
' ========================================================================================
' ========================================================================================
' Converts twips to pixels.
' Twips are screen-independent units to ensure that the proportion of screen elements are
' the same on all display systems. A twip is defined as being 1/1440 of an inch.
' ========================================================================================
' Horizontal resolution
PRIVATE FUNCTION AfxTwipsToPixelsX (BYVAL nTwips AS LONG) AS LONG
DIM hDC AS HDC = GetDC(HWND_DESKTOP)
DIM LPX AS LONG = GetDeviceCaps(hDC, LOGPIXELSX)
ReleaseDC(HWND_DESKTOP, hDC)
FUNCTION = (nTwips / 1440) * LPX
END FUNCTION
' ========================================================================================
' Vertical resolution
PRIVATE FUNCTION AfxTwipsToPixelsY (BYVAL nTwips AS LONG) AS LONG
DIM hDC AS HDC = GetDC(HWND_DESKTOP)
DIM LPY AS LONG = GetDeviceCaps(hDC, LOGPIXELSY)
ReleaseDC(HWND_DESKTOP, hDC)
FUNCTION = (nTwips / 1440) * LPY
END FUNCTION
' ========================================================================================
' ========================================================================================
' Returns the width of a pixel, in twips.
' Pixel dimensions can vary between systems and may not always be square, so separate
' functions for pixel width and height are required.
' ========================================================================================
' Horizontal resolution
PRIVATE FUNCTION AfxTwipsPerPixelX () AS LONG
DIM hDC AS HDC = GetDC(HWND_DESKTOP)
DIM LPX AS LONG = GetDeviceCaps(hDC, LOGPIXELSX)
ReleaseDC(HWND_DESKTOP, hDC)
FUNCTION = 1440 / LPX
END FUNCTION
' ========================================================================================
' Vertical resolution
PRIVATE FUNCTION AfxTwipsPerPixelY () AS LONG
DIM hDC AS HDC = GetDC(HWND_DESKTOP)
DIM LPY AS LONG = GetDeviceCaps(hDC, LOGPIXELSY)
ReleaseDC(HWND_DESKTOP, hDC)
FUNCTION = 1440 / LPY
END FUNCTION
' ========================================================================================
An additional one:
' ========================================================================================
' Converts point size to DIP (device independent pixel).
' DIP is defined as 1/96 of an inch and a point is 1/72 of an inch.
' ========================================================================================
FUNCTION AfxPointSizeToDip (BYVAL ptsize AS SINGLE) AS SINGLE
FUNCTION = (ptsize / 72) * 96
END FUNCTION
' ========================================================================================
Quote from: Jose Roca on May 06, 2016, 03:09:50 PM
We could do it faster it we had beta testers.
I totally agree. ;)
I am writing my first application with your code. Pretty straight forward so far. I can say that I totally HATE having to position controls via code :-) It reminds me of the days when I first bought PB and had to hand code DDT. Certainly makes me appreciate FireFly for the visual positioning of controls.
I will continue to report any issues that I encounter. The keyboard accelerators was the only one so far but it is all working now.
Clipboard functions:
' ########################################################################################
' *** CLIPBOARD ***
' ########################################################################################
' ========================================================================================
' Clears the contents of the clipboard.
' Return Value
' If the function succeeds, the return value is nonzero.
' If the function fails, the return value is zero.
' ========================================================================================
PRIVATE FUNCTION AfxClearClipboard () AS LONG
' // Opens the clipboard
IF OpenClipboard(NULL) <> 0 THEN
' // Empties the clipboard
FUNCTION = EmptyClipboard
' // Closes the clipboard
CloseClipboard
END IF
END FUNCTION
' ========================================================================================
' ========================================================================================
' Retrieves data from the clipboard in the specified format.
' Parameter
' cfFormat = Clipboard format.
' Return Value
' If the function succeeds, the return value is the handle to the data.
' If the function fails, the return value is NULL.
' ========================================================================================
PRIVATE FUNCTION AfxGetClipboardData (BYVAL cfFormat AS DWORD) AS HGLOBAL
DIM hSource AS HANDLE
' // Opens the clipboard
IF OpenClipboard(NULL) <> 0 THEN
' // Retrieves data from the clipboard in the specified format
hSource = GetClipboardData(cfFormat)
' // Closes the clipboard
CloseClipboard
' // Exits on failure
IF hSource = NULL THEN EXIT FUNCTION
END IF
' // Gets the size of the specified global memory object, in bytes
DIM dwSize AS SIZE_T_ = GlobalSize(hSource)
' // Exits on failure
IF dwSize = 0 THEN EXIT FUNCTION
' // Gets a pointer to the source memory object
DIM pSource AS LPVOID = GlobalLock(hSource)
' // Exits on failure
IF pSource = NULL THEN EXIT FUNCTION
' // Allocates the specified number of bytes from the heap
DIM hDest AS HGLOBAL = GlobalAlloc(GHND_, dwSize)
' // Exits on failure
IF hDest = NULL THEN
' // Unlocks the source memory object
GlobalUnlock hSource
EXIT FUNCTION
END IF
' // Gets a pointer to the destination memory object
DIM pDest AS LPVOID = GlobalLock(hDest)
' // Exits on failure
IF pDest = NULL THEN
' // Unlocks the source memory object
GlobalUnlock hSource
' // Frees the allocated memory block
GlobalFree hDest
EXIT FUNCTION
END IF
' // Copies the data from the source to the destination
memcpy pDest, pSource, dwSize
' // Unlocks the source memory object
GlobalUnlock hSource
' // Unlocks the destination memory object
GlobalUnlock hDest
' // Returns the handle to the data
FUNCTION = hDest
END FUNCTION
' ========================================================================================
' ========================================================================================
' Places a data object into the clipboard.
' Parameters
' cfFormat = Clipboard format.
' hData = Handle to the data in the specified format.
' Return Value
' If the function succeeds, the return value is the handle to the data.
' If the function fails, the return value is NULL.
' Remarks
' The application must not use the hData handle once it has called the AfxSetClipboardData function.
' ========================================================================================
PRIVATE FUNCTION AfxSetClipboardData (BYVAL cfFormat AS DWORD, BYVAL hData AS HANDLE) AS HANDLE
' // Opens the clipboard
IF OpenClipboard(NULL) <> 0 THEN
' // Empties the clipboard
EmptyClipboard
' // Places the data object in the clipboard
FUNCTION = SetClipboardData(cfFormat, hData)
' // Closes the clipboard
CloseClipboard
END IF
END FUNCTION
' ========================================================================================
' ========================================================================================
' Returns a text string from the clipboard.
' ========================================================================================
PRIVATE FUNCTION AfxGetClipboardTextA () AS STRING
' // If the text format is available...
IF IsClipboardFormatAvailable(CF_TEXT) <> 0 THEN
' // Opens the clipboard
IF OpenClipboard(NULL) <> 0 THEN
' // Gets memory object of clipboard text
DIM hMem AS HANDLE = GetClipboardData(CF_TEXT)
IF hMem <> NULL THEN
' // Locks it and get a pointer
DIM pMem AS HGLOBAL = GlobalLock(hMem)
' // Assigns the data to our function return value
IF pMem <> NULL THEN FUNCTION = *CAST(ZSTRING PTR, pMem)
' // Releases the memory object
GlobalUnlock hMem
END IF
' // Closes the clipboard
CloseClipboard
END IF
END IF
END FUNCTION
' ========================================================================================
' ========================================================================================
' Returns a unicode text string from the clipboard.
' Usage:
' DIM pwsz AS WSTRING PTR
' pwsz = AfxGetClipboardTextW
' MessageBoxW 0, *pwsz, "", MB_OK
' IF pwsz THEN Delete(pwsz)
' ========================================================================================
PRIVATE FUNCTION AfxGetClipboardTextW () AS WSTRING PTR
' // If the text format is available...
IF IsClipboardFormatAvailable(CF_UNICODETEXT) <> 0 THEN
' // Opens the clipboard
IF OpenClipboard(NULL) <> 0 THEN
' // Gets memory object of clipboard text
DIM hMem AS HANDLE = GetClipboardData(CF_UNICODETEXT)
IF hMem <> NULL THEN
' // Locks it and get a pointer
DIM pMem AS HGLOBAL = GlobalLock(hMem)
' // Assigns the data to our function return value
IF pMem <> NULL THEN
' // Gets the size of the global lock
DIM dwSize AS DWORD = GlobalSize(hMem)
IF dwSize > 0 THEN
' // Allocates a buffer and copies the contents of the clipboard to it
DIM pBuffer AS WSTRING PTR = CAllocate(dwSize, 1)
memcpy(pBuffer, pMem, dwSize)
FUNCTION = pBuffer
END IF
END IF
' // Releases the memory object
GlobalUnlock hMem
END IF
' // Closes the clipboard
CloseClipboard
END IF
END IF
END FUNCTION
' ========================================================================================
#ifdef UNICODE
#define AfxGetClipboardText AfxGetClipboardTextW
#else
#define AfxGetClipboardText AfxGetClipboardTextA
#endif
' ========================================================================================
' Places a text string into the clipboard.
' Parameter
' strText = Text to place in the clipboard.
' Return Value
' If the function succeeds, the return value is the handle to the data.
' If the function fails, the return value is NULL.
' ========================================================================================
PRIVATE FUNCTION AfxSetClipboardTextA (BYVAL strText AS STRING) AS HANDLE
' // Opens the clipboard
IF OpenClipboard(NULL) <> 0 THEN
' // Empties the clipboard
EmptyClipboard
' // Allocates a global memory block
DIM hMem AS HGLOBAL = GlobalAlloc(GMEM_MOVEABLE OR GMEM_DDESHARE, LEN(strText) + 1)
IF hMem <> NULL THEN
' // Locks it and gets a pointer to the memory location
DIM pMem AS LPVOID = GlobalLock(hMem)
' // Copies the text into the allocated memory block
IF pMem <> NULL THEN *CAST(ZSTRING PTR, pMem) = strText & CHR(0)
' // Unlocks the memory block
GlobalUnlock hMem
' // Places the text in the clipboard
DIM hData AS HANDLE = SetClipboardData(CF_TEXT, hMem)
IF hData <> NULL THEN
' // Returns the handle of the data
FUNCTION = hData
ELSE
' // Frees the memory block
GlobalFree hMem
END IF
END IF
' // Closes the clipboard
CloseClipboard
END IF
END FUNCTION
' ========================================================================================
' ========================================================================================
' Places a unicode text string into the clipboard.
' Parameter
' wszText = Text to place in the clipboard.
' Return Value
' If the function succeeds, the return value is the handle to the data.
' If the function fails, the return value is NULL.
' ========================================================================================
PRIVATE FUNCTION AfxSetClipboardTextW (BYREF wszText AS WSTRING) AS HANDLE
' // Opens the clipboard
IF OpenClipboard(NULL) <> 0 THEN
' // Empties the clipboard
EmptyClipboard
' // Allocates a global memory block
DIM hMem AS HGLOBAL = GlobalAlloc(GMEM_MOVEABLE OR GMEM_DDESHARE, (LEN(wszText) + 1) * 2)
IF hMem <> NULL THEN
' // Locks it and gets a pointer to the memory location
DIM pMem AS LPVOID = GlobalLock(hMem)
' // Copies the text into the allocated memory block
IF pMem <> NULL THEN *CAST(WSTRING PTR, pMem) = wszText & CHR(0, 0)
' // Unlocks the memory block
GlobalUnlock hMem
' // Places the text in the clipboard
DIM hData AS HANDLE = SetClipboardData(CF_UNICODETEXT, hMem)
IF hData <> NULL THEN
' // Returns the handle of the data
FUNCTION = hData
ELSE
' // Frees the memory block
GlobalFree hMem
END IF
END IF
' // Closes the clipboard
CloseClipboard
END IF
END FUNCTION
' ========================================================================================
#ifdef UNICODE
#define AfxSetClipboardText AfxSetClipboardTextW
#else
#define AfxSetClipboardText AfxSetClipboardTextA
#endif
Quote
I am writing my first application with your code. Pretty straight forward so far. I can say that I totally HATE having to position controls via code :-) It reminds me of the days when I first bought PB and had to hand code DDT.
I did not use FireFly for PB because it was not unicode aware.
I also like to code by hand because I don't write many applications and mostly of my code is testing code. If I'm doing all this work it is because I like to investigate and experiment. It is more fun than playing cards with other retirees.
I only have a monitor, so I can't test this one:
' ========================================================================================
' If you use dual (or even triple/quad) displays then you have undoubtedly encountered the
' following situation: You change the physical order of your displays, or otherwise
' reconfigure the logical ordering using your display software. This sometimes has the
' side-effect of changing your desktop coordinates from zero-based to negative starting
' coordinates (i.e. the top-left coordinate of your desktop changes from 0,0 to -1024,-768).
' This effects many Windows programs which restore their last on-screen position whenever
' they are started. Should the user reorder their display configuration this can sometimes
' result in a Windows program subsequently starting in an off-screen position (i.e. at a
' location that used to be visible) - and is now effectively invisible, preventing the
' user from closing it down or otherwise moving it back on-screen.
' The ForceVisibleDisplay function can be called at program start-time right after the
' main window has been created and positioned 'on-screen'. Should the window be positioned
' in an off-screen position, it is forced back onto the nearest display to its last
' position. The user will be unaware this is happening and won't even realise to thank you
' for keeping their user-interface visible, even though they changed their display
' settings.
' Source: http://www.catch22.net/tuts/tips2
' ========================================================================================
PRIVATE SUB AfxForceVisibleDisplay (BYVAL hwnd AS HWND)
' // Check if the specified window-recrangle is visible on any display
DIM rc AS RECT
GetWindowRect(hwnd, @rc)
IF MonitorFromRect(@rc, MONITOR_DEFAULTTONULL) <> NULL THEN EXIT SUB
' // Find the nearest display to the rectangle
DIM hMonitor AS HMONITOR
DIM mi AS MONITORINFO
mi.cbSize = SIZEOF(mi)
hMonitor = MonitorFromRect(@rc, MONITOR_DEFAULTTONEAREST)
GetMonitorInfoW(hMonitor, @mi)
' // Center window rectangle
rc.left = mi.rcWork.left + ((mi.rcWork.right - mi.rcWork.left) - (rc.right-rc.left)) \ 2
rc.top = mi.rcWork.top + ((mi.rcWork.bottom - mi.rcWork.top) - (rc.bottom-rc.top)) \ 2
SetWindowPos(hwnd, 0, rc.left, rc.top, 0, 0, SWP_NOACTIVATE OR SWP_NOZORDER OR SWP_NOSIZE)
END SUB
' ========================================================================================
This one has revealed a problem that I was having. If I use DIM hwndForeground AS HWND, the compiler gives an error, but if I use DIM hwndForeground AS .HWND, it compiles fine.
Therefore, in CWindow I have changed
#ifdef USEMDI
' // Note: I have needed to use HANDLE instead of HWND; otherwise, the compiler
' // gives error 14: Branch crossing local variable definition. Don't know why.
STATIC hwndClient AS HANDLE ' // Handle of the MDI client window
DIM hwndActive AS HANDLE ' // Active window
DIM hMdi AS HANDLE ' // MDI child window handle
' // MDI client window handle
IF hwndClient = NULL AND pWindow <> NULL THEN hwndClient = pWindow->hwndClient
#endif
to
#ifdef USEMDI
STATIC hwndClient AS .HWND ' // Handle of the MDI client window
DIM hwndActive AS .HWND ' // Active window
DIM hMdi AS HANDLE ' // MDI child window handle
' // MDI client window handle
IF hwndClient = NULL AND pWindow <> NULL THEN hwndClient = pWindow->hwndClient
#endif
' ========================================================================================
' Brings the thread that created the specified window into the foreground and activates
' the window. Keyboard input is directed to the window, and various visual cues are changed
' for the user. The system assigns a slightly higher priority to the thread that created
' the foreground window than it does to other threads.
' Replacement for the SetForegroundWindow API function, that sometimes fails.
' ========================================================================================
SUB AfxForceSetForegroundWindow (BYVAL hwnd AS HWND)
DIM dwProcessId AS DWORD
DIM hwndForeground AS .HWND = GetForegroundWindow
DIM dwThreadId AS DWORD = GetWindowThreadProcessId(hwndForeground, @dwProcessId)
DIM dwCurThreadId AS DWORD = GetCurrentThreadId
AttachThreadInput(dwCurThreadId, dwThreadId, CTRUE)
SetForegroundWindow(hwnd)
BringWindowToTop(hwnd)
SetFocus(hwnd)
AttachThreadInput(dwCurThreadId, dwThreadId, FALSE)
END SUB
' ========================================================================================
Menu wrapper functions.
' ########################################################################################
' *** MENU ***
' ########################################################################################
' ========================================================================================
' Checks a menu item.
' - hMenu = A handle to the menu that contains the menu item.
' - uItem = The identifier or position of the menu item to get information about.
' The meaning of this parameter depends on the value of fByPosition.
' - fByPosition = The meaning of uItem. If this parameter is FALSE, uItem is a menu item
' identifier. Otherwise, it is a menu item position.
' Return Value: The return value specifies the previous state of the menu item (either
' MF_CHECKED or MF_UNCHECKED). If the menu item does not exist, the return value is -1.
' ========================================================================================
PRIVATE FUNCTION AfxCheckMenuItem (BYVAL hMenu AS HMENU, BYVAL uItem AS DWORD, BYVAL fByPosition AS LONG = FALSE) AS DWORD
DIM dwFlags AS DWORD
IF fByPosition THEN dwFlags = MF_BYPOSITION ELSE dwFlags = MF_BYCOMMAND
dwFlags = dwFlags OR MF_CHECKED
FUNCTION = CheckMenuItem(hMenu, uItem, dwFlags)
END FUNCTION
' ========================================================================================
' ========================================================================================
' Unchecks a menu item.
' - hMenu = A handle to the menu that contains the menu item.
' - uItem = The identifier or position of the menu item to get information about.
' The meaning of this parameter depends on the value of fByPosition.
' - fByPosition = The meaning of uItem. If this parameter is FALSE, uItem is a menu item
' identifier. Otherwise, it is a menu item position.
' Return Value: The return value specifies the previous state of the menu item (either
' MF_CHECKED or MF_UNCHECKED). If the menu item does not exist, the return value is -1.
' ========================================================================================
PRIVATE FUNCTION AfxUnCheckMenuItem (BYVAL hMenu AS HMENU, BYVAL uItem AS DWORD, BYVAL fByPosition AS LONG = FALSE) AS DWORD
DIM dwFlags AS DWORD
IF fByPosition THEN dwFlags = MF_BYPOSITION ELSE dwFlags = MF_BYCOMMAND
dwFlags = dwFlags OR MF_UNCHECKED
FUNCTION = CheckMenuItem(hMenu, uItem, dwFlags)
END FUNCTION
' ========================================================================================
' ========================================================================================
' Toggles the checked state of a menu item.
' ========================================================================================
PRIVATE FUNCTION ToggleMenuItem (BYVAL hMenu AS HMENU, BYVAL uItem AS DWORD, BYVAL fByPosition AS LONG = FALSE) AS DWORD
DIM dwFlags AS DWORD
IF fByPosition THEN dwFlags = MF_BYPOSITION ELSE dwFlags = MF_BYCOMMAND
IF GetMenuState(hMenu, uItem, dwFlags) AND MF_CHECKED = MF_CHECKED THEN
dwFlags = dwFlags OR MF_UNCHECKED
ELSE
dwFlags = dwFlags OR MF_CHECKED
END IF
FUNCTION = CheckMenuItem(hMenu, uItem, dwFlags)
END FUNCTION
' ========================================================================================
' ========================================================================================
' Returns TRUE if the specified menu item is checked; FALSE otherwise.
' ========================================================================================
PRIVATE FUNCTION AfxIsMenuItemChecked (BYVAL hMenu AS HMENU, BYVAL uItem AS DWORD, BYVAL fByPosition AS LONG = FALSE) AS BOOLEAN
DIM dwFlags AS DWORD
IF fByPosition THEN dwFlags = MF_BYPOSITION ELSE dwFlags = MF_BYCOMMAND
IF GetMenuState(hMenu, uItem, dwFlags) AND MF_CHECKED = MF_CHECKED THEN FUNCTION = TRUE
END FUNCTION
' ========================================================================================
' ========================================================================================
' Returns TRUE if the specified menu item is enabled; FALSE otherwise.
' ========================================================================================
PRIVATE FUNCTION AfxIsMenuItemEnabled (BYVAL hMenu AS HMENU, BYVAL uItem AS DWORD, BYVAL fByPosition AS LONG = FALSE) AS BOOLEAN
DIM dwFlags AS DWORD
IF fByPosition THEN dwFlags = MF_BYPOSITION ELSE dwFlags = MF_BYCOMMAND
DIM dwRes AS DWORD = GetMenuState(hMenu, uItem, dwFlags)
IF ((dwRes AND MF_DISABLED) <> MF_DISABLED) AND ((dwRes AND MF_GRAYED) <> MF_GRAYED) THEN FUNCTION = TRUE
END FUNCTION
' ========================================================================================
' ========================================================================================
' Returns TRUE if the specified menu item is disabled; FALSE otherwise.
' ========================================================================================
PRIVATE FUNCTION AfxIsMenuItemDisabled (BYVAL hMenu AS HMENU, BYVAL uItem AS DWORD, BYVAL fByPosition AS LONG = FALSE) AS BOOLEAN
DIM dwFlags AS DWORD
IF fByPosition THEN dwFlags = MF_BYPOSITION ELSE dwFlags = MF_BYCOMMAND
DIM dwRes AS DWORD = GetMenuState(hMenu, uItem, dwFlags)
IF ((dwRes AND MF_DISABLED) = MF_DISABLED) THEN FUNCTION = TRUE
END FUNCTION
' ========================================================================================
' ========================================================================================
' Returns TRUE if the specified menu item is grayed; FALSE otherwise.
' ========================================================================================
PRIVATE FUNCTION AfxIsMenuItemGrayed (BYVAL hMenu AS HMENU, BYVAL uItem AS DWORD, BYVAL fByPosition AS LONG = FALSE) AS BOOLEAN
DIM dwFlags AS DWORD
IF fByPosition THEN dwFlags = MF_BYPOSITION ELSE dwFlags = MF_BYCOMMAND
DIM dwRes AS DWORD = GetMenuState(hMenu, uItem, dwFlags)
IF ((dwRes AND MF_GRAYED) = MF_GRAYED) THEN FUNCTION = TRUE
END FUNCTION
' ========================================================================================
' ========================================================================================
' Returns TRUE if the specified menu item is highlighted; FALSE otherwise.
' ========================================================================================
PRIVATE FUNCTION AfxIsMenuItemHighlighted (BYVAL hMenu AS HMENU, BYVAL uItem AS DWORD, BYVAL fByPosition AS LONG = FALSE) AS BOOLEAN
DIM dwFlags AS DWORD
IF fByPosition THEN dwFlags = MF_BYPOSITION ELSE dwFlags = MF_BYCOMMAND
DIM dwRes AS DWORD = GetMenuState(hMenu, uItem, dwFlags)
IF ((dwRes AND MF_HILITE) = MF_HILITE) THEN FUNCTION = TRUE
END FUNCTION
' ========================================================================================
' ========================================================================================
' Returns TRUE if the specified menu item is a separator; FALSE otherwise.
' ========================================================================================
PRIVATE FUNCTION AfxIsMenuItemSeparator (BYVAL hMenu AS HMENU, BYVAL uItem AS DWORD, BYVAL fByPosition AS LONG = FALSE) AS BOOLEAN
DIM dwFlags AS DWORD
IF fByPosition THEN dwFlags = MF_BYPOSITION ELSE dwFlags = MF_BYCOMMAND
DIM dwRes AS DWORD = GetMenuState(hMenu, uItem, dwFlags)
IF ((dwRes AND MF_SEPARATOR) = MF_SEPARATOR) THEN FUNCTION = TRUE
END FUNCTION
' ========================================================================================
' ========================================================================================
' Returns TRUE if the specified menu item is a submenu; FALSE otherwise.
' ========================================================================================
PRIVATE FUNCTION AfxIsMenuItemPopup (BYVAL hMenu AS HMENU, BYVAL uItem AS DWORD, BYVAL fByPosition AS LONG = FALSE) AS BOOLEAN
DIM dwFlags AS DWORD
IF fByPosition THEN dwFlags = MF_BYPOSITION ELSE dwFlags = MF_BYCOMMAND
DIM dwRes AS DWORD = GetMenuState(hMenu, uItem, dwFlags)
IF ((dwRes AND MF_POPUP) = MF_POPUP) THEN FUNCTION = TRUE
END FUNCTION
' ========================================================================================
' ========================================================================================
' Returns TRUE if the specified menu item is ownerdraw; FALSE otherwise.
' ========================================================================================
PRIVATE FUNCTION AfxIsMenuItemOwnerDraw (BYVAL hMenu AS HMENU, BYVAL uItem AS DWORD, BYVAL fByPosition AS LONG = FALSE) AS BOOLEAN
DIM dwFlags AS DWORD
IF fByPosition THEN dwFlags = MF_BYPOSITION ELSE dwFlags = MF_BYCOMMAND
DIM dwRes AS DWORD = GetMenuState(hMenu, uItem, dwFlags)
IF ((dwRes AND MF_OWNERDRAW) = MF_OWNERDRAW) THEN FUNCTION = TRUE
END FUNCTION
' ========================================================================================
Menu wrapper functions (continued).
' ========================================================================================
' Retrieves the state of the specified menu item.
' - hMenu = A handle to the menu that contains the menu item.
' - uItem = The identifier or position of the menu item to get information about.
' The meaning of this parameter depends on the value of fByPosition.
' - fByPosition = The meaning of uItem. If this parameter is FALSE, uItem is a menu item
' identifier. Otherwise, it is a menu item position.
' Return Value: 0 on failure or one or more of the following values:
' - MFS_CHECKED The item is checked
' - MFS_DEFAULT The menu item is the default.
' - MFS_DISABLED The item is disabled.
' - MFS_ENABLED The item is enabled.
' - MFS_GRAYED The item is grayed.
' - MFS_HILITE The item is highlighted
' - MFS_UNCHECKED The item is unchecked.
' - MFS_UNHILITE The item is not highlighed.
' Note: To get extended error information, use the GetLastError function.
' ========================================================================================
PRIVATE FUNCTION AfxGetMenuItemState (BYVAL hMenu AS HMENU, BYVAL uItem AS DWORD, BYVAL fByPosition AS LONG = FALSE) AS DWORD
DIM mii AS MENUITEMINFOW
mii.cbSize = SIZEOF(mii)
mii.fMask = MIIM_STATE
IF GetMenuItemInfoW(hMenu, uItem, fByPosition, @mii) = 0 THEN EXIT FUNCTION
FUNCTION = mii.fState
END FUNCTION
' ========================================================================================
' ========================================================================================
' Sets the state of the specified menu item.
' - hMenu = A handle to the menu that contains the menu item.
' - uItem = The identifier or position of the menu item to get information about.
' The meaning of this parameter depends on the value of fByPosition.
' - fState = The menu item state. It can be one or more of these values:
' - MFS_CHECKED Checks the menu item.
' - MFS_DEFAULT Specifies that the menu item is the default.
' - MFS_DISABLED Disables the menu item and grays it so that it cannot be selected.
' - MFS_ENABLED Enables the menu item so that it can be selected. This is the default state.
' - MFS_GRAYED Disables the menu item and grays it so that it cannot be selected.
' - MFS_HILITE Highlights the menu item.
' - MFS_UNCHECKED Unchecks the menu item.
' - MFS_UNHILITE Removes the highlight from the menu item. This is the default state.
' - fByPosition = The meaning of uItem. If this parameter is FALSE, uItem is a menu item
' identifier. Otherwise, it is a menu item position.
' Return Value: If the function succeeds, the return value is nonzero. If the function
' fails, the return value is zero. To get extended error information, use the
' GetLastError function.
' Note: The application must call the DrawMenuBar function whenever a menu changes,
' whether or not the menu is in a displayed window.
' ========================================================================================
PRIVATE FUNCTION AfxSetMenuItemState (BYVAL hMenu AS HMENU, BYVAL uItem AS DWORD, BYVAL fState AS DWORD, BYVAL fByPosition AS LONG = FALSE) AS LONG
DIM mii AS MENUITEMINFOW
mii.cbSize = SIZEOF(mii)
mii.fMask = MIIM_STATE
mii.fState = fState
FUNCTION = SetMenuItemInfoW(hMenu, uItem, fByPosition, @mii)
END FUNCTION
' ========================================================================================
' ========================================================================================
' Enables the specified menu item.
' ========================================================================================
PRIVATE FUNCTION AfxEnableMenuItem (BYVAL hMenu AS HMENU, BYVAL uItem AS DWORD, BYVAL fByPosition AS LONG = FALSE) AS LONG
DIM mii AS MENUITEMINFOW
mii.cbSize = SIZEOF(mii)
mii.fMask = MIIM_STATE
mii.fState = MFS_ENABLED
FUNCTION = SetMenuItemInfoW(hMenu, uItem, fByPosition, @mii)
END FUNCTION
' ========================================================================================
' ========================================================================================
' Disables the specified menu item.
' ========================================================================================
PRIVATE FUNCTION AfxDisableMenuItem (BYVAL hMenu AS HMENU, BYVAL uItem AS DWORD, BYVAL fByPosition AS LONG = FALSE) AS LONG
DIM mii AS MENUITEMINFOW
mii.cbSize = SIZEOF(mii)
mii.fMask = MIIM_STATE
mii.fState = MFS_DISABLED
FUNCTION = SetMenuItemInfoW(hMenu, uItem, fByPosition, @mii)
END FUNCTION
' ========================================================================================
' ========================================================================================
' Grays the specified menu item.
' ========================================================================================
PRIVATE FUNCTION AfxGrayMenuItem (BYVAL hMenu AS HMENU, BYVAL uItem AS DWORD, BYVAL fByPosition AS LONG = FALSE) AS LONG
DIM mii AS MENUITEMINFOW
mii.cbSize = SIZEOF(mii)
mii.fMask = MIIM_STATE
mii.fState = MFS_GRAYED
FUNCTION = SetMenuItemInfoW(hMenu, uItem, fByPosition, @mii)
END FUNCTION
' ========================================================================================
' ========================================================================================
' Highlights the specified menu item.
' ========================================================================================
PRIVATE FUNCTION AfxHiliteMenuItem (BYVAL hMenu AS HMENU, BYVAL uItem AS DWORD, BYVAL fByPosition AS LONG = FALSE) AS LONG
DIM mii AS MENUITEMINFOW
mii.cbSize = SIZEOF(mii)
mii.fMask = MIIM_STATE
mii.fState = MFS_HILITE
FUNCTION = SetMenuItemInfoW(hMenu, uItem, fByPosition, @mii)
END FUNCTION
' ========================================================================================
' ========================================================================================
' Removes the system menu close option and disables the X button.
' ========================================================================================
PRIVATE SUB AfxRemoveCloseMenu (BYVAL hwnd AS HWND)
' // Get the system menu handle
DIM hMenu AS HMENU = GetSystemMenu(hwnd, 0)
IF hMenu = NULL THEN EXIT SUB
' // Get the number of menu items
DIM cbItems AS LONG = GetMenuItemCount(hMenu)
' // Remove the close menu item
RemoveMenu(hMenu, cbItems - 1, MF_REMOVE OR MF_BYPOSITION)
' // Remove the separator line
RemoveMenu(hMenu, cbItems - 2, MF_REMOVE OR MF_BYPOSITION)
' // Redraw the menu (this refreshes the caption bar, dimming the X button)
DrawMenuBar(hwnd)
END SUB
' ========================================================================================
' ========================================================================================
' Right justifies a top level menu item. This is usually used to have the Help menu item
' right-justified on the menu bar.
' - hwnd = [in] A handle to the menu that contains the menu item.
' - uItem = [in] The zero-based position of the menu item to change.
' Return value:
' If the function succeeds, the return value is nonzero.
' If the function fails, the return value is zero.
' ========================================================================================
PRIVATE FUNCTION AfxRightJustifyMenuItem (BYVAL hMenu AS HMENU, BYVAL uItem AS DWORD) AS LONG
DIM mii AS MENUITEMINFOW, buffer AS WSTRING * MAX_PATH + 1
mii.cbSize = SIZEOF(MENUITEMINFOW)
mii.dwTypeData = @buffer
mii.cch = MAX_PATH
mii.fType = MF_STRING
mii.fState = MFS_DEFAULT
mii.fMask = MIIM_ID OR MIIM_DATA OR MIIM_TYPE OR MIIM_SUBMENU
IF GetMenuItemInfoW(hMenu, uItem, CTRUE, @mii) THEN
mii.fType = mii.fType OR MF_HELP
FUNCTION = SetMenuItemInfoW(hMenu, uItem, CTRUE, @mii)
END IF
END FUNCTION
' ========================================================================================
' ========================================================================================
' Changes the text of a menu item to bold.
' - hwnd = [in] A handle to the menu that contains the menu item.
' - uItem = [in] The zero-based position of the menu item to change.
' Return value:
' If the function succeeds, the return value is nonzero.
' If the function fails, the return value is zero.
' ========================================================================================
PRIVATE FUNCTION AfxSetMenuItemBold (BYVAL hMenu AS HMENU, BYVAL uItem AS DWORD) AS LONG
DIM mii AS MENUITEMINFOW, buffer AS WSTRING * MAX_PATH + 1
mii.cbSize = SIZEOF(MENUITEMINFOW)
mii.dwTypeData = @buffer
mii.cch = MAX_PATH
mii.fType = MF_STRING
mii.fMask = MIIM_ID OR MIIM_DATA OR MIIM_TYPE OR MIIM_SUBMENU OR MIIM_STATE
IF GetMenuItemInfoW(hMenu, uItem, TRUE, @mii) THEN
mii.fState = mii.fState OR &H1000
FUNCTION = SetMenuItemInfoW(hMenu, uItem, CTRUE, @mii)
END IF
END FUNCTION
' ========================================================================================
' ========================================================================================
' Sets the text of the specified menu item.
' - hMenu = A handle to the menu that contains the menu item.
' - uItem = The identifier or position of the menu item to get information about.
' The meaning of this parameter depends on the value of fByPosition.
' - strText = Text to set.
' - fByPosition = The meaning of uItem. If this parameter is FALSE, uItem is a menu item
' identifier. Otherwise, it is a menu item position.
' ========================================================================================
PRIVATE FUNCTION AfxSetMenuItemText (BYVAL hMenu AS HMENU, BYVAL uItem AS DWORD, BYREF wszText AS WSTRING, BYVAL fByPosition AS LONG = FALSE) AS LONG
DIM mii AS MENUITEMINFOW
mii.cbSize = SIZEOF(mii)
mii.fMask = MIIM_STRING
mii.dwTypeData = @wszText
FUNCTION = SetMenuItemInfoW(hMenu, uItem, fByPosition, @mii)
END FUNCTION
' ========================================================================================
' ========================================================================================
' Retrieves the text of the specified menu item.
' - hMenu = Handle to the menu that contains the menu item.
' - uItem = The identifier or position of the menu item to get information about.
' The meaning of this parameter depends on the value of fByPosition.
' - fByPosition = The meaning of uItem. If this parameter is FALSE, uItem is a menu item
' identifier. Otherwise, it is a menu item position.
' ========================================================================================
PRIVATE FUNCTION AfxGetMenuItemTextA (BYVAL hMenu AS HMENU, BYVAL uItem AS DWORD, BYVAL fByPosition AS LONG = FALSE) AS STRING
' // Fills the MENUITEMINFOA structure
DIM mii AS MENUITEMINFOA
mii.cbSize = SIZEOF(mii)
mii.fMask = MIIM_STRING
mii.dwTypeData = NULL
' // Get the needed size of the buffer
IF GetMenuItemInfoA(hMenu, uItem, fByPosition, @mii) = 0 THEN EXIT FUNCTION
' // Make room for the trailing null
mii.cch += 1
' // Allocate the buffer
DIM buffer AS STRING = SPACE$(mii.cch)
' // Get the menu string
mii.dwTypeData = STRPTR(buffer)
IF GetMenuItemInfoA(hMenu, uItem, fByPosition, @mii) THEN
FUNCTION = RTRIM(buffer, CHR(0))
END IF
END FUNCTION
' ========================================================================================
' ========================================================================================
' Retrieves the text of the specified menu item.
' - hMenu = Handle to the menu that contains the menu item.
' - uItem = The identifier or position of the menu item to get information about.
' The meaning of this parameter depends on the value of fByPosition.
' - fByPosition = The meaning of uItem. If this parameter is FALSE, uItem is a menu item
' identifier. Otherwise, it is a menu item position.
' Remarks: The returned WSTRING pointer must be freed with Delete.
' Usage:
' DIM pwsz AS WSTRING PTR
' pwsz = AfxGetMenuItemTextW(hMenu, uItem, fByPosition)
' MessageBoxW 0, *pwsz, "", MB_OK
' IF pwsz THEN Delete(pwsz)
' ========================================================================================
PRIVATE FUNCTION AfxGetMenuItemTextW (BYVAL hMenu AS HMENU, BYVAL uItem AS DWORD, BYVAL fByPosition AS LONG = FALSE) AS WSTRING PTR
' // Fills the MENUITEMINFOW structure
DIM mii AS MENUITEMINFOW
mii.cbSize = SIZEOF(mii)
mii.fMask = MIIM_STRING
mii.dwTypeData = NULL
' // Get the needed size of the buffer
IF GetMenuItemInfoW(hMenu, uItem, fByPosition, @mii) = 0 THEN EXIT FUNCTION
' // Make room for the trailing null
mii.cch += 1
' // Allocate the buffer
DIM pbuffer AS WSTRING PTR = CAllocate(mii.cch * 2, 1)
' // Get the menu string
mii.dwTypeData = pbuffer
IF GetMenuItemInfoW(hMenu, uItem, fByPosition, @mii) THEN
FUNCTION = pBuffer
END IF
END FUNCTION
' ========================================================================================
#ifdef UNICODE
#define AfxGetMenuItemText AfxGetMenuItemTextW
#else
#define AfxGetMenuItemText AfxGetMenuItemTextA
#endif
Another one:
' ========================================================================================
' Retrieves information about the font used in menu bars.
' If the function succeeds, the return value is a nonzero value.
' If the function fails, the return value is zero.
' To get extended error information, call GetLastError.
' ========================================================================================
FUNCTION AfxGetMenuFont (BYVAL lfw AS LOGFONTW PTR) AS BOOLEAN
DIM ncm AS NONCLIENTMETRICSW
IF VARPTR(lfw) = 0 THEN EXIT FUNCTION
IF AfxWindowsVersion >= 6 THEN ncm.cbSize = 504 ELSE ncm.cbSize = 500
DIM r AS LONG = SystemParametersInfoW(SPI_GETNONCLIENTMETRICS, SIZEOF(ncm), @ncm, 0)
IF r THEN *lfw = ncm.lfMenuFont
FUNCTION = r
END FUNCTION
' ========================================================================================
' ========================================================================================
' Retrieves the point size of the font used in menu bars.
' If the function fails, the return value is 0.
' ========================================================================================
FUNCTION AfxGetMenuFontPointSize () AS LONG
DIM ncm AS NONCLIENTMETRICSW
IF AfxWindowsVersion >= 6 THEN ncm.cbSize = 504 ELSE ncm.cbSize = 500
IF SystemParametersInfoW(SPI_GETNONCLIENTMETRICS, SIZEOF(ncm), @ncm, 0) = 0 THEN EXIT FUNCTION
DIM hDC AS HDC = CreateDCW("DISPLAY", NULL, NULL, NULL)
IF hDC = NULL THEN EXIT FUNCTION
DIM cyPixelsPerInch AS LONG = GetDeviceCaps(hDC, LOGPIXELSY)
DeleteDC hDC
DIM nPointSize AS LONG = MulDiv(ncm.lfMenuFont.lfHeight, 72, cyPixelsPerInch)
IF nPointSize < 0 THEN nPointSize = -nPointSize
FUNCTION = nPointSize
END FUNCTION
' ========================================================================================
This version of FileExists is much more complete than the FB one, since it is only for Windows.
' ========================================================================================
' Searches a directory for a file or subdirectory with a name that matches a specific name
' (or partial name if wildcards are used).
' Parameter:
' - pwszFileSpec: The directory or path, and the file name, which can include wildcard
' characters, for example, an asterisk (*) or a question mark (?).
' This parameter should not be NULL, an invalid string (for example, an empty string or a
' string that is missing the terminating null character), or end in a trailing backslash (\).
' If the string ends with a wildcard, period (.), or directory name, the user must have
' access permissions to the root and all subdirectories on the path.
' To extend the limit of MAX_PATH wide characters to 32,767 wide characters, prepend
' "\\?\" to the path.
' Return value:
' Returns TRUE if the specified file exists or FALSE otherwise.
' Remarks:
' Prepending the string "\\?\" does not allow access to the root directory.
' On network shares, you can use a pwszFileSpec in the form of the following:
' "\\server\service\*". However, you cannot use a pwszFileSpec that points to the share
' itself; for example, "\\server\service" is not valid.
' To examine a directory that is not a root directory, use the path to that directory,
' without a trailing backslash. For example, an argument of "C:\Windows" returns information
' about the directory "C:\Windows", not about a directory or file in "C:\Windows".
' To examine the files and directories in "C:\Windows", use an pwszFileSpec of "C:\Windows\*".
' Be aware that some other thread or process could create or delete a file with this name
' between the time you query for the result and the time you act on the information.
' If this is a potential concern for your application, one possible solution is to use
' the CreateFile function with CREATE_NEW (which fails if the file exists) or OPEN_EXISTING
' (which fails if the file does not exist).
' ========================================================================================
FUNCTION AfxFileExists (BYVAL pwszFileSpec AS WSTRING PTR) AS BOOLEAN
DIM fd AS WIN32_FIND_DATAW
IF pwszFileSpec = NULL THEN EXIT FUNCTION
DIM hFind AS HANDLE = FindFirstFileW(pwszFileSpec, @fd)
IF hFind = INVALID_HANDLE_VALUE THEN EXIT FUNCTION
FindClose hFind
' // Make sure that it is not a directory or a temporary file
IF (fd.dwFileAttributes AND FILE_ATTRIBUTE_DIRECTORY) <> FILE_ATTRIBUTE_DIRECTORY AND _
(fd.dwFileAttributes AND FILE_ATTRIBUTE_TEMPORARY) <> FILE_ATTRIBUTE_TEMPORARY THEN
FUNCTION = TRUE
END IF
END FUNCTION
' ========================================================================================
' ========================================================================================
' Searches a directory for a file or subdirectory with a name that matches a specific name
' (or partial name if wildcards are used).
' Parameter:
' - pwszFileSpec: The directory or path, and the file name, which can include wildcard
' characters, for example, an asterisk (*) or a question mark (?).
' This parameter should not be NULL, an invalid string (for example, an empty string or a
' string that is missing the terminating null character), or end in a trailing backslash (\).
' If the string ends with a wildcard, period (.), or directory name, the user must have
' access permissions to the root and all subdirectories on the path. To extend the limit
' of MAX_PATH wide characters to 32,767 wide characters, prepend "\\?\" to the path.
' Return value:
' Returns TRUE if the specified folder exists or FALSE otherwise.
' Remarks
' Prepending the string "\\?\" does not allow access to the root directory.
' On network shares, you can use an btrFileName in the form of the following: "\\server\service\*".
' However, you cannot use an btrFileName that points to the share itself; for example,
' "\\server\service" is not valid.
' To examine a directory that is not a root directory, use the path to that directory,
' without a trailing backslash. For example, an argument of "C:\Windows" returns information
' about the directory "C:\Windows", not about a directory or file in "C:\Windows".
' To examine the files and directories in "C:\Windows", use an btrFileName of "C:\Windows\*".
' Be aware that some other thread or process could create or delete a file with this name
' between the time you query for the result and the time you act on the information.
' If this is a potential concern for your application, one possible solution is to use
' the CreateFile function with CREATE_NEW (which fails if the file exists) or OPEN_EXISTING
' (which fails if the file does not exist).
' ========================================================================================
FUNCTION AfxFolderExists (BYVAL pwszFileSpec AS WSTRING PTR) AS BOOLEAN
DIM fd AS WIN32_FIND_DATAW
IF pwszFileSpec = NULL THEN EXIT FUNCTION
DIM hFind AS HANDLE = FindFirstFileW(pwszFileSpec, @fd)
IF hFind = INVALID_HANDLE_VALUE THEN EXIT FUNCTION
FindClose hFind
' // Make sure that it is a directory
IF (fd.dwFileAttributes AND FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY THEN FUNCTION = TRUE
END FUNCTION
' ========================================================================================
' ========================================================================================
' Calculates the size of a menu bar or a drop-down menu.
' - hwnd = Handle of the window that owns the menu.
' - hmenu = handle of the menu.
' - prcmenu = Pointer to a variable of type RECT where to return the retrieved values.
' Return Value:
' If the function succeeds, the return value is 0.
' If the function fails, the return value is a system error code.
' ========================================================================================
FUNCTION AfxGetMenuRect (BYVAL hwnd AS HWND, BYVAL hmenu AS HMENU, BYVAL prcmenu AS RECT PTR) AS LONG
DIM i AS LONG, nRes AS LONG, rc AS RECT
FOR i = 1 TO GetMenuItemCount(hmenu)
nRes = GetMenuItemRect(hwnd, hmenu, i, @rc)
IF nRes = -1 THEN nRes = GetLastError : EXIT FOR
UnionRect prcmenu, prcmenu, @rc
NEXT
FUNCTION = nRes
END FUNCTION
' ========================================================================================
Changed several functions to return a BOOLEAN.
QuoteIt is more fun than playing cards with other retirees.
:) By the level of the things you create, I don't think 99% of retirees will understand the slightest bit of what you are doing!
I mean this in the best possible way, but you have to be a kick-ass retiree. :)
I have a big advantage. As I have learned English mainly reading Microsoft documentation, I have no problems understanding it, whereas native English speakers apparently have great difficulties to understand "Microsoft English". :)
Recently, a PBer has posted in the PB forum: 'Depsite having read and reread the help on Objects, Classes, Methods and Properties I still cannot figure out why I am getting the compiler error " Method or Property Name Expected" on the line "amc.MediaUsername = WEdstr".'
He has declared amc AS DISPATCH and then is trying to use amc to do direct interface calls. That is, he does not understand the difference between Automation and direct interface calls. For some reason, 99% of PBer's seem unable to understand low-level COM programming.
I'm quite sure that Paul has not any problem understanding the code that I'm writing with FB.
You are correct.
Many people do tend to approach programming like they would approach unpacking a complicated sound system:
"IF all else fails....read instructions!"
...and then we don't understand the instructions.....
But then again if com programming we easy, everyone would have programmed.
I still think the work You, Paul, Gary and the others do are pretty much up there with the best, so thanks for all the efforts, because without the work you all do, I still would have tried to make my first button.
:)
Font functions.
' ========================================================================================
' Font enum
' ========================================================================================
enum
AFX_FONT_CAPTION = 1 ' // Caption font
AFX_FONT_SMALLCAPTION ' // Small caption font
AFX_FONT_MENU ' // Font used in menu bars
AFX_FONT_STATUS ' // Font used in status bars and tooltips
AFX_FONT_MESSAGE ' // Font used in message boxes
' // Font settings
AFX_FONT_HEIGHT ' // Font height
AFX_FONT_WEIGHT ' // Font weight
AFX_FONT_ITALIC ' // Font italic
AFX_FONT_UNDERLINE ' // Font underline
AFX_FONT_STRIKEOUT ' // Font strikeout
AFX_FONT_CHARSET ' // Font charset
end enum
' ========================================================================================
' ========================================================================================
' Retrieves information about the fonts used by Windows.
' Parameters:
' - nType = The type of font:
' AFX_FONT_CAPTION, AFX_FONT_SMALLCAPTION, AFX_FONT_MENU, AFX_FONT_STATUS, AFX_FONT_MESSAGE
' - plfw = Pointer to a LOGFONTW structure that receives the font information.
' Return value: TRUE on succes or FALSE on failure.
' To get extended error information, call GetLastError.
' ========================================================================================
FUNCTION AfxGetWindowsFontInfo (BYVAL nType AS LONG, BYVAL plfw AS LOGFONTW PTR) AS BOOLEAN
DIM ncm AS NONCLIENTMETRICSW
IF plfw = NULL THEN EXIT FUNCTION
IF AfxWindowsVersion >= 6 THEN ncm.cbSize = 504 ELSE ncm.cbSize = 500
IF SystemParametersInfoW(SPI_GETNONCLIENTMETRICS, SIZEOF(ncm), @ncm, 0) = 0 THEN EXIT FUNCTION
SELECT CASE nType
CASE AFX_FONT_CAPTION : *plfw = ncm.lfCaptionFont
CASE AFX_FONT_SMALLCAPTION : *plfw = ncm.lfSmCaptionFont
CASE AFX_FONT_MENU : *plfw = ncm.lfMenuFont
CASE AFX_FONT_STATUS : *plfw = ncm.lfStatusFont
CASE AFX_FONT_MESSAGE : *plfw = ncm.lfMessageFont
CASE ELSE
RETURN FALSE
END SELECT
FUNCTION = TRUE
END FUNCTION
' ========================================================================================
' ========================================================================================
' Retrieves the point size of the fonts used by Windows.
' Parameters:
' - nType = The type of font:
' AFX_FONT_CAPTION, AFX_FONT_SMALLCAPTION, AFX_FONT_MENU, AFX_FONT_STATUS, AFX_FONT_MESSAGE
' Return value: The point size.
' ========================================================================================
FUNCTION AfxGetWindowsFontPointSize (BYVAL nType AS LONG) AS LONG
DIM ncm AS NONCLIENTMETRICSW
IF AfxWindowsVersion >= 6 THEN ncm.cbSize = 504 ELSE ncm.cbSize = 500
IF SystemParametersInfoW(SPI_GETNONCLIENTMETRICS, SIZEOF(ncm), @ncm, 0) = 0 THEN EXIT FUNCTION
DIM hDC AS HDC = CreateDCW("DISPLAY", NULL, NULL, NULL)
IF hDC = NULL THEN EXIT FUNCTION
DIM cyPixelsPerInch AS LONG = GetDeviceCaps(hDC, LOGPIXELSY)
DeleteDC hDC
DIM nPointSize AS LONG
SELECT CASE nType
CASE AFX_FONT_CAPTION : nPointSize = MulDiv(ncm.lfCaptionFont.lfHeight, 72, cyPixelsPerInch)
CASE AFX_FONT_SMALLCAPTION : nPointSize = MulDiv(ncm.lfSmCaptionFont.lfHeight, 72, cyPixelsPerInch)
CASE AFX_FONT_MENU : nPointSize = MulDiv(ncm.lfMenuFont.lfHeight, 72, cyPixelsPerInch)
CASE AFX_FONT_STATUS : nPointSize = MulDiv(ncm.lfStatusFont.lfHeight, 72, cyPixelsPerInch)
CASE AFX_FONT_MESSAGE : nPointSize = MulDiv(ncm.lfMessageFont.lfHeight, 72, cyPixelsPerInch)
END SELECT
IF nPointSize < 0 THEN nPointSize = -nPointSize
FUNCTION = nPointSize
END FUNCTION
' ========================================================================================
' ========================================================================================
' Returns the point size of a font given its logical height
' ========================================================================================
PRIVATE FUNCTION AfxGetFontPointSize (BYVAL nHeight AS LONG) AS LONG
DIM hDC AS HDC = CreateDCW("DISPLAY", NULL, NULL, NULL)
IF hDC = NULL THEN EXIT FUNCTION
DIM cyPixelsPerInch AS LONG = GetDeviceCaps(hDC, LOGPIXELSY)
DeleteDC HDC
DIM nPointSize AS LONG = MulDiv(nHeight, 72, cyPixelsPerInch)
IF nPointSize < 0 THEN nPointSize = -nPointSize
FUNCTION = nPointSize
END FUNCTION
' ========================================================================================
' ========================================================================================
' Returns the logical height of a font given its point size
' ========================================================================================
PRIVATE FUNCTION AfxGetFontHeight (BYVAL nPointSize AS LONG) AS LONG
DIM hDC AS HDC = CreateDCW("DISPLAY", NULL, NULL, NULL)
IF hDC = NULL THEN EXIT FUNCTION
DIM cyPixelsPerInch AS LONG = GetDeviceCaps(hDC, LOGPIXELSY)
DeleteDC HDC
DIM nHeight AS LONG = -MulDiv(nPointSize, cyPixelsPerInch, 72)
FUNCTION = nHeight
END FUNCTION
' ========================================================================================
' ========================================================================================
' Modifies the face name of the font of a window or control.
' Parameters:
' - hwnd = Handle of the window or control.
' - pwszNewFaceName = The new face name of the font
' Return value: TRUE on succes or FALSE on failure.
' To get extended error information, call GetLastError.
' ========================================================================================
PRIVATE FUNCTION AfxModifyFontFaceName (BYVAL hwnd AS HWND, BYREF wszNewFaceName AS WSTRING) AS BOOLEAN
DIM lfw AS LOGFONTW
IF hwnd = NULL OR VARPTR(wszNewFaceName) = NULL THEN EXIT FUNCTION
' // Get the handle of the font used by the header
DIM hCurFont AS HFONT = CAST(HFONT, SendMessageW(hwnd, WM_GETFONT, 0, 0))
IF hCurFont = 0 THEN EXIT FUNCTION
' // Get the LOGFONTW structure
IF GetObject(hCurFont, SIZEOF(lfw), @lfw) = 0 THEN EXIT FUNCTION
' // Change the face name
lfw.lfFaceName = wszNewFaceName
' // Create a new font
DIM hNewFont AS HFONT = CreateFontIndirectW(@lfw)
IF hNewFont = 0 THEN EXIT FUNCTION
' // Select the new font and delete the old one
DIM hDC AS HDC = GetDC(hwnd)
DeleteObject(SelectObject(hDC, CAST(HGDIOBJ, hNewFont)))
ReleaseDC(hwnd, hDC)
SendMessageW(hwnd, WM_SETFONT, CAST(WPARAM, hNewFont), CTRUE)
FUNCTION = TRUE
END FUNCTION
' ========================================================================================
' ========================================================================================
' Modifies settings of the font used by a window of control.
' Parameters:
' - hwnd = Handle of the window or control.
' - nSetting : One of the AFX_FONT_xxx constants.
' - nValue: Depends of the nSetting value
' AFX_FONT_HEIGHT
' The base is 100. To increase the font a 20% pass 120; to reduce it a 20% pass 80%.
' AFX_FONT_WEIGHT
' 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)
' AFX_FONT_ITALIC : TRUE or FALSE.
' AFX_FONT_UNDERLINE : TRUE or FALSE.
' AFX_FONT_STRIKEOUT : TRUE or FALSE.
' AFX_FONT_CHARSET
' 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, JOHAB_CHARSET (Korean language edition of Windows), ARABIC_CHARSET and
' HEBREW_CHARSET (Middle East language edition of Windows), THAI_CHARSET (Thai language
' edition of Windows).
' 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: TRUE on succes or FALSE on failure.
' To get extended error information, call GetLastError.
' ========================================================================================
PRIVATE FUNCTION AfxModifyFontSettings (BYVAL hwnd AS HWND, BYVAL nSetting AS LONG, BYVAL nValue AS LONG) AS BOOLEAN
DIM lfw AS LOGFONTW
IF IsWindow(hwnd) = 0 THEN EXIT FUNCTION
' // Get the handle of the font used by the header
DIM hCurFont AS HFONT = CAST(HFONT, SendMessageW(hwnd, WM_GETFONT, 0, 0))
IF hCurFont = NULL THEN EXIT FUNCTION
' // Get the LOGFONTW structure
IF GetObject(hCurFont, SIZEOF(lfw), @lfw) = 0 THEN EXIT FUNCTION
' // Change the specified setting
SELECT CASE nSetting
CASE AFX_FONT_HEIGHT
' // Change the point size
DIM lPointSize AS LONG = AfxGetFontPointSize(lfw.lfHeight)
lPointSize = lPointSize * (nValue / 100)
lfw.lfHeight = -MulDiv(lPointSize, AfxLogPixelsY, 72)
CASE AFX_FONT_WEIGHT
' // Change the font weight
lfw.lfWeight = nValue
CASE AFX_FONT_ITALIC
' // Change the italic flag
lfw.lfItalic = CUBYTE(nValue)
CASE AFX_FONT_UNDERLINE
' // Change the underline flag
lfw.lfUnderline = CUBYTE(nValue)
CASE AFX_FONT_STRIKEOUT
' // Change the strikeout flag
lfw.lfStrikeOut = CUBYTE(nValue)
CASE AFX_FONT_CHARSET
' // Change the charset
lfw.lfCharset = CUBYTE(nValue)
CASE ELSE
RETURN FALSE
END SELECT
' // Create a new font
DIM hNewFont AS HFONT = CreateFontIndirectW(@lfw)
IF hNewFont = NULL THEN EXIT FUNCTION
' // Select the new font and delete the old one
DIM hDC AS HDC = GetDC(hwnd)
DeleteObject(SelectObject(hDC, CAST(HGDIOBJ, hNewFont)))
ReleaseDC(hwnd, hDC)
SendMessageW(hwnd, WM_SETFONT, CAST(WPARAM, hNewFont), CTRUE)
FUNCTION = TRUE
END FUNCTION
' ========================================================================================
' ========================================================================================
' Creates a logical font.
' Parameters:
' - wszFaceName = The typeface name.
' - lPointSize = The point size.
' - DPI = Dots per inch to calculate scaling. Default value = 96 (no scaling). If you pass -1
' and the application is DPI aware, the DPI value used by the operating system will be used.
' - lWeight = 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)
' - bItalic = Italic flag. CTRUE or FALSE
' - bUnderline = Underline flag. CTRUE or FALSE
' - bStrikeOut = StrikeOut flag. CTRUE or FALSE
' - bCharset = Charset.
' 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, JOHAB_CHARSET (Korean language edition of Windows), ARABIC_CHARSET and
' HEBREW_CHARSET (Middle East language edition of Windows), THAI_CHARSET (Thai language
' edition of Windows).
' 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: The handle of the font or NULL on failure.
' Remarks: The returned font must be destroyed with DeleteObject or the macro DeleteFont
' when no longer needed to prevent memory leaks.
' Usage examples:
' hFont = AfxCreateFont("MS Sans Serif", 8, , FW_NORMAL, , , , DEFAULT_CHARSET)
' hFont = AfxCreateFont("Courier New", 10, 96 , FW_BOLD, , , , DEFAULT_CHARSET)
' hFont = AfxCreateFont("Marlett", 8, -1, FW_NORMAL, , , , SYMBOL_CHARSET)
' ========================================================================================
FUNCTION AfxCreateFont (BYREF wszFaceName AS WSTRING, BYVAL lPointSize AS LONG, BYVAL DPI AS LONG = 96, _
BYVAL lWeight AS LONG = 0, BYVAL bItalic AS UBYTE = FALSE, BYVAL bUnderline AS UBYTE = FALSE, _
BYVAL bStrikeOut AS UBYTE = FALSE, BYVAL bCharSet AS UBYTE = DEFAULT_CHARSET) AS HFONT
DIM tlfw AS LOGFONTW
DIM hDC AS HDC = GetDC(HWND_DESKTOP)
' // Font scaling
IF DPI = -1 THEN DPI = GetDeviceCaps(hDC, LOGPIXELSX)
IF DPI > 0 THEN lPointSize = (lPointSize * DPI) \ GetDeviceCaps(hDC, LOGPIXELSY)
tlfw.lfHeight = -MulDiv(lPointSize, .GetDeviceCaps(hDC, LOGPIXELSY), 72) ' logical font height
tlfw.lfWidth = 0 ' average character width
tlfw.lfEscapement = 0 ' escapement
tlfw.lfOrientation = 0 ' orientation angles
tlfw.lfWeight = lWeight ' font weight
tlfw.lfItalic = bItalic ' italic(CTRUE/FALSE)
tlfw.lfUnderline = bUnderline ' underline(CTRUE/FALSE)
tlfw.lfStrikeOut = bStrikeOut ' strikeout(CTRUE/FALSE)
tlfw.lfCharSet = bCharset ' character set
tlfw.lfOutPrecision = OUT_TT_PRECIS ' output precision
tlfw.lfClipPrecision = CLIP_DEFAULT_PRECIS ' clipping precision
tlfw.lfQuality = DEFAULT_QUALITY ' output quality
tlfw.lfPitchAndFamily = FF_DONTCARE ' pitch and family
tlfw.lfFaceName = wszFaceName ' typeface name
ReleaseDC(HWND_DESKTOP, hDC)
FUNCTION = CreateFontIndirectW(@tlfw)
END FUNCTION
' ========================================================================================