COMWrapperBuilder tool

User projects written in or related to FreeBASIC.
Xusinboy Bekchanov
Posts: 243
Joined: Jul 26, 2018 18:28

COMWrapperBuilder tool

Postby Xusinboy Bekchanov » Aug 02, 2020 19:04

Added COMWrapperBuilder tool.
It creates SimpleVariantPlus.bi to make working with COM easier. SimpleVariantPlus.bi is based on OSchmidt's SimpleVariant.bi.

For this tool to work, you need:
1. Add #include "SimpleVariantPlus.bi" into one of the modules of the project or a single file.
The tool creates "SimpleVariantPlus.bi" itself if it is not available, otherwise it overwrites.
2. Select the path to the project or a single file in graphical mode or specify in the command line.
Has two switches on the command line:
-p Path to the project
-s Path to a single file

OSchmidt's example can be represented as follows

Code: Select all

#define UNICODE
#include once "SimpleVariantPlus.bi"

'Whilst the other examples so far, were creating InProcess-ObjectInstances -
'the following snippet covers an OutOfProcess-COMServer ("Excel.Application")
MsgBox "It might take a few seconds before something happens" & Chr(10) & _
"(Excel-Startups are not the fastest, especially on a 'cold FileCache')"

ShowCOMErrors = False 'we check the COMErr-Variable (and show an Error-MsgBox when needed) ourselves
Dim xlApp As vbVariant = CreateObject("Excel.Application")
If COMErr.Number Then MsgBox COMErr.Description: End ' early exit on Machines without an Excel-Install
ShowCOMErrors = True 'for the rest of the snippet, we switch the built-in COMErr-Messaging back On

xlApp.WorkBooks.Add
xlApp.Visible = True

Dim xlSheet As vbVariant = xlApp.ActiveSheet, CellValue As vbVariant

With xlSheet.Range("A1") 'let's operate from the TopLeft-cell
   
   Dim SArr(0 To 2) As String = {"Hello", "COM-calls", "from FB"}
   For i As Integer = 0 To UBound(SArr)
      .Offset(0, i).Value = SArr(i)
   Next
   
   CellValue = .Offset(0, 1).Value '<- should return "COM-calls"
   
End With '<- at this point, the above instantiated A1-Range-Object will be destroyed implicitly

xlSheet.Parent.Saved = True 'let's suppress the "Save Document" Dialogue ...
xlSheet.Clear '... and destroy the Sheet-Object with the appropriate vbVariant.Method ...

MsgBox CellValue '... now show the CellValue we have retrieved (should contain "COM-calls") ...

xlApp.Quit '...  before we "call it quits" here


After working with this tool, SimpleVariantPlus.bi looks like this:

Code: Select all

'SimpleVariant.bi: a "lean and mean" (not library-dependent) LateBound-Helper-Module for FreeBasic
'Author:      Olaf Schmidt (June 2016)
'The Vartype-Letters, as used for the ByName...-Methods are as follows:
'    u: 8BitU-Integer(FB UByte)
'    i: 16Bit-Integer(FB Short)
'    l: 32Bit-Integer(FB Long)
'    c: 64Bit-Integer(FB LongInt, mapped between 64Bit-FB-Int and -OLEVariant-Currency)
'    b: 16Bit-Boolean(FB Boolean, mapped between 8Bit-FB and 16Bit-OLEVariant-Booleans)
'    f: 32Bit-FlPoint(FB Single)
'    d: 64Bit-FlPoint(FB Double)
'    t: 64BitDateTime(FB Double)
'    s: 8Bit-per-Char(FB String)  !!! note, that only in normal ANSI-FB-Source-Modules, String-Literals can be passed as "s"...
'    w: 16Bit-per-Chr(FB WString) !!! ...in FB-Source-Modules that are Unicode, String-Literals need to be passed as "w" instead
'    v: OleVariant (which always need to be passed with their VarPtr -> @VariantVariable
'When used in the TypeChars-Param of the CallByName-Func, an UpperCase-Letter signifies
'"ByRef"-passing (the FB-Variable needs to be prefixed by an @ in these cases)

#include once "vbcompat.bi"
#include once "windows.bi"
#include once "win/ole2.bi"
#include once "crt/string.bi"

#ifdef __FB_WIN32__ 'this is necessary, because FB maps the original FB-Long-Def to Boolean somehow (remove when Fix is available in the Compiler)
   #undef  Long
   #define Long Integer '...though it should not do any harm to leave it as is... on Win32 it's the same BitLength (+ we filtered with the #IfDef)
   #undef  CLng
   #define CLng CInt 'same thing here - a redefinition is necessary to work around the FB-Win32-Compiler-Bug
   #undef Call 'to allow usage of that KeyWord as an UDT-Method (it's not used anyways in lang -fb)
#endif

'the following Const is used in the (Variant)Conversions from BSTRs to FB-Strings
Dim Shared DefaultCodePage_StringConv As UINT
#ifdef UNICODE
   DefaultCodePage_StringConv = CP_UTF8 'an 8Bit-FB-String will hold an UTF8-Stream when a vbVariant is casted to it
#else
   DefaultCodePage_StringConv = CP_ACP 'that conforms to the normal ANSI-Conversion
#endif

'the Const below is relevant for the Variant-Conversions (Strings <-> Numbers or DateValues) - we avoid LOCALE_USER_DEFAULT,
'since that would convert e.g. a DoubleValue of 1.1 to a String-Representation of 1,1 on a german system, instead LOCALE_INVARIANT ...
Const DefaultLocale_VariantConv As Long = LOCALE_INVARIANT '...conforms to FB-StringConv-Representations of Dates and rational Numbers

Type tCOMErr
   Number As UINT
   Description As String
End Type
Dim Shared COMErr As tCOMErr, EInfo As tagEXCEPINFO, ShowCOMErrors As Boolean = True

Dim Shared Done As Boolean 'anything COM-related needs to CoInitialize... (shell32 and comctl32 are preloaded, to play nicely with Manifested Apps)
If Not Done Then Done = True: CoInitializeEx(0, 2): DyLibLoad("shell32.dll"): DyLibLoad("comctl32.dll")

Function AppName() As String
   Static S As String
   If Len(S) = 0 Then S = Command(0):S = Mid(S, InStrRev(S, "\") + 1): S = Left(S, Len(S) - 4)
   Return S
End Function

Function MsgBox cdecl Overload (ByVal Msg As LPCWSTR, ByVal Flags As Long = MB_ICONINFORMATION) As Long
   Return MessageBoxW(GetActiveWindow, Msg, AppName, Flags)
End Function

Private Function HandleCOMErr(ByVal HRes As HResult, ByVal MethodName As LPOLESTR) As HResult
   Static Msg As WString Ptr: If Msg = NULL Then Msg = CAllocate(8192 + 2)
   
   Function = HRes
   If HRes = DISP_E_EXCEPTION Then
      COMErr.Number = EInfo.sCode
      COMErr.Description= "Err(&H" & Hex(HRes) & ") in " & *Cast(WString Ptr, EInfo.bstrSource) & ", whilst calling: " & *Cast(WString Ptr, MethodName) & Chr(10) & *Cast(WString Ptr, EInfo.bstrDescription)
   ElseIf HRes Then
      FormatMessageW FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS, NULL, HRes, MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), Msg, 4096, NULL
      COMErr.Number = HRes
      COMErr.Description= "Err(&H" & Hex(HRes) & ") in SimpleVariant.bi, whilst calling: " & *Cast(WString Ptr, MethodName) & Chr(10) & *Msg
   End If
   If CBool(HRes) And ShowCOMErrors Then MsgBox COMErr.Description
End Function

'the usual Instantiation-Helper for COM-Objects which are known in the Win-Registry (e.g. CreateObject("Scripting.Dictionary")
Function CreateObject(ByVal ProgID As LPCOLESTR) As tagVariant
   If Not Done Then Done = True: CoInitializeEx(0, 2): DyLibLoad("shell32.dll"): DyLibLoad("comctl32.dll")
   
   COMErr.Number = 0
   Dim CLSID As CLSID, RetVal As tagVariant
   If HandleCOMErr(CLSIDFromProgID(ProgID, @ClsID), "CLSIDFromProgID") Then Return RetVal
   If HandleCOMErr(CoCreateInstance(@ClsID, NULL, CLSCTX_SERVER, @IID_IDispatch, @RetVal.pDispVal), "CreateObject") Then Return RetVal
   RetVal.VT = VT_DISPATCH
   Return RetVal
End Function

'but here's a helper-function to create COM-Objects regfree, in case the user provided a *.manifest-File (and placed it beside the COM-Dll-File)
Function CreateObjectRegFree(ProgID As WString Ptr, ManifestFileName As WString Ptr) As tagVariant
   Static ACW As ACTCTXW
   ACW.cbSize = Len(ACW)
   ACW.lpSource = ManifestFileName
   
   COMErr.Number = 0
   
   Dim hActCtx As HANDLE, Cookie As ULONG_PTR
   hActCtx = CreateActCtxW(@ACW)
   If (hActCtx = INVALID_HANDLE_VALUE) Then
      COMErr.Number = &H80020009
      COMErr.Description = "Couldn't create ActCtx from Manifest: " & *ManifestFileName
      If ShowCOMErrors Then MsgBox COMErr.Description
      Exit Function
   End If
   
   If ActivateActCtx(hActCtx, @Cookie) Then
      Dim OrigDir As String, DllPath As String = Left(*ManifestFileName, InStrRev(*ManifestFileName, "\"))
      OrigDir = CurDir()
      ChDir DllPath
      Function = CreateObject(ProgID)
      ChDir OrigDir
      DeactivateActCtx 0, Cookie
   Else
      COMErr.Number = &H80020009
      COMErr.Description = "Couldn't activate ActCtx from Manifest: " & *ManifestFileName
      If ShowCOMErrors Then MsgBox COMErr.Description
   End If
   
   ReleaseActCtx hActCtx
End Function

Function BSTR2S cdecl (ByVal BS As Const BSTR, ByVal CodePage As UINT = DefaultCodePage_StringConv) As String
   Dim BytesNeeded As UINT, S As String
   BytesNeeded = WideCharToMultiByte(CodePage, 0, BS, SysStringLen(BS), 0, 0, 0, 0)
   S = String(BytesNeeded, 0)
   WideCharToMultiByte CodePage, 0, BS, SysStringLen(BS), StrPtr(S), BytesNeeded, 0, 0
   Return S
End Function
Function S2BSTR cdecl (S As Const String, ByVal CodePage As UINT = DefaultCodePage_StringConv) As BSTR 'the caller is responsible for freeing the returned BSTR per SysFreeString
   Dim WCharsNeeded As UINT, BS As BSTR
   WCharsNeeded = MultiByteToWideChar(CodePage, 0, StrPtr(S), Len(S), 0, 0)
   BS = SysAllocStringLen(BS, WCharsNeeded)
   MultiByteToWideChar CodePage, 0, StrPtr(S), Len(S), BS, WCharsNeeded
   Return BS
End Function

Function BSTR2W(ByVal BS As Const BSTR) As WString Ptr 'the caller is responsible for freeing the returned WString per DeAllocate
   Dim W As WString Ptr
   W = CAllocate(SysStringByteLen(BS) + 2)
   If BS Then memcpy W, BS, SysStringByteLen(BS)
   Return W
End Function
Function W2BSTR(ByVal W As Const WString Ptr) As BSTR 'the caller is responsible for freeing the returned BSTR per SysFreeString
   Return SysAllocString(W)
End Function

'well, this is the workhorse for all the Dispatch-Calls (IDispatch::Invoke)... there's easier Wrapper-Methods around this at the end of this module)
Dim Shared LastDispID As Long = 0, UseDispId As Long = 0
Function CallByName cdecl (vDisp As tagVariant, ByVal MethodName As LPOLESTR, ByVal CallFlag As Word, TypeChars As String = "", ByVal Args As Any Ptr) As tagVariant
   Static DispParams As DISPPARAMS, DispidNamed As DISPID = DISPID_PROPERTYPUT
   Static VParams(31) As tagVariant, SArr(31) As BSTR, ArgsArr(31) As Any Ptr
   Const As UByte l=108,i=105,b=98,d=100,f=102,t=116,v=118,w=119,s=115,c=99,u=117,sR=83,wR=87 'to make the Type-Selects more readable
   Dim TypeChar As UByte, IsByRef As Boolean, VRes As tagVariant, DispId As DISPID
   
   If UseDispID Then DispID = UseDispID: UseDispID = 0
   COMErr.Number = 0
   If DispID = 0 Then
      LastDispID = 0
      If HandleCOMErr(vDisp.pDispVal->lpVtbl->GetIDsOfNames(vDisp.pDispVal, @IID_NULL, @MethodName, 1, LOCALE_USER_DEFAULT, @DispId), MethodName) Then Return VRes
      LastDispID = DispId
   End If
   
   DispParams.cArgs = Len(TypeChars)
   DispParams.rgVarg = @VParams(0)
   DispParams.cNamedArgs = IIf(CallFlag >= DISPATCH_PROPERTYPUT, 1, 0)
   DispParams.rgdispidNamedArgs = IIf(CallFlag >= DISPATCH_PROPERTYPUT, @DispidNamed, 0)
   
   For j As Integer = DispParams.cArgs - 1 To 0 Step -1
      TypeChar = TypeChars[DispParams.cArgs - j - 1]
      IsByRef  = TypeChar < 97
      If IsByRef Then TypeChar += 32 'since the ByRef-Info is now retrieved, we work further with just the lower-case letter
      
      'in a first pass, we set only the proper Variant-Type-Members
      Select Case TypeChar
      Case s,w: VParams(j).VT = VT_BSTR    Or VT_BYREF
      Case u:   VParams(j).VT = VT_UI1     Or VT_BYREF
      Case i:   VParams(j).VT = VT_I2      Or VT_BYREF
      Case l:   VParams(j).VT = VT_I4      Or VT_BYREF
      Case c:   VParams(j).VT = VT_CY      Or IIf(IsByRef, VT_BYREF, 0)
      Case b:   VParams(j).VT = VT_BOOL    Or IIf(IsByRef, VT_BYREF, 0)
      Case f:   VParams(j).VT = VT_R4      Or IIf(IsByRef, VT_BYREF, 0)
      Case d:   VParams(j).VT = VT_R8      Or VT_BYREF
      Case t:   VParams(j).VT = VT_DATE    Or VT_BYREF
      Case v:   VParams(j).VT = VT_VARIANT Or VT_BYREF
      End Select
      
      'in a second pass, we set the Variant-Value-Members of our (static) VParams-Array
      Select Case TypeChar
      Case s,w:  If IsByRef Then ArgsArr(j) = Args
         If SArr(j) Then SysFreeString SArr(j): SArr(j) = 0 'destroy the previous allocation from our static BSTR-Cache
         Select Case TypeChar
         Case s: If IsByRef Then SArr(j) = S2BSTR(*va_arg(Args, String Ptr))      Else SArr(j) = S2BSTR(*va_arg(Args, ZString Ptr))
         Case w: If IsByRef Then SArr(j) = W2BSTR(*va_arg(Args, WString Ptr Ptr)) Else SArr(j) = W2BSTR(*va_arg(Args, WString Ptr))
         End Select
         VParams(j).pbstrVal = @SArr(j)
      Case v:    VParams(j) = *va_arg(Args, tagVARIANT Ptr)
      Case f:    If IsByRef Then VParams(j).pbVal = va_arg(Args, Any Ptr) Else VParams(j).fltVal = CSng(va_arg(Args, Double))
      Case b:    If IsByRef Then VParams(j).pbVal = va_arg(Args, Any Ptr) Else VParams(j).boolVal = CShort(va_arg(Args, Boolean))
      Case c:    If IsByRef Then VParams(j).pbVal = va_arg(Args, Any Ptr) Else VParams(j).llVal = va_arg(Args, LongInt) * 10000
      Case Else: If IsByRef Then VParams(j).pbVal = va_arg(Args, Any Ptr) Else VParams(j).pbVal  = Args
      End Select
      
      'what remains is the type-based Args-Shift
      Select Case TypeChar
      Case s,w,v: Args = va_next(Args, Any Ptr)
      Case f,d,t: If IsByRef Then Args = va_next(Args, Any Ptr) Else Args = va_next(Args, Double)
      Case i:     If IsByRef Then Args = va_next(Args, Any Ptr) Else Args = va_next(Args, Short)
      Case l:     If IsByRef Then Args = va_next(Args, Any Ptr) Else Args = va_next(Args, Long)
      Case b:     If IsByRef Then Args = va_next(Args, Any Ptr) Else Args = va_next(Args, Boolean)
      Case u:     If IsByRef Then Args = va_next(Args, Any Ptr) Else Args = va_next(Args, UByte)
      Case c:     If IsByRef Then Args = va_next(Args, Any Ptr) Else Args = va_next(Args, LongInt)
      End Select
   Next
   
   HandleCOMErr vDisp.pDispVal->lpVtbl->Invoke(VDisp.pDispVal, DispId, @IID_NULL, LOCALE_USER_DEFAULT, CallFlag, @DispParams, @VRes, @EInfo, NULL), MethodName
   
   'this is needed, to pass back any StringValues from our SArr-BSTR-Cache into the FB-StringVariables (in the ByRef-case)
   For j As Integer = DispParams.cArgs - 1 To 0 Step -1
      If VParams(j).VT = (VT_BSTR Or VT_BYREF) Then
         Select Case TypeChars[DispParams.cArgs - j - 1]
         Case sR: *va_arg(ArgsArr(j), String Ptr)      = BSTR2S(SArr(j)) 'pass back, in case it was a FB-ByRef-String
         Case wR: *va_arg(ArgsArr(j), WString Ptr Ptr) = BSTR2W(SArr(j)) 'pass back, in case it was a FB-ByRef-WString
         End Select
      End If
   Next
   
   Return VRes
End Function

'*************************** Begin of the Variant-Wrapper-Section *******************************

Enum vbVarType
   vbEmpty    = &H0000
   vbNull     = &H0001
   vbInteger  = &H0002
   vbLong     = &H0003
   vbSingle   = &H0004
   vbDouble   = &H0005
   vbCurrency = &H0006
   vbDate     = &H0007
   vbString   = &H0008
   vbObject   = &H0009
   vbError    = &H000A
   vbBoolean  = &H000B
   vbVariant  = &H000C
   vbDecimal  = &H000E
   vbByte     = &H0011
   vbArray    = &H2000
   vbByRef    = &H4000
End Enum

Type vbVariant
   V As tagVariant
   Declare Constructor()
   Declare Destructor()
   Declare Sub Clear()
   
   Declare Function VarType()  As vbVarType
   Declare Function TypeName() As String
   Declare Function IsEmpty()  As Boolean
   Declare Function IsArray()  As Boolean
   Declare Function IsObject() As Boolean
   
   Declare Constructor (ByVal RHS As Boolean)
   Declare Operator Let(ByVal RHS As Boolean)
   Declare Operator Cast() As Boolean
   
   Declare Constructor (ByVal RHS As UByte)
   Declare Operator Let(ByVal RHS As UByte)
   Declare Operator Cast() As UByte
   
   Declare Constructor (ByVal RHS As Short)
   Declare Operator Let(ByVal RHS As Short)
   Declare Operator Cast() As Short
   
   Declare Constructor (ByVal RHS As Long)
   Declare Operator Let(ByVal RHS As Long)
   Declare Operator Cast() As Long
   
   Declare Constructor (ByVal RHS As LongInt)
   Declare Operator Let(ByVal RHS As LongInt)
   Declare Operator Cast() As LongInt
   
   Declare Constructor (ByVal RHS As Single)
   Declare Operator Let(ByVal RHS As Single)
   Declare Operator Cast() As Single
   
   Declare Constructor (ByVal RHS As Double)
   Declare Operator Let(ByVal RHS As Double)
   Declare Operator Cast() As Double
   
   Declare Constructor (RHS As String)
   Declare Operator Let(RHS As String)
   Declare Operator Cast()  As String
   
   Declare Constructor (ByVal RHS As Const WString Ptr)
   Declare Operator Let(ByVal RHS As Const WString Ptr)
   Declare Operator Cast() As WString Ptr
   
   Declare Constructor (RHS As tagVariant)
   Declare Operator Let(RHS As tagVariant)
   Declare Operator Cast()  As tagVariant
   
   Declare Constructor (RHS As vbVariant)
   Declare Operator Let(RHS As vbVariant)
   
   Declare Function Call cdecl (ByVal MethodName As LPOLESTR, TypeChars As String = "", ...) As vbVariant
   Declare Function  Get cdecl (ByVal MethodName As LPOLESTR, TypeChars As String = "", ...) As vbVariant
   Declare Sub       Put cdecl (ByVal MethodName As LPOLESTR, TypeChars As String = "", ...)
   Declare Sub       Set cdecl (ByVal MethodName As LPOLESTR, TypeChars As String = "", ...)
   Declare Function  vbV() As vbVariant

   Declare Function Add As vbVariant
   Declare Function WorkBooks As vbVariant
   Declare Property Visible As vbVariant
   Declare Property Visible(ByRef Param1 As vbVariant)
   Declare Function ActiveSheet As vbVariant
   Declare Function Range(ByRef Param1 As vbVariant) As vbVariant
   Declare Property Value As vbVariant
   Declare Property Value(ByRef Param1 As vbVariant)
   Declare Function Offset(ByRef Param1 As vbVariant, ByRef Param2 As vbVariant) As vbVariant
   Declare Property Saved As vbVariant
   Declare Property Saved(ByRef Param1 As vbVariant)
   Declare Function Parent As vbVariant
   Declare Function Quit As vbVariant
End Type

Function vbVariant.Add As vbVariant
   Return This.Get("Add")
End Function
Function vbVariant.WorkBooks As vbVariant
   Return This.Get("WorkBooks")
End Function
Property vbVariant.Visible As vbVariant
   Return This.Get("Visible")
End Property
Property vbVariant.Visible(ByRef Param1 As vbVariant)
   This.Put("Visible", "v", @Param1)
End Property
Function vbVariant.ActiveSheet As vbVariant
   Return This.Get("ActiveSheet")
End Function
Function vbVariant.Range(ByRef Param1 As vbVariant) As vbVariant
   Return This.Get("Range", "v", @Param1)
End Function
Property vbVariant.Value As vbVariant
   Return This.Get("Value")
End Property
Property vbVariant.Value(ByRef Param1 As vbVariant)
   This.Put("Value", "v", @Param1)
End Property
Function vbVariant.Offset(ByRef Param1 As vbVariant, ByRef Param2 As vbVariant) As vbVariant
   Return This.Get("Offset", "vv", @Param1, @Param2)
End Function
Property vbVariant.Saved As vbVariant
   Return This.Get("Saved")
End Property
Property vbVariant.Saved(ByRef Param1 As vbVariant)
   This.Put("Saved", "v", @Param1)
End Property
Function vbVariant.Parent As vbVariant
   Return This.Get("Parent")
End Function
Function vbVariant.Quit As vbVariant
   Return This.Get("Quit")
End Function
Function vbVariant.vbV() As vbVariant
   Return This
End Function
Constructor vbVariant()
   'we dont't do anything here in the base constructor currently
End Constructor
Destructor vbVariant()
   'MsgBox "Destructor of: " & TypeName
   If V.VT Then VariantClear @V
End Destructor
Sub vbVariant.Clear() 'usable on the Outside, e.g. to dereference an Object "early"
   If V.VT Then VariantClear @V: VariantInit @V
End Sub

Function WCacheValue(BSTR2Copy As BSTR) As WString Ptr 'a little Helper, to avoid leaking with the WString-DataType (in the User-Code)
   Const  CacheSize As Integer = 1024
   Static Cache(0 To CacheSize-1) As WString Ptr, NxtIdx As Integer
   NxtIdx= (NxtIdx + 1) Mod CacheSize
   If Cache(NxtIdx) Then Deallocate Cache(NxtIdx)
   Cache(NxtIdx) = BSTR2W(BSTR2Copy)
   Return Cache(NxtIdx)
End Function

Function vbVariant.VarType() As vbVarType
   Return V.VT
End Function
Function vbVariant.TypeName() As String
   Dim T As String
   Select Case V.VT And Not (vbArray Or vbByRef)
   Case vbVarType.vbEmpty:    T = "Empty"
   Case vbVarType.vbNull:     T = "Null"
   Case vbVarType.vbInteger:  T = "Integer"
   Case vbVarType.vbLong:     T = "Long"
   Case vbVarType.vbSingle:   T = "Single"
   Case vbVarType.vbDouble:   T = "Double"
   Case vbVarType.vbCurrency: T = "Currency"
   Case vbVarType.vbDate:     T = "Date"
   Case vbVarType.vbString:   T = "String"
   Case vbVarType.vbObject:   T = "Object"
   Case vbVarType.vbError:    T = "Error"
   Case vbVarType.vbBoolean:  T = "Boolean"
   Case vbVarType.vbVariant:  T = "Variant"
   Case vbVarType.vbDecimal:  T = "Decimal"
   Case vbVarType.vbByte:     T = "Byte"
   Case Else:                 T = "UnsupportedType(" & Hex(V.VT) & ")"
   End Select
   If V.VT And vbArray Then Return T & "()"
   Return T
End Function
Function vbVariant.IsEmpty() As Boolean
   Return V.VT = vbEmpty
End Function
Function vbVariant.IsArray() As Boolean
   If V.VT And vbArray Then Return True
End Function
Function vbVariant.IsObject() As Boolean
   Return V.VT = vbObject
End Function


Constructor vbVariant(ByVal RHS As Boolean)
   This = RHS
End Constructor
Operator vbVariant.Let(ByVal RHS As Boolean)
   If V.VT <> vbBoolean  And V.VT <> vbEmpty Then VariantClear @V
   V.VT =  vbBoolean: V.boolVal = CShort(RHS)
End Operator
Operator vbVariant.Cast() As Boolean
   If V.VT = vbBoolean Then
      Return CBool(V.boolVal)
   Else
      Dim VV As tagVariant
      HandleCOMErr VariantChangeTypeEx(@VV, @V, DefaultLocale_VariantConv, VARIANT_NOVALUEPROP Or VARIANT_ALPHABOOL, vbBoolean), "SimpleVariant.Cast_Boolean"
      Return CBool(VV.boolVal)
   End If
End Operator


Constructor vbVariant(ByVal RHS As UByte)
   This = RHS
End Constructor
Operator vbVariant.Let(ByVal RHS As UByte)
   If V.VT <> vbByte  And V.VT <> vbEmpty Then VariantClear @V
   V.VT =  vbByte: V.bVal = RHS
End Operator
Operator vbVariant.Cast() As UByte
   If V.VT = vbByte Then
      Return V.bVal
   Else
      Dim VV As tagVariant
      HandleCOMErr VariantChangeTypeEx(@VV, @V, DefaultLocale_VariantConv, VARIANT_NOVALUEPROP, vbByte), "SimpleVariant.Cast_UByte"
      Return VV.bVal
   End If
End Operator


Constructor vbVariant(ByVal RHS As Short)
   This = RHS
End Constructor
Operator vbVariant.Let(ByVal RHS As Short)
   If V.VT <> vbInteger  And V.VT <> vbEmpty Then VariantClear @V
   V.VT =  vbInteger: V.iVal = RHS
End Operator
Operator vbVariant.Cast() As Short
   If V.VT = vbInteger Then
      Return V.iVal
   Else
      Dim VV As tagVariant
      HandleCOMErr VariantChangeTypeEx(@VV, @V, DefaultLocale_VariantConv, VARIANT_NOVALUEPROP, vbInteger), "SimpleVariant.Cast_Short"
      Return VV.iVal
   End If
End Operator


Constructor vbVariant(ByVal RHS As Long)
   This = RHS
End Constructor
Operator vbVariant.Let(ByVal RHS As Long)
   If V.VT <> vbLong  And V.VT <> vbEmpty Then VariantClear @V
   V.VT =  vbLong: V.lVal = RHS
End Operator
Operator vbVariant.Cast() As Long
   If V.VT = vbLong Then
      Return V.lVal
   Else
      Dim VV As tagVariant
      HandleCOMErr VariantChangeTypeEx(@VV, @V, DefaultLocale_VariantConv, VARIANT_NOVALUEPROP, vbLong), "SimpleVariant.Cast_Long"
      Return VV.lVal
   End If
End Operator


Constructor vbVariant(ByVal RHS As LongInt)
   This = RHS
End Constructor
Operator vbVariant.Let(ByVal RHS As LongInt)
   If V.VT <> vbCurrency  And V.VT <> vbEmpty Then VariantClear @V
   V.VT =  vbCurrency: V.llVal = RHS * 10000
End Operator
Operator vbVariant.Cast() As LongInt
   If V.VT = vbCurrency Then
      Return V.llVal / 10000
   Else
      Dim VV As tagVariant
      HandleCOMErr VariantChangeTypeEx(@VV, @V, DefaultLocale_VariantConv, VARIANT_NOVALUEPROP, VT_I8), "SimpleVariant.Cast_LongInt"
      Return VV.llVal
   End If
End Operator


Constructor vbVariant(ByVal RHS As Single)
   This = RHS
End Constructor
Operator vbVariant.Let(ByVal RHS As Single)
   If V.VT <> vbSingle  And V.VT <> vbEmpty Then VariantClear @V
   V.VT =  vbSingle: V.fltVal = RHS
End Operator
Operator vbVariant.Cast() As Single
   If V.VT = vbSingle Then
      Return V.fltVal
   Else
      Dim VV As tagVariant
      HandleCOMErr VariantChangeTypeEx(@VV, @V, DefaultLocale_VariantConv, VARIANT_NOVALUEPROP, vbSingle), "SimpleVariant.Cast_Single"
      Return VV.fltVal
   End If
End Operator


Constructor vbVariant(ByVal RHS As Double)
   This = RHS
End Constructor
Operator vbVariant.Let(ByVal RHS As Double)
   If V.VT <> vbDouble  And V.VT <> vbEmpty Then VariantClear @V
   V.VT =  vbDouble: V.dblVal = RHS
End Operator
Operator vbVariant.Cast() As Double
   If V.VT = vbDouble Then
      Return V.dblVal
   Else
      Dim VV As tagVariant
      HandleCOMErr VariantChangeTypeEx(@VV, @V, DefaultLocale_VariantConv, VARIANT_NOVALUEPROP, vbDouble), "SimpleVariant.Cast_Double"
      Return VV.dblVal
   End If
End Operator


Constructor vbVariant(RHS As String)
   This = RHS
End Constructor
Operator vbVariant.Let(RHS As String)
   If V.VT Then VariantClear @V
   V.VT = vbString: V.bstrVal = S2BSTR(RHS)
End Operator
Operator vbVariant.Cast() As String
   If V.VT = vbString Then
      Return BSTR2S(V.bstrVal)
   Else
      Dim VV As tagVariant
      HandleCOMErr VariantChangeTypeEx(@VV, @V, DefaultLocale_VariantConv, VARIANT_NOVALUEPROP Or VARIANT_ALPHABOOL, vbString), "SimpleVariant.Cast_String"
      If V.VT = (vbArray Or vbByte) Then
         Dim S As String = String(SysStringByteLen(VV.bstrVal), 0)
         memcpy StrPtr(S), VV.bstrVal, Len(S)
         Operator = S
      Else
         Operator = BSTR2S(VV.bstrVal)
      End If
      VariantClear @VV
   End If
End Operator


Constructor vbVariant(ByVal RHS As Const WString Ptr)
   This = RHS
End Constructor
Operator vbVariant.Let(ByVal RHS As Const WString Ptr)
   If V.VT Then VariantClear @V
   V.VT = vbString: V.bstrVal = W2BSTR(RHS)
End Operator
Operator vbVariant.Cast() As WString Ptr
   If V.VT = vbString Then
      Return WCacheValue(V.bstrVal)
   Else
      Dim VV As tagVariant
      HandleCOMErr VariantChangeTypeEx(@VV, @V, DefaultLocale_VariantConv, VARIANT_NOVALUEPROP Or VARIANT_ALPHABOOL, vbString), "SimpleVariant.Cast_WString"
      Operator = WCacheValue(VV.bstrVal)
      VariantClear @VV
   End If
End Operator


Constructor vbVariant(RHS As tagVariant)
   If @This = @RHS Then Exit Constructor
   If V.VT Then VariantClear @V
   V=RHS '<- we go with a shallow copy here (to not mess-up RefCounts - e.g. when normal tagVariants come in from Function-Results)
End Constructor
Operator vbVariant.Let(RHS As tagVariant)
   If @This = @RHS Then Exit Operator
   If V.VT Then VariantClear @V
   VariantCopy @V, @RHS
End Operator
Operator vbVariant.Cast() As tagVariant
   Dim Dst As tagVariant
   VariantCopy @Dst, @V
   Return Dst
End Operator


Constructor vbVariant(RHS As vbVariant)
   If @This = @RHS Then Exit Constructor
   If V.VT Then VariantClear @V
   VariantCopy @V, @RHS.V
End Constructor
Operator vbVariant.Let(RHS As vbVariant)
   If @This = @RHS Then Exit Operator
   If V.VT Then VariantClear @V
   VariantCopy @V, @RHS.V
End Operator


Function vbVariant.Call cdecl (ByVal MethodName As LPOLESTR, TypeChars As String = "", ...) As vbVariant
   Dim tv As tagVariant
   tv = CallByName(V, MethodName, DISPATCH_METHOD Or DISPATCH_PROPERTYGET, TypeChars, va_first)
   Function = tv
End Function
Function vbVariant.Get cdecl (ByVal MethodName As LPOLESTR, TypeChars As String = "", ...) As vbVariant
   Return CallByName(V, MethodName, DISPATCH_METHOD Or DISPATCH_PROPERTYGET, TypeChars, va_first)
End Function
Sub vbVariant.Put cdecl (ByVal MethodName As LPOLESTR, TypeChars As String = "", ...)
   CallByName(V, MethodName, DISPATCH_PROPERTYPUT, TypeChars, va_first)
End Sub
Sub vbVariant.Set cdecl (ByVal MethodName As LPOLESTR, TypeChars As String = "", ...)
   CallByName(V, MethodName, DISPATCH_PROPERTYPUTREF,  TypeChars, va_first)
End Sub

'finally a MsgBox-OverLoad, which accepts a vbVariant as the Msg-Parameter
Function MsgBox cdecl (ByVal Msg As vbVariant, ByVal Flags As Long = MB_ICONINFORMATION) As Long
   If Msg.V.VT = vbString Then
      Return MessageBoxW(GetActiveWindow, Msg.V.bstrVal, AppName, Flags)
   Else
      Dim VV As tagVariant
      HandleCOMErr VariantChangeTypeEx(@VV, @Msg.V, DefaultLocale_VariantConv, VARIANT_NOVALUEPROP Or VARIANT_ALPHABOOL, vbString), "SimpleVariant.MsgBox"
      Function = MessageBoxW(GetActiveWindow, VV.bstrVal, AppName, Flags)
      VariantClear @VV
   End If
End Function

#define Set
#define Nothing 0


https://github.com/XusinboyBekchanov/Vi ... perBuilder
UEZ
Posts: 613
Joined: May 05, 2017 19:59
Location: Germany

Re: COMWrapperBuilder tool

Postby UEZ » Aug 03, 2020 10:42

Thanks Xusinboy Bekchanov for sharing this useful code example to control Excel via COM interface.

But I don't understand what COMWrapperBuilder tool is doing. Can you please explain it again?

With Autoit I'm working since years with this COM interface to control Excel, Word, PP, ActiveDirectory, etc.
Xusinboy Bekchanov
Posts: 243
Joined: Jul 26, 2018 18:28

Re: COMWrapperBuilder tool

Postby Xusinboy Bekchanov » Aug 03, 2020 12:40

UEZ wrote:Thanks Xusinboy Bekchanov for sharing this useful code example to control Excel via COM interface.

But I don't understand what COMWrapperBuilder tool is doing. Can you please explain it again?

With Autoit I'm working since years with this COM interface to control Excel, Word, PP, ActiveDirectory, etc.

You can write code like you work in VB without additional variables in functions, at the end you can run this tool. This tool creates all the necessary methods by analyzing your code.

For example, you can write like this:

Code: Select all

#include "SimpleVariantPlus.bi"

Dim As vbVariant wordApp

wordApp = CreateObject("Word.Application")
wordApp.Documents.Add
wordApp.Visible = True

Sleep

And this code will work after running this tool.
oyster
Posts: 216
Joined: Oct 11, 2005 10:46

Re: COMWrapperBuilder tool

Postby oyster » Aug 03, 2020 14:00

I am still puzzled. A step by step tutorial could be better
Xusinboy Bekchanov
Posts: 243
Joined: Jul 26, 2018 18:28

Re: COMWrapperBuilder tool

Postby Xusinboy Bekchanov » Aug 03, 2020 15:10

oyster wrote:I am still puzzled. A step by step tutorial could be better

Here I wrote the same:
Xusinboy Bekchanov wrote:For this tool to work, you need:
1. Add #include "SimpleVariantPlus.bi" into one of the modules of the project or a single file.
The tool creates "SimpleVariantPlus.bi" itself if it is not available, otherwise it overwrites.
2. Select the path to the project or a single file in graphical mode or specify in the command line.
Has two switches on the command line:
-p Path to the project
-s Path to a single file

3. In the graphical mode you need to click on the button Run. If passed to the command line, the tool automatically works when the tool is loaded
At the end, reports on the result of the work.
Can be used in IDEs that support Tools. There, the command lines are set in the settings and you will not manually specify the path. Only you will choose a tool from the menu.
4. To test, you must compile your code and run your program.

I have now updated the tool and SimpleVariantPlusTemplate.bi. Now it can be compiled to 64-bit. OSchmidt's SimpleVariant.bi only worked in 32-bit mode.
Changes: https://github.com/XusinboyBekchanov/Vi ... 8fffaa12b1
UEZ
Posts: 613
Joined: May 05, 2017 19:59
Location: Germany

Re: COMWrapperBuilder tool

Postby UEZ » Aug 03, 2020 17:17

COMWrapperBuilder.exe doesn't work properly. I get a message "Not find #include "SimpleVariantPlus.bi" in modules!" although the line exists at the top of the code (the Word example).

Why is Notepad.exe starting when I press the open button?

After the last update also the Excel example is not working anymore.
Xusinboy Bekchanov
Posts: 243
Joined: Jul 26, 2018 18:28

Re: COMWrapperBuilder tool

Postby Xusinboy Bekchanov » Aug 03, 2020 17:41

UEZ wrote:COMWrapperBuilder.exe doesn't work properly. I get a message "Not find #include "SimpleVariantPlus.bi" in modules!" although the line exists at the top of the code (the Word example).

Maybe you haven't saved your code. Or not set as main (in VisualFBEditor you need to set as main).
After the message, shows the form, there will show the path to the Main file. If there is no main file, then SimpleVariantPlus.bi does not find either.
Maybe you chose another file by mistake?
UEZ wrote:Why is Notepad.exe starting when I press the open button?

Upon successful execution, it will show Path to SimpleVariantPlus.bi. The Open button will open this path to notepad for you to check the changes SimpleVariantPlus.bi
UEZ wrote:After the last update also the Excel example is not working anymore.

I also downloaded and tested it now. It works. What error is being reported?
Xusinboy Bekchanov
Posts: 243
Joined: Jul 26, 2018 18:28

Re: COMWrapperBuilder tool

Postby Xusinboy Bekchanov » Aug 03, 2020 19:39

Updated SimpleVariantPlusTemplate.bi
Now old COMWrapperBuilder.exe (in the distribution package VisualFBEditor 1.2.5) also works with 64-bit, only need to replace text of SimpleVariantPlusTemplate.bi
https://github.com/XusinboyBekchanov/Vi ... 25a2924f67

Code of SimpleVariantPlusTemplate.bi:

Code: Select all

'SimpleVariantPlus.bi: a "lean and mean" (not library-dependent) LateBound-Helper-Module for FreeBasic
'Author:      Olaf Schmidt (June 2016)
'Updated by Xusinboy Bekchanov to support 64-bit (August 2020)
'The Vartype-Letters, as used for the ByName...-Methods are as follows:
'    u: 8BitU-Integer(FB UByte)
'    i: 16Bit-Integer(FB Short)
'    l: 32Bit-Integer(FB Long)
'    c: 64Bit-Integer(FB LongInt, mapped between 64Bit-FB-Int and -OLEVariant-Currency)
'    b: 16Bit-Boolean(FB Boolean, mapped between 8Bit-FB and 16Bit-OLEVariant-Booleans)
'    f: 32Bit-FlPoint(FB Single)
'    d: 64Bit-FlPoint(FB Double)
'    t: 64BitDateTime(FB Double)
'    s: 8Bit-per-Char(FB String)  !!! note, that only in normal ANSI-FB-Source-Modules, String-Literals can be passed as "s"...
'    w: 16Bit-per-Chr(FB WString) !!! ...in FB-Source-Modules that are Unicode, String-Literals need to be passed as "w" instead
'    v: OleVariant (which always need to be passed with their VarPtr -> @VariantVariable
'When used in the TypeChars-Param of the CallByName-Func, an UpperCase-Letter signifies
'"ByRef"-passing (the FB-Variable needs to be prefixed by an @ in these cases)

#include once "vbcompat.bi"
#include once "windows.bi"
#include once "win/ole2.bi"
#include once "crt/string.bi"

#ifdef __FB_WIN32__ 'this is necessary, because FB maps the original FB-Long-Def to Boolean somehow (remove when Fix is available in the Compiler)
   #undef  Long
   #define Long Integer '...though it should not do any harm to leave it as is... on Win32 it's the same BitLength (+ we filtered with the #IfDef)
   #undef  CLng
   #define CLng CInt 'same thing here - a redefinition is necessary to work around the FB-Win32-Compiler-Bug
   #undef Call 'to allow usage of that KeyWord as an UDT-Method (it's not used anyways in lang -fb)
#endif

'the following Const is used in the (Variant)Conversions from BSTRs to FB-Strings
Dim Shared DefaultCodePage_StringConv As UINT
#ifdef UNICODE
   DefaultCodePage_StringConv = CP_UTF8 'an 8Bit-FB-String will hold an UTF8-Stream when a vbVariant is casted to it
#else
   DefaultCodePage_StringConv = CP_ACP 'that conforms to the normal ANSI-Conversion
#endif

'the Const below is relevant for the Variant-Conversions (Strings <-> Numbers or DateValues) - we avoid LOCALE_USER_DEFAULT,
'since that would convert e.g. a DoubleValue of 1.1 to a String-Representation of 1,1 on a german system, instead LOCALE_INVARIANT ...
Const DefaultLocale_VariantConv As Long = LOCALE_INVARIANT '...conforms to FB-StringConv-Representations of Dates and rational Numbers

Type tCOMErr
   Number As UINT
   Description As String
End Type
Dim Shared COMErr As tCOMErr, EInfo As tagEXCEPINFO, ShowCOMErrors As Boolean = True

Dim Shared Done As Boolean 'anything COM-related needs to CoInitialize... (shell32 and comctl32 are preloaded, to play nicely with Manifested Apps)
If Not Done Then Done = True: CoInitializeEx(0, 2): DyLibLoad("shell32.dll"): DyLibLoad("comctl32.dll")

Function AppName() As String
   Static S As String
   If Len(S) = 0 Then S = Command(0):S = Mid(S, InStrRev(S, "\") + 1): S = Left(S, Len(S) - 4)
   Return S
End Function

Function MsgBox cdecl Overload (ByVal Msg As LPCWSTR, ByVal Flags As Long = MB_ICONINFORMATION) As Long
   Return MessageBoxW(GetActiveWindow, Msg, AppName, Flags)
End Function

Private Function HandleCOMErr(ByVal HRes As HResult, ByVal MethodName As LPOLESTR) As HResult
   Static Msg As WString Ptr: If Msg = NULL Then Msg = CAllocate(8192 + 2)
   
   Function = HRes
   If HRes = DISP_E_EXCEPTION Then
      COMErr.Number = EInfo.sCode
      COMErr.Description= "Err(&H" & Hex(HRes) & ") in " & *Cast(WString Ptr, EInfo.bstrSource) & ", whilst calling: " & *Cast(WString Ptr, MethodName) & Chr(10) & *Cast(WString Ptr, EInfo.bstrDescription)
   ElseIf HRes Then
      FormatMessageW FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS, NULL, HRes, MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), Msg, 4096, NULL
      COMErr.Number = HRes
      COMErr.Description= "Err(&H" & Hex(HRes) & ") in SimpleVariant.bi, whilst calling: " & *Cast(WString Ptr, MethodName) & Chr(10) & *Msg
   End If
   If CBool(HRes) And ShowCOMErrors Then MsgBox COMErr.Description
End Function

'the usual Instantiation-Helper for COM-Objects which are known in the Win-Registry (e.g. CreateObject("Scripting.Dictionary")
Function CreateObject(ByVal ProgID As LPCOLESTR) As tagVariant
   If Not Done Then Done = True: CoInitializeEx(0, 2): DyLibLoad("shell32.dll"): DyLibLoad("comctl32.dll")
   
   COMErr.Number = 0
   Dim CLSID As CLSID, RetVal As tagVariant
   If HandleCOMErr(CLSIDFromProgID(ProgID, @ClsID), "CLSIDFromProgID") Then Return RetVal
   If HandleCOMErr(CoCreateInstance(@ClsID, NULL, CLSCTX_SERVER, @IID_IDispatch, @RetVal.pDispVal), "CreateObject") Then Return RetVal
   RetVal.VT = VT_DISPATCH
   Return RetVal
End Function

'but here's a helper-function to create COM-Objects regfree, in case the user provided a *.manifest-File (and placed it beside the COM-Dll-File)
Function CreateObjectRegFree(ProgID As WString Ptr, ManifestFileName As WString Ptr) As tagVariant
   Static ACW As ACTCTXW
   ACW.cbSize = Len(ACW)
   ACW.lpSource = ManifestFileName
   
   COMErr.Number = 0
   
   Dim hActCtx As HANDLE, Cookie As ULONG_PTR
   hActCtx = CreateActCtxW(@ACW)
   If (hActCtx = INVALID_HANDLE_VALUE) Then
      COMErr.Number = &H80020009
      COMErr.Description = "Couldn't create ActCtx from Manifest: " & *ManifestFileName
      If ShowCOMErrors Then MsgBox COMErr.Description
      Exit Function
   End If
   
   If ActivateActCtx(hActCtx, @Cookie) Then
      Dim OrigDir As String, DllPath As String = Left(*ManifestFileName, InStrRev(*ManifestFileName, "\"))
      OrigDir = CurDir()
      ChDir DllPath
      Function = CreateObject(ProgID)
      ChDir OrigDir
      DeactivateActCtx 0, Cookie
   Else
      COMErr.Number = &H80020009
      COMErr.Description = "Couldn't activate ActCtx from Manifest: " & *ManifestFileName
      If ShowCOMErrors Then MsgBox COMErr.Description
   End If
   
   ReleaseActCtx hActCtx
End Function

Function BSTR2S cdecl (ByVal BS As Const BSTR, ByVal CodePage As UINT = DefaultCodePage_StringConv) As String
   Dim BytesNeeded As UINT, S As String
   BytesNeeded = WideCharToMultiByte(CodePage, 0, BS, SysStringLen(BS), 0, 0, 0, 0)
   S = String(BytesNeeded, 0)
   WideCharToMultiByte CodePage, 0, BS, SysStringLen(BS), StrPtr(S), BytesNeeded, 0, 0
   Return S
End Function
Function S2BSTR cdecl (S As Const String, ByVal CodePage As UINT = DefaultCodePage_StringConv) As BSTR 'the caller is responsible for freeing the returned BSTR per SysFreeString
   Dim WCharsNeeded As UINT, BS As BSTR
   WCharsNeeded = MultiByteToWideChar(CodePage, 0, StrPtr(S), Len(S), 0, 0)
   BS = SysAllocStringLen(BS, WCharsNeeded)
   MultiByteToWideChar CodePage, 0, StrPtr(S), Len(S), BS, WCharsNeeded
   Return BS
End Function

Function BSTR2W(ByVal BS As Const BSTR) As WString Ptr 'the caller is responsible for freeing the returned WString per DeAllocate
   Dim W As WString Ptr
   W = CAllocate(SysStringByteLen(BS) + 2)
   If BS Then memcpy W, BS, SysStringByteLen(BS)
   Return W
End Function
Function W2BSTR(ByVal W As Const WString Ptr) As BSTR 'the caller is responsible for freeing the returned BSTR per SysFreeString
   Return SysAllocString(W)
End Function

'well, this is the workhorse for all the Dispatch-Calls (IDispatch::Invoke)... there's easier Wrapper-Methods around this at the end of this module)
Dim Shared LastDispID As Long = 0, UseDispId As Long = 0
#ifdef __FB_64BIT__
   Function CallByName cdecl (vDisp As tagVariant, ByVal MethodName As LPOLESTR, ByVal CallFlag As Word, TypeChars As String = "", ByVal Arg0 As Any Ptr = 0, ByVal Arg1 As Any Ptr = 0, ByVal Arg2 As Any Ptr = 0, ByVal Arg3 As Any Ptr = 0, ByVal Arg4 As Any Ptr = 0, ByVal Arg5 As Any Ptr = 0, ByVal Arg6 As Any Ptr = 0, ByVal Arg7 As Any Ptr = 0, ByVal Arg8 As Any Ptr = 0, ByVal Arg9 As Any Ptr = 0, ByVal Arg10 As Any Ptr = 0, ByVal Arg11 As Any Ptr = 0, ByVal Arg12 As Any Ptr = 0, ByVal Arg13 As Any Ptr = 0, ByVal Arg14 As Any Ptr = 0, ByVal Arg15 As Any Ptr = 0, ByVal Arg16 As Any Ptr = 0, ByVal Arg17 As Any Ptr = 0, ByVal Arg18 As Any Ptr = 0, ByVal Arg19 As Any Ptr = 0,ByVal Arg20 As Any Ptr = 0,ByVal Arg21 As Any Ptr = 0,ByVal Arg22 As Any Ptr = 0,ByVal Arg23 As Any Ptr = 0,ByVal Arg24 As Any Ptr = 0,ByVal Arg25 As Any Ptr = 0,ByVal Arg26 As Any Ptr = 0,ByVal Arg27 As Any Ptr = 0,ByVal Arg28 As Any Ptr = 0,ByVal Arg29 As Any Ptr = 0,ByVal Arg30 As Any Ptr = 0,ByVal Arg31 As Any Ptr = 0) As tagVariant
      Static DispParams As DISPPARAMS, DispidNamed As DISPID = DISPID_PROPERTYPUT
      Static VParams(31) As tagVariant, SArr(31) As BSTR, ArgsArr(31) As Any Ptr
      Const As UByte l=108,i=105,b=98,d=100,f=102,t=116,v=118,w=119,s=115,c=99,u=117,sR=83,wR=87 'to make the Type-Selects more readable
      Dim TypeChar As UByte, IsByRef As Boolean, VRes As tagVariant, DispId As DISPID
      Dim Args(31) As Any Ptr => {Arg0, Arg1, Arg2, Arg3, Arg4, Arg5, Arg6, Arg7, Arg8, Arg9, Arg10, Arg11, Arg12, Arg13, Arg14, Arg15, Arg16, Arg17, Arg18, Arg19, Arg20, Arg21, Arg22, Arg23, Arg24, Arg25, Arg26, Arg27, Arg28, Arg29, Arg30, Arg31}
      Dim k As Integer

      If UseDispID Then DispID = UseDispID: UseDispID = 0
      COMErr.Number = 0
      If DispID = 0 Then
         LastDispID = 0
         If HandleCOMErr(vDisp.pDispVal->lpVtbl->GetIDsOfNames(vDisp.pDispVal, @IID_NULL, @MethodName, 1, LOCALE_USER_DEFAULT, @DispId), MethodName) Then Return VRes
         LastDispID = DispId
      End If
      
      DispParams.cArgs = Len(TypeChars)
      DispParams.rgVarg = @VParams(0)
      DispParams.cNamedArgs = IIf(CallFlag >= DISPATCH_PROPERTYPUT, 1, 0)
      DispParams.rgdispidNamedArgs = IIf(CallFlag >= DISPATCH_PROPERTYPUT, @DispidNamed, 0)
      
      k = -1
      For j As Integer = DispParams.cArgs - 1 To 0 Step -1
         k = k + 1
         TypeChar = TypeChars[DispParams.cArgs - j - 1]
         IsByRef  = TypeChar < 97
         If IsByRef Then TypeChar += 32 'since the ByRef-Info is now retrieved, we work further with just the lower-case letter
         
         'in a first pass, we set only the proper Variant-Type-Members
         Select Case TypeChar
         Case s,w: VParams(j).VT = VT_BSTR    Or VT_BYREF
         Case u:   VParams(j).VT = VT_UI1     Or VT_BYREF
         Case i:   VParams(j).VT = VT_I2      Or VT_BYREF
         Case l:   VParams(j).VT = VT_I4      Or VT_BYREF
         Case c:   VParams(j).VT = VT_CY      Or IIf(IsByRef, VT_BYREF, 0)
         Case b:   VParams(j).VT = VT_BOOL    Or IIf(IsByRef, VT_BYREF, 0)
         Case f:   VParams(j).VT = VT_R4      Or IIf(IsByRef, VT_BYREF, 0)
         Case d:   VParams(j).VT = VT_R8      Or VT_BYREF
         Case t:   VParams(j).VT = VT_DATE    Or VT_BYREF
         Case v:   VParams(j).VT = VT_VARIANT Or VT_BYREF
         End Select
         
         'in a second pass, we set the Variant-Value-Members of our (static) VParams-Array
         Select Case TypeChar
         Case s,w:  If IsByRef Then ArgsArr(j) = Args(k)
            If SArr(j) Then SysFreeString SArr(j): SArr(j) = 0 'destroy the previous allocation from our static BSTR-Cache
            Select Case TypeChar
            Case s: If IsByRef Then SArr(j) = S2BSTR(*Cast(String Ptr, Args(k)))      Else SArr(j) = S2BSTR(*Cast(ZString Ptr, Args(k)))
            Case w: If IsByRef Then SArr(j) = W2BSTR(*Cast(WString Ptr Ptr, Args(k))) Else SArr(j) = W2BSTR(*Cast(WString Ptr, Args(k)))
            End Select
            VParams(j).pbstrVal = @SArr(j)
         Case v:    VParams(j) = *Cast(tagVARIANT Ptr, Args(k))
         Case f:    If IsByRef Then VParams(j).pbVal = Args(k) Else VParams(j).fltVal = CSng(*Cast(Double Ptr, Args(k)))
         Case b:    If IsByRef Then VParams(j).pbVal = Args(k) Else VParams(j).boolVal = CShort(*Cast(Boolean Ptr, Args(k)))
         Case c:    If IsByRef Then VParams(j).pbVal = Args(k) Else VParams(j).llVal = *Cast(LongInt Ptr, Args(k)) * 10000
         Case Else: If IsByRef Then VParams(j).pbVal = Args(k) Else VParams(j).pbVal  = Args(k)
         End Select
         
         '      'what remains is the type-based Args-Shift
         '      Select Case TypeChar
         '      Case s,w,v: Args = va_next(Args, Any Ptr)
         '      Case f,d,t: If IsByRef Then Args = va_next(Args, Any Ptr) Else Args = va_next(Args, Double)
         '      Case i:     If IsByRef Then Args = va_next(Args, Any Ptr) Else Args = va_next(Args, Short)
         '      Case l:     If IsByRef Then Args = va_next(Args, Any Ptr) Else Args = va_next(Args, Long)
         '      Case b:     If IsByRef Then Args = va_next(Args, Any Ptr) Else Args = va_next(Args, Boolean)
         '      Case u:     If IsByRef Then Args = va_next(Args, Any Ptr) Else Args = va_next(Args, UByte)
         '      Case c:     If IsByRef Then Args = va_next(Args, Any Ptr) Else Args = va_next(Args, LongInt)
         '      End Select
      Next
      
      HandleCOMErr vDisp.pDispVal->lpVtbl->Invoke(VDisp.pDispVal, DispId, @IID_NULL, LOCALE_USER_DEFAULT, CallFlag, @DispParams, @VRes, @EInfo, NULL), MethodName
      
      'this is needed, to pass back any StringValues from our SArr-BSTR-Cache into the FB-StringVariables (in the ByRef-case)
      For j As Integer = DispParams.cArgs - 1 To 0 Step -1
         If VParams(j).VT = (VT_BSTR Or VT_BYREF) Then
            Select Case TypeChars[DispParams.cArgs - j - 1]
            Case sR: *Cast(String Ptr, ArgsArr(j))      = BSTR2S(SArr(j)) 'pass back, in case it was a FB-ByRef-String
            Case wR: *Cast(WString Ptr Ptr, ArgsArr(j)) = BSTR2W(SArr(j)) 'pass back, in case it was a FB-ByRef-WString
            End Select
         End If
      Next
      
      Return VRes
   End Function
#else
   Function CallByName cdecl (vDisp As tagVariant, ByVal MethodName As LPOLESTR, ByVal CallFlag As Word, TypeChars As String = "", ByVal Args As Any Ptr) As tagVariant
      Static DispParams As DISPPARAMS, DispidNamed As DISPID = DISPID_PROPERTYPUT
      Static VParams(31) As tagVariant, SArr(31) As BSTR, ArgsArr(31) As Any Ptr
      Const As UByte l=108,i=105,b=98,d=100,f=102,t=116,v=118,w=119,s=115,c=99,u=117,sR=83,wR=87 'to make the Type-Selects more readable
      Dim TypeChar As UByte, IsByRef As Boolean, VRes As tagVariant, DispId As DISPID
      
      If UseDispID Then DispID = UseDispID: UseDispID = 0
      COMErr.Number = 0
      If DispID = 0 Then
         LastDispID = 0
         If HandleCOMErr(vDisp.pDispVal->lpVtbl->GetIDsOfNames(vDisp.pDispVal, @IID_NULL, @MethodName, 1, LOCALE_USER_DEFAULT, @DispId), MethodName) Then Return VRes
         LastDispID = DispId
      End If
      
      DispParams.cArgs = Len(TypeChars)
      DispParams.rgVarg = @VParams(0)
      DispParams.cNamedArgs = IIf(CallFlag >= DISPATCH_PROPERTYPUT, 1, 0)
      DispParams.rgdispidNamedArgs = IIf(CallFlag >= DISPATCH_PROPERTYPUT, @DispidNamed, 0)
      
      For j As Integer = DispParams.cArgs - 1 To 0 Step -1
         TypeChar = TypeChars[DispParams.cArgs - j - 1]
         IsByRef  = TypeChar < 97
         If IsByRef Then TypeChar += 32 'since the ByRef-Info is now retrieved, we work further with just the lower-case letter
         
         'in a first pass, we set only the proper Variant-Type-Members
         Select Case TypeChar
         Case s,w: VParams(j).VT = VT_BSTR    Or VT_BYREF
         Case u:   VParams(j).VT = VT_UI1     Or VT_BYREF
         Case i:   VParams(j).VT = VT_I2      Or VT_BYREF
         Case l:   VParams(j).VT = VT_I4      Or VT_BYREF
         Case c:   VParams(j).VT = VT_CY      Or IIf(IsByRef, VT_BYREF, 0)
         Case b:   VParams(j).VT = VT_BOOL    Or IIf(IsByRef, VT_BYREF, 0)
         Case f:   VParams(j).VT = VT_R4      Or IIf(IsByRef, VT_BYREF, 0)
         Case d:   VParams(j).VT = VT_R8      Or VT_BYREF
         Case t:   VParams(j).VT = VT_DATE    Or VT_BYREF
         Case v:   VParams(j).VT = VT_VARIANT Or VT_BYREF
         End Select
         
         'in a second pass, we set the Variant-Value-Members of our (static) VParams-Array
         Select Case TypeChar
         Case s,w:  If IsByRef Then ArgsArr(j) = Args
            If SArr(j) Then SysFreeString SArr(j): SArr(j) = 0 'destroy the previous allocation from our static BSTR-Cache
            Select Case TypeChar
            Case s: If IsByRef Then SArr(j) = S2BSTR(*va_arg(Args, String Ptr))      Else SArr(j) = S2BSTR(*va_arg(Args, ZString Ptr))
            Case w: If IsByRef Then SArr(j) = W2BSTR(*va_arg(Args, WString Ptr Ptr)) Else SArr(j) = W2BSTR(*va_arg(Args, WString Ptr))
            End Select
            VParams(j).pbstrVal = @SArr(j)
         Case v:    VParams(j) = *va_arg(Args, tagVARIANT Ptr)
         Case f:    If IsByRef Then VParams(j).pbVal = va_arg(Args, Any Ptr) Else VParams(j).fltVal = CSng(va_arg(Args, Double))
         Case b:    If IsByRef Then VParams(j).pbVal = va_arg(Args, Any Ptr) Else VParams(j).boolVal = CShort(va_arg(Args, Boolean))
         Case c:    If IsByRef Then VParams(j).pbVal = va_arg(Args, Any Ptr) Else VParams(j).llVal = va_arg(Args, LongInt) * 10000
         Case Else: If IsByRef Then VParams(j).pbVal = va_arg(Args, Any Ptr) Else VParams(j).pbVal  = Args
         End Select
         
         'what remains is the type-based Args-Shift
         Select Case TypeChar
         Case s,w,v: Args = va_next(Args, Any Ptr)
         Case f,d,t: If IsByRef Then Args = va_next(Args, Any Ptr) Else Args = va_next(Args, Double)
         Case i:     If IsByRef Then Args = va_next(Args, Any Ptr) Else Args = va_next(Args, Short)
         Case l:     If IsByRef Then Args = va_next(Args, Any Ptr) Else Args = va_next(Args, Long)
         Case b:     If IsByRef Then Args = va_next(Args, Any Ptr) Else Args = va_next(Args, Boolean)
         Case u:     If IsByRef Then Args = va_next(Args, Any Ptr) Else Args = va_next(Args, UByte)
         Case c:     If IsByRef Then Args = va_next(Args, Any Ptr) Else Args = va_next(Args, LongInt)
         End Select
      Next
      
      HandleCOMErr vDisp.pDispVal->lpVtbl->Invoke(VDisp.pDispVal, DispId, @IID_NULL, LOCALE_USER_DEFAULT, CallFlag, @DispParams, @VRes, @EInfo, NULL), MethodName
      
      'this is needed, to pass back any StringValues from our SArr-BSTR-Cache into the FB-StringVariables (in the ByRef-case)
      For j As Integer = DispParams.cArgs - 1 To 0 Step -1
         If VParams(j).VT = (VT_BSTR Or VT_BYREF) Then
            Select Case TypeChars[DispParams.cArgs - j - 1]
            Case sR: *va_arg(ArgsArr(j), String Ptr)      = BSTR2S(SArr(j)) 'pass back, in case it was a FB-ByRef-String
            Case wR: *va_arg(ArgsArr(j), WString Ptr Ptr) = BSTR2W(SArr(j)) 'pass back, in case it was a FB-ByRef-WString
            End Select
         End If
      Next
      
      Return VRes
   End Function
#endif
'*************************** Begin of the Variant-Wrapper-Section *******************************

Enum vbVarType
   vbEmpty    = &H0000
   vbNull     = &H0001
   vbInteger  = &H0002
   vbLong     = &H0003
   vbSingle   = &H0004
   vbDouble   = &H0005
   vbCurrency = &H0006
   vbDate     = &H0007
   vbString   = &H0008
   vbObject   = &H0009
   vbError    = &H000A
   vbBoolean  = &H000B
   vbVariant  = &H000C
   vbDecimal  = &H000E
   vbByte     = &H0011
   vbArray    = &H2000
   vbByRef    = &H4000
End Enum

Type vbVariant
   V As tagVariant
   Declare Constructor()
   Declare Destructor()
   Declare Sub Clear()
   
   Declare Function VarType()  As vbVarType
   Declare Function TypeName() As String
   Declare Function IsEmpty()  As Boolean
   Declare Function IsArray()  As Boolean
   Declare Function IsObject() As Boolean
   
   Declare Constructor (ByVal RHS As Boolean)
   Declare Operator Let(ByVal RHS As Boolean)
   Declare Operator Cast() As Boolean
   
   Declare Constructor (ByVal RHS As UByte)
   Declare Operator Let(ByVal RHS As UByte)
   Declare Operator Cast() As UByte
   
   Declare Constructor (ByVal RHS As Short)
   Declare Operator Let(ByVal RHS As Short)
   Declare Operator Cast() As Short
   
   Declare Constructor (ByVal RHS As Long)
   Declare Operator Let(ByVal RHS As Long)
   Declare Operator Cast() As Long
   
   Declare Constructor (ByVal RHS As LongInt)
   Declare Operator Let(ByVal RHS As LongInt)
   Declare Operator Cast() As LongInt
   
   Declare Constructor (ByVal RHS As Single)
   Declare Operator Let(ByVal RHS As Single)
   Declare Operator Cast() As Single
   
   Declare Constructor (ByVal RHS As Double)
   Declare Operator Let(ByVal RHS As Double)
   Declare Operator Cast() As Double
   
   Declare Constructor (RHS As String)
   Declare Operator Let(RHS As String)
   Declare Operator Cast()  As String
   
   Declare Constructor (ByVal RHS As Const WString Ptr)
   Declare Operator Let(ByVal RHS As Const WString Ptr)
   Declare Operator Cast() As WString Ptr
   
   Declare Constructor (RHS As tagVariant)
   Declare Operator Let(RHS As tagVariant)
   Declare Operator Cast()  As tagVariant
   
   Declare Constructor (RHS As vbVariant)
   Declare Operator Let(RHS As vbVariant)
   
   #ifdef __FB_64BIT__
      Declare Function Call cdecl (ByVal MethodName As LPOLESTR, TypeChars As String = "", ByVal Arg0 As Any Ptr = 0, ByVal Arg1 As Any Ptr = 0, ByVal Arg2 As Any Ptr = 0, ByVal Arg3 As Any Ptr = 0, ByVal Arg4 As Any Ptr = 0, ByVal Arg5 As Any Ptr = 0, ByVal Arg6 As Any Ptr = 0, ByVal Arg7 As Any Ptr = 0, ByVal Arg8 As Any Ptr = 0, ByVal Arg9 As Any Ptr = 0, ByVal Arg10 As Any Ptr = 0, ByVal Arg11 As Any Ptr = 0, ByVal Arg12 As Any Ptr = 0, ByVal Arg13 As Any Ptr = 0, ByVal Arg14 As Any Ptr = 0, ByVal Arg15 As Any Ptr = 0, ByVal Arg16 As Any Ptr = 0, ByVal Arg17 As Any Ptr = 0, ByVal Arg18 As Any Ptr = 0, ByVal Arg19 As Any Ptr = 0, ByVal Arg20 As Any Ptr = 0, ByVal Arg21 As Any Ptr = 0, ByVal Arg22 As Any Ptr = 0, ByVal Arg23 As Any Ptr = 0, ByVal Arg24 As Any Ptr = 0, ByVal Arg25 As Any Ptr = 0, ByVal Arg26 As Any Ptr = 0, ByVal Arg27 As Any Ptr = 0, ByVal Arg28 As Any Ptr = 0, ByVal Arg29 As Any Ptr = 0, ByVal Arg30 As Any Ptr = 0, ByVal Arg31 As Any Ptr = 0) As vbVariant
      Declare Function  Get cdecl (ByVal MethodName As LPOLESTR, TypeChars As String = "", ByVal Arg0 As Any Ptr = 0, ByVal Arg1 As Any Ptr = 0, ByVal Arg2 As Any Ptr = 0, ByVal Arg3 As Any Ptr = 0, ByVal Arg4 As Any Ptr = 0, ByVal Arg5 As Any Ptr = 0, ByVal Arg6 As Any Ptr = 0, ByVal Arg7 As Any Ptr = 0, ByVal Arg8 As Any Ptr = 0, ByVal Arg9 As Any Ptr = 0, ByVal Arg10 As Any Ptr = 0, ByVal Arg11 As Any Ptr = 0, ByVal Arg12 As Any Ptr = 0, ByVal Arg13 As Any Ptr = 0, ByVal Arg14 As Any Ptr = 0, ByVal Arg15 As Any Ptr = 0, ByVal Arg16 As Any Ptr = 0, ByVal Arg17 As Any Ptr = 0, ByVal Arg18 As Any Ptr = 0, ByVal Arg19 As Any Ptr = 0, ByVal Arg20 As Any Ptr = 0, ByVal Arg21 As Any Ptr = 0, ByVal Arg22 As Any Ptr = 0, ByVal Arg23 As Any Ptr = 0, ByVal Arg24 As Any Ptr = 0, ByVal Arg25 As Any Ptr = 0, ByVal Arg26 As Any Ptr = 0, ByVal Arg27 As Any Ptr = 0, ByVal Arg28 As Any Ptr = 0, ByVal Arg29 As Any Ptr = 0, ByVal Arg30 As Any Ptr = 0, ByVal Arg31 As Any Ptr = 0) As vbVariant
      Declare Sub       Put cdecl (ByVal MethodName As LPOLESTR, TypeChars As String = "", ByVal Arg0 As Any Ptr = 0, ByVal Arg1 As Any Ptr = 0, ByVal Arg2 As Any Ptr = 0, ByVal Arg3 As Any Ptr = 0, ByVal Arg4 As Any Ptr = 0, ByVal Arg5 As Any Ptr = 0, ByVal Arg6 As Any Ptr = 0, ByVal Arg7 As Any Ptr = 0, ByVal Arg8 As Any Ptr = 0, ByVal Arg9 As Any Ptr = 0, ByVal Arg10 As Any Ptr = 0, ByVal Arg11 As Any Ptr = 0, ByVal Arg12 As Any Ptr = 0, ByVal Arg13 As Any Ptr = 0, ByVal Arg14 As Any Ptr = 0, ByVal Arg15 As Any Ptr = 0, ByVal Arg16 As Any Ptr = 0, ByVal Arg17 As Any Ptr = 0, ByVal Arg18 As Any Ptr = 0, ByVal Arg19 As Any Ptr = 0, ByVal Arg20 As Any Ptr = 0, ByVal Arg21 As Any Ptr = 0, ByVal Arg22 As Any Ptr = 0, ByVal Arg23 As Any Ptr = 0, ByVal Arg24 As Any Ptr = 0, ByVal Arg25 As Any Ptr = 0, ByVal Arg26 As Any Ptr = 0, ByVal Arg27 As Any Ptr = 0, ByVal Arg28 As Any Ptr = 0, ByVal Arg29 As Any Ptr = 0, ByVal Arg30 As Any Ptr = 0, ByVal Arg31 As Any Ptr = 0)
      Declare Sub       Set cdecl (ByVal MethodName As LPOLESTR, TypeChars As String = "", ByVal Arg0 As Any Ptr = 0, ByVal Arg1 As Any Ptr = 0, ByVal Arg2 As Any Ptr = 0, ByVal Arg3 As Any Ptr = 0, ByVal Arg4 As Any Ptr = 0, ByVal Arg5 As Any Ptr = 0, ByVal Arg6 As Any Ptr = 0, ByVal Arg7 As Any Ptr = 0, ByVal Arg8 As Any Ptr = 0, ByVal Arg9 As Any Ptr = 0, ByVal Arg10 As Any Ptr = 0, ByVal Arg11 As Any Ptr = 0, ByVal Arg12 As Any Ptr = 0, ByVal Arg13 As Any Ptr = 0, ByVal Arg14 As Any Ptr = 0, ByVal Arg15 As Any Ptr = 0, ByVal Arg16 As Any Ptr = 0, ByVal Arg17 As Any Ptr = 0, ByVal Arg18 As Any Ptr = 0, ByVal Arg19 As Any Ptr = 0, ByVal Arg20 As Any Ptr = 0, ByVal Arg21 As Any Ptr = 0, ByVal Arg22 As Any Ptr = 0, ByVal Arg23 As Any Ptr = 0, ByVal Arg24 As Any Ptr = 0, ByVal Arg25 As Any Ptr = 0, ByVal Arg26 As Any Ptr = 0, ByVal Arg27 As Any Ptr = 0, ByVal Arg28 As Any Ptr = 0, ByVal Arg29 As Any Ptr = 0, ByVal Arg30 As Any Ptr = 0, ByVal Arg31 As Any Ptr = 0)
   #else
      Declare Function Call cdecl (ByVal MethodName As LPOLESTR, TypeChars As String = "", ...) As vbVariant
      Declare Function  Get cdecl (ByVal MethodName As LPOLESTR, TypeChars As String = "", ...) As vbVariant
      Declare Sub       Put cdecl (ByVal MethodName As LPOLESTR, TypeChars As String = "", ...)
      Declare Sub       Set cdecl (ByVal MethodName As LPOLESTR, TypeChars As String = "", ...)
   #endif
   Declare Function  vbV() As vbVariant
   'Declares
End Type
'Functions
Function vbVariant.vbV() As vbVariant
   Return This
End Function
Constructor vbVariant()
   'we dont't do anything here in the base constructor currently
End Constructor
Destructor vbVariant()
   'MsgBox "Destructor of: " & TypeName
   If V.VT Then VariantClear @V
End Destructor
Sub vbVariant.Clear() 'usable on the Outside, e.g. to dereference an Object "early"
   If V.VT Then VariantClear @V: VariantInit @V
End Sub

Function WCacheValue(BSTR2Copy As BSTR) As WString Ptr 'a little Helper, to avoid leaking with the WString-DataType (in the User-Code)
   Const  CacheSize As Integer = 1024
   Static Cache(0 To CacheSize-1) As WString Ptr, NxtIdx As Integer
   NxtIdx= (NxtIdx + 1) Mod CacheSize
   If Cache(NxtIdx) Then Deallocate Cache(NxtIdx)
   Cache(NxtIdx) = BSTR2W(BSTR2Copy)
   Return Cache(NxtIdx)
End Function

Function vbVariant.VarType() As vbVarType
   Return V.VT
End Function
Function vbVariant.TypeName() As String
   Dim T As String
   Select Case V.VT And Not (vbArray Or vbByRef)
   Case vbVarType.vbEmpty:    T = "Empty"
   Case vbVarType.vbNull:     T = "Null"
   Case vbVarType.vbInteger:  T = "Integer"
   Case vbVarType.vbLong:     T = "Long"
   Case vbVarType.vbSingle:   T = "Single"
   Case vbVarType.vbDouble:   T = "Double"
   Case vbVarType.vbCurrency: T = "Currency"
   Case vbVarType.vbDate:     T = "Date"
   Case vbVarType.vbString:   T = "String"
   Case vbVarType.vbObject:   T = "Object"
   Case vbVarType.vbError:    T = "Error"
   Case vbVarType.vbBoolean:  T = "Boolean"
   Case vbVarType.vbVariant:  T = "Variant"
   Case vbVarType.vbDecimal:  T = "Decimal"
   Case vbVarType.vbByte:     T = "Byte"
   Case Else:                 T = "UnsupportedType(" & Hex(V.VT) & ")"
   End Select
   If V.VT And vbArray Then Return T & "()"
   Return T
End Function
Function vbVariant.IsEmpty() As Boolean
   Return V.VT = vbEmpty
End Function
Function vbVariant.IsArray() As Boolean
   If V.VT And vbArray Then Return True
End Function
Function vbVariant.IsObject() As Boolean
   Return V.VT = vbObject
End Function


Constructor vbVariant(ByVal RHS As Boolean)
   This = RHS
End Constructor
Operator vbVariant.Let(ByVal RHS As Boolean)
   If V.VT <> vbBoolean  And V.VT <> vbEmpty Then VariantClear @V
   V.VT =  vbBoolean: V.boolVal = CShort(RHS)
End Operator
Operator vbVariant.Cast() As Boolean
   If V.VT = vbBoolean Then
      Return CBool(V.boolVal)
   Else
      Dim VV As tagVariant
      HandleCOMErr VariantChangeTypeEx(@VV, @V, DefaultLocale_VariantConv, VARIANT_NOVALUEPROP Or VARIANT_ALPHABOOL, vbBoolean), "SimpleVariant.Cast_Boolean"
      Return CBool(VV.boolVal)
   End If
End Operator


Constructor vbVariant(ByVal RHS As UByte)
   This = RHS
End Constructor
Operator vbVariant.Let(ByVal RHS As UByte)
   If V.VT <> vbByte  And V.VT <> vbEmpty Then VariantClear @V
   V.VT =  vbByte: V.bVal = RHS
End Operator
Operator vbVariant.Cast() As UByte
   If V.VT = vbByte Then
      Return V.bVal
   Else
      Dim VV As tagVariant
      HandleCOMErr VariantChangeTypeEx(@VV, @V, DefaultLocale_VariantConv, VARIANT_NOVALUEPROP, vbByte), "SimpleVariant.Cast_UByte"
      Return VV.bVal
   End If
End Operator


Constructor vbVariant(ByVal RHS As Short)
   This = RHS
End Constructor
Operator vbVariant.Let(ByVal RHS As Short)
   If V.VT <> vbInteger  And V.VT <> vbEmpty Then VariantClear @V
   V.VT =  vbInteger: V.iVal = RHS
End Operator
Operator vbVariant.Cast() As Short
   If V.VT = vbInteger Then
      Return V.iVal
   Else
      Dim VV As tagVariant
      HandleCOMErr VariantChangeTypeEx(@VV, @V, DefaultLocale_VariantConv, VARIANT_NOVALUEPROP, vbInteger), "SimpleVariant.Cast_Short"
      Return VV.iVal
   End If
End Operator


Constructor vbVariant(ByVal RHS As Long)
   This = RHS
End Constructor
Operator vbVariant.Let(ByVal RHS As Long)
   If V.VT <> vbLong  And V.VT <> vbEmpty Then VariantClear @V
   V.VT =  vbLong: V.lVal = RHS
End Operator
Operator vbVariant.Cast() As Long
   If V.VT = vbLong Then
      Return V.lVal
   Else
      Dim VV As tagVariant
      HandleCOMErr VariantChangeTypeEx(@VV, @V, DefaultLocale_VariantConv, VARIANT_NOVALUEPROP, vbLong), "SimpleVariant.Cast_Long"
      Return VV.lVal
   End If
End Operator


Constructor vbVariant(ByVal RHS As LongInt)
   This = RHS
End Constructor
Operator vbVariant.Let(ByVal RHS As LongInt)
   If V.VT <> vbCurrency  And V.VT <> vbEmpty Then VariantClear @V
   V.VT =  vbCurrency: V.llVal = RHS * 10000
End Operator
Operator vbVariant.Cast() As LongInt
   If V.VT = vbCurrency Then
      Return V.llVal / 10000
   Else
      Dim VV As tagVariant
      HandleCOMErr VariantChangeTypeEx(@VV, @V, DefaultLocale_VariantConv, VARIANT_NOVALUEPROP, VT_I8), "SimpleVariant.Cast_LongInt"
      Return VV.llVal
   End If
End Operator


Constructor vbVariant(ByVal RHS As Single)
   This = RHS
End Constructor
Operator vbVariant.Let(ByVal RHS As Single)
   If V.VT <> vbSingle  And V.VT <> vbEmpty Then VariantClear @V
   V.VT =  vbSingle: V.fltVal = RHS
End Operator
Operator vbVariant.Cast() As Single
   If V.VT = vbSingle Then
      Return V.fltVal
   Else
      Dim VV As tagVariant
      HandleCOMErr VariantChangeTypeEx(@VV, @V, DefaultLocale_VariantConv, VARIANT_NOVALUEPROP, vbSingle), "SimpleVariant.Cast_Single"
      Return VV.fltVal
   End If
End Operator


Constructor vbVariant(ByVal RHS As Double)
   This = RHS
End Constructor
Operator vbVariant.Let(ByVal RHS As Double)
   If V.VT <> vbDouble  And V.VT <> vbEmpty Then VariantClear @V
   V.VT =  vbDouble: V.dblVal = RHS
End Operator
Operator vbVariant.Cast() As Double
   If V.VT = vbDouble Then
      Return V.dblVal
   Else
      Dim VV As tagVariant
      HandleCOMErr VariantChangeTypeEx(@VV, @V, DefaultLocale_VariantConv, VARIANT_NOVALUEPROP, vbDouble), "SimpleVariant.Cast_Double"
      Return VV.dblVal
   End If
End Operator


Constructor vbVariant(RHS As String)
   This = RHS
End Constructor
Operator vbVariant.Let(RHS As String)
   If V.VT Then VariantClear @V
   V.VT = vbString: V.bstrVal = S2BSTR(RHS)
End Operator
Operator vbVariant.Cast() As String
   If V.VT = vbString Then
      Return BSTR2S(V.bstrVal)
   Else
      Dim VV As tagVariant
      HandleCOMErr VariantChangeTypeEx(@VV, @V, DefaultLocale_VariantConv, VARIANT_NOVALUEPROP Or VARIANT_ALPHABOOL, vbString), "SimpleVariant.Cast_String"
      If V.VT = (vbArray Or vbByte) Then
         Dim S As String = String(SysStringByteLen(VV.bstrVal), 0)
         memcpy StrPtr(S), VV.bstrVal, Len(S)
         Operator = S
      Else
         Operator = BSTR2S(VV.bstrVal)
      End If
      VariantClear @VV
   End If
End Operator


Constructor vbVariant(ByVal RHS As Const WString Ptr)
   This = RHS
End Constructor
Operator vbVariant.Let(ByVal RHS As Const WString Ptr)
   If V.VT Then VariantClear @V
   V.VT = vbString: V.bstrVal = W2BSTR(RHS)
End Operator
Operator vbVariant.Cast() As WString Ptr
   If V.VT = vbString Then
      Return WCacheValue(V.bstrVal)
   Else
      Dim VV As tagVariant
      HandleCOMErr VariantChangeTypeEx(@VV, @V, DefaultLocale_VariantConv, VARIANT_NOVALUEPROP Or VARIANT_ALPHABOOL, vbString), "SimpleVariant.Cast_WString"
      Operator = WCacheValue(VV.bstrVal)
      VariantClear @VV
   End If
End Operator


Constructor vbVariant(RHS As tagVariant)
   If @This = @RHS Then Exit Constructor
   If V.VT Then VariantClear @V
   V=RHS '<- we go with a shallow copy here (to not mess-up RefCounts - e.g. when normal tagVariants come in from Function-Results)
End Constructor
Operator vbVariant.Let(RHS As tagVariant)
   If @This = @RHS Then Exit Operator
   If V.VT Then VariantClear @V
   VariantCopy @V, @RHS
End Operator
Operator vbVariant.Cast() As tagVariant
   Dim Dst As tagVariant
   VariantCopy @Dst, @V
   Return Dst
End Operator


Constructor vbVariant(RHS As vbVariant)
   If @This = @RHS Then Exit Constructor
   If V.VT Then VariantClear @V
   VariantCopy @V, @RHS.V
End Constructor
Operator vbVariant.Let(RHS As vbVariant)
   If @This = @RHS Then Exit Operator
   If V.VT Then VariantClear @V
   VariantCopy @V, @RHS.V
End Operator

#ifdef __FB_64BIT__
   Function vbVariant.Call cdecl (ByVal MethodName As LPOLESTR, TypeChars As String = "", ByVal Arg0 As Any Ptr = 0, ByVal Arg1 As Any Ptr = 0, ByVal Arg2 As Any Ptr = 0, ByVal Arg3 As Any Ptr = 0, ByVal Arg4 As Any Ptr = 0, ByVal Arg5 As Any Ptr = 0, ByVal Arg6 As Any Ptr = 0, ByVal Arg7 As Any Ptr = 0, ByVal Arg8 As Any Ptr = 0, ByVal Arg9 As Any Ptr = 0, ByVal Arg10 As Any Ptr = 0, ByVal Arg11 As Any Ptr = 0, ByVal Arg12 As Any Ptr = 0, ByVal Arg13 As Any Ptr = 0, ByVal Arg14 As Any Ptr = 0, ByVal Arg15 As Any Ptr = 0, ByVal Arg16 As Any Ptr = 0, ByVal Arg17 As Any Ptr = 0, ByVal Arg18 As Any Ptr = 0, ByVal Arg19 As Any Ptr = 0, ByVal Arg20 As Any Ptr = 0, ByVal Arg21 As Any Ptr = 0, ByVal Arg22 As Any Ptr = 0, ByVal Arg23 As Any Ptr = 0, ByVal Arg24 As Any Ptr = 0, ByVal Arg25 As Any Ptr = 0, ByVal Arg26 As Any Ptr = 0, ByVal Arg27 As Any Ptr = 0, ByVal Arg28 As Any Ptr = 0, ByVal Arg29 As Any Ptr = 0, ByVal Arg30 As Any Ptr = 0, ByVal Arg31 As Any Ptr = 0) As vbVariant
      Dim tv As tagVariant
      tv = CallByName(V, MethodName, DISPATCH_METHOD Or DISPATCH_PROPERTYGET, TypeChars, Arg0, Arg1, Arg2, Arg3, Arg4, Arg5, Arg6, Arg7, Arg8, Arg9, Arg10, Arg11, Arg12, Arg13, Arg14, Arg15, Arg16, Arg17, Arg18, Arg19, Arg20, Arg21, Arg22, Arg23, Arg24, Arg25, Arg26, Arg27, Arg28, Arg29, Arg30, Arg31)
      Function = tv
   End Function
   Function vbVariant.Get cdecl (ByVal MethodName As LPOLESTR, TypeChars As String = "", ByVal Arg0 As Any Ptr = 0, ByVal Arg1 As Any Ptr = 0, ByVal Arg2 As Any Ptr = 0, ByVal Arg3 As Any Ptr = 0, ByVal Arg4 As Any Ptr = 0, ByVal Arg5 As Any Ptr = 0, ByVal Arg6 As Any Ptr = 0, ByVal Arg7 As Any Ptr = 0, ByVal Arg8 As Any Ptr = 0, ByVal Arg9 As Any Ptr = 0, ByVal Arg10 As Any Ptr = 0, ByVal Arg11 As Any Ptr = 0, ByVal Arg12 As Any Ptr = 0, ByVal Arg13 As Any Ptr = 0, ByVal Arg14 As Any Ptr = 0, ByVal Arg15 As Any Ptr = 0, ByVal Arg16 As Any Ptr = 0, ByVal Arg17 As Any Ptr = 0, ByVal Arg18 As Any Ptr = 0, ByVal Arg19 As Any Ptr = 0, ByVal Arg20 As Any Ptr = 0, ByVal Arg21 As Any Ptr = 0, ByVal Arg22 As Any Ptr = 0, ByVal Arg23 As Any Ptr = 0, ByVal Arg24 As Any Ptr = 0, ByVal Arg25 As Any Ptr = 0, ByVal Arg26 As Any Ptr = 0, ByVal Arg27 As Any Ptr = 0, ByVal Arg28 As Any Ptr = 0, ByVal Arg29 As Any Ptr = 0, ByVal Arg30 As Any Ptr = 0, ByVal Arg31 As Any Ptr = 0) As vbVariant
      Return CallByName(V, MethodName, DISPATCH_METHOD Or DISPATCH_PROPERTYGET, TypeChars, Arg0, Arg1, Arg2, Arg3, Arg4, Arg5, Arg6, Arg7, Arg8, Arg9, Arg10, Arg11, Arg12, Arg13, Arg14, Arg15, Arg16, Arg17, Arg18, Arg19, Arg20, Arg21, Arg22, Arg23, Arg24, Arg25, Arg26, Arg27, Arg28, Arg29, Arg30, Arg31)
   End Function
   Sub vbVariant.Put cdecl (ByVal MethodName As LPOLESTR, TypeChars As String = "", ByVal Arg0 As Any Ptr = 0, ByVal Arg1 As Any Ptr = 0, ByVal Arg2 As Any Ptr = 0, ByVal Arg3 As Any Ptr = 0, ByVal Arg4 As Any Ptr = 0, ByVal Arg5 As Any Ptr = 0, ByVal Arg6 As Any Ptr = 0, ByVal Arg7 As Any Ptr = 0, ByVal Arg8 As Any Ptr = 0, ByVal Arg9 As Any Ptr = 0, ByVal Arg10 As Any Ptr = 0, ByVal Arg11 As Any Ptr = 0, ByVal Arg12 As Any Ptr = 0, ByVal Arg13 As Any Ptr = 0, ByVal Arg14 As Any Ptr = 0, ByVal Arg15 As Any Ptr = 0, ByVal Arg16 As Any Ptr = 0, ByVal Arg17 As Any Ptr = 0, ByVal Arg18 As Any Ptr = 0, ByVal Arg19 As Any Ptr = 0, ByVal Arg20 As Any Ptr = 0, ByVal Arg21 As Any Ptr = 0, ByVal Arg22 As Any Ptr = 0, ByVal Arg23 As Any Ptr = 0, ByVal Arg24 As Any Ptr = 0, ByVal Arg25 As Any Ptr = 0, ByVal Arg26 As Any Ptr = 0, ByVal Arg27 As Any Ptr = 0, ByVal Arg28 As Any Ptr = 0, ByVal Arg29 As Any Ptr = 0, ByVal Arg30 As Any Ptr = 0, ByVal Arg31 As Any Ptr = 0)
      CallByName(V, MethodName, DISPATCH_PROPERTYPUT, TypeChars, Arg0, Arg1, Arg2, Arg3, Arg4, Arg5, Arg6, Arg7, Arg8, Arg9, Arg10, Arg11, Arg12, Arg13, Arg14, Arg15, Arg16, Arg17, Arg18, Arg19, Arg20, Arg21, Arg22, Arg23, Arg24, Arg25, Arg26, Arg27, Arg28, Arg29, Arg30, Arg31)
   End Sub
   Sub vbVariant.Set cdecl (ByVal MethodName As LPOLESTR, TypeChars As String = "", ByVal Arg0 As Any Ptr = 0, ByVal Arg1 As Any Ptr = 0, ByVal Arg2 As Any Ptr = 0, ByVal Arg3 As Any Ptr = 0, ByVal Arg4 As Any Ptr = 0, ByVal Arg5 As Any Ptr = 0, ByVal Arg6 As Any Ptr = 0, ByVal Arg7 As Any Ptr = 0, ByVal Arg8 As Any Ptr = 0, ByVal Arg9 As Any Ptr = 0, ByVal Arg10 As Any Ptr = 0, ByVal Arg11 As Any Ptr = 0, ByVal Arg12 As Any Ptr = 0, ByVal Arg13 As Any Ptr = 0, ByVal Arg14 As Any Ptr = 0, ByVal Arg15 As Any Ptr = 0, ByVal Arg16 As Any Ptr = 0, ByVal Arg17 As Any Ptr = 0, ByVal Arg18 As Any Ptr = 0, ByVal Arg19 As Any Ptr = 0, ByVal Arg20 As Any Ptr = 0, ByVal Arg21 As Any Ptr = 0, ByVal Arg22 As Any Ptr = 0, ByVal Arg23 As Any Ptr = 0, ByVal Arg24 As Any Ptr = 0, ByVal Arg25 As Any Ptr = 0, ByVal Arg26 As Any Ptr = 0, ByVal Arg27 As Any Ptr = 0, ByVal Arg28 As Any Ptr = 0, ByVal Arg29 As Any Ptr = 0, ByVal Arg30 As Any Ptr = 0, ByVal Arg31 As Any Ptr = 0)
      CallByName(V, MethodName, DISPATCH_PROPERTYPUTREF,  TypeChars, Arg0, Arg1, Arg2, Arg3, Arg4, Arg5, Arg6, Arg7, Arg8, Arg9, Arg10, Arg11, Arg12, Arg13, Arg14, Arg15, Arg16, Arg17, Arg18, Arg19, Arg20, Arg21, Arg22, Arg23, Arg24, Arg25, Arg26, Arg27, Arg28, Arg29, Arg30, Arg31)
   End Sub
#Else
   Function vbVariant.Call cdecl (ByVal MethodName As LPOLESTR, TypeChars As String = "", ...) As vbVariant
      Dim tv As tagVariant
      tv = CallByName(V, MethodName, DISPATCH_METHOD Or DISPATCH_PROPERTYGET, TypeChars, va_first)
      Function = tv
   End Function
   Function vbVariant.Get cdecl (ByVal MethodName As LPOLESTR, TypeChars As String = "", ...) As vbVariant
      Return CallByName(V, MethodName, DISPATCH_METHOD Or DISPATCH_PROPERTYGET, TypeChars, va_first)
   End Function
   Sub vbVariant.Put cdecl (ByVal MethodName As LPOLESTR, TypeChars As String = "", ...)
      CallByName(V, MethodName, DISPATCH_PROPERTYPUT, TypeChars, va_first)
   End Sub
   Sub vbVariant.Set cdecl (ByVal MethodName As LPOLESTR, TypeChars As String = "", ...)
      CallByName(V, MethodName, DISPATCH_PROPERTYPUTREF,  TypeChars, va_first)
   End Sub
#Endif
'finally a MsgBox-OverLoad, which accepts a vbVariant as the Msg-Parameter
Function MsgBox cdecl (ByVal Msg As vbVariant, ByVal Flags As Long = MB_ICONINFORMATION) As Long
   If Msg.V.VT = vbString Then
      Return MessageBoxW(GetActiveWindow, Msg.V.bstrVal, AppName, Flags)
   Else
      Dim VV As tagVariant
      HandleCOMErr VariantChangeTypeEx(@VV, @Msg.V, DefaultLocale_VariantConv, VARIANT_NOVALUEPROP Or VARIANT_ALPHABOOL, vbString), "SimpleVariant.MsgBox"
      Function = MessageBoxW(GetActiveWindow, VV.bstrVal, AppName, Flags)
      VariantClear @VV
   End If
End Function

#define Set
#define Nothing 0
Last edited by Xusinboy Bekchanov on Aug 04, 2020 4:49, edited 2 times in total.
UEZ
Posts: 613
Joined: May 05, 2017 19:59
Location: Germany

Re: COMWrapperBuilder tool

Postby UEZ » Aug 03, 2020 20:17

I'm still getting error with latest SimpleVariantPlusTemplate.bi

Code: Select all

FreeBASIC Compiler - Version 1.08.0 (2020-05-12), built for win32 (32bit)
Copyright (C) 2004-2019 The FreeBASIC development team.
standalone
target:       win32, 486, 32bit
backend:      gas
compiling:    C:\...\Excel Example.bas -o C:\...\Excel Example.asm (main module)
C:\...\Excel Example.bas(14) error 18: Element not defined, WorkBooks in 'xlApp.WorkBooks.Add'
C:\...\Excel Example.bas(15) error 18: Element not defined, Visible in 'xlApp.Visible = True'
C:\...\Excel Example.bas(17) error 18: Element not defined, ActiveSheet in 'Dim xlSheet As vbVariant = xlApp.ActiveSheet, CellValue As vbVariant'
C:\...\Excel Example.bas(19) error 18: Element not defined, Range in 'With xlSheet.Range("A1") 'let's operate from the TopLeft-cell'
C:\...\Excel Example.bas(23) error 265: Symbol not a CLASS, ENUM, TYPE or UNION type, before 'Offset' in '.Offset(0, i).Value = SArr(i)'
C:\...\Excel Example.bas(26) error 265: Symbol not a CLASS, ENUM, TYPE or UNION type, before 'Offset' in 'CellValue = .Offset(0, 1).Value '<- should return "COM-calls"'
C:\...\Excel Example.bas(30) error 18: Element not defined, Parent in 'xlSheet.Parent.Saved = True 'let's suppress the "Save Document" Dialogue ...'
C:\...\Excel Example.bas(35) error 18: Element not defined, Quit in 'xlApp.Quit '...  before we "call it quits" here'


Xusinboy Bekchanov wrote:Maybe you haven't saved your code. Or not set as main (in VisualFBEditor you need to set as main).
After the message, shows the form, there will show the path to the Main file. If there is no main file, then SimpleVariantPlus.bi does not find either.
Maybe you chose another file by mistake?

Image
grafik erstellen online kostenlos ohne anmeldung
Xusinboy Bekchanov
Posts: 243
Joined: Jul 26, 2018 18:28

Re: COMWrapperBuilder tool

Postby Xusinboy Bekchanov » Aug 04, 2020 1:12

I found my mistake. I only opened files in UTF8, so I didn't open ANSI files. Now I've fixed it, I'm trying to open it in several formats.
I updated:
https://github.com/XusinboyBekchanov/Vi ... 0ca80dfc69
UEZ
Posts: 613
Joined: May 05, 2017 19:59
Location: Germany

Re: COMWrapperBuilder tool

Postby UEZ » Aug 04, 2020 12:40

Xusinboy Bekchanov wrote:I found my mistake. I only opened files in UTF8, so I didn't open ANSI files. Now I've fixed it, I'm trying to open it in several formats.
I updated:
https://github.com/XusinboyBekchanov/Vi ... 0ca80dfc69


ANSI is still not working, getting the same error message as described above but UTF-8 (BOM) works properly (x86 and x64).
Xusinboy Bekchanov
Posts: 243
Joined: Jul 26, 2018 18:28

Re: COMWrapperBuilder tool

Postby Xusinboy Bekchanov » Aug 04, 2020 16:46

UEZ wrote:
Xusinboy Bekchanov wrote:I found my mistake. I only opened files in UTF8, so I didn't open ANSI files. Now I've fixed it, I'm trying to open it in several formats.
I updated:
https://github.com/XusinboyBekchanov/Vi ... 0ca80dfc69


ANSI is still not working, getting the same error message as described above but UTF-8 (BOM) works properly (x86 and x64).

After this update, the problem was resolved on my computer.
I will open the files like this:

Code: Select all

Result = Open(.txtPath.Text For Input Encoding "utf-8" As #Fn1)
         If Result <> 0 Then Result = Open(.txtPath.Text For Input Encoding "utf-16" As #Fn1)
         If Result <> 0 Then Result = Open(.txtPath.Text For Input Encoding "utf-32" As #Fn1)
         If Result <> 0 Then Result = Open(.txtPath.Text For Input As #Fn1)
         If Result = 0 Then
         

The last item is by default ANSI without specifying the encoding.

Return to “Projects”

Who is online

Users browsing this forum: No registered users and 6 guests