PlanetSquires Forums

Support Forums => WinFBX - Windows Framework for FreeBASIC => Topic started by: José Roca on May 02, 2016, 07:21:53 PM

Title: CWindow RC05
Post by: José Roca on May 02, 2016, 07:21:53 PM
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

Code: [Select]
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

Code: [Select]
pWindow = CAST(CWindow PTR, GetWindowLongPtr(hwnd, 0))
Title: Re: CWindow RC05
Post by: José Roca on May 02, 2016, 07:26:38 PM
And these are the modified OOP versions of the progress bar sample programs.
Title: Re: CWindow RC05 - Split button example
Post by: José Roca on May 03, 2016, 12:27:27 AM
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:

Code: [Select]
   ' // 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.

Code: [Select]
' ########################################################################################
' 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
' ========================================================================================
Title: Re: CWindow RC05
Post by: José Roca on May 03, 2016, 12:43:59 AM
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.
Title: Re: CWindow RC05
Post by: José Roca on May 03, 2016, 12:47:12 AM
I also like this FreeBasic shortcut to fill structures:

Code: [Select]
DIM bi AS BUTTON_IMAGELIST = (hImageList, (3, 3, 3, 3), BUTTON_IMAGELIST_ALIGN_LEFT)

The structure is as follows:

Code: [Select]
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.
Title: Re: CWindow RC05
Post by: Paul Squires on May 03, 2016, 12:36:08 PM
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.


Title: Re: CWindow RC05
Post by: José Roca on May 03, 2016, 02:18:38 PM
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.
Title: Re: CWindow RC05
Post by: José Roca on May 03, 2016, 04:35:17 PM
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.
Title: Re: CWindow RC05
Post by: José Roca on May 03, 2016, 04:55:38 PM
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


Title: Re: CWindow RC05
Post by: James Fuller on May 03, 2016, 05:20:14 PM
Jose,
  It probably isn't this but I NEVER use single line IF THEN statements.

James
Title: Re: CWindow RC05
Post by: José Roca on May 03, 2016, 05:36:02 PM
If doesn't matter if I use one line or

Code: [Select]
         IF hNewFont NULL THEN
            DeleteFont(hNewFont)
         END IF

or

Code: [Select]
         IF hNewFont <> NULL THEN
            DeleteFont(hNewFont)
         END IF

Where is the syntax error?
Title: Re: CWindow RC05
Post by: José Roca on May 03, 2016, 05:43:39 PM
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++.

Title: Re: CWindow RC05
Post by: Paul Squires on May 03, 2016, 05:48: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.


Title: Re: CWindow RC05
Post by: José Roca on May 03, 2016, 05:49:07 PM
Something frequently asked. How to make a modal popup window?

Code: [Select]
' ########################################################################################
' 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
' ========================================================================================

Title: Re: CWindow RC05
Post by: José Roca on May 03, 2016, 05:52:40 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.
Title: Re: CWindow RC05
Post by: Paul Squires on May 03, 2016, 05:55:33 PM
Happens with SelectFont as well. I bet it happens with all the HFONT macros.
Title: Re: CWindow RC05
Post by: Paul Squires on May 03, 2016, 08:18:17 PM
I posted over on the FB forum regarding the DeleteFont sysntax error.
http://www.freebasic.net/forum/viewtopic.php?f=6&t=24663
Title: Re: CWindow RC05 - Combobox color list
Post by: José Roca on May 04, 2016, 12:29:16 PM
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.

Code: [Select]
' ########################################################################################
' 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
Title: Re: CWindow RC05 - Combobox color list example
Post by: José Roca on May 04, 2016, 12:31:35 PM
Example:

Code: [Select]
' ########################################################################################
' 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
' ========================================================================================
Title: Re: CWindow RC05 - CbColorEx (Combobox color list)
Post by: José Roca on May 04, 2016, 02:00:58 PM
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.

Code: [Select]
' ########################################################################################
' 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
Title: Re: CWindow RC05 - CbColorEx example
Post by: José Roca on May 04, 2016, 02:01:53 PM
This example demonstrates the use of the CbColorEx control.

Code: [Select]
' ########################################################################################
' 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
' ========================================================================================
Title: Re: CWindow RC05
Post by: Paul Squires on May 04, 2016, 03:02:54 PM
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.

Code: [Select]
' //
' //  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
' ========================================================================================
     
Title: Re: CWindow RC05
Post by: Paul Squires on May 04, 2016, 03:15:57 PM
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:
Code: [Select]
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?


Title: Re: CWindow RC05
Post by: José Roca on May 04, 2016, 03:31:58 PM
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.
Title: Re: CWindow RC05
Post by: José Roca on May 04, 2016, 04:24:24 PM
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?

Code: [Select]
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
Title: Re: CWindow RC05
Post by: Paul Squires on May 04, 2016, 05:58:53 PM
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.

Code: [Select]

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
   

Title: Re: CWindow RC05
Post by: José Roca on May 04, 2016, 06:25: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?
Title: Re: CWindow RC05
Post by: José Roca on May 04, 2016, 06:44:32 PM
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:

Code: [Select]
   ' // 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:

Code: [Select]
@rgNames(0), 18 * 20 * 2

With pointers we can do everything, but little error checking.
Title: Re: CWindow RC05
Post by: José Roca on May 04, 2016, 06:52:48 PM
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.

Code: [Select]
' ########################################################################################
' 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
' ========================================================================================
Title: Re: CWindow RC05
Post by: Paul Squires on May 04, 2016, 06:54:54 PM
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.
Title: Re: CWindow RC05
Post by: Paul Squires on May 04, 2016, 06:57:06 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.

Title: Re: CWindow RC05
Post by: José Roca on May 04, 2016, 07:35:12 PM
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.
Title: Re: CWindow RC05
Post by: José Roca on May 04, 2016, 07:54:04 PM
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.
Title: Re: CWindow RC05
Post by: José Roca on May 04, 2016, 07:57:40 PM
Well, looks like that one was the only that needed a change.
Title: Re: CWindow RC05
Post by: Paul Squires on May 04, 2016, 07:59:27 PM
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.
Title: Re: CWindow RC05
Post by: Paul Squires on May 04, 2016, 08:15:03 PM
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
Title: Re: CWindow RC05
Post by: José Roca on May 04, 2016, 08:27:19 PM
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.
Title: Re: CWindow RC05
Post by: Paul Squires on May 05, 2016, 09:26:45 AM
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.

Title: Re: CWindow RC05
Post by: Paul Squires on May 05, 2016, 12:56:38 PM
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.


Title: Re: CWindow RC05
Post by: José Roca on May 05, 2016, 01:58:48 PM
Thanks very much. I will remember it.
Title: Re: CWindow RC05
Post by: José Roca on May 05, 2016, 02:52:44 PM
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?
Title: Re: CWindow RC05
Post by: José Roca on May 05, 2016, 03:10:17 PM
It works!

I wonder why they don't explain it in the documentation.
Title: Re: CWindow RC05
Post by: José Roca on May 05, 2016, 04:18:57 PM
Another oddity.

This works:

Code: [Select]
DIM tbb AS TBBUTTON = (idxBitmap, idCommand, fsState, fsStyle, {0, 0, 0, 0, 0, 0}, dwData, idxString)

But this one gives Error 7: Expected ')'

Code: [Select]
DIM tbb AS TBBUTTON
tbb = (idxBitmap, idCommand, fsState, fsStyle, {0, 0, 0, 0, 0, 0}, dwData, idxString)

Title: Re: CWindow RC05
Post by: Paul Squires on May 05, 2016, 05:54:03 PM
Another oddity.

This works:

Code: [Select]
DIM tbb AS TBBUTTON = (idxBitmap, idCommand, fsState, fsStyle, {0, 0, 0, 0, 0, 0}, dwData, idxString)

But this one gives Error 7: Expected ')'

Code: [Select]
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.
Title: Re: CWindow RC05
Post by: José Roca on May 05, 2016, 06:10:21 PM
Sorry, but you have misunderstood me.

This one works both in 32 and 64 bit:

Code: [Select]
#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:

Code: [Select]
#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
Title: Re: CWindow RC05
Post by: Paul Squires on May 05, 2016, 06:35:58 PM
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.
 
Title: Re: CWindow RC05
Post by: Paul Squires on May 05, 2016, 06:39:59 PM
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.
Title: Re: CWindow RC05
Post by: José Roca on May 05, 2016, 07:38:30 PM
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.
Title: Re: CWindow RC05
Post by: Paul Squires on May 06, 2016, 12:44:17 PM
Jose, have you tried creating an accelerator table yet? I tried but it looks like there may be a problem.

Code: [Select]
   '  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.

Title: Re: CWindow RC05
Post by: Paul Squires on May 06, 2016, 02:07:41 PM
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

Title: Re: CWindow RC05
Post by: José Roca on May 06, 2016, 02:28:10 PM
You're right. The only features that I haven't yet tested are accelerator keys and the BITMAP/ICON LABEL, BITMAP/ICON BUTTON.
Title: Re: CWindow RC05
Post by: José Roca on May 06, 2016, 02:36:43 PM
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:

Code: [Select]
' ########################################################################################
'                              *** 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
' ========================================================================================
Title: Re: CWindow RC05
Post by: José Roca on May 06, 2016, 02:39:50 PM
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.
Title: Re: CWindow RC05
Post by: José Roca on May 06, 2016, 03:48:29 PM
Metric conversions.

Code: [Select]
' ########################################################################################
'                                *** 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:

Code: [Select]
' ========================================================================================
' 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
' ========================================================================================
Title: Re: CWindow RC05
Post by: Paul Squires on May 06, 2016, 04:59:08 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.
 
Title: Re: CWindow RC05
Post by: José Roca on May 06, 2016, 06:04:26 PM
Clipboard functions:

Code: [Select]
' ########################################################################################
'                                    *** 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
Title: Re: CWindow RC05
Post by: José Roca on May 06, 2016, 06:12:20 PM
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.

Title: Re: CWindow RC05
Post by: José Roca on May 06, 2016, 06:43:05 PM
I only have a monitor, so I can't test this one:

Code: [Select]
' ========================================================================================
' 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
' ========================================================================================
Title: Re: CWindow RC05
Post by: José Roca on May 06, 2016, 07:21:38 PM
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

Code: [Select]
#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

Code: [Select]
#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

Code: [Select]
' ========================================================================================
' 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
' ========================================================================================
Title: Re: CWindow RC05
Post by: José Roca on May 06, 2016, 09:27:09 PM
Menu wrapper functions.

Code: [Select]
' ########################################################################################
'                                      *** 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
' ========================================================================================
Title: Re: CWindow RC05
Post by: José Roca on May 06, 2016, 09:27:57 PM
Menu wrapper functions (continued).

Code: [Select]
' ========================================================================================
' 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
Title: Re: CWindow RC05
Post by: José Roca on May 06, 2016, 10:54:50 PM
Another one:

Code: [Select]
' ========================================================================================
' 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
' ========================================================================================
Title: Re: CWindow RC05
Post by: José Roca on May 06, 2016, 11:05:43 PM
Code: [Select]
' ========================================================================================
' 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
' ========================================================================================
Title: Re: CWindow RC05
Post by: José Roca on May 06, 2016, 11:45:38 PM
This version of FileExists is much more complete than the FB one, since it is only for Windows.

Code: [Select]
' ========================================================================================
' 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
' ========================================================================================
Title: Re: CWindow RC05
Post by: José Roca on May 06, 2016, 11:55:19 PM
Code: [Select]
' ========================================================================================
' 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
' ========================================================================================
Title: Re: CWindow RC05
Post by: José Roca on May 07, 2016, 12:07:59 AM
Code: [Select]
' ========================================================================================
' 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.
Title: Re: CWindow RC05
Post by: Petrus Vorster on May 07, 2016, 03:27:03 AM
Quote
It 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.  :)
Title: Re: CWindow RC05
Post by: José Roca on May 07, 2016, 04:32:14 AM
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.

Title: Re: CWindow RC05
Post by: Petrus Vorster on May 07, 2016, 05:02:18 AM
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.

 :)
Title: Re: CWindow RC05
Post by: José Roca on May 07, 2016, 06:30:50 PM
Font functions.

Code: [Select]
' ========================================================================================
' 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
' ========================================================================================