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.
Hi Paul,
If you want to report a bug to dkl....
He has changed
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
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
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:
#undef BSTR
TYPE BSTR AS WSTRING PTR
DIM pbstr AS BSTR
pbstr = SysAllocString("This is a test")
print *pbstr
SysFreeString(pbstr)
' ########################################################################################
' *** 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.
Virtual Style Menu example:
' ########################################################################################
' 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
' ========================================================================================
Alpha-blended icons in visually styled menus as easy as:
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.
Awesome! I will be looking at this code closely tonight.
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
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.
Quote from: Andrew Lindsay on May 09, 2016, 08:19:49 PM
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).
I do find that when Jose gets excited and starts programming again that it reignites the passion inside me to program as well.
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.
' ========================================================================================
' 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
' ========================================================================================
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.
' ========================================================================================
' 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
' ========================================================================================
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:
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
Two new functions, equivalent to PB's GUID$ and GUIDTXT$.
' ========================================================================================
' 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
' ========================================================================================
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...
I have learned a technique that eases a little the use of COM interfaces with FB.
The classic way is to do this kind of declaration:
TYPE IDictionaryVtbl
' // IDispatch interface
QueryInterface AS FUNCTION (BYVAL this AS IDictionary PTR, BYVAL riid AS CONST IID CONST PTR, BYVAL ppvObject AS any ptr PTR) AS HRESULT
AddRef AS FUNCTION (BYVAL this AS IDictionary PTR) AS ULONG
Release AS FUNCTION (BYVAL this AS IDictionary PTR) AS ULONG
GetTypeInfoCount AS FUNCTION (BYVAL this AS IDictionary PTR, BYVAL pctinfo AS UINT PTR) AS HRESULT
GetTypeInfo AS FUNCTION (BYVAL this AS IDictionary PTR, BYVAL iTInfo AS UINT, BYVAL lcid AS LCID, BYVAL ppTInfo AS ITypeInfo ptr PTR) AS HRESULT
GetIDsOfNames AS FUNCTION (BYVAL this AS IDictionary PTR, BYVAL riid AS CONST IID CONST PTR, BYVAL rgszNames AS LPOLESTR PTR, BYVAL cNames AS UINT, BYVAL lcid AS LCID, BYVAL rgDispId AS DISPID PTR) AS HRESULT
Invoke AS FUNCTION (BYVAL this AS IDictionary PTR, BYVAL dispIdMember AS DISPID, BYVAL riid AS CONST IID CONST PTR, BYVAL lcid AS LCID, BYVAL wFlags AS WORD, BYVAL pDispParams AS DISPPARAMS PTR, BYVAL pVarResult AS VARIANT PTR, BYVAL pExcepInfo AS EXCEPINFO PTR, BYVAL puArgErr AS UINT PTR) AS HRESULT
' // IDictionary interface
putref_Item AS FUNCTION (BYVAL this AS IDictionary PTR, BYVAL vKey AS VARIANT PTR, BYVAL pRetItem AS VARIANT PTR) AS HRESULT
put_Item AS FUNCTION (BYVAL this AS IDictionary PTR, BYVAL vKey AS VARIANT PTR, BYVAL vNewItem AS VARIANT PTR) AS HRESULT
get_Item AS FUNCTION (BYVAL this AS IDictionary PTR, BYVAL vKey AS VARIANT PTR, BYVAL vRetItem AS VARIANT PTR) AS HRESULT
Add AS FUNCTION (BYVAL this AS IDictionary PTR, BYVAL vKey AS VARIANT PTR, BYVAL vItem AS VARIANT PTR) AS HRESULT
get_Count AS FUNCTION (BYVAL this AS IDictionary PTR, BYVAL pCount AS long PTR) AS HRESULT
Exists AS FUNCTION (BYVAL this AS IDictionary PTR, BYVAL vKey AS VARIANT PTR, BYVAL pExists AS SHORT PTR) AS HRESULT
Items AS FUNCTION (BYVAL this AS IDictionary PTR, BYVAL pItemsArray AS VARIANT PTR) AS HRESULT
put_Key AS FUNCTION (BYVAL this AS IDictionary PTR, BYVAL vKey AS VARIANT PTR, BYVAL vItem AS VARIANT PTR) AS HRESULT
Keys AS FUNCTION (BYVAL this AS IDictionary PTR, BYVAL pKeysArray AS VARIANT PTR) AS HRESULT
Remove AS FUNCTION (BYVAL this AS IDictionary PTR, BYVAL vKey AS VARIANT PTR) AS HRESULT
RemoveAll AS FUNCTION (BYVAL this AS IDictionary PTR) AS HRESULT
put_CompareMode AS FUNCTION (BYVAL this AS IDictionary PTR, BYVAL pcomp AS COMPAREMETHOD) AS HRESULT
get_CompareMode AS FUNCTION (BYVAL this AS IDictionary PTR, BYVAL pcomp AS COMPAREMETHOD PTR) AS HRESULT
_NewEnum AS FUNCTION (BYVAL this AS IDictionary PTR, BYVAL ppunk AS IUnknown PTR PTR) AS HRESULT
get_HashVal AS FUNCTION (BYVAL this AS IDictionary PTR, BYVAL vKey AS VARIANT PTR, BYVAL HashVal AS VARIANT PTR) AS HRESULT
END TYPE
TYPE IDictionary_
lpVtbl AS IDictionaryVtbl PTR
END TYPE
and use it as
DIM pDic AS IDictionary PTR
hr = CoCreateInstance(@CLSID_Dictionary, NULL, CLSCTX_INPROC_SERVER, @IID_IDictionary, @pDic)
DIM vKey AS VARIANT
VariantClear(@vKey)
V_VT(@vKey) = VT_BSTR
V_BSTR(@vKey) = SysAllocString("a")
DIM vItem AS VARIANT
VariantClear(@vItem)
V_VT(@vItem) = VT_BSTR
V_BSTR(@vItem) = SysAllocString("Athens")
pDic->lpVtbl->Add(pDic, @vKey, @vItem)
VariantClear(@vItem)
pDic->lpVtbl->get_Item(pDic, @vKey, @vItem)
VariantClear(@vKey)
VariantClear(@vItem)
IF pDic THEN pDic->lpVtbl->Release(pDic)
Continued in the next post.
But by declaring the methods of the interfaces as ABSTRACT (the IUnknown interface inherits from OBJECT, a built-in type).
TYPE Afx_IUnknown as Afx_IUnknown_
TYPE Afx_IUnknown_ EXTENDS OBJECT
DECLARE ABSTRACT FUNCTION QueryInterface (BYVAL riid AS REFIID, BYVAL ppvObject AS LPVOID PTR) AS HRESULT
DECLARE ABSTRACT FUNCTION AddRef() AS ULONG
DECLARE ABSTRACT FUNCTION Release() AS ULONG
END TYPE
TYPE AFXLPUNKNOWN as Afx_IUnknown PTR
TYPE Afx_IDispatch AS Afx_IDispatch_
TYPE Afx_IDispatch_ EXTENDS Afx_Iunknown
DECLARE ABSTRACT FUNCTION GetTypeInfoCount (BYVAL pctinfo AS UINT PTR) as HRESULT
DECLARE ABSTRACT FUNCTION GetTypeInfo (BYVAL iTInfo AS UINT, BYVAL lcid AS LCID, BYVAL ppTInfo AS ITypeInfo PTR PTR) AS HRESULT
DECLARE ABSTRACT FUNCTION GetIDsOfNames (BYVAL riid AS CONST IID CONST PTR, BYVAL rgszNames AS LPOLESTR PTR, BYVAL cNames AS UINT, BYVAL lcid AS LCID, BYVAL rgDispId AS DISPID PTR) AS HRESULT
DECLARE ABSTRACT FUNCTION Invoke (BYVAL dispIdMember AS DISPID, BYVAL riid AS CONST IID CONST PTR, BYVAL lcid AS LCID, BYVAL wFlags AS WORD, BYVAL pDispParams AS DISPPARAMS PTR, BYVAL pVarResult AS VARIANT PTR, BYVAL pExcepInfo AS EXCEPINFO PTR, BYVAL puArgErr AS UINT PTR) AS HRESULT
END TYPE
TYPE AFX_LPDISPATCH AS Afx_IDispatch PTR
TYPE Afx_IDictionary AS Afx_IDictionary_
TYPE Afx_IDictionary_ EXTENDS Afx_IDispatch
DECLARE ABSTRACT FUNCTION putref_Item (BYVAL vKey AS VARIANT PTR, BYVAL pRetItem AS VARIANT PTR) AS HRESULT
DECLARE ABSTRACT FUNCTION put_Item (BYVAL vKey AS VARIANT PTR, BYVAL vNewItem AS VARIANT PTR) AS HRESULT
DECLARE ABSTRACT FUNCTION get_Item (BYVAL vKey AS VARIANT PTR, BYVAL vRetItem AS VARIANT PTR) AS HRESULT
DECLARE ABSTRACT FUNCTION Add (BYVAL vKey AS VARIANT PTR, BYVAL vItem AS VARIANT PTR) AS HRESULT
DECLARE ABSTRACT FUNCTION get_Count (BYVAL pCount AS long PTR) AS HRESULT
DECLARE ABSTRACT FUNCTION Exists (BYVAL vKey AS VARIANT PTR, BYVAL pExists AS SHORT PTR) AS HRESULT
DECLARE ABSTRACT FUNCTION Items (BYVAL pItemsArray AS VARIANT PTR) AS HRESULT
DECLARE ABSTRACT FUNCTION put_Key (BYVAL vKey AS VARIANT PTR, BYVAL vItem AS VARIANT PTR) AS HRESULT
DECLARE ABSTRACT FUNCTION Keys (BYVAL pKeysArray AS VARIANT PTR) AS HRESULT
DECLARE ABSTRACT FUNCTION Remove (BYVAL vKey AS VARIANT PTR) AS HRESULT
DECLARE ABSTRACT FUNCTION RemoveAll () AS HRESULT
DECLARE ABSTRACT FUNCTION put_CompareMode (BYVAL pcomp AS COMPAREMETHOD) AS HRESULT
DECLARE ABSTRACT FUNCTION get_CompareMode (BYVAL pcomp AS COMPAREMETHOD PTR) AS HRESULT
DECLARE ABSTRACT FUNCTION _NewEnum (BYVAL ppunk AS IUnknown PTR PTR) AS HRESULT
DECLARE ABSTRACT FUNCTION get_HashVal (BYVAL vKey AS VARIANT PTR, BYVAL HashVal AS VARIANT PTR) AS HRESULT
END TYPE
TYPE AFX_LPDICTIONARY AS Afx_IDictionary PTR
the calls to the interface methods can use a simplified syntax:
pDic->Add(@vKey, @vItem)
pDic->get_Item(@vKey, @vItem)
pDic->Release
That is, without having to add ->lpVtbl and having to always pass the this pointer as the first parameter.
pDic->lpVtbl->Add(pDic, @vKey, @vItem)
pDic->lpVtbl->get_Item(pDic, @vKey, @vItem)
pDic->lpVtbl->Release(pDic)
Quote from: Jose Roca on May 08, 2016, 03:26:09 AM
Hi Paul,
If you want to report a bug to dkl....
He has changed
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
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
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:
#undef BSTR
TYPE BSTR AS WSTRING PTR
DIM pbstr AS BSTR
pbstr = SysAllocString("This is a test")
print *pbstr
SysFreeString(pbstr)
Jose, which version of FB were you using prior to the one where you noticed the change? I looked at several of the latest FB versions and this is what I think the BSTR definition resolves to (it seems to match the C header files I saw as well):
wtypes.bi
Type BSTR As OLECHAR Ptr
wtypesbase.bi
type OLECHAR as WCHAR
winnt.bi
Type WCHAR As wchar_t
stddef.bi
#ifdef __FB_DOS__
type wchar_t as ubyte
#elseif defined( __FB_WIN32__ ) or defined( __FB_CYGWIN__ )
type wchar_t as ushort
#else
type wchar_t as long
#endif
So, it seems to resolve to wchar_t (which is a long or ushort depending on platform).
Then I saw this: http://stackoverflow.com/questions/1607266/whats-the-meaning-of-bstr-lpcolestr-and-others
Does this mean that for every time you use a BSTR you would have to CAST it?
*cast(wstring ptr, pbstr)
Quote
Does this mean that for every time you use a BSTR you would have to CAST it?
*cast(wstring ptr, pbstr)
Yes. I think that I'm going to define my own type. WCHAR can only contain a unicode character, therefore a BSTR can't be a WCHAR, but an array of WCHARs. What they have done is like if we defined a STRING as of type UBYTE.
In the file AfxCOM.inc that I'm currently writing, I already have defined the two base types that allow the use of abstract methods, simplifying the syntax.
#ifndef __Afx_IUnknown_INTERFACE_DEFINED__
#define __Afx_IUnknown_INTERFACE_DEFINED__
TYPE Afx_IUnknown AS Afx_IUnknown_
TYPE Afx_IUnknown_ EXTENDS OBJECT
DECLARE ABSTRACT FUNCTION QueryInterface (BYVAL riid AS REFIID, BYVAL ppvObject AS LPVOID PTR) AS HRESULT
DECLARE ABSTRACT FUNCTION AddRef() AS ULONG
DECLARE ABSTRACT FUNCTION Release() AS ULONG
END TYPE
TYPE AFXLPUNKNOWN AS Afx_IUnknown PTR
#endif
#ifndef __Afx_IDispatch_INTERFACE_DEFINED__
#define __Afx_IDispatch_INTERFACE_DEFINED__
TYPE Afx_IDispatch AS Afx_IDispatch_
TYPE Afx_IDispatch_ EXTENDS Afx_Iunknown
DECLARE ABSTRACT FUNCTION GetTypeInfoCount (BYVAL pctinfo AS UINT PTR) as HRESULT
DECLARE ABSTRACT FUNCTION GetTypeInfo (BYVAL iTInfo AS UINT, BYVAL lcid AS LCID, BYVAL ppTInfo AS ITypeInfo PTR PTR) AS HRESULT
DECLARE ABSTRACT FUNCTION GetIDsOfNames (BYVAL riid AS CONST IID CONST PTR, BYVAL rgszNames AS LPOLESTR PTR, BYVAL cNames AS UINT, BYVAL lcid AS LCID, BYVAL rgDispId AS DISPID PTR) AS HRESULT
DECLARE ABSTRACT FUNCTION Invoke (BYVAL dispIdMember AS DISPID, BYVAL riid AS CONST IID CONST PTR, BYVAL lcid AS LCID, BYVAL wFlags AS WORD, BYVAL pDispParams AS DISPPARAMS PTR, BYVAL pVarResult AS VARIANT PTR, BYVAL pExcepInfo AS EXCEPINFO PTR, BYVAL puArgErr AS UINT PTR) AS HRESULT
END TYPE
TYPE AFX_LPDISPATCH AS Afx_IDispatch PTR
#endif
BTW which name do you think would be more appropriate for the overloaded function AfxNewCom? Maybe AfxNewObj, AfxNewObject, AfxCreateObject?
> Jose, which version of FB were you using prior to the one where you noticed the change?
I was using version 1.04, but I think that the headers were the ones of version 1.02.
FreeBASIC binding for mingw-w64-v4.0.1
The ones that I'm using now:
FreeBASIC binding for mingw-w64-v4.0.4
@Hi Paul,
I have found a solution for the "A" and "W" functions.
Ihave written these two helper functions:
' ========================================================================================
' Translates ansi bytes into unicode bytes.
' ========================================================================================
FUNCTION AfxUCode (BYREF strIn AS STRING) AS STRING
IF VARPTR(strIn) = 0 OR LEN(strIn) = 0 THEN EXIT FUNCTION
IF IsTextUnicode(STRPTR(strIn), LEN(strIn), NULL) = 1 THEN FUNCTION = strIn : EXIT FUNCTION
DIM buffer AS STRING = SPACE(LEN(strIn) * 2)
DIM nLen AS LONG = MultiByteToWidechar(CP_ACP, MB_PRECOMPOSED, STRPTR(strIn), -1, CAST(WSTRING PTR, STRPTR(buffer)), LEN(buffer))
FUNCTION = buffer
END FUNCTION
' ========================================================================================
' ========================================================================================
' Translates unicode bytes into ansi bytes.
' ========================================================================================
FUNCTION AfxACode (BYREF strIn AS STRING) AS STRING
IF VARPTR(strIn) = 0 OR LEN(strIn) = 0 THEN EXIT FUNCTION
IF IsTextUnicode(STRPTR(strIn), LEN(strIn), NULL) = 0 THEN FUNCTION = strIn : EXIT FUNCTION
DIM buffer AS STRING = SPACE(LEN(strIn) \ 2)
DIM nLen AS LONG = WidecharToMultiByte(CP_ACP, 0, CAST(WSTRING PTR, STRPTR(strIn)), -1, STRPTR(buffer), LEN(buffer), NULL, NULL)
FUNCTION = buffer
END FUNCTION
' ========================================================================================
Now I can write this:
' ========================================================================================
' Returns the complete drive, path, file name, and extension of the program which is
' currently executing.
' ========================================================================================
FUNCTION AfxGetExePathNameA () AS STRING
DIM buffer AS STRING * MAX_PATH + 1
GetModuleFileNameA NULL, STRPTR(buffer), LEN(buffer)
DIM p AS LONG = INSTRREV(buffer, ANY ":/\")
FUNCTION = LEFT(buffer, p)
END FUNCTION
' ========================================================================================
' ========================================================================================
FUNCTION AfxGetExePathNameW () AS STRING
DIM buffer AS WSTRING * MAX_PATH
GetModuleFileNameW NULL, buffer, SIZEOF(buffer)
DIM p AS LONG = INSTRREV(buffer, ANY ":/\")
FUNCTION = AfxUcode(LEFT(buffer, p))
END FUNCTION
' ========================================================================================
AfxGetExePathNameW will return an ansi string with unicode contents. The trick is to use AfxUcode when returning the string to bypass the FB automatic conversion to ansi (in the above code, FUNCTION = AfxUcode(LEFT(buffer, p))). AfxUcode checks if the string is already in unicode format to no convert a unicode string to unicode again.
These ansi strings with unicode content can be used in place of BSTRs when calling API functions that require a BSTR, as we did with PowerBasic 9, passing the STRPTR of the variable.
This way, we don't need to worry about having to free the BSTRs.
There is a problem. Like with PB 9, the parameter of the function must be declared as STRING instead of BSTR.
This is a show stopper because we aren't going to change the declares.
Quote from: Jose Roca on May 11, 2016, 07:35:43 AM
There is a problem. Like with PB 9, the parameter of the function must be declared as STRING instead of BSTR.
This is a show stopper because we aren't going to change the declares.
Hi Jose,
Which function are you talking about here? Is there a possibility of overloading the function call and then call the string function?
Here is something that appears to work. I just simply picked SysAllocString as an example.
#Include Once "windows.bi"
Type BSTR As OLECHAR Ptr
Declare Function SysAllocString Overload ( ByVal myValue As Long ) As BSTR
#Include Once "win/ole2.bi"
Function SysAllocString( ByVal myValue As Long ) As BSTR
Function = SysAllocString(Str(myValue))
End Function
Dim pbstr As BSTR
pbstr = SysAllocString("This is a test")
Print *cast(wstring ptr, pbstr)
SysFreeString(pbstr)
pbstr = SysAllocString(999)
Print *Cast(WString Ptr, pbstr)
SysFreeString(pbstr)
Print "press esc"
Sleep
> Which function are you talking about here?
Any function that has a wide string parameter. If we pass to it an ansi string containing unicode characters, FB only sees that the type of the passeed string is ansi and converts it to unicode again.
Example:
SUB foo (BYVAL b AS WSTRING PTR)
print *b; "..."
END SUB
foo(AfxUcode("pepe"))
The only way that works is to return a pointer to a BSTR or a WSTRING and then free it.
If you pass it BYVAL b AS CONST WSTRING PTR, will FB do any conversion?
..... it probably will. CONST only keeps the pointer from not being modified and not the string it points to (I assume).
Or,
FUNCTION AfxUCode (BYREF strIn AS CONST STRING) AS STRING
It isn't worth the effort. With PB9 we could use strings in combination with UCODE$ and ACODE$ because they are BSTRs with ansi contents. This is the opposite, ASCIIZ strings with unicode content. Therefore, we can't use them with parameters that will receive a BSTR. And using one method when we want to pass a BSTR and another when we will receive a BSTR is not consistent.
We have tried, but if it can't be, it can't be. If FB does not implement native BSTR support, we will have to use the BSTR API and allocate and free the strings.
I have tried the new way to declare interfaces and works fine. They should use it in the headers besides the already existing ones of VTable and macros.
Will do more testing when they fix the broken headers.
Thanks Jose, I haven't followed all the cases where you need to pass a BSTR or receive a BSTR. However, I was thinking about your AfxUCode function and thought that maybe if you made it so you just passed it a pointer to the string and a length then it would be generic enough to handle any type of string passed to it?
' ========================================================================================
' Translates ansi bytes into unicode bytes.
' ========================================================================================
Function AfxUCode (ByVal strIn As Any Ptr, ByVal strLength As Long) As String
If strIn = 0 Or strLength = 0 Then Exit Function
Dim buffer As String = Space(strLength * 2)
If IsTextUnicode(strIn, strLength, Null) = 1 Then
Print "already unicode"
' String is already unicode
memcpy(Strptr(buffer), strIn, strLength * 2)
Else
' String is not unicode. Do the conversion.
Print "convert to unicode"
Dim nLen As Long = MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, Cast(ZString Ptr, strIn), -1, Strptr(buffer), Len(buffer))
End If
Function = buffer
End Function
Dim As String st = "This is a test"
Print AfxUCode( Strptr(st), Len(st) )
Dim wst As WString * 10 = "Paul"
Print AfxUCode( Strptr(wst), Len(wst) )
Print "press esc"
Sleep
The purpose of these functions was to try something as we did with PB9. Otherwise, it is not needed.
The more satisfactory method is the CBStr class that I wrote, although can't be used to create temporary BSTRs on the fly because of memory leaks.
Another question are variants. We can use a class or procedures. Private procedures have the advantage of dead code removal and the disadvantage of not freeing the variant automatically.
'#define unicode
#INCLUDE ONCE "win/ole2.bi"
' ========================================================================================
' Initializes a variant from a string.
' ========================================================================================
PRIVATE FUNCTION VarFromStr OVERLOAD (BYVAL pwsz AS WSTRING PTR) AS VARIANT
DIM v AS VARIANT
VariantInit(@v)
V_VT(@v) = VT_BSTR
V_BSTR(@v) = SysAllocString(pwsz)
FUNCTION = v
VariantClear(@v)
END FUNCTION
' ========================================================================================
' ========================================================================================
PRIVATE SUB VarFromStr OVERLOAD (BYVAL pvar AS VARIANT PTR, BYVAL pwsz AS WSTRING PTR)
IF pvar = NULL THEN EXIT SUB
VariantClear(pvar)
V_VT(pvar) = VT_BSTR
V_BSTR(pvar) = SysAllocString(pwsz)
END SUB
' ========================================================================================
PRIVATE SUB VarFromStr OVERLOAD (BYREF v AS VARIANT, BYVAL pwsz AS WSTRING PTR)
IF VARPTR(v) = NULL THEN EXIT SUB
VariantClear(@v)
V_VT(@v) = VT_BSTR
V_BSTR(@v) = SysAllocString(pwsz)
END SUB
' ========================================================================================
DIM v AS VARIANT
v = VarFromStr("Athens")
print *CAST(WSTRING PTR, v.bstrVal)
VarFromStr(@v, "Paris")
print *CAST(WSTRING PTR, v.bstrVal)
VarFromStr(v, "Rome")
print *CAST(WSTRING PTR, v.bstrVal)
VariantClear(@v)
print
print "press esc"
Sleep
Another COM example: Embedded Explorer Browser control.
' ########################################################################################
' Microsoft Windows
' File: CW_ExplorerBrowser.fbtpl
' Contents: Resizable CWindow with an embedded Explorer Browser 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 _WIN32_WINNT &h0602
#INCLUDE ONCE "windows.bi"
#INCLUDE ONCE "win/shlobj.bi"
#INCLUDE ONCE "Afx/CWindow.inc"
USING Afx.CWindowClass
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)
' ========================================================================================
' Window procedure
' ========================================================================================
FUNCTION WndProc (BYVAL hWnd AS HWND, BYVAL uMsg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM) AS LRESULT
DIM pWindow AS CWindow PTR, rc AS RECT
STATIC peb AS IExplorerBrowser PTR
SELECT CASE uMsg
CASE WM_CREATE
' // Get a pointer to the CWindow class
DIM pCreateStruct AS CREATESTRUCT PTR = CAST(CREATESTRUCT PTR, lParam)
DIM pWindow AS CWindow PTR = CAST(CWindow PTR, pCreateStruct->lpCreateParams)
' // Add a button control
IF pWindow THEN pWindow->AddControl("Button", hwnd, IDCANCEL, "&Close")
' // Create an instance of IExplorerBrowser
CoCreateInstance(@CLSID_ExplorerBrowser, NULL, CLSCTX_INPROC_SERVER, @IID_IExplorerBrowser, @peb)
IF peb = NULL THEN EXIT FUNCTION
peb->lpVtbl->SetOptions(peb, EBO_SHOWFRAMES)
DIM fs AS FOLDERSETTINGS
fs.ViewMode = FVM_DETAILS
DIM rc AS RECT
GetClientRect hwnd, @rc
peb->lpVtbl->Initialize(peb, hwnd, @rc, @fs)
' // Navigate to the Profile folder
DIM pidlBrowse AS LPITEMIDLIST
IF SUCCEEDED(SHGetFolderLocation(NULL, CSIDL_PROFILE, NULL, 0, @pidlBrowse)) THEN
peb->lpVtbl->BrowseToIDList(peb, pidlBrowse, 0)
ILFree(pidlBrowse)
END IF
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_SIZE
IF wParam <> SIZE_MINIMIZED THEN
' // Resize the controls
pWindow = CAST(CWindow PTR, GetWindowLongPtr(hwnd, 0))
pWindow->MoveWindow GetDlgItem(hwnd, IDCANCEL), pWindow->ClientWidth - 90, pWindow->ClientHeight - 35, 75, 23, CTRUE
' // Resize the Explorer control
GetClientRect hwnd, @rc
rc.Right -= 210
IF peb THEN peb->lpVtbl->SetRect(peb, NULL, rc)
END IF
CASE WM_DESTROY
IF peb THEN
' // Destroy the browser and release the interface
peb->lpVtbl->Release(peb)
peb->lpVtbl->Release(peb)
END IF
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
' // Initialize the COM library
CoInitialize NULL
DIM pWindow AS CWindow
pWindow.Create(NULL, "CWindow with an embedded Explorer Browser", @WndProc)
pWindow.Brush = GetStockObject(WHITE_BRUSH)
pWindow.SetClientSize(500, 320)
pWindow.Center
FUNCTION = pWindow.DoEvents(nCmdShow)
' // Uninitialize the COM library
CoUninitialize
END FUNCTION
' ========================================================================================
Quote from: Jose Roca on May 12, 2016, 12:36:20 AM
The more satisfactory method is the CBStr class that I wrote, although can't be used to create temporary BSTRs on the fly because of memory leaks.
Hi Jose, I am at work right now so I am only reading your posts and can't do much with them at the moment. Question: Couldn't the CBStr class simply clean up any allocated memory (from SysAllocString?) in the class's DESTRUCTOR. When the class goes out of scope the Destructor should be called and then the allocated memory freed?
I don't know if this is feasable but BCX,bc9 use a circular buffer for temporary strings:
#ifndef BCXTmpStrSize
#define BCXTmpStrSize 2048
#endif
char *BCX_TmpStr (size_t Bites, size_t iPad, int iAlloc)
{
static int StrCnt;
static char *StrFunc[BCXTmpStrSize];
StrCnt = (StrCnt + 1) & (BCXTmpStrSize - 1);
if(StrFunc[StrCnt]) {
free (StrFunc[StrCnt]);
StrFunc[StrCnt] = NULL;
}
#if defined BCX_MAX_VAR_SIZE
if(Bites * sizeof(char) > BCX_MAX_VAR_SIZE)
{
printf("Buffer Overflow caught in BCX_TmpStr - requested space of %d EXCEEDS %d\n", (int)(Bites * sizeof(char)), BCX_MAX_VAR_SIZE);
abort();
}
#endif
if(iAlloc) StrFunc[StrCnt] = (char*)calloc(Bites + iPad + 1, sizeof(char));
return StrFunc[StrCnt];
}
Called from the internal LEFT$ function like this:
char *left (const char *S, int length)
{
register int tmplen = strlen(S);
if(length < 1) return BCX_TmpStr(1, 0, 1);
if(length < tmplen) tmplen = length;
char *strtmp = BCX_TmpStr(tmplen, 1, 1);
return (char*)memcpy(strtmp, S, tmplen);
}
James
Speaking about COM code with the abstract interfaces, I do what you do today of then more than Two years, your reputation will make perhaps change the things.
So that that things goes more quickly , looks at what I did in FREEBASIC forum , inside COM with feebasic, other share I have tons of code for this purpose.
Considering what you did with POWERBASIC, it is an honor which you makes it with FREEBASIC, I same already translated your comBrowsher into Freebasic.
your web container don't work for me
look at this small api code:
#include Once "windows.bi"
#include Once "win/ole2.bi"
#Include Once "win/ExDisp.bi"
Extern "windows" lib "atl"
Declare Function AtlAxAttachControl(As IUnknown Ptr, As HWND,As IUnknown Ptr Ptr) As HRESULT
End Extern
Dim Shared As HWND hconteneur ' Déclaration du HWND de notre conteneur en global:
Function WndProc(hWnd As HWND ,msg As UINT ,wParam As WPARAM ,lParam As LPARAM )As LRESULT
Select Case(msg)
case WM_SIZE:
' Redimensionnement du conteneur quand la taille de la fenêtre change:
MoveWindow(hconteneur,0,0,LOWORD(lParam), HIWORD(lParam),1)
case WM_CLOSE:
DestroyWindow(hWnd)
case WM_DESTROY:
PostQuitMessage(0)
Return 0
Case Else:
return DefWindowProc(hWnd, msg, wParam, lParam)
End Select
return 0
End Function
Function WinMain(hInst As HINSTANCE ,hPreInst As HINSTANCE ,lpszCmdLine As LPSTR , nCmdShow As Integer )As Integer
' Déclarer notre classe de fenêtre et définir ses membres:
Dim As WNDCLASS wc
Dim As ZString ptr NomClasse = @"Conteneur"
wc.lpszClassName = NomClasse
wc.hInstance = hInst
wc.lpfnWndProc = @WndProc
wc.hCursor = LoadCursor( 0, IDC_ARROW )
wc.hIcon = LoadIcon( 0, IDI_APPLICATION )
wc.lpszMenuName = 0
wc.hbrBackground = 0
wc.style = 0
wc.cbClsExtra = 0
wc.cbWndExtra = 0
' Enregistrer la classe de notre fenêtre:
if (0=RegisterClass(@wc))Then return 0
' Créer notre fenêtre principale:
Dim As HWND hWnd = CreateWindow( NomClasse,"Conteneur Activex",WS_OVERLAPPEDWINDOW,0,0,800,575, 0, 0, hInst,0)
' Montrer la fenêtre:
ShowWindow(hWnd, nCmdShow )
UpdateWindow( hWnd )
' Obtenir les dimensions de notre fenêtre:
Dim As RECT rect
GetClientRect(hWnd,@rect)
' Créer l'EDIT qui servira de conteneur Activex:
hconteneur=CreateWindowEx(WS_EX_CLIENTEDGE,"EDIT","",WS_CHILD Or WS_VISIBLE,0,0,rect.right,rect.bottom,hWnd,0,0,0)
' Initialiser la librairie COM pour notre programme:
CoInitialize(0)
' Déclarer un pointeur sur l'interface IWebBrowser2:
Dim As IWebBrowser2 Ptr pIwb
' Créer une instance de l'objet WebBrowser et de l'interface IWebBrowser2:
CoCreateInstance(@CLSID_WebBrowser,0,CLSCTX_ALL,@IID_IWebBrowser2,cast(lpvoid Ptr,@pIwb))
' Attacher l'objet WebBrowser à notre EDIT conteneur:
AtlAxAttachControl(pIwb,hconteneur,0)
' Lancer la page de démarrage:
pIwb->lpvtbl->GoHome(pIwb)
' Boucle des messages:
Dim As MSG Msg
while( GetMessage(@Msg, 0, 0, 0))
TranslateMessage( @Msg )
DispatchMessage( @Msg )
Wend
' Libérer l'interface IWebBrowser2:
pIwb->lpvtbl->Release(pIwb)
' Fermer la librairie COM pour notre programme:
CoUninitialize()
' Quitter le programme:
return Msg.wParam
End Function
End WinMain(getmodulehandle(0),NULL,Command,SW_SHOW)
If you did it more that two years ago, they should have used it in the translated headers and explained it in the help file.
Looking at the C++ headers, we can see that they have declaratons for C++, ansi C and macros:
EXTERN_C const IID IID_IMalloc;
#if defined(__cplusplus) && !defined(CINTERFACE)
MIDL_INTERFACE("00000002-0000-0000-C000-000000000046")
IMalloc : public IUnknown
{
public:
virtual void *STDMETHODCALLTYPE Alloc(
/* [annotation][in] */
__in SIZE_T cb) = 0;
virtual void *STDMETHODCALLTYPE Realloc(
/* [annotation][in] */
__in_opt void *pv,
/* [annotation][in] */
__in SIZE_T cb) = 0;
virtual void STDMETHODCALLTYPE Free(
/* [annotation][in] */
__in_opt void *pv) = 0;
virtual SIZE_T STDMETHODCALLTYPE GetSize(
/* [annotation][in] */
__in_opt void *pv) = 0;
virtual int STDMETHODCALLTYPE DidAlloc(
/* [annotation][in] */
__in_opt void *pv) = 0;
virtual void STDMETHODCALLTYPE HeapMinimize( void) = 0;
};
#else /* C style interface */
typedef struct IMallocVtbl
{
BEGIN_INTERFACE
HRESULT ( STDMETHODCALLTYPE *QueryInterface )(
IMalloc * This,
/* [in] */ REFIID riid,
/* [annotation][iid_is][out] */
__RPC__deref_out void **ppvObject);
ULONG ( STDMETHODCALLTYPE *AddRef )(
IMalloc * This);
ULONG ( STDMETHODCALLTYPE *Release )(
IMalloc * This);
void *( STDMETHODCALLTYPE *Alloc )(
IMalloc * This,
/* [annotation][in] */
__in SIZE_T cb);
void *( STDMETHODCALLTYPE *Realloc )(
IMalloc * This,
/* [annotation][in] */
__in_opt void *pv,
/* [annotation][in] */
__in SIZE_T cb);
void ( STDMETHODCALLTYPE *Free )(
IMalloc * This,
/* [annotation][in] */
__in_opt void *pv);
SIZE_T ( STDMETHODCALLTYPE *GetSize )(
IMalloc * This,
/* [annotation][in] */
__in_opt void *pv);
int ( STDMETHODCALLTYPE *DidAlloc )(
IMalloc * This,
/* [annotation][in] */
__in_opt void *pv);
void ( STDMETHODCALLTYPE *HeapMinimize )(
IMalloc * This);
END_INTERFACE
} IMallocVtbl;
interface IMalloc
{
CONST_VTBL struct IMallocVtbl *lpVtbl;
};
#ifdef COBJMACROS
#define IMalloc_QueryInterface(This,riid,ppvObject) \
( (This)->lpVtbl -> QueryInterface(This,riid,ppvObject) )
#define IMalloc_AddRef(This) \
( (This)->lpVtbl -> AddRef(This) )
#define IMalloc_Release(This) \
( (This)->lpVtbl -> Release(This) )
#define IMalloc_Alloc(This,cb) \
( (This)->lpVtbl -> Alloc(This,cb) )
#define IMalloc_Realloc(This,pv,cb) \
( (This)->lpVtbl -> Realloc(This,pv,cb) )
#define IMalloc_Free(This,pv) \
( (This)->lpVtbl -> Free(This,pv) )
#define IMalloc_GetSize(This,pv) \
( (This)->lpVtbl -> GetSize(This,pv) )
#define IMalloc_DidAlloc(This,pv) \
( (This)->lpVtbl -> DidAlloc(This,pv) )
#define IMalloc_HeapMinimize(This) \
( (This)->lpVtbl -> HeapMinimize(This) )
#endif /* COBJMACROS */
#endif /* C style interface */
But in FB the headers, only the ansi C interface and the macros are translated, so I first thought that the C++ way was not possible. Then I saw a post in wich you were using DECLARE ABSTRACT FUNCTION and began to investigate and try...
Frankly, it does not make sense to translate the C interfaces and macros and skip the C++ way, which makes its use easier.
> your web container don't work for me
If you mean the YouTube example, it works fine in my computer, but the old ATL.DLL that comes as a system DLL with Windows does not work very well. I plan to adapt my OLE container later...
> Question: Couldn't the CBStr class simply clean up any allocated memory (from SysAllocString?) in the class's DESTRUCTOR. When the class goes out of scope the Destructor should be called and then the allocated memory freed?
It does it, of course. But there are situations which only native support from the compiler could solve.
If I have two BSTRs, a and b, and want to concatenate them with an overloaded & operator...
It will work if I assign the resulting new string to another instance of the CBStr class, e.g. cb = a & b.
It also will work if I assign the result to another new BSTR, e.g. c = a & b, and later I free c with SysFreeString, but if c already has contents, I will get a memory leak unless I first free it.
I will also get memory leaks if I intend to pass the new resulting string to a function without first assigning it to another BSTR and passing this third string, e.g.
c = a & b
Foo(c)
will work
but using Foo (a & b) will leak.
> I don't know if this is feasable but BCX,bc9 use a circular buffer for temporary strings:
The compiler can know if the resulting string is temporary, i.e. it is not assigned to another variable, or not and free it, but the class doesn't know how it is going to be used.
To call COM API functions and methods we only need SysAllocString and SysFreeString. Without support of the compiler, it will be not be a good choice for those that need unicode.
Quote from: Jose Roca on May 12, 2016, 01:23:38 PM
I will also get memory leaks if I intend to pass the new resulting string to a function without first assigning it to another BSTR and passing this third string, e.g.
c = a & b
Foo(c)
will work
but using Foo (a & b) will leak.
I haven't created a test case yet but in my mind I am not seeing why that case described above would leak memory. Wouldn't the logic be something like this:
- Create "a" CBSTR.
- Create "b" CBSTR
- Pass "a + b" to function Foo. Foo accepts the concatenation and stores it in object "c". At this point, memory is being held for "a", "b" and "c".
- Foo() does whatever it needs to do and eventually returns from that function call. "c" goes out of scope at that point and is automatically destroyed/freed.
- "a" and "b" are now freed when they go out of scope (ie. the program ends or the function that "a" and "b" may be in is eventually exited.
Function MySub() As Long
Dim a As CBStr = "A String"
Dim b As CBStr = "B String"
Foo( a & b )
'<--- "a" and "b" are freed as MySub() ends
End Function
Function Foo( c As CBSTR ) As Long
' <--- "c" is freed when function returns
End Function
> ' <--- "c" is freed when function returns
I don't think so, and much less if you are passing a & b to an API function.
Attached is a version of CBStr.inc in which I have changed the BSTR type for AFX_BSTR; otherwise, it won't work with the latest FB headers.
This code demonstrates the leak problem.
SUB Foo (BYVAL b AS AFX_BSTR)
PRINT *b
END SUB
If I assign the result of concatenating two BSTRs (in the example both bs1 and bs2 are of the type CBStr, but they can be other types or even literals)
DIM bs1 AS CBStr = "Text"
DIM bs2 AS CBStr = "string"
DIM bs3 AS CBStr = bs1 & bs2
Foo *bs3
then it works fine because the resulting new BSTR is assigned to a variable of the type CBStr that will free the memory when it goes out of scope.
But if I use
Foo bs1 & bs2
The resulting new BSTR is never freed.
Also, if I use
DIM bs1 AS CBStr = "Text"
DIM bs2 AS CBStr = "string"
DIM bs3 AS CBStr = bs1 & " " & bs2
Foo *bs3
there is also a leak because the operation generates two new temporary BSTRs, the first one by bs1 & " " and the second one by the result of bs1 & " " and <result> & bs2, but only the second is assigned to bs3 and, therefore, the temporary string generated by bs1 & " " will be never freed.
To avoid the leak, I will have to use
DIM bs1 AS CBStr = "Text"
DIM bs2 AS CBStr = "string"
DIM bs3 AS CBStr = bs1 & " "
DIM bs4 AS CBStr = bs3 & bs2
Foo *bs3
The other problem is to known if when you assign a pointer to a variable of type CBStr, this pointer if to a real BSTR or not. I'm using a trick.
' ========================================================================================
OPERATOR CBStr.Let (BYREF bstrHandle AS AFX_BSTR)
IF bstrHandle = NULL THEN EXIT OPERATOR
' Free the current OLE string
IF m_bstr THEN SysFreeString(m_bstr)
' Detect if the passed handle is an OLE string
' If it is an OLE string it must have a descriptor; otherwise, don't
' Get the length looking at the descriptor
DIM res AS INTEGER = PEEK(DWORD, CAST(ANY PTR, bstrHandle) - 4) \ 2
' If the retrieved length if the same that the returned by LEN, then it must be an OLE string
IF res = .LEN(*bstrHandle) THEN
' Attach the passed handle to the class
m_bstr = bstrHandle
ELSE
' Allocate an OLE string with the contents of the string pointer by bstrHandle
m_bstr = SysAllocString(*bstrHandle)
END IF
END OPERATOR
' ========================================================================================
Thanks Jose, I just downloaded the new class and I am now working through your code in your post above in order to understand the points of the memory leak. I will post again when I am fully knowledgeable.
The ones that can generate memory leaks are these that return a BSTR, i.e. the & and + overloaded operators.
The only way is to remove the Concat function and the & and + operators.
We can still do string concatenation this way:
SUB Foo (BYVAL b AS AFX_BSTR)
PRINT *b
END SUB
DIM bs1 AS CBStr = "Text"
DIM bs2 AS CBStr = "string"
DIM bs3 AS CBStr = **bs1 & " " & **bs2
Foo *bs3
Quote from: Jose Roca on May 13, 2016, 10:26:39 AM
The ones that can generate memory leaks are these that return a BSTR, i.e. the & and + overloaded operators.
Yes, it FINALLY clicked in for me once I wrote some test code and followed the logic through. :)
You are passing two OBJECTS to Foo and concatenating their strings via the & operator. The concatenation function returns an AFX_BSTR (basically a wstring ptr with manually allocated memory via SysAllocStringLen). The problem then is that the AFX_BSTR will never be freed because it is never tracked nor is it an object that can have a Destructor called).
It does seem like this is a situation where the compiler needs to handle the tracking of the creation and deleting of the BSTR. That is, the same way the compiler tracks allocated internal FBSTRING types. I doubt that will be added to the compiler anytime soon.
I can't think of a solution around this(?)
We can do string concatenation without memory leaks using
DIM bs3 AS CBStr = **bs1 & " " & **bs2
A little weird syntax, but...
No wonder the CComBstr class of Microsoft Fundation Classes does not have string concatenation.
Only the compiler can deal with the intermediate temporary strings.
I have added the operator @. It allows to pass the address of the BSTR pointer (m_bstr) to a function (OUT parameter). As the address is manipulated directly, we must first set it to empty if it has contents to avoid memory leaks. To set it to empty, just assign an empty string to it, i.e. bs = "".
' ========================================================================================
' Returns the address of the BSTR
' ========================================================================================
OPERATOR CBStr.@ () AS AFX_BSTR PTR
OPERATOR = @m_bstr
END OPERATOR
' ========================================================================================
Usage example:
SUB Foo (BYVAL b AS AFX_BSTR PTR)
*b = SysAllocString("xxxxx")
END SUB
DIM bs AS CBStr
Foo @bs
print **bs
Well, I think that now the class is fully usable. We still need to use double indirection to print the contents of the BSTR (**bs) because the current version of the compiler does not support the * operator as a member of the class. It is in the TODO list.
We can declare "A" and "W" functions as follows:
' ========================================================================================
' Returns the path of the program that is currently executing.
' Contrarily to the Free Basic ExePath function, it includes a trailing "\".
' ========================================================================================
PRIVATE FUNCTION AfxGetExePathA () AS STRING
DIM buffer AS STRING * MAX_PATH + 1
GetModuleFileNameA NULL, STRPTR(buffer), LEN(buffer)
DIM p AS LONG = INSTRREV(buffer, ANY ":/\")
FUNCTION = LEFT(buffer, p)
END FUNCTION
' ========================================================================================
' ========================================================================================
PRIVATE FUNCTION AfxGetExePathW () AS AFX_BSTR
DIM buffer AS WSTRING * MAX_PATH
GetModuleFileNameW NULL, @buffer, SIZEOF(buffer)
DIM p AS LONG = INSTRREV(buffer, ANY ":/\")
DIM bs AS AFX_BSTR = SysAllocString(LEFT(buffer, p))
FUNCTION = bs
END FUNCTION
' ========================================================================================
#ifndef UNICODE
#define AfxGetExePath AfxGetExePathA
#else
#define AfxGetExePath AfxGetExePathW
#endif
Usage of the "W" version:
DIM bs AS CBStr = AfxGetExePathW
print **bs
Usage example without assigning the returned handle to an instance of the class.
DIM b AS AFX_BSTR = AfxGetExePathW
print *b
SysFreeString b
Quote from: Petrus Vorster on May 10, 2016, 01:51:43 PM
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...
I think what I will do as an interim step will be to create a small utility that will read a FireFly frm file and create the necessary cWindow code. Allow that code to be copied to the clipboard so that you can paste it into your editor. This will allow us to use FireFly to visually create a form while still be able to have access to the underlying cWindow code that could be used to create that form.
EDIT: Added - this utility is just about complete. Just need to do some testing and then I will post it.
EDIT: Added - utility is now available at: http://www.planetsquires.com/protect/forum/index.php?topic=3834.msg28038
josé
for CBSTR ,I have to add a constructor, operator let and cast for the BSTR
your method is not badly, but there is simpler with my method
to see widestring.bi and its test
#pragma once
#include once "windows.bi"
#include once "win/ole2.bi"
#Include once "win/shlwapi.bi"
#ifndef AFX_BSTR
#define AFX_BSTR WSTRING PTR
#endif
NAMESPACE Afx.CBStrClass
' ========================================================================================
' CBStr - OLE strings class
' ========================================================================================
TYPE CBStr
Private:
m_bstr AS AFX_BSTR
Public:
DECLARE CONSTRUCTOR (BYREF wszStr AS CONST WSTRING = "")
DECLARE CONSTRUCTOR (BYREF szStr AS STRING = "")
DECLARE CONSTRUCTOR (BYREF pCBStr AS CBStr)
DECLARE CONSTRUCTOR (BYREF bstrHandle AS AFX_BSTR = NULL)
DECLARE CONSTRUCTOR (BYVAL pCBStr AS BSTR)
DECLARE DESTRUCTOR
DECLARE OPERATOR Let (BYREF szStr AS STRING)
DECLARE OPERATOR Let (BYREF wszStr AS CONST WSTRING)
DECLARE OPERATOR Let (BYREF pCBStr AS CBStr)
DECLARE OPERATOR Let (BYREF bstrHandle AS AFX_BSTR)
DECLARE OPERATOR Let (BYVAL pBStr AS BSTR)
DECLARE OPERATOR += (BYREF wszStr AS CONST WSTRING)
DECLARE OPERATOR += (BYREF pCBStr AS CBStr)
DECLARE OPERATOR &= (BYREF wszStr AS CONST WSTRING)
DECLARE OPERATOR &= (BYREF pCBStr AS CBStr)
DECLARE PROPERTY Handle () AS AFX_BSTR
DECLARE SUB Append (BYREF wszStr AS CONST WSTRING)
DECLARE FUNCTION Concat (BYREF wszStr2 AS CONST WSTRING, BYREF wszStr2 AS CONST WSTRING) AS AFX_BSTR
DECLARE OPERATOR cast() AS String
DECLARE OPERATOR cast() AS BSTR
END TYPE
' ========================================================================================
' ========================================================================================
' CBStr class constructor
' ========================================================================================
CONSTRUCTOR CBStr (BYREF wszStr AS CONST WSTRING = "")
m_bstr = SysAllocString(wszStr)
END CONSTRUCTOR
' ========================================================================================
' ========================================================================================
CONSTRUCTOR CBStr (BYREF szStr AS STRING = "")
m_bstr = SysAllocString(WSTR(szStr))
END CONSTRUCTOR
' ========================================================================================
' ========================================================================================
CONSTRUCTOR CBStr (BYREF pCBStr AS CBStr)
m_bstr = SysAllocString(*pCBStr.Handle)
END CONSTRUCTOR
' ========================================================================================
' ========================================================================================
CONSTRUCTOR CBStr (BYREF bstrHandle AS AFX_BSTR = NULL)
IF bstrHandle = NULL THEN
m_bstr = SysAllocString("")
ELSE
' Detect if the passed handle is an OLE string
' If it is an OLE string it must have a descriptor; otherwise, don't
' Get the length looking at the descriptor
DIM res AS INTEGER = PEEK(DWORD, CAST(ANY PTR, bstrHandle) - 4) \ 2
' If the retrieved length if the same that the returned by LEN, then it must be an OLE string
IF res = .LEN(*bstrHandle) THEN
' Free the current OLE string and attach the passed handle to the class
m_bstr = bstrHandle
ELSE
' Allocate an OLE string with the contents of the string pointer by bstrHandle
m_bstr = SysAllocString(*bstrHandle)
END IF
END IF
END CONSTRUCTOR
CONSTRUCTOR CBStr(BYVAL pCBStr AS BSTR)
m_bstr =Cast(WString Ptr,pCBStr)
End Constructor
' ========================================================================================
' CBStr class destructor
' ========================================================================================
DESTRUCTOR CBStr
IF m_bstr THEN SysFreeString m_bstr
END DESTRUCTOR
' ========================================================================================
' ========================================================================================
' Assigns new text to the BSTR
' Note: We can also pass a FB ansi string (the conversion to Unicode is automatic)
' ========================================================================================
OPERATOR CBStr.Let (BYREF wszStr AS CONST WSTRING)
IF m_bstr THEN SysFreeString(m_bstr)
m_bstr = SysAllocString(wszStr)
END OPERATOR
' ========================================================================================
' ========================================================================================
OPERATOR CBStr.Let (BYREF szStr AS STRING)
IF m_bstr THEN SysFreeString(m_bstr)
m_bstr = SysAllocString(WSTR(szStr))
END OPERATOR
' ========================================================================================
' ========================================================================================
OPERATOR CBStr.Let (BYREF pCBStr AS CBStr)
IF m_bstr THEN SysFreeString(m_bstr)
m_bstr = SysAllocString(*pCBStr.Handle)
END OPERATOR
' ========================================================================================
' ========================================================================================
OPERATOR CBStr.Let (BYREF bstrHandle AS AFX_BSTR)
IF bstrHandle = NULL THEN EXIT OPERATOR
' Free the current OLE string
IF m_bstr THEN SysFreeString(m_bstr)
' Detect if the passed handle is an OLE string
' If it is an OLE string it must have a descriptor; otherwise, don't
' Get the length looking at the descriptor
DIM res AS INTEGER = PEEK(DWORD, CAST(ANY PTR, bstrHandle) - 4) \ 2
' If the retrieved length if the same that the returned by LEN, then it must be an OLE string
IF res = .LEN(*bstrHandle) THEN
' Attach the passed handle to the class
m_bstr = bstrHandle
ELSE
' Allocate an OLE string with the contents of the string pointer by bstrHandle
m_bstr = SysAllocString(*bstrHandle)
END IF
END OPERATOR
OPERATOR CBStr.Let (BYVAL szStr AS BSTR)
IF m_bstr THEN SysFreeString(m_bstr)
m_bstr = Cast(WString Ptr,szStr)
END Operator
OPERATOR CBStr.cast() AS String
Return *m_bstr
End Operator
OPERATOR CBStr.cast() AS BSTR
Return Cast(BSTR,m_bstr)
End Operator
' ========================================================================================
' Returns the handle of the BSTR
' ========================================================================================
PROPERTY CBStr.Handle () AS AFX_BSTR
PROPERTY = m_bstr
END PROPERTY
' ========================================================================================
' ========================================================================================
' Appends a string to the BSTR. The string can be a literal or a FB STRING or WSTRING variable.
' To append another BSTR:
' DIM bs1 AS CBStr = "1st string"
' DIM bs2 AS CBStr = "2nd string"
' bs1.Append *bs2.Handle
' -or-
' bs1.Append **bs2
' ========================================================================================
SUB CBStr.Append (BYREF wszStr AS CONST WSTRING)
DIM n1 AS UINT = SysStringLen(m_bstr)
DIM nLen AS UINT = .LEN(wszStr)
IF nLen = 0 THEN EXIT SUB
DIM b AS AFX_BSTR = SysAllocStringLen(NULL, n1+nLen)
IF b = NULL THEN EXIT SUB
memcpy(b, m_bstr, n1 * SIZEOF(WSTRING))
memcpy(b+n1, @wszStr, nLen * SIZEOF(WSTRING))
SysFreeString(m_bstr)
m_bstr = b
END SUB
' ========================================================================================
' ========================================================================================
' Appends a string to the BSTR. The string can be a literal or a FB STRING or WSTRING variable.
' ========================================================================================
OPERATOR CBStr.+= (BYREF wszStr AS CONST WSTRING)
this.Append(wszStr)
END OPERATOR
' ========================================================================================
' ========================================================================================
' Appends a BSTR to the BSTR.
' ========================================================================================
OPERATOR CBStr.+= (BYREF pCBStr AS CBStr)
this.Append(*pCBStr.Handle)
END OPERATOR
' ========================================================================================
' ========================================================================================
' Appends a string to the BSTR. The string can be a literal or a FB STRING or WSTRING variable.
' ========================================================================================
OPERATOR CBStr.&= (BYREF wszStr AS CONST WSTRING)
this.Append(wszStr)
END OPERATOR
' ========================================================================================
' ========================================================================================
' Appends a BSTR to the BSTR.
' ========================================================================================
OPERATOR CBStr.&= (BYREF pCBStr AS CBStr)
this.Append(*pCBStr.Handle)
END OPERATOR
' ========================================================================================
' ========================================================================================
' Returns vbTrue (-1) if the two BSTRings are equal; FALSE, otherwise.
' ========================================================================================
OPERATOR = (BYREF pCBStr1 AS CBStr, BYREF pCBStr2 AS CBStr) AS INTEGER
OPERATOR = StrCmpW(*pCBStr1.Handle, *pCBStr2.Handle) = 0
END OPERATOR
' ========================================================================================
' ========================================================================================
OPERATOR = (BYREF pCBStr AS CBStr, BYREF wszStr AS CONST WSTRING) AS INTEGER
OPERATOR = StrCmpW(*pCBStr.Handle, wszStr) = 0
END OPERATOR
' ========================================================================================
OPERATOR = (BYREF wszStr AS CONST WSTRING, BYREF pCBStr AS CBStr) AS INTEGER
OPERATOR = StrCmpW(wszStr, *pCBStr.Handle) = 0
END OPERATOR
' ========================================================================================
' ========================================================================================
' Returns vbTrue (-1) if the two BSTRings are not equal; FALSE, otherwise.
' ========================================================================================
OPERATOR <> (BYREF pCBStr1 AS CBStr, BYREF pCBStr2 AS CBStr) AS INTEGER
OPERATOR = StrCmpW(*pCBStr1.Handle, *pCBStr2.Handle) <> 0
END OPERATOR
' ========================================================================================
' ========================================================================================
OPERATOR <> (BYREF pCBStr AS CBStr, BYREF wszStr AS CONST WSTRING) AS INTEGER
OPERATOR = StrCmpW(*pCBStr.Handle, wszStr) <> 0
END OPERATOR
' ========================================================================================
OPERATOR <> (BYREF wszStr AS CONST WSTRING, BYREF pCBStr AS CBStr) AS INTEGER
OPERATOR = StrCmpW(wszStr, *pCBStr.Handle) <> 0
END OPERATOR
' ========================================================================================
' ========================================================================================
' Returns vbTrue (-1) if the the first BSTR is greater than the 2nd BSTR; FALSE, otherwise.
' ========================================================================================
OPERATOR > (BYREF pCBStr1 AS CBStr, BYREF pCBStr2 AS CBStr) AS INTEGER
OPERATOR = StrCmpW(*pCBStr1.Handle, *pCBStr2.Handle) > 0
END OPERATOR
' ========================================================================================
' ========================================================================================
OPERATOR > (BYREF pCBStr AS CBStr, BYREF wszStr AS CONST WSTRING) AS INTEGER
OPERATOR = StrCmpW(*pCBStr.Handle, wszStr) > 0
END OPERATOR
' ========================================================================================
OPERATOR > (BYREF wszStr AS CONST WSTRING, BYREF pCBStr AS CBStr) AS INTEGER
OPERATOR = StrCmpW(wszStr, *pCBStr.Handle) > 0
END OPERATOR
' ========================================================================================
' ========================================================================================
' Returns vbTrue (-1) if the the first BSTR is less than the 2nd BSTR; FALSE, otherwise.
' ========================================================================================
OPERATOR < (BYREF pCBStr1 AS CBStr, BYREF pCBStr2 AS CBStr) AS INTEGER
OPERATOR = StrCmpW(*pCBStr1.Handle, *pCBStr2.Handle) < 0
END OPERATOR
' ========================================================================================
' ========================================================================================
OPERATOR < (BYREF pCBStr AS CBStr, BYREF wszStr AS CONST WSTRING) AS INTEGER
OPERATOR = StrCmpW(*pCBStr.Handle, wszStr) < 0
END OPERATOR
' ========================================================================================
OPERATOR < (BYREF wszStr AS CONST WSTRING, BYREF pCBStr AS CBStr) AS INTEGER
OPERATOR = StrCmpW(wszStr, *pCBStr.Handle) < 0
END OPERATOR
' ========================================================================================
' ========================================================================================
' Returns vbTrue (-1) if the the first BSTR is greater or equal than the 2nd BSTR; FALSE, otherwise.
' ========================================================================================
OPERATOR >= (BYREF pCBStr1 AS CBStr, BYREF pCBStr2 AS CBStr) AS INTEGER
DIM nResult AS LONG
nResult = StrCmpW(*pCBStr1.Handle, *pCBStr2.Handle)
IF nResult > 0 OR nResult = 0 THEN OPERATOR = -1 ELSE OPERATOR = 0
END OPERATOR
' ========================================================================================
' ========================================================================================
OPERATOR >= (BYREF pCBStr AS CBStr, BYREF wszStr AS CONST WSTRING) AS INTEGER
DIM nResult AS LONG
nResult = StrCmpW(*pCBStr.Handle, wszStr)
IF nResult > 0 OR nResult = 0 THEN OPERATOR = -1 ELSE OPERATOR = 0
END OPERATOR
' ========================================================================================
OPERATOR >= (BYREF wszStr AS CONST WSTRING, BYREF pCBStr AS CBStr) AS INTEGER
DIM nResult AS LONG
nResult = StrCmpW(wszStr, *pCBStr.Handle)
IF nResult > 0 OR nResult = 0 THEN OPERATOR = -1 ELSE OPERATOR = 0
test.bas
#Include Once "cbstr.bi"
Using Afx.CBStrClass
Dim cs As CBStr=CBStr("Une string dans Com String")
Dim cs2 As CBStr
Dim bs As BSTR =cs
Print cs
Print *Cast(WString Ptr,bs)
Print
cs2=cs
Print cs2
Print
Print
Dim wz As WString*45="Une BSTR dans CCOMBSTR"
cs2=sysallocstring(@wz)
Print cs2
' To append another BSTR:
DIM b1 AS CBStr = "1st string"
DIM b2 AS CBStr = " 2nd string"
b1.Append *b2.Handle
'-or-
'b1.Append **b2
Print **b1
DIM bss AS CBStr = "Test string"
PRINT **bss '(notice the double indirection)
DIM bs1 AS CBStr = "Test string 1"
DIM wsz AS WSTRING * 250 = " - concatenated string"
DIM bs2 AS CBStr
bs2 = bs1 & wsz
Print **bs2
Sleep
widestring.bi
#Include Once "windows.bi"
#Include Once "win/ole2.bi"
type WideString
Private:
Public:
m_bstr As BSTR
m_str As ZString Ptr
Public:
Declare Constructor()
Declare Constructor(mbstr As BSTR )
Declare Constructor(mstr As String )
Declare Constructor(byref mwstr As WideString )
Declare Operator Let(mbstr As BSTR )
Declare Operator Let(mstr As String )
Declare Operator Let(ByRef mstr As WideString )
Declare Operator +=(byref s as WideString )
Declare Operator &=(byref s as WideString )
Declare Operator +=(byref s as String )
Declare Operator &=(byref s as String )
Declare Operator +=(byref s as BSTR )
Declare Operator &=(byref s as BSTR )
Declare Operator Cast() As BSTR
Declare Operator Cast() As String
Declare Operator Cast() As BSTR Ptr
Declare Operator Cast() As String Ptr
Declare Destructor()
End Type
Constructor WideString()
m_str=NULL
m_bstr=NULL
End Constructor
Constructor WideString(mbstr As BSTR )
if (0=mbstr) Then
m_str = NULL
Else
Dim s As String=*Cast(WString Ptr,mbstr)
m_str=New Byte[Len(s)+1]
*m_str= s
End If
m_bstr=mbstr
End Constructor
Constructor WideString(mstr As String )
if Len(mstr)=NULL Then
m_str = NULL
m_bstr=NULL
Else
m_str=New Byte[Len(mstr)+1]
*m_str= mstr
m_bstr=SysAllocString(WStr(mstr))
End if
End Constructor
Constructor WideString(byref mwstr As WideString )
'if mwstr.m_str Then m_str = mwstr.m_str ' erratique m_str non instancié
'if mwstr.m_bstr Then m_bstr = mwstr.m_bstr
if mwstr.m_str Then
this.constructor(*mwstr.m_str)
Exit Constructor
Else
if mwstr.m_bstr Then this.constructor(mwstr.m_bstr)
EndIf
End Constructor
Operator WideString.let(mbstr As BSTR )
if m_str Then Delete [] m_str :m_str = NULL
if m_bstr Then sysfreestring(m_bstr) :m_bstr = NULL
this.constructor(mbstr)
End Operator
Operator WideString.let(mstr As String )
if m_str Then Delete [] m_str :m_str = NULL
if m_bstr Then sysfreestring(m_bstr) :m_bstr = NULL
this.constructor(mstr)
End Operator
Operator WideString.let(byref mwstr As WideString )
if m_str Then Delete [] m_str :m_str = NULL
if m_bstr Then sysfreestring(m_bstr) :m_bstr = NULL
this.constructor(mwstr)
End Operator
Operator WideString.Cast() As BSTR
if m_bstr=NULL Then
Return SysAllocString(WStr(*m_str))
Else
Return m_bstr
End If
End Operator
Operator WideString.Cast() As String
if m_str=NULL Then
'*m_str=*Cast(WString Ptr,m_bstr) ' mauvais car m_str non initialisé
this.constructor(m_bstr)
Return *m_str
Else
Return *m_str
End If
End Operator
Operator WideString.Cast() As BSTR Ptr
if m_bstr=NULL Then
m_bstr=SysAllocString(WStr(*m_str))
Return cptr(BSTR Ptr,m_bstr)
Else
Return cptr(BSTR Ptr,m_bstr)
End If
End Operator
Operator WideString.Cast() As String Ptr
if m_str=NULL Then
this.constructor(m_bstr)
Return Cast(String Ptr,m_str)
Else
Return Cast(String Ptr,m_str)
End If
End Operator
Destructor WideString()
If m_str Then Delete [] m_str : m_str=NULL
if m_bstr Then sysfreestring(m_bstr) :m_bstr = NULL
End Destructor
Operator WideString.+=(byref s As WideString )
'If Len(*m_str) And Len(*s.m_str) Then ' on ne peut pas ajouter un " " /
Dim temp As String =*m_str
temp=temp & *s.m_str
if m_str Then Delete [] m_str :m_str = NULL
If m_bstr Then sysfreestring(m_bstr) :m_bstr = NULL
this.constructor(temp)
'Else
'End If
End Operator
Operator WideString.&=(byref s as WideString )
'If Len(*m_str) And Len(*s.m_str) Then
Dim temp As String =*m_str
temp=temp & *s.m_str
if m_str Then Delete [] m_str :m_str = NULL
If m_bstr Then sysfreestring(m_bstr) :m_bstr = NULL
this.constructor(temp)
'Else
'End If
End Operator
Operator WideString.+=(byref s as String )
'If m_str<>NULL And Len(s)<>NULL Then
Dim temp As String =*m_str
temp=temp & s
if m_str Then Delete [] m_str :m_str = NULL
If m_bstr Then sysfreestring(m_bstr) :m_bstr = NULL
this.constructor(temp)
' Else
' End If
End Operator
Operator WideString.&=(byref s As String )
'If m_str<>NULL And Len(s)<>NULL Then
Dim temp As String =*m_str
temp=temp & s
If m_str Then Delete [] m_str :m_str = NULL
If m_bstr Then sysfreestring(m_bstr) :m_bstr = NULL
this.constructor(temp)
' Else
' End If
End Operator
Operator WideString.+=(byref s as BSTR )
' If sysstringLen(m_bstr) Then
Dim As BSTR mbstr
VarBstrCat(m_bstr,s,@mbstr)
if m_str Then Delete [] m_str :m_str = NULL
If m_bstr Then sysfreestring(m_bstr) :m_bstr = NULL
this.constructor(mbstr)
' Else
' End If
End Operator
Operator WideString.&=(byref s as BSTR )
' If sysstringLen(m_bstr) Then
Dim As BSTR mbstr
VarBstrCat(m_bstr,s,@mbstr)
if m_str Then Delete [] m_str :m_str = NULL
If m_bstr Then sysfreestring(m_bstr) :m_bstr = NULL
this.constructor(mbstr)
' Else
' End If
End Operator
Operator + OverLoad ( byref s1 As ZString Ptr , byref s2 As WideString ) As WideString
Dim As String s = *s1 + Cast(String,s2)
Operator= (s)
End Operator
Operator +( byref s2 As WideString, byref s1 As ZString Ptr ) As WideString
Dim s As String= Cast(String,s2) + *s1
Return s
End Operator
Operator +( byref s1 As BSTR , byref s2 As WideString ) As WideString
Dim s As BStr
VarBstrCat(s1,Cast(BSTR,s2),@s)
Operator= s
End Operator
Operator +( byref s2 As WideString, byref s1 As BSTR ) As WideString
Dim s As BStr
VarBstrCat(Cast(BSTR,s2),s1,@s)
Operator= s
End Operator
Operator & OverLoad ( byref s1 As ZString Ptr , byref s2 As WideString ) As WideString
Dim As String s = *s1 & Cast(String,s2)
Return (s)
End Operator
Operator &( byref s2 As WideString, byref s1 As ZString Ptr ) As WideString
Dim s As String= Cast(String,s2) & *s1
Return (s)
End Operator
Operator &( byref s1 As BSTR , byref s2 As WideString ) As WideString
Dim s As BStr
VarBstrCat(s1,Cast(BSTR,s2),@s)
Return s
End Operator
Operator &( byref s2 As WideString, byref s1 As BSTR ) As WideString
Dim s As BStr
VarBstrCat(Cast(BSTR,s2),s1,@s)
Return s
End Operator
Operator Not OverLoad ( ByRef lhs As WideString) As boolean
Return (Cast(String,lhs) = "") And (Cast(BSTR,lhs) = NULL)
End Operator
Operator = OverLoad ( ByRef lhs As WideString, ByRef rhs As ZString Ptr ) As boolean
Return (Cast(String,lhs) = *rhs)
End Operator
Operator = OverLoad (ByRef rhs As ZString Ptr, ByRef lhs As WideString) As boolean
Return (Cast(String,lhs) = *rhs)
End Operator
Operator <> OverLoad ( ByRef lhs As WideString, ByRef rhs As ZString Ptr ) As boolean
Return (Cast(String,lhs) <> *rhs)
End Operator
Operator <> OverLoad (ByRef rhs As ZString Ptr , ByRef lhs As WideString) As boolean
Return (Cast(String,lhs) <> *rhs)
End Operator
Operator = ( ByRef lhs As WideString, ByRef rhs As BSTR ) As boolean
Return (Cast(BSTR,lhs) = rhs)
End Operator
Operator = ( ByRef rhs As BSTR,ByRef lhs As WideString ) As boolean
Return (Cast(BSTR,lhs) = rhs)
End Operator
Operator <> ( ByRef lhs As WideString, ByRef rhs As BSTR ) As boolean
Return (Cast(BSTR,lhs) <> rhs)
End Operator
Operator <> (ByRef rhs As BSTR, ByRef lhs As WideString ) As boolean
Return (Cast(BSTR,lhs) <> rhs)
End Operator
testw.bas
#Define UNICODE ' OR NOT
#Include Once "widestring.bi"
'Using Afx.CBStrClass
#Define CBStr WideString
Dim cs As CBStr=CBStr("Une string dans Com String")
Dim cs2 As CBStr
Dim bs As BSTR =cs
Print cs
Print *Cast(WString Ptr,bs)
Print
cs2=cs
Print cs2
Print
Print
Dim wz As WString*45="Une BSTR dans CCOMBSTR"
cs2=sysallocstring(@wz)
Print cs2
' To append another BSTR:
DIM b1 AS CBStr = "1st string"
DIM b2 AS CBStr = " 2nd string"
b1 +=b2
'-or-
'b1.Append **b2
Print b1
DIM bss AS CBStr = "Test string"
PRINT bss '(notice the double indirection)
DIM bs1 AS CBStr = "Test string 1"
DIM wsz AS WSTRING * 250 = " - concatenated string"
DIM bs2 AS CBStr
bs2 = bs1 & wsz
Print bs2
Sleep
But with
Dim cs As CBStr=CBStr("Une string dans Com String")
Print cs
You're printing an ansi string, not an unicode one.
When you use Print cs, it calls this casting operator
Operator WideString.Cast() As String
if m_str=NULL Then
'*m_str=*Cast(WString Ptr,m_bstr) ' mauvais car m_str non initialisé
this.constructor(m_bstr)
Return *m_str
Else
Return *m_str
End If
End Operator
Unicode is not just converting ansi to utf-16 adding a CHR(0) to any character. This will work with languages that use the ANSI Latin 1; Western European (Windows), but not for Russian, for example.
Using this code, where 1251 is the code page for ANSI Cyrillic; Cyrillic (Windows):
#define unicode
#INCLUDE ONCE "windows.bi"
#INCLUDE ONCE "Afx/CBStr.inc"
using Afx.CBStrClass
DIM s AS STRING = CHR(209, 229, 236, 229, 237)
DIM wsz AS WSTRING * 260
MultiByteToWidechar(1251, MB_PRECOMPOSED,STRPTR(s), -1, @wsz, SIZEOF(wsz))
DIM bs AS CBStr = wsz
MessageBoxW 0, **bs, "", MB_OK
print
print "press esc"
sleep
The message box correctly displays семен
Using your class:
#define unicode
#INCLUDE ONCE "windows.bi"
#Include Once "Afx/widestring.bi"
DIM s AS STRING = CHR(209, 229, 236, 229, 237)
DIM wsz AS WSTRING * 260
MultiByteToWidechar(1251, MB_PRECOMPOSED,STRPTR(s), -1, @wsz, SIZEOF(wsz))
DIM bs AS WideString = wsz
MessageBoxW 0, bs, "", MB_OK
print
print "press esc"
sleep
It displays ?????
New version of CbStr.inc. I have removed the leaky concatenation operators and added support to set the code page, as the FreeBasic WSTR function has not a parameter to especify the code page to be used (it should).
We can use:
DIM bs AS CBStr = 1251 ' Sets the Russian code page
bs = CHR(209, 229, 236, 229, 237)
MessageBoxW 0, **bs, "", MB_OK
or
DIM bs AS CBStr = CBStr(CHR(209, 229, 236, 229, 237), 1251)
MessageBoxW 0, **bs, "", MB_OK
this one uses the Russian code page to do the translation but does not set it permanenty.
You can also use the CodePage property:
dim bs AS CBStr
bs.CodePage = 1251 ' Sets the Russian code page
bs = CHR(209, 229, 236, 229, 237)
MessageBoxW 0, **bs, "", MB_OK
We may need to set the code page because we can't use an additional parameter to sepecify it when using the Let operator to assign an ansi string.
you are right but this is resolved by puting operator cast() byref as wstring
update one
widestring.bi
#Include Once "windows.bi"
#Include Once "win/ole2.bi"
type WideString
Private:
Public:
m_bstr As BSTR
m_str As ZString Ptr
Public:
Declare Constructor()
Declare Constructor(mbstr As BSTR )
Declare Constructor(mstr As String )
Declare Constructor(mstr As WString Ptr )
Declare Constructor(byref mwstr As WideString )
Declare Operator Let(mbstr As BSTR )
Declare Operator Let(mstr As String )
Declare Operator Let(mstr As WString Ptr )
Declare Operator Let(ByRef mstr As WideString )
Declare Operator +=(byref s as WideString )
Declare Operator &=(byref s as WideString )
Declare Operator +=(byref s as String )
Declare Operator &=(byref s as String )
Declare Operator +=(byref s as BSTR )
Declare Operator &=(byref s as BSTR )
Declare Operator Cast() As BSTR
Declare Operator Cast() As String
Declare Operator Cast() ByRef As WString
Declare Destructor()
End Type
Constructor WideString()
m_str=NULL
m_bstr=NULL
End Constructor
Constructor WideString(mbstr As BSTR )
if (0=mbstr) Then
m_str = NULL
Else
Dim s As String=*Cast(WString Ptr,mbstr)
m_str=New Byte[Len(s)+1]
*m_str= s
End If
m_bstr=mbstr
End Constructor
Constructor WideString(mstr As String )
if Len(mstr)=NULL Then
m_str = NULL
m_bstr=NULL
Else
m_str=New Byte[Len(mstr)+1]
*m_str= mstr
m_bstr=SysAllocString(WStr(mstr))
End if
End Constructor
Constructor WideString(mstr As WString Ptr )
this.constructor(Cast(BSTR,mstr))
End Constructor
Constructor WideString(byref mwstr As WideString )
'if mwstr.m_str Then m_str = mwstr.m_str ' erratique m_str non instancié
'if mwstr.m_bstr Then m_bstr = mwstr.m_bstr
if mwstr.m_str Then
this.constructor(*mwstr.m_str)
Exit Constructor
Else
if mwstr.m_bstr Then this.constructor(mwstr.m_bstr)
EndIf
End Constructor
Operator WideString.let(mbstr As BSTR )
if m_str Then Delete [] m_str :m_str = NULL
if m_bstr Then sysfreestring(m_bstr) :m_bstr = NULL
this.constructor(mbstr)
End Operator
Operator WideString.let(mstr As String )
if m_str Then Delete [] m_str :m_str = NULL
if m_bstr Then sysfreestring(m_bstr) :m_bstr = NULL
this.constructor(mstr)
End Operator
Operator WideString.Let(mstr As WString Ptr )
this=(Cast(BSTR,mstr))
End Operator
Operator WideString.let(byref mwstr As WideString )
if m_str Then Delete [] m_str :m_str = NULL
if m_bstr Then sysfreestring(m_bstr) :m_bstr = NULL
this.constructor(mwstr)
End Operator
Operator WideString.Cast() As BSTR
if m_bstr=NULL Then
Return SysAllocString(WStr(*m_str))
Else
Return m_bstr
End If
End Operator
Operator WideString.Cast() As String
if m_str=NULL Then
'*m_str=*Cast(WString Ptr,m_bstr) ' pas bon car m_str non initialisé
this.constructor(m_bstr)
Return *m_str
Else
Return *m_str
End If
End Operator
Operator WideString.Cast() ByRef As WString
if m_str=NULL Then
this.constructor(m_bstr)
Return peek(WString,m_str)
Else
Return peek(WString,m_str)
End If
End Operator
Destructor WideString()
If m_str Then Delete [] m_str : m_str=NULL
if m_bstr Then sysfreestring(m_bstr) :m_bstr = NULL
End Destructor
Operator WideString.+=(byref s As WideString )
'If Len(*m_str) And Len(*s.m_str) Then ' on ne peut pas ajouter un " " /
Dim temp As String =*m_str
temp=temp & *s.m_str
if m_str Then Delete [] m_str :m_str = NULL
If m_bstr Then sysfreestring(m_bstr) :m_bstr = NULL
this.constructor(temp)
'Else
'End If
End Operator
Operator WideString.&=(byref s as WideString )
'If Len(*m_str) And Len(*s.m_str) Then
Dim temp As String =*m_str
temp=temp & *s.m_str
if m_str Then Delete [] m_str :m_str = NULL
If m_bstr Then sysfreestring(m_bstr) :m_bstr = NULL
this.constructor(temp)
'Else
'End If
End Operator
Operator WideString.+=(byref s as String )
'If m_str<>NULL And Len(s)<>NULL Then
Dim temp As String =*m_str
temp=temp & s
if m_str Then Delete [] m_str :m_str = NULL
If m_bstr Then sysfreestring(m_bstr) :m_bstr = NULL
this.constructor(temp)
' Else
' End If
End Operator
Operator WideString.&=(byref s As String )
'If m_str<>NULL And Len(s)<>NULL Then
Dim temp As String =*m_str
temp=temp & s
If m_str Then Delete [] m_str :m_str = NULL
If m_bstr Then sysfreestring(m_bstr) :m_bstr = NULL
this.constructor(temp)
' Else
' End If
End Operator
Operator WideString.+=(byref s as BSTR )
' If sysstringLen(m_bstr) Then
Dim As BSTR mbstr
VarBstrCat(m_bstr,s,@mbstr)
if m_str Then Delete [] m_str :m_str = NULL
If m_bstr Then sysfreestring(m_bstr) :m_bstr = NULL
this.constructor(mbstr)
' Else
' End If
End Operator
Operator WideString.&=(byref s as BSTR )
' If sysstringLen(m_bstr) Then
Dim As BSTR mbstr
VarBstrCat(m_bstr,s,@mbstr)
if m_str Then Delete [] m_str :m_str = NULL
If m_bstr Then sysfreestring(m_bstr) :m_bstr = NULL
this.constructor(mbstr)
' Else
' End If
End Operator
Operator + OverLoad ( byref s1 As ZString Ptr , byref s2 As WideString ) As WideString
Dim As String s = *s1 + Cast(String,s2)
Operator= (s)
End Operator
Operator +( byref s2 As WideString, byref s1 As ZString Ptr ) As WideString
Dim s As String= Cast(String,s2) + *s1
Return s
End Operator
Operator +( byref s1 As BSTR , byref s2 As WideString ) As WideString
Dim s As BStr
VarBstrCat(s1,Cast(BSTR,s2),@s)
Operator= s
End Operator
Operator +( byref s2 As WideString, byref s1 As BSTR ) As WideString
Dim s As BStr
VarBstrCat(Cast(BSTR,s2),s1,@s)
Operator= s
End Operator
Operator & OverLoad ( byref s1 As ZString Ptr , byref s2 As WideString ) As WideString
Dim As String s = *s1 & Cast(String,s2)
Return (s)
End Operator
Operator &( byref s2 As WideString, byref s1 As ZString Ptr ) As WideString
Dim s As String= Cast(String,s2) & *s1
Return (s)
End Operator
Operator &( byref s1 As BSTR , byref s2 As WideString ) As WideString
Dim s As BStr
VarBstrCat(s1,Cast(BSTR,s2),@s)
Return s
End Operator
Operator &( byref s2 As WideString, byref s1 As BSTR ) As WideString
Dim s As BStr
VarBstrCat(Cast(BSTR,s2),s1,@s)
Return s
End Operator
Operator Not OverLoad ( ByRef lhs As WideString) As boolean
Return (Cast(String,lhs) = "") And (Cast(BSTR,lhs) = NULL)
End Operator
Operator = OverLoad ( ByRef lhs As WideString, ByRef rhs As ZString Ptr ) As boolean
Return (Cast(String,lhs) = *rhs)
End Operator
Operator = OverLoad (ByRef rhs As ZString Ptr, ByRef lhs As WideString) As boolean
Return (Cast(String,lhs) = *rhs)
End Operator
Operator <> OverLoad ( ByRef lhs As WideString, ByRef rhs As ZString Ptr ) As boolean
Return (Cast(String,lhs) <> *rhs)
End Operator
Operator <> OverLoad (ByRef rhs As ZString Ptr , ByRef lhs As WideString) As boolean
Return (Cast(String,lhs) <> *rhs)
End Operator
Operator = ( ByRef lhs As WideString, ByRef rhs As BSTR ) As boolean
Return (Cast(BSTR,lhs) = rhs)
End Operator
Operator = ( ByRef rhs As BSTR,ByRef lhs As WideString ) As boolean
Return (Cast(BSTR,lhs) = rhs)
End Operator
Operator <> ( ByRef lhs As WideString, ByRef rhs As BSTR ) As boolean
Return (Cast(BSTR,lhs) <> rhs)
End Operator
Operator <> (ByRef rhs As BSTR, ByRef lhs As WideString ) As boolean
Return (Cast(BSTR,lhs) <> rhs)
End Operator
If I use that change, the program GPFs when it ends.
#define unicode
#INCLUDE ONCE "windows.bi"
#Include Once "Afx/widestring.bi"
DIM s AS STRING = CHR(209, 229, 236, 229, 237)
DIM wsz AS WSTRING * 260
MultiByteToWidechar(1251, MB_PRECOMPOSED, STRPTR(s), -1, @wsz, SIZEOF(wsz))
DIM bs AS WideString = wsz
MessageBoxW 0, bs, "", MB_OK
I have rewritten the AfxUcode/Acode functions:
' ========================================================================================
' Translates ansi bytes to unicode bytes
' ========================================================================================
FUNCTION AfxUcode (BYREF ansiStr AS CONST STRING, BYVAL nCodePage AS LONG = 0) AS BSTR
DIM pbstr AS BSTR = SysAllocString(WSTR(ansiStr))
IF nCodePage <> 0 THEN MultiByteToWideChar(nCodePage, MB_PRECOMPOSED, STRPTR(ansiStr), -1, pbstr, LEN(ansiStr) * 2)
FUNCTION = pbstr
END FUNCTION
' ========================================================================================
' ========================================================================================
' Translates unicode bytes to ansi bytes
' ========================================================================================
FUNCTION AfxAcode (BYVAL pbstr AS BSTR, BYVAL nCodePage AS LONG = 0) AS STRING
DIM ansiStr AS STRING = SPACE(SysStringLen(pbstr))
DIM hr AS LONG = WideCharToMultiByte(nCodePage, 0, pbstr, SysStringLen(pbstr), STRPTR(ansiStr), LEN(ansiStr), NULL, NULL)
FUNCTION = ansiStr
END FUNCTION
' ========================================================================================
this allows to use the assignment operator without setting the code page first:
Dim bs AS CBStr
bs = AfxUcode(CHR(209, 229, 236, 229, 237), 1251)
MessageBoxW 0, **bs, "", MB_OK
Of course, if WSTR had an optional CodePage parameter, we could do this: bs = WSTR(CHR(209, 229, 236, 229, 237), 1251). In PowerBASIC, that optional CodePage parameter was added by my suggestion.
QuoteIf I use that change, the program GPFs when it ends.
curious operator cast() byref as wstring was not the only change
I have copied all the code you have posted in #55. It GPFs after I click "OK" in the message box. Test it by yourself.
But when I use
#define unicode
#INCLUDE ONCE "windows.bi"
#Include Once "Afx/widestring.bi"
DIM s AS STRING = CHR(209, 229, 236, 229, 237)
DIM wsz AS WSTRING * 260
MultiByteToWidechar(1251, MB_PRECOMPOSED, STRPTR(s), -1, @wsz, SIZEOF(wsz))
DIM bs AS WideString = wsz
MessageBoxW 0, bs, "", MB_OK
the opeator that is being called is not the one with BYREF AS WSTRING, but
Operator WideString.Cast() As BSTR
if m_bstr=NULL Then
Return SysAllocString(WStr(*m_str))
Else
Return m_bstr
End If
End Operator
If I add this operator to my class, it works
' ========================================================================================
' Returns a pointer to the BSTR
' ========================================================================================
OPERATOR CBStr.CAST () BYREF AS WSTRING
' OPERATOR = PEEK(WSTRING, m_bstr)
OPERATOR = *CAST(WSTRING PTR, m_bstr)
END OPERATOR
' ========================================================================================
I'm very interested in that BYREF thing, because
FUNCTION Foo () AS BSTR
DIM bstrHandle AS BSTR
bstrHandle = SysAllocString("Test string")
FUNCTION = bstrHandle
END FUNCTION
DIM bs AS CBSTR
bs = Foo
' we can use
print bs
' instead of
'print *bs.Handle
'-or-
'print **bs
' that also work
This is a version of CBStr.inc with the BYREF AS WSTRING cast operator added.
See attachment.
Interesting test:
#INCLUDE ONCE "windows.bi"
#INCLUDE ONCE "Afx/AfxWin.inc"
#INCLUDE ONCE "Afx/CBStr.inc"
using Afx.CBStrClass
DIM bs1 AS CBStr = "First"
DIM bs2 AS CBStr = "Second"
print bs1, bs2
print bs1 & bs2
print **bs1 & " --- " & **bs2 ' this works
'print bs1 & " --- " & bs2 ' this does not work; type mismatch error
print bs1 & " --- " & **bs2 ' this works
'print **bs1 & " --- " & bs2 ' this does not work; type mismatch error
dim s as string
s = bs1 & bs2
print s
print "press esc"
sleep
I have modified the functions that load icons from file or resource to allow to pass a dimming percentage and/or gray escale conversion. This way, with only a set of icons we can buid both the normal imagelist and the disabled one, e.g.
' // Create an image list for the toolbar
DIM hImageListNormal AS HIMAGELIST
DIM cx AS LONG = 16 * pWindow->DPI \ 96
hImageListNormal = ImageList_Create(cx, cx, ILC_COLOR32 OR ILC_MASK, 4, 0)
IF hImageListNormal THEN
ImageList_ReplaceIcon(hImageListNormal, -1, AfxGdipImageFromResEx(hInst, "IDI_NEW_32"))
ImageList_ReplaceIcon(hImageListNormal, -1, AfxGdipImageFromResEx(hInst, "IDI_OPEN_32"))
ImageList_ReplaceIcon(hImageListNormal, -1, AfxGdipImageFromResEx(hInst, "IDI_SAVE_32"))
END IF
SendMessageW hToolBar, TB_SETIMAGELIST, 0, CAST(LPARAM, hImageListNormal)
' // Create the disabled image list for the toolbar
DIM hImageListDisabled AS HIMAGELIST
hImageListDisabled = ImageList_Create(cx, cx, ILC_COLOR32 OR ILC_MASK, 4, 0)
IF hImageListDisabled THEN
ImageList_ReplaceIcon(hImageListNormal, -1, AfxGdipImageFromResEx(hInst, "IDI_NEW_32", 60, TRUE))
ImageList_ReplaceIcon(hImageListNormal, -1, AfxGdipImageFromResEx(hInst, "IDI_OPEN_32", 60, TRUE))
ImageList_ReplaceIcon(hImageListNormal, -1, AfxGdipImageFromResEx(hInst, "IDI_SAVE_32", 60, TRUE))
END IF
SendMessageW hToolBar, TB_SETDISABLEDIMAGELIST, 0, CAST(LPARAM, hImageListDisabled)
With only a set of icons we can display them with the appropriate size for the DPI chosen by the user, both in toolbars and in menus.
It's time to throw to the recycle bin these old bitmaps with a pink background and without alpha channel that we used in the past.
your example CWindow with a rebar control don't work anymore
This is because I have removed the auxiliary functions from CWindow.inc. What I'm posting is testing code.
Add the functions to the example and it will compile:
' ========================================================================================
' Adds a button to a toolbar.
' Minimum operating systems Windows NT 3.51, Windows 95
' ========================================================================================
PRIVATE FUNCTION AfxToolbarAddButtonW (BYVAL hToolBar AS HWND, BYVAL idxBitmap AS LONG, BYVAL idCommand AS LONG, _
BYVAL fsState AS UBYTE = 0, BYVAL fsStyle AS UBYTE = 0, BYVAL dwData AS DWORD_PTR = 0, BYVAL pwszText AS WSTRING PTR = NULL) AS LRESULT
IF fsState = 0 THEN fsState = TBSTATE_ENABLED
DIM idxString AS INT_PTR
IF pwszText <> NULL THEN idxString = IIF(LEN(*pwszText) = 0, -1, CAST(INT_PTR, pwszText))
#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
FUNCTION = SendMessageW(hToolBar, TB_ADDBUTTONSW, 1, CAST(LPARAM, @tbb))
END FUNCTION
' ========================================================================================
' ========================================================================================
' Adds a separator to a toolbar.
' Minimum operating systems Windows NT 3.51, Windows 95
' ========================================================================================
PRIVATE FUNCTION AfxToolbarAddSeparatorW (BYVAL hToolBar AS HWND, BYVAL nWidth AS LONG = 0) AS LRESULT
#ifdef __FB_64BIT__
DIM tbb AS TBBUTTON = (nWidth, 0, TBSTATE_ENABLED, TBSTYLE_SEP, {0, 0, 0, 0, 0, 0}, 0, -1)
#else
DIM tbb AS TBBUTTON = (nWidth, 0, TBSTATE_ENABLED, TBSTYLE_SEP, {0, 0}, 0, -1)
#endif
FUNCTION = SendMessageW(hToolBar, TB_ADDBUTTONSW, 1, CAST(LPARAM, @tbb))
END FUNCTION
' ========================================================================================
BTW do you know why this compiles
DIM tbb AS TBBUTTON = (idxBitmap, idCommand, fsState, fsStyle, {0, 0, 0, 0, 0, 0}, dwData, idxString)
but this one don't
DIM tbb AS TBBUTTON
tbb = (idxBitmap, idCommand, fsState, fsStyle, {0, 0, 0, 0, 0, 0}, dwData, idxString)
CWindow with a rebar control work with Cwindow_RC02 but don't wit Cwindow_RC06
This one will work:
' ########################################################################################
' Microsoft Windows
' File: CW_COMMCTRL_Rebar.fbtpl
' Contents: CWindow with a rebar 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 _WIN32_WINNT &h0602
#INCLUDE ONCE "windows.bi"
#INCLUDE ONCE "Afx/CWindow.inc"
USING Afx.CWindowClass
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)
CONST IDC_TOOLBAR = 1001
CONST IDC_CBBOX = 1002
CONST IDC_REBAR = 1003
enum
IDM_CUT = 28000
IDM_COPY, IDM_PASTE, IDM_UNDO, IDM_REDOW, IDM_DELETE, IDM_FILENEW, IDM_FILEOPEN
IDM_FILESAVE, IDM_PRINTPRE, IDM_PROPERTIES, IDM_HELP, IDM_FIND, IDM_REPLACE, IDM_PRINT
end enum
' ========================================================================================
' Adds a button to a toolbar.
' Minimum operating systems Windows NT 3.51, Windows 95
' ========================================================================================
PRIVATE FUNCTION AfxToolbar_AddButton (BYVAL hToolBar AS HWND, BYVAL idxBitmap AS LONG, BYVAL idCommand AS LONG, _
BYVAL fsState AS UBYTE = 0, BYVAL fsStyle AS UBYTE = 0, BYVAL dwData AS DWORD_PTR = 0, BYVAL pwszText AS WSTRING PTR = NULL) AS LRESULT
IF fsState = 0 THEN fsState = TBSTATE_ENABLED
DIM idxString AS INT_PTR
IF pwszText <> NULL THEN idxString = IIF(LEN(*pwszText) = 0, -1, CAST(INT_PTR, pwszText))
#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
FUNCTION = SendMessageW(hToolBar, TB_ADDBUTTONSW, 1, CAST(LPARAM, @tbb))
END FUNCTION
' ========================================================================================
' ========================================================================================
' Adds a separator to a toolbar.
' Minimum operating systems Windows NT 3.51, Windows 95
' ========================================================================================
PRIVATE FUNCTION AfxToolbar_AddSeparator (BYVAL hToolBar AS HWND, BYVAL nWidth AS LONG = 0) AS LRESULT
#ifdef __FB_64BIT__
DIM tbb AS TBBUTTON = (nWidth, 0, TBSTATE_ENABLED, TBSTYLE_SEP, {0, 0, 0, 0, 0, 0}, 0, -1)
#else
DIM tbb AS TBBUTTON = (nWidth, 0, TBSTATE_ENABLED, TBSTYLE_SEP, {0, 0}, 0, -1)
#endif
FUNCTION = SendMessageW(hToolBar, TB_ADDBUTTONSW, 1, CAST(LPARAM, @tbb))
END FUNCTION
' ========================================================================================
' ========================================================================================
' Create the toolbar
' ========================================================================================
FUNCTION CreateToolbar (BYVAL pWindow AS CWindow PTR) AS HWND
' // Add a tooolbar
DIM hToolBar AS HWND = pWindow->AddControl("Toolbar", pWindow->hWindow, IDC_TOOLBAR, "", 0, 0, 0, 0, _
WS_CHILD OR WS_VISIBLE OR TBSTYLE_TOOLTIPS OR TBSTYLE_FLAT OR CCS_NODIVIDER OR CCS_NORESIZE OR CCS_NOPARENTALIGN)
' // Allow drop down arrows
SendMessageW hToolBar, TB_SETEXTENDEDSTYLE, 0, TBSTYLE_EX_DRAWDDARROWS
' // Add a bitmap with the button images
DIM ttbab AS TBADDBITMAP
ttbab.hInst = HINST_COMMCTRL
IF AfxIsProcessDPIAware THEN
ttbab.nId = IDB_STD_LARGE_COLOR
ELSE
ttbab.nId = IDB_STD_SMALL_COLOR
END IF
SendMessageW(hToolBar, TB_ADDBITMAP, 0, CAST(LPARAM, @ttbab))
' // Add buttons to the toolbar
AfxToolbar_AddButton hToolBar, STD_CUT, IDM_CUT
AfxToolbar_AddButton hToolBar, STD_COPY, IDM_COPY
AfxToolbar_AddButton hToolBar, STD_PASTE, IDM_PASTE
AfxToolbar_AddButton hToolBar, STD_DELETE, IDM_DELETE
AfxToolbar_AddSeparator hToolBar
AfxToolbar_AddButton hToolBar, STD_UNDO, IDM_UNDO
AfxToolbar_AddButton hToolBar, STD_REDOW, IDM_REDOW
AfxToolbar_AddSeparator hToolBar
AfxToolbar_AddButton hToolBar, STD_FILENEW, IDM_FILENEW, 0, BTNS_DROPDOWN
AfxToolbar_AddButton hToolBar, STD_FILEOPEN, IDM_FILEOPEN
AfxToolbar_AddButton hToolBar, STD_FILESAVE, IDM_FILESAVE
AfxToolbar_AddButton hToolBar, STD_PRINTPRE, IDM_PRINTPRE
AfxToolbar_AddSeparator hToolBar
AfxToolbar_AddButton hToolBar, STD_FIND, IDM_FIND
AfxToolbar_AddButton hToolBar, STD_REPLACE, IDM_REPLACE
AfxToolbar_AddSeparator hToolBar
AfxToolbar_AddButton hToolBar, STD_PROPERTIES, IDM_PROPERTIES
AfxToolbar_AddButton hToolBar, STD_PRINT, IDM_PRINT
AfxToolbar_AddSeparator hToolBar
AfxToolbar_AddButton hToolBar, STD_HELP, IDM_HELP
' // Size the toolbar
SendMessageW hToolBar, TB_AUTOSIZE, 0, 0
' // Return the toolbar handle
FUNCTION = hToolbar
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 pWindow AS CWindow PTR
DIM rc AS RECT
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_CUT ' etc.
' MessageBoxW hwnd, "You have clicked the Cut button", "Toolbar", MB_OK
' EXIT FUNCTION
END SELECT
CASE WM_NOTIFY
' -------------------------------------------------------
' Notification messages are handled here.
' The TTN_GETDISPINFO message is sent by a ToolTip control
' to retrieve information needed to display a ToolTip window.
' ------------------------------------------------------
DIM ptnmhdr AS NMHDR PTR ' // Information about a notification message
DIM ptttdi AS NMTTDISPINFOW PTR ' // Tooltip notification message information
DIM wszTooltipText AS WSTRING * 260 ' // Tooltip text
ptnmhdr = CAST(NMHDR PTR, lParam)
SELECT CASE ptnmhdr->code
' // The height of the rebar has changed
CASE RBN_HEIGHTCHANGE
' // Get the coordinates of the client area
GetClientRect hwnd, @rc
' // Send a WM_SIZE message to resize the controls
SendMessageW hwnd, WM_SIZE, SIZE_RESTORED, MAKELONG(rc.Right - rc.Left, rc.Bottom - rc.Top)
' // Toolbar tooltips
CASE TTN_GETDISPINFO
ptttdi = CAST(NMTTDISPINFOW PTR, lParam)
ptttdi->hinst = NULL
wszTooltipText = ""
SELECT CASE ptttdi->hdr.hwndFrom
CASE SendMessageW(GetDlgItem(GetDlgItem(hwnd, IDC_REBAR), IDC_TOOLBAR), TB_GETTOOLTIPS, 0, 0)
SELECT CASE ptttdi->hdr.idFrom
CASE IDM_CUT : wszTooltipText = "Cut"
CASE IDM_COPY : wszTooltipText = "Copy"
CASE IDM_PASTE : wszTooltipText = "Paste"
CASE IDM_UNDO : wszTooltipText = "Undo"
CASE IDM_REDOW : wszTooltipText = "Redo"
CASE IDM_DELETE : wszTooltipText = "Delete"
CASE IDM_FILENEW : wszTooltipText = "File New"
CASE IDM_FILEOPEN : wszTooltipText = "File Open"
CASE IDM_FILESAVE : wszTooltipText = "File Save"
CASE IDM_PRINTPRE : wszTooltipText = "Print Preview"
CASE IDM_PROPERTIES : wszTooltipText = "Properties"
CASE IDM_HELP : wszTooltipText = "Help"
CASE IDM_FIND : wszTooltipText = "Find"
CASE IDM_REPLACE : wszTooltipText = "Replace"
CASE IDM_PRINT : wszTooltipText = "Print"
END SELECT
IF LEN(wszTooltipText) THEN ptttdi->lpszText = @wszTooltipText
END SELECT
CASE TBN_DROPDOWN
DIM ptbn AS TBNOTIFY PTR = CAST(TBNOTIFY PTR, lParam)
SELECT CASE ptbn->iItem
CASE IDM_FILENEW
DIM rc AS RECT
SendMessageW(ptbn->hdr.hwndFrom, TB_GETRECT, ptbn->iItem, CAST(LPARAM, @rc))
MapWindowPoints(ptbn->hdr.hwndFrom, HWND_DESKTOP, CAsT(LPPOINT, @rc), 2)
DIM hPopupMenu AS HMENU = CreatePopUpMenu
AppendMenuW hPopupMenu, MF_ENABLED, 10001, "Option 1"
AppendMenuW hPopupMenu, MF_ENABLED, 10002, "Option 2"
AppendMenuW hPopupMenu, MF_ENABLED, 10003, "Option 3"
AppendMenuW hPopupMenu, MF_ENABLED, 10004, "Option 4"
AppendMenuW hPopupMenu, MF_ENABLED, 10005, "Option 5"
TrackPopupMenu(hPopupMenu, 0, rc.Left, rc.Bottom, 0, hwnd, NULL)
DestroyMenu hPopupMenu
END SELECT
END SELECT
CASE WM_SIZE
IF wParam <> SIZE_MINIMIZED THEN
' // Update the size and position of the Rebar control
SendMessageW GetDlgItem(hwnd, IDC_REBAR), WM_SIZE, wParam, lParam
' // Resize the button
pWindow = CAST(CWindow PTR, GetWindowLongPtr(hwnd, 0))
pWindow->MoveWindow GetDlgItem(hwnd, IDCANCEL), pWindow->ClientWidth - 95, pWindow->ClientHeight - 35, 75, 23, 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, "CWindow with a rebar", @WndProc)
' // Disable background erasing
pWindow.ClassStyle = CS_DBLCLKS
' // Set the client size
pWindow.SetClientSize(600, 250)
' // Center the window
pWindow.Center
' // Add a button
DIM hButton AS HWND = pWindow.AddControl("Button", pWindow.hWindow, IDCANCEL, "&Close")
' // Create a rebar control
DIM hRebar AS HWND = pWindow.AddControl("Rebar", pWindow.hWindow, IDC_REBAR)
' Create the toolbar
DIM hToolbar AS HWND = CreateToolbar(@pWindow)
' // Add the band containing the toolbar control to the rebar
' // The size of the REBARBANDINFOW is different in Vista/Windows 7
DIM rc AS RECT, wszText AS WSTRING * 260
DIM rbbi AS REBARBANDINFOW
IF AfxWindowsVersion >= 600 AND AfxComCtlVersion >= 600 THEN
rbbi.cbSize = REBARBANDINFO_V6_SIZE
ELSE
rbbi.cbSize = REBARBANDINFO_V3_SIZE
END IF
' // Insert the toolbar in the rebar control
rbbi.fMask = RBBIM_STYLE OR RBBIM_CHILD OR RBBIM_CHILDSIZE OR _
RBBIM_SIZE OR RBBIM_ID OR RBBIM_IDEALSIZE OR RBBIM_TEXT
rbbi.fStyle = RBBS_CHILDEDGE
rbbi.hwndChild = hToolbar
rbbi.cxMinChild = 270 * pWindow.rxRatio
rbbi.cyMinChild = HIWORD(SendMessageW(hToolBar, TB_GETBUTTONSIZE, 0, 0))
rbbi.cx = 270 * pWindow.rxRatio
rbbi.cxIdeal = 270 * pWindow.rxRatio
wszText = "Toolbar"
rbbi.lpText = @wszText
'// Insert band into rebar
SendMessageW hRebar, RB_INSERTBANDW, -1, CAST(LPARAM, @rbbi)
' // Insert a combobox in the rebar control
DIM hCbBox AS HWND = pWindow.AddControl("ComboBox", pWindow.hWindow, IDC_CBBOX, "", 0, 0, 0, 50 * pWindow.rxRatio)
GetWindowRect hCbBox, @rc
rbbi.fMask = RBBIM_STYLE OR RBBIM_CHILD OR RBBIM_CHILDSIZE OR _
RBBIM_SIZE OR RBBIM_ID OR RBBIM_IDEALSIZE OR RBBIM_TEXT
rbbi.fStyle = RBBS_FIXEDSIZE OR RBBS_CHILDEDGE
rbbi.hwndChild = hCbBox
rbbi.cxMinChild = 200 * pWindow.rxRatio
rbbi.cyMinChild = rc.Bottom - rc.Top
rbbi.cx = 200 * pWindow.rxRatio
rbbi.cxIdeal = 200 * pWindow.rxRatio
wszText = "Combobox"
rbbi.lpText = @wszText
'// Insert band into rebar
SendMessageW hRebar, RB_INSERTBANDW, -1, CAST(LPARAM, @rbbi)
' // Process event messages
FUNCTION = pWindow.DoEvents(nCmdShow)
END FUNCTION
' ========================================================================================
Hi Paul,
Good news. I have succesfully translated my graphic control to FreeBasic.
That's awesome Jose!
I had also converted my version of the image control to FreeBasic: http://www.planetsquires.com/protect/forum/index.php?topic=3701.0