PlanetSquires Forums

Support Forums => WinFBX - Windows Framework for FreeBASIC => Topic started by: José Roca on August 06, 2017, 02:51:36 PM

Title: CWindow Release Candidate 31
Post by: José Roca on August 06, 2017, 02:51:36 PM
Unrar the Afx folder in the "inc" folder of your compiler(s).

On-line help: http://www.jose.it-berater.org/WinFBX/WinFBX.html
GitHub: https://github.com/JoseRoca/WinFBX

Incorporates the changes discussed in the thread of the previous version.

I also have removed the deprecated classes CWstrArray, CWstrDic and CWmiCli. Use instead CSafeArray, CDicObj and CWmiDisp.

9 Aug 2017: Added RemoveStr, ReplaceStr and InStr to the CRegExp class.
14 Aug 2017: Some minor changes and a new class: CPropVar
26 Aug 2017: Added return value to several functions
3 Oct 2017 : Updated with the all changes discussed in this thread
4 Oct 2017 : Updated CVAR and CDispInvoke classes
16 Oct 2017 : Updated with new classes for Time and Ini files
19 Oct 2017 : Modified CDispInvoke
19 Oct 2017 : Removed a couple of suffixes in CPgBar3D.inc
27 Oct 2017 : Fixed a bug in the WebBrowser events; small changes in CWSTR and CVAR.
31 Oct 2017 : Small modification in AfxStr.inc
Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on August 06, 2017, 03:32:57 PM
Thanks Jose - I have downloaded and updated the WinFBE source tree with your new files. The changes will be available in the next GitHub upload.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on August 09, 2017, 01:40:03 PM
Added new methods to the CRegExp class: RemoveStr, ReplaceStr and InStr.

They allow to do string manipulation using regular expressions.

Code: [Select]
' ========================================================================================
' * Returns a copy of a string with text removed using a regular expression as the search string.
' Parameters:
' - cbsSourceString : The source string.
' - cbsPattern : The pattern to search.
' - bIgnoreCase : FALSE = case sensitive; TRUE = case insensitive.
' - bGlobal : FALSE = Delete only the first match; TRUE = delete all matches.
' - bMultiline : TRUE = Match at the start and the end of multiple lines separated by line breaks.
' Examples:
' DIM pRegExp AS CRegExp
' PRINT pRegExp.RemoveStr("abacadabra", "ab") - prints "acadra"
' PRINT pRegExp.RemoveStr("abacadabra", "[bAc]", TRUE) - prints "dr"
' ========================================================================================
PRIVATE FUNCTION CRegExp.RemoveStr (BYREF cbsSourceString AS CBSTR, BYREF cbsPattern AS CBSTR, _
   BYVAL bIgnoreCase AS BOOLEAN = FALSE, BYVAL bGlobal AS BOOLEAN = TRUE, BYVAL bMultiline AS BOOLEAN = FALSE) AS CBSTR
   DIM bstrDestString AS AFX_BSTR
   IF m_pRegExp = NULL THEN this.SetResult(E_POINTER): RETURN bstrDestString
   m_pRegExp->put_IgnoreCase(bIgnoreCase)
   m_pRegExp->put_Global(bGlobal)
   m_pRegExp->put_Multiline(bMultiline)
   m_pRegExp->put_Pattern(cbsPattern)
   this.SetResult(m_pRegExp->Replace(cbsSourceString, CVAR(""), @bstrDestString))
   RETURN bstrDestString
END FUNCTION
' ========================================================================================

Code: [Select]
' ========================================================================================
' * Returns a copy of a string with text replaced using a regular expression as the search string.
' Parameters:
' - cbsSourceString : The source string.
' - cbsPattern : The pattern to search.
' - cvReplaceString : The replacement string.
' - bIgnoreCase : FALSE = case sensitive; TRUE = case insensitive.
' - bGlobal : FALSE = Delete only the first match; TRUE = delete all matches.
' - bMultiline : TRUE = Match at the start and the end of multiple lines separated by line breaks.
' Examples:
' DIM pRegExp AS CRegExp
' PRINT pRegExp.ReplaceStr("Hello World", "World", "Earth") - prints "Hello Earth"
' PRINT pRegExp.ReplaceStr("abacadabra", "[bac]", "*") - prints "*****d**r*"
' PRINT pRegExp.ReplaceStr("555-123-4567", "(\d{3})-(\d{3})-(\d{4})", "($1) $2-$3") - prints "(555) 123-4567"
' PRINT pRegExp.ReplaceStr("Squires, Paul", "(\S+), (\S+)", "$2 $1") - prints "Paul Squires"
' PRINT pRegExp.ReplaceStr("0000.34500044", $"\b0{1,}\.", ".") - prints ".34500044"
' ========================================================================================
PRIVATE FUNCTION CRegExp.ReplaceStr (BYREF cbsSourceString AS CBSTR, BYREF cbsPattern AS CBSTR, BYREF cvReplaceString AS CVAR, _
   BYVAL bIgnoreCase AS BOOLEAN = FALSE, BYVAL bGlobal AS BOOLEAN = TRUE, BYVAL bMultiline AS BOOLEAN = FALSE) AS CBSTR
   DIM bstrDestString AS AFX_BSTR
   IF m_pRegExp = NULL THEN this.SetResult(E_POINTER): RETURN bstrDestString
   m_pRegExp->put_IgnoreCase(bIgnoreCase)
   m_pRegExp->put_Global(bGlobal)
   m_pRegExp->put_Multiline(bMultiline)
   m_pRegExp->put_Pattern(cbsPattern)
   this.SetResult(m_pRegExp->Replace(cbsSourceString, cvReplaceString, @bstrDestString))
   RETURN bstrDestString
END FUNCTION
' ========================================================================================

Code: [Select]
' ========================================================================================
' Global, multiline in string function with VBScript regular expressions search patterns.
' Parameters:
' - cbsSourceString = The text to be parsed.
' - cbsPattern = The pattern to match.
' - bIgnoreCase = Ignore case.
' Return value:
' - Returns a list of comma separated "index, length" value pairs. The pairs are separated
'   by a semicolon.
' Usage Example:
'   DIM cbsText AS CBSTR = "blah blah a234 blah blah x345 blah blah"
'   DIM cbsPattern AS CBSTR = "[a-z][0-9][0-9][0-9]"
'   DIM cbsOut AS CBSTR
'   cbsOut = pRegExp.InStr(cbsText, cbsPattern)
'   PRINT cbs   - prints 11,4; 26,4
' ========================================================================================
PRIVATE FUNCTION CRegExp.InStr (BYREF cbsSourceString AS CBSTR, BYREF cbsPattern AS CBSTR, _
   BYVAL bIgnoreCase AS BOOLEAN = FALSE, BYVAL bGlobal AS BOOLEAN = TRUE, BYVAL bMultiline AS BOOLEAN = TRUE) AS CBSTR

   IF m_pRegExp = NULL THEN this.SetResult(E_POINTER): RETURN ""
   m_pRegExp->put_IgnoreCase(bIgnoreCase)
   m_pRegExp->put_Global(bGlobal)
   m_pRegExp->put_Multiline(bMultiline)
   m_pRegExp->put_Pattern(cbsPattern)

   DIM cbsOut AS CBSTR, pMatches AS Afx_IMatchCollection2 PTR
   this.SetResult(m_pRegExp->Execute(cbsSourceString, cast(Afx_IDispatch PTR PTR, @pMatches)))
   IF pMatches THEN
      DIM nCount AS LONG
      pMatches->get_Count(@nCount)
      FOR i AS LONG = 0 TO nCount - 1
         DIM pMatch AS Afx_IMatch2 PTR
         this.SetResult(pMatches->get_Item(i, cast(Afx_IDispatch PTR PTR, @pMatch)))
         IF pMatch THEN
            DIM nFirstIndex AS LONG
            pMatch->get_FirstIndex(@nFirstIndex)
            DIM nLen AS LONG
            pMatch->get_Length(@nLen)
            IF i < nCount - 1 THEN
               cbsOut += STR(i + 1) & "," & STR(nLen) & ";"
            ELSE
               cbsOut += STR(i + 1) & "," & STR(nLen)
            END IF
            AfxSafeRelease(pMatch)
         END IF
      NEXT
      AfxSafeRelease(pMatches)
   END IF
   RETURN cbsOut

END FUNCTION
' ========================================================================================
Title: Re: CWindow Release Candidate 31
Post by: José Roca on August 12, 2017, 01:09:58 AM
Layered window template.

Code: [Select]
2
FBGUI
.bas
CWindow: Layered window
' ########################################################################################
' Microsoft Windows
' File: CW_LayeredWindow.fbtpl
' Contents: CWindow layered window example
' Compiler: FreeBasic 32 & 64 bit
' Copyright (c) 2017 Jose Roca. Freeware. Use at your own risk.
' THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
' EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE IMPLIED WARRANTIES OF
' MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
' ########################################################################################

#define UNICODE
#INCLUDE ONCE "Afx/CWindow.inc"
USING Afx

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)

' // Forward declaration
DECLARE FUNCTION WndProc (BYVAL hwnd AS HWND, BYVAL uMsg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM) AS LRESULT

' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS HINSTANCE, _
                  BYVAL hPrevInstance AS HINSTANCE, _
                  BYVAL szCmdLine AS ZSTRING PTR, _
                  BYVAL nCmdShow AS LONG) AS LONG

   ' // Set process DPI aware
   ' // The recommended way is to use a manifest file
   AfxSetProcessDPIAware

   ' // Creates the main window
   DIM pWindow AS CWindow
   DIM hwnd AS HWND = pWindow.Create(NULL, "CWindow - Layered window", @WndProc)
   ' // Make the window layered
   AfxAddWindowExStyle(hwnd, WS_EX_LAYERED)
   ' // Make this window 70% alpha
   SetLayeredWindowAttributes(hwnd, 0, (255 * 70) / 100, LWA_ALPHA)
   ' // Sizes it by setting the wanted width and height of its client area
   pWindow.SetClientSize(500, 320)
   ' // Centers the window
   pWindow.Center

   ' // Adds a button
   pWindow.AddControl("Button", , IDCANCEL, "&Close", 350, 250, 75, 23)

   |

   ' // Displays the window and dispatches the Windows messages
   FUNCTION = pWindow.DoEvents(nCmdShow)

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

' ========================================================================================
' Main window procedure
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS HWND, BYVAL uMsg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM) AS LRESULT

   SELECT CASE uMsg

      CASE WM_COMMAND
         SELECT CASE GET_WM_COMMAND_ID(wParam, lParam)
            CASE IDCANCEL
               ' // If ESC key pressed, close the application by sending an WM_CLOSE message
               IF GET_WM_COMMAND_CMD(wParam, lParam) = BN_CLICKED THEN
                  SendMessageW hwnd, WM_CLOSE, 0, 0
                  EXIT FUNCTION
               END IF
         END SELECT

      CASE WM_SIZE
         ' // Optional resizing code
         IF wParam <> SIZE_MINIMIZED THEN
            ' // Retrieve a pointer to the CWindow class
            DIM pWindow AS CWindow PTR = AfxCWindowPtr(hwnd)
            ' // Move the position of the button
            IF pWindow THEN pWindow->MoveWindow GetDlgItem(hwnd, IDCANCEL), _
               pWindow->ClientWidth - 120, pWindow->ClientHeight - 50, 75, 23, CTRUE
         END IF

    CASE WM_DESTROY
         ' // Ends the application by sending a WM_QUIT message
         PostQuitMessage(0)
         EXIT FUNCTION

   END SELECT

   ' // Default processing of Windows messages
   FUNCTION = DefWindowProcW(hwnd, uMsg, wParam, lParam)

END FUNCTION
' ========================================================================================
Title: Re: CWindow Release Candidate 31
Post by: José Roca on August 12, 2017, 06:14:50 AM
Using the WinFBE editor with the UTF-8 (BOM) encoding, and using CWSTR, CBSTR, CVAR or WSTRING as the data types, international users can now work with unicode transparently.

Code: [Select]
'DIM cws AS CWSTR = "ドミートリイ・ショスタコーヴィチ"   ' Chinese
DIM cws AS CWSTR = "Дми́трий Шостако́вич"   ' Russian
SetWindowTextW hCtl, cws

DIM cbs AS CBSTR = "Дми́трий Шостако́вич"   ' Russian
SetWindowTextW hCtl, cbs

DIM cv AS CVAR = "Дми́трий Шостако́вич"   ' Russian
SetWindowTextW hCtl, cv.wstr

DIM cws2 AS CWSTR = "دمیتری دمیتری‌یویچ شوستاکوویچ"    ' Arab
SetWindowTextW hCtl, cws2

Finally we can use unicode transparently with languages like Chinese, Russian, Arab, etc., even mixed.

All the other past attempts (charsets, code pages) must fall into the oblivion. This one seems to work perfectly and no conversions are needed since the characters are stored in the data types as unicode, not utf8.

Hope our international members will bother to test...
Title: Re: CWindow Release Candidate 31
Post by: José Roca on August 12, 2017, 06:56:57 AM
@Paul,

Maybe changing the file encoding should require confirmation. Too easy to click the status bar by accident and mess the code.
Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on August 12, 2017, 10:01:08 AM
@Paul,

Maybe changing the file encoding should require confirmation. Too easy to click the status bar by accident and mess the code.

Hi Jose, instead of an intrusive confirmation messagebox, I'll have a context menu popup allowing to choose between the 3 file types. This will be similar to the way that the panel next to it works when wanting to switch between NORMAL, MODULE, MAIN, etc...
Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on August 12, 2017, 10:12:11 AM
@Paul,

Maybe changing the file encoding should require confirmation. Too easy to click the status bar by accident and mess the code.

Hi Jose, instead of an intrusive confirmation messagebox, I'll have a context menu popup allowing to choose between the 3 file types. This will be similar to the way that the panel next to it works when wanting to switch between NORMAL, MODULE, MAIN, etc...

This is now done and will be in the next update.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on August 14, 2017, 08:25:07 AM
Updated the framework with some minor changes and a new class: CPropVar.

CPropVar implements a new data type, PROPVARIANT, that is needed to use some COM technologies.

I think that we already have all the Windows data types.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on August 14, 2017, 04:15:38 PM
Help file in .chm format.
Title: Re: CWindow Release Candidate 31
Post by: Johan Klassen on August 14, 2017, 04:44:57 PM
thank you Jose Roca for the help file  :)
Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on August 14, 2017, 06:21:56 PM
Is there anything in PowerBasic that we still can't do using FreeBasic?  (maybe working with, or interfacing to, DLL's is easier in PB)

Jose's library makes it so easy to program Windows in 32 and 64 bit.

Title: Re: CWindow Release Candidate 31
Post by: José Roca on August 15, 2017, 12:43:14 AM
> Is there anything in PowerBasic that we still can't do using FreeBasic?

There is not much left. And the alternatives offered by the framework are superior.

I'm going to add this small class:

Code: [Select]
' ========================================================================================
' CComPtr class
' ========================================================================================
TYPE CComPtr
   m_pUnk AS IUnknown PTR
   DECLARE CONSTRUCTOR (BYVAL pUnk AS ANY PTR, BYVAL fAddRef AS BOOLEAN = FALSE)
   DECLARE DESTRUCTOR
   DECLARE OPERATOR Let (BYVAL pUnk AS ANY PTR)
END TYPE
' ========================================================================================
' ========================================================================================
PRIVATE CONSTRUCTOR CComPtr (BYVAL pUnk AS ANY PTR, BYVAL fAddRef AS BOOLEAN = FALSE)
   m_pUnk = pUnk
   IF fAddRef THEN AfxSafeAddRef(m_pUnk)
END CONSTRUCTOR
' ========================================================================================
' ========================================================================================
PRIVATE DESTRUCTOR CComPtr
   AfxSafeRelease(m_pUnk)
END DESTRUCTOR
' ========================================================================================
' ========================================================================================
PRIVATE OPERATOR CComPtr.Let (BYVAL pUnk AS ANY PTR)
   AfxSafeRelease(m_pUnk)
   m_pUnk= pUnk
END OPERATOR
' ========================================================================================
' ========================================================================================
PRIVATE OPERATOR * (BYREF _ccomptr AS CComPtr) AS ANY PTR
   OPERATOR = _ccomptr.m_pUnk
END OPERATOR
' ========================================================================================

When working with COM we can assign COM pointers to instances of this class and we no longer have to worry about releasing them.
Title: Re: CWindow Release Candidate 31
Post by: James Fuller on August 15, 2017, 06:44:33 AM
Is there anything in PowerBasic that we still can't do using FreeBasic?  (maybe working with, or interfacing to, DLL's is easier in PB)

Jose's library makes it so easy to program Windows in 32 and 64 bit.
One of the big selling points of PowerBASIC in my opinion is the ease to create COM servers.

James
Title: Re: CWindow Release Candidate 31
Post by: aloberr on August 15, 2017, 08:36:42 AM
COM servers can be easy with the use of the virtual classes, that will be more with the concepts of interface or/and  multiples inheritance that FB do not have yet.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on August 15, 2017, 03:45:14 PM
Is there anything in PowerBasic that we still can't do using FreeBasic?  (maybe working with, or interfacing to, DLL's is easier in PB)

Jose's library makes it so easy to program Windows in 32 and 64 bit.
One of the big selling points of PowerBASIC in my opinion is the ease to create COM servers.

James


You must be the only one using this feature. I don't know of any other user writing COM servers with PB. Any example of a COM server written with PB?
Title: Re: CWindow Release Candidate 31
Post by: José Roca on August 15, 2017, 11:59:28 PM
Well, I have translated this example to Free Basic:

COM in plain C: https://www.codeproject.com/Articles/13601/COM-in-plain-C

Just to know what are the minimal requirements.

C++ examples use ATL, wizards, etc., and you get lost in a lot of messy code.

Code: [Select]
' // Free Basic source code to a simple COM object, compiled into an ordinary
' // dynamic link library (DLL).

#include once "windows.bi"
#include once "win/ocidl.bi"

' // Our IExample object's GUID
' // {6899A2A3-405B-44d4-A415-E0 8C EE 2A 97 CB}
DIM SHARED CLSID_IExample AS GUID = TYPE(&h6899A2A3, &h405B, &h44D4, {&hA4, &h15, &hE0, &h8C, &hEE, &h2A, &h97, &hCB})

' // Our IExample VTable's GUID
' // {74666CAC-C2B1-4FA8-A049-97F3214802F0}
DIM SHARED IID_IExample AS GUID = TYPE(&h74666CAC, &hC2B1, &h4FA8, {&hA0, &h49, &h97, &hF3, &h21, &h48, &h02, &hF0})

' // A count of how many objects our DLL has created (by some
' // app calling our IClassFactory object's CreateInstance())
' // which have not yet been Release()'d by the app
STATIC SHARED OutstandingObjects AS DWORD

' // A count of how many apps have locked our DLL via calling our
' // IClassFactory object's LockServer()
STATIC SHARED LockCount AS DWORD

' ========================================================================================
' IExample object
' ========================================================================================

TYPE IExampleVtbl_ As IExampleVtbl
TYPE IExample
   lpvtbl AS IExampleVtbl_ Ptr
   ' // Additional variables
   count AS DWORD
   buffer AS WSTRING * 80
END TYPE

TYPE IExampleVTbl
   ' Functions for the IUnknown Interface
   QueryInterface AS FUNCTION (BYVAL pthis AS IExample PTR, BYVAL vTableGuid AS CONST IID CONST PTR, BYVAL ppv AS ANY PTR PTR) AS HRESULT
   AddRef AS FUNCTION (BYVAL pthis AS IExample PTR) AS ULONG
   Release AS FUNCTION (BYVAL pthis AS IExample PTR) AS ULONG
   ' Our functions
   SetString AS Function (BYVAL pthis AS IExample PTR, BYVAL pwsz AS WSTRING PTR) AS HRESULT
   GetString AS FUNCTION (BYVAL pthis AS IExample PTR, BYVAL pbuffer AS WSTRING PTR, BYVAL cch AS DWORD) AS HRESULT
END TYPE

' ========================================================================================
' IExample methods
' ========================================================================================

' // IExample's QueryInterface()
FUNCTION QueryInterface (BYVAL pthis AS IExample PTR, BYVAL vTableGuid AS CONST IID CONST PTR, BYVAL ppv AS ANY PTR PTR) AS HRESULT
   ' // Check if the GUID matches IExample VTable's GUID. We gave the C variable name
   ' // IID_IExample to our VTable GUID. We can use an OLE function called
   ' // IsEqualIID to do the comparison for us. Also, if the caller passed a
   ' // IUnknown GUID, then we'll likewise return the IExample, since it can
   ' // masquerade as an IUnknown object too
   IF IsEqualIID(vTableGuid, @IID_IUnknown) = FALSE AND IsEqualIID(vTableGuid, @IID_IExample) = FALSE THEN
      ' // We don't recognize the GUID passed to us. Let the caller know this,
      ' // by clearing his handle, and returning E_NOINTERFACE.
      *ppv = 0
      RETURN E_NOINTERFACE
   END IF

   ' // Fill in the caller's handle
   *ppv = pthis

   ' // Increment the count of callers who have an outstanding pointer to this object
   pthis->lpVtbl->AddRef(pthis)

   RETURN NOERROR
END FUNCTION

' // IExample's AddRef()
FUNCTION AddRef(BYVAL pthis AS IExample PTR) AS ULONG
   ' // Increment IExample's reference count, and return the updated value.
   ' // NOTE: We have to typecast to gain access to any data members. These
   ' // members are not defined in our .H file (so that an app can't directly
   ' // access them). Rather they are defined only above in our MyRealIExample
   ' // struct. So typecast to that in order to access those data members
   pthis->count += 1
   RETURN pthis->count
END FUNCTION

' // IExample's Release()
FUNCTION Release (BYVAL pthis AS IExample PTR) AS ULONG
   ' // Decrement IExample's reference count. If 0, then we can safely free
   ' // this IExample now
   pthis->count -= 1
   IF pthis->count = 0 THEN
      GlobalFree(pthis)
      InterlockedDecrement(@OutstandingObjects)
      RETURN 0
   END IF
   RETURN pthis->count
END FUNCTION

' // IExample's SetString(). This copies the passed string to IExample's buffer
FUNCTION SetString (BYVAL pthis AS IExample PTR, BYVAL pwsz AS WSTRING PTR) AS HRESULT
   ' // Make sure that caller passed a buffer
   IF pwsz = NULL THEN RETURN E_POINTER
   ' // Copy the passed str to IExample's buffer
   pthis->buffer = *pwsz
   RETURN NOERROR
END FUNCTION

' // IExample's GetString(). This retrieves IExample's buffer,
' // and stores its contents in a buffer passed by the caller
FUNCTION GetString(BYVAL pthis AS IExample PTR, BYVAL pbuffer AS WSTRING PTR, BYVAL cch AS DWORD) AS HRESULT
   ' // Make sure that caller passed a buffer
   IF pbuffer = NULL THEN RETURN E_POINTER
   IF cch THEN
      ' // Let's copy IExample's buffer to the passed buffer
      IF cch > 79 THEN cch = 79
      memcpy(pbuffer, @pthis->buffer, cch)
   END IF
   RETURN NOERROR
END FUNCTION

' // Here's IExample's VTable. It never changes so we can declare it static
STATIC SHARED IExample_Vtbl AS IExampleVtbl = TYPE(@QueryInterface, @AddRef, @Release, _
   @SetString, @GetString)

' ========================================================================================
' // The IClassFactory object ////////////////////////////////////////////////////////////
' ========================================================================================

' // Since we only ever need one IClassFactory object, we declare
' // it static. The only requirement is that we ensure any
' // access to its members is thread-safe
STATIC SHARED MyIClassFactoryObj As IClassFactory

' // IClassFactory's AddRef()
FUNCTION classAddRef (BYVAL pthis AS IClassFactory PTR) AS ULONG
   ' // Someone is obtaining my IClassFactory, so inc the count of
   ' // pointers that I've returned which some app needs to Release()
   InterlockedIncrement(@OutstandingObjects)

   ' // Since we never actually allocate/free an IClassFactory (ie, we
   ' // use just 1 static one), we don't need to maintain a separate
   ' // reference count for our IClassFactory. We'll just tell the caller
   ' // that there's at least one of our IClassFactory objects in existance
   RETURN 1
END FUNCTION

' // IClassFactory's QueryInterface()
FUNCTION classQueryInterface (BYVAL pthis AS IClassFactory PTR, BYVAL factoryGuid AS CONST IID CONST PTR, BYVAL ppv AS ANY PTR PTR) AS HRESULT
   ' // Make sure the caller wants either an IUnknown or an IClassFactory.
   ' // In either case, we return the same IClassFactory pointer passed to
   ' // us since it can also masquerade as an IUnknown
   IF IsEqualIID(factoryGuid, @IID_IUnknown) OR IsEqualIID(factoryGuid, @IID_IClassFactory) THEN
      ' // Call my IClassFactory's AddRef
      pthis->lpVtbl->AddRef(pthis)
      ' // Return (to the caller) a ptr to my IClassFactory
      *ppv = pthis
      RETURN NOERROR
   END IF

   ' // We don't know about any other GUIDs
   *ppv = 0
   RETURN E_NOINTERFACE
END FUNCTION

' // IClassFactory's Release()
FUNCTION classRelease(BYVAL pthis AS IClassFactory PTR) AS ULONG
   ' // One less object that an app has not yet Release()'ed
   RETURN InterlockedDecrement(@OutstandingObjects)
END FUNCTION

' // IClassFactory's CreateInstance() function. It is called by
' // someone who has a pointer to our IClassFactory object and now
' // wants to create and retrieve a pointer to our IExample
FUNCTION classCreateInstance(BYVAL pthis AS IClassFactory PTR, BYVAL punkOuter AS IUnknown PTR, _
   BYVAL vTableGuid AS CONST IID CONST PTR, BYVAL objHandle AS ANY PTR PTR) AS HRESULT

   DIM hr AS HRESULT
   DIM thisObj AS IExample PTR

   ' // Assume an error by clearing caller's handle
   *objHandle = 0

   ' // We don't support aggregation in this example
   IF punkOuter THEN RETURN CLASS_E_NOAGGREGATION
   ' // Allocate our IExample object
   thisObj = GlobalAlloc(GMEM_FIXED, SIZEOF(IExample))
   IF thisObj = NULL THEN RETURN E_OUTOFMEMORY
   ' // Store IExample's VTable in the object
   thisobj->lpVtbl = @IExample_Vtbl
   ' // Increment the reference count so we can call Release() below and
   '  // it will deallocate only if there is an error with QueryInterface()
   thisobj->count = 1
   ' // Initialize any other members we added to the IExample. We added
   ' // a buffer member
   thisobj->buffer = ""
   ' // Fill in the caller's handle with a pointer to the IExample we just
   ' // allocated above. We'll let IExample's QueryInterface do that, because
   ' // it also checks the GUID the caller passed, and also increments the
   ' // reference count (to 2) if all goes well
   hr = thisObj->lpVtbl->QueryInterface(thisobj, vTableGuid, objHandle)
   ' // Decrement reference count. NOTE: If there was an error in QueryInterface()
   ' // then Release() will be decrementing the count back to 0 and will free the
   ' // IExample for us. One error that may occur is that the caller is asking for
   ' // some sort of object that we don't support (ie, it's a GUID we don't recognize)
   thisObj->lpVtbl->Release(thisobj)
   ' // If success, inc static object count to keep this DLL loaded
   IF hr = S_OK THEN InterlockedIncrement(@OutstandingObjects)

   RETURN hr
END FUNCTION

' // IClassFactory's LockServer(). It is called by someone
' // who wants to lock this DLL in memory
FUNCTION classLockServer (BYVAL pthis AS IClassFactory PTR, BYVAL flock AS WINBOOL) AS HRESULT
   IF flock THEN InterlockedIncrement(@LockCount) ELSE InterlockedDecrement(@LockCount)
   RETURN NOERROR
END FUNCTION

STATIC SHARED MyClassFactoryVTbl AS IClassFactoryVTbl = TYPE(@classQueryInterface, _
   @classAddRef, @classRelease, @classCreateInstance, @classLockServer)

' ========================================================================================
' Implementation of the DllGetClassObject and DllCanUnloadNow functions.
' ========================================================================================

EXTERN "windows-ms"

#UNDEF DllGetClassObject
FUNCTION DllGetClassObject ALIAS "DllGetClassObject" ( _
   BYVAL objGuid AS CLSID PTR, _
   BYVAL factoryGuid AS IID PTR, _
   BYVAL factoryHandle As VOID PTR PTR _
   ) AS HRESULT EXPORT

   DIM hr AS HRESULT

   ' // Check that the caller is passing our IExample GUID. That's the
   ' // only object our DLL implements
   IF IsEqualCLSID(objGuid, @CLSID_IExample) THEN
      ' // Fill in the caller's handle with a pointer to our IClassFactory object.
      ' // We'll let our IClassFactory's QueryInterface do that, because it also
      ' // checks the IClassFactory GUID and does other book-keeping
      hr = classQueryInterface(@MyIClassFactoryObj, factoryGuid, factoryHandle)
   ELSE
      ' // We don't understand this GUID. It's obviously not for our DLL.
      ' // Let the caller know this by clearing his handle and returning
      ' // CLASS_E_CLASSNOTAVAILABLE
      *factoryHandle = 0
      hr = CLASS_E_CLASSNOTAVAILABLE
   END IF

   RETURN hr

END FUNCTION

' * This is called by some OLE function in order to determine
' * whether it is safe to unload our DLL from memory.
' *
' * RETURNS: S_OK if safe to unload, or S_FALSE if not.

' // If someone has retrieved pointers to any of our objects, and
' // not yet Release()'ed them, then we return S_FALSE to indicate
' // not to unload this DLL. Also, if someone has us locked, return
' // S_FALSE

#UNDEF DllCanUnloadNow
FUNCTION DllCanUnloadNow ALIAS "DllCanUnloadNow" () AS HRESULT EXPORT
   RETURN IIF(OutstandingObjects OR LockCount, S_FALSE, S_OK)
END FUNCTION

' ========================================================================================

END EXTERN

' ========================================================================================
' Constructor and destructor of the module
' ========================================================================================
SUB ctor () CONSTRUCTOR
   OutputDebugString "DLL loaded"
   ' // Clear static counts
   OutstandingObjects = 0
   LockCount = 0
   ' // Initialize my IClassFactory with the pointer to its VTable
   MyIClassFactoryObj.lpVtbl = @MyClassFactoryVTbl
END SUB

SUB dtor () DESTRUCTOR
    OutputDebugString "DLL unloaded"
END SUB
' ========================================================================================

You must compile it as a DLL with the -dll switch.

This is a test using one of my overloaded AfxNewCom functions that allows to use the server without having to register it.

Code: [Select]
'#CONSOLE ON
#define UNICODE
#INCLUDE ONCE "windows.bi"
#include once "win/ocidl.bi"
#include once "Afx/AfxCOM.inc"
USING Afx

' // Our IExample object's GUID
' // {6899A2A3-405B-44d4-A415-E0 8C EE 2A 97 CB}
DIM CLSID_IExample AS GUID = TYPE(&h6899A2A3, &h405B, &h44D4, {&hA4, &h15, &hE0, &h8C, &hEE, &h2A, &h97, &hCB})
' // Our IExample VTable's GUID
' // {74666CAC-C2B1-4FA8-A049-97F3214802F0}
DIM IID_IExample AS GUID = TYPE(&h74666CAC, &hC2B1, &h4FA8, {&hA0, &h49, &h97, &hF3, &h21, &h48, &h02, &hF0})

TYPE IExample As IExample_
TYPE IExampleVTbl
   ' Functions for the IUnknown Interface
   QueryInterface AS FUNCTION (BYVAL pthis AS IExample PTR, BYVAL vTableGuid AS CONST IID CONST PTR, BYVAL ppv AS ANY PTR PTR) AS HRESULT
   AddRef AS FUNCTION (BYVAL pthis AS IExample PTR) AS HRESULT
   Release AS FUNCTION (BYVAL pthis AS IExample PTR) AS HRESULT
   ' Our functions
   SetString AS Function (BYVAL pthis AS IExample PTR, BYVAL pwsz AS WSTRING PTR) AS HRESULT
   GetString AS FUNCTION (BYVAL pthis AS IExample PTR, BYVAL pbuffer AS WSTRING PTR, BYVAL cch AS DWORD) AS HRESULT
END TYPE

TYPE IExample_
   lpVtbl as IExampleVTbl PTR
END TYPE

' // Initialize the COM library
CoInitialize NULL

DIM wszLibName AS WSTRING * MAX_PATH = ExePath & "\IExample.dll"
DIM pExample AS IExample PTR = AfxNewCom(wszLibName, CLSID_IExample, IID_IExample)
print "pExample = ", pExample
IF pExample THEN
   DIM hr AS HRESULT
   hr = pExample->lpvtbl->SetString(pExample, "Jose Roca")
   IF hr THEN print "hr = ", HEX(hr, 8)
   DIM wsz AS WSTRING * 80
   hr = pExample->lpvtbl->GetString(pExample, @wsz, SIZEOF(wsz))
   IF hr THEN print "hr = ", HEX(hr, 8)
   PRINT wsz
END IF
AfxSafeRelease(pExample)

' // Uninitialize the COM library
CoUninitialize

PRINT
PRINT "Press any key..."
SLEEP

and it works.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on August 16, 2017, 12:06:57 AM
Now it is a matter of seeing if the task can be simplified, if we can use a Free Basic class instead of a plain virtual table, etc.

I'm only interested in low-level COM servers. I don't plan to get involved in the nasty business of creating OCXs, type libraries, etc.

Please note that I'm not using DllMain or LibMain in the DLL because apparently it does not work, so I'm using the constructor and destructor of the module instead.

See this thread: http://www.freebasic.net/forum/viewtopic.php?t=15690

Also note that if we only use COM and don't add to the DLL other exported functions that we wish to call, we don't need to use the generated import library.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on August 16, 2017, 01:53:02 AM
The test example using abstract methods:

Code: [Select]
'#CONSOLE ON
#define UNICODE
#INCLUDE ONCE "windows.bi"
#include once "win/ocidl.bi"
#include once "Afx/AfxCOM.inc"

' // Our IExample object's GUID
' // {6899A2A3-405B-44d4-A415-E0 8C EE 2A 97 CB}
DIM CLSID_IExample AS GUID = TYPE(&h6899A2A3, &h405B, &h44D4, {&hA4, &h15, &hE0, &h8C, &hEE, &h2A, &h97, &hCB})
' // Our IExample VTable's GUID
' // {74666CAC-C2B1-4FA8-A049-97F3214802F0}
DIM IID_IExample AS GUID = TYPE(&h74666CAC, &hC2B1, &h4FA8, {&hA0, &h49, &h97, &hF3, &h21, &h48, &h02, &hF0})

TYPE IExample EXTENDS Afx_IUnknown
   DECLARE ABSTRACT FUNCTION SetString (BYVAL pwsz AS WSTRING PTR) AS HRESULT
   DECLARE ABSTRACT FUNCTION GetString (BYVAL pbuffer AS WSTRING PTR, BYVAL cch AS DWORD) AS HRESULT
END TYPE

' // Initialize the COM library
CoInitialize NULL

DIM wszLibName AS WSTRING * MAX_PATH = ExePath & "\IExample.dll"
DIM pExample AS IExample PTR = AfxNewCom(wszLibName, CLSID_IExample, IID_IExample)
print "pExample = ", pExample
IF pExample THEN
   DIM hr AS HRESULT
   hr = pExample->SetString("Jose Roca")
   IF hr THEN print "hr = ", HEX(hr, 8)
   DIM wsz AS WSTRING * 80
   hr = pExample->GetString(@wsz, SIZEOF(wsz))
   IF hr THEN print "hr = ", HEX(hr, 8)
   PRINT wsz
END IF
AfxSafeRelease(pExample)

' // Uninitialize the COM library
CoUninitialize

PRINT
PRINT "Press any key..."
SLEEP
Title: Re: CWindow Release Candidate 31
Post by: José Roca on August 16, 2017, 02:28:30 AM
Examples of use with PowerBASIC (32-bit only)

Inheriting from IUnknown:

Code: [Select]
#INCLUDE ONCE "windows.inc"

$CLSID_IExample = GUID$("{6899A2A3-405B-44D4-A415-E08CEE2A97CB}")
$IID_IExample = GUID$("{74666CAC-C2B1-4FA8-A049-97F3214802F0}")

INTERFACE IExample $IID_IExample : INHERIT IUnknown
   METHOD SetString (BYREF pwsz AS WSTRINGZ) AS LONG
   METHOD GetString (BYREF pbuffer AS WSTRINGZ, BYVAL cch AS DWORD) AS LONG
END INTERFACE

FUNCTION PBMAIN

DIM LibName AS STRING
LibName = Exe.Path$ & "IExample.dll"
DIM pExample AS IExample
pExample = NEWCOM CLSID $CLSID_IExample LIB LibName
IF ISOBJECT(pExample) THEN
   DIM hr AS LONG
   hr = pExample.SetString("Jose Roca")
   IF hr THEN print "hr = ", HEX$(hr, 8)
   DIM wsz AS WSTRINGZ * 80
   hr = pExample.GetString(wsz, SIZEOF(wsz))
   IF hr THEN print "hr = ", HEX$(hr, 8)
   PRINT wsz
END IF

PRINT
PRINT "Press any key..."
WAITKEY$

END FUNCTION

Inheriting from IAutomation:

Code: [Select]
#INCLUDE ONCE "windows.inc"
#INCLUDE ONCE "Ole2utils.inc"

$CLSID_IExample = GUID$("{6899A2A3-405B-44D4-A415-E08CEE2A97CB}")
$IID_IExample = GUID$("{74666CAC-C2B1-4FA8-A049-97F3214802F0}")

INTERFACE IExample $IID_IExample : INHERIT IAutomation
   METHOD SetString (BYREF pwsz AS WSTRINGZ)
   METHOD GetString (BYREF pbuffer AS WSTRINGZ, BYVAL cch AS DWORD)
END INTERFACE

FUNCTION PBMAIN

DIM LibName AS STRING
LibName = Exe.Path$ & "IExample.dll"
DIM pExample AS IExample
pExample = NEWCOM CLSID $CLSID_IExample LIB LibName
IF ISOBJECT(pExample) THEN
   TRY
      pExample.SetString("Jose Roca")
      DIM wsz AS WSTRINGZ * 80
      pExample.GetString(wsz, SIZEOF(wsz))
      PRINT wsz
   CATCH
      PRINT HEX$(OBJRESULT, 8)
   END TRY
END IF

PRINT
PRINT "Press any key..."
WAITKEY$

END FUNCTION

Therefore, FB can be used to write COM servers that work with PB and viceversa. After all, COM is a binary standard. The problem with PB is that it is 32-bit only; otherwise, probably I never would have tried FB.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on August 16, 2017, 04:12:29 AM
I have managed to use a class using virtual methods.

Code: [Select]
' ========================================================================================
' IExample object
' ========================================================================================
TYPE IExample EXTENDS Afx_IUnknown
   ' Functions for the IUnknown Interface
   DECLARE VIRTUAL FUNCTION QueryInterface (BYVAL vTableGuid AS CONST IID CONST PTR, BYVAL ppv AS ANY PTR PTR) AS HRESULT
   DECLARE VIRTUAL FUNCTION AddRef () AS ULONG
   DECLARE VIRTUAL FUNCTION Release () AS ULONG
   ' Our functions
   DECLARE VIRTUAL FUNCTION SetString (BYVAL pwsz AS WSTRING PTR) AS HRESULT
   DECLARE VIRTUAL FUNCTION GetString (BYVAL pbuffer AS WSTRING PTR, BYVAL cch AS DWORD) AS HRESULT
   ' Constructor/destructor
   DECLARE CONSTRUCTOR
   DECLARE DESTRUCTOR
   ' Data
   count AS DWORD
   buffer AS WSTRING * 80
END TYPE
' ========================================================================================

This means that we can use all kind of data types, even CWSTR, CBSTR, etc., to store the data.

DLL code:

Code: [Select]
' // Free Basic source code to a simple COM object, compiled into an ordinary
' // dynamic link library (DLL).

#include once "windows.bi"
#include once "win/ocidl.bi"
#include once "Afx/AfxCOM.inc"

' // Our IExample object's GUID
' // {6899A2A3-405B-44d4-A415-E0 8C EE 2A 97 CB}
DIM SHARED CLSID_IExample AS GUID = TYPE(&h6899A2A3, &h405B, &h44D4, {&hA4, &h15, &hE0, &h8C, &hEE, &h2A, &h97, &hCB})

' // Our IExample VTable's GUID
' // {74666CAC-C2B1-4FA8-A049-97F3214802F0}
DIM SHARED IID_IExample AS GUID = TYPE(&h74666CAC, &hC2B1, &h4FA8, {&hA0, &h49, &h97, &hF3, &h21, &h48, &h02, &hF0})

' // A count of how many objects our DLL has created (by some
' // app calling our IClassFactory object's CreateInstance())
' // which have not yet been Release()'d by the app
STATIC SHARED OutstandingObjects AS DWORD

' // A count of how many apps have locked our DLL via calling our
' // IClassFactory object's LockServer()
STATIC SHARED LockCount AS DWORD

' ========================================================================================
' IExample object
' ========================================================================================
TYPE IExample EXTENDS Afx_IUnknown
   ' Functions for the IUnknown Interface
   DECLARE VIRTUAL FUNCTION QueryInterface (BYVAL vTableGuid AS CONST IID CONST PTR, BYVAL ppv AS ANY PTR PTR) AS HRESULT
   DECLARE VIRTUAL FUNCTION AddRef () AS ULONG
   DECLARE VIRTUAL FUNCTION Release () AS ULONG
   ' Our functions
   DECLARE VIRTUAL FUNCTION SetString (BYVAL pwsz AS WSTRING PTR) AS HRESULT
   DECLARE VIRTUAL FUNCTION GetString (BYVAL pbuffer AS WSTRING PTR, BYVAL cch AS DWORD) AS HRESULT
   ' Constructor/destructor
   DECLARE CONSTRUCTOR
   DECLARE DESTRUCTOR
   ' Data
   count AS DWORD
   buffer AS WSTRING * 80
END TYPE
' ========================================================================================

' ========================================================================================
' IExample constructor
' ========================================================================================
CONSTRUCTOR IExample
END CONSTRUCTOR
' ========================================================================================

' ========================================================================================
' IExample destructor
' ========================================================================================
DESTRUCTOR IExample
END DESTRUCTOR
' ========================================================================================

' ========================================================================================
' IExample's QueryInterface
' ========================================================================================
FUNCTION IExample.QueryInterface (BYVAL vTableGuid AS CONST IID CONST PTR, BYVAL ppv AS ANY PTR PTR) AS HRESULT
   ' // Check if the GUID matches IExample VTable's GUID. We gave the C variable name
   ' // IID_IExample to our VTable GUID. We can use an OLE function called
   ' // IsEqualIID to do the comparison for us. Also, if the caller passed a
   ' // IUnknown GUID, then we'll likewise return the IExample, since it can
   ' // masquerade as an IUnknown object too
   IF IsEqualIID(vTableGuid, @IID_IUnknown) = FALSE AND IsEqualIID(vTableGuid, @IID_IExample) = FALSE THEN
      ' // We don't recognize the GUID passed to us. Let the caller know this,
      ' // by clearing his handle, and returning E_NOINTERFACE.
      *ppv = 0
      RETURN E_NOINTERFACE
   END IF
   ' // Fill in the caller's handle
   *ppv = @this
   ' // Increment the count of callers who have an outstanding pointer to this object
   this.AddRef
   RETURN NOERROR
END FUNCTION
' ========================================================================================

' ========================================================================================
' IExample's AddRef
' ========================================================================================
FUNCTION IExample.AddRef() AS ULONG
   ' // Increment IExample's reference count, and return the updated value.
   ' // NOTE: We have to typecast to gain access to any data members. These
   ' // members are not defined in our .H file (so that an app can't directly
   ' // access them). Rather they are defined only above in our MyRealIExample
   ' // struct. So typecast to that in order to access those data members
   this.count += 1
   RETURN this.count
END FUNCTION
' ========================================================================================

' ========================================================================================
' IExample's Release
' ========================================================================================
FUNCTION IExample.Release () AS ULONG
   ' // Decrement IExample's reference count
   this.count -= 1
   ' // If 0, then we can safely free this IExample now
   IF this.count = 0 THEN
      Delete @this
      InterlockedDecrement(@OutstandingObjects)
      RETURN 0
   END IF
   RETURN this.count
END FUNCTION
' ========================================================================================

' ========================================================================================
' IExample's SetString
' This copies the passed string to IExample's buffer
' ========================================================================================
FUNCTION IExample.SetString (BYVAL pwsz AS WSTRING PTR) AS HRESULT
   ' // Make sure that caller passed a buffer
   IF pwsz = NULL THEN RETURN E_POINTER
   ' // Copy the passed str to IExample's buffer
   this.buffer = *pwsz
   RETURN NOERROR
END FUNCTION
' ========================================================================================

' ========================================================================================
' IExample's GetString
' This retrieves IExample's buffer and stores its contents in a buffer passed by the caller.
' ========================================================================================
FUNCTION IExample.GetString (BYVAL pbuffer AS WSTRING PTR, BYVAL cch AS DWORD) AS HRESULT
   ' // Make sure that caller passed a buffer
   IF pbuffer = NULL THEN RETURN E_POINTER
   IF cch THEN
      ' // Let's copy IExample's buffer to the passed buffer
      IF cch > 79 THEN cch = 79
      memcpy(pbuffer, @this.buffer, cch)
   END IF
   RETURN NOERROR
END FUNCTION
' ========================================================================================

' ========================================================================================
' // The IClassFactory object ////////////////////////////////////////////////////////////
' ========================================================================================

' // Since we only ever need one IClassFactory object, we declare
' // it static. The only requirement is that we ensure any
' // access to its members is thread-safe
STATIC SHARED MyIClassFactoryObj As IClassFactory

' // IClassFactory's AddRef()
FUNCTION classAddRef (BYVAL pthis AS IClassFactory PTR) AS ULONG
   ' // Someone is obtaining my IClassFactory, so inc the count of
   ' // pointers that I've returned which some app needs to Release()
   InterlockedIncrement(@OutstandingObjects)

   ' // Since we never actually allocate/free an IClassFactory (ie, we
   ' // use just 1 static one), we don't need to maintain a separate
   ' // reference count for our IClassFactory. We'll just tell the caller
   ' // that there's at least one of our IClassFactory objects in existance
   RETURN 1
END FUNCTION

' // IClassFactory's QueryInterface()
FUNCTION classQueryInterface (BYVAL pthis AS IClassFactory PTR, BYVAL factoryGuid AS CONST IID CONST PTR, BYVAL ppv AS ANY PTR PTR) AS HRESULT
   ' // Make sure the caller wants either an IUnknown or an IClassFactory.
   ' // In either case, we return the same IClassFactory pointer passed to
   ' // us since it can also masquerade as an IUnknown
   IF IsEqualIID(factoryGuid, @IID_IUnknown) OR IsEqualIID(factoryGuid, @IID_IClassFactory) THEN
      ' // Call my IClassFactory's AddRef
      pthis->lpVtbl->AddRef(pthis)
      ' // Return (to the caller) a ptr to my IClassFactory
      *ppv = pthis
      RETURN NOERROR
   END IF

   ' // We don't know about any other GUIDs
   *ppv = 0
   RETURN E_NOINTERFACE
END FUNCTION

' // IClassFactory's Release()
FUNCTION classRelease(BYVAL pthis AS IClassFactory PTR) AS ULONG
   ' // One less object that an app has not yet Release()'ed
   RETURN InterlockedDecrement(@OutstandingObjects)
END FUNCTION

' // IClassFactory's CreateInstance() function. It is called by
' // someone who has a pointer to our IClassFactory object and now
' // wants to create and retrieve a pointer to our IExample
FUNCTION classCreateInstance(BYVAL pthis AS IClassFactory PTR, BYVAL punkOuter AS IUnknown PTR, _
   BYVAL vTableGuid AS CONST IID CONST PTR, BYVAL objHandle AS ANY PTR PTR) AS HRESULT

   DIM hr AS HRESULT
   ' // Assume an error by clearing caller's handle
   *objHandle = 0
   ' // We don't support aggregation in this example
   IF punkOuter THEN RETURN CLASS_E_NOAGGREGATION
   ' // Allocate our IExample object
   DIM thisObj AS IExample PTR = NEW IExample
   ' // Increment the reference count so we can call Release() below and
   '  // it will deallocate only if there is an error with QueryInterface()
   thisobj->count = 1
   ' // Initialize any other members we added to the IExample. We added
   ' // a buffer member
   thisobj->buffer = ""
   ' // Fill in the caller's handle with a pointer to the IExample we just
   ' // allocated above. We'll let IExample's QueryInterface do that, because
   ' // it also checks the GUID the caller passed, and also increments the
   ' // reference count (to 2) if all goes well
   hr = thisObj->QueryInterface(vTableGuid, objHandle)
   ' // Decrement reference count. NOTE: If there was an error in QueryInterface()
   ' // then Release() will be decrementing the count back to 0 and will free the
   ' // IExample for us. One error that may occur is that the caller is asking for
   ' // some sort of object that we don't support (ie, it's a GUID we don't recognize)
   thisObj->Release
   ' // If success, inc static object count to keep this DLL loaded
   IF hr = S_OK THEN InterlockedIncrement(@OutstandingObjects)
   RETURN hr
END FUNCTION

' // IClassFactory's LockServer(). It is called by someone
' // who wants to lock this DLL in memory
FUNCTION classLockServer (BYVAL pthis AS IClassFactory PTR, BYVAL flock AS WINBOOL) AS HRESULT
   IF flock THEN InterlockedIncrement(@LockCount) ELSE InterlockedDecrement(@LockCount)
   RETURN NOERROR
END FUNCTION

STATIC SHARED MyClassFactoryVTbl AS IClassFactoryVTbl = TYPE(@classQueryInterface, _
   @classAddRef, @classRelease, @classCreateInstance, @classLockServer)

' ========================================================================================
' Implementation of the DllGetClassObject and DllCanUnloadNow functions.
' ========================================================================================

EXTERN "windows-ms"

#UNDEF DllGetClassObject
FUNCTION DllGetClassObject ALIAS "DllGetClassObject" ( _
   BYVAL objGuid AS CLSID PTR, _
   BYVAL factoryGuid AS IID PTR, _
   BYVAL factoryHandle As VOID PTR PTR _
   ) AS HRESULT EXPORT

   DIM hr AS HRESULT

   ' // Check that the caller is passing our IExample GUID. That's the
   ' // only object our DLL implements
   IF IsEqualCLSID(objGuid, @CLSID_IExample) THEN
      ' // Fill in the caller's handle with a pointer to our IClassFactory object.
      ' // We'll let our IClassFactory's QueryInterface do that, because it also
      ' // checks the IClassFactory GUID and does other book-keeping
      hr = classQueryInterface(@MyIClassFactoryObj, factoryGuid, factoryHandle)
   ELSE
      ' // We don't understand this GUID. It's obviously not for our DLL.
      ' // Let the caller know this by clearing his handle and returning
      ' // CLASS_E_CLASSNOTAVAILABLE
      *factoryHandle = 0
      hr = CLASS_E_CLASSNOTAVAILABLE
   END IF

   RETURN hr

END FUNCTION

' * This is called by some OLE function in order to determine
' * whether it is safe to unload our DLL from memory.
' *
' * RETURNS: S_OK if safe to unload, or S_FALSE if not.

' // If someone has retrieved pointers to any of our objects, and
' // not yet Release()'ed them, then we return S_FALSE to indicate
' // not to unload this DLL. Also, if someone has us locked, return
' // S_FALSE

#UNDEF DllCanUnloadNow
FUNCTION DllCanUnloadNow ALIAS "DllCanUnloadNow" () AS HRESULT EXPORT
   RETURN IIF(OutstandingObjects OR LockCount, S_FALSE, S_OK)
END FUNCTION

' ========================================================================================

END EXTERN

' ========================================================================================
' Constructor of the module
' ========================================================================================
SUB ctor () CONSTRUCTOR
   OutputDebugString "DLL loaded"
   ' // Clear static counts
   OutstandingObjects = 0
   LockCount = 0
   ' // Initialize my IClassFactory with the pointer to its VTable
   MyIClassFactoryObj.lpVtbl = @MyClassFactoryVTbl
END SUB
' ========================================================================================

' ========================================================================================
' Destructor of the module
' ========================================================================================
SUB dtor () DESTRUCTOR
    OutputDebugString "DLL unloaded"
END SUB
' ========================================================================================

Test example, using ABSTRACT methods:

Code: [Select]
'#CONSOLE ON
#define UNICODE
#INCLUDE ONCE "windows.bi"
#include once "win/ocidl.bi"
#include once "Afx/AfxCOM.inc"

' // Our IExample object's GUID
' // {6899A2A3-405B-44d4-A415-E0 8C EE 2A 97 CB}
DIM CLSID_IExample AS GUID = TYPE(&h6899A2A3, &h405B, &h44D4, {&hA4, &h15, &hE0, &h8C, &hEE, &h2A, &h97, &hCB})
' // Our IExample VTable's GUID
' // {74666CAC-C2B1-4FA8-A049-97F3214802F0}
DIM IID_IExample AS GUID = TYPE(&h74666CAC, &hC2B1, &h4FA8, {&hA0, &h49, &h97, &hF3, &h21, &h48, &h02, &hF0})

TYPE IExample EXTENDS Afx_IUnknown
   DECLARE ABSTRACT FUNCTION SetString (BYVAL pwsz AS WSTRING PTR) AS HRESULT
   DECLARE ABSTRACT FUNCTION GetString (BYVAL pbuffer AS WSTRING PTR, BYVAL cch AS DWORD) AS HRESULT
END TYPE

' // Initialize the COM library
CoInitialize NULL

DIM wszLibName AS WSTRING * MAX_PATH = ExePath & "\IExample2.dll"
DIM pExample AS IExample PTR = AfxNewCom(wszLibName, CLSID_IExample, IID_IExample)
print "pExample = ", pExample
IF pExample THEN
   DIM hr AS HRESULT
   hr = pExample->SetString("Jose Roca")
   IF hr THEN print "hr = ", HEX(hr, 8)
   DIM wsz AS WSTRING * 80
   hr = pExample->GetString(@wsz, SIZEOF(wsz))
   IF hr THEN print "hr = ", HEX(hr, 8)
   PRINT wsz
END IF
AfxSafeRelease(pExample)

' // Uninitialize the COM library
CoUninitialize

PRINT
PRINT "Press any key..."
SLEEP
Title: Re: CWindow Release Candidate 31
Post by: José Roca on August 16, 2017, 04:24:18 AM
Looks like we are going to have a good alternative to ordinary DLLs :)

As you can see, low-level COM servers have very little overhead. Just the IClassFactory object and the DllGetClassObject/DllCanUnloadNow functions.

Code: [Select]
' ========================================================================================
' // The IClassFactory object ////////////////////////////////////////////////////////////
' ========================================================================================

' // Since we only ever need one IClassFactory object, we declare
' // it static. The only requirement is that we ensure any
' // access to its members is thread-safe
STATIC SHARED MyIClassFactoryObj As IClassFactory

' // IClassFactory's AddRef()
FUNCTION classAddRef (BYVAL pthis AS IClassFactory PTR) AS ULONG
   ' // Someone is obtaining my IClassFactory, so inc the count of
   ' // pointers that I've returned which some app needs to Release()
   InterlockedIncrement(@OutstandingObjects)

   ' // Since we never actually allocate/free an IClassFactory (ie, we
   ' // use just 1 static one), we don't need to maintain a separate
   ' // reference count for our IClassFactory. We'll just tell the caller
   ' // that there's at least one of our IClassFactory objects in existance
   RETURN 1
END FUNCTION

' // IClassFactory's QueryInterface()
FUNCTION classQueryInterface (BYVAL pthis AS IClassFactory PTR, BYVAL factoryGuid AS CONST IID CONST PTR, BYVAL ppv AS ANY PTR PTR) AS HRESULT
   ' // Make sure the caller wants either an IUnknown or an IClassFactory.
   ' // In either case, we return the same IClassFactory pointer passed to
   ' // us since it can also masquerade as an IUnknown
   IF IsEqualIID(factoryGuid, @IID_IUnknown) OR IsEqualIID(factoryGuid, @IID_IClassFactory) THEN
      ' // Call my IClassFactory's AddRef
      pthis->lpVtbl->AddRef(pthis)
      ' // Return (to the caller) a ptr to my IClassFactory
      *ppv = pthis
      RETURN NOERROR
   END IF

   ' // We don't know about any other GUIDs
   *ppv = 0
   RETURN E_NOINTERFACE
END FUNCTION

' // IClassFactory's Release()
FUNCTION classRelease(BYVAL pthis AS IClassFactory PTR) AS ULONG
   ' // One less object that an app has not yet Release()'ed
   RETURN InterlockedDecrement(@OutstandingObjects)
END FUNCTION

' // IClassFactory's CreateInstance() function. It is called by
' // someone who has a pointer to our IClassFactory object and now
' // wants to create and retrieve a pointer to our IExample
FUNCTION classCreateInstance(BYVAL pthis AS IClassFactory PTR, BYVAL punkOuter AS IUnknown PTR, _
   BYVAL vTableGuid AS CONST IID CONST PTR, BYVAL objHandle AS ANY PTR PTR) AS HRESULT

   DIM hr AS HRESULT
   DIM thisObj AS IExample PTR

   ' // Assume an error by clearing caller's handle
   *objHandle = 0

   ' // We don't support aggregation in this example
   IF punkOuter THEN RETURN CLASS_E_NOAGGREGATION
   ' // Allocate our IExample object
''   thisObj = GlobalAlloc(GMEM_FIXED, SIZEOF(IExample))
''   IF thisObj = NULL THEN RETURN E_OUTOFMEMORY
   ' // Store IExample's VTable in the object
   thisobj = NEW IExample
   ' // Increment the reference count so we can call Release() below and
   '  // it will deallocate only if there is an error with QueryInterface()
   thisobj->count = 1
   ' // Initialize any other members we added to the IExample. We added
   ' // a buffer member
   thisobj->buffer = ""
   ' // Fill in the caller's handle with a pointer to the IExample we just
   ' // allocated above. We'll let IExample's QueryInterface do that, because
   ' // it also checks the GUID the caller passed, and also increments the
   ' // reference count (to 2) if all goes well
   hr = thisObj->QueryInterface(vTableGuid, objHandle)
   ' // Decrement reference count. NOTE: If there was an error in QueryInterface()
   ' // then Release() will be decrementing the count back to 0 and will free the
   ' // IExample for us. One error that may occur is that the caller is asking for
   ' // some sort of object that we don't support (ie, it's a GUID we don't recognize)
   thisObj->Release
   ' // If success, inc static object count to keep this DLL loaded
   IF hr = S_OK THEN InterlockedIncrement(@OutstandingObjects)
   RETURN hr
END FUNCTION

' // IClassFactory's LockServer(). It is called by someone
' // who wants to lock this DLL in memory
FUNCTION classLockServer (BYVAL pthis AS IClassFactory PTR, BYVAL flock AS WINBOOL) AS HRESULT
   IF flock THEN InterlockedIncrement(@LockCount) ELSE InterlockedDecrement(@LockCount)
   RETURN NOERROR
END FUNCTION

STATIC SHARED MyClassFactoryVTbl AS IClassFactoryVTbl = TYPE(@classQueryInterface, _
   @classAddRef, @classRelease, @classCreateInstance, @classLockServer)

' ========================================================================================
' Implementation of the DllGetClassObject and DllCanUnloadNow functions.
' ========================================================================================

EXTERN "windows-ms"

#UNDEF DllGetClassObject
FUNCTION DllGetClassObject ALIAS "DllGetClassObject" ( _
   BYVAL objGuid AS CLSID PTR, _
   BYVAL factoryGuid AS IID PTR, _
   BYVAL factoryHandle As VOID PTR PTR _
   ) AS HRESULT EXPORT

   DIM hr AS HRESULT

   ' // Check that the caller is passing our IExample GUID. That's the
   ' // only object our DLL implements
   IF IsEqualCLSID(objGuid, @CLSID_IExample) THEN
      ' // Fill in the caller's handle with a pointer to our IClassFactory object.
      ' // We'll let our IClassFactory's QueryInterface do that, because it also
      ' // checks the IClassFactory GUID and does other book-keeping
      hr = classQueryInterface(@MyIClassFactoryObj, factoryGuid, factoryHandle)
   ELSE
      ' // We don't understand this GUID. It's obviously not for our DLL.
      ' // Let the caller know this by clearing his handle and returning
      ' // CLASS_E_CLASSNOTAVAILABLE
      *factoryHandle = 0
      hr = CLASS_E_CLASSNOTAVAILABLE
   END IF

   RETURN hr

END FUNCTION

' * This is called by some OLE function in order to determine
' * whether it is safe to unload our DLL from memory.
' *
' * RETURNS: S_OK if safe to unload, or S_FALSE if not.

' // If someone has retrieved pointers to any of our objects, and
' // not yet Release()'ed them, then we return S_FALSE to indicate
' // not to unload this DLL. Also, if someone has us locked, return
' // S_FALSE

#UNDEF DllCanUnloadNow
FUNCTION DllCanUnloadNow ALIAS "DllCanUnloadNow" () AS HRESULT EXPORT
   RETURN IIF(OutstandingObjects OR LockCount, S_FALSE, S_OK)
END FUNCTION

' ========================================================================================
Title: Re: CWindow Release Candidate 31
Post by: José Roca on August 16, 2017, 05:06:07 AM
A further improvement would be to also use a class with virtual methods for the class factory and put it in an include file. The DllGetClassObject will create an instance of the IExample class, pass it to the class factory class and call its QueryInterface method. This way, we won't have to change the class factory when writing new COM DLLs and will also allow to have more than one interface implemented. The constructor of the module can create an instance of the class factory and the destructor delete it. Promising :)

For events, we can implement a method to set a pointer to a callback funtion and send the events to that function. This is what the low-level COM servers do. I'm sorry (or maybe not) for the lovers of Automation languages, but I hate dispatch interfaces and events. A low-level COM server is as efficient as an ordinary DLL and can work with all kind of data types. VB6 can't use them, but it is dead and buried.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on August 16, 2017, 05:31:48 AM
Another advantage of low-level COM servers is that we can use them to create custom controls that can be added to a GUI without having to use an OLE Container, contrarily to these nasty OCXs. We only need to pass the handle of the parent window and they will work just like any other custom control implemented in a DLL or an include file. Another advantage of SDK over DDT.
Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on August 16, 2017, 09:07:33 AM
Wow, now this is very exciting stuff! I can't wait to try it when I get home. I am itching here wanting to download, compile and experiment!  :)
Title: Re: CWindow Release Candidate 31
Post by: José Roca on August 16, 2017, 09:17:05 AM
Meanwhile, because I have become distracted by a post in the FB forum about finding occurrences of a substring (tally), I have made a test that will become an alternative tor PB's FILESCAN, but mine is faster :)

Code: [Select]
#INCLUDE ONCE "windows.bi"
#INCLUDE ONCE "crt/string.bi"

' --> change the path
DIM wszFileName AS WSTRING * MAX_PATH = $"C:\Users\Pepe\FreeBasic64\inc\win\mshtmlc.bi"
DIM bSuccess AS LONG, dwFileSize AS DWORD, dwHighSize AS DWORD, dwBytesRead AS DWORD
DIM nCount AS DWORD
DIM hFile AS HANDLE = CreateFileW(@wszFileName, GENERIC_READ, FILE_SHARE_READ, NULL, _
                      OPEN_EXISTING, FILE_FLAG_SEQUENTIAL_SCAN, NULL)
IF hFile = INVALID_HANDLE_VALUE THEN END
' // Get the size of the file
dwFileSize = GetFileSize(hFile, @dwHighSize)
IF dwHighSize THEN
   CloseHandle(hFile)
   END
END IF
DIM pBuffer AS UBYTE PTR
pBuffer = CAllocate(1, dwFileSize)
bSuccess = ReadFile(hFile, pBuffer, dwFileSize, @dwBytesRead, NULL)
CloseHandle(hFile)
IF bSuccess THEN
   IF pBuffer THEN
      DIM pstr AS ANY PTR = pBuffer
      DIM sf AS ZSTRING * 3 = CHR(13, 10)
      DIM t1 AS DOUBLE = TIMER
      DO
         pstr = strstr(pstr, sf)
         IF pstr = NULL THEN EXIT DO
         pstr += 2
         nCount += 1
      LOOP
      DIM t2 AS DOUBLE = TIMER
      PRINT "seconds: ", t2 - t1
      DeAllocate(pBuffer)
   END IF
END IF

print "Count: ", nCount

PRINT
PRINT "Press any key..."
SLEEP

Count: 24974
Seconds: 0.002644868538482115



PowerBASIC FILESCAN:

Code: [Select]
#COMPILE CON
#DIM ALL

FUNCTION PBMAIN () AS LONG

   OPEN "C:\Users\Pepe\FreeBasic64\inc\win\mshtmlc.bi" FOR INPUT AS #1
   LOCAL t1, t2 AS DOUBLE, count AS LONG
   t1 = TIMER
   FILESCAN #1, RECORDS TO count
   t2 = TIMER
   CLOSE #1
   PRINT "Count:", count
   PRINT "Seconds: ", STR$(t2 - t1, 18)
   WAITKEY$

END FUNCTION

Count: 24974
Seconds: .016000000003259629


With this function I will retrieve the number of lines and I will allocate a 1D dimensional safe array with number of lines elements, that I will fill with calls to strtok. These C functions are speed demons because they use pointers.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on August 16, 2017, 09:49:42 AM
Wow, now this is very exciting stuff! I can't wait to try it when I get home. I am itching here wanting to download, compile and experiment!  :)

For some reason, many people find COM very hard to understand, yet I find it very straightforward. In the PB world, only Dominic and I have mastered it. Dominic knows more than I about Automation, in part because Automation has never interested too much to me and in part because he is a more skilled Windows programmer than I. The first thing that they don't undestand is that COM is not OOP (I began to use it with PB using CALL DWORD!) and that classes are used for convenience, but its use is not mandatory at all. This confusion has led to many people to buy books about OOP programming to understand COM! Poor guys...

Another big confusion is the belief that it is slow and bloated, and mention VB6 and the infamous OCXs. As you can see, using low-level COM the bloat won't be bigger than 2 KB, the speed will be the same that a standard DLL, and you aren't forced to use VARIANTs, safe arrays and BSTR. You can use any kind of data type, including UDTs, as with any other procedure.

In the beginning it was low-level COM, then came the VB6 designers and spoiled it all with Automation. Microsoft writes almost all of its COM servers using low-level COM (except Office), then they wrote Automation wrappers for VB6 and now for .NET. Automation has its use for scripting languages, but it is an speed killer.
Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on August 16, 2017, 01:29:30 PM
Another big confusion is the belief that it is slow and bloated, and mention VB6 and the infamous OCXs. As you can see, using low-level COM the bloat won't be bigger than 2 KB, the speed will be the same that a standard DLL, and you aren't forced to use VARIANTs, safe arrays and BSTR. You can use any kind of data type, including UDTs, as with any other procedure.
I admit, until a few short years ago, I was guilty of believing this as well. Slow and bloated.
Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on August 16, 2017, 05:46:05 PM
A further improvement would be to also use a class with virtual methods for the class factory and put it in an include file. The DllGetClassObject will create an instance of the IExample class, pass it to the class factory class and call its QueryInterface method. This way, we won't have to change the class factory when writing new COM DLLs and will also allow to have more than one interface implemented. The constructor of the module can create an instance of the class factory and the destructor delete it. Promising :)

I just finished working through the examples and was able to easily create the COM dll and call it successfully. No problems at all. I then started to learn the sequence of the code in the dll and the use of IUnknown and IClassFactory. It is pretty cool how you simplified the code as your examples progressed simply by using EXTENDS and the virtual and abstract functions. I like the idea you describe above for simplifying the handling of IClassFactory.

Quote
For events, we can implement a method to set a pointer to a callback funtion and send the events to that function. This is what the low-level COM servers do. I'm sorry (or maybe not) for the lovers of Automation languages, but I hate dispatch interfaces and events. A low-level COM server is as efficient as an ordinary DLL and can work with all kind of data types. VB6 can't use them, but it is dead and buried.
Ah yes, handling events. Simply set a pointer to a callback function. Easy and efficient.

I must say, the whole world of COM with all of its different terminology can be intimidating at first but once you break it all down to the basic parts then it all seems to make sense and is no more difficult to understand conceptually than any other programming concept. Have you found some type of simple basic primer on the topic that we can post here so people new to the subject can wrap their heads around the concepts? I will search for some and post.

Quote
...and you aren't forced to use VARIANTs, safe arrays and BSTR. You can use any kind of data type, including UDTs, as with any other procedure.
That was always a hangup I had with COM automation, having to mangle your data into safe data structures for use with Automation. With your low level COM servers, being able to use native data types is an incredibly better, easier, and faster freedom.

Maybe we should have a simple tool that creates the GUIDs? Maybe an external user tool for WinFBE?

You have done an incredible job on this. Simply incredible. Fast, small, dll's without having to use an import library.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on August 16, 2017, 07:40:57 PM
> Maybe we should have a simple tool that creates the GUIDs? Maybe an external user tool for WinFBE?

There is not need for a tool. Calling the AfxGuid function (in AfxCOM.inc) generates a unique guid, and AfxGuidText(guid) returns it as human readable text. In my editor, if you press Ctrl+Alt+G, it inserts the guid in the cursor position. The only problem is that as in FB a GUID is not a data type but an structure, instead of "{6899A2A3-405B-44d4-A415-E08CEE2A97CB}" it uses CLSID_IExample AS GUID = TYPE(&h6899A2A3, &h405B, &h44D4, {&hA4, &h15, &hE0, &h8C, &hEE, &h2A, &h97, &hCB}). Maybe an small dialog with two edit text boxes and when you press a "Generate button" display the new guid in the two formats? Or two different hot keys?

Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on August 16, 2017, 07:50:03 PM
Thanks Jose, yes I was aware of those functions because I use them to generate unique GUIDs for the tools in the User Tools dialog within WinFBE. I like the idea of having it built into the editor or having it as a standalone tool that can be called from WinFBE's User Tools via hot key. Given that it is a very specific functionality I think having it as a User Tool would be preferable. Other things like popup ASCII charts, keycode charts, or color values/color pickers, could also be User Tools.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on August 16, 2017, 08:33:50 PM
Low-level COM is very straightforward. To create an instance of an object you call CoCreateInstance, that is a convenience wrapper for

Code: [Select]
CoGetClassObject(rclsid, dwClsContext, NULL, IID_IClassFactory, &pCF);
hresult = pCF->CreateInstance(pUnkOuter, riid, ppvObj)
pCF->Release();

CoGetClassObject loads the library with LoadLibrary, just like any other DLL, and calls the function DllGetClassObject, that every COM server must implement and export. DllGetClassObject creates an instance of the class factory and returns a pointer to its virtual table. Once CoGetClassObject has retrieved the class factory pointer, it calls its CreateInstance method, that creates an instance of the requested object (identified by its unique CLSID and IID) and returns a pointer to its virtual table. Then you call the methods using offsets to the virtual table.

It is similar to using LoadLibrary and GetProcAddress, but instead of a pointer to a single function you get the address of a virtual table, that is just an array of pointers to the methods of the object. Because it returns the address of the virtual table instead of a direct pointer, double indirection must be used. This is because the virtual table is treated as an array. But unless you call the function pointers directly, as I did years ago with PB's CALL DWORD, you don't have to worry about double indirection and offsets becase the compiler calculates them based in the declares for the interface. For an interface that inherits from IUnknown, QueryInterface has the offset 0, AddRef the offset 4 (or 8 in 64 bit, the size of a pointer), Release the offset 8 (or 16 in 64 bit) and then the implemented custom methods follow.

That is, instead of retrieving pointers to the functions individually, as with GetProcAddess, you get the address of an array of pointers to all the methods of the object. Because classes are very convenient to group these methods, they are the prefered way, but you could use just an array or an UDT. It is the old good way of calling a function through a pointer. Nothing more. The use of classes and the dotted syntax is just for convenience, but has nothing to do with OOP.

They also implement a simple reference count that starts at 1 when you create the object, is incremented when you call AddRef or QueryInterface and is decremented when you call Release. When the count reaches 0, the object commits suicide :)

Automation is very complicated and confusing, and because each compiler has its own way to work with strings and arrays, they discarded them and invented new ones: VARIANTs, BSTRs and safe arrays. They also designed its "forms" as a sophisticated OLE container and wrote OCXs. As the form was an OLE container, the OCXs integrated very well with it, but when yo use a SDK window, an OCX does not became integrated and you need an OLE container to act as a middleman. They also designed a system to raise events that worked very well with VB because it was designed for it, but when you try to use them in another compiler it becames complicated. And then all that nasty business of registering the OCX in the registry, etc. As you can see, you can use a COM server without registering it.

One of my overloaded AfxNewCom functions is a replacement for CoCreateInstance and clearly shows all the process, with two added touches: contrarily to CoCreateInstance, it can use unregistered servers and it is also able to create instances of licensed controls.

Code: [Select]
' ========================================================================================
' Loads the specified library from file and creates an instance of an object.
' Parameters:
' - wszLibName = Full path where the library is located.
' - rclsid = 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.
' - wszLicKey = The license key.
' 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 DyLibFree 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, pDisp AS ANY 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, @pDisp)
      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, @pDisp)
      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)
   RETURN pDisp

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

In short, low-level COM is just a way to group related procedures and data, like the FB classes, but as it is a binary standard with some strict rules (*), any language that can call functions through pointers can use them. Also instead of destroying the object with Delete, it implements a reference count and self-destruction, and instead of name mangling, it uses class identifiers and interface identifiers.

(*) Not many: To implement and export DllGetClassObject, to implement a class factory and to implement reference counting with the QueryInterface, AddRef and Release methods. QueryInterface is used to "navigate" between interfaces if the server implements more than one.


Title: Re: CWindow Release Candidate 31
Post by: José Roca on August 16, 2017, 09:28:38 PM
> It is pretty cool how you simplified the code as your examples progressed simply by using EXTENDS and the virtual and abstract functions.

This is a nice feature of the compiler and it is not related to COM.

Extending from Afx_IUnknown, that in turn extends OBJECT, allows the use of virtual methods in the class and ABSTRACT methods in the declares. The difference between virtual and abstract methods is that the virtual ones require implementation, i.e. they are used to write the procedures, and the abstract ones don't, so they are used for the declares.

The built-in OBJECT type

Code: [Select]
Type object
   As fb_BaseVT Ptr vtable_ptr
   Declare Constructor()
End Type

has as the first member a pointer to the virtual table of the object. The virtual table pointer is used to dispatch Virtual and Abstract methods and passes the address of the virtual table (know as this in C and ME in VB and PB) as an hidden parameter to all the methods. This allows to construct a FB class as a COM virtual table and also allows an easier syntax when calling methods <pInterface>.<method name> (parameters) instead of <pInterface>->lpvtbl-><method name>(<pInteface>, <parameters>). Since COM will only care about the array of pointers at the beginning of the virtual table (as long as your declares aren't wrong and you end calling a wrong offset), the table can contain additional pointers to wathever you wish to use them, usually data. Using a FB class has the advantage that the compiler will take care of the dirty work. Therefore, you can use all kind of public and private data.

The only precaution is to not mess the virtual table, although if you do it the compiler and/or the linker will fail. This is why in the following declaration of the FB class the virtual methods come first, followed with the other stuff, even the constructor and destructor of the class. This allows to pass a pointer to the class to COM as if it was a virtual table (array of pointers).

Code: [Select]
TYPE IExample EXTENDS Afx_IUnknown
   ' Functions for the IUnknown Interface
   DECLARE VIRTUAL FUNCTION QueryInterface (BYVAL vTableGuid AS CONST IID CONST PTR, BYVAL ppv AS ANY PTR PTR) AS HRESULT
   DECLARE VIRTUAL FUNCTION AddRef () AS ULONG
   DECLARE VIRTUAL FUNCTION Release () AS ULONG
   ' Our functions
   DECLARE VIRTUAL FUNCTION SetString (BYVAL pwsz AS WSTRING PTR) AS HRESULT
   DECLARE VIRTUAL FUNCTION GetString (BYVAL pbuffer AS WSTRING PTR, BYVAL cch AS DWORD) AS HRESULT
   ' Constructor/destructor
   DECLARE CONSTRUCTOR
   DECLARE DESTRUCTOR
   ' Data
   count AS DWORD
   buffer AS WSTRING * 80
END TYPE

And that's all (unless I'm forgetting something). Anybody proficient with the use of pointers should have not many problems understanding it if he is able of not mix it with all that Automation garbage.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on August 16, 2017, 09:58:53 PM
Before someone asks why I'm not calling CoInitialize in the DLL...

From MSDN:

Quote
Because there is no way to control the order in which in-process servers are loaded or unloaded, do not call CoInitialize, CoInitializeEx, or CoUninitialize from the DllMain function.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on August 17, 2017, 12:45:38 AM
The beauty of this technique is that if you make a FB DLL using FB classes, it won't work with other compilers, but wrapping it as a COM object, it works with any language that can call functions through pointers.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on August 17, 2017, 05:33:57 AM
This is a revised version of the example. Demonstrates that we can also use our own data types such CBSTR, CWSTR and CVAR. Of course, if we intend to use the DLL with other languages, then we can't do that beause the other language does not know how to deal with them and we will have to return standard data types such BSTR, WSTRING PTR and VARIANT.

My idea of converting the factory class into a virtual class doesn't seem possible. First, we only need a class factory, so a static one is enough; second, the CreateInstance method of the factory class needs to know the name of the class to create; third, Free Basic does not support to have more than one interface in a class.

DLL code:

Code: [Select]
' // Free Basic source code to a simple COM object, compiled into an ordinary
' // dynamic link library (DLL).

#include once "windows.bi"
#include once "win/ocidl.bi"
#include once "Afx/AfxCOM.inc"
#include once "Afx/CWSTR.inc"
#include once "Afx/CVar.inc"
using Afx

' Things to change:
' - The name of the interface
' - CLSID and IID of the inteface
'   - Replace CLSID_IExample and IID_IExample with the names of your election
'   - Replace CLSID_IExample in the DllGetClassObject function
'   - Replace IID_IExample in the QueryInteface method of the class
' - Our virtual functions
' - The variables to store data

' Things to keep:
' - The virtual methods QueryInterface, AddRef and Release
' - The static variables OutstandingObjects and LockCount

' // Our IExample CLSID (class identifier)
' // {6899A2A3-405B-44d4-A415-E08CEE2A97CB}
' // (*** change it***)
DIM SHARED CLSID_IExample AS GUID = TYPE(&h6899A2A3, &h405B, &h44D4, {&hA4, &h15, &hE0, &h8C, &hEE, &h2A, &h97, &hCB})

' // Our IExample IID (interface identifier)
' // {74666CAC-C2B1-4FA8-A049-97F3214802F0}
' // (*** change it***)
DIM SHARED IID_IExample AS GUID = TYPE(&h74666CAC, &hC2B1, &h4FA8, {&hA0, &h49, &h97, &hF3, &h21, &h48, &h02, &hF0})

' // A count of how many objects our DLL has created (by some
' // app calling our IClassFactory object's CreateInstance())
' // which have not yet been Release()'d by the app
' // (***keep it***)
STATIC SHARED OutstandingObjects AS DWORD

' // A count of how many apps have locked our DLL via calling our
' // IClassFactory object's LockServer()
' // (***keep it***)
STATIC SHARED LockCount AS DWORD

' ========================================================================================
' IExample object
' ========================================================================================
TYPE IExample EXTENDS OBJECT
   ' Functions for the IUnknown Interface (*** keep them ***)
   DECLARE VIRTUAL FUNCTION QueryInterface (BYVAL riid AS CONST IID CONST PTR, BYVAL ppvObj AS ANY PTR PTR) AS HRESULT
   DECLARE VIRTUAL FUNCTION AddRef () AS ULONG
   DECLARE VIRTUAL FUNCTION Release () AS ULONG
   ' Our functions (*** change them ***)
   ' / ------------------------------------------------
   ' // Adequate for use with other languages that won't understand our CBSTR class
   ' // The caller will be responsible of freeing the returned BSTR with SysFreeString
   ' // PowerBASIC will attach the handle and free it when the WSTRING will go out of scope
   ' // e.g. LOCAL ws AS WSTRING = pExample.GetString
   ' // If called with Free Basic, we must assign it to a CBSTR to avoid memory leaks, e.g.
   ' // DIM cbs AS CBSTR = pExample->GetString
   DECLARE VIRTUAL SUB SetString (BYVAL bs AS AFX_BSTR)
   DECLARE VIRTUAL FUNCTION GetString () AS AFX_BSTR
   ' / ------------------------------------------------
   ' // If we are going to use the server only with Free Basic, we can use CBSTR
   DECLARE VIRTUAL PROPERTY MyCBStr (BYREF cbs AS CBSTR)
   DECLARE VIRTUAL PROPERTY MyCBStr () AS CBSTR
   ' / ------------------------------------------------
   DECLARE VIRTUAL PROPERTY MyCWStr (BYREF cws AS CWSTR)
   DECLARE VIRTUAL PROPERTY MyCWStr () AS CWSTR
   DECLARE VIRTUAL PROPERTY MyCVar (BYREF cv AS CVAR)
   DECLARE VIRTUAL PROPERTY MyCVar () AS CVAR
   DECLARE VIRTUAL PROPERTY MyNumber (BYVAL num AS DOUBLE)
   DECLARE VIRTUAL PROPERTY MyNumber () AS DOUBLE
   ' Constructor/destructor
   DECLARE CONSTRUCTOR
   DECLARE DESTRUCTOR
   ' Reference count
   cRef AS DWORD ' (*** keep it ***)
   ' Data (*** change it ***)
   m_MyCBStr AS CBSTR
   m_MyCWStr AS CWSTR
   m_MyCVar AS CVAR
   m_MyNumber AS DOUBLE
END TYPE
' ========================================================================================

' ========================================================================================
' IExample constructor
' ========================================================================================
CONSTRUCTOR IExample
END CONSTRUCTOR
' ========================================================================================

' ========================================================================================
' IExample destructor
' ========================================================================================
DESTRUCTOR IExample
END DESTRUCTOR
' ========================================================================================

' ========================================================================================
' IExample's QueryInterface
' (***change IID_IExample***)
' ========================================================================================
FUNCTION IExample.QueryInterface (BYVAL riid AS CONST IID CONST PTR, BYVAL ppvObj AS ANY PTR PTR) AS HRESULT
   ' // Check if the GUID matches the IID of our interface or the IUnknown interface.
   IF IsEqualIID(riid, @IID_IUnknown) = FALSE AND IsEqualIID(riid, @IID_IExample) = FALSE THEN
      ' // We don't recognize the GUID passed to us. Let the caller know this,
      ' // by clearing his handle, and returning E_NOINTERFACE.
      *ppvObj = 0
      RETURN E_NOINTERFACE
   END IF
   ' // Fill in the caller's handle
   *ppvObj = @this
   ' // Increment the count of callers who have an outstanding pointer to this object
   this.AddRef
   RETURN NOERROR
END FUNCTION
' ========================================================================================

' ========================================================================================
' IExample's AddRef
' ========================================================================================
FUNCTION IExample.AddRef() AS ULONG
   ' // Increment IExample's reference count, and return the updated value.
   this.cRef += 1
   RETURN this.cRef
END FUNCTION
' ========================================================================================

' ========================================================================================
' IExample's Release
' ========================================================================================
FUNCTION IExample.Release () AS ULONG
   ' // Decrement IExample's reference count
   this.cRef -= 1
   ' // If 0, then we can safely free this IExample now
   IF this.cRef = 0 THEN
      Delete @this
      InterlockedDecrement(@OutstandingObjects)
      RETURN 0
   END IF
   RETURN this.cRef
END FUNCTION
' ========================================================================================

' ========================================================================================
' Sets/gets a string
' ========================================================================================
SUB IExample.SetString (BYVAL bs AS AFX_BSTR)
   this.m_MyCBStr = bs
END SUB
' ========================================================================================
' ========================================================================================
FUNCTION IExample.GetString () AS AFX_BSTR
   RETURN this.m_MyCBStr
END FUNCTION
' ========================================================================================

' ========================================================================================
' Sets/gets a CBSTR
' ========================================================================================
PROPERTY IExample.MyCBStr (BYREF cbs AS CBSTR)
   this.m_MyCBStr = cbs
END PROPERTY
' ========================================================================================
' ========================================================================================
PROPERTY IExample.MyCBStr () AS CBSTR
   RETURN this.m_MyCBStr
END PROPERTY
' ========================================================================================

' ========================================================================================
' Sets/gets a CWSTR
' ========================================================================================
PROPERTY IExample.MyCWStr (BYREF cws AS CWSTR)
   this.m_MyCWStr = cws
END PROPERTY
' ========================================================================================
' ========================================================================================
PROPERTY IExample.MyCWStr () AS CWSTR
   RETURN this.m_MyCWStr
END PROPERTY
' ========================================================================================

' ========================================================================================
' Sets/gets a CVAR
' ========================================================================================
PROPERTY IExample.MyCVar (BYREF cv AS CVAR)
   this.m_MyCVar = cv
END PROPERTY
' ========================================================================================
' ========================================================================================
PROPERTY IExample.MyCVar () AS CVAR
   RETURN this.m_MyCVar
END PROPERTY
' ========================================================================================

' ========================================================================================
' Sets/gets a number
' ========================================================================================
PROPERTY IExample.MyNumber (BYVAL num AS DOUBLE)
   this.m_MyNumber = num
END PROPERTY
' ========================================================================================
' ========================================================================================
PROPERTY IExample.MyNumber () AS DOUBLE
   PROPERTY = this.m_MyNumber
END PROPERTY
' ========================================================================================

' ========================================================================================
' // The IClassFactory object ////////////////////////////////////////////////////////////
' ========================================================================================

' // Since we only ever need one IClassFactory object, we declare
' // it static. The only requirement is that we ensure any
' // access to its members is thread-safe
STATIC SHARED MyIClassFactoryObj As IClassFactory

' // IClassFactory's AddRef()
FUNCTION classAddRef (BYVAL pthis AS IClassFactory PTR) AS ULONG
   ' // Someone is obtaining my IClassFactory, so inc the count of
   ' // pointers that I've returned which some app needs to Release()
   InterlockedIncrement(@OutstandingObjects)

   ' // Since we never actually allocate/free an IClassFactory (ie, we
   ' // use just 1 static one), we don't need to maintain a separate
   ' // reference count for our IClassFactory. We'll just tell the caller
   ' // that there's at least one of our IClassFactory objects in existance
   RETURN 1
END FUNCTION

' // IClassFactory's QueryInterface()
FUNCTION classQueryInterface (BYVAL pthis AS IClassFactory PTR, BYVAL factoryGuid AS CONST IID CONST PTR, BYVAL ppv AS ANY PTR PTR) AS HRESULT
   ' // Make sure the caller wants either an IUnknown or an IClassFactory.
   ' // In either case, we return the same IClassFactory pointer passed to
   ' // us since it can also masquerade as an IUnknown
   IF IsEqualIID(factoryGuid, @IID_IUnknown) OR IsEqualIID(factoryGuid, @IID_IClassFactory) THEN
      ' // Call my IClassFactory's AddRef
      pthis->lpVtbl->AddRef(pthis)
      ' // Return (to the caller) a ptr to my IClassFactory
      *ppv = pthis
      RETURN NOERROR
   END IF
   ' // We don't know about any other GUIDs
   *ppv = 0
   RETURN E_NOINTERFACE
END FUNCTION

' // IClassFactory's Release()
FUNCTION classRelease(BYVAL pthis AS IClassFactory PTR) AS ULONG
   ' // One less object that an app has not yet Release()'ed
   RETURN InterlockedDecrement(@OutstandingObjects)
END FUNCTION

' // IClassFactory's CreateInstance() function. It is called by
' // someone who has a pointer to our IClassFactory object and now
' // wants to create and retrieve a pointer to our IExample
FUNCTION classCreateInstance(BYVAL pthis AS IClassFactory PTR, BYVAL punkOuter AS IUnknown PTR, _
   BYVAL riid AS CONST IID CONST PTR, BYVAL objHandle AS ANY PTR PTR) AS HRESULT

   DIM hr AS HRESULT
   ' // Assume an error by clearing caller's handle
   *objHandle = 0
   ' // We don't support aggregation in this example
   IF punkOuter THEN RETURN CLASS_E_NOAGGREGATION
   ' // Allocate our object (***change the name of the class***)
   DIM thisObj AS IExample PTR = NEW IExample
   ' // Increment the reference count so we can call Release() below and
   '  // it will deallocate only if there is an error with QueryInterface()
   thisobj->cRef = 1
   ' // Fill in the caller's handle with a pointer to the object we just allocated
   ' // above. We'll let the QueryInterface method of the object do that, because
   ' // it also checks the GUID the caller passed, and also increments the
   ' // reference count (to 2) if all goes well
   hr = thisObj->QueryInterface(riid, objHandle)
   ' // Decrement reference count. NOTE: If there was an error in QueryInterface()
   ' // then Release() will be decrementing the count back to 0 and will free the
   ' // IExample for us. One error that may occur is that the caller is asking for
   ' // some sort of object that we don't support (ie, it's a GUID we don't recognize)
   thisObj->Release
   ' // If success, inc static object count to keep this DLL loaded
   IF hr = S_OK THEN InterlockedIncrement(@OutstandingObjects)
   RETURN hr
END FUNCTION

' // IClassFactory's LockServer(). It is called by someone
' // who wants to lock this DLL in memory
FUNCTION classLockServer (BYVAL pthis AS IClassFactory PTR, BYVAL flock AS WINBOOL) AS HRESULT
   IF flock THEN InterlockedIncrement(@LockCount) ELSE InterlockedDecrement(@LockCount)
   RETURN NOERROR
END FUNCTION

STATIC SHARED MyClassFactoryVTbl AS IClassFactoryVTbl = TYPE(@classQueryInterface, _
   @classAddRef, @classRelease, @classCreateInstance, @classLockServer)

' ========================================================================================
' Implementation of the DllGetClassObject and DllCanUnloadNow functions.
' ========================================================================================

EXTERN "windows-ms"

#UNDEF DllGetClassObject
FUNCTION DllGetClassObject ALIAS "DllGetClassObject" (BYVAL objGuid AS CLSID PTR, _
   BYVAL factoryGuid AS IID PTR, BYVAL factoryHandle As VOID PTR PTR) AS HRESULT EXPORT

   DIM hr AS HRESULT
   ' // Check that the caller is passing our interface CLSID.
   ' // That's the only object our DLL implements
   ' // (***change CLSID_IExample***)
   IF IsEqualCLSID(objGuid, @CLSID_IExample) THEN
      ' // Fill in the caller's handle with a pointer to our IClassFactory object.
      ' // We'll let our IClassFactory's QueryInterface do that, because it also
      ' // checks the IClassFactory GUID and does other book-keeping
      hr = classQueryInterface(@MyIClassFactoryObj, factoryGuid, factoryHandle)
   ELSE
      ' // We don't understand this GUID. It's obviously not for our DLL.
      ' // Let the caller know this by clearing his handle and returning
      ' // CLASS_E_CLASSNOTAVAILABLE
      *factoryHandle = 0
      hr = CLASS_E_CLASSNOTAVAILABLE
   END IF
   RETURN hr

END FUNCTION

' * This is called by some OLE function in order to determine
' * whether it is safe to unload our DLL from memory.
' *
' * RETURNS: S_OK if safe to unload, or S_FALSE if not.

' // If someone has retrieved pointers to any of our objects, and
' // not yet Release()'ed them, then we return S_FALSE to indicate
' // not to unload this DLL. Also, if someone has us locked, return
' // S_FALSE

#UNDEF DllCanUnloadNow
FUNCTION DllCanUnloadNow ALIAS "DllCanUnloadNow" () AS HRESULT EXPORT
   RETURN IIF(OutstandingObjects OR LockCount, S_FALSE, S_OK)
END FUNCTION

' ========================================================================================

END EXTERN

' ========================================================================================
' Constructor of the module
' ========================================================================================
SUB ctor () CONSTRUCTOR
'   OutputDebugStringW "DLL loaded"
   ' // Clear static counts
   OutstandingObjects = 0
   LockCount = 0
   ' // Initialize my IClassFactory with the pointer to its VTable
   MyIClassFactoryObj.lpVtbl = @MyClassFactoryVTbl
END SUB
' ========================================================================================

' ========================================================================================
' Destructor of the module
' ========================================================================================
SUB dtor () DESTRUCTOR
'   OutputDebugStringW "DLL unloaded"
END SUB
' ========================================================================================
Title: Re: CWindow Release Candidate 31
Post by: José Roca on August 17, 2017, 05:34:33 AM
Test code:

Code: [Select]
'#CONSOLE ON
#define _CBSTR_DEBUG_ 1
#define UNICODE
#INCLUDE ONCE "windows.bi"
#include once "win/ocidl.bi"
#include once "Afx/AfxCOM.inc"
#include once "Afx/CVAR.inc"
using Afx

' // Our IExample object's GUID
' // {6899A2A3-405B-44d4-A415-E0 8C EE 2A 97 CB}
DIM CLSID_IExample AS GUID = TYPE(&h6899A2A3, &h405B, &h44D4, {&hA4, &h15, &hE0, &h8C, &hEE, &h2A, &h97, &hCB})
' // Our IExample VTable's GUID
' // {74666CAC-C2B1-4FA8-A049-97F3214802F0}
DIM IID_IExample AS GUID = TYPE(&h74666CAC, &hC2B1, &h4FA8, {&hA0, &h49, &h97, &hF3, &h21, &h48, &h02, &hF0})

TYPE IExample EXTENDS Afx_IUnknown
   ' // Adequate for use with other languages that won't understand our CBSTR class
   DECLARE ABSTRACT SUB SetString (BYVAL bs AS AFX_BSTR)
   DECLARE ABSTRACT FUNCTION GetString () AS AFX_BSTR
   ' / ------------------------------------------------
   DECLARE ABSTRACT PROPERTY MyCBStr (BYREF cbs AS CBSTR)
   DECLARE ABSTRACT PROPERTY MyCBStr () AS CBSTR
   DECLARE ABSTRACT PROPERTY MyCWStr (BYREF cws AS CWSTR)
   DECLARE ABSTRACT PROPERTY MyCWStr () AS CWSTR
   DECLARE ABSTRACT PROPERTY MyCVar (BYREF cv AS CVAR)
   DECLARE ABSTRACT PROPERTY MyCVar () AS CVAR
   DECLARE ABSTRACT PROPERTY MyNumber (BYVAL num AS DOUBLE)
   DECLARE ABSTRACT PROPERTY MyNumber () AS DOUBLE
END TYPE

' // Initialize the COM library
CoInitialize NULL

DIM wszLibName AS WSTRING * MAX_PATH = ExePath & "\IExample3.dll"
DIM pExample AS IExample PTR = AfxNewCom(wszLibName, CLSID_IExample, IID_IExample)
print "pExample = ", pExample
IF pExample THEN
   pExample->SetString("Jose Roca")
   ' // As it returns a BSTR, we need to attach it to a CBSTR to avoid a memory leak
   DIM cbs AS CBSTR = pExample->GetString
   PRINT cbs
   ' // -------------------------------------------
   pExample->MyCBStr = "Paul Squires"
   PRINT pExample->MyCBStr
   pExample->MyCWStr = "Free Basic"
   PRINT pExample->MyCWStr
   pExample->MyCVar = "This is a variant"
   PRINT pExample->MyCVar.ToStr
   pExample->MyNumber = 123456.78
   PRINT pExample->MyNumber
END IF
AfxSafeRelease(pExample)

' // Uninitialize the COM library
CoUninitialize

PRINT
PRINT "Press any key..."
SLEEP
Title: Re: CWindow Release Candidate 31/ dll info creation-usage
Post by: Marc Pons on August 17, 2017, 06:16:30 AM
Hi Jose, very good job  :)

just some points to share here about fb dll  creation-usage

specific dllmain
can be done easily like that

Code: [Select]
' entry point dll    'use any name you want but better to stay with uppercase name
#ifdef  __FB_64BIT__

  Function _MYDLLMAIN Alias " _MYDLLMAIN" ( ByVal hinstDLL As HINSTANCE, _
                  ByVal fdwReason As Long, _
                  Byval lpvReserved As LPVOID ) As Long
#else
  Function MYDLLMAIN ( ByVal hinstDLL As HINSTANCE, _
                  ByVal fdwReason As Long, _
                  Byval lpvReserved As LPVOID ) As Long
#endif

   Select Case fdwReason
      Case DLL_PROCESS_ATTACH
        function = dll_init()  ' your user init function, use any name it's your function
        exit function
      Case DLL_PROCESS_DETACH
        function =  dll_detach()  ' your user detach function, use any name it's your function
        exit function
   End Select

   function = 1
  End Function



to compile :
Quote
"c:\Freebasic_Path\fbc.exe" -x "NAME.dll" -dll -export -Wl "--kill-at --entry _MYDLLMAIN" NAME.bas -v -w pedantic > NAME.log 2>&1

where
-Wl "--kill-at --entry _MYDLLMAIN"

are linker parameters

--kill-at   ; to not have decorated functions@x 
-- entry _MYDLLMAIN  ; define the specific entry dll point use always uppercase

a tip : because win32 add underscore as first character(even you did not put it on the code)
it is interresting on win64 to add it in the code, so the command line to compile will be the same for win32/win 64.

that why i've put the conditionnal compilation on the code


about interface libxxx.dll.a
you can use the tool i've posted here on the forum to create interface for win32/win64 dll
but in fact you only need that interface : if at compile time the dll is not on the same folder as the .bas you are compiling
if it is on the same folder , you don't need to have the .dll.a  ( it just an helper way)
if you have a .dll.a it has to be placed in the compiler lib folder or in the same folder as the .bas you are compiling

so if the idea is to produce an executable whith specific dll , just put the dll on the folder you have the source
and when using/deploying  put the dll near the executable that need it (or on the system32 )

using dll functions
if you compile the dll as i've showed above, the easiest way to use the exported functions :
Code: [Select]
"Windows-ms" Lib "NAME"
Declare Function your_dllfunction Alias "YOUR_DLLFUNCTION" (ByVal Hparent As HWND) As Long
End Extern

hope can help

Marc
Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on August 17, 2017, 09:37:22 AM
Hi Marc,

My understanding is that the COM dll does not need a dllmain. Jose is using the module constructor/destructor to handle the same functionality as provided by dllmain. You can read that in this post: http://www.planetsquires.com/protect/forum/index.php?topic=4073.msg30861#msg30861

Also, as a COM server I do not believe that a dll.a interface file at all. This is a great benefit of the COM type of dlls.

Jose can correct me if I'm wrong.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on August 17, 2017, 04:13:20 PM
A DLLMAIN is not needed because we can use the constructor and destructor of the module.

Unless we export functions that are not methods of the class, we don't need an import library at all.

Using registration free techniques, such my overloaded function AfxNewCom or PowerBASIC NEWCOM CLSID $CLSID_IExample LIB LibName, we can put the COM DLL anywhere.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on August 17, 2017, 04:24:57 PM
To allow the use of our data types and also compiling for other languages, we can use conditional compiling, e.g.

Code: [Select]
#IF USE_FB
PROPERTY IExample.MyCBStr () AS CBSTR
#ELSE
PROPERTY IExample.MyCBStr () AS AFX_BSTR
#ENDIF

Title: Re: CWindow Release Candidate 31
Post by: José Roca on August 17, 2017, 04:38:20 PM
Hi Marc,

Thanks very much for your tips. Maybe I will have a use for them some day, but currently I'm trying to avoid these import libraries like a pest. I hate to have to say to a user things like "you have to use this switch when compiling", "you have to copy the import library in the xxx folder", etc. Where is the real need for all these complications?

Place the COM dll where you wish and specify the full path to it when calling AfxNewCom. No need to register it, no need for an import library, no nothing.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on August 17, 2017, 05:08:37 PM
The technique that I'm using is very simple.

To use the COM DLL you have to use AfxNewCom (NEWCOM with PowerBasic), that does the following:

- Loads the COM DLL.

- Calls the exported function DllGetClassObject, that returns a pointer to the factory class.

- Calls the CreateInstance method of the factory class, that creates an instance of the requested COM class (identified by a CLSID and an IID) and returns a pointer to it, allowing to call the implemented methods of the class.

- The class implements a reference count managed by its QueryInterface, AddRef and Release methods, and kills itself when the reference count reaches 0.

That's all!
Title: Re: CWindow Release Candidate 31
Post by: José Roca on August 18, 2017, 12:35:37 AM
If somebody does not know it, we can use any name in the interface declaration because what identifies the object is not the name of the class but its CLSID and IID. Therefore, we can use MyExample (or any other name) instead of IExample in

Code: [Select]
TYPE MyExample EXTENDS Afx_IUnknown
   ' // Adequate for use with other languages that won't understand our CBSTR class
   DECLARE ABSTRACT SUB SetString (BYVAL bs AS AFX_BSTR)
   DECLARE ABSTRACT FUNCTION GetString () AS AFX_BSTR
   ' / ------------------------------------------------
   DECLARE ABSTRACT PROPERTY MyCBStr (BYREF cbs AS CBSTR)
   DECLARE ABSTRACT PROPERTY MyCBStr () AS CBSTR
   DECLARE ABSTRACT PROPERTY MyCWStr (BYREF cws AS CWSTR)
   DECLARE ABSTRACT PROPERTY MyCWStr () AS CWSTR
   DECLARE ABSTRACT PROPERTY MyCVar (BYREF cv AS CVAR)
   DECLARE ABSTRACT PROPERTY MyCVar () AS CVAR
   DECLARE ABSTRACT PROPERTY MyNumber (BYVAL num AS DOUBLE)
   DECLARE ABSTRACT PROPERTY MyNumber () AS DOUBLE
END TYPE

and then use

Code: [Select]
DIM pExample AS MyExample PTR = AfxNewCom(wszLibName, CLSID_IExample, IID_IExample)

instead of

Code: [Select]
DIM pExample AS IExample PTR = AfxNewCom(wszLibName, CLSID_IExample, IID_IExample)

This is great to avoid conflict names. Just make sure when writing a new COM class of using unique GUIDs. Paul has just posted a tool for his editor to generate GUIDs.

The names of the methods and properties can also be changed, but not its position in the list, that the compiler uses to calculate its offset in the virtual table.

Also in the DLL, we can use

Code: [Select]
TYPE IExample EXTENDS OBJECT

instead of

Code: [Select]
TYPE IExample EXTENDS Afx_IUnknown

(I have modified it in the template code posted in reply #40)

but keep TYPE IExample EXTENDS Afx_IUnknown in the declaration of the abstract method in the test code.

Instead of EXTENDS Afx_IUnknown you can also use EXTENDS OBJECT if you include the QueryInterface, AddRef and Release methods in the declaration.

Code: [Select]
TYPE IExample EXTENDS OBJECT
   DECLARE ABSTRACT FUNCTION QueryInterface (BYVAL riid AS CONST IID CONST PTR, BYVAL ppvObj AS ANY PTR PTR) AS HRESULT
   DECLARE ABSTRACT FUNCTION AddRef () AS ULONG
   DECLARE ABSTRACT FUNCTION Release () AS ULONG
   ' // Adequate for use with other languages that won't understand our CBSTR class
   DECLARE ABSTRACT SUB SetString (BYVAL bs AS AFX_BSTR)
   DECLARE ABSTRACT FUNCTION GetString () AS AFX_BSTR
   ' / ------------------------------------------------
   DECLARE ABSTRACT PROPERTY MyCBStr (BYREF cbs AS CBSTR)
   DECLARE ABSTRACT PROPERTY MyCBStr () AS CBSTR
   DECLARE ABSTRACT PROPERTY MyCWStr (BYREF cws AS CWSTR)
   DECLARE ABSTRACT PROPERTY MyCWStr () AS CWSTR
   DECLARE ABSTRACT PROPERTY MyCVar (BYREF cv AS CVAR)
   DECLARE ABSTRACT PROPERTY MyCVar () AS CVAR
   DECLARE ABSTRACT PROPERTY MyNumber (BYVAL num AS DOUBLE)
   DECLARE ABSTRACT PROPERTY MyNumber () AS DOUBLE
END TYPE

Therefore, the easiest way of making the declares to use the COM DLL is to copy the declares of the class and change VIRTUAL to ABSTRACT.
Title: Re: CWindow Release Candidate 31
Post by: Marc Pons on August 18, 2017, 06:23:24 AM
Jose and Paul

sorry, to "disturbe" that subject

my input was more general creation/usage of dll  , just to say :

if you need  a dedicated dllmain , it is possible to do it quite simple , to give a precision to  that :


Please note that I'm not using DllMain or LibMain in the DLL because apparently it does not work, so I'm using the constructor and destructor of the module instead.

See this thread: http://www.freebasic.net/forum/viewtopic.php?t=15690

and also to say, it not always needed these    libXXX.dll.a  to use dll functions
and give some precisions too

but probably it could be placed in a different topic...

Paul , if you think so ( and estimate useful) , please change to different topic.

thanks again Jose for your precious job, 
and Paul for your superb tools  (editor, and Firefly for FB, you i'm using it again) :)

Marc
Title: Re: CWindow Release Candidate 31
Post by: José Roca on August 18, 2017, 04:37:55 PM
Hi Marc,

Your posts are always welcome and the information that you have posted is useful. What happens is that the PowerBasic users are not used to this nasty business of compiler switches and import libraries, and we try to avoid its use like a pest.

Its annoyig to download old code that does not compile, not only because of changes in the compiler, but also because you need some updated library. And when you search for a C library, these Linux guys often don't provide binaries and you're supposed to know C programming, install some C compiler and toolchain, etc. If it was a C programmer I won't be using Free Basic.

Why all these complications? They are only good for scaring beginners. Basic is supposed to be a language easy to use.

And don't worry about being disruptive because currently there are only two users of my framework, Paul and me. I'm using these threads as bloc-notes.
Title: Re: CWindow Release Candidate 31
Post by: Richard Kelly on August 21, 2017, 10:35:07 AM
I've been off in the wilds of Alaska chasing grayling this month and just returned. A guy takes off and look at what you've done...geez...I'm already tired thinking about all the possible ways to use cWindow and the new designer.

Rick
Title: Re: CWindow Release Candidate 31
Post by: José Roca on August 26, 2017, 07:42:01 AM
File reuploaded in the original post.

Added an explicit return value to several functions that used IF xxx THEN RETURN xxx. According to a post in the FB forum, failing to do it could give unexpected results or crashes.

Title: Re: CWindow Release Candidate 31
Post by: Richard Kelly on August 30, 2017, 11:10:15 AM
With all you have accomplished, it looks like it is now possible to create Excel files without Excel installed. Take a look at:

https://gallery.technet.microsoft.com/scriptcenter/Export-XLSX-PowerShell-f2f0c035 (https://gallery.technet.microsoft.com/scriptcenter/Export-XLSX-PowerShell-f2f0c035)

Rick
Title: Re: CWindow Release Candidate 31
Post by: Richard Kelly on August 30, 2017, 02:44:09 PM
Jose:

Windows has, I think since 7/Vista days, had the Network List Manager (NLM) built on top of the Network Connectivity Status Indicator (NCSI), which is part of a broader feature called Network Awareness. What happens is:

1.When connected to the network, the system sends an HTTP-request to http://www.msftncsi.com/ncsi.txt. This is a plain text file which contains just a single line 'Microsoft NCSI'. In case of a successful query, the server should send back a response with the header “200 OK” containing this line.

2.The DNS service health is checked in the second step with the NCSI trying to resolve the name dns.msftncsi.com to an IP address. The expected value is 131.107.255.255

If these two steps are OK, Internet/WAN connectivity is assumed to be functional.

Using your COM functions, do you think the objects documented at:

https://msdn.microsoft.com/en-us/library/windows/desktop/aa370799(v=vs.85).aspx (https://msdn.microsoft.com/en-us/library/windows/desktop/aa370799(v=vs.85).aspx)

could be hosted?

All the approaches I've seen, and even used myself, was to do some HTTP to a known site such as WhatsMyIP and see if it works.

Rick
Title: Re: CWindow Release Candidate 31
Post by: José Roca on August 30, 2017, 03:17:11 PM
You will need interface declarations (see attached file).

What I can't do is to test it because I don't have a network.
Title: Re: CWindow Release Candidate 31
Post by: Richard Kelly on August 30, 2017, 04:13:28 PM
You will need interface declarations (see attached file).

What I can't do is to test it because I don't have a network.

I'll test it over the next few days. I have both wired and wireless with a NAT router connected to a cable modem. I can try various points of failure and see what results come in.

Rick
Title: Re: CWindow Release Candidate 31
Post by: José Roca on August 31, 2017, 12:17:38 PM
One of the reasons to write the class is that it can be used as an alternative to multi-dimensional arrays. We can use a memory SQLite database to store the data and use SQL to access it.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 01, 2017, 07:36:01 PM
Next update will include several new functions, among them AfxFileScanA/W, a replacement for PowerBasic FILESCAN, but in both ansi and unicode versions. These two functions are truly speed demons, even a bit faster than FILESCAN.

Included in AfxWin.inc:

Code: [Select]
' ========================================================================================
' Scans a text file ans returns the number of occurrences of the specified delimiter.
' Default value is CHR(13, 10), which returns the number of lines.
' ========================================================================================
PRIVATE FUNCTION AfxFileScanA (BYREF wszFileName AS WSTRING, BYREF szDelimiter AS ZSTRING = CHR(13, 10)) AS DWORD
   DIM dwCount AS DWORD, dwFileSize AS DWORD, dwHighSize AS DWORD, dwBytesRead AS DWORD
   IF LEN(szDelimiter) = 0 THEN EXIT FUNCTION
   ' // Open the file
   DIM hFile AS HANDLE = CreateFileW(@wszFileName, GENERIC_READ, FILE_SHARE_READ, NULL, _
                         OPEN_EXISTING, FILE_FLAG_SEQUENTIAL_SCAN, NULL)
   IF hFile = INVALID_HANDLE_VALUE THEN EXIT FUNCTION
   ' // Get the size of the file
   dwFileSize = GetFileSize(hFile, @dwHighSize)
   DIM pBuffer AS UBYTE PTR
   pBuffer = CAllocate(1, dwFileSize)
   IF pBuffer = NULL THEN EXIT FUNCTION
   DIM bSuccess AS LONG = ReadFile(hFile, pBuffer, dwFileSize, @dwBytesRead, NULL)
   CloseHandle(hFile)
   IF bSuccess = FALSE THEN EXIT FUNCTION
   DIM nLen AS LONG = LEN(szDelimiter)
   DIM pstr AS ANY PTR = pBuffer
   DO
      pstr = strstr(pstr, szDelimiter)
      IF pstr = NULL THEN EXIT DO
      pstr += nLen
      dwCount += 1
   LOOP
   DeAllocate(pBuffer)
   FUNCTION = dwCount
END FUNCTION
' ========================================================================================
' ========================================================================================
' Version for unicode text files.
' ========================================================================================
PRIVATE FUNCTION AfxFileScanW (BYREF wszFileName AS WSTRING, BYREF wszDelimiter AS WSTRING = CHR(13, 10)) AS DWORD
   DIM dwCount AS DWORD, dwFileSize AS DWORD, dwHighSize AS DWORD, dwBytesRead AS DWORD
   IF LEN(wszDelimiter) = 0 THEN EXIT FUNCTION
   ' // Open the file
   DIM hFile AS HANDLE = CreateFileW(@wszFileName, GENERIC_READ, FILE_SHARE_READ, NULL, _
                         OPEN_EXISTING, FILE_FLAG_SEQUENTIAL_SCAN, NULL)
   IF hFile = INVALID_HANDLE_VALUE THEN EXIT FUNCTION
   ' // Get the size of the file
   dwFileSize = GetFileSize(hFile, @dwHighSize)
   DIM pBuffer AS UBYTE PTR
   pBuffer = CAllocate(1, dwFileSize)
   IF pBuffer = NULL THEN EXIT FUNCTION
   DIM bSuccess AS LONG = ReadFile(hFile, pBuffer, dwFileSize, @dwBytesRead, NULL)
   CloseHandle(hFile)
   IF bSuccess = FALSE THEN EXIT FUNCTION
   DIM nLen AS LONG = LEN(wszDelimiter) * 2
   DIM pstr AS ANY PTR = pBuffer
   DO
      pstr = wcsstr(pstr, @wszDelimiter)
      IF pstr = NULL THEN EXIT DO
      pstr += nLen
      dwCount += 1
   LOOP
   DeAllocate(pBuffer)
   FUNCTION = dwCount
END FUNCTION
' ========================================================================================
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 02, 2017, 01:08:05 AM
The following functions read all lines of the specified file into a safe array.

Included in CSafeArray.inc:

Code: [Select]
' ========================================================================================
' Reads all the lines of the specified file into a safe array.
' - wszFileName: Path of the file
' - szDelimiter: Delimiter of the line (CHR(13, 10) in Windows, CHR(10) in Linmux).
' ========================================================================================
PRIVATE FUNCTION AfxFileReadAllLinesA (BYREF wszFileName AS WSTRING, BYREF szDelimiter AS ZSTRING = CHR(13, 10)) AS CSafeArray
   DIM _csa AS CSafeArray = CSafeArray(VT_BSTR, 0, 1)
   DIM dwCount AS DWORD, dwFileSize AS DWORD, dwHighSize AS DWORD, dwBytesRead AS DWORD
   IF LEN(szDelimiter) = 0 THEN RETURN _csa
   ' // Open the file
   DIM hFile AS HANDLE = CreateFileW(@wszFileName, GENERIC_READ, FILE_SHARE_READ, NULL, _
                         OPEN_EXISTING, FILE_FLAG_SEQUENTIAL_SCAN, NULL)
   IF hFile = INVALID_HANDLE_VALUE THEN RETURN _csa
   ' // Get the size of the file
   dwFileSize = GetFileSize(hFile, @dwHighSize)
   DIM pBuffer AS UBYTE PTR
   pBuffer = CAllocate(1, dwFileSize)
   IF pBuffer = NULL THEN RETURN _csa
   DIM bSuccess AS LONG = ReadFile(hFile, pBuffer, dwFileSize, @dwBytesRead, NULL)
   CloseHandle(hFile)
   IF bSuccess = FALSE THEN RETURN _csa
   ' // Get the number of lines
   DIM nLen AS LONG = LEN(szDelimiter)
   DIM pstr AS ANY PTR = pBuffer
   ' // Check for UTF-8 BOM
   s = "   "
   strncpy STRPTR(s), _pstr, 3
   IF s = CHR(&hEF, &hBB, &hBF) THEN _pstr += 3
   ' // Parse the buffer
   DO
      pstr = strstr(pstr, szDelimiter)
      IF pstr = NULL THEN EXIT DO
      pstr += nLen
      dwCount += 1
   LOOP
' -------------------------------------------------------------------
  ' // Dimension a safe array with dwCount elements
'   DIM csa AS CSafeArray = CSafeArray(VT_BSTR, dwCount, 1)
'   Note: strtok can't be used because it skips empty lines.
'   ' // Fill the array with the lines
'   DIM pwsz AS ZSTRING PTR = strtok(pBuffer, @szDelimiter)
'   DIM idx AS LONG = 1
'   WHILE pwsz <> NULL
'      IF idx < dwCount THEN csa.PutElement(idx, CBSTR(*pwsz))
'      idx += 1
'      pwsz = strtok(NULL, @szDelimiter)
'   WEND
' -------------------------------------------------------------------
  ' // Dimension a safe array with dwCount elements
   DIM csa AS CSafeArray = CSafeArray(VT_BSTR, dwCount, 1)
   DIM s AS STRING, sLen AS LONG
   DIM idx AS LONG = 1
   DIM _pstr AS ANY PTR = pBuffer
   pstr = pBuffer
   DO
      pstr = strstr(pstr, szDelimiter)
      IF pstr = NULL THEN EXIT DO
      sLen = pstr - _pstr
      s = ""
      IF sLen > nLen THEN
         s = STRING(sLen, CHR(0))
         strncpy STRPTR(s), _pstr, sLen
      END IF
      IF idx <= dwCount THEN csa.PutElement(idx, CBSTR(s))
      idx += 1
      pstr += nLen
      _pstr = pstr
   LOOP
   DeAllocate(pBuffer)
   RETURN csa
END FUNCTION
' ========================================================================================

' ========================================================================================
' Reads all the lines of the specified file into a safe array.
' - wszFileName: Path of the file
' - szDelimiter: Delimiter of the line (CHR(13, 10) in Windows, CHR(10) in Linmux).
' ========================================================================================
PRIVATE FUNCTION AfxFileReadAllLinesW (BYREF wszFileName AS WSTRING, BYREF wszDelimiter AS WSTRING = CHR(13, 10)) AS CSafeArray
   DIM _csa AS CSafeArray = CSafeArray(VT_BSTR, 0, 1)
   DIM dwCount AS DWORD, dwFileSize AS DWORD, dwHighSize AS DWORD, dwBytesRead AS DWORD
   IF LEN(wszDelimiter) = 0 THEN RETURN _csa
   ' // Open the file
   DIM hFile AS HANDLE = CreateFileW(@wszFileName, GENERIC_READ, FILE_SHARE_READ, NULL, _
                         OPEN_EXISTING, FILE_FLAG_SEQUENTIAL_SCAN, NULL)
   IF hFile = INVALID_HANDLE_VALUE THEN RETURN _csa
   ' // Get the size of the file
   dwFileSize = GetFileSize(hFile, @dwHighSize)
   DIM pBuffer AS UBYTE PTR
   pBuffer = CAllocate(1, dwFileSize)
   IF pBuffer = NULL THEN RETURN _csa
   DIM bSuccess AS LONG = ReadFile(hFile, pBuffer, dwFileSize, @dwBytesRead, NULL)
   CloseHandle(hFile)
   IF bSuccess = FALSE THEN RETURN _csa
   ' // Get the number of lines
   DIM nLen AS LONG = LEN(wszDelimiter) * 2
   DIM pstr AS ANY PTR = pBuffer
   DO
      pstr = wcsstr(pstr, @wszDelimiter)
      IF pstr = NULL THEN EXIT DO
      pstr += nLen
      dwCount += 1
   LOOP
  ' // Dimension a safe array with dwCount elements
   DIM csa AS CSafeArray = CSafeArray(VT_BSTR, dwCount, 1)
   DIM cws AS CWSTR, sLen AS LONG
   DIM idx AS LONG = 1
   DIM _pstr AS ANY PTR = pBuffer
   pstr = pBuffer
   ' / Skip the BOM
   DIM s AS STRING = "  "
   strncpy STRPTR(s), _pstr, 2
   ' // Check for UTF-16 BOM (little endian)
   IF s = CHR(&hFF, &hFE) THEN
      _pstr += 2
   ELSE
      ' // Check for UTF-8 BOM
      s = "   "
      strncpy STRPTR(s), _pstr, 3
      IF s = CHR(&hEF, &hBB, &hBF) THEN _pstr += 3
   END IF
   ' // Parse the buffer
   DO
      pstr = wcsstr(pstr, @wszDelimiter)
      IF pstr = NULL THEN EXIT DO
      sLen = (pstr - _pstr) \ 2
      cws = ""
      IF sLen > nLen THEN
         cws = STRING(sLen, CHR(0))
         wcsncpy cws, _pstr, sLen
      END IF
      IF idx <= dwCount THEN csa.PutElement(idx, CBSTR(cws))
      idx += 1
      pstr += nLen
      _pstr = pstr
   LOOP
   DeAllocate(pBuffer)
   RETURN csa
END FUNCTION
' ========================================================================================

These functions are equivalent to the following PowerBasic code:

Code: [Select]
OPEN "datafile.dat" FOR INPUT AS #1
FILESCAN #1, RECORDS TO count&
DIM TheData(1 TO count&) AS STRING
LINE INPUT #1, TheData() TO count&
CLOSE #1

But also work with unicode files.
Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on September 02, 2017, 12:56:44 PM
These FileScan routines are an awesome addition to the framework.

BTW, you need to change the name of the library now.... it is so much more than CWindow that it seems to be a shame to call it that. :)

Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 02, 2017, 03:20:45 PM
What about WinFBX (Windows FreeBasic eXtensions)? Makes a good couple with WinFBE.
Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on September 02, 2017, 03:45:18 PM
I think it's perfectly alright :)
You can also have WinLIB if you prefer that. I'll just rename the library that I'm making that works on top of yours.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 02, 2017, 03:54:15 PM
I think that WinFBX is a bit more suited that WinLib because it is more descriptive, since it includes Win for Windows, FB for FreeBasic and X for extensions.
Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on September 02, 2017, 05:18:39 PM
Sounds good :)
Have you tried using GitHub to keep your code? I started using it for WinFBE and it is incredibly easy. Just download the GitHub Desktop client and it handles everything.  https://desktop.github.com
I never have to worry that I will lose my source code. It is always online and releasing packages is a breeze. Just a thought in case it interests you.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 02, 2017, 07:08:24 PM
It is impossible to work with that tool at 192 DPI. I have uninstalled it.

They must think that to make an application DPI aware you only have to do scaling, without worrying about anything else, such making the controls accessible. Holy crap!


Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 03, 2017, 12:14:06 AM
As an alternative to arrays and/or dictionary objects, we can use ADO to create in-memory recordsets. Some advantages of using ADO over SQLite for this task is that we don't need to use a third party DLL and that we can save a recordset to disk as a stream or as XML just calling Save or SaveAsXml.

A sort test:

Code: [Select]
#include "Afx/CADODB/CADODB.inc"
using Afx

' // Create an instance of the CAdoRecorset class
DIM pRecordset AS CAdoRecordset
' // Get a reference to the Fields collection
DIM pFields AS CAdoFields = pRecordset.Fields

pFields.Append("Key", adVarChar, 10)
pFields.Append("Item", adVarChar, 20)

pRecordset.CursorType = adOpenKeyset
pRecordset.CursorLocation = adUseClient
pRecordset.LockType = adLockOptimistic
pRecordset.Open

pRecordset.AddNew
   pRecordset.Collect("Key") = "One"
   pRecordset.Collect("Item") = "Item one"
'pRecordset.Update
' Don't call Update or it will add an additional empty record

pRecordset.AddNew
   pRecordset.Collect("Key") = "Two"
   pRecordset.Collect("Item") = "Item two"
'pRecordset.Update

print "Record count: ", pRecordset.Recordcount

pRecordset.MoveFirst
DO
   IF pRecordset.EOF THEN EXIT DO
   PRINT pRecordset.Collect("Key").ToStr
   PRINT pRecordset.Collect("Item").ToStr
   IF pRecordset.MoveNext <> S_OK THEN EXIT DO
LOOP

PRINT
PRINT "Press any key..."
SLEEP

Seek does not work, but we can use Find (to search by name) or AbsolutePosition (to search by ordinal). We can also use other ADO methods such Delete, Sort and Filter.

We can also get all the rows as a two-dimensional safe array, calling the GetRows method, or as an string calling the GetString method, that allows to specify the number of rows to read, a separator (default = tab) and a row delimiter (default = CRLF).

This is a good option for things that we can't do with normal arrays, such having a multi-dimensional array in which each dimension can be of any type.
Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on September 06, 2017, 06:43:32 PM
Jose do you think that you could add a small text file to your release candidates so that it would be easy to determine what version of the library we have installed? Periods of time pass and I keep forgetting what version of the library I am releasing with WinFBE. If the version was in a small text file, say, "_version.txt", then I could quickly see if I need to upgrade the library before posting a WinFBE release.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 06, 2017, 06:58:34 PM
In CWindow.inc you can find:

' File: CWindow.inc
' Version: 1.0
' Release candidate 31

Anyway, I think that it is time to release the first WinFBX version.

I have opened an account in GitHub and will upload the code to it, together with examples, tools or whatever.

I will try to do it using the web interface, because the GitHib Desktop tool is almost unusable at 192 DPI.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 07, 2017, 03:21:52 PM
I have written a class, CCLRHost, to host the .NET 4 runtime. So far it works with .NET system classes, e.g.:

Code: [Select]
'#CONSOLE ON
#define UNICODE
#INCLUDE ONCE "windows.bi"
#INCLUDE ONCE "Afx/CCLRHost.inc"
USING Afx

' // Create an instance of the CCLRHost class
DIM pCLRHost AS CCLRHost

' // Create an instance of the .NET stack collection
DIM pDisp AS CDispInvoke = pCLRHost.CreateInstance ("mscorlib", "System.Collections.Stack")
IF pDisp.DispPtr = NULL THEN END

pDisp.Invoke("Push", 1, CVAR("rocks!"))
pDisp.Invoke("Push", 1, CVAR("FreeBasic"))
print pDisp.Get("Pop").ToStr
print pDisp.Get("Pop").ToStr

' To get the count, call
' DIM nCount AS LONG = pDisp.Invoke("Count").ValInt

PRINT
PRINT "Press any key..."
SLEEP

The class also provides the method CreateInstanceFrom that will allow to load an assembly from disk and create an instance of the requested class. However, as I never have used .NET, I can't curently test it because i would need suitable assemblies (bit 32 and 64-bit) to test. If somebody is interested in using .NET assemblies with FreeBasic and can provide suitable assemblies to test, I will continue to develop the class. If there is no interest, it will end being a curiosity as it happened with PowerBasic.

The use of the "System.Collections.Stack" .NET class already allows to replace the PowerBasic Stack collection.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 07, 2017, 03:54:33 PM
BTW notice that I have used a class just to make it easier to use the code, but only an instance of the class can be created because the CLR runtime can only be loaded once in the same process.

Also, Automation and late binding must be used to call the methods and properties of the classes because they are dynamic properties (there is not a virtual table).
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 07, 2017, 04:05:04 PM
We an also use the .NET ArrayList class:

Code: [Select]
'#CONSOLE ON
#define UNICODE
#INCLUDE ONCE "windows.bi"
#INCLUDE ONCE "Afx/CCLRHost.inc"
USING Afx

' // Create an instance of the CCLRHost class
DIM pCLRHost AS CCLRHost

' // Create an instance of the .NET ArrayList class
DIM pDisp AS CDispInvoke = pCLRHost.CreateInstance ("mscorlib", "System.Collections.ArrayList")
IF pDisp.DispPtr = NULL THEN END

pDisp.Invoke("Add", 1, CVAR("First string"))
pDisp.Invoke("Add", 1, CVAR("Second string"))
pDisp.Invoke("Add", 1, CVAR("Third string"))

DIM nCount AS LONG = pDisp.Invoke("Count").ValInt
FOR i AS LONG = 0 TO nCount - 1
   print pDisp.Get("Item", CVAR(i)).ToStr
NEXT

PRINT
PRINT "Press any key..."
SLEEP

See: https://msdn.microsoft.com/es-es/library/system.collections.arraylist(v=vs.110).aspx
Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on September 07, 2017, 04:20:13 PM
Wow, this is very interesting. There is so much in .Net that could be used especially if the speed is okay. the .Net runtime ships with Windows so unless you are trying to interface very new functionality then access to .Net functions should (in theory) be no different than accessing WinApi directly. I will definitely be looking into this further.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 07, 2017, 04:20:43 PM
For overloaded methods, when NET creates the COM callable wrapper it adds an underscore and an ordinal to each one. Therefore, the first overloaded Append method of the "System.Text.StringBuilder" class is called "Append", but the second one "Append_2" and so on.

Code: [Select]
'#CONSOLE ON
#define UNICODE
#INCLUDE ONCE "windows.bi"
#INCLUDE ONCE "Afx/CCLRHost.inc"
USING Afx

' // Create an instance of the CCLRHost class
DIM pCLRHost AS CCLRHost

' // Create an instance of the .NET StrigBuilder class
DIM pDisp AS CDispInvoke = pCLRHost.CreateInstance ("mscorlib", "System.Text.StringBuilder")
IF pDisp.DispPtr = NULL THEN END

pDisp.Invoke("Append_3", 1, CVAR("Hello"))
pDisp.Invoke("Append_3", 1, CVAR(" World!"))
print pDisp.Invoke("ToString").ToStr

PRINT
PRINT "Press any key..."
SLEEP

As we are using Automation, the call to pDisp.Invoke("ToString") does not return a string, but a VARIANT. Therefore, we have to use pDisp.Invoke("ToString").ToStr to convert the returned variant to a string.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 07, 2017, 04:33:25 PM
> then access to .Net functions should (in theory) be no different than accessing WinApi directly

Well, it is very different. The complexity is hidden in the class. We have to host the .NET runtime and force it to create a COM callable wrapper on the fly that allows to call the methods of the .NET class as if it was a COM object. Also as they are dynamic, we must use Automation and late binding, which is slower than direct calls.
Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on September 07, 2017, 06:14:49 PM
> then access to .Net functions should (in theory) be no different than accessing WinApi directly

Well, it is very different. The complexity is hidden in the class. We have to host the .NET runtime and force it to create a COM callable wrapper on the fly that allows to call the methods of the .NET class as if it was a COM object. Also as they are dynamic, we must use Automation and late binding, which is slower than direct calls.

Hmmmm.... yes, that does sound like a significant amount of overhead. That's too bad because access to the wealth of functionality within the .net CLR would be quite awesome.
 
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 07, 2017, 06:25:13 PM
But we are still in the beginning... There is still much to explore.

If we add these attributes to the public classes of our assembly and then we make a COM callable wrapper, that we can register win regasm, it will create dual interfaces that can we used as if it was a COM server, without having to host the .NET runtime.

Code: [Select]
VB.NET: <ClassInterface(ClassInterfaceType.AutoDual)>
C#:     [ClassInterface(ClassInterfaceType.AutoDual)]

With these attributes, the methods will be visible to COM browsers and we can create interface declarations and use direct calls, although I guess that the COM wrapper will marshall these calls to the .NET assembly.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 07, 2017, 06:28:32 PM
There is a .NET assembly that comes with the .NET framework, called System.dll. It has allowed me to test if the CreateInstanceFrom method of the CCLRHost class works, and it does:

Code: [Select]
'#CONSOLE ON
#define UNICODE
#INCLUDE ONCE "windows.bi"
#INCLUDE ONCE "Afx/CCLRHost.inc"
USING Afx

' // Create an instance of the CCLRHost class
DIM pCLRHost AS CCLRHost

' // Create an instance of the .NET WebClient class
DIM pDisp AS CDispInvoke = pCLRHost.CreateInstanceFrom( _
   $"C:\Windows\Microsoft.NET\Framework\v4.0.30319\System.dll", _
   "System.Net.WebClient")
IF pDisp.DispPtr = NULL THEN END

DIM cvAddress AS CVAR = $"http://www.jose.it-berater.org/webpages_images/h_2.jpg"
DIM cvFileName AS CVAR = ExePath & $"\h_2.jpg"
DIM cvRes AS CVAR = pDisp.Invoke("DownloadFile", 2, cvAddress, cvFileName)
IF pDisp.GetLastResult <> S_OK THEN
   print "Error: &H"; HEX(pDisp.GetErrorCode)
ELSE
   print "Picture saved"
END IF

PRINT
PRINT "Press any key..."
SLEEP

If we register it with regasm, then we can use it as:

Code: [Select]
'#CONSOLE ON
#define UNICODE
#INCLUDE ONCE "windows.bi"
#INCLUDE ONCE "Afx/AfxCOM.inc"
USING Afx

' // Create an instance of the .NET WebClient class
DIM pDisp AS CDispInvoke = AfxNewCom("System.Net.WebClient")
IF pDisp.DispPtr = NULL THEN END

DIM cvAddress AS CVAR = $"http://www.jose.it-berater.org/webpages_images/h_2.jpg"
DIM cvFileName AS CVAR = ExePath & $"\h_2.jpg"
pDisp.Invoke("DownloadFile", 2, cvAddress, cvFileName)

PRINT
PRINT "Press any key..."
SLEEP
Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on September 07, 2017, 07:00:37 PM
We an also use the .NET ArrayList class:

Code: [Select]
'#CONSOLE ON
#define UNICODE
#INCLUDE ONCE "windows.bi"
#INCLUDE ONCE "Afx/CCLRHost.inc"
USING Afx

' // Create an instance of the CCLRHost class
DIM pCLRHost AS CCLRHost

' // Create an instance of the .NET ArrayList class
DIM pDisp AS CDispInvoke = pCLRHost.CreateInstance ("mscorlib", "System.Collections.ArrayList")
IF pDisp.DispPtr = NULL THEN END

pDisp.Invoke("Add", 1, CVAR("First string"))
pDisp.Invoke("Add", 1, CVAR("Second string"))
pDisp.Invoke("Add", 1, CVAR("Third string"))

DIM nCount AS LONG = pDisp.Invoke("Count").ValInt
FOR i AS LONG = 0 TO nCount - 1
   print pDisp.Get("Item", CVAR(i)).ToStr
NEXT

PRINT
PRINT "Press any key..."
SLEEP

See: https://msdn.microsoft.com/es-es/library/system.collections.arraylist(v=vs.110).aspx

Works perfectly. I also love how your msdn link takes us to the Spanish webpage version :) :)
Here's the English in case anyone is interested: https://msdn.microsoft.com/en-ca/library/system.collections.arraylist(v=vs.110).aspx

I am surprised with how fast it is even as you say that it must create an instance and use dispatch interface. I added 100,000 strings in about a second or so.
Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on September 07, 2017, 07:08:02 PM
> then access to .Net functions should (in theory) be no different than accessing WinApi directly

Well, it is very different. The complexity is hidden in the class. We have to host the .NET runtime and force it to create a COM callable wrapper on the fly that allows to call the methods of the .NET class as if it was a COM object. Also as they are dynamic, we must use Automation and late binding, which is slower than direct calls.

Yeah, that's a hell of an interesting looking code base! Amazing.
Is the creating of an instance of the class a time consuming process? Seems to me based on my limited tests that everything runs half decently fast as it is.
Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on September 07, 2017, 07:18:46 PM
For overloaded methods, when NET creates the COM callable wrapper it adds an underscore and an ordinal to each one. Therefore, the first overloaded Append method of the "System.Text.StringBuilder" class is called "Append", but the second one "Append_2" and so on.

Code: [Select]
'#CONSOLE ON
#define UNICODE
#INCLUDE ONCE "windows.bi"
#INCLUDE ONCE "Afx/CCLRHost.inc"
USING Afx

' // Create an instance of the CCLRHost class
DIM pCLRHost AS CCLRHost

' // Create an instance of the .NET StrigBuilder class
DIM pDisp AS CDispInvoke = pCLRHost.CreateInstance ("mscorlib", "System.Text.StringBuilder")
IF pDisp.DispPtr = NULL THEN END

pDisp.Invoke("Append_3", 1, CVAR("Hello"))
pDisp.Invoke("Append_3", 1, CVAR(" World!"))
print pDisp.Invoke("ToString").ToStr

PRINT
PRINT "Press any key..."
SLEEP

As we are using Automation, the call to pDisp.Invoke("ToString") does not return a string, but a VARIANT. Therefore, we have to use pDisp.Invoke("ToString").ToStr to convert the returned variant to a string.

I could envision down the road a FB class that encapsulates this code to make it transparent to the programmer. A class with overloaded functions that in turn call the necessary version of the underscored .net function (append_1, append_2, append_3, etc).

I guess you only need to create instance of runtime once at start of program and even make it global so that you could call it throughout your program.
Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on September 07, 2017, 07:20:43 PM
....this is blowing my mind it is so cool.   :)
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 07, 2017, 07:32:24 PM
Quote
I am surprised with how fast it is even as you say that it must create an instance and use dispatch interface. I added 100,000 strings in about a second or so.

And CVAR("xxx string") is also creating and destroying a temporay instance of the CVAR class, that has to allocate the string as a BSTR. We could gain some speed manipulating the variants directly, but that will be harder to code.

Quote
Is the creating of an instance of the class a time consuming process? Seems to me based on my limited tests that everything runs half decently fast as it is.

Looks like it is a fast process. Anyway, it is done only once, so the overhead that must worry us is the one of calling the methods using Automation. It will never be as fast as a low-level COM server, but for many tasks it will be acceptable. Of course, the purpose of my research is not to use the .NET framework instead of other techniques, but to allow to use it when we find it convenient. For example, I won't use "System.Net.WebClient" to download a file, but CWinHTTP or WinInet, but we really need to write our own code to support stacks when we can use System.Collections.Stack"? This is not something that needs raw speed.

Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 07, 2017, 07:37:10 PM
Quote
I guess you only need to create instance of runtime once at start of program and even make it global so that you could call it throughout your program.

As I have noted in a previous post, I have used a class just to make it easier to use the code, but only an instance of the class can be created because the CLR runtime can only be loaded once in the same process. This means that we only need to create an instance of the CCLRHost class per process and use it to create instances of the classes of the .NET assemblies.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 07, 2017, 07:42:50 PM
Quote
I could envision down the road a FB class that encapsulates this code to make it transparent to the programmer. A class with overloaded functions that in turn call the necessary version of the underscored .net function (append_1, append_2, append_3, etc).

I guess you only need to create instance of runtime once at start of program and even make it global so that you could call it throughout your program.

As I dislike the use of globals (they are poison to write reusable code), you can pass the pointer of the CCLRHost class as a parameter.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 07, 2017, 08:26:38 PM
In the constructor of the CCLRHost class I'm using "v4.0.30319", which is the highest version installed in my computer, as the default value It can be overriden by passing another version.

I will see if I can write a wrapper function that returns the highest version installed in a computer.
Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on September 07, 2017, 09:02:53 PM
I noticed that hard coded path. I wonder if you could use the code at the following link to query the Registry to get the highest installed net version.
https://docs.microsoft.com/en-us/dotnet/framework/migration-guide/how-to-determine-which-versions-are-installed

You could also query the "InstallPath" key.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 07, 2017, 09:14:08 PM
Looking at the registry of my computer I see that the version installed is 4.7.02053, although the name of InstallPath remains being "C:\Windows\Microsoft.NET\FrameWork64\v4.0.30319\".

And what happens if the computer is only 32 bit? Will the name be "C:\Windows\Microsoft.NET\FrameWork\v4.0.30319\"?

It's odd that Windows does not provide a function to return it.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 07, 2017, 09:33:50 PM
Seems that we have to use "v4.0.30319" and .NET will use the version found there (apparently it wants the name of the subfolder instead of the version installed). If I change that value to "v4.7.02053" it does not work. Guess that this value will be valid until version 5. One problem less :)

Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on September 07, 2017, 09:54:29 PM
Looking at the registry of my computer I see that the version installed is 4.7.02053, although the name of InstallPath remains being "C:\Windows\Microsoft.NET\FrameWork64\v4.0.30319\".

And what happens if the computer is only 32 bit? Will the name be "C:\Windows\Microsoft.NET\FrameWork\v4.0.30319\"?

It's odd that Windows does not provide a function to return it.

On my 64bit Windows 10 laptop I have both folders.... FrameWork and FrameWork64. On my 32 Windows 7 laptop I only have FrameWork.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 07, 2017, 10:04:41 PM
The ICLRMetaHost interface as a method called EnumerateInstalledRuntimes. I will try to use it and see what it returns.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 07, 2017, 10:24:04 PM
Well, I don't see any need to search for complications. It seems that what matters is the name of the subfolder where it is installed.

v1.0.3705 - not available in 64 bit
v1.1.4322 - not available in 64 bit
v2.0.50727 - Net Framework 2
v3.0 - Net Framework 3
v3.5 - Net Framework 3.5
v4.0.30319 - Net Framework 4

Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on September 07, 2017, 10:26:40 PM
So I guess you query Windows to see if you are running on 32 or 64 and then pick either the FrameWork or FrameWork64 subfolders, I guess?
Title: Re: CWindow Release Candidate 31
Post by: Pierre Bellisle on September 07, 2017, 10:28:21 PM
-
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 07, 2017, 10:37:29 PM
So I guess you query Windows to see if you are running on 32 or 64 and then pick either the FrameWork or FrameWork64 subfolders, I guess?

No. We only need to pass "v4.0.30319" to support the .NET Framework 4. It works both with 32 and 64 bit. NET will look in the "Framework" subfolder if the application is 32 bit and in "Framework64" if it is 64 bit. This makes it easier to use. What I don't know is why they don't explain it.

Notice that no matter which version you have installed, the subfolder is called "v4.0.30319". and it works if we pass this value, whereas it does not work if we pass e.g. "v4.7.02053".

Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on September 07, 2017, 10:54:05 PM
Ahhhhh.... now I understand. You only need to pass that value and not a full path. Got it.
Seems like version 4.5 would be the version to support as it requires Vista and I assume it is installed on all machines. I wonder if that's true.

Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 07, 2017, 11:16:31 PM
In the beginning (version 1 and 2) you had to install the Framework, but now it comes pre-installed. I could have added a method to support version 2, but why bother? We don't support Windows 2000 and XP.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 08, 2017, 06:17:14 PM
I can't understand why calling the method below fails with an out of memory error in the call to m_pCorRuntimeHost->CreateDomain. The same code, but using the PowerBasic syntax, works with PowerBasic.

Code: [Select]
' ========================================================================================
' Creates an application domain.
' Note: Does not work. Returns error COR_E_OUTOFMEMORY (&h8007000E) in the call to CreateDomain.
' ========================================================================================
PRIVATE FUNCTION CCLRHost.CreateDomain (BYREF wszFriendlyName AS WSTRING) AS Afx__AppDomain PTR
   DIM pUnk AS Afx_IUnknown PTR, pDomain AS Afx__AppDomain PTR
   DIM hr AS HRESULT = m_pCorRuntimeHost->CreateDomain(@wszFriendlyName, NULL, cast(ANY PTR, @pUnk))
   IF hr <> S_OK THEN SetLastError(hr) : RETURN NULL
   DIM IID__AppDomain AS GUID = TYPE(&h05F696DC, &h2B29, &h3663, {&hAD, &h8B, &hC4, &h38, &h9C, &hF2, &hA7, &h13})
   pUnk->QueryInterface(@IID__AppDomain, @pDomain)
   pUnk->Release
   FUNCTION = pDomain
END FUNCTION
' ========================================================================================
Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on September 08, 2017, 06:24:28 PM
Maybe the call to m_pCorRuntimeHost->CreateDomain is calling the same instance function CCLRHost.CreateDomain over and over again until the recursion causes memory fail?
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 08, 2017, 06:29:27 PM
No. it is called only once. You can't call CCLRHost.CreateDomain using the m_pCorRuntimeHost pointer. m_pCorRuntimeHost->CreateDomain calls the CreateDomain method of the ICorRuntimeHost interface.
Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on September 08, 2017, 06:37:50 PM
Can you post the current class code you have and the example you are working with? Maybe I can trace it with the debugger.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 08, 2017, 06:47:40 PM
The testing code is very simple:

Code: [Select]
'#CONSOLE ON
#define UNICODE
#INCLUDE ONCE "windows.bi"
#INCLUDE ONCE "Afx/CCLRHost.inc"
USING Afx

' // Create an instance of the CCLRHost class
DIM pCLRHost AS CCLRHost

' // Create a custom domain
DIM pDomain AS Afx__AppDomain PTR = pCLRHost.CreateDomain("MyDomain")
print HEX(GetLastError)
IF pDomain THEN pCLRHost.UnloadDomain(pDomain)


PRINT
PRINT "Press any key..."
SLEEP

Attached is the current version of the hosting class.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 08, 2017, 06:52:14 PM
With PowerBasic I use this code and works. The names and the syntax are a bit different, but as far as I know both do the same thing.

Code: [Select]
   ' =====================================================================================
   METHOD CreateDomain ( _                              ' VTable offset = 48
     BYREF pwzFriendlyName AS WSTRINGZ _                ' __in LPCWSTR pwzFriendlyName
   , BYVAL pIdentityArray AS IUnknown _                 ' __in IUnknown *pIdentityArray
   , BYREF pAppDomain AS IUnknown _                     ' __out IUnknown **pAppDomain
   ) AS LONG                                            ' HRESULT
   ' =====================================================================================

Code: [Select]
' =====================================================================================
' Creates an application domain.
' =====================================================================================
METHOD CreateDomain (OPTIONAL BYREF wszFriendlyName AS WSTRINGZ, BYVAL pIdentityArray AS IUnknown) AS SystemAppDomain
   LOCAL hr AS LONG
   LOCAL pUnk AS IUnknown
   LOCAL pDomain AS SystemAppDomain
   hr = m_pCorRuntimeHost.CreateDomain(wszFriendlyName, pIdentityArray, pUnk)
   IF hr THEN
      METHOD OBJRESULT = hr
   ELSE
      pDomain = pUnk
      pUnk = NOTHING
      METHOD = pDomain
   END IF
END METHOD
' =====================================================================================
Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on September 08, 2017, 07:00:03 PM
Putting GetLastError after;

DIM pCLRHost AS CCLRHost
GetLastError

Returns:
Error 127 ERROR_PROC_NOT_FOUND

Problem with the class constructor?
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 08, 2017, 07:14:36 PM
No. This error must be set internally by NET in the call to CLRCreateInstance, but it is not meaningful since what it counts is the result code of the function. I will have to set the last error to 0 after calling it.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 08, 2017, 07:26:11 PM
I have changed the code to not use SetLastError, because it can't be trusted. You can call a function or method that succeeds, but GetLastError can return an unmeaningful error.

Code: [Select]
'#CONSOLE ON
#define UNICODE
#INCLUDE ONCE "windows.bi"
#INCLUDE ONCE "Afx/CCLRHost.inc"
USING Afx

' // Create an instance of the CCLRHost class
DIM pCLRHost AS CCLRHost
print pCLRHost.GetLastResult

' // Create a custom domain
DIM pDomain AS Afx__AppDomain PTR = pCLRHost.CreateDomain("MyDomain")
print HEX(pCLRHost.GetLastResult, 8)
IF pDomain THEN pCLRHost.UnloadDomain(pDomain)


PRINT
PRINT "Press any key..."
SLEEP
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 08, 2017, 07:47:43 PM
I even have tried using a VTable instead of abstract methods with the same result.
Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on September 08, 2017, 10:39:49 PM
I wonder if it could be the string that is being passed to CreateDomain. Is CreateDomain expecting a .dot net string class rather than a UTF-16 string of characters? The documentation seems to say that it is a UTF-16 string of characters.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 08, 2017, 11:03:46 PM
Code: [Select]
HRESULT CreateDomain ( 
    [in] LPWSTR    pwzFriendlyName, 
    [in] IUnknown* pIdentityArray, 
    [out] void   **pAppDomain 
); 

It is a LPWSTR, i.e. a pointer to a WSTR (null terminated unicode string). The ICorRuntimeHost interface is a low-level COM interface, not a .NET class. With PowerBasic, it works using a WSTRINGZ. I have tried everything and I always get the same error.
Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on September 08, 2017, 11:19:51 PM
You are passing NULL to pIdentityArray but in the PowerBasic it seems you are passing an actual value. The docs say that NULL is valid but maybe it is worth a look.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 08, 2017, 11:35:57 PM
With PowerBASIC the parameter is optional and a NULL is also being passed. The returned message does not make sense to me. It is not even listed in the list of possible errors in the MSDN documentation for the CreateDomain method.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 08, 2017, 11:53:12 PM
And CreateDomainEx also fails with the same error. These are the only two that have an string parameter in this interface, so it is my main suspect.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 09, 2017, 12:18:46 AM
I also have tried

Code: [Select]
   DIM ppEvidence AS IUnknown PTR
   m_pCorRuntimeHost->CreateEvidence(@ppEvidence)
   DIM hr AS HRESULT = m_pCorRuntimeHost->CreateDomain(@wszFriendlyName, ppEvidence, cast(ANY PTR, @pUnk))

and also fails.

Looks like the string parameter is the problem, but I have also tried passing a BSTR and even a CWSTR and a ZSTRING and it fails. I don't understand why.
Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on September 11, 2017, 09:56:45 AM
Have you been able to figure out the string problem? Problems like this must drive you crazy! :)  :)  :)
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 11, 2017, 10:19:59 AM
No. I have tried everything and always get the same error. Yet similar code works with PowerBasic. Everything else works, so we can use it using the default domain. Custom domains aren't indispensable, just convenient for some tasks.

Some time ago I had a problem to add OpenGL support to the graphic control. Some months later, I tried again and it worked. I can't tell you where was the problem, because I had discarded the code and started from scratch.

Meanwhile, I have been working writing wrapper functions to support Complex numbers. Instead of a class, this time I have used plain functions and use the Afx namespace to avoid conflicts.

Code: [Select]
#include once "AfxComplex.inc"

DIM cpx1 AS _complex = (3, 4)
DIM cpx2 AS _complex = (5, 6)
cpx1 = cpx1 + cpx2
print Afx.Cstr(cpx1)

There are a lot of math functions, most of which I have already checked that return the right results. The most complex functions are an adaptation of the ones from the GSL - GNU Scientific Library, which unfortunately is LGPL.

Title: Re: CWindow Release Candidate 31
Post by: Johan Klassen on September 12, 2017, 10:03:55 AM
hello Jose Roca
just in case you need to have a look at complex functions implementation there's this library http://www.wolfgang-ehrhardt.de/misc_en.html#damath
Quote
License

(C) Copyright 2002-2017 Wolfgang Ehrhardt

Copying Conditions

This software is provided 'as-is', without any express or implied warranty. In no event will the authors be held liable for any damages arising from the use of this software.

Permission is granted to anyone to use this software for any purpose, including commercial applications, and to alter it and redistribute it freely, subject to the following restrictions:

1. The origin of this software must not be misrepresented; you must not claim that you wrote the original software. If you use this software in a product, an acknowledgment in the product documentation would be appreciated but is not required.

2. Altered source versions must be plainly marked as such, and must not be misrepresented as being the original software.

3. This notice may not be removed or altered from any source distribution.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 12, 2017, 03:34:09 PM
Thanks for the link. I already have implemented a big amount of functions and, more important, I have checked that all of them work correctly. Don't know if I will add more. Math is not my forte.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 14, 2017, 11:58:24 PM
I'm replacing the GSL functions with translations of the .NET System.Numerics/System/Numerics/Complex.cs class (source code: https://github.com/Microsoft/referencesource/blob/master/System.Numerics/System/Numerics/Complex.cs ) and apparently the code for the Asin and Acos methods is reversed! I have checked results with GSL and from MATLAB examples, and Asin returns the expected results for Acos, and viceversa.

The reason of the replacement is because this .NET class as a MIT license, whereas GSL as a GPL license.

Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 15, 2017, 01:42:41 AM
And also differs in the sign of the imaginary part, + instead of - (according the other sources). Looks like they have got everything reversed. Anybody has the means to ascertain which source is right?

Code: [Select]
' ========================================================================================
' * Returns the complex arcsine of a complex number.
' The branch cuts are on the real axis, less than -1 and greater than 1.
' Example:
'   DIM z AS _complex = (1, 1)
'   z = AfxCArcSin(z)
'   PRINT AfxCStr(z)
' Output: 0.6662394324925152 +1.061275061905036 * i
' ========================================================================================
' ========================================================================================
' - NET 4.7 code:
' public static Complex Acos(Complex value) /* Arccos */
' { return (-ImaginaryOne) * Log(value + ImaginaryOne*Sqrt(One - (value * value))); }
' Note: Apparently, .NET has got the code for the Asin and Acos function revesed!
' It also returns -1.061275061905036 * i instead of +1.061275061905036 * i in the above example.
' ========================================================================================
PRIVATE FUNCTION AfxCArcSin (BYREF value AS _complex) AS _complex
   DIM ImaginaryOne AS _complex = TYPE<_complex>(0.0, 1.0)
   DIM One AS _complex = TYPE<_complex>(1.0, 0.0)
'   RETURN (-ImaginaryOne) * AfxCLog(value + ImaginaryOne * AfxCSqr(One - (value * value)))
   DIM z AS _complex = AfxCLog(value + ImaginaryOne * AfxCSqr(One - (value * value)))
   RETURN TYPE<_complex>(z.y, z.x)
END FUNCTION
' ========================================================================================

Code: [Select]
' ========================================================================================
' * Returns the complex arccosine of a complex number.
' The branch cuts are on the real axis, less than -1 and greater than 1.
' Example:
'   DIM z AS _complex = (1, 1)
'   z = AfxCArcCos(z)
'   print AfxCStr(z)
' Output: 0.9045568943023814 -1.061275061905036 * i
' ========================================================================================
' ========================================================================================
' - NET 4.7 code:
' public static Complex Asin(Complex value) /* Arcsin */
' { return (-ImaginaryOne) * Log(ImaginaryOne * value + Sqrt(One - value * value)); }
' Note: Apparently, .NET has got the code for the Asin and Acos function revesed!
' It also returns +1.061275061905036 * i instead of -1.061275061905036 * i in the above example.
' ========================================================================================
PRIVATE FUNCTION AfxCArcCos (BYREF value AS _complex) AS _complex
   DIM ImaginaryOne AS _complex = TYPE<_complex>(0.0, 1.0)
   DIM One AS _complex = TYPE<_complex>(1.0, 0.0)
'   RETURN (-ImaginaryOne) * AfxCLog(ImaginaryOne * value + AfxCSqr(One - value * value))
   DIM z AS _complex = AfxCLog(ImaginaryOne * value + AfxCSqr(One - value * value))
   RETURN TYPE<_complex>(z.y, z.x)
END FUNCTION
' ========================================================================================

Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 15, 2017, 02:09:58 AM
Another problem with the sign in the arctangent function.

Code: [Select]
' ========================================================================================
' * This function returns the complex arctangent of a complex number.
' The branch cuts are on the imaginary axis, below -i and above i.
' Example:
'   DIM z AS _complex = (1, 1)
'   z = AfxCArcTan(z)
'   PRINT AfxCStr(z)
' Output: 1.017221967897851 +0.4023594781085251 * i
' ========================================================================================
' ========================================================================================
' - NET 4.7 code:
' public static Complex Atan(Complex value) /* Arctan */
' {
'    Complex Two = new Complex(2.0, 0.0);
'    return (ImaginaryOne / Two) * (Log(One - ImaginaryOne * value) - Log(One + ImaginaryOne * value));
' }
' Note: It returns -0.4023594781085251 * i instead of +0.4023594781085251 * i, so I have
' needed to use a workaround.
' ========================================================================================
' ========================================================================================
PRIVATE FUNCTION AfxCArcTan (BYREF value AS _complex) AS _complex
   DIM ImaginaryOne AS _complex = TYPE<_complex>(0.0, 1.0)
   DIM One AS _complex = TYPE<_complex>(1.0, 0.0)
   DIM Two AS _complex = TYPE<_complex>(2.0, 0.0)
'   RETURN (ImaginaryOne / Two) * (AfxCLog(One - ImaginaryOne * value) - AfxCLog(One + ImaginaryOne * value))
   DIM z AS _complex = AfxCLog(One - ImaginaryOne * value) - AfxCLog(One + ImaginaryOne * value)
   z /= 2 : DIM temp AS DOUBLE = z.x : z.x = z.y : z.y = temp
   RETURN z
END FUNCTION
' ========================================================================================
Title: Re: CWindow Release Candidate 31
Post by: Johan Klassen on September 15, 2017, 09:20:57 AM
hello Jose Roca
I downloaded your AfxComplex and it agrees with pari/gp
however the functions in your last posts give wrong result, is AfxClog giving the right result?
note: I changed the call to AfxClog to Clog because AfxClog is not posted.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 15, 2017, 01:36:19 PM
Forget the previous code. I have fully reworked the module to get rid of the GSL code beause the GNU Scientific Library has a GPL license. Some of the new functions are based in code from Complex.cs class for .NET, that uses the more permissive MIT license. I also have changed the naming convention and removed the namespace to make the module fully independent of my framework (as soon as you use some open source code, you risk to "contaminate" all the rest of your code).

It seems to be working fine, although apparently the .NET code for Acos and Asin, that I have used in the AfxCArcSin and AfxCArcCos functions, seems to be reversed, so I have swaped it. These two functions and Atan (code used in AfxCArcTan) also return a wrong sign, so I have used a workaround.
Title: Re: CWindow Release Candidate 31
Post by: Johan Klassen on September 15, 2017, 02:43:22 PM
there's a problem with AfxClog
Code: [Select]
dim as _complex y, x=(1,1)
y=AfxCexp(x)
y=AfxClog(y)
print y.x, y.y '-> 1             0.5707963267948967
I think the culprit is atan2, if you swap the arguments it seems to work, but then the other function are broke, perhaps this was the cause of your problems all along.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 15, 2017, 03:15:06 PM
Yes, AfxCLog is wrong. I will have to fix it and then recheck all the other functions that use it. I was surprised of such a "bug" in a .NET class and thought that I was missing something. Thanks very much for spotting it.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 15, 2017, 03:45:13 PM
> perhaps this was the cause of your problems all along.

Yes, that was it. It was I who was reversing the result, not the .NET class. It has been an easy fix because I had the original code remed just before the workaround code, so I only have needed to unrem it and remove the other code. I didn't notice the bug in AfxCLog because, unfortunately, with the values that I used to test it the result was right.

Title: Re: CWindow Release Candidate 31
Post by: Johan Klassen on September 15, 2017, 04:15:07 PM
yes that works at least for the values tested, but maybe you will consider the following alternatives for inspiration: A public domain complex math library for Arduino (http://arduino.cc/playground/Main/ComplexMath)
Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on September 15, 2017, 06:57:09 PM
All this math is making my head hurt :)
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 15, 2017, 08:01:27 PM
Then we forget the quaternions? :)
Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on September 15, 2017, 08:15:07 PM
lol, I consider myself a smart and educated guy, but I had to google quaternions  :)  :)  :)
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 16, 2017, 08:53:55 AM
Tonight I have been working in the implementation of a currency data type.

' CCur class
' CCUR is a wrapper for the CURRENCY data type. CURRENCY is implemented as an 8-byte
' two's-complement integer value scaled by 10,000. This gives a fixed-point number with
' 15 digits to the left of the decimal point and 4 digits to the right. The CURRENCY data
' type is extremely useful for calculations involving money, or for any fixed-point
' calculations where accuracy is important.
' The CCUR wrapper implements arithmetic, assignment, and comparison operations for this
' fixed-point type, and provides access to the numbers on either side of the decimal point
' in the form of two components: an integer component which stores the value to the left
' of the decimal point, and a fractional component which stores the value to the right of
' the decimal point. The fractional component is stored internally as an integer value
' between -9999 (CY_MIN_FRACTION) and +9999 (CY_MAX_FRACTION). The function GetFraction
' returns a value scaled by a factor of 10000 (CY_SCALE).
' When specifying the integer and fractional components of a CCUR object, remember that
' the fractional component is a number in the range 0 to 9999. This is important when
' dealing with a currency such as the US dollar that expresses amounts using only two
' significant digits after the decimal point. Even though the last two digits are not
' displayed, they must be taken into account.

const CY_MIN_INTEGER   = -922337203685477LL
const CY_MAX_INTEGER   = 922337203685477LL
const CY_MIN_FRACTION  = -9999
const CY_MAX_FRACTION  = 9999
const CY_SCALE         = 10000

Test code:

Code: [Select]
'#CONSOLE ON
#INCLUDE ONCE "Afx/CCur.inc"
using Afx

DIM c AS CCUR = 12345.1234
print c
c = c + 111.11
print c
c = c - 111.11
print c
c = c * 2
print c
c = c / 2
print c
c += 123
print c
c -= 123
print c
c *= 2.3
print c
c /= 2.3
print c
c = c ^ 2
print c
c = SQR(c)
print c
DIM c2 AS CCUR = c
print c2
DIM c3 AS CCUR = c * 2
print c3
DIM c4 AS CCUR = c3 / 2
print c4
DIM c5 AS CCUR = "1234.789"
print c5
DIM c6 AS CCUR
c6 = "77777.999"
print c6
DIM c7 AS CCUR
c7 = c6
print c7
DIM cl AS CCUR = 3
cl = LOG(cl)
print cl
DIM v AS VARIANT = cl
dim cv AS CCUR = v
print cv
print "--------------"
DIM cx AS CCUR
FOR i AS LONG = 1 TO 1000000
   cx += 0.0001
NEXT
PRINT "0.0001 added 1,000,000 times = "; cx

PRINT
PRINT "Press any key..."
SLEEP
Title: Re: CWindow Release Candidate 31
Post by: Petrus Vorster on September 16, 2017, 01:00:50 PM
Quote
lol, I consider myself a smart and educated guy, but I had to google quaternions  :)  :)  :)

O dear heavens. This is how i feel amongst you two....
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 16, 2017, 06:55:27 PM
The currency data type was one of the few things supported by PowerBasic missing in the framework. No more. PowerBasic also supports CURX, that uses two decimals instead of four, but this is not a standard data type, which limits is usefulness because it can't be used with COM or databases, unless you first convert it to currency, losing the advantage of having two additional integer digits.

Other useful data types to consider are BigInteger and Decimal.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 16, 2017, 09:50:53 PM
Modified the constructors that accept integer numeric values. They were setting the fractional part of the complex numbers instead of the integer part.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 18, 2017, 09:34:35 PM
The attached zip file contains three include files:

AfxGslComplex.inc

This was my original attempt, using code from the GNU Scientific Library.

AfxComplex.inc

Because GSL has a restrictive GPL license, I reworked the functions to use Microsoft .NET code, that has a more permissive MIT license.

CComplex.inc

This one provides compound dotted syntax. However, you must be aware that the compound syntax can confuse programmers only used to standard functions.

Using the flat API of AfxComplex.inc you can nest functions this way:

Code: [Select]
DIM cx AS CCOmplex = CComplex(-2, 1)
cx = Afx.CArcCosH(Afx.CCosH(Afx.CSin(cx))

It evaluates from right to left. That is, Afx.CSin(cx) is the first function executed.

Code: [Select]
temp <CComplex> = Afx.CSin(cx)
temp2 <CComplex> = Afx.CCosH(temp CComplex)
temp3 <CComplex> = Afx.CArcCosH(temp2 CComplex)
cx = temp3 CComplex

The temporary CComplex classes are created and destroyed by the compiler.

The compound dotted syntax evaluates the instructions from left to right.

Code: [Select]
DIM cx AS CComplex = CComplex(-2, 1)
cx = cx.CSinH.CCosH.CArcCosH

It is equivalent to:

Code: [Select]
temp <CComplex> = cx.CSin
temp2 <CComplex> temp.CCosH
temp3 <CComplex> temp2.CArcCosH
cx = temp3

They do the same calculation, but the syntax is different.

Also code like this, using the flat API...

Code: [Select]
DIM cx AS CComplex = CComplex(-2, 1)
DIM i AS CComplex = CComplex(0, 1)
cx = Afx.CArcSinH(cx / i))

becomes

Code: [Select]
DIM cx AS CComplex = CComplex(-2, 1)
DIM i AS CComplex = CComplex(0, 1)
cx = (cx / i).CArcSinH
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 19, 2017, 01:35:48 AM
CCUR class

Modified the operator that casts it to a string to always return four decimals.

Code: [Select]
' ========================================================================================
PRIVATE OPERATOR CCur.CAST () AS STRING
   DIM s AS STRING = STR(m_cur.int64 / CY_SCALE)
   DIM p AS LONG = INSTR(s, ".")
   DIM dec AS STRING
   IF p THEN
      dec = MID(s + "0000", p + 1, 4)
      s = LEFT(s, p) & dec
   END IF
   IF s = "0" THEN s = "0.0000"
   OPERATOR = s
END OPERATOR
' ========================================================================================

There is not need to implement ABS, FIX or INT because the FreeBasic ones can be used.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 19, 2017, 04:42:24 AM
CCUR

Added the ToVar method to return the currency value as a VT_CY variant.

This allows to assign a CCUR to a CVAR:

Code: [Select]
DIM c AS CCUR = 12345.1234
DIM cv AS CVAR = c.ToVar

Alternate way:

Code: [Select]
DIM v AS VARIANT = c
cv = v

AfcCOM.inc

Modified the AfxVarToStr function to support VT_CY variants.

Code: [Select]
      CASE VT_CY   ' // Currency
         DIM s AS STRING = STR(pvarIn->cyVal.int64 / 10000)
         DIM p AS LONG = INSTR(s, ".")
         DIM dec AS STRING
         IF p THEN
            dec = MID(s + "0000", p + 1, 4)
            s = LEFT(s, p) & dec
         END IF
         IF s = "0" THEN s = "0.0000"
         RETURN s
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 19, 2017, 04:45:32 AM
I have opened an account in GitHub where I'm uploading the changes.

See: https://github.com/JoseRoca/WinFBX
Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on September 19, 2017, 01:10:04 PM
I have opened an account in GitHub where I'm uploading the changes.

See: https://github.com/JoseRoca/WinFBX

Excellent! Are you using the GitHub Desktop client? You said it did not scale well with the high dpi.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 19, 2017, 01:51:49 PM
I have opened an account in GitHub where I'm uploading the changes.

See: https://github.com/JoseRoca/WinFBX

Excellent! Are you using the GitHub Desktop client? You said it did not scale well with the high dpi.


No. It is unusable at 192 dpi. It scales without any regard about the dimenensions of the monitor. It is like some programs that display a popup dialog that exceeds the height of the monitor when scaled and the OK and Cancel buttons became unreachable. This tool both exceeds the width and the height.

Using the web GUI I can do almost anything, except deleting a folder (maybe deleting all the files one by one will make the folder disapperar?).
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 20, 2017, 03:23:47 AM
I'm working in a new data type, DECIMAL.

Holds signed 128-bit (16-byte) values representing 96-bit (12-byte) integer numbers scaled by a variable power of 10. The scaling factor specifies the number of digits to the right of the decimal point; it ranges from 0 through 28. With a scale of 0 (no decimal places), the largest possible value is +/-79,228,162,514,264,337,593,543,950,335 (+/-7.9228162514264337593543950335E+28). With 28 decimal places, the largest value is +/-7.9228162514264337593543950335, and the smallest nonzero value is +/-0.0000000000000000000000000001 (+/-1E-28).

In my implementation, the scale is dynamic, dictated by the number of decimal places.

Code: [Select]
DIM dec AS CDEC = 12345.12
print dec
print "scale: ", dec.m_dec.scale  ' --> scale = 2
dec += dec + 11.1111
print dec
print "new scale: ", dec.m_dec.scale  ' --> scale = 4
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 20, 2017, 03:58:19 AM
As the bigger numeric variable supported by FreeBasic is a long integer, if we want to set bigger values we need to use strings, e.g.

Code: [Select]
DIM dec AS CDEC = "-79228162514264337593543950.335"
--or--
DIM dec AS CDEC = "-79,228,162,514,264,337,593,543,950.335"

By default, the locale user identifier is used. Therefore, in my Spanish computer I need to use "," as the decimal separator and "." as the thousands separator.

Code: [Select]
DIM dec AS CDEC = "-79.228.162.514.264.337.593.543.950,335"

But it can be overriden by passing an LCID value (1033 for US).

Code: [Select]
DIM dec AS CDEC = CDEC("-79,228,162,514,264,337,593,543,950.335", 1033)
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 20, 2017, 06:10:06 AM
It seems to be working fine. If anybody wants to try iy, download the attached file.

If you still need bigger numbers, there are open source big numbers libraries available, but CCUR and CDEC can be used to store currency (8 bytes) and decimal (16 bytes) in databases as true numeric types. not as strings.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 20, 2017, 08:23:41 AM
Two new collections: CStack and CQueue.

Because the framework has a safe array class, the implementation of these collections has been trivial. Two differences less with PowerBasic. As it uses variants, you can push/pop, queue/dequeue almost any kind of data.

It has also been useful to discover that the CSafeArray class had a little bug: After destroying the data it was locking the descriptor, making it impossible to add new elements.

The attached file contains the updated CSafeArray.inc file and CStack.inc.

Usage example:

Code: [Select]
'#CONSOLE ON
#INCLUDE ONCE "Afx/CStack.inc"
using Afx

DIM pStack AS CStack
pStack.Push "String 1"
pStack.Push "String 2"
DIM cv AS CVAR = pStack.Pop
print cv.ToStr
cv = pStack.Pop
print cv.ToStr
' --or--
'print pStack.Pop.ToStr
'print pStack.Pop.ToStr

print

DIM pQueue AS CQueue
pQueue.Enqueue "String 1"
pQueue.Enqueue 12345.12
print pQueue.Dequeue.ToStr
print pQueue.Dequeue.ToStr

PRINT
PRINT "Press any key..."
SLEEP
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 20, 2017, 08:51:26 AM
Source code of the stack classes:

Code: [Select]
' ########################################################################################
' Microsoft Windows
' File: CStack.inc
' Contents: Stack and Queue collections
' Compiler: FreeBasic 32 & 64-bit
' (c) 2017 by 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.
' ########################################################################################

#pragma once
#include once "Afx/CSafeArray.inc"
using Afx

NAMESPACE Afx

' ========================================================================================
' CStack class
' A Stack Collection is an ordered set of data items, which are accessed on a LIFO
' (Last-In / First-Out) basis. Each data item is passed and stored as a variant variable,
' using the Push and Pop methods.
' ========================================================================================
TYPE CStack

Private:
   DIM m_psa AS CSafeArray PTR

Public:
   DECLARE CONSTRUCTOR
   DECLARE DESTRUCTOR
   DECLARE FUNCTION Push (BYREF cvData AS CVAR) AS HRESULT
   DECLARE FUNCTION Pop () AS CVAR
   DECLARE FUNCTION Count () AS UINT
   DECLARE FUNCTION Clear () AS HRESULT

END TYPE
' ========================================================================================

' ========================================================================================
' CStack constructor
' ========================================================================================
PRIVATE CONSTRUCTOR CStack
   ' // Create a safe array of 0 elements and a lower bound of 1
   m_psa = NEW CSafeArray(VT_VARIANT, 0, 1)
END CONSTRUCTOR
' ========================================================================================

' ========================================================================================
' CStack destructor
' ========================================================================================
PRIVATE DESTRUCTOR CStack
   Delete m_psa
END DESTRUCTOR
' ========================================================================================

' ========================================================================================
' Appends a variant at the end of the array.
' ========================================================================================
PRIVATE FUNCTION CStack.Push (BYREF cvData AS CVAR) AS HRESULT
   RETURN m_psa->AppendElement(cvData)
END FUNCTION
' ========================================================================================

' ========================================================================================
' Gets and removes the last element of the array.
' ========================================================================================
PRIVATE FUNCTION CStack.Pop () AS CVAR
   DIM cv AS CVAR
   DIM nPos AS UINT = this.Count
   IF nPos = 0 THEN RETURN cv
   cv = m_psa->GetVar(nPos)
   m_psa->DeleteVariantElement(nPos)
   RETURN cv
END FUNCTION
' ========================================================================================

' ========================================================================================
' Returns the number of elements in the collection.
' ========================================================================================
PRIVATE FUNCTION CStack.Count () AS UINT
   RETURN m_psa->Count
END FUNCTION
' ========================================================================================

' ========================================================================================
' Removes all the elements in the collection.
' ========================================================================================
PRIVATE FUNCTION CStack.Clear () AS HRESULT
   RETURN m_psa->Reset
END FUNCTION
' ========================================================================================

' ========================================================================================
' CQueue class
' A Queue Collection is an ordered set of data items, which are accessed on a FIFO
' (First-In / First-Out) basis. Each data item is passed and stored as a variant variable,
' using the Enqueue and Dequeue methods.
' ========================================================================================
TYPE CQueue

Private:
   DIM m_psa AS CSafeArray PTR

Public:
   DECLARE CONSTRUCTOR
   DECLARE DESTRUCTOR
   DECLARE FUNCTION Enqueue (BYREF cvData AS CVAR) AS HRESULT
   DECLARE FUNCTION Dequeue () AS CVAR
   DECLARE FUNCTION Count () AS UINT
   DECLARE FUNCTION Clear () AS HRESULT

END TYPE
' ========================================================================================

' ========================================================================================
' CQueue constructor
' ========================================================================================
PRIVATE CONSTRUCTOR CQueue
   ' // Create a safe array of 0 elements and a lower bound of 1
   m_psa = NEW CSafeArray(VT_VARIANT, 0, 1)
END CONSTRUCTOR
' ========================================================================================

' ========================================================================================
' CQueue destructor
' ========================================================================================
PRIVATE DESTRUCTOR CQueue
   Delete m_psa
END DESTRUCTOR
' ========================================================================================

' ========================================================================================
' Appends a variant at the end of the array.
' ========================================================================================
PRIVATE FUNCTION CQueue.Enqueue (BYREF cvData AS CVAR) AS HRESULT
   RETURN m_psa->AppendElement(cvData)
END FUNCTION
' ========================================================================================

' ========================================================================================
' Gets and removes the first element of the array.
' ========================================================================================
PRIVATE FUNCTION CQueue.Dequeue () AS CVAR
   DIM cv AS CVAR
   IF this.Count = 0 THEN RETURN cv
   cv = m_psa->GetVar(1)
   m_psa->DeleteVariantElement(1)
   RETURN cv
END FUNCTION
' ========================================================================================

' ========================================================================================
' Returns the number of elements in the collection.
' ========================================================================================
PRIVATE FUNCTION CQueue.Count () AS UINT
   RETURN m_psa->Count
END FUNCTION
' ========================================================================================

' ========================================================================================
' Removes all the elements in the collection.
' ========================================================================================
PRIVATE FUNCTION CQueue.Clear () AS HRESULT
   RETURN m_psa->Reset
END FUNCTION
' ========================================================================================

END NAMESPACE

Just displaying it so everybody can see how trivial it is (the hard stuff is in the CSafeArray class).
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 20, 2017, 12:24:10 PM
I finally have managed to be able of print a CVAR directly, without having to use cv.ToStr.

I have added a private CWSTR variabe that will be alive during the life of the CVAR class and overwritten by the following method:

Code: [Select]
' =====================================================================================
PRIVATE OPERATOR CVar.CAST () BYREF AS WSTRING
   CWSTR_DP("CWSTR CAST BYREF AS WSTRING")
   cws = AfxVarToStr(@vd)
   OPERATOR = *cast(WSTRING PTR, cws.m_pBuffer)
END OPERATOR
' ========================================================================================

that returns a reference to it.

So with the updated CVAR.INC file, we can now do

Code: [Select]
'#CONSOLE ON
#INCLUDE ONCE "Afx/CStack.inc"
using Afx

DIM pStack AS CStack
pStack.Push "String 1"
pStack.Push "String 2"
DIM cv AS CVAR = pStack.Pop
print cv
cv = pStack.Pop
print cv
' --or--
'print pStack.Pop
'print pStack.Pop

print

DIM pQueue AS CQueue
pQueue.Enqueue "String 1"
pQueue.Enqueue 12345.12
print pQueue.Dequeue
print pQueue.Dequeue

PRINT
PRINT "Press any key..."
SLEEP

Seems like last night I have been really inspired: A decimal data type, two collections (Stack and Queue), and now this workaround that I have been searching for a year.
Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on September 20, 2017, 12:50:16 PM
That's awesome news Jose! You are being extremely productive. On the other hand, I have not because I bought a new place last week and now this week I'm getting my house ready for sale. Damn, real life getting in the way of programming.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 20, 2017, 01:15:49 PM
Hope you will be happy in your new house.

I'm happier with the CVAR workaround that with the new classes because I have the need to print the contents of a variant everyday, and each time that I had to add .ToStr I said to myself that I had to find a solution. And, finally, today I have find the inspiration after trying other three workarounds that didn't work. And the solution is the simpler one!

Now I have to remove all these .ToStr from the documentation :)

Title: Re: CWindow Release Candidate 31
Post by: Johan Klassen on September 20, 2017, 02:57:40 PM
hello Jose Roca
I know you are aware of the many bignum libraries but just in case you missed this there's a free lib by Alexander Valyalkin at https://github.com/valyala/big_int, license is freeware
also available is libtomath at http://www.libtom.net licensed under WTFPL license.
my apologies if am stating something you already knew.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 20, 2017, 03:28:25 PM
Thanks for the links, but I have no plans to write a big numbers class. This is why I have said that if anyone has use for them, there are plenty of free libraries available. I have implemented currency and decimal because they are useful general purpose data types. Math is a field in which I have very little knowledge and expertise.
Title: Re: CWindow Release Candidate 31
Post by: Andrew Lindsay on September 20, 2017, 08:23:49 PM
Jose,
Your framework grows better and better each day.  I'm only using such a tiny bit of what you've written, but I am ever thankful for what you've done.

Andrew
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 21, 2017, 08:17:33 AM
Quote
I'm happier with the CVAR workaround that with the new classes because I have the need to print the contents of a variant everyday, and each time that I had to add .ToStr I said to myself that I had to find a solution. And, finally, today I have find the inspiration after trying other three workarounds that didn't work. And the solution is the simpler one!

This workaround is very important because it is going to allow me to make the use of the new data types more integrated with the language.

For example, until now we could do

Code: [Select]
DIM cv1 AS CVAR = "String 1"
DIM cv2 AS CVAR = "String 2"
print cv2 + " " + cv2

but we could not do

Code: [Select]
DIM cv1 AS CVAR = "String 1"
DIM cv2 AS CVAR = "String 2"
print cv2 & " " & cv2

that gave a type mismatch error.

But now I can overload the & operator

Code: [Select]
' ========================================================================================
' Concatenates two CVARs.
' ========================================================================================
PRIVATE OPERATOR & (BYREF cv1 AS CVAR, BYREF cv2 AS CVAR) AS CVAR
   RETURN cv1 + cv2
END OPERATOR
' ========================================================================================

and use

Code: [Select]
print cv2 & " " & cv2

wihout problems.

and even

Code: [Select]
print cv1 & " " & STR(2) & " " & cv2 & " test " & 1 & " test " & 2
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 21, 2017, 10:39:54 AM
And using another workaround, I can get the intrinsic functions LEFT, RIGHT and VAL work with CVARs (MID as never been a problem and does not need a workaround):

Code: [Select]
' // Must be outside a namespace because they are global

' ========================================================================================
PRIVATE FUNCTION Left OVERLOAD (BYREF cv AS CVAR, BYVAL nChars AS INTEGER) AS CWSTR
   DIM cws AS CWSTR = cv.wstr
   RETURN LEFT(**cws, nChars)
END FUNCTION
' ========================================================================================
' ========================================================================================
PRIVATE FUNCTION Right OVERLOAD (BYREF cv AS CVAR, BYVAL nChars AS INTEGER) AS CWSTR
   DIM cws AS CWSTR = cv.wstr
   RETURN RIGHT(**cws, nChars)
END FUNCTION
' ========================================================================================
' ========================================================================================
PRIVATE FUNCTION Val OVERLOAD (BYREF cv AS CVAR) AS DOUBLE
   DIM cws AS CWSTR = cv.wstr
   RETURN VAL(**cws)
END FUNCTION
' ========================================================================================

Code: [Select]
'#CONSOLE ON
#define _CVAR_DEBUG_ 1
#INCLUDE ONCE "Afx/CVar.inc"
using Afx

DIM cv AS CVAR = "12345.67"
print Left(cv, 3)
print Right(cv, 3)
print Mid(cv, 3, 2)
print Val(cv)
print Asc(cv, 3)


PRINT
PRINT "Press any key..."
SLEEP

It works even if the contents are numeric because the casting converts the CVAR to a WSTRING.

Code: [Select]
'#CONSOLE ON
#define _CVAR_DEBUG_ 1
#INCLUDE ONCE "Afx/CVar.inc"
using Afx

DIM cv AS CVAR = 12345.67
print Left(cv, 3)
print Right(cv, 3)
print Mid(cv, 3, 2)
print Val(cv)
print Asc(cv, 3)

PRINT
PRINT "Press any key..."
SLEEP
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 21, 2017, 05:29:19 PM
I'm going to improve the new data types.

CVAR (Variants)

Besides Left, Right and Val, I have added Round and the following operators: &, &=, +, +=, -, -=, *, *=, /, /=, \, \=, =, <>, <, >, <=, >=, - (negate), Not, And, Or, Xor, Mod, Imp, Eqv, ^, Abs, Fix, Int.

Math functions can be used if you use val, eg. DIM cv AS CVAR = 10 : PRINT (Log(Val(cv)), Val is needed because the CVAR is cast as a WSTRING. It is not possible to cast it also as a DOUBLE because it will confuse the & operator (the problem with this operator is that it accepts to concatenate strings and numbers without using STR(number)). Anyway, it is unliquely that you will use variants for math operations other than the ones already supported.

CWSTR/CBSTR (dynamic unicode strings)

I will add &, Left, Right and Val to avoid the need to use **, although ** will remain supported and will always be faster than the other options, specially with big strings.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 22, 2017, 06:46:17 PM
This is my attempt to implement COM smart pointers.

Code: [Select]
'#CONSOLE ON
#INCLUDE ONCE "Afx/AfxCom.inc"
#INCLUDE ONCE "Afx/AfxSapi.bi"
using Afx

' ========================================================================================
' _CComPtr macro
' ========================================================================================
#macro _CComPtr(T)
#ifndef CComPtr##T
TYPE CComPtr##T
Private:
   DIM m_pUnk AS T PTR
   m_bUninitCOM AS BOOLEAN
Public:
   DECLARE CONSTRUCTOR
   DECLARE CONSTRUCTOR (BYVAL pUnk AS T PTR, BYVAL fAddRef AS BOOLEAN = FALSE)
   DECLARE DESTRUCTOR
   DECLARE OPERATOR CAST () AS T PTR
   DECLARE OPERATOR LET (BYVAL pUnk AS T PTR)
   DECLARE FUNCTION vtbl () AS T PTR
   DECLARE FUNCTION vptr () AS T PTR
END TYPE
' ========================================================================================
' ========================================================================================
CONSTRUCTOR CComPtr##T
   ' // Initialize the COM library
   DIM hr AS HRESULT = CoInitialize(NULL)
   IF hr = S_OK OR hr = S_FALSE THEN m_bUninitCOM = TRUE
END CONSTRUCTOR
' ========================================================================================
' ========================================================================================
' // The first time that is called, pUnk receives a NULL (?), the 2nd time, works!
CONSTRUCTOR CComPtr##T (BYVAL pUnk AS T PTR, BYVAL fAddRef AS BOOLEAN = FALSE)
   ' // Initialize the COM library
   DIM hr AS HRESULT = CoInitialize(NULL)
   IF hr = S_OK OR hr = S_FALSE THEN m_bUninitCOM = TRUE
   ' // Assign the passed pointer
   m_pUnk = pUnk
   ' // Increase the reference count if requested
   IF fAddRef THEN AfxSafeAddRef(m_pUnk)
END CONSTRUCTOR
' ========================================================================================
' ========================================================================================
DESTRUCTOR CComPtr##T
   ' // Release the interface pointer
   AfxSafeRelease(m_pUnk)
   ' // Uninitialize the COM library
   IF m_bUninitCOM THEN CoUninitialize
END DESTRUCTOR
' ========================================================================================
' ========================================================================================
PRIVATE OPERATOR CComPtr##T.CAST () AS T PTR
   ' // Return an addrefed interface pointer
   AfxSafeAddRef(m_pUnk)
   OPERATOR = m_pUnk
END OPERATOR
' ========================================================================================
' ========================================================================================
PRIVATE OPERATOR CComPtr##T.LET (BYVAL pUnk AS T PTR)
   ' // Release the interface pointer
   AfxSafeRelease(m_pUnk)
   ' // Assign the passed reference counted interface pointer
   m_pUnk= pUnk
END OPERATOR
' ========================================================================================
' ========================================================================================
PRIVATE FUNCTION CComPtr##T.vtbl () AS T PTR
   ' // Return the stored interface pointer
   RETURN m_pUnk
END FUNCTION
' ========================================================================================
' ========================================================================================
PRIVATE FUNCTION CComPtr##T.vptr () AS T PTR
   ' // Release the interface pointer
   AfxSafeRelease(m_pUnk)
   ' // Return the address of the interface pointer
   RETURN @m_pUnk
END FUNCTION
' ========================================================================================
#endif
#endmacro

' // The COM library must be initialized to call AfxNewCom
CoInitialize NULL

' // Define the _CComPtrAfx_ISpVoice class
_CComPtr(Afx_ISpVoice)

' // Create an instance of the _CComPtrAfx_ISpVoice class
' // and assign an instance of the Afx_ISpVoice interface to it
DIM pSpVoice AS CComPtrAfx_ISpVoice = AfxNewCom("SAPI.SpVoice")

' // Call the Speak method
'DIM cwsText AS CWSTR = "Hello World"
'pSpVoice.vtbl->Speak(cwsText, 0, NULL)
pSpVoice.vtbl->Speak("Hello World", 0, NULL)

' // Uninitialize the COM library
CoUninitialize

PRINT
PRINT "Press any key..."
SLEEP
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 22, 2017, 06:56:05 PM
Another way is to use an instance of the CComPtr class (in AfxCom.inc) to assign the pointer and let it the task of release it when it goes out of scope.

Code: [Select]
'#CONSOLE ON
#INCLUDE ONCE "Afx/AfxCom.inc"
#INCLUDE ONCE "Afx/AfxSapi.bi"
using Afx

' // The COM library must be initialized to call AfxNewCom
CoInitialize NULL

' // Create an instance of the Afx_ISpVoice interface
DIM pSpVoice AS Afx_ISpVoice PTR = AfxNewCom("SAPI.SpVoice")
DIM pCComPtrSpVoice AS CComPtr = pSpVoice

' // Call the Speak method
pSpVoice->Speak("Hello World", 0, NULL)

' // Uninitialize the COM library
CoUninitialize

PRINT
PRINT "Press any key..."
SLEEP

If FreeBasic had support for templates like C++, we could do:

Code: [Select]
DIM pSpVoice AS CComptr<Afx_ISpVoice> = AfxNewCom("SAPI.SpVoice")
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 22, 2017, 07:08:23 PM
This is another way to use CComPtr, but casting is annoying:

Code: [Select]
'#CONSOLE ON
#INCLUDE ONCE "Afx/AfxCom.inc"
#INCLUDE ONCE "Afx/AfxSapi.bi"
using Afx

' // The COM library must be initialized to call AfxNewCom
CoInitialize NULL

' // Create an instance of the Afx_ISpVoice interface
DIM pSpVoice AS CComPtr = AfxNewCom("SAPI.SpVoice")
' // Call the Speak method
cast(Afx_ISpVoice PTR, *pSpVoice)->Speak("Hello World", 0, NULL)

' // Uninitialize the COM library
CoUninitialize

PRINT
PRINT "Press any key..."
SLEEP
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 22, 2017, 10:26:25 PM
Added &, Left, Right and Val to CWSTR and CBSTR.
Added _CComPtr macro to AfxCom.inc.

Last updates can always be found at https://github.com/JoseRoca/WinFBX


Reuploaded because I had forget to add using Afx before the new global operators.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 24, 2017, 04:26:40 PM
String conversion functions

The string conversion functions available in FreeBasic are not fully suitable for some languages.

For example, the Turkish word "karışıklığı" is uppercased as "KARıŞıKLıĞı" instead of "KARIŞIKLIĞI", and "KARIŞIKLIĞI" is lowercased to "karişikliği" instead of "karışıklığı". Notice the "ı", that is not an "i".

The following functions use the API function LCMapStringEx to properly convert it.

Code: [Select]
' ========================================================================================
' - pwszStr [in]:
'      The string to convert. Cannot have a size of 0.
' - pwszLocaleName [in, optional]:
'      Pointer to a locale name or one of these pre-defined values:
'         LOCALE_NAME_INVARIANT
'         LOCALE_NAME_SYSTEM_DEFAULT
'         LOCALE_NAME_USER_DEFAULT
'      For a table of language culture names see:
'         https://msdn.microsoft.com/es-es/library/ee825488(v=cs.20).aspx
' - dwMapFlags [in, optional]:
'      Flag specifying the type of transformation to use during string mapping or the type
'      of sort key to generate. This parameter can have the following values
'      For a complete list see:
'      https://msdn.microsoft.com/en-us/library/windows/desktop/dd318702(v=vs.85).aspx
' Return value:
'   The uppercased string.
' ========================================================================================
PRIVATE FUNCTION AfxStrUCase (BYVAL pwszStr AS WSTRING PTR, _
   BYVAL pwszLocaleName AS WSTRING PTR = LOCALE_NAME_USER_DEFAULT, _
   BYVAL dwMapFlags AS DWORD = 0) AS CWSTR

   ' // Check the vailidy of the passed parameters
   IF pwszStr = NULL THEN RETURN ""
   IF LEN(*pwszStr) = 0 THEN RETURN ""
   DIM cwsOut AS CWSTR = *pwszStr
   ' // Make sure that LCMAP_LOWERCASE is not being used
   dwMapFlags = dwMapFlags AND (NOT LCMAP_LOWERCASE)
   ' // Make sure that LCMAP_LINGUISTIC_CASING OR LCMAP_UPPERCASE is being used
   dwMapFlags OR= LCMAP_LINGUISTIC_CASING OR LCMAP_UPPERCASE
   ' // Ususally, the length of the converted string will be the same that the one of
   ' // the input string, so let's try it
   DIM cbLen AS LONG = LCMapStringEx(pwszLocaleName, dwMapFlags, pwszStr, LEN(*pwszStr), _
       cwsOut.vptr, LEN(cwsOut), NULL, NULL, 0)
   ' // If the output length is bigger than the input one, request the needed length,
   ' // mke the buffer bigger and try it again
   IF cbLen = 0 AND GetLastError = ERROR_INSUFFICIENT_BUFFER THEN
      cbLen = LCMapStringEx(pwszLocaleName, dwMapFlags, pwszStr, LEN(*pwszStr), NULL, 0, NULL, NULL, 0)
      IF cbLen THEN
         cwsOut += SPACE(cbLen)
         cbLen = LCMapStringEx(pwszLocaleName, dwMapFlags, pwszStr, LEN(*pwszStr), _
                 cwsOut.vptr, LEN(cwsOut), NULL, NULL, 0)
      END IF
   END IF
   RETURN cwsOut

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

' ========================================================================================
' - pwszStr [in]:
'      The string to convert. Cannot have a size of 0.
' - pwszLocaleName [in, optional]:
'      Pointer to a locale name or one of these pre-defined values:
'         LOCALE_NAME_INVARIANT
'         LOCALE_NAME_SYSTEM_DEFAULT
'         LOCALE_NAME_USER_DEFAULT
'      For a table of language culture names see:
'         https://msdn.microsoft.com/es-es/library/ee825488(v=cs.20).aspx
' - dwMapFlags [in, optional]:
'      Flag specifying the type of transformation to use during string mapping or the type
'      of sort key to generate. This parameter can have the following values
'      For a complete list see:
'      https://msdn.microsoft.com/en-us/library/windows/desktop/dd318702(v=vs.85).aspx
' Return value:
'   The lowercased string.
' ========================================================================================
PRIVATE FUNCTION AfxStrLCase (BYVAL pwszStr AS WSTRING PTR, _
   BYVAL pwszLocaleName AS WSTRING PTR = LOCALE_NAME_USER_DEFAULT, _
   BYVAL dwMapFlags AS DWORD = 0) AS CWSTR

   ' // Check the vailidy of the passed parameters
   IF pwszStr = NULL THEN RETURN ""
   IF LEN(*pwszStr) = 0 THEN RETURN ""
   DIM cwsOut AS CWSTR = *pwszStr
   ' // Make sure that LCMAP_UPPERCASE is not being used
   dwMapFlags = dwMapFlags AND (NOT LCMAP_UPPERCASE)
   ' // Make sure that LCMAP_LINGUISTIC_CASING OR LCMAP_LOWERCASE is being used
   dwMapFlags OR= LCMAP_LINGUISTIC_CASING OR LCMAP_LOWERCASE
   ' // Ususally, the length of the converted string will be the same that the one of
   ' // the input string, so let's try it
   DIM cbLen AS LONG = LCMapStringEx(pwszLocaleName, dwMapFlags, pwszStr, LEN(*pwszStr), _
       cwsOut.vptr, LEN(cwsOut), NULL, NULL, 0)
   ' // If the output length is bigger than the input one, request the needed length,
   ' // mke the buffer bigger and try it again
   IF cbLen = 0 AND GetLastError = ERROR_INSUFFICIENT_BUFFER THEN
      cbLen = LCMapStringEx(pwszLocaleName, dwMapFlags, pwszStr, LEN(*pwszStr), NULL, 0, NULL, NULL, 0)
      IF cbLen THEN
         cwsOut += SPACE(cbLen)
         cbLen = LCMapStringEx(pwszLocaleName, dwMapFlags, pwszStr, LEN(*pwszStr), _
                 cwsOut.vptr, LEN(cwsOut), NULL, NULL, 0)
      END IF
   END IF
   RETURN cwsOut

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


Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 25, 2017, 03:55:41 AM
Although we can't write variadic functions with FreeBasic 64 bit (we can with 32 bit only), we can call external variadic functions written in C, e.g.

Code: [Select]
DIM wszOut AS WSTRING * 260
DIM wszFmt AS WSTRING * 260 = "%s %d + %d = %d."
DIM wszText AS WSTRING * 260 = "The answer is"
DIM hr AS HRESULT = StringCbPrintfW(@wszOut, SIZEOF(wszOut), @wszFmt, @wszText, 1, 2, 3)
print wszOut

Output: "The answer is 1 + 2 = 3."

StringCbPrintf function:
https://msdn.microsoft.com/en-us/library/windows/desktop/ms647510(v=vs.85).aspx

StringCbPrintf is a replacement for the following functions:

sprintf, swprintf, _stprintf
wsprintf
wnsprintf
_snprintf, _snwprintf, _sntprintf

StringCbPrintf_l (A/W) is similar to StringCbPrintf but includes a parameter for locale information.

StringCbPrintfEx (A/W) adds to the functionality of StringCbPrintf by returning a pointer to the end of the destination string as well as the number of bytes left unused in that string. Flags may also be passed to the function for additional control.

StringCbPrintf_lEx (A/W) is similar to StringCbPrintfEx but includes a parameter for locale information.

They can be very useful to do string formatting.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 25, 2017, 05:07:12 AM
Another function that can be used is StrSpn, that returns the length of the initial portion of a string which consists only of characters that are part of a specified set of characters.

Code: [Select]
'#CONSOLE ON
#define _WIN32_WINNT &h0602
#INCLUDE ONCE "windows.bi"
#INCLUDE ONCE "win/shlwapi.bi"
#INCLUDE ONCE "/crt/stdio.bi"

DIM wszText AS WSTRING * 260 = "129th"
DIM wszSet AS WSTRING * 260 = "1234567890"
DIM n AS LONG = StrSpnW(@wszText, @wszSet)
printf(!"The initial number has %d digits.\n", n)
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 25, 2017, 01:41:43 PM
@Paul,

While adding new string functions and modifying several ones to make them work faster, I have noticed that there was a bug in AfxStrDelete and AfxStrInsert.

Code: [Select]
' ========================================================================================
' * Deletes a specified number of characters from a string expression.
' Returns a string based on wszMainStr but with nCount characters deleted
' starting at position nStart. The first character in the string is position 1, etc.
' Usage example:
' DIM cws AS CWSTR = AfxStrDelete("1234567890", 4, 3)
' ========================================================================================
PRIVATE FUNCTION AfxStrDelete (BYREF wszMainStr AS WSTRING, BYVAL nStart AS LONG, BYVAL nCount AS LONG) AS CWSTR
   DIM cws AS CWSTR = wszMainStr
   DIM nLen AS LONG = LEN(wszMainStr)
   IF nLen = 0 OR nStart < 0 OR nCount <= 0 OR nStart > nLen THEN RETURN cws
'   cws = LEFT(wszMainStr, nStart) + MID(wszMainStr, nStart + 1 + nCount, nCount)   ' // wrong calculation
   cws.DelChars nStart, nCount
   RETURN cws
END FUNCTION
' ========================================================================================

Code: [Select]
' ========================================================================================
' * Inserts a string at a specified position within another string expression.
' Returns a string consisting of wszMainStr with the string wszInsertString inserted
' at nPosition. If nPosition is greater than the length of wszMainStr or <= zero then
' wszInsertString is appended to wszMainStr. The first character in the string is position 1, etc.
' DIM cws AS CWSTR = AfxStrInsert("1234567890", "--", 6)
' ========================================================================================
PRIVATE FUNCTION AfxStrInsert (BYREF wszMainStr AS WSTRING, BYREF wszInsertString AS WSTRING, BYVAL nPosition AS LONG) AS CWSTR
   DIM cws AS CWSTR = wszMainStr
'   IF nPosition > LEN(wszMainStr) OR nPosition <= 0 THEN
'      cws += wszInsertString
'   ELSE
'      cws = MID(wszMainStr, 1, nPosition) + wszInsertString + MID(wszMainStr, nPosition + 1)
'   END IF
   IF nPosition <= 0 THEN RETURN CWS
   IF nPosition > LEN(wszMainStr) THEN
      cws += wszInsertString
   ELSEIF nPosition = 1 THEN
      cws = wszInsertString + MID(wszMainStr, 1)
   ELSE
      cws = MID(wszMainStr, 1, nPosition - 1) + wszInsertString + MID(wszMainStr, nPosition)
   END IF
   RETURN cws
END FUNCTION
' ========================================================================================

AfxStrDelete was removing the correct characters, but in some cases the remaining of the string after the characters deleted were lost.

In the WinFBE editor you're using this function in modCompile.inc.

Code: [Select]
   ' Search main source code for any user embedded compile directives. These will override
   ' anything that was set at the default or project level.
   dim directives as COMPILE_DIRECTIVES
   pDocMain->CompileDirectives(@directives)
   select case directives.ConsoleFlag
      case IDM_CONSOLE
         i = instr(gCompile.CompileFlags, " -S GUI ")
         if i THEN gCompile.CompileFlags = AfxStrDelete(gCompile.CompileFlags, i, 8)
         gCompile.CompileFlags = gCompile.CompileFlags + " " + wstr(" -s console ")
      case IDM_GUI
         i = instr(gCompile.CompileFlags, " -S CONSOLE ")
         if i THEN gCompile.CompileFlags = AfxStrDelete(gCompile.CompileFlags, i, 12)
         gCompile.CompileFlags = gCompile.CompileFlags + " " + wstr(" -s gui ")
   END select

Please check if all works fine after replacing the old AfxStr.inc with the new one.

Regarding AfxStrInsert, it was inserting the string at a wrong  position (one character more than it should).
Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on September 25, 2017, 06:28:52 PM
Hi Jose, thanks for letting me know. I will add your # of lines in file request as well as recompile with the new Afx functions. I will post a new release this evening.
Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on September 25, 2017, 07:17:28 PM
I downloaded your latest code from GitHub (RC31) but when I use those files the resulting compiled WinFBE will hang almost immediately when attempting to open a project. Opening individual files seems to be okay. I do not have time tonight to track down the exact source of the problem but I am wondering if it might be related to the changes you made to the CWSTR class. I should hopefully be able to give you a much better bug report ASAP.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 26, 2017, 04:50:49 AM
There was a bug in StrReplace, causing an endless loop.

Also, in

File: frmFindInFiles.inc
function DoFindInFilesEx() as LONG

You need to change

   wszResults = wstr(AfxGetExePathName & "\_search.txt")

to:
   wszResults = AfxGetExePathName & "_search.txt"

and

   wszBatchFile = wstr(AfxGetExePathName & "\_search.bat")

to:

   wszBatchFile = AfxGetExePathName & "_search.bat"

Not only WSTR isn't needed, but because of the addition of the & operator, AfxGetExePathName & "\_search.txt" return an ANY PTR pointer and WSTR complains. The problem with FreeBasic & operator is that it allows to concatenate numbers with strings without using STR(number), and when it finds a void pointer does not know what to do with it (wstr(AfxGetExePathName + "\_search.bat") works). Guess that this silly beahavior comes from Visual Basic.


Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 26, 2017, 04:54:24 AM
BTW sometimes you're forgetting that AfxGetExePathName returns a trailing "\", like with PowerBasic and unlike FB's Exepath. Fortunately, Windows seems to accept double backslashes.

Code: [Select]
File: clsconfig.inc

Function clsConfig.LoadKeywords() as Long
   If Open( AfxGetExePathName & "\Settings\freebasic_keywords.txt" For Input As #f) = 0 Then
should be changed to:
   If Open( AfxGetExePathName & "Settings\freebasic_keywords.txt" For Input As #f) = 0 Then

Function clsConfig.SaveKeywords() As Long
   If Open( AfxGetExePathName & "\Settings\freebasic_keywords.txt" For Output As #f) = 0 Then
should be changed to:
   If Open( AfxGetExePathName & "Settings\freebasic_keywords.txt" For Output As #f) = 0 Then

File: frmTemplates.inc
Function frmTemplates_Show (ByVal hParent As HWnd, ByVal x As Long, ByVal y As Long) As Long
   wszPath = AfxGetExePathName & "\Templates\"
should be changed to:
   wszPath = AfxGetExePathName & "Templates\"

File: modMenus.inc

Function CreateScintillaContextMenu() As HMENU
      ElseIf AfxFileExists(AfxGetExePathName & sFilename) Then
         gApp.IncludeFilename = AfxGetExePathName & "\" & sFilename
should be changed to:
      ElseIf AfxFileExists(AfxGetExePathName & sFilename) Then
         gApp.IncludeFilename = AfxGetExePathName & sFilename


File: modRoutines.inc

File: modTopMenu.inc

Function CreateScintillaContextMenu() As HMENU

      ElseIf AfxFileExists(AfxGetExePathName & "\" & sFilename) Then
         gpApp->IncludeFilename = AfxGetExePathName & sFilename
should be changed to:
      ElseIf AfxFileExists(AfxGetExePathName sFilename) Then
         gpApp->IncludeFilename = AfxGetExePathName & sFilename

WinFBE

Function WinMain
   wszLocalizationFile = AfxGetExePathName + wstr("\Languages\") + gConfig.LocalizationFile
should be changed to:
   wszLocalizationFile = AfxGetExePathName + wstr("Languages\") + gConfig.LocalizationFile

   gConfig.LoadCodetips( AfxGetExePathName & "\Settings\codetips.ini" )
should be changed to:
   gConfig.LoadCodetips( AfxGetExePathName & "Settings\codetips.ini" )

gConfig.LoadCodetipsWinAPI( AfxGetExePathName & "\Settings\codetips_winapi.ini" )
should be changed to:
gConfig.LoadCodetipsWinAPI( AfxGetExePathName & "Settings\codetips_winapi.ini" )
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 26, 2017, 07:59:11 AM
I have added AfxGetExePath to AfxWin. Call it if you want to get a path without backslash and AfxGetExeName otherwise. There is an additional function, AfxGetExeFullPath, that returns the full path, including the file name.

Code: [Select]
' ========================================================================================
' Returns the path of the program which is currently executing.
' The path name has not a trailing backslash, except if it is a drive, e.g. "C:\".
' ========================================================================================
PRIVATE FUNCTION AfxGetExePath () AS CWSTR
   DIM buffer AS WSTRING * MAX_PATH, p AS LONG
   GetModuleFileNameW NULL, buffer, SIZEOF(buffer)
   p = INSTRREV(buffer, ANY ":/\")
   IF p THEN buffer = AfxPathRemoveBackslash(LEFT(buffer, p))
   RETURN buffer
END FUNCTION
' ========================================================================================
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 26, 2017, 05:08:13 PM
CWSTR.inc

Removed an accidental double declaration of a LET operator. It was causing an ambiguous call error when trying to assign to a CBSTR variable the result of a function that returned another CBSTR.

Code: [Select]
DECLARE OPERATOR LET (BYREF cbs AS CBStr)
DECLARE OPERATOR LET (BYREF cbs AS CBSTR_)
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 26, 2017, 05:53:36 PM
We already have got an extensive set of string manipulation functions, but there are many cases for which regular expressions are better suited.

For example,

Code: [Select]
DIM cbsText AS CBSTR = "World, worldx, world, worldy, hello world"
print AfxStrReplaceI(cbsText, cbsText, "earth")

Outputs "earth, earthx, earth, earthy, hello earth"

but what if we only want to replace only whole words?

Code: [Select]
DIM pRegExp AS CRegExp
DIM cbsText AS CBSTR = "World, worldx, world, worldy, hello world"
print pRegExp.ReplaceStr(cbsText, $"\bworld\b", "earth", TRUE)

Outputs "earth, worldx, earth, worldy, hello earth"

Code: [Select]
PRINT pRegExp.ReplaceStr("Hello World", "World", "Earth")
Outputs "Hello Earth", same as AfxStrReplace("Hello World", "World", "Earth")

Code: [Select]
PRINT pRegExp.ReplaceStr(pRegExp.ReplaceStr("abacadabra", "[bac]", "*")
Outputs "*****d**r*", same as AfxStrReplaceAny("abacadabra", "bac", "*")

Code: [Select]
PRINT pRegExp.ReplaceStr("555-123-4567", "(\d{3})-(\d{3})-(\d{4})", "($1) $2-$3")
Outputs "(555) 123-4567"

Code: [Select]
PRINT pRegExp.ReplaceStr("Squires, Paul", "(\S+), (\S+)", "$2 $1")
Outputs "Paul Squires"

Code: [Select]
PRINT pRegExp.ReplaceStr("0000.34500044", $"\b0{1,}\.", ".")
Outputs ".34500044"

Almost everything can be done, if you find the right pattern.

Although the Microsoft regular expressions object is not as complete as other libraries, the advantage is that is pre-installed in all versions of Windows and works with 32 and 64 bit. Open source libraries are a nightmare if you aren't an skilled C programmer: No windows binaries available or only available for old versions, import libraries, some are 32-bit only, etc.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 26, 2017, 06:01:34 PM
We can also do the same to delete substrings, e.g.

Code: [Select]
DIM pRegExp AS CRegExp
DIM cbsText AS CBSTR = "World, worldx, world, worldy, hello world"
print pRegExp.RemoveStr(cbsText, $"\bworld\b", TRUE)

Outputs: ", worldx, , worldy, hello"

And also do complex searchs.

Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 26, 2017, 06:43:57 PM
This one extracts text

Code: [Select]
DIM pRegExp AS CRegExp
DIM cbsText AS CBSTR = "anything textToExtract anything"
pRegExp.Pattern = "anything (.*) anything"
print pRegExp.Execute(cbsText)
IF pRegExp.SubMatchesCount(0) THEN print pRegExp.SubMatchValue(0, 0)
' Outputs textToExtract

If there are several matches, we will use a loop.

Code: [Select]
DIM pRegExp AS CRegExp
DIM cbsText AS CBSTR = "anything textToExtract anything TextToExtract anything"
DIm cbsPattern AS CBSTR = $"\btextToExtract\b"
pRegExp.Execute(cbsText, cbsPattern, TRUE)
FOR i AS LONG = 0 TO pRegExp.MatchesCount
   print pRegExp.MatchValue(i)
NEXT
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 27, 2017, 09:26:36 AM
We can search for more than a word at the same time.

Code: [Select]
'#CONSOLE ON
#define UNICODE
#INCLUDE ONCE "Afx/CRegExp.inc"
using Afx

DIM pRegExp AS CRegExp
DIM cbsText AS CBSTR = "The contests will be in January, July and November"
DIm cbsPattern AS CBSTR = $"\b(january|february|march|april|may|june|july|" & _
    $"august|september|october|november|december)\b"
PRINT pRegExp.Execute(cbsText, cbsPattern, TRUE)
For i AS LONG = 0 TO pRegExp.MatchesCount - 1
   print pRegExp.MatchValue(i)
NEXT

PRINT
PRINT "Press any key..."
SLEEP

Output:
January
July
November
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 27, 2017, 09:36:31 PM
Code: [Select]
'#CONSOLE ON
#define UNICODE
#INCLUDE ONCE "Afx/CRegExp.inc"
#include once "afx/cwstr.inc"
using Afx

' // Case insensitive, double search (c.t and d.g), whole words
' // Retrieves cat, dog, but not cats, dogs
DIM pRegExp AS CRegExp
DIM cbsText AS CBSTR = "I have a cat and a dog, because I love cats and dogs"
DIM cbsPattern AS CBSTR = $"\bC.T\b|\bD.G\b"
pRegExp.Execute(cbsText, cbsPattern, TRUE)
FOR i AS LONG = 0 TO pRegExp.MatchesCount - 1
   print pRegExp.MatchValue(i)
NEXT

PRINT
PRINT "Press any key..."
SLEEP


Code: [Select]
'#CONSOLE ON
#define UNICODE
#INCLUDE ONCE "Afx/CRegExp.inc"
#include once "afx/cwstr.inc"
using Afx

' // Case insensitive, double search (c.t and d.g), whole words
' // Retrieves cut, cat, i.e. whole words with three letters that begin
' // with c and end with t.
' // With this constructor we set the pattern, ignore case and global
DIM pRegExp AS CRegExp = CRegExp($"\bC.T\b|\bD.G\b", TRUE, TRUE)
pRegExp.Execute("I have cut a cat tail")
FOR i AS LONG = 0 TO pRegExp.MatchesCount - 1
   print pRegExp.MatchValue(i)
NEXT

PRINT
PRINT "Press any key..."
SLEEP
Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on September 27, 2017, 09:41:15 PM
In all my years of programming I've only used regular expressions a handful of times. It is so powerful that I regret not using it more often. Your example makes it look so easy.... maybe because it is.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 28, 2017, 02:36:09 AM
It is not difficult, but it is verbose when used with FreeBasic. This is why I have wrapped it in a class, to hide the verbosity inside the methods. The only difficulty is to find the appropriate pattern, because if you don't use it often, each time you have to reread the table of metacharacters. But it s always much less work that having to write code to perform an specific task. Now we have string functions to perform the most common tasks and regular expressions. Imagine writing code to extract a word that begins with a letter, followed by 3 numbers. With the CRegExp class you just have to do pRegExp.Extract(cbsText, "[a-z][0-9][0-9][0-9]"), and if you want to do another kind of extraction, you just have to change the pattern. And if you want to do it ignoring case, you just have to pass TRUE in the bIgnoreCase parameter. They can be used to parse, extract and validate data.

I have renamed the function InStr as FindEx and added two overloaded Find functions and two overloaded Extract functions.

Code: [Select]
' ========================================================================================
' Find function with VBScript regular expressions search patterns.
' Parameters:
' - cbsSourceString = The text to be parsed.
' - cbsPattern = The pattern to match.
' - bIgnoreCase = Ignore case.
' Return value:
' - Returns the position of the match or 0 if not found.
'   The length of the match can be retrieved calling pRegExp.MatchLen.
' Usage example:
'   DIM pRegExp AS CRegExp
'   DIM cbsText AS CBSTR = "blah blah a234 blah blah x345 blah blah"
'   DIM cbsPattern AS CBSTR = "[a-z][0-9][0-9][0-9]"
'   DIM nPos AS LONG = pRegExp.Find(cbsText, cbsPattern)
' ========================================================================================
PRIVATE FUNCTION CRegExp.Find (BYREF cbsSourceString AS CBSTR, BYREF cbsPattern AS CBSTR, BYVAL bIgnoreCase AS BOOLEAN = FALSE) AS LONG
   IF m_pRegExp = NULL THEN this.SetResult(E_POINTER): RETURN 0
   IF m_pMatches THEN AfxSafeRelease(m_pMatches)
   m_pRegExp->put_IgnoreCase(bIgnoreCase)
   m_pRegExp->put_Global(FALSE)
   m_pRegExp->put_Multiline(FALSE)
   m_pRegExp->put_Pattern(cbsPattern)
   this.SetResult(m_pRegExp->Execute(cbsSourceString, cast(Afx_IDispatch PTR PTR, @m_pMatches)))
   RETURN this.MatchPos(0)
END FUNCTION
' ========================================================================================

' ========================================================================================
' Find function with VBScript regular expressions search patterns.
' Parameters:
' - nStart: The position in the string at which the search will begin. The first character
'   starts at position 1.
' - cbsSourceString = The text to be parsed.
' - cbsPattern = The pattern to match.
' - bIgnoreCase = Ignore case.
' Return value:
' - Returns the position of the match or 0 if not found.
'   The length of the match can be retrieved calling pRegExp.MatchLen.
' Usage example:
'   DIM pRegExp AS CRegExp
'   DIM cbsText AS CBSTR = "blah blah a234 blah blah x345 blah blah"
'   DIM cbsPattern AS CBSTR = "[a-z][0-9][0-9][0-9]"
'   DIM nPos AS LONG = pRegExp.Find(15, cbsText, cbsPattern)
' ========================================================================================
PRIVATE FUNCTION CRegExp.Find (BYVAL nStart AS LONG, BYREF cbsSourceString AS CBSTR, BYREF cbsPattern AS CBSTR, BYVAL bIgnoreCase AS BOOLEAN = FALSE) AS LONG
   IF m_pRegExp = NULL THEN this.SetResult(E_POINTER): RETURN 0
   IF m_pMatches THEN AfxSafeRelease(m_pMatches)
   m_pRegExp->put_IgnoreCase(bIgnoreCase)
   m_pRegExp->put_Global(FALSE)
   m_pRegExp->put_Multiline(FALSE)
   m_pRegExp->put_Pattern(cbsPattern)
   DIM pbstr AS BSTR
   IF nStart < 0 OR nStart > SysStringLen(cbsSourceString.m_bstr) THEN RETURN 0
   DIM cbs AS CBSTR = cbsSourceString.MidChars(nStart)
   this.SetResult(m_pRegExp->Execute(cbs, cast(Afx_IDispatch PTR PTR, @m_pMatches)))
   RETURN this.MatchPos(0) + nStart - 1
END FUNCTION
' ========================================================================================

' ========================================================================================
' Global, multiline find function with VBScript regular expressions search patterns.
' Parameters:
' - cbsSourceString = The text to be parsed.
' - cbsPattern = The pattern to match.
' - bIgnoreCase = Ignore case.
' - bGlobal : FALSE = Return only the first match; TRUE = return all matches.
' - bMultiline : TRUE = Match at the start and the end of multiple lines separated by line breaks.
' Return value:
' - Returns a list of comma separated "index, length" value pairs. The pairs are separated
'   by a semicolon.
' Usage Example:
'   DIM pRegExp AS CRegExp
'   DIM cbsText AS CBSTR = "blah blah a234 blah blah x345 blah blah"
'   DIM cbsPattern AS CBSTR = "[a-z][0-9][0-9][0-9]"
'   DIM cbsOut AS CBSTR
'   cbsOut = pRegExp.FindAll(cbsText, cbsPattern)
' ========================================================================================
PRIVATE FUNCTION CRegExp.FindAll (BYREF cbsSourceString AS CBSTR, BYREF cbsPattern AS CBSTR, _
   BYVAL bIgnoreCase AS BOOLEAN = FALSE, BYVAL bGlobal AS BOOLEAN = TRUE, BYVAL bMultiline AS BOOLEAN = TRUE) AS CBSTR

   IF m_pRegExp = NULL THEN this.SetResult(E_POINTER): RETURN ""
   m_pRegExp->put_IgnoreCase(bIgnoreCase)
   m_pRegExp->put_Global(bGlobal)
   m_pRegExp->put_Multiline(bMultiline)
   m_pRegExp->put_Pattern(cbsPattern)

   DIM cbsOut AS CBSTR, pMatches AS Afx_IMatchCollection2 PTR
   this.SetResult(m_pRegExp->Execute(cbsSourceString, cast(Afx_IDispatch PTR PTR, @pMatches)))
   IF pMatches THEN
      DIM nCount AS LONG
      pMatches->get_Count(@nCount)
      FOR i AS LONG = 0 TO nCount - 1
         DIM pMatch AS Afx_IMatch2 PTR
         this.SetResult(pMatches->get_Item(i, cast(Afx_IDispatch PTR PTR, @pMatch)))
         IF pMatch THEN
            DIM nFirstIndex AS LONG
            pMatch->get_FirstIndex(@nFirstIndex)
            DIM nLen AS LONG
            pMatch->get_Length(@nLen)
            IF i < nCount - 1 THEN
               cbsOut += STR(nFirstIndex + 1) & "," & STR(nLen) & ";"
            ELSE
               cbsOut += STR(nFirstIndex + 1) & "," & STR(nLen)
            END IF
            AfxSafeRelease(pMatch)
         END IF
      NEXT
      AfxSafeRelease(pMatches)
   END IF
   RETURN cbsOut

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

' ========================================================================================
' Extracts a substring using VBScript regular expressions search patterns.
' Parameters:
' - cbsSourceString = The text to be parsed.
' - cbsPattern = The pattern to match.
' - bIgnoreCase = Ignore case.
' Return value:
' - Returns the retrieved string on exit or an empty string on failure.
' Usage example:
'   DIM pRegExp AS CRegExp
'   DIM cbsText AS CBSTR = "blah blah a234 blah blah x345 blah blah"
'   DIM cbsPattern AS CBSTR = "[a-z][0-9][0-9][0-9]"
'   DIM cbs AS CBSTR = pRegExp.Extract(cbsText, cbsPattern)
' ========================================================================================
PRIVATE FUNCTION CRegExp.ExtractStr (BYREF cbsSourceString AS CBSTR, BYREF cbsPattern AS CBSTR, BYVAL bIgnoreCase AS BOOLEAN = FALSE) AS CBSTR
   IF m_pRegExp = NULL THEN this.SetResult(E_POINTER): RETURN 0
   IF m_pMatches THEN AfxSafeRelease(m_pMatches)
   m_pRegExp->put_IgnoreCase(bIgnoreCase)
   m_pRegExp->put_Global(FALSE)
   m_pRegExp->put_Multiline(FALSE)
   m_pRegExp->put_Pattern(cbsPattern)
   this.SetResult(m_pRegExp->Execute(cbsSourceString, cast(Afx_IDispatch PTR PTR, @m_pMatches)))
   DIM nPos AS LONG = this.MatchPos(0)
   DIM nLen AS LONG = this.MatchLen(0)
   DIM cbs AS CBSTR = MID(cbsSourceString, nPos, nLen)
   RETURN cbs
END FUNCTION
' ========================================================================================

' ========================================================================================
' Extracts a substring using VBScript regular expressions search patterns.
' Parameters:
' - nStart: The position in the string at which the search will begin. The first character
'   starts at position 1.
' - cbsSourceString = The text to be parsed.
' - cbsPattern = The pattern to match.
' - bIgnoreCase = Ignore case.
' Return value:
' - Returns the position of the match or 0 if not found.
'   The length can be retrieves calling pRegExp.MatchLen.
' Usage example:
'   DIM pRegExp AS CRegExp
'   DIM cbsText AS CBSTR = "blah blah a234 blah blah x345 blah blah"
'   DIM cbsPattern AS CBSTR = "[a-z][0-9][0-9][0-9]"
'   DIM nPos AS LONG = pRegExp.Extract(15, cbsText, cbsPattern)
' ========================================================================================
PRIVATE FUNCTION CRegExp.ExtractStr (BYVAL nStart AS LONG, BYREF cbsSourceString AS CBSTR, BYREF cbsPattern AS CBSTR, BYVAL bIgnoreCase AS BOOLEAN = FALSE) AS CBSTR
   IF m_pRegExp = NULL THEN this.SetResult(E_POINTER): RETURN 0
   IF m_pMatches THEN AfxSafeRelease(m_pMatches)
   m_pRegExp->put_IgnoreCase(bIgnoreCase)
   m_pRegExp->put_Global(FALSE)
   m_pRegExp->put_Multiline(FALSE)
   m_pRegExp->put_Pattern(cbsPattern)
   DIM pbstr AS BSTR
   IF nStart < 0 OR nStart > SysStringLen(cbsSourceString.m_bstr) THEN RETURN 0
   DIM cbs AS CBSTR = cbsSourceString.MidChars(nStart)
   this.SetResult(m_pRegExp->Execute(cbs, cast(Afx_IDispatch PTR PTR, @m_pMatches)))
   DIM nPos AS LONG = this.MatchPos(0)
   DIM nLen AS LONG = this.MatchLen(0)
   RETURN MID(cbsSourceString, nPos + nStart - 1, nLen)
END FUNCTION
' ========================================================================================

Remark: If you google to find patterns, make sure that they are for VbScript, because other implementations can use different metacharacters or have additional features.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 28, 2017, 05:05:37 AM
Some more (the main purpose is to test the class to make changes if needed):

Code: [Select]
' // Adds an space after the dots that are immediately followed by a word
DIM pRegExp AS CRegExp
DIM cbsText AS CBSTR = "This is a text.With some dots.Between words. This one not."
DIM cbsPattern AS CBSTR = "(\.)(\w)"
DIM cbs AS CBSTR = pRegExp.ReplaceStr(cbsText, cbsPattern, "$1 $2")
print cbs

Code: [Select]
' // Replaces an occurrence of two consecutive identical words in a string of text
' // with a single occurrence of the same word
DIM pRegExp AS CRegExp
DIM cbsText AS CBSTR = "Is is the cost of of gasoline going up up?."
DIM cbsPattern AS CBSTR = $"\b([a-z]+) \1\b"
DIM cbs AS CBSTR = pRegExp.ReplaceStr(cbsText, cbsPattern, "$1")
print cbs

Code: [Select]
' // Breaks down a URI down to the protocol (ftp, http, and so on), the domain
' // address, and the page/path
DIM pRegExp AS CRegExp
DIM cbsText AS CBSTR = "http://msdn.microsoft.com:80/scripting/default.htm"
DIM cbsPattern AS CBSTR = $"(\w+):\/\/([^/:]+)(:\d*)?([^# ]*)"
pRegExp.Execute(cbsText, cbsPattern)
FOR i AS LONG = 0 TO pRegExp.SubMatchesCount - 1
   print pRegExp.SubMatchValue(0, i)
NEXT
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 28, 2017, 02:44:04 PM
As the main difficulty is to get the right pattern (it is impossible to remember something like "(\w+):\/\/([^/:]+)(:\d*)?([^# ]*)" ), it would be a good idea to collect "recipes" and include them in the documentation.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 28, 2017, 04:09:05 PM
For example,

Code: [Select]
' // Finding variations on words (John, Jon, Jonathan)
DIM pRegExp AS CRegExp
DIM cbsText AS CBSTR = "Hello, my name is John Doe, what's your name?"
DIM cbsPattern AS CBSTR = $"\bJoh?n(athan)? Doe\b"
pRegExp.Execute(cbsText, cbsPattern)
IF pRegExp.MatchesCount THEN print pRegExp.MatchValue

Recipe taken from the book "Regular Expression Recipes for Windows Developers: A Problem-Solution Approach by Nathan Good

This expression works by finding the common and optional parts of a word and searching based on them. John, Jon, Jonathan are all similar. They start by Jo and have an n in them. The rest is the h in John or the athan ending in Jonathan:

\b a word boundary...
J followed by
o then...
h that is...
? optional, followed by...
n followed by...
(...) a group of characters...
Note: In the example, this group of characters is athan, which will let the
expression match Jonathan. It may or may not appear as a whole part, so that's
why is grouped win parentheses and followed by ?
? that may appear once but isn't required, followed by
<space> a space, followed by...
D then...
o and finally...
e and e, then...
\b another word boundary
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 28, 2017, 04:32:59 PM
Another "recipe": Finding similar words.

Code: [Select]
' // Finding similar words
DIM pRegExp AS CRegExp
DIM cbsText AS CBSTR = "My cat found a dead bat over the mat"
DIM cbsPattern AS CBSTR = $"\b[bcm]at\b"
pRegExp.Execute(cbsText, cbsPattern)
FOR i AS LONG = 0 TO pRegExp.MatchesCount - 1
   print pRegExp.MatchValue(i)
NEXT

\b a word boundary
[bcm] one of b, c, or m, followed by...
a then...
t and finally...
\b a word boundary

As an alternative, we can use the operator "|":

Code: [Select]
DIM cbsPattern AS CBSTR = $"\b(b|c|m)at\b"
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 29, 2017, 07:19:40 PM
Check if a string is numeric

Code: [Select]
#define UNICODE
#INCLUDE ONCE "Afx/CRegExp.inc"
USING Afx

DIM pRegExp AS CRegExp
DIM cbsText AS CBSTR = "1.2345678901234567e+029"
DIM cbsPattern AS CBSTR = "^[\+\-]?\d*\.?\d+(?:[Ee][\+\-]?\d+)?$"
PRINT pRegExp.Test(cbsText, cbsPattern)

Output:
True

Pattern: "^[\+\-]?\d*\.?\d+(?:[Ee][\+\-]?\d+)?$"

The initial "^" and the final "$" match the start and the end of the string, to ensure the check spans the whole string.
The "[\+\-]?" part is the initial plus or minus sign with the "?" multiplier that allows zero or one instance of it.
The "\d*" is a digit, zero or more times.
"\.?" is the decimal point, zero or one time.
The "\d+" part matches a digit one or more times.
The "(?:[Ee][\+\-]?\d+)?" matches "e+", "e-", "E+" or "E-" followed by one or more digits, with the "?" multiplier that allows zero or one instance of it.
Title: Re: CWindow Release Candidate 31
Post by: James Fuller on September 30, 2017, 07:48:49 AM
Jose,
  Fantastic stuff as always!
How about a complete package update on the first thread post or a new Candidate (32)

Are you now using  fbc  1.06 for all your testing?

James
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 30, 2017, 02:46:49 PM
You can find the latest updated code here:

https://github.com/JoseRoca/WinFBX

I plan to use GitHub to keep the code always updated.

> Are you now using  fbc  1.06 for all your testing?

Yes, mainly to catch the use of suffixes. We were so used to suffixes with PB, that it is too easy to use HEX$ instead of HEX, SPACE$ instead of SPACE, etc.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on September 30, 2017, 09:22:56 PM
I have added some overloaded methods to allow compound syntax.

Now, besides

Code: [Select]
DIM cbsPattern AS CBSTR = "[a-z][0-9][0-9][0-9]"
DIM cbsText AS CBSTR = "blah blah a234 blah blah x345 blah blah"
DIM pRegExp AS CRegExp
print pRegExp.Extract(cbsPattern, cbsText)

you can also do

Code: [Select]
DIM cbsPattern AS CBSTR = "[a-z][0-9][0-9][0-9]"
DIM cbsText AS CBSTR = "blah blah a234 blah blah x345 blah blah"
print CRegExp(cbsPattern).Extract(cbsText)

Code: [Select]
' // Ignore case
DIM cbsPattern AS CBSTR = "[a-z][0-9][0-9][0-9]"
DIM cbsText AS CBSTR = "blah blah A234 blah blah x345 blah blah"
print CRegExp(cbsPattern).Extract(cbsText, TRUE)

Code: [Select]
DIM cbsText AS CBSTR = "anything textToExtract anything TextToExtract anything"
DIM cbsPattern AS CBSTR = $"\btextToExtract\b"
DIM pRegExp AS CRegExp = CRegExp(cbsPattern).Execute(cbsText, TRUE)
FOR i AS LONG = 0 TO pRegExp.MatchesCount
   print pRegExp.MatchValue(i)
NEXT
Title: Re: CWindow Release Candidate 31
Post by: José Roca on October 02, 2017, 07:55:28 PM
Finally I have figured how to set the focus in a document (usually an html page) hosted in an instance of the CWebBrowser class.

Code: [Select]
' ========================================================================================
' Sets the focus in the hosted document.
' Return value:
' - S_OK if successful, or an error value otherwise.
' ========================================================================================
PRIVATE FUNCTION CWebBrowser.SetFocus () AS HRESULT
   IF m_pWebBrowser = NULL THEN RETURN E_POINTER
   DIM pIHTMLDocument2 AS IHTMLDocument2 PTR
   m_pWebBrowser->get_Document(@cast(ANY PTR, pIHTMLDocument2))
   IF pIHTMLDocument2 = NULL THEN RETURN E_NOINTERFACE
   DIM pWindow2 AS IHTMLWindow2 PTR
   pIHTMLDocument2->lpvtbl->get_parentWindow(pIHTMLDocument2, @pWindow2)
   AfxSafeRelease(pIHTMLDocument2)
   IF pWindow2 = NULL THEN RETURN E_NOINTERFACE
   pWindow2->lpvtbl->focus(pWindow2)
   AfxSafeRelease(pWindow2)
END FUNCTION
' ========================================================================================

This is something that has elluded me during years and today I have had an inspiration :)

Now we can use WebGL in an instance of the WebBrowser control embedded in our application being responsive to the key presses.

Code: [Select]
   ' // Add a WebBrowser control
   DIM pwb AS CWebBrowser = CWebBrowser(@pWindow, IDC_WEBBROWSER, 0, 0, pWindow.ClientWidth, pWindow.ClientHeight)
   ' // Set the IDocHostUIHandler interface
   pwb.SetUIHandler

   ' // Navigate to the path
   DIM wszPath AS WSTRING * MAX_PATH = ExePath & "\index.html"
   pwb.Navigate(wszPath)
   ' // Processes pending Windows messages to allow the page to load
   ' // Needed if the message pump isn't running
   AfxPumpMessages
   ' // Set the focus in the hosted html page
   pwb.SetFocus

   ' // Note: Instead of pWindow.DoeEvents, we need to use a custom message pump
   ' // to be able to forward the keyboard messages to the WebBrowser control.
   ' // Otherwise, the web page will not respond to them.

   ' // Display the window
   ShowWindow(hWndMain, nCmdShow)
   UpdateWindow(hWndMain)

   ' // Dispatch Windows messages
   DIM uMsg AS MSG
   WHILE (GetMessageW(@uMsg, NULL, 0, 0) <> FALSE)
      IF AfxForwardMessage(GetFocus, @uMsg) = FALSE THEN
         IF IsDialogMessageW(hWndMain, @uMsg) = 0 THEN
            TranslateMessage(@uMsg)
            DispatchMessageW(@uMsg)
         END IF
      END IF
   WEND
   FUNCTION = uMsg.wParam

Title: Re: CWindow Release Candidate 31
Post by: José Roca on October 02, 2017, 10:37:09 PM
Updated the download file in the first post with all the changes discussed in this thread.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on October 04, 2017, 12:20:02 PM
Updated again.

CVAR and CDispInvoke classes modified.
- The change to allow to print CVARs directly did break the CDispInvoke class.

AfxStr.inc
- Added functions to encode/decode base 64.

Modified CGdiPlus.inc and CADODB.inc to remove a couple of suffixes (FB 1.06 doesn't allow suffixes anymore).

- Added new methods to CDispInvoke to allow an easier syntax. e.g.

Code: [Select]
'#CONSOLE ON
#define UNICODE
#include once "Afx/CDispInvoke.inc"
USING Afx

' // Create an instance of the RegExp object
DIM pDisp AS CDispInvoke = "VBScript.RegExp"
' // To check for success, see if the value returned by the DispPtr method is not null
IF pDisp.DispPtr = NULL THEN END

' // Set some properties
' // Use VARIANT_TRUE or CTRUE, not TRUE, because Free Basic TRUE is a BOOLEAN data type, not a LONG
pDisp.Put("Pattern", ".is")
pDisp.Put("IgnoreCase", VARIANT_TRUE)
pDisp.Put("Global", VARIANT_TRUE)

' // Execute a search
DIM pMatches AS CDispInvoke = pDisp.Invoke("Execute", "IS1 is2 IS3 is4")
' // Parse the collection of matches
IF pMatches.DispPtr THEN
   ' // Get the number of matches
   DIM nCount AS LONG = VAL(pMatches.Get("Count"))
   FOR i AS LONG = 0 TO nCount -1
      ' // Get a pointer to the Match object
      DIM pMatch AS CDIspInvoke = pMatches.Get("Item", i)
      IF pMatch.DispPtr THEN
         ' // Get the value of the match
         print pMatch.Get("Value")
      END IF
   NEXT
END IF

PRINT
PRINT "Press any key..."
SLEEP

Title: Re: CWindow Release Candidate 31
Post by: José Roca on October 08, 2017, 05:31:24 AM
I have adapted the COleDateTime and ColeDateTimeSpan classes to FreeBasic.

Reference:
ColeDateTime: https://msdn.microsoft.com/en-us/library/38wh24td.aspx
ColeDateTimeSpan: https://msdn.microsoft.com/en-us/library/xb7yw6f3.aspx

Usage example:

Code: [Select]
'#CONSOLE ON
#define UNICODE
#include once "Afx/COleDateTime.inc"
USING Afx

' // Create an instance of the COleDateTime class
DIM cdt AS COleDateTime = ColeDateTime(2017, 10, 8, 12, 5, 30)   ' // 8 October 2017, 12 hour, 5 minute, and 30 second
print cdt.GetYear, cdt.GetMonth, cdt.GetDay, cdt.GetHour, cdt.GetMinute, cdt.GetSecond
print cdt.GetDayOfWeek, cdt.GetDayOfYear
print cdt.Format

' // Add a time span
DIM ts AS COleDateTimeSpan = COleDateTimeSpan(3, 1, 5, 12)   ' // 3 days, 1 hour, 5 min, and 12 sec
cdt += ts
print cdt.GetDayOfWeek, cdt.GetDayOfYear

' // Display the date
print cdt.Format
print cdt.Format("%A, %B %d, %Y")
   
PRINT
PRINT "Press any key..."
SLEEP
Title: Re: CWindow Release Candidate 31
Post by: José Roca on October 09, 2017, 11:19:13 AM
Because the time64 C functions aren't available in msvcrt.dll, wich is limited to 32 bits, limiting the handling of dates from midnight, January 1, 1970, to 23:59:59 January 18, 2038, UTC, I have developed the following replacements:

Code: [Select]
' ========================================================================================
' * Converts a __time64_t (LONGLONG) value to a FILETIME structure.
' ========================================================================================
PRIVATE FUNCTION AfxTime64ToFileTime (BYVAL t64 AS LONGLONG) AS FILETIME
   DIM ft AS FILETIME, uli AS ULARGE_INTEGER
   uli.QuadPart = t64 * 10000000
   ' 10000000 = ticks per second
   ft.dwLowDateTime = uli.LowPart
   ft.dwHighDateTime = uli.HighPart
   RETURN ft
END FUNCTION
' ========================================================================================

' ========================================================================================
' * Converts a FILETIME to a __time64_t (LONGLONG) value.
' ========================================================================================
PRIVATE FUNCTION AfxFileTimeToTime64 (BYREF ft AS FILETIME) AS LONGLONG
   DIM uli AS ULARGE_INTEGER
   uli.LowPart = ft.dwLowDateTime
   uli.HighPart = ft.dwHighDateTime
   DIM t64 AS LONGLONG = uli.QuadPart / 10000000
   ' 10000000 = ticks per second
   RETURN t64
END FUNCTION
' ========================================================================================

' ========================================================================================
' * Converts a system time to a __time64_t.
' ========================================================================================
PRIVATE FUNCTION AfxSystemTimeToTime64 (BYREF st AS SYSTEMTIME) AS LONGLONG
   DIM ft AS FILETIME
   SystemTimeToFileTime(@st, @ft)
   DIM t64 AS LONGLONG = AfxFileTimeToTime64(ft) - 11644473600
   ' 11644473600 = number of days from 1 Jan 1970
   RETURN t64
END FUNCTION
' ========================================================================================

' ========================================================================================
' * Converts a __time64_t (LONGLONG) to a system time.
' ========================================================================================
PRIVATE FUNCTION AfxTime64ToSystemTime (BYVAL t64 AS LONGLONG) AS SYSTEMTIME
   DIM ft AS FILETIME
   t64 += 11644473600
   ft = AfxTime64ToFileTime(t64)
   DIM st AS SYSTEMTIME
   FileTimeToSystemTime(@ft, @st)
   RETURN st
END FUNCTION
' ========================================================================================

' ========================================================================================
' * Converts a __time64_t (LONGLONG) to a GMT time.
' t64 : A __time64_t (LONGLONG) value.  The time is represented as seconds elapsed since
' midnight (00:00:00), January 1, 1970, coordinated universal time (UTC).
' Returns a tm structure. The fields of the returned structure hold the evaluated value of
' the time argument in UTC rather than in local time.
' Note: Replacement for _gmtime64, not available in msvcrt.dll.
' The fields of the structure type tm store the following values, each of which is an int:
' tm_sec : Seconds after minute (0 – 59).
' tm_min : Minutes after hour (0 – 59).
' tm_hour : Hours after midnight (0 – 23).
' tm_mday : Day of month (1 – 31).
' tm_mon : Month (0 – 11; January = 0).
' tm_year : Year (current year minus 1900).
' tm_wday : Day of week (0 – 6; Sunday = 0).
' tm_yday : Day of year (0 – 365; January 1 = 0).
' tm_isdst : Positive value if daylight saving time is in effect; 0 if daylight saving
' time is not in effect; negative value if status of daylight saving time is unknown.
' ========================================================================================
PRIVATE FUNCTION AfxGmtTime64 (BYVAL t64 AS LONGLONG) AS tm
   DIM st AS SYSTEMTIME
   st = AfxTime64ToSystemTime(t64)
   DIM _tm AS tm
   _tm.tm_wday = st.wDayOfWeek
   _tm.tm_min = st.wMinute
   _tm.tm_sec = st.wSecond
   _tm.tm_mon = st.wMonth - 1
   _tm.tm_mday = st.wDay
   _tm.tm_hour = st.wHour
   _tm.tm_year = st.wYear - 1900
   DIM stYear AS SYSTEMTIME
   DIM t64Year AS LONGLONG
   stYear.wYear = st.wYear
   stYear.wMonth = 1
   stYear.wDay = 1
   t64Year = AfxSystemTimeToTime64(stYear)
   _tm.tm_yday = (t64 - t64Year) / 60*60*24   ' 60*60*24 = day in seconds
   _tm.tm_isdst = 0
   RETURN _tm
END FUNCTION
' ========================================================================================

' ========================================================================================
' * Returns a UTC time as a local time.
' Convert a time value and correct for the local time zone.
' Note: Replacement for _localtime64, not available in msvcrt.dll.
' The fields of the structure type tm store the following values, each of which is an int:
' tm_sec : Seconds after minute (0 – 59).
' tm_min : Minutes after hour (0 – 59).
' tm_hour : Hours after midnight (0 – 23).
' tm_mday : Day of month (1 – 31).
' tm_mon : Month (0 – 11; January = 0).
' tm_year : Year (current year minus 1900).
' tm_wday : Day of week (0 – 6; Sunday = 0).
' tm_yday : Day of year (0 – 365; January 1 = 0).
' tm_isdst : Positive value if daylight saving time is in effect; 0 if daylight saving
' time is not in effect; negative value if status of daylight saving time is unknown.
' ========================================================================================
PRIVATE FUNCTION AfxGetLocalTime64 (BYVAL t64 AS LONGLONG) AS tm
   DIM AS FILETIME ft, ftLocal
   ft = AfxTime64ToFileTime(t64)
   FileTimeToLocalFiletime(@ft, @ftLocal)
   t64 = AfxFileTimeToTime64(ftLocal)
   DIM _tm AS tm = AfxGmtTime64(t64)
   DIM tzi AS TIME_ZONE_INFORMATION
   SELECT CASE GetTimeZoneInformation(@tzi)
      CASE TIME_ZONE_ID_DAYLIGHT : _tm.tm_isdst = 1
      CASE TIME_ZONE_ID_STANDARD : _tm.tm_isdst = 0
      CASE TIME_ZONE_ID_UNKNOWN  : _tm.tm_isdst = -1
   END SELECT
   RETURN _tm
END FUNCTION
' ========================================================================================

' ========================================================================================
' * Converts the local time to a calendar value.
' Note: Replacemenet for _mktime64, not available in msvcrt.dll.
' ========================================================================================
PRIVATE FUNCTION AfxMakeTime64 (BYREF _tm AS tm) AS LONGLONG
   
   ' // Fills a SYSTEMTIME structure
   DIM st AS SYSTEMTIME
   st.wDay = _tm.tm_mday
   st.wDayOfWeek = _tm.tm_wday
   st.wHour = _tm.tm_hour
   st.wMinute = _tm.tm_min
   st.wMonth = _tm.tm_mon + 1
   st.wSecond = _tm.tm_sec
   st.wYear = _tm.tm_year + 1900
   st.wMilliseconds = 0
  ' // Daylight savings
   DIM tzi AS TIME_ZONE_INFORMATION
   DIM r AS DWORD = GetTimeZoneInformation(@tzi)
   IF r <> TIME_ZONE_ID_INVALID THEN
      DIM stOut AS SYSTEMTIME
      IF _tm.tm_isdst = 1 THEN
         ' // Converts a local time to a time in Coordinated Universal Time (UTC).
         IF TzSpecificLocalTimeToSystemTime(@tzi, @st, @stOut) THEN st = stOut
      END IF
   END IF
   DIM t64 AS LONGLONG = AfxSystemTimeToTime64(st)
   IF _tm.tm_isdst = 0 THEN
      DIM ft AS FILETIME = AfxTime64ToFileTime(t64)
      DIM ft2 AS FILETIME
      ' // Converts a local file time to a file time based on the Coordinated Universal Time (UTC).
      LocalFileTimeToFileTime(@ft, @ft2)
      t64 = AfxFileTimeToTime64(ft2)
   END IF
   RETURN t64
END FUNCTION
' ========================================================================================

' ========================================================================================
' * Returns the system time as a __time64_t (LONGLONG) value.
' Returns the time as seconds elapsed since midnight, January 1, 1970.
' Note: Replacement for _time64, not available in msvcrt.dll.
' ========================================================================================
PRIVATE FUNCTION AfxTime64 () AS LONGLONG
   DIM t64 AS LONGLONG
   DIM st AS SYSTEMTIME
   GetSystemTime(@st)
   RETURN AfxSystemTimeToTime64(st)
END FUNCTION
' ========================================================================================
Title: Re: CWindow Release Candidate 31
Post by: José Roca on October 10, 2017, 12:08:00 PM
This update includes new wrappers in AfxTime.inc as well as new classes: CTime64, CTimeSpan, COleDateTime, COleDateTimeSpan, CFileTime and CFileTimeSpan.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on October 11, 2017, 01:08:49 PM
I finally have found the bug that caused problems with the OpenGL support. I was using a wrong variable, m_hDC instead of hDC. Now OpenGL support works very well.

I did check the failing code dozens of times, and until now I have been unable to find that subtle bug. I could not understand why the same code (less the bug) was working with PowerBasic and failed with FreeBasic.
Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on October 11, 2017, 08:17:07 PM
Thanks Jose! Awesome work as always. I haven't done a line of code in over two weeks! Real life is just too busy. I will jump back into it as soon as possible.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on October 12, 2017, 04:26:11 PM
Yet another class, CIniFile, to easily work with .ini files.
13 October 2017: Modified the constructor.

Code: [Select]
' ########################################################################################
' Microsoft Windows
' File: CIniFile.inc
' Contents: Class to work with Windows .ini files
' Compiler: FreeBasic 32 & 64-bit
' Copyright (c) 2017 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.
' ########################################################################################

#pragma once
#include once "windows.bi"
#include once "crt/stdio.bi"
#include once "Afx/CSafeArray.inc"
#include once "Afx/CDicObj.inc"
USING Afx

NAMESPACE Afx

' ########################################################################################
' CIniFile class.
' ########################################################################################
TYPE CIniFile

   m_Path AS WSTRING * MAX_PATH   ' // Full path of the .ini file

   DECLARE CONSTRUCTOR (BYREF wszFileName AS WSTRING)
   DECLARE DESTRUCTOR
   DECLARE FUNCTION GetPath () AS CWSTR
   DECLARE FUNCTION WriteValue (BYREF wszSectionName AS WSTRING, BYREF wszKeyName AS WSTRING, BYREF wszValue AS WSTRING) AS BOOLEAN
   DECLARE FUNCTION WriteValue (BYREF wszSectionName AS WSTRING, BYREF wszKeyName AS WSTRING, BYREF dblValue AS DOUBLE) AS BOOLEAN
   DECLARE FUNCTION WriteValue (BYREF wszSectionName AS WSTRING, BYREF wszKeyName AS WSTRING, BYREF intValue AS LONG) AS BOOLEAN
   DECLARE FUNCTION DeleteKey (BYREF wszSectionName AS WSTRING, BYREF wszKeyName AS WSTRING) AS BOOLEAN
   DECLARE FUNCTION DeleteSection (BYREF wszSectionName AS WSTRING) AS BOOLEAN
   DECLARE FUNCTION GetString (BYREF wszSectionName AS WSTRING, BYREF wszKeyName AS WSTRING, BYREF wszDefaultValue AS WSTRING = "") AS CWSTR
   DECLARE FUNCTION GetDouble (BYREF wszSectionName AS WSTRING, BYREF wszKeyName AS WSTRING, BYVAL nDefaultValue AS DOUBLE = 0) AS DOUBLE
   DECLARE FUNCTION GetInt (BYREF wszSectionName AS WSTRING, BYREF wszKeyName AS WSTRING, BYVAL nDefaultValue AS LONG = 0) AS LONG
   DECLARE FUNCTION GetSectionNames () AS CSafeARray
   DECLARE FUNCTION GetKeyNames (BYREF wszSectionName AS WSTRING) AS CSafeARray
   DECLARE FUNCTION GetSectionValues (BYREF wszSectionName AS WSTRING, BYREF pDic AS CDicObj) AS BOOLEAN

END TYPE

' ========================================================================================
' Default constructor
' Initializes a new instance of the CIniFile class.
' - wszFileName: The ini file to read and write from.
' ========================================================================================
PRIVATE CONSTRUCTOR CIniFile (BYREF wszFileName AS WSTRING)
   ' // Convert to the full path. Because of backward compatibility,
   ' // the win32 functions tend to assume the path should be the
   ' // root Windows directory if it is not specified. By calling
   ' // GetFullPath, we make sure we are always passing the full path
   ' // the win32 functions.
   DIM nLen AS LONG, buffer AS WSTRING * 4096
   nLen = .GetFullPathNameW(wszFileName, SIZEOF(buffer) \ 2, buffer, NULL)
   IF nLen THEN m_Path = LEFT(buffer, nLen)
   ' // Even if we use WritePrivateProfileStringW, it will only write unicode text if the
   ' // file has been created using UTF 16 little endian. The solution is to create the
   ' // ini-file with the encoding UTF-16LE before writing an unicode string to it.
   ' // Make sure the file does not already exist
   IF AfxFileExists(m_Path) = FALSE THEN
      ' // create file with encoding UTF-16LE
      DIM fileHandle AS FILE PTR
      DIM wszMode AS WSTRING * 260 = "w, ccs=UTF-16LE"
      fileHandle = _wfopen(@m_Path, @wszMode)
      IF fileHandle THEN fclose(fileHandle)
   END IF
END CONSTRUCTOR
' ========================================================================================
 
' ========================================================================================
' Destructor
' ========================================================================================
PRIVATE DESTRUCTOR CIniFile
END DESTRUCTOR
' ========================================================================================

' ========================================================================================
' Returns the full path of ini file this object instance is operating on.
' ========================================================================================
PRIVATE FUNCTION CIniFile.GetPath () AS CWSTR
   RETURN m_Path
END FUNCTION
' ========================================================================================

' ========================================================================================
' Copies a value into the specified section of an initialization file.
' - wszSectionName: Name of the section
' - wszKeyName: Name of key
' - wszValue / dblValue / intValue: The value to write
' ========================================================================================
PRIVATE FUNCTION CIniFile.WriteValue (BYREF wszSectionName AS WSTRING, BYREF wszKeyName AS WSTRING, BYREF wszValue AS WSTRING) AS BOOLEAN
   RETURN WritePrivateProfileStringW(wszSectionName, wszKeyName, wszValue, m_path)
END FUNCTION
' ========================================================================================
' ========================================================================================
PRIVATE FUNCTION CIniFile.WriteValue (BYREF wszSectionName AS WSTRING, BYREF wszKeyName AS WSTRING, BYREF dblValue AS DOUBLE) AS BOOLEAN
   RETURN WritePrivateProfileStringW(wszSectionName, wszKeyName, WSTR(dblValue), m_path)
END FUNCTION
' ========================================================================================
' ========================================================================================
PRIVATE FUNCTION CIniFile.WriteValue (BYREF wszSectionName AS WSTRING, BYREF wszKeyName AS WSTRING, BYREF intValue AS LONG) AS BOOLEAN
   RETURN WritePrivateProfileStringW(wszSectionName, wszKeyName, WSTR(intValue), m_path)
END FUNCTION
' ========================================================================================

' ========================================================================================
' * Retrieves a string from the specified section in an initialization file.
' - wszSectionName: Name of the section
' - wszKeyName: Name of key
' - wszDefaultValue: A default string. If the key key cannot be found in the initialization
'   file, the default string is returned.
'   Avoid specifying a default string with trailing blank characters. The function inserts
'   a null character in the returned buffer to strip any trailing blanks.
' ========================================================================================
PRIVATE FUNCTION CIniFile.GetString (BYREF wszSectionName AS WSTRING, BYREF wszKeyName AS WSTRING, BYREF wszDefaultValue AS WSTRING = "") AS CWSTR
   DIM wsz AS WSTRING * 32767
   DIM dwLen AS DWORD = GetPrivateProfileStringW(wszSectionName, wszKeyName, wszDefaultValue, @wsz, 32767, m_path)
   RETURN LEFT(wsz, dwLen)
END FUNCTION
' ========================================================================================
' ========================================================================================
PRIVATE FUNCTION CIniFile.GetDouble (BYREF wszSectionName AS WSTRING, BYREF wszKeyName AS WSTRING, BYVAL nDefaultValue AS DOUBLE = 0) AS DOUBLE
   DIM wsz AS WSTRING * 32767
   DIM dwLen AS DWORD = GetPrivateProfileStringW(wszSectionName, wszKeyName, NULL, @wsz, 32767, m_path)
   wsz = LEFT(wsz, dwLen)
   IF VAL(wsz) = 0 THEN RETURN nDefaultValue ELSE RETURN VAL(wsz)
END FUNCTION
' ========================================================================================
' ========================================================================================
PRIVATE FUNCTION CIniFile.GetInt (BYREF wszSectionName AS WSTRING, BYREF wszKeyName AS WSTRING, BYVAL nDefaultValue AS LONG = 0) AS LONG
   RETURN CLNG(GetPrivateProfileInt(wszSectionName, wszKeyName, nDefaultValue, m_path))
END FUNCTION
' ========================================================================================

' ========================================================================================
' Deletes a key from the specified section of an initialization file.
' - wszSectionName: Name of the section
' - wszKeyName: Name of key
' ========================================================================================
PRIVATE FUNCTION CIniFile.DeleteKey (BYREF wszSectionName AS WSTRING, BYREF wszKeyName AS WSTRING) AS BOOLEAN
   RETURN WritePrivateProfileStringW(wszSectionName, wszKeyName, NULL, m_path)
END FUNCTION
' ========================================================================================

' ========================================================================================
' Deletes a section from an initialization file.
' - wszSectionName: Name of the section
' ========================================================================================
PRIVATE FUNCTION CIniFile.DeleteSection (BYREF wszSectionName AS WSTRING) AS BOOLEAN
   RETURN WritePrivateProfileStringW(wszSectionName, NULL, NULL, m_path)
END FUNCTION
' ========================================================================================

' ========================================================================================
' Returns a safe array with the names of all sections in the ini file.
' Example:
' DIM cIni AS CInifile = "Test.ini"
' DIM csa AS CSafeArray = cIni.GetSectionNames
' FOR i AS LONG = csa.LBound TO csa.UBound
'    print csa.GetStr(i)
' NEXT
' ========================================================================================
PRIVATE FUNCTION CIniFile.GetSectionNames () AS CSafeARray
   DIM csa AS CSafeArray = CSafeArray(VT_BSTR, 0, 1)
   DIM wsz AS WSTRING * 32767
   DIM dwLen AS DWORD = GetPrivateProfileSectionNamesW(@wsz, 32767, m_path)
   IF dwLen = 0 THEN RETURN csa
   DIM pwsz AS WSTRING PTR = @wsz
   DO
      IF pwsz = NULL THEN EXIT DO
      csa.AppendStr(pwsz)
      dwLen = LEN(*pwsz)
      IF dwLen = 0 THEN EXIT DO
      pwsz += dwLen + 1
   LOOP
   RETURN csa
END FUNCTION
' ========================================================================================

' ========================================================================================
' Returns a safe array with the names of all the keys of the specified section.
' Example:
' DIM cIni AS CInifile = "Test.ini"
' DIM csa AS CSafeArray = cIni.GetKeyNames("StARtup")
' FOR i AS LONG = csa.LBound TO csa.UBound
'    print csa.GetStr(i)
' NEXT
' ========================================================================================
PRIVATE FUNCTION CIniFile.GetKeyNames (BYREF wszSectionName AS WSTRING) AS CSafeARray
   DIM csa AS CSafeArray = CSafeArray(VT_BSTR, 0, 1)
   DIM wsz AS WSTRING * 32767
   DIM dwLen AS DWORD = GetPrivateProfileStringW(@wszSectionName, NULL, NULL, @wsz, 32767, m_path)
   IF dwLen = 0 THEN RETURN csa
   DIM pwsz AS WSTRING PTR = @wsz
   DO
      IF pwsz = NULL THEN EXIT DO
      csa.AppendStr(pwsz)
      dwLen = LEN(*pwsz)
      IF dwLen = 0 THEN EXIT DO
      pwsz += dwLen + 1
   LOOP
   RETURN csa
END FUNCTION
' ========================================================================================

' ========================================================================================
' Returns the keys and values of the specified section as a dictionary object.
' ========================================================================================
PRIVATE FUNCTION CIniFile.GetSectionValues (BYREF wszSectionName AS WSTRING, BYREF pDic AS CDicObj) AS BOOLEAN
   IF pDic.m_pDictionary = NULL THEN RETURN FALSE
   DIM wsz AS WSTRING * 32767
   DIM dwLen AS DWORD = GetPrivateProfileStringW(@wszSectionName, NULL, NULL, @wsz, 32767, m_path)
   IF dwLen = 0 THEN RETURN FALSE
   DIM cwsKeyName AS CWSTR, cwsValue AS CWSTR
   DIM pwsz AS WSTRING PTR = @wsz
   DO
      IF pwsz = NULL THEN EXIT DO
      cwsKeyName = pwsz
      cwsValue = this.GetString(wszSectionName, cwsKeyName)
      pDic.Add(cwsKeyName, cwsValue)
      dwLen = LEN(*pwsz)
      IF dwLen = 0 THEN EXIT DO
      pwsz += dwLen + 1
   LOOP
   RETURN TRUE
END FUNCTION
' ========================================================================================

END NAMESPACE
Title: Re: CWindow Release Candidate 31
Post by: José Roca on October 12, 2017, 09:31:57 PM
Even using WritePrivateProfileStringW, it will only write unicode text if the file has been created using UTF 16 little endian. The solution is to create the ini-file with the encoding UTF-16LE before writing an unicode string to it. Therefore, I have modified the constructor to check if the file does exist or not. If it does not exist, it creates an empty .ini file using UTF-16LE encoding. If the file already exists, WritePrivateProfileStringW will use the encoding used to create the file.

Code: [Select]
' ========================================================================================
' Default constructor
' Initializes a new instance of the CIniFile class.
' - wszFileName: The ini file to read and write from.
' ========================================================================================
PRIVATE CONSTRUCTOR CIniFile (BYREF wszFileName AS WSTRING)
   ' // Convert to the full path. Because of backward compatibility,
   ' // the win32 functions tend to assume the path should be the
   ' // root Windows directory if it is not specified. By calling
   ' // GetFullPath, we make sure we are always passing the full path
   ' // the win32 functions.
   DIM nLen AS LONG, buffer AS WSTRING * 4096
   nLen = .GetFullPathNameW(wszFileName, SIZEOF(buffer) \ 2, buffer, NULL)
   IF nLen THEN m_Path = LEFT(buffer, nLen)
   ' // Even if we use WritePrivateProfileStringW, it will only write unicode text if the
   ' // file has been created using UTF 16 little endian. The solution is to create the
   ' // ini-file with the encoding UTF-16LE before writing an unicode string to it.
   ' // Make sure the file does not already exist
   IF AfxFileExists(m_Path) = FALSE THEN
      ' // create file with encoding UTF-16LE
      DIM fileHandle AS FILE PTR
      DIM wszMode AS WSTRING * 260 = "w, ccs=UTF-16LE"
      fileHandle = _wfopen(@m_Path, @wszMode)
      IF fileHandle THEN fclose(fileHandle)
   END IF
END CONSTRUCTOR
' ========================================================================================
Title: Re: CWindow Release Candidate 31
Post by: José Roca on October 13, 2017, 04:05:44 PM
I have added the AfxCGraphCtx function to the graphic control. The attached file contains the updated CGraphCtx.inc file and an OpenGL example that uses it. I also have added a 32 bit version executable of the example just in case somebody is willing to try it with other OSEs. I have tried it with Windows 7.

The control is scrollable by default, but you can choose instead to make it strechable or resizable. In the example, I have made it resizable, and the rendering of the control is very smooth, even when resizing it, thanks to the use of a timer. It is also flicker free, lightweight, DPI aware, works with 32 and 64 bit and supports GDI, GDI+ and OpenGL, and it's free! As we say in Spain: Bueno, bonito y barato.

Code: [Select]
' ########################################################################################
' Microsoft Windows
' File: CW_OGL_Nehe_05
' Contents: CWindow OpenGL - NeHe lesson 5
' Compiler: FreeBasic 32 & 64 bit
' Translated in 2017 by Jose Roca. Freeware. Use at your own risk.
' THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
' EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE IMPLIED WARRANTIES OF
' MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
' ########################################################################################

#define UNICODE
#INCLUDE ONCE "Afx/CWindow.inc"
#INCLUDE ONCE "Afx/CGraphCtx.inc"
USING Afx

CONST GL_WINDOWWIDTH   = 600               ' Window width
CONST GL_WINDOWHEIGHT  = 400               ' Window height
CONST GL_WindowCaption = "NeHe Lesson 5"   ' Window caption
CONST IDC_GRCTX = 1001

DECLARE FUNCTION WinMain (BYVAL hInstance AS HINSTANCE, _
                          BYVAL hPrevInstance AS HINSTANCE, _
                          BYVAL szCmdLine AS ZSTRING PTR, _
                          BYVAL nCmdShow AS LONG) AS LONG

   END WinMain(GetModuleHandleW(NULL), NULL, COMMAND(), SW_NORMAL)

' // Forward declarations
DECLARE FUNCTION WndProc (BYVAL hwnd AS HWND, BYVAL uMsg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM) AS LRESULT
DECLARE FUNCTION GraphCtx_SubclassProc ( _
   BYVAL hwnd   AS HWND, _                 ' // Control window handle
   BYVAL uMsg   AS UINT, _                 ' // Type of message
   BYVAL wParam AS WPARAM, _               ' // First message parameter
   BYVAL lParam AS LPARAM, _               ' // Second message parameter
   BYVAL uIdSubclass AS UINT_PTR, _        ' // The subclass ID
   BYVAL dwRefData AS DWORD_PTR _          ' // Pointer to reference data
   ) AS LRESULT

' =======================================================================================
' OpenGL class
' =======================================================================================
TYPE CTXOGL

   Private:
      m_pGraphCtx AS CGraphCtx PTR
      rtri AS SINGLE
      rquad AS SINGLE

   Public:
      DECLARE CONSTRUCTOR (BYVAL pGraphCtx AS CGraphCtx PTR)
      DECLARE DESTRUCTOR
      DECLARE SUB SetupScene
      DECLARE SUB ResizeScene
      DECLARE SUB RenderScene

END TYPE
' =======================================================================================

' ========================================================================================
' COGL constructor
' ========================================================================================
CONSTRUCTOR CTXOGL (BYVAL pGraphCtx AS CGraphCtx PTR)
   m_pGraphCtx = pGraphCtx
END CONSTRUCTOR
' ========================================================================================

' ========================================================================================
' COGL Destructor
' ========================================================================================
DESTRUCTOR CTXOGL
END DESTRUCTOR
' ========================================================================================

' =======================================================================================
' All the setup goes here
' =======================================================================================
SUB CTXOGL.SetupScene

   ' // Specify clear values for the color buffers
   glClearColor 0.0, 0.0, 0.0, 0.0
   ' // Specify the clear value for the depth buffer
   glClearDepth 1.0
   ' // Specify the value used for depth-buffer comparisons
   glDepthFunc GL_LESS
   ' // Enable depth comparisons and update the depth buffer
   glEnable GL_DEPTH_TEST
   ' // Select smooth shading
   glShadeModel GL_SMOOTH

END SUB
' =======================================================================================

' =======================================================================================
SUB CTXOGL.ResizeScene

   ' // Get the dimensions of the control
   IF m_pGraphCtx = NULL THEN EXIT SUB
   DIM nWidth AS LONG = AfxGetWindowWidth(m_pGraphCtx->hWindow)
   DIM nHeight AS LONG = AfxGetWindowHeight(m_pGraphCtx->hWindow)
   ' // Prevent divide by zero making height equal one
   IF nHeight = 0 THEN nHeight = 1
   ' // Reset the current viewport
   glViewport 0, 0, nWidth, nHeight
   ' // Select the projection matrix
   glMatrixMode GL_PROJECTION
   ' // Reset the projection matrix
   glLoadIdentity
   ' // Calculate the aspect ratio of the window
   gluPerspective 45.0, nWidth / nHeight, 0.1, 100.0
   ' // Select the model view matrix
   glMatrixMode GL_MODELVIEW
   ' // Reset the model view matrix
   glLoadIdentity

END SUB
' =======================================================================================

' =======================================================================================
SUB CTXOGL.RenderScene

   ' // Clear the screen buffer
   glClear GL_COLOR_BUFFER_BIT OR GL_DEPTH_BUFFER_BIT
   ' // Reset the view
   glLoadIdentity

   glTranslatef -1.5, 0.0, -6.0           ' Move left 1.5 units and into the screen
   glRotatef rtri, 0.0, 1.0, 0.0          ' Rotate the triangle on the Y axis

   glBegin GL_TRIANGLES
      ' Front
      glColor3f   1.0,  0.0,  0.0         ' Red
      glVertex3f  0.0,  1.0,  0.0         ' Top of triangle (Front)
      glColor3f   0.0,  1.0,  0.0         ' Green
      glVertex3f -1.0, -1.0,  1.0         ' Left of triangle (Front)
      glColor3f   0.0,  0.0,  1.0         ' Blue
      glVertex3f  1.0, -1.0,  1.0         ' Right of triangle (Front)

      ' Right
      glColor3f   1.0,  0.0,  0.0         ' Red
      glVertex3f  0.0,  1.0,  0.0         ' Top of triangle (Right)
      glColor3f   0.0,  0.0,  1.0         ' Blue
      glVertex3f  1.0, -1.0,  1.0         ' Left of triangle (Right)
      glColor3f   0.0,  1.0,  0.0         ' Green
      glVertex3f  1.0, -1.0, -1.0         ' Right of triangle (Right)

      ' Back
      glColor3f   1.0,  0.0,  0.0         ' Red
      glVertex3f  0.0,  1.0,  0.0         ' Top of triangle (Back)
      glColor3f   0.0,  1.0,  0.0         ' Green
      glVertex3f  1.0, -1.0, -1.0         ' Left of triangle (Back)
      glColor3f   0.0,  0.0,  1.0         ' Blue
      glVertex3f -1.0, -1.0, -1.0         ' Right of triangle (Back)

      ' Left
      glColor3f   1.0,  0.0,  0.0         ' Red
      glVertex3f  0.0,  1.0,  0.0         ' Top of triangle (Left)
      glColor3f   0.0,  0.0,  1.0         ' Blue
      glVertex3f -1.0, -1.0, -1.0         ' Left of triangle (Left)
      glColor3f   0.0,  1.0,  0.0         ' Green
      glVertex3f -1.0, -1.0,  1.0         ' Right of triangle (Left)
   glEnd

   glLoadIdentity
   glTranslatef 1.5, 0.0, -7.0            ' Move right 1.5 units and into the screen
   glRotatef rquad, 1.0, 1.0, 1.0         ' Rotate the quad on the X axis

   glBegin GL_QUADS
      glColor3f   0.0,  1.0,  0.0         ' Set the color to green
      glVertex3f  1.0,  1.0, -1.0         ' Top right of the quad (Top)
      glVertex3f -1.0,  1.0, -1.0         ' Top left of the quad (Top)
      glVertex3f -1.0,  1.0,  1.0         ' Bottom left of the quad (Top)
      glVertex3f  1.0,  1.0,  1.0         ' Bottom right of the quad (Top)

      glColor3f   1.0,  0.5,  0.0         ' Set the color to orange
      glVertex3f  1.0, -1.0,  1.0         ' Top right of the quad (Bottom)
      glVertex3f -1.0, -1.0,  1.0         ' Top left of the quad (Bottom)
      glVertex3f -1.0, -1.0, -1.0         ' Bottom left of the quad (Bottom)
      glVertex3f  1.0, -1.0, -1.0         ' Bottom right of the quad (Bottom)

      glColor3f   1.0,  0.0,  0.0         ' Set the color to red
      glVertex3f  1.0,  1.0,  1.0         ' Top right of the quad (Front)
      glVertex3f -1.0,  1.0,  1.0         ' Top left of the quad (Front)
      glVertex3f -1.0, -1.0,  1.0         ' Bottom left of the quad (Front)
      glVertex3f  1.0, -1.0,  1.0         ' Bottom right of the quad (Front)

      glColor3f   1.0,  1.0,  0.0         ' Set the color to yellow
      glVertex3f  1.0, -1.0, -1.0         ' Top right of the quad (Back)
      glVertex3f -1.0, -1.0, -1.0         ' Top left of the quad (Back)
      glVertex3f -1.0,  1.0, -1.0         ' Bottom left of the quad (Back)
      glVertex3f  1.0,  1.0, -1.0         ' Bottom right of the quad (Back)

      glColor3f   0.0,  0.0,  1.0         ' Set the color to blue
      glVertex3f -1.0,  1.0,  1.0         ' Top right of the quad (Left)
      glVertex3f -1.0,  1.0, -1.0         ' Top left of the quad (Left)
      glVertex3f -1.0, -1.0, -1.0         ' Bottom left of the quad (Left)
      glVertex3f -1.0, -1.0,  1.0         ' Bottom right of the quad (Left)

      glColor3f   1.0,  0.0,  1.0         ' Set the color to violet
      glVertex3f  1.0,  1.0, -1.0         ' Top right of the quad (Right)
      glVertex3f  1.0,  1.0,  1.0         ' Top left of the quad (Right)
      glVertex3f  1.0, -1.0,  1.0         ' Bottom left of the quad (Right)
      glVertex3f  1.0, -1.0, -1.0         ' Bottom right of the quad (Right)
   glEnd

   rtri = rtri + 0.2                      ' Increase the rotation variable for the triangle
   rquad = rquad - 0.15                   ' Decrease the rotation variable for the quad

   ' // Required: force execution of GL commands in finite time
   glFlush

   ' // Required: Force repainting of the control
   IF m_pGraphCtx THEN InvalidateRect(m_pGraphCtx->hWindow, NULL, CTRUE)

END SUB
' =======================================================================================

' ========================================================================================
' 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
   ' // The recommended way is to use a manifest file
   AfxSetProcessDPIAware

   ' // Creates the main window
   DIM pWindow AS CWindow
   ' -or- DIM pWindow AS CWindow = "MyClassName" (use the name that you wish)
   ' // Create the window
   DIM hwndMain AS HWND = pWindow.Create(NULL, GL_WindowCaption, @WndProc)
   ' // Don't erase the background
   pWindow.ClassStyle = CS_DBLCLKS
   ' // Use a black brush
   pWindow.Brush = CreateSolidBrush(BGR(255, 255, 255))
   ' // Sizes the window by setting the wanted width and height of its client area
   pWindow.SetClientSize(GL_WINDOWWIDTH, GL_WINDOWHEIGHT)
   ' // Centers the window
   pWindow.Center

   ' // Add a subclassed graphic control with OPENGL enabled
   DIM pGraphCtx AS CGraphCtx = CGraphCtx(@pWindow, IDC_GRCTX, "OPENGL", _
       0, 0, pWindow.ClientWidth, pWindow.ClientHeight)
'   pGraphCtx.Stretchable = TRUE
   pGraphCtx.Resizable = TRUE
   ' // Set the timer (using a timer to trigger redrawing allows a smoother rendering)
   SetTimer(pGraphCtx.hWindow, 1, 0, NULL)

   ' // Create an instance of the CtxOgl class
   DIM pCtxOgl AS CtxOgl = @pGraphCtx
   ' // Subclass the graphic control
   SetWindowSubclass pGraphCtx.hWindow, CAST(SUBCLASSPROC, @GraphCtx_SubclassProc), IDC_GRCTX, CAST(DWORD_PTR, @pCtxOgl)
   ' // Setup the OpenGL scene
   pCtxOgl.SetupScene
   ' // Resize the OpenGL scene
   pCtxOgl.ResizeScene
   ' // Render the OpenGL scene
   pCtxOgl.RenderScene

   ' // Dispatch Windows events
   FUNCTION = pWindow.DoEvents(nCmdShow)

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

' ========================================================================================
' Main 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_SYSCOMMAND
         ' // Disable the Windows screensaver
         IF (wParam AND &hFFF0) = SC_SCREENSAVE THEN EXIT FUNCTION
         ' // Close the window
         IF (wParam AND &hFFF0) = SC_CLOSE THEN
            SendMessageW hwnd, WM_CLOSE, 0, 0
            EXIT FUNCTION
         END IF

      CASE WM_COMMAND
         SELECT CASE GET_WM_COMMAND_ID(wParam, lParam)
            CASE IDCANCEL
               ' // If ESC key pressed, close the application by sending an WM_CLOSE message
               IF GET_WM_COMMAND_CMD(wParam, lParam) = BN_CLICKED THEN
                  SendMessageW hwnd, WM_CLOSE, 0, 0
                  EXIT FUNCTION
               END IF
         END SELECT

      CASE WM_SIZE
         IF wParam <> SIZE_MINIMIZED THEN
            DIM pWindow AS CWindow PTR = AfxCWindowPtr(hwnd)
            ' // If the window isn't minimized, resize the graphic control
            IF pWindow THEN pWindow->MoveWindow GetDlgItem(hwnd, IDC_GRCTX), _
               0, 0, pWindow->ClientWidth, pWindow->ClientHeight, CTRUE
         END IF

    CASE WM_DESTROY
         ' // Ends the application by sending a WM_QUIT message
         PostQuitMessage(0)
         EXIT FUNCTION

   END SELECT

   ' // Default processing of Windows messages
   FUNCTION = DefWindowProcW(hwnd, uMsg, wParam, lParam)

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

' ========================================================================================
' Processes messages for the subclassed Button window.
' ========================================================================================
FUNCTION GraphCtx_SubclassProc ( _
   BYVAL hwnd   AS HWND, _                 ' // Control window handle
   BYVAL uMsg   AS UINT, _                 ' // Type of message
   BYVAL wParam AS WPARAM, _               ' // First message parameter
   BYVAL lParam AS LPARAM, _               ' // Second message parameter
   BYVAL uIdSubclass AS UINT_PTR, _        ' // The subclass ID
   BYVAL dwRefData AS DWORD_PTR _          ' // Pointer to reference data
   ) AS LRESULT

   SELECT CASE uMsg

      CASE WM_GETDLGCODE
         ' // All keyboard input
         FUNCTION = DLGC_WANTALLKEYS
         EXIT FUNCTION

      CASE WM_LBUTTONDOWN
         MessageBoxW(GetParent(hwnd), "Click", "FreeBasic", MB_OK)
         EXIT FUNCTION

      CASE WM_KEYDOWN
         SELECT CASE GET_WM_COMMAND_ID(wParam, lParam)
            CASE VK_ESCAPE
               SendMessageW(GetParent(hwnd), WM_CLOSE, 0, 0)
               EXIT FUNCTION
         END SELECT

      CASE WM_TIMER
         ' // Render the scene
         DIM pCtxOgl AS CTXOGL PTR = cast(CTXOGL PTR, dwRefData)
         IF pCtxOgl THEN pCtxOgl->RenderScene
         EXIT FUNCTION

      CASE WM_SIZE
         ' // First perform the default action
         DefSubclassProc(hwnd, uMsg, wParam, lParam)
         ' // Check if the graphic contol is resizable
         DIM bResizable AS BOOLEAN =  AfxCGraphCtxPtr(hwnd)->Resizable
         ' // If it is resizable, we need to recreate the scene
         ' // because the rendering context has changed
         IF bResizable THEN
            DIM pCtxOgl AS CtxOgl PTR = cast(CtxOgl PTR, dwRefData)
            IF pCtxOgl THEN
               pCtxOgl->SetUpScene
               pCtxOgl->ResizeScene
               pCtxOgl->RenderScene
            END IF
         END IF

      EXIT FUNCTION

      CASE WM_DESTROY
         ' // Kill the timer
         KillTimer(hwnd, 1)
         ' // REQUIRED: Remove control subclassing
         RemoveWindowSubclass hwnd, @GraphCtx_SubclassProc, uIdSubclass

   END SELECT

   ' // Default processing of Windows messages
   FUNCTION = DefSubclassProc(hwnd, uMsg, wParam, lParam)

END FUNCTION
' ========================================================================================
Title: Re: CWindow Release Candidate 31
Post by: José Roca on October 13, 2017, 10:36:52 PM
This example demonstrates how to process keystrokes and the mouse.
Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on October 14, 2017, 09:10:22 AM
Thanks Jose!
BTW, I am back to programming again so if you need anything added/changed to the editor then just let me know. I am working on the visual designer now.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on October 16, 2017, 08:37:21 AM
Updated the download in the first post with the changes and new classes recently discussed.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on October 19, 2017, 11:18:53 AM
Updated the download in the first post with a modified CDispInvoke class.

Changes in the CVAR class to ease the use of variants could cause an ambiguos call to overloaded function Invoke. I have removed the old overloads that caused the error.

With the changes, you no longer have to specify the number of parameters when calling Invoke and also you won't need the use of CVAR except in some cases.

This example

Code: [Select]
#define UNICODE
#INCLUDE ONCE "windows.bi"
#INCLUDE ONCE "Afx/CCLRHost.inc"
USING Afx

' // Create an instance of the CCLRHost class
DIM pCLRHost AS CCLRHost

' // Create an instance of the .NET ArrayList class
DIM pDisp AS CDispInvoke = pCLRHost.CreateInstance ("mscorlib", "System.Collections.ArrayList")
IF pDisp.DispPtr = NULL THEN END

pDisp.Invoke("Add", 1, CVAR("First string"))
pDisp.Invoke("Add", 1, CVAR("Second string"))
pDisp.Invoke("Add", 1, CVAR("Third string"))

DIM nCount AS LONG =  pDisp.Invoke("Count").ValInt
FOR i AS LONG = 0 TO nCount - 1
   print pDisp.Get("Item", CVAR(i)).ToStr
NEXT

PRINT
PRINT "Press any key..."
SLEEP

becomes

Code: [Select]
'#CONSOLE ON
#define UNICODE
#INCLUDE ONCE "windows.bi"
#INCLUDE ONCE "Afx/CCLRHost.inc"
USING Afx

' // Create an instance of the CCLRHost class
DIM pCLRHost AS CCLRHost

' // Create an instance of the .NET ArrayList class
DIM pDisp AS CDispInvoke = pCLRHost.CreateInstance ("mscorlib", "System.Collections.ArrayList")
IF pDisp.DispPtr = NULL THEN END

pDisp.Invoke("Add", "First string")
pDisp.Invoke("Add", "Second string")
pDisp.Invoke("Add", "Third string")

DIM nCount AS LONG =  VAL(pDisp.Invoke("Count"))
FOR i AS LONG = 0 TO nCount - 1
   print pDisp.Get("Item", i)
NEXT

PRINT
PRINT "Press any key..."
SLEEP
Title: Re: CWindow Release Candidate 31
Post by: José Roca on October 25, 2017, 11:06:53 PM
We can use the FreeBasic array intrinsics with CWSTRings.

Code: [Select]
DIM rg(1 TO 10) AS CWSTR
FOR i AS LONG = 1 TO 10
   rg(i) = "string " & i
NEXT

FOR i AS LONG = 1 TO 10
   print rg(i)
NEXT

Code: [Select]
DIM rg2 (1 TO 2, 1 TO 2) AS CWSTR
rg2(1, 1) = "string 1 1"
rg2(1, 2) = "string 1 2"
rg2(2, 1) = "string 2 1"
rg2(2, 2) = "string 2 2"
print rg2(2, 1)

Code: [Select]
REDIM rg(0) AS CWSTR
rg(0) = "string 0"
REDIM PRESERVE rg(0 TO 2) AS CWSTR
rg(1) = "string 1"
rg(2) = "string 2"
print rg(0)
print rg(1)
print rg(2)
ERASE rg

And also with CVARs (variants)

Code: [Select]
DIM rg(1 TO 10) AS CVAR
FOR i AS LONG = 1 TO 10
   rg(i) = "string " & i
NEXT

FOR i AS LONG = 1 TO 10
   print rg(i)
NEXT

Now they behave like FB strings with the exception of the MID statement (don't confuse it with the MID function) and the [] operator to change the contents of the string. This is because casting generates a temporary string and the changes will be made to that temporary string. However, MID(**wstring, 2, 3) = "xx" will work.

Since BSTRings and Safe Arrays are slower, CWSTRings should be used for general purposes, and CBSTRrings and CSafeArrays for COM programming and for DLLs or COM servers to be used with other languages such PowerBasic.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on October 26, 2017, 01:55:11 AM
And I have got sorting to work with one-dimensional CWSTR arrays...

Code: [Select]
'#CONSOLE ON
#define UNICODE
#include once "Afx/CWSTR.inc"
USING Afx

' ========================================================================================
' qsort CWstr comparison function
' ========================================================================================
PRIVATE FUNCTION AfxCWstrArrayCompare CDECL (BYVAL a AS CWSTR PTR, BYVAL b AS CWSTR PTR) AS LONG
   FUNCTION = wcscmp(cast(WSTRING PTR, a->m_pBuffer), cast(WSTRING PTR, b->m_pBuffer))
END FUNCTION
' ========================================================================================
' ========================================================================================
' Reverse qsort CWstr comparison function
' ========================================================================================
PRIVATE FUNCTION AfxCWStrArrayReverseCompare CDECL (BYVAL a AS CWSTR PTR, BYVAL b AS CWSTR PTR) AS LONG
   DIM r AS LONG = wcscmp(cast(WSTRING PTR, a->m_pBuffer), cast(WSTRING PTR, b->m_pBuffer))
   IF r = 1 THEN r = -1 ELSE IF r = -1 THEN r = 1
   RETURN r
END FUNCTION
' ========================================================================================

' ========================================================================================
' Sorts a one-dimensional CWSTR array calling the C qsort function.
' Parameters:
' - rgwstr : Start of target array.
' - numElm : Number of elements in the array.
' - bAscend: TRUE for sorting in ascending order; FALSE for sorting in descending order.
' ========================================================================================
PRIVATE SUB AfxCWstrSort (BYREF rgwstr AS ANY PTR, BYVAL numElm AS LONG, BYVAL bAscend AS BOOLEAN = TRUE)
   IF rgwstr = NULL OR numElm < 2 THEN EXIT SUB
   IF bAscend THEN
      qsort rgwstr, numElm, SIZEOF(CWSTR), CPTR(ANY PTR, @AfxCWstrArrayCompare)
   ELSE
      qsort rgwstr, numElm, SIZEOF(CWSTR) , CPTR(ANY PTR, @AfxCWStrArrayReverseCompare)
   END IF
END SUB
' ========================================================================================

DIM rg(1 TO 10) AS CWSTR
FOR i AS LONG = 1 TO 10
   rg(i) = "string " & i
NEXT

FOR i AS LONG = 1 TO 10
'   print varptr(rg(i))
   print rg(i)
NEXT

print "---- after sorting ----"

AfxCWstrSort @rg(1), 10, TRUE

FOR i AS LONG = 1 TO 10
   print rg(i)
NEXT

PRINT
PRINT "Press any key..."
SLEEP
Title: Re: CWindow Release Candidate 31
Post by: José Roca on October 26, 2017, 02:27:23 PM
If we use REDIM PRESERVE to shorten or expand a CWSTR array, the discarded element will call its destructor, and the added element(s) will call its default constructor.

Code: [Select]
'#CONSOLE ON
#define UNICODE
#define _CWSTR_DEBUG_ 1
#include once "Afx/CWSTR.inc"
USING Afx

REDIM rg(1 TO 10) AS CWSTR
FOR i AS LONG = 1 TO 10
   rg(i) = "string " & i
NEXT

REDIM PRESERVE rg(1 TO 9) AS CWSTR

FOR i AS LONG = 1 TO UBOUND(rg)
   print rg(i)
NEXT

PRINT
PRINT "Press any key..."
SLEEP
Title: Re: CWindow Release Candidate 31
Post by: José Roca on October 26, 2017, 02:44:20 PM
And we even can have dynamic arrays of CWSTRings in a UDT!

Code: [Select]
'#CONSOLE ON
#define UNICODE
#include once "Afx/CWSTR.inc"
USING Afx

TYPE MyType
   rg(ANY) AS CWSTR
END TYPE

DIM t AS MyType
REDIM t.rg(1 TO 2) AS CWSTR

t.rg(1) = "String 1"
t.rg(2) = "String 2"

print t.rg(1)
print t.rg(2)

PRINT
PRINT "Press any key..."
SLEEP
Title: Re: CWindow Release Candidate 31
Post by: José Roca on October 26, 2017, 02:49:01 PM
And also dynamic arrays of CVARs (Variants).

Code: [Select]
'#CONSOLE ON
#define UNICODE
#define _CVAR_DEBUG_ 1
#include once "Afx/CVAR.inc"
USING Afx

TYPE MyType
   rg(ANY) AS CVAR
END TYPE

DIM t AS MyType
REDIM t.rg(1 TO 2) AS CVAR

PRINT LBOUND(t.rg)
PRINT UBOUND(t.rg)

t.rg(1) = "String"
t.rg(2) = CVAR(12345.12)

print t.rg(1)
print t.rg(2)

PRINT
PRINT "Press any key..."
SLEEP
Title: Re: CWindow Release Candidate 31
Post by: José Roca on October 26, 2017, 03:26:42 PM
I have added two new overloaded LET operators to allow to assign numeric values without having to use CVAR(value) when the type of the variant isn't important.

Code: [Select]
' ========================================================================================
PRIVATE OPERATOR CVar.Let (BYVAL _value AS LONGINT)
   VariantClear(@vd) : vd.vt = VT_I8   : vd.llVal = CLNGINT(_value)
END OPERATOR
' ========================================================================================
' ========================================================================================
PRIVATE OPERATOR CVar.Let (BYVAL _value AS DOUBLE)
   VariantClear(@vd) : vd.vt = VT_R8   : vd.dblVal = CDBL(_value)
END OPERATOR
' ========================================================================================

Not only we can have dynamic arrays of dynamic unicode strings but also dynamic arrays of variants.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on October 27, 2017, 05:26:40 AM
Updated the download file with changes to the WebBroser class and small changes to CWSTR and CVAR.

@Paul
Next time you will post an update to your editor, don't forget to update the includes, templates and projects.
Latest version always in GitHub: https://github.com/JoseRoca/WinFBX

There have been small but important changes in CWebBrowserEventsImpl.inc that I have discovered trying to modify the HTML5 YouTube player template to add processing of the NewWindow3 event to avoid the creation of a new instance of Internet Explorer if the user clicks a link.

Code: [Select]
' ########################################################################################
' Microsoft Windows
' File: CW_WB_YouTube_HTML5.fbtpl
' Contents: WebBrowser - YouTube HTML5 Player
' Compiler: FreeBasic 32 & 64 bit
' Copyright (c) 2016 Jose Roca. Freeware. Use at your own risk.
' THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
' EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE IMPLIED WARRANTIES OF
' MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
' ########################################################################################

#define UNICODE
#INCLUDE ONCE "Afx/CWindow.inc"
#INCLUDE ONCE "Afx/CVAR.inc"
#INCLUDE ONCE "Afx/CWebBrowser/CWebBrowser.inc"
USING Afx

CONST IDC_WEBBROWSER = 1001

DECLARE FUNCTION WinMain (BYVAL hInstance AS HINSTANCE, _
                          BYVAL hPrevInstance AS HINSTANCE, _
                          BYVAL szCmdLine AS ZSTRING PTR, _
                          BYVAL nCmdShow AS LONG) AS LONG

   END WinMain(GetModuleHandleW(NULL), NULL, COMMAND(), SW_NORMAL)

' // Forward declarations
DECLARE FUNCTION WndProc (BYVAL hwnd AS HWND, BYVAL uMsg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM) AS LRESULT
DECLARE SUB WebBrowser_NewWindow3Proc (BYVAL hwndContainer AS HWND, BYVAL ppdispVal AS IDispatch PTR PTR, _
   BYVAL pbCancel AS VARIANT_BOOL PTR, BYVAL dwFlags AS ULONG, BYVAL pwszUrlContext AS WSTRING PTR, _
   BYVAL pwszUrl AS WSTRING PTR)

' ========================================================================================
' Build the script
' Notes: For some reason, using 'height=100%' with iframe does not work as expected; the
' height attribute only works with pixel values, not percentage. As a workaround, we style
' the iframe by giving it a relative height value in viewport units (vh) instead of
' absolute pixels (style='height:100vh'). To force YouTube to use the HTML5 player
' instead of the Shockwave-Flash player, we have to add ""?html5=1'".
' ========================================================================================
FUNCTION BuildYouTubeScript (BYVAL strCode AS STRING) AS STRING

   DIM s AS STRING

   s  = "<!DOCTYPE html>"
   s += "<html>"
   s += "<head>"
   s += "   <title>YouTube video (HTML5 player)</title>"
   s += "   <meta http-equiv='X-UA-Compatible' content='IE=edge' />"
   s += "   <meta http-equiv='MSThemeCompatible' content='Yes'>"
   s += "</head>"
   s += "<body scroll='no' style='MARGIN: 0px 0px 0px 0px'>"
   s += "<iframe width='100%' style='height:100vh'"
   s += " src='http://www.youtube.com/embed/" & strCode & "?html5=1'>"
   s += "</iframe>"
   s += "</body>"
   s += "</html>"

   FUNCTION = s

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
   ' // The recommended way is to use a manifest file
   AfxSetProcessDPIAware

   ' // Creates the main window
   DIM pWindow AS CWindow
   ' -or- DIM pWindow AS CWindow = "MyClassName" (use the name that you wish)
   DIM hwndMain AS HWND = pWindow.Create(NULL, "WebBrowser - YouTube HTML5 Player", @WndProc)
   ' // Sizes it by setting the wanted width and height of its client area
   pWindow.SetClientSize(750, 450)
   ' // Centers the window
   pWindow.Center

   ' // Add a WebBrowser control
   DIM pwb AS CWebBrowser = CWebBrowser(@pWindow, IDC_WEBBROWSER, 0, 0, pWindow.ClientWidth, pWindow.ClientHeight)
   ' // Set the IDocHostUIHandler interface
   pwb.SetUIHandler
   ' // Connect events
   pwb.Advise
   ' // Set event callback procedures
   pwb.SetEventProc("NewWindow3", @WebBrowser_NewWindow3Proc)

   ' // Build the script
   DIM strCode AS STRING = "sJFOhTBelpU"   ' --> Change me: 11 character video code
   DIM s AS STRING = BuildYouTubeScript(strCode)
   ' // Save the script as a temporary file
   DIM wszPath AS WSTRING * MAX_PATH = AfxSaveTempFile(s, "html")
   ' // Navigate to the path
   pwb.Navigate(wszPath)
   ' // Processes pending Windows messages to allow the page to load
   ' // Needed if the message pump isn't running
   AfxPumpMessages
   ' // Kill the temporary file
   KILL wszPath

   ' // Displays the window and dispatches the Windows messages
   FUNCTION = pWindow.DoEvents(nCmdShow)

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

' ========================================================================================
' Main window procedure
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS HWND, BYVAL uMsg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM) AS LRESULT

   SELECT CASE uMsg

      CASE WM_COMMAND
         SELECT CASE GET_WM_COMMAND_ID(wParam, lParam)
            CASE IDCANCEL
               ' // If ESC key pressed, close the application by sending an WM_CLOSE message
               IF GET_WM_COMMAND_CMD(wParam, lParam) = BN_CLICKED THEN
                  SendMessageW hwnd, WM_CLOSE, 0, 0
                  EXIT FUNCTION
               END IF
         END SELECT

      CASE WM_SIZE
         IF wParam <> SIZE_MINIMIZED THEN
            ' // Retrieve a pointer to the CWindow class
            DIM pWindow AS CWindow PTR = AfxCWindowPtr(hwnd)
            ' // Move the position of the button
            IF pWindow THEN pWindow->MoveWindow GetDlgItem(hwnd, IDC_WEBBROWSER), _
               0, 0, pWindow->ClientWidth, pWindow->ClientHeight, CTRUE
         END IF

    CASE WM_DESTROY
         ' // Ends the application by sending a WM_QUIT message
         PostQuitMessage(0)
         EXIT FUNCTION

   END SELECT

   ' // Default processing of Windows messages
   FUNCTION = DefWindowProcW(hwnd, uMsg, wParam, lParam)

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

' ========================================================================================
' If the user clicks a link, prevent the creation of a new instance of Internet Explorer
' and display it in our embedded web browser control.
' ========================================================================================
SUB WebBrowser_NewWindow3Proc (BYVAL hwndContainer AS HWND, BYVAL ppdispVal AS IDispatch PTR PTR, _
   BYVAL pbCancel AS VARIANT_BOOL PTR, BYVAL dwFlags AS ULONG, BYVAL pwszUrlContext AS WSTRING PTR, _
   BYVAL pwszUrl AS WSTRING PTR)

   ' // Get a pointer to the hosted web browser control
   DIM pwb AS Afx_IWebBrowser2 PTR = AfxGetBrowserPtr(hwndContainer, IDC_WEBBROWSER)
   IF pwb = NULL THEN EXIT SUB
   ' // Cancel the new window creation
   *pbCancel = VARIANT_TRUE
   ' // Navigate to the page
'   DIM vUrl AS VARIANT : vUrl.vt = VT_BSTR : vUrl.bstrVal = SysAllocString(pwszUrl)
'   pwb->Navigate2(@vUrl)
'   VariantClear @vurl
   ' // Alternate way
   DIM cvUrl AS CVAR = *pwszUrl
   pwb->Navigate2(cvUrl)

END SUB
' ========================================================================================
Title: Re: CWindow Release Candidate 31
Post by: José Roca on October 31, 2017, 07:28:22 PM
Changed a BOOLEAN to LONG in a couple of secondary functions in AfxStr.inc to make them compatible with both FBC 1.05 and FBC 1.06. I wrote them using 1.06 and 1.05 complains about mixing booleans with other data types.

Two templates have become obsolete:

CW_WB_VirtualEarthMap.fbtpl

Microsoft stopped supporting this API in Nov 2016. Now uses Bing Maps version 8.

CW_WB_YouTube.fbtpl

Google has stopped support for embedding Shockwave-Flash. Now only uses the HTML5 player. Not a loss because Shockwave was very oudated. Use the CW_WB_YouTube_HTML5.fbtpl template.

Also, the Google Maps template sometimes GPFs when the applications ends.

Title: Re: CWindow Release Candidate 31
Post by: José Roca on November 02, 2017, 12:39:51 AM
I wrote the OLE container because I didn't know how to make web pages DPI aware with ATL. Because I had some problems with it recently, I have examined the source code for the ATL container and I have figured how to do it. It is a metter of retrieving the host interface, use it to retrieve the IAxWinAmbientDispatch interface and then call the put_DocHostFlags method.

Code: [Select]
' ========================================================================================
' Obtains a direct interface pointer to the container for a specified window (if any),
' given its handle.
' - hwnd:  A handle to the window that is hosting the control.
' Return value:
'   The IUnknown of the container of the control.
' ========================================================================================
PRIVATE FUNCTION CAtlCon.AtlHost (BYVAL hwnd AS .HWND) AS IUnknown PTR
   DIM pProc AS FUNCTION (BYVAL hwnd AS .HWND, BYREF punk AS IUnknown PTR) AS HRESULT
   pProc = cast(ANY PTR, GetProcAddress(m_hAtlLib, "AtlAxGetHost"))
   IF pProc = NULL THEN RETURN NULL
   DIM punk AS IUnknown PTR
   DIM hr AS HRESULT = pProc(hwnd, punk)
   RETURN punk
END FUNCTION
' ========================================================================================

Code: [Select]
' ========================================================================================
PRIVATE PROPERTY CAtlCon.DocHostFlags (BYVAL hwnd AS .HWND, BYVAL dwDocHostFlags AS DWORD)
   DIM AFX_IID_IAxWinAmbientDispatch_ AS GUID = (&hB6EA2051, &h048A, &h11D1, {&h82, &hB9, &h00, &hC0, &h4F, &hB9, &h94, &h2E})
   DIM pDocHost AS IUnknown PTR = this.AtlHost(hwnd)
   DIM pAmbientDisp AS Afx_IAxWinAmbientDispatch PTR
   IF pDocHost THEN
      pDocHost->lpvtbl->QueryInterface(pDocHost, @AFX_IID_IAxWinAmbientDispatch_, @pAmbientDisp)
      IF pAmbientDisp THEN
         pAmbientDisp->put_DocHostFlags(DOCHOSTUIFLAG_NO3DBORDER OR DOCHOSTUIFLAG_THEME OR DOCHOSTUIFLAG_DPI_AWARE)
         pAmbientDisp->Release
      END IF
   END IF
END PROPERTY
' ========================================================================================

I have needed to look at the source code to figure it because the MSDN documentation is very scarce and short. Just "[AtlAxGetHost] Obtains a direct interface pointer to the container for a specified window (if any), given its handle." Nothing more: no explanation of what you can do with this pointer, no examples.

I have started to write a new class, CAtlCon, that will replace COleCon and CWebBrowser. With just an instance of the class we will be able to work with many ActiveX controls at the same time. The handle of each control will differentiate them. As Atl.dll is a system component, it's use will also reduce the size of the executable.

Usage example:

Code: [Select]
   ' // Create  an instance of the CAtlCon class
   DIM pAtlCon AS CAtlCon
   ' // Add a web browser control
   DIM hWb AS HWND = pAtlCon.AddWebBrowser(@pWindow, IDC_ATLWIN)
   ' // Set the user interface capabilities of the host object
   pAtlCon.DocHostFlags(hWb) = DOCHOSTUIFLAG_NO3DBORDER OR DOCHOSTUIFLAG_THEME OR DOCHOSTUIFLAG_DPI_AWARE
   pAtlCon.WbNavigate(hWb, "https://forum.powerbasic.com/")

Title: Re: CWindow Release Candidate 31
Post by: Petrus Vorster on November 02, 2017, 01:59:04 PM
The stuff you come up with is staggering and mind boggling.
Insanely interesting but way above my best level of understanding.

Great stuff.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on November 04, 2017, 07:32:58 AM
It is going very well. In a day or two it will be finished. Much better that the former COleCon / CWebBrowser classes. Despite the scarce documentation and the lack of examples, I have managed to learn how this ATL container works. I have written an OLE container class, CAtlCon, that wraps the ATL.DLL procedures and the customization COM interface, and a WebBrowser class, CWebCtx, that extends CAtlCon and implements wrappers for all the IWebBrowser2 interface and several of the most useful HTML interfaces. What remains to do is a class for events sink and a couple of additional wrappers for using unregistered and/or licensed ActiveX controls.

I just have finished a function to allow keyboard navigation that works perfectly. I have had problems with that during many years. One could use SendMessage to send an special message to the control in the message pump, but it was impractical if you use several controls. Besides, once the focus was caught by a web page, there was not way to exit from it using the tab key. Now it works seamless and honoring the z order.

Code: [Select]
' ========================================================================================
' Forwards the message to the control. Active in-place objects must always be given the
' first chance at translating accelerator keystrokes.
' Usage example:
'   ' // Dispatch Windows messages
'   DIM uMsg AS MSG
'   WHILE (GetMessageW(@uMsg, NULL, 0, 0) <> FALSE)
'      IF AtlForwardMessage(GetFocus, @uMsg) = FALSE THEN
'         IF IsDialogMessageW(hWndMain, @uMsg) = 0 THEN
'            TranslateMessage(@uMsg)
'            DispatchMessageW(@uMsg)
'         END IF
'      END IF
'   WEND
' Note: WM_FORWARDMSG = &H37F ' (895)
' ========================================================================================
PRIVATE FUNCTION AtlForwardMessage (BYVAL hctl AS HWND, BYVAL pMsg AS tagMsg PTR) AS BOOLEAN
   IF (pMsg->message < WM_KEYFIRST OR pMsg->message > WM_KEYLAST) AND _
      (pMsg->message < WM_MOUSEFIRST OR pMsg->message > WM_MOUSELAST) THEN RETURN FALSE
   DIM hwnd AS HWND = hctl
   DIM wszClassName AS WSTRING * 260
   WHILE (GetWindowLongPtrW(hwnd, GWL_STYLE) AND WS_CHILD)
      IF (GetWindowLongPtrW(hwnd, GWL_EXSTYLE) AND WS_EX_MDICHILD) THEN EXIT WHILE
      GetClassNameW hwnd, wszClassName, SIZEOF(wszClassName)
      IF wszClassName = "AtlAxWin" THEN EXIT WHILE
      hwnd = GetParent(hwnd)
   WEND
   IF wszClassName <> "AtlAxWin" THEN RETURN FALSE
   RETURN SendMessageW(hwnd, &H37F, 0, cast(LPARAM, pMsg))
END FUNCTION
' ========================================================================================

I had tried many variations of similar code and never managed to get the perfect combination, but I'm persistent.
Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on November 04, 2017, 08:43:12 AM
...but I'm persistent.

You are the most persistent person I know!
Title: Re: CWindow Release Candidate 31
Post by: Petrus Vorster on November 05, 2017, 03:29:34 AM
Quote
I have had problems with that during many years.
It's really hard to believe Josč had a code problem for "many years".  ;D
When all this stuff finally comes together with that designer of Paul, no tears will ever be wept for the loss of Powerbasic.

Title: Re: CWindow Release Candidate 31
Post by: Jean-pierre Leroy on November 05, 2017, 10:16:31 AM
Excellent Petrus  :D
Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on November 05, 2017, 05:05:24 PM
OMG, Peter that's epic!  :)
Title: Re: CWindow Release Candidate 31
Post by: José Roca on November 06, 2017, 08:52:47 AM
Love it! :) Exaggerated but friendly.
Title: Re: CWindow Release Candidate 31
Post by: Petrus Vorster on November 06, 2017, 12:16:57 PM
LOL, man, where would we be without you?
You are way too modest.
If this forum were for martial arts, you would be Bruce Lee.

Thought you guys may find it funny.  :D
Title: Re: CWindow Release Candidate 31
Post by: José Roca on November 11, 2017, 04:01:31 PM
ATL.DLL is a dead way. Although works fine to host the WebBrowser control, it works very badly with other ActiveX controls.

The good news is that I have made another OLE container, CAxHost, that works very well. When i wrote COleCon, I didn't know how to write a true COM class with FreeBasic. This new container uses reference counted COM classes with automatic creation and self destruction.

Now I will adapt the WebBrowser class to work with the new container and modify the templates and examples.

After this, the only item in my list of unresolved problems is the failure to create a domain with the NET hosting class.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on November 14, 2017, 12:24:49 PM
I have finished the work. ColeCon and CWebBrowser are now history, having been replaced by CAxHost and CWebCtx. I have also have modified the examples and templates.

I think that it is time to leave the release candidate versions and post the first version of the WinFBX framework. WinFBX means Windows FreeBasic Extensions and it has been chosen to highlight its ties with the WinFBE editor. It can be used with other editors, but WinFBE makes its use easier.
Title: Re: CWindow Release Candidate 31
Post by: Paul Squires on November 14, 2017, 04:12:11 PM
That's great news Jose! Congratulations on making it to Version 1, although with everything that's in this package it feels more like version 10!  :)
Title: Re: CWindow Release Candidate 31
Post by: ganlinlao on November 15, 2017, 12:22:19 AM
wow , Jose,thank you very much! :)
Title: Re: CWindow Release Candidate 31
Post by: ganlinlao on November 19, 2017, 03:16:06 AM
hi, jose
Error in compiling example mothviews. There is an error in axhost.inc
Title: Re: CWindow Release Candidate 31
Post by: José Roca on November 19, 2017, 07:51:05 AM
In fact it is a bug in the version 1.05 of the compiler. You can download version 1.06 at http://users.freebasic-portal.de/stw/builds/ or change pAxHost->m_bInPlaceActive = FALSE to CLNG(pAxHost->m_bInPlaceActive) = FALSE.

The other error is caused by a change in Put from a function to a property. Use this code:

Code: [Select]
' ########################################################################################
' Microsoft Windows
' Contents: Embedded MonthView Calendar OCX
' Compiler: FreeBasic 32 & 64 bit
' Copyright (c) 2016 Jose Roca. Freeware. Use at your own risk.
' THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
' EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE IMPLIED WARRANTIES OF
' MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
' ########################################################################################

#define UNICODE
#INCLUDE ONCE "Afx/CAxHost/CAxHost.inc"
#INCLUDE ONCE "Afx/CDispInvoke.inc"
#INCLUDE ONCE "Afx/AfxCOM.inc"
USING Afx

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)

DECLARE FUNCTION WndProc (BYVAL hwnd AS HWND, BYVAL uMsg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM) AS LRESULT

CONST IDC_MONTHVIEW = 1001

' ========================================================================================
' 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
   ' // The recommended way is to use a manifest file
   AfxSetProcessDPIAware

   ' // Creates the main window
   DIM pWindow AS CWindow
   ' -or- DIM pWindow AS CWindow = "MyClassName" (use the name that you wish)
   DIM hwndMain AS HWND = pWindow.Create(NULL, "CAxHost - Embedded MonthView Calendar OCX", @WndProc)
   ' // Sizes it by setting the wanted width and height of its client area
   pWindow.SetClientSize(580, 360)
   ' // Centers the window
   pWindow.Center

   DIM wszLibName AS WSTRING * 260 = ExePath & "\MSCOMCT2.OCX"
   DIM CLSID_MSComCtl2_MonthView AS CLSID = (&h232E456A, &h87C3, &h11D1, {&h8B, &hE3,&h00, &h00, &hF8, &h75, &h4D, &hA1})
   DIM IID_MSComCtl2_MonthView AS CLSID = (&h232E4565, &h87C3, &h11D1, {&h8B, &hE3,&h00, &h00, &hF8, &h75, &h4D, &hA1})
   DIM RTLKEY_MSCOMCT2 AS WSTRING * 260 = "651A8940-87C5-11d1-8BE3-0000F8754DA1"

   DIM pHost AS CAxHost = CAxHost(@pWindow, IDC_MONTHVIEW, wszLibName, CLSID_MSComCtl2_MonthView, _
       IID_MSComCtl2_MonthView, RTLKEY_MSCOMCT2, 0, 0, pWindow.ClientWidth, pWindow.ClientHeight)
   DIM hCtl AS HWND = GetDlgItem(pWindow.hWindow, IDC_MONTHVIEW)

'   SetFocus pHost.hWindow

   DIM pdisp AS CDispInvoke = pHost.OcxDispObj
   pdisp.Put("Year") = 1985
   pdisp.Put("Month") = 1
   pdisp.Put("Day") = 21

   ' // Display the window
   ShowWindow(hwndMain, nCmdShow)
   UpdateWindow(hwndMain)

   ' // Dispatch Windows messages
   DIM uMsg AS MSG
   WHILE (GetMessageW(@uMsg, NULL, 0, 0) <> FALSE)
      IF AfxCAxHostForwardMessage(GetFocus, @uMsg) = FALSE THEN
         IF IsDialogMessageW(hwndMain, @uMsg) = 0 THEN
            TranslateMessage(@uMsg)
            DispatchMessageW(@uMsg)
         END IF
      END IF
   WEND
   FUNCTION = uMsg.wParam

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

' ========================================================================================
' Main window procedure
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS HWND, BYVAL uMsg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM) AS LRESULT

   SELECT CASE uMsg

      CASE WM_COMMAND
         SELECT CASE LOWORD(wParam)
            CASE IDCANCEL
               ' // If ESC key pressed, close the application by sending an WM_CLOSE message
               IF HIWORD(wParam) = BN_CLICKED THEN
                  SendMessageW hwnd, WM_CLOSE, 0, 0
                  EXIT FUNCTION
               END IF
         END SELECT

      CASE WM_SIZE
         ' // Optional resizing code
         IF wParam <> SIZE_MINIMIZED THEN
            ' // Retrieve a pointer to the CWindow class
            DIM pWindow AS CWindow PTR = AfxCWindowPtr(hwnd)
            ' // Move the position of the button
            IF pWindow THEN pWindow->MoveWindow GetDlgItem(hwnd, IDC_MONTHVIEW), _
               0, 0, pWindow->ClientWidth, pWindow->ClientHeight, CTRUE
         END IF

    CASE WM_DESTROY
         ' // Ends the application by sending a WM_QUIT message
         PostQuitMessage(0)
         EXIT FUNCTION

   END SELECT

   ' // Default processing of Windows messages
   FUNCTION = DefWindowProcW(hwnd, uMsg, wParam, lParam)

END FUNCTION
' ========================================================================================
Title: Re: CWindow Release Candidate 31
Post by: José Roca on November 19, 2017, 08:04:34 AM
If you're going to try the old VB6 OCXs, here is an example for the masked edit control.

Code: [Select]
' ########################################################################################
' Microsoft Windows
' Contents: Embedded Microsoft Masked Edit Control
' Compiler: FreeBasic 32 & 64 bit
' Copyright (c) 2017 Jose Roca. Freeware. Use at your own risk.
' THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
' EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE IMPLIED WARRANTIES OF
' MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
' ########################################################################################

#define UNICODE
#INCLUDE ONCE "Afx/CAxHost/CAxHost.inc"
#INCLUDE ONCE "Afx/CDispInvoke.inc"
#INCLUDE ONCE "Afx/AfxCOM.inc"
USING Afx

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)

DECLARE FUNCTION WndProc (BYVAL hwnd AS HWND, BYVAL uMsg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM) AS LRESULT

CONST IDC_MSMASK1 = 1001
CONST IDC_MSMASK2 = 1002

' ========================================================================================
' 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
   ' // The recommended way is to use a manifest file
   AfxSetProcessDPIAware

   ' // Creates the main window
   DIM pWindow AS CWindow
   ' -or- DIM pWindow AS CWindow = "MyClassName" (use the name that you wish)
   DIM hwndMain AS HWND = pWindow.Create(NULL, "Masked Edit Control", @WndProc)
   ' // Sizes it by setting the wanted width and height of its client area
   pWindow.SetClientSize(200, 80)
   ' // Centers the window
   pWindow.Center

   DIM wszLibName AS WSTRING * 260 = ExePath & "\MSMASK32.OCX"
   DIM CLSID_MaskEdBox AS CLSID = (&hC932BA85, &h4374, &h101B, {&hA5, &h6C, &h00, &hAA, &h00, &h36, &h68, &hDC})
   DIM IID_IMSMask AS IID = (&h4D6CC9A0, &hDF77, &h11CF, {&h8E, &h74, &h00, &hA0, &hC9, &h0F, &h26, &hF8})
   DIM RTLKEY_MaskEdBox AS WSTRING * 260 = "BC96F860-9928-11cf-8AFA-00AA00C00905"

   DIM pHost AS CAxHost = CAxHost(@pWindow, IDC_MSMASK1, wszLibName, CLSID_MaskEdBox, _
       IID_IMSMask, RTLKEY_MaskEdBox, 10, 10, pWindow.ClientWidth - 20, 22)
   DIM pHost2 AS CAxHost = CAxHost(@pWindow, IDC_MSMASK2, wszLibName, CLSID_MaskEdBox, _
       IID_IMSMask, RTLKEY_MaskEdBox, 10, 45, pWindow.ClientWidth - 20, 22)
   SetFocus pHost.hWindow

   DIM pdisp AS CDispInvoke = pHost.OcxDispObj
   ' Set the fore and back colors
   pdisp.Put("ForeColor") = BGR(0, 0, 255)
   ' Set the mask
   pdisp.Put("Mask") = "(###) - ### - ####"

   DIM pdisp2 AS CDispInvoke = pHost2.OcxDispObj
   ' Set the fore and back colors
   pdisp2.Put("ForeColor") = BGR(255, 0, 0)
   pdisp2.Put("BackColor") = BGR(255, 255, 0)
   ' Set the mask
   pdisp2.Put("Mask") = "(###) - ### - ####"

   ' // Display the window
   ShowWindow(hwndMain, nCmdShow)
   UpdateWindow(hwndMain)

   ' // Dispatch Windows messages
   DIM uMsg AS MSG
   WHILE (GetMessageW(@uMsg, NULL, 0, 0) <> FALSE)
      IF AfxCAxHostForwardMessage(GetFocus, @uMsg) = FALSE THEN
         IF IsDialogMessageW(hwndMain, @uMsg) = 0 THEN
            TranslateMessage(@uMsg)
            DispatchMessageW(@uMsg)
         END IF
      END IF
   WEND
   FUNCTION = uMsg.wParam

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

' ========================================================================================
' Main window procedure
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS HWND, BYVAL uMsg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM) AS LRESULT

   SELECT CASE uMsg

      CASE WM_COMMAND
         SELECT CASE LOWORD(wParam)
            CASE IDCANCEL
               ' // If ESC key pressed, close the application by sending an WM_CLOSE message
               IF HIWORD(wParam) = BN_CLICKED THEN
                  SendMessageW hwnd, WM_CLOSE, 0, 0
                  EXIT FUNCTION
               END IF
         END SELECT

      CASE WM_SIZE
         ' // Optional resizing code
         IF wParam <> SIZE_MINIMIZED THEN
            ' // Retrieve a pointer to the CWindow class
            DIM pWindow AS CWindow PTR = AfxCWindowPtr(hwnd)
            ' // Move the position of the controls
            IF pWindow THEN pWindow->MoveWindow GetDlgItem(hwnd, IDC_MSMASK1), _
               10, 10, pWindow->ClientWidth - 20, 22, CTRUE
            IF pWindow THEN pWindow->MoveWindow GetDlgItem(hwnd, IDC_MSMASK2), _
               10, 45, pWindow->ClientWidth - 20, 22, CTRUE
         END IF

    CASE WM_DESTROY
         ' // Ends the application by sending a WM_QUIT message
         PostQuitMessage(0)
         EXIT FUNCTION

   END SELECT

   ' // Default processing of Windows messages
   FUNCTION = DefWindowProcW(hwnd, uMsg, wParam, lParam)

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

Please note that these examples are for testing purposes and use the a registration free technique (I don't have any of them registered). If they are registered and licensed, you can use the constructor that accepts a ProgID. As with my previous OLE containers, some will work a some won't. VB6 used the form as an OLE container and implemented interfaces (some not standard) to build complex controls that contain other controls, and even arrays of controls. These are outside the purpose of my modest OLE container. I wanted to use ATL.DLL, but it works very badly.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on November 19, 2017, 10:24:58 AM
CDispInvoke.inc

I have changed Put and PutRef to a properties, but as FreeBasic doesn't accept more than a parameter in properties, I also have added the Set and SetRef functions with up to two index parameters (I think that two are enough; we could add more if needed).

But whereas Put and PutRef will allow this syntax:

pdisp.Put ("property name") = value

being a function, with Set and SetRef you will have to use

pdisp.Set ("property name", index[es], value)
Title: Re: CWindow Release Candidate 31
Post by: José Roca on November 19, 2017, 01:02:09 PM
I have added another overloaded PutRef property. Only when testing you find the convenience of additions to ease its use.

Code: [Select]
' ========================================================================================
PRIVATE PROPERTY CDispInvoke.PutRef (BYVAL dispID AS DISPID, BYVAL pv AS ANY PTR)
   CDISPINVOKE_DP("CDISPINVOKE DispInvoke.PutRef - DISPID - ANY PTR")
   DIM cvArg AS CVAR = CVAR(CAST(IUnknown PTR, pv), TRUE)
   SetResult(this.DispInvoke(DISPATCH_PROPERTYPUTREF, dispID, cvArg, 1, m_lcid))
END PROPERTY
' ========================================================================================
' ========================================================================================
PRIVATE PROPERTY CDispInvoke.PutRef (BYVAL pwszName AS WSTRING PTR, BYVAL pv AS ANY PTR)
   CDISPINVOKE_DP("CDISPINVOKE DispInvoke.PutRef - Name - ANY PTR")
   DIM cvArg AS CVAR = CVAR(CAST(IUnknown PTR, pv), TRUE)
   SetResult(this.DispInvoke(DISPATCH_PROPERTYPUTREF, pwszName, cvArg, 1, m_lcid))
END PROPERTY
' ========================================================================================

Preparing the test for the Microsoft Hierarchical Control (see below) I needed it to set a pointer to the data source.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on November 19, 2017, 01:08:23 PM
Two of the Microsoft grid controls, the Flex Grid and the Hierarchical Flex Grid work well with my OLE container, and because they use twips, they're DPI aware. It is a pity that they are only 32 bit. Maybe I will write classes to ease its use and add events.

Test for the Microsoft Hierarchical Grid Control:

Code: [Select]
' ########################################################################################
' Microsoft Windows
' Contents: Embedded Microsoft Hierarchical Grid Control
' Compiler: FreeBasic 32 & 64 bit
' Copyright (c) 2017 Jose Roca. Freeware. Use at your own risk.
' THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
' EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE IMPLIED WARRANTIES OF
' MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
' ########################################################################################

#define UNICODE
#INCLUDE ONCE "Afx/AfxCOM.inc"
#INCLUDE ONCE "Afx/CAxHost/CAxHost.inc"
#INCLUDE ONCE "Afx/CDispInvoke.inc"
#INCLUDE ONCE "Afx/CADODB/CADODB.inc"
USING Afx

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)

DECLARE FUNCTION WndProc (BYVAL hwnd AS HWND, BYVAL uMsg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM) AS LRESULT

CONST IDC_GRID = 1001

' ========================================================================================
' 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
   ' // The recommended way is to use a manifest file
   AfxSetProcessDPIAware

   ' // Creates the main window
   DIM pWindow AS CWindow
   ' -or- DIM pWindow AS CWindow = "MyClassName" (use the name that you wish)
   DIM hwndMain AS HWND = pWindow.Create(NULL, "Microsoft Hierarchical Flex Grid", @WndProc)
   ' // Sizes it by setting the wanted width and height of its client area
   pWindow.SetClientSize(800, 450)
   ' // Centers the window
   pWindow.Center

   DIM wszLibName AS WSTRING * 260 = ExePath & "\MSHFLXGD.OCX"
   DIM CLSID_MSHFlexGrid AS CLSID = (&h0ECD9B64, &h23AA, &h11D0, {&hB3, &h51, &h00, &hA0, &hC9, &h05, &h5D, &h8E})
   DIM IID_IMSHFlexGrid AS IID = (&h0ECD9B62, &h23AA, &h11D0, {&hB3, &h51, &h00, &hA0, &hC9, &h05, &h5D, &h8E})
   DIM RTLKEY_MSHFlexGrid AS WSTRING * 260 = "1F3D5522-3F42-11d1-B2FA-00A0C908FB55"

   DIM pHost AS CAxHost = CAxHost(@pWindow, IDC_GRID, wszLibName, CLSID_MSHFlexGrid, _
       IID_IMSHFlexGrid, RTLKEY_MSHFlexGrid, 0, 0, pWindow.ClientWidth, pWindow.ClientHeight)
   SetFocus pHost.hWindow

   DIM pGrid AS CDispInvoke = pHost.OcxDispObj
   ' Change the width of the columns (measures are in twips)
   ' The first parameter is the grid's pointer reference,
   ' the second the column index, and the third the col width.
   pGrid.Set("ColWidth", 0, 0, 300)
   pGrid.Set("ColWidth", 1, 0, 1100)
   pGrid.Set("ColWidth", 2, 0, 3000)
   pGrid.Set("ColWidth", 3, 0, 2000)
   pGrid.Set("ColWidth", 4, 0, 2000)
   pGrid.Set("ColWidth", 5, 0, 3000)
   pGrid.Set("ColWidth", 6, 0, 1500)
   pGrid.Set("ColWidth", 7, 0, 700)
   pGrid.Set("ColWidth", 8, 0, 1200)
   pGrid.Set("ColWidth", 9, 0, 1200)
   pGrid.Set("ColWidth", 10, 0, 1500)
   pGrid.Set("ColWidth", 11, 0, 1500)

   ' Change the foreground and background colors
   pGrid.Put("ForeColor") = BGR(0, 0, 0)
   pGrid.Put("BackColor") = BGR(255,255,235)

   ' Open an ADO connection
   DIM pConnection AS CAdoConnection PTR = NEW CAdoConnection
   pConnection->ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ExePath & $"\nwind.mdb"
   pConnection->Open
   ' Open a recordset
   DIM pRecordset AS CAdoRecordset PTR = NEW CAdoRecordset
   DIM cvSource AS CVAR = "SELECT * FROM Customers"
   pRecordset->Open(cvSource, pConnection, adOpenKeyset, adLockOptimistic, adCmdText)
   ' Set the Datasource property of the recordset
   pGrid.PutRef("DataSource") = pRecordset->DataSource
   ' Close the recordset
   pRecordset->Close
   ' Close the connection
   pConnection->Close
   ' // Delete the recordset
   Delete pRecordset
   ' // Delete the connection
   Delete pConnection

   ' // Display the window
   ShowWindow(hwndMain, nCmdShow)
   UpdateWindow(hwndMain)

   ' // Dispatch Windows messages
   DIM uMsg AS MSG
   WHILE (GetMessageW(@uMsg, NULL, 0, 0) <> FALSE)
      IF AfxCAxHostForwardMessage(GetFocus, @uMsg) = FALSE THEN
         IF IsDialogMessageW(hwndMain, @uMsg) = 0 THEN
            TranslateMessage(@uMsg)
            DispatchMessageW(@uMsg)
         END IF
      END IF
   WEND
   FUNCTION = uMsg.wParam

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

' ========================================================================================
' Main window procedure
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS HWND, BYVAL uMsg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM) AS LRESULT

   SELECT CASE uMsg

      CASE WM_COMMAND
         SELECT CASE LOWORD(wParam)
            CASE IDCANCEL
               ' // If ESC key pressed, close the application by sending an WM_CLOSE message
               IF HIWORD(wParam) = BN_CLICKED THEN
                  SendMessageW hwnd, WM_CLOSE, 0, 0
                  EXIT FUNCTION
               END IF
         END SELECT

      CASE WM_SIZE
         ' // Optional resizing code
         IF wParam <> SIZE_MINIMIZED THEN
            ' // Retrieve a pointer to the CWindow class
            DIM pWindow AS CWindow PTR = AfxCWindowPtr(hwnd)
            ' // Move the position of the button
            IF pWindow THEN pWindow->MoveWindow GetDlgItem(hwnd, IDC_GRID), _
               0, 0, pWindow->ClientWidth, pWindow->ClientHeight, CTRUE
         END IF

    CASE WM_DESTROY
         ' // Ends the application by sending a WM_QUIT message
         PostQuitMessage(0)
         EXIT FUNCTION

   END SELECT

   ' // Default processing of Windows messages
   FUNCTION = DefWindowProcW(hwnd, uMsg, wParam, lParam)

END FUNCTION
' ========================================================================================
Title: Re: CWindow Release Candidate 31
Post by: José Roca on November 19, 2017, 01:50:13 PM
Test for the Microsoft Flex Grid Control:

Code: [Select]
' ########################################################################################
' Microsoft Windows
' Contents: Embedded Microsoft Flex Grid Control
' Compiler: FreeBasic 32 & 64 bit
' Copyright (c) 2017 Jose Roca. Freeware. Use at your own risk.
' THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
' EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE IMPLIED WARRANTIES OF
' MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
' ########################################################################################

#define UNICODE
#INCLUDE ONCE "Afx/AfxCOM.inc"
#INCLUDE ONCE "Afx/CAxHost/CAxHost.inc"
#INCLUDE ONCE "Afx/CDispInvoke.inc"
#INCLUDE ONCE "Afx/CADODB/CADODB.inc"
USING Afx

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)

DECLARE FUNCTION WndProc (BYVAL hwnd AS HWND, BYVAL uMsg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM) AS LRESULT

CONST IDC_GRID = 1001

' ========================================================================================
' 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
   ' // The recommended way is to use a manifest file
   AfxSetProcessDPIAware

   ' // Creates the main window
   DIM pWindow AS CWindow
   ' -or- DIM pWindow AS CWindow = "MyClassName" (use the name that you wish)
   DIM hwndMain AS HWND = pWindow.Create(NULL, "Microsoft Flex Grid", @WndProc)
   ' // Sizes it by setting the wanted width and height of its client area
   pWindow.SetClientSize(800, 450)
   ' // Centers the window
   pWindow.Center

   DIM wszLibName AS WSTRING * 260 = ExePath & "\Msflxgrd.ocx"
   DIM CLSID_MSFlexGrid AS CLSID = (&h6262D3A0, &h531B, &h11CF, {&h91, &hF6, &hC2, &h86, &h3C, &h38, &h5E, &h30})
   DIM IID_IMSFlexGrid AS IID = (&h5F4DF280, &h531B, &h11CF, {&h91, &hF6, &hC2, &h86, &h3C, &h38, &h5E, &h30})
   DIM RTLKEY_MSFlexGrid AS WSTRING * 260 = "72E67120-5959-11cf-91F6-C2863C385E30"

   DIM pHost AS CAxHost = CAxHost(@pWindow, IDC_GRID, wszLibName, CLSID_MSFlexGrid, _
       IID_IMSFlexGrid, RTLKEY_MSFlexGrid, 0, 0, pWindow.ClientWidth, pWindow.ClientHeight)
   SetFocus pHost.hWindow

   ' Open an ADO connection
   DIM pConnection AS CAdoConnection PTR = NEW CAdoConnection
   pConnection->ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ExePath & $"\nwind.mdb"
   pConnection->Open
   ' Open a recordset
   DIM pRecordset AS CAdoRecordset PTR = NEW CAdoRecordset
   DIM cvSource AS CVAR = "SELECT * FROM Customers"
   pRecordset->Open(cvSource, pConnection, adOpenKeyset, adLockOptimistic, adCmdText)
   ' Move to the last record
   pRecordset->MoveLast

   ' Set the number of grid rows and columns
   DIM pGrid AS CDispInvoke = pHost.OcxDispObj
   pGrid.Put("Rows") = pRecordset->RecordCount + 1
   pGrid.Put("Cols") = 12

   ' Set the headers
   pGrid.Set("TextMatrix", 0,  1, "Customer ID")
   pGrid.Set("TextMatrix", 0,  2, "Company Name")
   pGrid.Set("TextMatrix", 0,  3, "Contact Name")
   pGrid.Set("TextMatrix", 0,  4, "Contact Title")
   pGrid.Set("TextMatrix", 0,  5, "Address")
   pGrid.Set("TextMatrix", 0,  6, "City")
   pGrid.Set("TextMatrix", 0,  7, "Region")
   pGrid.Set("TextMatrix", 0,  8, "Postal Code")
   pGrid.Set("TextMatrix", 0,  9, "Country")
   pGrid.Set("TextMatrix", 0,  10, "Phone")
   pGrid.Set("TextMatrix", 0,  11, "Fax")

   ' Change the width of the columns (measures are in twips)
   pGrid.Set("ColWidth", 0, 300)
   pGrid.Set("ColWidth", 1, 1100)
   pGrid.Set("ColWidth", 2, 3000)
   pGrid.Set("ColWidth", 3, 2000)
   pGrid.Set("ColWidth", 4, 2000)
   pGrid.Set("ColWidth", 5, 3000)
   pGrid.Set("ColWidth", 6, 1500)
   pGrid.Set("ColWidth", 7, 700)
   pGrid.Set("ColWidth", 8, 1200)
   pGrid.Set("ColWidth", 9, 1200)
   pGrid.Set("ColWidth", 10, 1500)
   pGrid.Set("ColWidth", 11, 1500)

   ' Allow to resize columns
   pGrid.Put("AllowUserResizing") = 1   ' flexResizeColumns

   ' Change the foreground and background colors
   pGrid.Put("ForeColor") = BGR(0, 0, 0)
   pGrid.Put("BackColor") = BGR(255,255,235)

   ' Move to the first record
   pRecordset->MoveFirst
   ' Parse the recordset and fill the grid
   DIM row AS LONG = 1
   WHILE NOT pRecordset->EOF
      'Select the row
      pGrid.Put("Row") = row
      ' Set the content of cell 1
      pGrid.Put("Col") = 1
      pGrid.Put("CellAlignment") = 1   ' flexAlignLeftCenter
      pGrid.Put("Text") = pRecordset->Collect("CustomerID")
      ' Set the content of cell 2
      pGrid.Put("Col") = 2
      pGrid.Put("CellAlignment") = 1   ' flexAlignLeftCenter
      pGrid.Put("Text") = pRecordset->Collect("CompanyName")
      ' Set the content of cell 3
      pGrid.Put("Col") = 3
      pGrid.Put("CellAlignment") = 1   ' flexAlignLeftCenter
      pGrid.Put("Text") = pRecordset->Collect("ContactName")
      ' Set the content of cell 4
      pGrid.Put("Col") = 4
      pGrid.Put("CellAlignment") = 1   ' flexAlignLeftCenter
      pGrid.Put("Text") = pRecordset->Collect("ContactTitle")
      ' Set the content of cell 5
      pGrid.Put("Col") = 5
      pGrid.Put("CellAlignment") = 1   ' flexAlignLeftCenter
      pGrid.Put("Text") = pRecordset->Collect("Address")
      ' Set the content of cell 6
      pGrid.Put("Col") = 6
      pGrid.Put("CellAlignment") = 1   ' flexAlignLeftCenter
      pGrid.Put("Text") = pRecordset->Collect("City")
      ' Set the content of cell 7
      pGrid.Put("Col") = 7
      pGrid.Put("CellAlignment") = 1   ' flexAlignLeftCenter
      pGrid.Put("Text") = pRecordset->Collect("Region")
      ' Set the content of cell 8
      pGrid.Put("Col") = 8
      pGrid.Put("CellAlignment") = 1   ' flexAlignLeftCenter
      pGrid.Put("Text") = pRecordset->Collect("PostalCode")
      ' Set the content of cell 9
      pGrid.Put("Col") = 9
      pGrid.Put("CellAlignment") = 1   ' flexAlignLeftCenter
      pGrid.Put("Text") = pRecordset->Collect("Country")
      ' Set the content of cell 10
      pGrid.Put("Col") = 10
      pGrid.Put("CellAlignment") = 1   ' flexAlignLeftCenter
      pGrid.Put("Text") = pRecordset->Collect("Phone")
      ' Set the content of cell 11
      pGrid.Put("Col") = 11
      pGrid.Put("CellAlignment") = 1   ' flexAlignLeftCenter
      pGrid.Put("Text") = pRecordset->Collect("Fax")
      ' Fetch the next row
      pRecordset->MoveNext
      ' Increment the counter
      row += 1
   WEND

   ' Select the first cell
   pGrid.Put("Row") = 1
   pGrid.Put("Col") = 1

   ' Close the recordset
   pRecordset->Close
   ' Close the connection
   pConnection->Close
   ' // Delete the recordset
   Delete pRecordset
   ' // Delete the connection
   Delete pConnection

   ' // Display the window
   ShowWindow(hwndMain, nCmdShow)
   UpdateWindow(hwndMain)

   ' // Dispatch Windows messages
   DIM uMsg AS MSG
   WHILE (GetMessageW(@uMsg, NULL, 0, 0) <> FALSE)
      IF AfxCAxHostForwardMessage(GetFocus, @uMsg) = FALSE THEN
         IF IsDialogMessageW(hwndMain, @uMsg) = 0 THEN
            TranslateMessage(@uMsg)
            DispatchMessageW(@uMsg)
         END IF
      END IF
   WEND
   FUNCTION = uMsg.wParam

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

' ========================================================================================
' Main window procedure
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS HWND, BYVAL uMsg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM) AS LRESULT

   SELECT CASE uMsg

      CASE WM_COMMAND
         SELECT CASE LOWORD(wParam)
            CASE IDCANCEL
               ' // If ESC key pressed, close the application by sending an WM_CLOSE message
               IF HIWORD(wParam) = BN_CLICKED THEN
                  SendMessageW hwnd, WM_CLOSE, 0, 0
                  EXIT FUNCTION
               END IF
         END SELECT

      CASE WM_SIZE
         ' // Optional resizing code
         IF wParam <> SIZE_MINIMIZED THEN
            ' // Retrieve a pointer to the CWindow class
            DIM pWindow AS CWindow PTR = AfxCWindowPtr(hwnd)
            ' // Move the position of the button
            IF pWindow THEN pWindow->MoveWindow GetDlgItem(hwnd, IDC_GRID), _
               0, 0, pWindow->ClientWidth, pWindow->ClientHeight, CTRUE
         END IF

    CASE WM_DESTROY
         ' // Ends the application by sending a WM_QUIT message
         PostQuitMessage(0)
         EXIT FUNCTION

   END SELECT

   ' // Default processing of Windows messages
   FUNCTION = DefWindowProcW(hwnd, uMsg, wParam, lParam)

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

I thik that CDispInvoke has become easier to use than DispHelper, and without having to use a third party C++ DLL.
Title: Re: CWindow Release Candidate 31
Post by: José Roca on November 19, 2017, 05:14:02 PM
Test for the Microsoft DataList Control

Code: [Select]
' ########################################################################################
' Microsoft Windows
' Contents: Microsoft Data List Control
' Compiler: FreeBasic 32 & 64 bit
' Copyright (c) 2017 Jose Roca. Freeware. Use at your own risk.
' THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
' EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE IMPLIED WARRANTIES OF
' MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
' ########################################################################################

#define UNICODE
#INCLUDE ONCE "Afx/AfxCOM.inc"
#INCLUDE ONCE "Afx/CAxHost/CAxHost.inc"
#INCLUDE ONCE "Afx/CDispInvoke.inc"
#INCLUDE ONCE "Afx/CADODB/CADODB.inc"
USING Afx

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)

DECLARE FUNCTION WndProc (BYVAL hwnd AS HWND, BYVAL uMsg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM) AS LRESULT

CONST IDC_DATALIST = 1001

' ========================================================================================
' 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
   ' // The recommended way is to use a manifest file
   AfxSetProcessDPIAware

   ' // Creates the main window
   DIM pWindow AS CWindow
   ' -or- DIM pWindow AS CWindow = "MyClassName" (use the name that you wish)
   DIM hwndMain AS HWND = pWindow.Create(NULL, "Microsoft Data List Control", @WndProc)
   ' // Sizes it by setting the wanted width and height of its client area
   pWindow.SetClientSize(300, 350)
   ' // Centers the window
   pWindow.Center

   DIM wszLibName AS WSTRING * 260 = ExePath & "\MSDATLST.OCX"
   DIM CLSID_DataList AS CLSID = (&hF0D2F219, &hCCB0, &h11D0, {&hA3, &h16, &h00, &hAA, &h00, &h68, &h8B, &h10})
   DIM IID_IDataList AS IID = (&hF0D2F217, &hCCB0, &h11D0, {&hA3, &h16, &h00, &hAA, &h00, &h68, &h8B, &h10})
   DIM RTLKEY_DATALIST AS WSTRING * 260 = "A133F000-CCB0-11d0-A316-00AA00688B10"

   DIM pHost AS CAxHost = CAxHost(@pWindow, IDC_DATALIST, wszLibName, CLSID_DataList, _
       IID_IDataList, RTLKEY_DATALIST, 0, 0, pWindow.ClientWidth, pWindow.ClientHeight)
   SetFocus pHost.hWindow

   ' Get a reference to the DataList object
   DIM pDataList AS CDispInvoke = pHost.OcxDispObj
   ' Change the foreground and background colors
   pDataList.Put("ForeColor") = BGR(0, 0, 0)
   pDataList.Put("BackColor") = BGR(255,255,235)

   ' Open an ADO connection
   DIM pConnection AS CAdoConnection PTR = NEW CAdoConnection
   pConnection->ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ExePath & $"\Biblio.mdb"
   pConnection->Open
   ' Open a recordset
   DIM pRecordset AS CAdoRecordset PTR = NEW CAdoRecordset
   DIM cvSource AS CVAR = "SELECT * FROM Publishers ORDER BY Name"
   pRecordset->Open(cvSource, pConnection, adOpenKeyset, adLockOptimistic, adCmdText)
   ' Set the recordset to the control
   pDataList.PutRef("RowSource") = pRecordset->DataSource
   pDataList.Put("ListField") = "Name"

   ' // Display the window
   ShowWindow(hwndMain, nCmdShow)
   UpdateWindow(hwndMain)

   ' // Dispatch Windows messages
   DIM uMsg AS MSG
   WHILE (GetMessageW(@uMsg, NULL, 0, 0) <> FALSE)
      IF AfxCAxHostForwardMessage(GetFocus, @uMsg) = FALSE THEN
         IF IsDialogMessageW(hwndMain, @uMsg) = 0 THEN
            TranslateMessage(@uMsg)
            DispatchMessageW(@uMsg)
         END IF
      END IF
   WEND
   FUNCTION = uMsg.wParam

   ' Close the recordset
   pRecordset->Close
   ' Close the connection
   pConnection->Close
   ' // Delete the recordset
   Delete pRecordset
   ' // Delete the connection
   Delete pConnection

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

' ========================================================================================
' Main window procedure
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS HWND, BYVAL uMsg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM) AS LRESULT

   SELECT CASE uMsg

      CASE WM_COMMAND
         SELECT CASE LOWORD(wParam)
            CASE IDCANCEL
               ' // If ESC key pressed, close the application by sending an WM_CLOSE message
               IF HIWORD(wParam) = BN_CLICKED THEN
                  SendMessageW hwnd, WM_CLOSE, 0, 0
                  EXIT FUNCTION
               END IF
         END SELECT

      CASE WM_SIZE
         ' // Optional resizing code
         IF wParam <> SIZE_MINIMIZED THEN
            ' // Retrieve a pointer to the CWindow class
            DIM pWindow AS CWindow PTR = AfxCWindowPtr(hwnd)
            ' // Move the position of the button
            IF pWindow THEN pWindow->MoveWindow GetDlgItem(hwnd, IDC_DATALIST), _
               0, 0, pWindow->ClientWidth, pWindow->ClientHeight, CTRUE
         END IF

    CASE WM_DESTROY
         ' // Ends the application by sending a WM_QUIT message
         PostQuitMessage(0)
         EXIT FUNCTION

   END SELECT

   ' // Default processing of Windows messages
   FUNCTION = DefWindowProcW(hwnd, uMsg, wParam, lParam)

END FUNCTION
' ========================================================================================
Title: Re: CWindow Release Candidate 31
Post by: José Roca on November 19, 2017, 05:26:09 PM
Test for the Microsoft Data Combo Control

Code: [Select]
' ########################################################################################
' Microsoft Windows
' Contents: Microsoft Data Combo Control
' Compiler: FreeBasic 32 & 64 bit
' Copyright (c) 2017 Jose Roca. Freeware. Use at your own risk.
' THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
' EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE IMPLIED WARRANTIES OF
' MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
' ########################################################################################

#define UNICODE
#INCLUDE ONCE "Afx/AfxCOM.inc"
#INCLUDE ONCE "Afx/CAxHost/CAxHost.inc"
#INCLUDE ONCE "Afx/CDispInvoke.inc"
#INCLUDE ONCE "Afx/CADODB/CADODB.inc"
USING Afx

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)

DECLARE FUNCTION WndProc (BYVAL hwnd AS HWND, BYVAL uMsg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM) AS LRESULT

CONST IDC_DATACOMBO = 1001

' ========================================================================================
' 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
   ' // The recommended way is to use a manifest file
   AfxSetProcessDPIAware

   ' // Creates the main window
   DIM pWindow AS CWindow
   ' -or- DIM pWindow AS CWindow = "MyClassName" (use the name that you wish)
   DIM hwndMain AS HWND = pWindow.Create(NULL, "Microsoft Data Combo Control", @WndProc)
   ' // Sizes it by setting the wanted width and height of its client area
   pWindow.SetClientSize(300, 200)
   ' // Centers the window
   pWindow.Center

   DIM wszLibName AS WSTRING * 260 = ExePath & "\MSDATLST.OCX"
   DIM CLSID_DataCombo AS CLSID = (&hF0D2F21C, &hCCB0, &h11D0, {&hA3, &h16, &h00, &hAA, &h00, &h68, &h8B, &h10})
   DIM IID_IDataCombo AS IID = (&hF0D2F21A, &hCCB0, &h11D0, {&hA3, &h16, &h00, &hAA, &h00, &h68, &h8B, &h10})
   DIM RTLKEY_DATACOMBO AS WSTRING * 260 = "A133F000-CCB0-11d0-A316-00AA00688B10"

   DIM pHost AS CAxHost = CAxHost(@pWindow, IDC_DATACOMBO, wszLibName, CLSID_DataCombo, _
       IID_IDataCombo, RTLKEY_DATACOMBO, 0, 0, pWindow.ClientWidth, pWindow.ClientHeight)
   SetFocus pHost.hWindow

   ' Get a reference to the DataList object
   DIM pDataList AS CDispInvoke = pHost.OcxDispObj
   ' Change the foreground and background colors
   pDataList.Put("ForeColor") = BGR(0, 0, 0)
   pDataList.Put("BackColor") = BGR(255,255,235)

   ' Open an ADO connection
   DIM pConnection AS CAdoConnection PTR = NEW CAdoConnection
   pConnection->ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ExePath & $"\Biblio.mdb"
   pConnection->Open
   ' Open a recordset
   DIM pRecordset AS CAdoRecordset PTR = NEW CAdoRecordset
   DIM cvSource AS CVAR = "SELECT * FROM Publishers ORDER BY Name"
   pRecordset->Open(cvSource, pConnection, adOpenKeyset, adLockOptimistic, adCmdText)
   ' Set the recordset to the control
   pDataList.PutRef("RowSource") = pRecordset->DataSource
   pDataList.Put("ListField") = "Name"

   ' // Display the window
   ShowWindow(hwndMain, nCmdShow)
   UpdateWindow(hwndMain)

   ' // Dispatch Windows messages
   DIM uMsg AS MSG
   WHILE (GetMessageW(@uMsg, NULL, 0, 0) <> FALSE)
      IF AfxCAxHostForwardMessage(GetFocus, @uMsg) = FALSE THEN
         IF IsDialogMessageW(hwndMain, @uMsg) = 0 THEN
            TranslateMessage(@uMsg)
            DispatchMessageW(@uMsg)
         END IF
      END IF
   WEND
   FUNCTION = uMsg.wParam

   ' Close the recordset
   pRecordset->Close
   ' Close the connection
   pConnection->Close
   ' // Delete the recordset
   Delete pRecordset
   ' // Delete the connection
   Delete pConnection

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

' ========================================================================================
' Main window procedure
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS HWND, BYVAL uMsg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM) AS LRESULT

   SELECT CASE uMsg

      CASE WM_COMMAND
         SELECT CASE LOWORD(wParam)
            CASE IDCANCEL
               ' // If ESC key pressed, close the application by sending an WM_CLOSE message
               IF HIWORD(wParam) = BN_CLICKED THEN
                  SendMessageW hwnd, WM_CLOSE, 0, 0
                  EXIT FUNCTION
               END IF
         END SELECT

      CASE WM_SIZE
         ' // Optional resizing code
         IF wParam <> SIZE_MINIMIZED THEN
            ' // Retrieve a pointer to the CWindow class
            DIM pWindow AS CWindow PTR = AfxCWindowPtr(hwnd)
            ' // Move the position of the button
            IF pWindow THEN pWindow->MoveWindow GetDlgItem(hwnd, IDC_DATACOMBO), _
               0, 0, pWindow->ClientWidth, pWindow->ClientHeight, CTRUE
         END IF

    CASE WM_DESTROY
         ' // Ends the application by sending a WM_QUIT message
         PostQuitMessage(0)
         EXIT FUNCTION

   END SELECT

   ' // Default processing of Windows messages
   FUNCTION = DefWindowProcW(hwnd, uMsg, wParam, lParam)

END FUNCTION
' ========================================================================================
Title: Re: CWindow Release Candidate 31
Post by: ganlinlao on November 20, 2017, 04:03:52 AM
hi,jose
I downloaded and used the fbc1.0.6 compiler and downloaded your latest idispinvoke.inc.
Using the latest example code from above. In the mothview example, there is still an error.
Code:
DIM pdisp AS CDispInvoke = pHost.OcxDispObj
   pdisp.Put ("Year", 2017)
   pdisp.Put ("Month", 12)
   pdisp.Put ("Day", 25)
Will show the same type of mismatch error.

 pdisp.Put ("Year", cVar (2017))

This will not be a problem.

I really like idispatch.put ("") = value like this style, thank you very much. I am very  looking forward to your ways to provide easier-to-handle "events".

Title: Re: CWindow Release Candidate 31
Post by: José Roca on November 20, 2017, 11:29:48 AM
Works fine here. Maybe you're using an outdated CVAR.inc.