Charles,
Do you see anything in Jose's CallByName PowerBasic code that wouldn't port to O2?
' EXCEPINFO structure
' ********************************************************************************************
TYPE EXCEPINFO
wCode AS WORD ' An error code describing the error.
wReserved AS WORD ' Reserved
bstrSource AS DWORD ' Source of the exception.
bstrDescription AS DWORD ' Textual description of the error.
bstrHelpFile AS DWORD ' Help file path.
dwHelpContext AS DWORD ' Help context ID.
pvReserved AS DWORD ' Reserved.
pfnDeferredFillIn AS DWORD ' Pointer to function that fills in Help and description info.
scode AS DWORD ' An error code describing the error.
END TYPE
' ********************************************************************************************
' ********************************************************************************************
' Helper function to calculate the VTable address.
' ********************************************************************************************
FUNCTION TB_VTableAddress (BYVAL pthis AS DWORD, BYVAL dwOffset AS DWORD) AS DWORD
LOCAL ppthis AS DWORD PTR
LOCAL pvtbl AS DWORD PTR
LOCAL ppmethod AS DWORD PTR
ppthis = pthis
pvtbl = @ppthis
ppmethod = pvtbl + dwOffset
FUNCTION = @ppmethod
END FUNCTION
' ********************************************************************************************
' ********************************************************************************************
' Maps a single member to a corresponding DispID, which can be used on subsequent calls to
' IDispatch_Invoke.
' Parameters:
' riid
' Reserved for future use. Must be IID_NULL.
' strName
' Name to be mapped.
' rgDispId
' Retrieved DispID value.
' Return Value:
' The return value obtained from the returned HRESULT is one of the following:
' %S_OK Success
' %E_OUTOFMEMORY Out of memory
' %DISP_E_UNKNOWNNAME One or more of the names were not known. The returned array of DISPIDs
' contains DISPID_UNKNOWN for each entry that corresponds to an unknown name.
' %DISP_E_UNKNOWNLCID The locale identifier (LCID) was not recognized.
' ********************************************************************************************
DECLARE FUNCTION Proto_IDispatch_GetIDOfName (BYVAL pthis AS DWORD, BYREF riid AS GUID, BYref rgszNames AS string, BYVAL cNames AS DWORD, BYVAL lcid AS DWORD, BYref rgdispid AS long) AS DWORD
FUNCTION IDispatch_GetIDOfName (BYVAL pthis AS DWORD, BYref strName AS string, BYref rgdispid AS long) AS DWORD
LOCAL HRESULT AS DWORD
LOCAL pmethod AS DWORD
local riid as guid
if pthis = 0 then exit function
pmethod = TB_VTableAddress (pthis, 20)
CALL DWORD pmethod USING Proto_IDispatch_GetIDOfName (pthis, riid, strName, 1, 0, rgdispid) TO HRESULT
FUNCTION = HRESULT
END FUNCTION
' ********************************************************************************************
' ********************************************************************************************
' Provides access to properties and methods exposed by an object. The dispatch function DispInvoke
' provides a standard implementation of IDispatch_Invoke.
' Parameters:
' dispIdMember
' Identifies the member. Use GetIDsOfNames or the object's documentation to obtain the dispatch identifier.
' riid
' Reserved for future use. Must be IID_NULL.
' lcid
' The locale context in which to interpret arguments. The lcid is used by the GetIDsOfNames
' function, and is also passed to IDispatch_Invoke to allow the object to interpret its
' arguments specific to a locale.
' Applications that do not support multiple national languages can ignore this parameter.
' wFlags
' Flags describing the context of the Invoke call, include:
' %DISPATCH_METHOD
' The member is invoked as a method. If a property has the same name, both this and the
' %DISPATCH_PROPERTYGET flag may be set.
' %DISPATCH_PROPERTYGET
' The member is retrieved as a property or data member.
' %DISPATCH_PROPERTYPUT
' The member is changed as a property or data member.
' %DISPATCH_PROPERTYPUTREF
' The member is changed by a reference assignment, rather than a value assignment. This
' flag is valid only when the property accepts a reference to an object.
' pDispParams
' Pointer to a structure containing an array of arguments, an array of argument DISPIDs for
' named arguments, and counts for the number of elements in the arrays.
' pVarResult
' Pointer to the location where the result is to be stored, or NULL if the caller expects no
' result. This argument is ignored if DISPATCH_PROPERTYPUT or DISPATCH_PROPERTYPUTREF is specified.
' pExcepInfo
' Pointer to a structure that contains exception information. This structure should be filled
' in if DISP_E_EXCEPTION is returned. Can be NULL.
' puArgErr
' The index within rgvarg of the first argument that has an error. Arguments are stored in
' pDispParams->rgvarg in reverse order, so the first argument is the one with the highest index
' in the array. This parameter is returned only when the resulting return value is
' %DISP_E_TYPEMISMATCH or %DISP_E_PARAMNOTFOUND. This argument can be set to null.
' Return Value:
' The return value obtained from the returned HRESULT is one of the following:
' %S_OK Success
' %DISP_E_BADPARAMCOUNT The number of elements provided to DISPPARAMS is different from the
' number of arguments accepted by the method or property.
' %DISP_E_BADVARTYPE One of the arguments in rgvarg is not a valid variant type.
' %DISP_E_EXCEPTION The application needs to raise an exception. In this case, the
' structure passed in pExcepInfo should be filled in.
' %DISP_E_MEMBERNOTFOUND The requested member does not exist, or the call to Invoke tried to
' set the value of a read-only property.
' %DISP_E_NONAMEDARGS This implementation of IDispatch does not support named arguments.
' %DISP_E_OVERFLOW One of the arguments in rgvarg could not be coerced to the specified type.
' %DISP_E_PARAMNOTFOUND One of the parameter DISPIDs does not correspond to a parameter on
' the method. In this case, puArgErr should be set to the first
' argument that contains the error.
' %DISP_E_TYPEMISMATCH One or more of the arguments could not be coerced. The index within
' rgvarg of the first parameter with the incorrect type is returned
' in the puArgErr parameter.
' %DISP_E_UNKNOWNINTERFACE The interface identifier passed in riid is not IID_NULL.
' %DISP_E_UNKNOWNLCID The member being invoked interprets string arguments according to
' the LCID, and the LCID is not recognized. If the LCID is not needed
' to interpret arguments, this error should not be returned.
' %DISP_E_PARAMNOTOPTIONAL A required parameter was omitted.
' ********************************************************************************************
FUNCTION IDispatch_Invoke (BYVAL pthis AS DWORD, BYVAL dispidMember AS LONG, BYREF riid AS GUID, _
BYVAL lcid AS DWORD, BYVAL wFlags AS WORD, BYREF pdispparams AS DISPPARAMS, BYREF pvarResult AS VARIANT, _
BYREF pexcepinfo AS EXCEPINFO, BYREF puArgErr AS DWORD) AS DWORD
LOCAL HRESULT AS DWORD
LOCAL pmethod AS DWORD
if pthis = 0 then exit function
pmethod = TB_VTableAddress (pthis, 24)
CALL DWORD pmethod USING IDispatch_Invoke (pthis, dispidMember, riid, lcid, wFlags, pdispparams, pvarResult, pexcepinfo, puArgErr) TO HRESULT
FUNCTION = HRESULT
END FUNCTION
' ********************************************************************************************
' ********************************************************************************************
' CallByName
' ********************************************************************************************
function TB_CallByName ( _
BYVAL pthis AS DWORD, _ ' *IDispatch
BYVAL vNameOrId AS VARIANT, _ ' Name or identifier
byval callType as long, _ ' Call type
byref vParams() as VARIANT, _ ' Array of variants
byref vResult as variant, _ ' Variant result
byref pex as EXCEPINFO _ ' EXCEPINFO
) EXPORT AS LONG ' Error code
dim dw_puArgErr AS DWORD, DISPID_PROPERTYPUT AS LONG, IID_NULL AS GUID
dim vArgs(0) AS VARIANT, udt_DispParams AS DISPPARAMS
dim strName as string, DispID as long, nParams as long, i as long, idx as long
' Check for null pointer
if pthis = 0 then function = -1 : exit function
' Get the DispID
if variantvt(vNameOrId) = %VT_BSTR then
strName = ucode$(variant$(vNameOrId))
IDispatch_GetIDOfName pthis, strName, DispID
else
DispID = variant#(vNameOrId)
end if
' Copy the array in reversed order
if varptr(vParams()) then
nParams = ubound(vParams) - lbound (vParams) + 1
if nParams > 0 then
redim vArgs(nParams - 1)
idx = nParams - 1
for i = Lbound(vParams) to Ubound(vParams)
if variantvt(vParams(i)) = %VT_EMPTY then
vArgs(idx) = error %DISP_E_PARAMNOTFOUND
else
vArgs(idx) = vParams(i)
end if
DECR idx
if idx < 0 then exit for
next
end if
end if
if CallType = 4 or CallType = 8 then ' %DISPATCH_PROPERTYPUT and %DISPATCH_PROPERTYPUTREF
DISPID_PROPERTYPUT = -3
udt_DispParams.CountNamed = 1
udt_DispParams.NamedDispId = VARPTR(DISPID_PROPERTYPUT)
end if
udt_DispParams.CountArgs = nParams
if nParams > 0 then udt_DispParams.VariantArgs = varptr(vArgs(0))
function = IDispatch_Invoke(pthis, DispID, IID_NULL, 0, CallType, udt_DispParams, vResult, pex, dw_puArgErr)
END function
' ********************************************************************************************
Example Use
#COMPILE EXE
#DIM ALL
#DEBUG ERROR ON
#INCLUDE "WIN32API.INC"
#INCLUDE "CallByName.INC"
%adOpenKeyset = &H00000001
%adLockOptimistic = &H00000003
%adCmdText = &H00000001
' ********************************************************************************************
' Main
' ********************************************************************************************
function pbmain
local oCon as dispatch
local oRec as dispatch
local hr as dword
local pex as EXCEPINFO
local vResult as VARIANT
local bstrlen as long
dim vParams(0) as variant
' Creates a connection instance
set oCon = new dispatch in "ADODB.Connection"
if isfalse isobject(oCon) then goto Terminate
redim vParams(3) ' Four parameters (0:3) - Empty variants are considered as optional parameters
vParams(0) = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=f:\ffado\biblio.mdb" ' <-- change as needed
hr = TB_CallByName(objptr(oCon), "Open", %DISPATCH_METHOD, vParams(), BYVAL %NULL, BYVAL %NULL)
' Creates a recordset instance
set oRec = new dispatch in "ADODB.Recordset"
if isfalse isobject(oRec) then goto Terminate
' Opens the recordset
redim vParams(4) ' Five parameters (0:4)
vParams(0) = "SELECT TOP 20 * FROM Authors ORDER BY Author"
set vParams(1) = oCon ' This is a dispatch variable, so we have to assign it using SET
vParams(2) = %adOpenKeyset
vParams(3) = %adLockOptimistic
vParams(4) = %adCmdText
hr = TB_CallByName(objptr(oRec), "Open", %DISPATCH_METHOD, vParams(), BYVAL %NULL, BYVAL %NULL)
do
hr = TB_CallByName(objptr(oRec), "Eof", %DISPATCH_PROPERTYGET, byval %NULL, vResult, BYVAL %NULL)
if variant#(vResult) then exit do
redim vParams(0) ' One parameter
vParams(0) = "Author"
hr = TB_CallByName(objptr(oRec), "Collect", %DISPATCH_PROPERTYGET, vParams(), vResult, BYVAL %NULL)
print variant$(vResult)
' Fetch the next row
hr = TB_CallByName(objptr(oRec), "MoveNext", %DISPATCH_METHOD, byval %NULL, BYVAL %NULL, BYVAL %NULL)
loop
Terminate:
' Close the reordset
hr = TB_CallByName(objptr(oRec), "Close", %DISPATCH_METHOD, BYVAL %NULL, BYVAL %NULL, BYVAL %NULL)
' Close the connection
hr = TB_CallByName(objptr(oCon), "Close", %DISPATCH_METHOD, BYVAL %NULL, BYVAL %NULL, BYVAL %NULL)
' Cleanup
set oRec = nothing
set oCon = nothing
waitkey$
end function
' ********************************************************************************************
