CWindow RC06

[José Roca]

The attached file containst CWindow.inc and the other classes, controls and wrapper procedures that I have been posting.

Does not include the BSTR class because with changes to the headers they have completely broken it. They have changed the definition from WSTRING to WCHAR_T and now I have to figure how to deal with that...

Sorry, I have forgot to change the number from 5 to 6 in CWindow. inc.

[José Roca]

Hi Paul,

If you want to report a bug to dkl....

He has changed

Code Select Expand


type WCHAR as wstring
type PWCHAR as wstring ptr
type LPWCH as wstring ptr
type PWCH as wstring ptr
type LPCWCH as const wstring ptr
type PCWCH as const wstring ptr


to

Code Select Expand


type WCHAR as wchar_t
type PWCHAR as WCHAR ptr
type LPWCH as WCHAR ptr
type PWCH as WCHAR ptr
type LPCWCH as const WCHAR ptr
type PCWCH as const WCHAR ptr


both in stddef.bi and winnt.bi.

As a result, if you use this test code

Code Select Expand


DIM pbstr AS BSTR
pbstr = SysAllocString("This is a test")
print *pbstr
SysFreeString(pbstr)

print "press esc"
sleep


It prints 84, that is the ASC code of the first character.

If I #undef BSTR and define it as WSTRING PTR, it works:

Code Select Expand


#undef BSTR
TYPE BSTR AS WSTRING PTR

DIM pbstr AS BSTR
pbstr = SysAllocString("This is a test")
print *pbstr
SysFreeString(pbstr)


[José Roca]

Code Select Expand


' ########################################################################################
'                              *** VISUAL STYLE MENUS ***
' ########################################################################################

' Windows Vista and porterior Windows versions provide menus that are part of the visual
' schema. These menus are rendered using visual styles, which can be added to existing
' applications. Adding code for new features to existing code must be done carefully to
' avoid breaking existing application behavior. Certain situations can cause visual styling
' to be disabled in an application. These situations include:
'    - Customizing menus using owner-draw menu items (MFT_OWNERDRAW)
'    - Using menu breaks (MFT_MENUBREAK or MFT_MENUBARBREAK)
'    - Using HBMMENU_CALLBACK to defer bitmap rendering
'    - Using a destroyed menu handle
' These situations prevent visual style menus from being rendered. Owner-draw menus can be
' used in Windows Vista and posterior Windows versions, but the menus will not be visually
' styled.
' Windows Vista and posterior Windows versions provide alpha-blended bitmaps, which enables
' menu items to be shown without using owner-draw menu items.
' Requirements:
'    - The bitmap is a 32bpp DIB section.
'    - The DIB section has BI_RGB compression.
'    - The bitmap contains pre-multiplied alpha pixels.
'    - The bitmap is stored in hbmpChecked, hbmpUnchecked, or hbmpItem fields.
' Note: MFT_BITMAP items do not support PARGB32 bitmaps.
' The following functions use the the Graphics Device Interface (GDI) to convert icons to
' bitmaps. Another solution is to use the Windows Imaging Component (WIC).
' Usage example:
'    DIM hSubMenu AS HMENU = GetSubMenu(hMenu, 1)
'    DIM hIcon AS HICON
'    hIcon = LoadImage(NULL, "MyIcon.ico", IMAGE_ICON, 32, 32, LR_LOADFROMFILE)
'    IF hIcon THEN AfxAddIconToMenuItem(hSubMenu, 0, TRUE, hIcon)
' PNG icons can be used by converting them to an icon with AfxGdipImageFromFileEx:
'    hIcon = AfxGdipImageFromFileEx("MyIcon.png")
'    IF hIcon THEN AfxAddIconToMenuItem(hSubMenu, 0, TRUE, hIcon)


For more information, see: https://msdn.microsoft.com/en-us/library/bb757020.aspx?s=6

I have adapted the Microsoft code posted in the above link and incorporated it to AfxMenu.inc, attached to this post.

[José Roca]

Virtual Style Menu example:

Code Select Expand


' ########################################################################################
' Microsoft Windows
' File: CW_Menu.fbtpl
' Contents: CWindow with a menu
' 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 _WIN32_WINNT &h0602
#INCLUDE ONCE "windows.bi"
#INCLUDE ONCE "win/uxtheme.bi"
#INCLUDE ONCE "Afx/CWindow.inc"
#INCLUDE ONCE "Afx/AfxMenu.inc"
#INCLUDE ONCE "Afx/AfxGdiplus.inc"
' $FB_RESPATH = "FBRES.rc"

USING Afx.CWindowClass

' // Menu identifiers
#define IDM_NEW      1001   ' New file
#define IDM_OPEN     1002   ' Open file...
#define IDM_SAVE     1003   ' Save file
#define IDM_SAVEAS   1004   ' Save file as...
#define IDM_EXIT     1005   ' Exit

#define IDM_UNDO     2001   ' Undo
#define IDM_CUT      2002   ' Cut
#define IDM_COPY     2003   ' Copy
#define IDM_PASTE    2004   ' Paste

#define IDM_TILEH    3001   ' Tile hosizontal
#define IDM_TILEV    3002   ' Tile vertical
#define IDM_CASCADE  3003   ' Cascade
#define IDM_ARRANGE  3004   ' Arrange icons
#define IDM_CLOSE    3005   ' Close
#define IDM_CLOSEALL 3006   ' Close all

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), NULL, COMMAND(), SW_NORMAL)

' ========================================================================================
' Build the menu
' ========================================================================================
FUNCTION BuildMenu () AS HMENU

   DIM hMenu AS HMENU
   DIM hPopUpMenu AS HMENU

   hMenu = CreateMenu
   hPopUpMenu = CreatePopUpMenu
      AppendMenuW hMenu, MF_POPUP OR MF_ENABLED, CAST(UINT_PTR, hPopUpMenu), "&File"
         AppendMenuW hPopUpMenu, MF_ENABLED, IDM_NEW, "&New" & CHR(9) & "Ctrl+N"
         AppendMenuW hPopUpMenu, MF_ENABLED, IDM_OPEN, "&Open..." & CHR(9) & "Ctrl+O"
         AppendMenuW hPopUpMenu, MF_SEPARATOR, 0, ""
         AppendMenuW hPopUpMenu, MF_ENABLED, IDM_SAVE, "&Save" & CHR(9) & "Ctrl+S"
         AppendMenuW hPopUpMenu, MF_ENABLED, IDM_SAVEAS, "Save &As..."
         AppendMenuW hPopUpMenu, MF_SEPARATOR, 0, ""
         AppendMenuW hPopUpMenu, MF_ENABLED, IDM_EXIT, "E&xit" & CHR(9) & "Alt+F4"
   hPopUpMenu = CreatePopUpMenu
      AppendMenuW hMenu, MF_POPUP OR MF_ENABLED, CAST(UINT_PTR, hPopUpMenu), "&Edit"
         AppendMenuW hPopUpMenu, MF_ENABLED, IDM_UNDO, "&Undo" & CHR(9) & "Ctrl+Z"
         AppendMenuW hPopUpMenu, MF_SEPARATOR, 0, ""
         AppendMenuW hPopUpMenu, MF_ENABLED, IDM_CUT, "Cu&t" & CHR(9) & "Ctrl+X"
         AppendMenuW hPopUpMenu, MF_ENABLED, IDM_COPY, "&Copy" & CHR(9) & "Ctrl+C"
         AppendMenuW hPopUpMenu, MF_ENABLED, IDM_PASTE, "&Paste" & CHR(9) & "Ctrl+V"
   hPopUpMenu = CreatePopUpMenu
      AppendMenuW hMenu, MF_POPUP OR MF_ENABLED, CAST(UINT_PTR, hPopUpMenu), "&Window"
         AppendMenuW hPopUpMenu, MF_ENABLED, IDM_TILEH, "&Tile Horizontal"
         AppendMenuW hPopUpMenu, MF_ENABLED, IDM_TILEV, "Tile &Vertical"
         AppendMenuW hPopUpMenu, MF_ENABLED, IDM_CASCADE, "Ca&scade"
         AppendMenuW hPopUpMenu, MF_ENABLED, IDM_ARRANGE, "&Arrange &Icons"
         AppendMenuW hPopUpMenu, MF_SEPARATOR, 0, ""
         AppendMenuW hPopUpMenu, MF_ENABLED, IDM_CLOSE, "&Close" & CHR(9) & "Ctrl+F4"
         AppendMenuW hPopUpMenu, MF_ENABLED, IDM_CLOSEALL, "Close &All"
   FUNCTION = hMenu

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

      CASE WM_CREATE
         EXIT FUNCTION

      CASE WM_COMMAND
         SELECT CASE LOWORD(wParam)
            CASE IDCANCEL
               ' // If ESC key pressed, close the application sending an WM_CLOSE message
               IF HIWORD(wParam) = BN_CLICKED THEN
                  SendMessageW hwnd, WM_CLOSE, 0, 0
                  EXIT FUNCTION
               END IF
            CASE IDM_NEW   ' IDM_OPEN, IDM_SAVE, etc.
               MessageBox hwnd, "New option clicked", "Menu", MB_OK
               EXIT FUNCTION
         END SELECT

    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, "CWindow with a menu", @WndProc)
   pWindow.SetClientSize(400, 250)
   pWindow.Center

   ' // Add a button
   pWindow.AddControl("Button", pWindow.hWindow, IDCANCEL, "&Close", 280, 180, 75, 23)

   ' // Create the menu
   DIM hMenu AS HMENU = BuildMenu
   SetMenu pWindow.hWindow, hMenu

DIM hSubMenu AS HMENU = GetSubMenu(hMenu, 1)
DIM hIcon AS HICON = LoadImage(NULL, ExePath & "\undo_32.ico", IMAGE_ICON, 32, 32, LR_LOADFROMFILE)
IF hIcon THEN AfxAddIconToMenuItem(hSubMenu, 0, TRUE, hIcon)
hIcon = LoadImage(NULL, ExePath & "\cut_clipboard_32.ico", IMAGE_ICON, 32, 32, LR_LOADFROMFILE)
IF hIcon THEN AfxAddIconToMenuItem(hSubMenu, 2, TRUE, hIcon)
hIcon = LoadImage(NULL, ExePath & "\copy_clipboard_lined_32.ico", IMAGE_ICON, 32, 32, LR_LOADFROMFILE)
IF hIcon THEN AfxAddIconToMenuItem(hSubMenu, 3, TRUE, hIcon)
hIcon = LoadImage(NULL, ExePath & "\paste_clipboard_lined_32.ico", IMAGE_ICON, 32, 32, LR_LOADFROMFILE)
IF hIcon THEN AfxAddIconToMenuItem(hSubMenu, 4, TRUE, hIcon)
'hIcon = AfxGdipImageFromFileEx(ExePath & "\arrow_left_32.png")
'IF hIcon THEN AfxAddIconToMenuItem(hSubMenu, 0, TRUE, hIcon)

   FUNCTION = pWindow.DoEvents(nCmdShow)

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


[José Roca]

Alpha-blended icons in visually styled menus as easy as:

Code Select Expand


DIM hSubMenu AS HMENU = GetSubMenu(hMenu, 1)
DIM hIcon AS HICON = LoadImage(NULL, ExePath & "\undo_32.ico", IMAGE_ICON, 32, 32, LR_LOADFROMFILE)
IF hIcon THEN AfxAddIconToMenuItem(hSubMenu, 0, TRUE, hIcon)


Who can give more?

@Hi Paul,

You can finally made nice toolbars and menus for FireFly and the new editor.

[Paul Squires]

Awesome! I will be looking at this code closely tonight.

[Andrew Lindsay]

Paul,


Is the ultimate goal of this to have FireFlyFB use Jose's Window Class and wrappers?  I, like you, find hand coding interfaces a real pain, but I have found Jose's assistants and examples an absolute godsend on more than one occasion.


Regards


Andrew

[José Roca]

Times have changed. The old technique of creating bitmap strips with pink background is obsolete. Now it is time of using alpha-blended icons or png icons, although apparently Windows 10 users are using flat icons, many of them in black and white!

The old technique of calling the API function SetMenuItemBitmaps always has given horrible results. Making the menu ownerdraw and doing the drawing by yourself still works, but it is hard to code and you lose visual styling, unless you complicate still more it and do the drawing using the themed procedures declared in extheme.bi.

Applications that are not DPI aware are scaled by Windows virtualizing them and rendering an stretched bitmap, making everything to look fuzzy. The funny alternative suggested by some is to use always 96 DPI and buy a magnifier All the code that DDTers are writing is not DPI aware and looks horrible in my system. Also drag and drop does not work correctly between a DPI aware application and a virtualized one.

2/3 or more of the world poblation needs unicode aware controls because for some odd reason they don't speak English

CWindow works with FB 32 & 64 bit compilers without any change in the code and is unicode aware.

I stopped working with FB during several months because, silly me, didn't know that declaring the functions as PRIVATE the unused ones aren't included in the application. This is a partial implementation of dead code removal.

[Paul Squires]

Paul,


Is the ultimate goal of this to have FireFlyFB use Jose's Window Class and wrappers?  I, like you, find hand coding interfaces a real pain, but I have found Jose's assistants and examples an absolute godsend on more than one occasion.


Regards


Andrew

I am not 100% sure what the end goal is. I would like to build a good visual designer using Jose's classes and helper functions. It is a lot of work because the existing FireFlyFB can not simply be used (it is written in PB and is not unicode aware). I would want everything to be open source so others could scrutinize the code and help if they can.

The biggest issue is the amount of work involved. I do not program nearly as much as I used to. I still want to finish the grid control I am working on (all the color messages are done).

[Paul Squires]

I do find that when Jose gets excited and starts programming again that it reignites the passion inside me to program as well.

[José Roca]

Because they have broken BSTR support by changing the definition from WSTRING to WCHAR (WCHAR can only contain a 16 bit character) I can't do much COM programming testing. Meanwhile, I will write some supporting wrappers.

This overloaded function allows to create instances of an object in several ways. Later I will add another allowing to create instances of unregistered OCXs, licensed or not.

Code Select Expand


' ========================================================================================
' Creates a single uninitialized object of the class associated with a specified ProgID or CLSID.
' Parameter:
' - wszProgID = A ProgID or a CLSID in string format.
' Return value:
'   The interface pointer or NULL.
' Usage examples:
'   DIM pDic AS IDictionary PTR
'   pDic = AfxNewCom("Scripting.Dictionary")
' -or-
'   pDic = AfxNewCom(CLSID_Dictionary)
' where CLSID_Dictionary has been declared as
' CONST CLSID_Dictionary = "{EE09B103-97E0-11CF-978F-00A02463E06F}"
' ========================================================================================
' ========================================================================================
PRIVATE FUNCTION AfxNewCom OVERLOAD (BYREF wszProgID AS CONST WSTRING) AS ANY PTR
   DIM classID AS CLSID, pUnk AS ANY PTR
   IF VARPTR(wszProgID) = NULL THEN EXIT FUNCTION
   IF INSTR(wszProgID, "{") THEN CLSIDFromString(wszProgID, @classID) ELSE CLSIDFromProgID(wszProgID, @classID)
   CoCreateInstance(@classID, NULL, CLSCTX_INPROC_SERVER, @IID_IUnknown, @pUnk)
   FUNCTION = pUnk
END FUNCTION
' ========================================================================================

' ========================================================================================
' Creates a single uninitialized object of the class associated with a specified ProgID or CLSID.
' Parameters:
' - wszProgID = A CLSID in string format.
' - riid = A reference to the identifier of the interface to be used to communicate with the object.
' Return value:
'   The interface pointer or NULL.
' Usage examples:
'   pDic = AfxNewCom(CLSID_Dictionary, IID_IDictionary)
'   pDic = AfxNewCom(CLSID_Dictionary, IID_IDictionary)
' where CLSID_Dictionary has been declared as
'   CONST CLSID_Dictionary = "{EE09B103-97E0-11CF-978F-00A02463E06F}"
' and IID_IDictionary as
'   CONST IID_IDictionary = "{42C642C1-97E1-11CF-978F-00A02463E06F}"
' ========================================================================================
' ========================================================================================
PRIVATE FUNCTION AfxNewCom OVERLOAD (BYREF wszClsID AS CONST WSTRING, BYREF wszIID AS CONST WSTRING) AS ANY PTR
   DIM classID AS CLSID, riid AS IID, pUnk AS ANY PTR
   IF VARPTR(wszClsID) = NULL OR VARPTR(wszIID) = NULL THEN EXIT FUNCTION
   CLSIDFromProgID(wszClsID, @classID)
   CLSIDFromProgID(wszIID, @riid)
   CoCreateInstance(@classID, NULL, CLSCTX_INPROC_SERVER, @riid, @pUnk)
   FUNCTION = pUnk
END FUNCTION
' ========================================================================================

' ========================================================================================
' Creates a single uninitialized object of the class associated with a specified CLSID.
' Parameter:
' - classID = The CLSID (class identifier) associated with the data and code that will be
'   used to create the object.
' Return value:
'   The interface pointer or NULL.
' Usage examples:
'   DIM pDic AS IDictionary PTR
'   pDic = AfxNewCom(CLSID_Dictionary)
' where CLSID_Dictionary has been declared as
'   DIM CLSID_Dictionary AS CLSID = (&hEE09B103, &h97E0, &h11CF, {&h97, &h8F, &h00, &hA0, &h24, &h63, &hE0, &h6F})
' ========================================================================================
' ========================================================================================
PRIVATE FUNCTION AfxNewCom OVERLOAD (BYREF classID AS CONST CLSID) AS ANY PTR
   DIM pUnk AS ANY PTR
   IF VARPTR(classID) = NULL THEN EXIT FUNCTION
   CoCreateInstance(@classID, NULL, CLSCTX_INPROC_SERVER, @IID_IUnknown, @pUnk)
   FUNCTION = pUnk
END FUNCTION
' ========================================================================================

' ========================================================================================
' Creates a single uninitialized object of the class associated with the specified CLSID and IID.
' Parameters:
' - classID = The CLSID (class identifier) associated with the data and code that will be
'   used to create the object.
' - riid = A reference to the identifier of the interface to be used to communicate with the object.
' Return value:
'   The interface pointer or NULL.
' Usage examples:
'   DIM pDic AS IDictionary PTR
'   pDic = IDictionary PTR, AfxNewCom(CLSID_Dictionary, IID_IDictionary)
' where CLSID_Dictionary has been declared as
'   DIM CLSID_Dictionary AS CLSID = (&hEE09B103, &h97E0, &h11CF, {&h97, &h8F, &h00, &hA0, &h24, &h63, &hE0, &h6F})
' and IID_IDictionary as
'   DIM IID_IDictionary AS IID = (&h42C642C1, &h97E1, &h11CF, {&h97, &h8F, &h00, &hA0, &h24, &h63, &hE0, &h6F})
' ========================================================================================
' ========================================================================================
PRIVATE FUNCTION AfxNewCom OVERLOAD (BYREF classID AS CONST CLSID, BYREF riid AS CONST IID) AS ANY PTR
   DIM pUnk AS ANY PTR
   IF VARPTR(classID) = NULL OR VARPTR(riid) = NULL THEN EXIT FUNCTION
   CoCreateInstance(@classID, NULL, CLSCTX_INPROC_SERVER, @riid, @pUnk)
   FUNCTION = pUnk
END FUNCTION
' ========================================================================================


[José Roca]

The following function allows to use unregistered OCXs, licensed or not. The old VB6 OCXs can only be used with the 32-bit compiler, since there are not 64-bit versions of them.

Code Select Expand


' ========================================================================================
' Loads the specified library and creates an instance of an object.
' If it succeeds, returns a reference to the requested interface; otherwise, it returns null.
' Not every component is a suitable candidate for use under this overloaded AfxNewCom function.
'  - Only in-process servers (DLLs) are supported.
'  - Components that are system components or part of the operating system, such as XML,
'    Data Access, Internet Explorer, or DirectX, aren't supported
'  - Components that are part of an application, such Microsoft Office, aren't supported.
'  - Components intended for use as an add-in or a snap-in, such as an Office add-in or
'    a control in a Web browser, aren't supported.
'  - Components that manage a shared physical or virtual system resource aren't supported.
'  - Visual ActiveX controls aren't supported because they need to be initilized and
'    activated by the OLE container.
' Note: Do not use DyLibFree to unload the library once you have got a valid reference
' to an interface or your application will GPF. Before calling DyLibFree, all the
' interface references must be released. If you don't need to unload the library until
' the application ends, then you don't need to call FreeLibrary because CoUninitialize
' closes the COM library on the current thread, unloads all DLLs loaded by the thread,
' frees any other resources that the thread maintains, and forces all RPC connections on
' the thread to close.
' ========================================================================================
PRIVATE FUNCTION AfxNewCom OVERLOAD (BYREF wszLibName AS CONST WSTRING, BYREF rclsid AS CONST CLSID, BYREF riid AS CONST IID, BYREF wszLicKey AS WSTRING) AS ANY PTR

   DIM hr AS LONG, hLib AS HANDLE, pUnk AS IUnknown PTR
   DIM pIClassFactory AS IClassFactory PTR, pIClassFactory2 AS IClassFactory2 PTR

   ' // See if the library is already loaded in the address space
   hLib = GetModuleHandleW(wszLibName)
   ' // If it is not loaded, load it
   IF hLib = NULL THEN hLib = DyLibLoad(wszLibName)
   ' // If it fails, abort
   IF hLib = NULL THEN EXIT FUNCTION

   ' // Retrieve the address of the exported function DllGetClassObject
   DIM pfnDllGetClassObject AS FUNCTION (BYVAL rclsid AS CONST IID CONST PTR, BYVAL riid AS CONST IID CONST PTR, BYVAL ppv AS LPVOID PTR) AS HRESULT
   pfnDllGetClassObject = DyLibSymbol(hLib, "DllGetClassObject")
   IF pfnDllGetClassObject = NULL THEN EXIT FUNCTION

   IF LEN(wszLicKey) = 0 THEN
      ' // Request a reference to the IClassFactory interface
      hr = pfnDllGetClassObject(@rclsid, @IID_IClassFactory, @pIClassFactory)
      IF hr <> S_OK THEN EXIT FUNCTION
      ' // Create an instance of the server or control
      hr = pIClassFactory->lpVtbl->CreateInstance(pIClassFactory, NULL, @riid, @pUnk)
      IF hr <> S_OK THEN
         pIClassFactory->lpVtbl->Release(pIClassFactory)
         EXIT FUNCTION
      END IF
   ELSE
      ' // Request a reference to the IClassFactory2 interface
      hr = pfnDllGetClassObject(@rclsid, @IID_IClassFactory, @pIClassFactory2)
      IF hr <> S_OK THEN EXIT FUNCTION
      ' // Create a licensed instance of the server or control
      hr = pIClassFactory2->lpVtbl->CreateInstanceLic(pIClassFactory2, NULL, NULL, @riid, @wszLicKey, @pUnk)
      IF hr <> S_OK THEN
         pIClassFactory2->lpVtbl->Release(pIClassFactory2)
         EXIT FUNCTION
      END IF
   END IF

   IF pIClassFactory THEN pIClassFactory->lpVtbl->Release(pIClassFactory)
   IF pIClassFactory2 THEN pIClassFactory2->lpVtbl->Release(pIClassFactory2)
   FUNCTION = pUnk

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

' ========================================================================================
' Converts the wszClsid and wszIid parameters to GUIDs and calls the function above.
' ========================================================================================
PRIVATE FUNCTION AfxNewCom OVERLOAD (BYREF wszLibName AS CONST WSTRING, BYREF wszClsid AS CONST WSTRING, BYREF wszIid AS CONST WSTRING, BYREF wszLicKey AS WSTRING = "") AS ANY PTR
   DIM rclsid AS CLSID, riid AS IID
   rclsid = AfxGuid(wszClsid)
   riid = AfxGuid(wszIid)
   FUNCTION = AfxNewCom(wszLibName, rclsid, riid, wszLicKey)
END FUNCTION
' ========================================================================================


[José Roca]

Another bug. The library for the RPCRT4.DLL seems broken. If I try to use the function UuidCreate, the linker fails.

I have needed to call it dynamically:

Code Select Expand


DIM g AS GUID
DIM AS ANY PTR pLib = DyLibLoad("RPCRT4.DLL")
IF pLib  THEN
   DIM pProc AS FUNCTION (byval Uuid as UUID ptr) as RPC_STATUS
   pProc = DyLibSymbol(pLib, "UuidCreate")
   IF pProc THEN pProc(@g)
   DyLibFree(pLib)
END IF


[José Roca]

Two new functions, equivalent to PB's GUID$ and GUIDTXT$.

Code Select Expand


' ========================================================================================
' Converts a string into a 16-byte (128-bit) Globally Unique Identifier (GUID)
' To be valid, the string must contain exactly 32 hexadecimal digits, delimited by hyphens
' and enclosed by curly braces. For example: {B09DE715-87C1-11D1-8BE3-0000F8754DA1}
' If pwszGuidText is omited, AfxGuid generates a new unique guid.
' Remarks: I have need to call the UuidCreate function dynamically because, at the time of
' writing, the library for the RPCRT4.DLL seems broken and the linker fails.
' ========================================================================================
PRIVATE FUNCTION AfxGuid (BYVAL pwszGuidText AS WSTRING PTR = NULL) AS GUID
   DIM rguid AS GUID
   IF pwszGuidText = NULL THEN
      ' // Generate a new guid
      DIM AS ANY PTR pLib = DyLibLoad("RPCRT4.DLL")
      IF pLib  THEN
         DIM pProc AS FUNCTION (BYVAL Uuid AS UUID PTR) AS RPC_STATUS
         pProc = DyLibSymbol(pLib, "UuidCreate")
         IF pProc THEN pProc(@rguid)
         DyLibFree(pLib)
      END IF
   ELSE
      CLSIDFromString(pwszGuidText, @rGuid)
   END IF
   FUNCTION = rguid
END FUNCTION
' ========================================================================================

' ========================================================================================
' Returns a 38-byte human-readable guid string from a 16-byte GUID.
' ========================================================================================
PRIVATE FUNCTION AfxGuidText (BYVAL classID AS CLSID PTR) AS STRING
   DIM pwsz AS WSTRING PTR
   StringFromCLSID(classID, CAST(LPOLESTR PTR, @pwsz))
   FUNCTION = *pwsz
   CoTaskMemFree(pwsz)
END FUNCTION
' ========================================================================================


[Petrus Vorster]

Will you consider adding some of these controls soon to the Firefly for FB interface, because I really suck at placing controls manually.
Some of the stuff you posted here really is starting to make Freebasic look like a good move, but many of us would love just to click and place.
PLEASE...