|
|
|
IDispatch Interface |
|
IID_IDispatch |
{00020400-0000-0000-C000-000000000046} |
|
The IDispatch interface exposes objects, methods and properties to programming tools and other applications that support Automation. COM components implement the IDispatch interface to enable access by Automation clients.
|
|
Methods in VTable order |
|
|
IUnknown Methods |
Description |
|
QueryInterface |
Returns pointers to supported interfaces. |
|
AddRef |
Increments reference count. |
|
Release |
Decrements reference count. |
|
IDispatch Methods |
Description |
|
GetTypeInfoCount |
Retrieves the number of type information interfaces that an object provides (either 0 or 1). |
|
GetTypeInfo |
Gets the type information for an object. |
|
GetIDsOfNames |
Maps a single member and an optional set of argument names to a corresponding set of integer DISPIDs. |
|
Invoke |
Provides access to properties and methods exposed by an object. |
|
GetTypeInfoCount |
|
FUNCTION IDispatch_GetTypeInfoCount ( _ BYVAL pthis AS DWORD PTR _ , BYREF pctinfo AS DWORD _
) AS LONG
LOCAL HRESULT AS
LONG
|
|
FUNCTION IDispatch_GetTypeInfoCount ( _ BYVAL pthis AS DWORD PTR _ , BYREF pctinfo AS DWORD _
) AS LONG
! push
pctinfo
|
|
GetTypeInfo |
|
FUNCTION IDispatch_GetTypeInfo ( _ BYVAL pthis AS DWORD PTR _ , BYVAL itinfo AS DWORD _ , BYVAL lcid AS DWORD _ , BYREF pptinfo AS DWORD _
) AS LONG
LOCAL HRESULT AS
LONG
|
|
FUNCTION IDispatch_GetTypeInfo ( _ BYVAL pthis AS DWORD PTR _ , BYVAL itinfo AS DWORD _ , BYVAL lcid AS DWORD _ , BYREF pptinfo AS DWORD _
) AS LONG
! push
pptinfo
! push itinfo
|
|
GetIDsOfNames |
|
FUNCTION IDispatch_GetIDsOfNames ( _ BYVAL pthis AS DWORD PTR _ , BYREF riid AS GUID _ , BYREF rgszNames AS STRING _ , BYVAL cNames AS DWORD _ , BYVAL lcid AS DWORD _ , BYREF rgdispid AS LONG _
) AS
LONG
LOCAL HRESULT AS
LONG
|
|
FUNCTION IDispatch_GetIDsOfNames ( _ BYVAL pthis AS DWORD PTR _ , BYREF riid AS GUID _ , BYVAL rgszNames AS DWORD _ , BYVAL cNames AS DWORD _ , BYVAL lcid AS DWORD _ , BYVAL rgdispid AS DWORD _
) AS
LONG
! push rgdispid
! push rgszNames
|
|
GetIDOfName |
|
Wrapper function to retrieve the DispID of a single method or property.
DECLARE FUNCTION Proto_IDispatch_GetIDOfName ( _ BYVAL pthis AS DWORD PTR _ , BYREF riid AS GUID _ , BYREF strName AS STRING _ , BYVAL cNames AS DWORD _ , BYVAL lcid AS DWORD _ , BYREF dispid AS LONG _ ) AS LONG
FUNCTION IDispatch_GetIDOfName ( _ BYVAL pthis AS DWORD PTR _ , BYREF strName AS STRING _ , BYREF dispid AS LONG _ ) AS LONG
CALL DWORD @@pthis[5]
USING Proto_IDispatch_GetIDOfName (pthis, riid,
strName, 1, 0, dispid) TO HRESULT END FUNCTION
|
|
FUNCTION IDispatch_GetIDOfName ( _ BYVAL pthis AS DWORD PTR _ , BYREF strName AS STRING _ , BYREF dispid AS LONG _ ) AS LONG
LOCAL riid AS GUID strName = UCODE$(strName) FUNCTION
= IDIspatch_GetIDsOfNames(pthis, riid, STRPTR(strName), 1, 0, dispid) END FUNCTION
|
|
DISPPARAMS Structure |
|
DISPPARAMS is an intrinsic structure (UDT) that has the following internal definition (as defined in the PowerBASIC compilers help file):
TYPE DISPPARAMS
|
|
EXCEPINFO Structure |
|
Describes an exception that occurred during a call to Invoke.
TYPE EXCEPINFO
wReserved AS WORD
|
|
Invoke |
|
FUNCTION IDispatch_Invoke ( _ BYVAL pthis AS DWORD PTR _ , 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
LONG
LOCAL HRESULT AS
LONG
|
|
FUNCTION IDispatch_Invoke ( _ BYVAL pthis AS DWORD PTR _ , 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
LONG
! push puArgErr
! mov eax,
pvarResult
! mov eax,
pdispparams
|
|
How to create a dual dispatch interface |
|
This example shows how to create a Dual Dispatch Interface that can be used using PB Automation (both early and late binding) and doing direct VTable calls with CALL DWORD.
|
|
TB_SaveOpenDlg.BAS |
' ****************************************************************************************
' This example demonstrates the use of the TB_OpenSaveFileName COM class (that wraps the
' API Save and Open file common dialogs). Excepting the instruction to create an instance of
' the class (TB_OpenSaveFileName_CreateInstance instead of [LET] objvar = NEW {DISPATCH | InterfaceName}),
' the use of the class with PB Automation is identical to the one used with any COM component.
' ****************************************************************************************
#COMPILE EXE
#DIM ALL
#INCLUDE "TB_OpenSaveDlg.inc"
%IDC_OPENDIALOG = 100
%IDC_SAVEDIALOG = 101
' *****************************************************************************************
' Shows the open file dialog
' *****************************************************************************************
FUNCTION CommonDialogShowOpenDialog (BYVAL hDlg AS DWORD) AS STRING
LOCAL oOsfn AS DISPATCH ' TB_OpenSaveFileName
LOCAL vVar AS VARIANT
LOCAL vRes AS VARIANT
' ============================================================
' Create an instance of our class
' ============================================================
TB_OpenSaveFileName_CreateInstance(oOsfn)
IF ISFALSE ISOBJECT(oOsfn) THEN
MSGBOX "Unable to create an instance of the class"
EXIT FUNCTION
END IF
' ============================================================
' Set some properties
' ============================================================
vVar = "All Files(*.*)|*.*|BAS Files(*.BAS)|*.BAS"
OBJECT LET oOsfn.Filter = vVar
vVar = "BAS" : OBJECT LET oOsfn.DefaultExt = vVar
vVar = 2 AS LONG : OBJECT LET oOsfn.FilterIndex = vVar
vVar = hDlg AS DWORD : OBJECT LET oOsfn.Parent = vVar
vVar = -1 AS INTEGER : OBJECT LET oOsfn.ReadOnly = vVar
vVar = -1 AS INTEGER : OBJECT LET oOsfn.AllowMultiSelect = vVar
vVar = -1 AS INTEGER : OBJECT LET oOsfn.LongNames = vVar
vVar = -1 AS INTEGER : OBJECT LET oOsfn.ExplorerStyle = vVar
' ============================================================
' Show the dialog
' ============================================================
OBJECT CALL oOsfn.ShowOpen TO vRes
' ============================================================
' Return the selected filename(s)
' ============================================================
OBJECT GET oOsfn.FILENAME TO vRes
FUNCTION = VARIANT$(vRes)
' ============================================================
' Release the class
' ============================================================
oOsfn = NOTHING
END FUNCTION
' *****************************************************************************************
' *****************************************************************************************
' Shows the save file dialog
' *****************************************************************************************
FUNCTION CommonDialogShowSaveDialog (BYVAL hDlg AS DWORD, BYVAL strFileName AS STRING) AS STRING
LOCAL oOsfn AS DISPATCH ' TB_OpenSaveFileName
LOCAL vVar AS VARIANT
LOCAL vRes AS VARIANT
' ============================================================
' Create an instance of our class
' ============================================================
TB_OpenSaveFileName_CreateInstance(oOsfn)
IF ISFALSE ISOBJECT(oOsfn) THEN
MSGBOX "Unable to create an instance of the class"
EXIT FUNCTION
END IF
' ============================================================
' Set some properties
' ============================================================
vVar = "All Files(*.*)|*.*|BAS Files(*.BAS)|*.BAS"
OBJECT LET oOsfn.Filter = vVar
vVar = "BAS" : OBJECT LET oOsfn.DefaultExt = vVar
IF LEN(strFIleName) THEN
vVar = strFIleName : OBJECT LET oOsfn.FILENAME = vVar
END IF
vVar = 2 AS LONG : OBJECT LET oOsfn.FilterIndex = vVar
vVar = hDlg AS DWORD : OBJECT LET oOsfn.Parent = vVar
vVar = -1 AS INTEGER : OBJECT LET oOsfn.LongNames = vVar
vVar = -1 AS INTEGER : OBJECT LET oOsfn.ExplorerStyle = vVar
' ============================================================
' Show the dialog
' ============================================================
OBJECT CALL oOsfn.ShowSave TO vRes
' ============================================================
' Return the filename
' ============================================================
OBJECT GET oOsfn.FILENAME TO vRes
FUNCTION = VARIANT$(vRes)
' ============================================================
' Release the class
' ============================================================
oOsfn = NOTHING
END FUNCTION
' *****************************************************************************************
' *****************************************************************************************
' Main
' *****************************************************************************************
FUNCTION PBMAIN () AS LONG
LOCAL hDlg AS LONG
DIALOG NEW 0, "Common Dialog Test", , , 300, 200, %WS_OVERLAPPED OR %WS_THICKFRAME OR %WS_SYSMENU OR _
%WS_MINIMIZEBOX OR %WS_MAXIMIZEBOX OR %WS_VISIBLE OR %DS_CENTER TO hDlg
' For icon from resource, instead use something like, LoadIcon(hInst, "APPICON")
DIALOG SEND hDlg, %WM_SETICON, %ICON_SMALL, LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
DIALOG SEND hDlg, %WM_SETICON, %ICON_BIG, LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
CONTROL ADD BUTTON, hDlg, %IDC_OPENDIALOG, "Open", 0, 0, 50, 14, %WS_CHILD OR %WS_VISIBLE OR %WS_TABSTOP OR %BS_FLAT
CONTROL ADD BUTTON, hDlg, %IDC_SAVEDIALOG, "Save", 0, 0, 50, 14, %WS_CHILD OR %WS_VISIBLE OR %WS_TABSTOP OR %BS_FLAT
CONTROL ADD BUTTON, hDlg, %IDCANCEL, "Close", 0, 0, 50, 14, %WS_CHILD OR %WS_VISIBLE OR %WS_TABSTOP OR %BS_FLAT
DIALOG SHOW MODAL hDlg, CALL DlgProc
END FUNCTION
' *****************************************************************************************
' *****************************************************************************************
' Main Dialog procedure
' *****************************************************************************************
CALLBACK FUNCTION DlgProc() AS LONG
LOCAL rc AS RECT
LOCAL strFileName AS STRING
SELECT CASE CBMSG
CASE %WM_SIZE
' Resize the two sample buttons of the dialog
IF CBWPARAM <> %SIZE_MINIMIZED THEN
GetClientRect CBHNDL, rc
MoveWindow GetDlgItem(CBHNDL, %IDC_OPENDIALOG), (rc.nRight - rc.nLeft) - 95, (rc.nBottom - rc.nTop) - 235, 75, 23, %TRUE
MoveWindow GetDlgItem(CBHNDL, %IDC_SAVEDIALOG), (rc.nRight - rc.nLeft) - 95, (rc.nBottom - rc.nTop) - 205, 75, 23, %TRUE
MoveWindow GetDlgItem(CBHNDL, %IDCANCEL), (rc.nRight - rc.nLeft) - 95, (rc.nBottom - rc.nTop) - 35, 75, 23, %TRUE
DIALOG REDRAW CBHNDL
END IF
CASE %WM_COMMAND
SELECT CASE CBCTL
CASE %IDC_OPENDIALOG
IF CBCTLMSG = %BN_CLICKED THEN
strFileName = CommonDialogShowOpenDialog(CBHNDL)
IF LEN(strFileName) THEN MSGBOX strFileName
END IF
CASE %IDC_SAVEDIALOG
IF CBCTLMSG = %BN_CLICKED THEN
strFileName = CommonDialogShowSaveDialog(CBHNDL, "Test.bas")
IF LEN(strFileName) THEN MSGBOX strFileName
END IF
CASE %IDCANCEL
IF CBCTLMSG = %BN_CLICKED THEN DIALOG END CBHNDL, 0
END SELECT
END SELECT
END FUNCTION
' *****************************************************************************************
|
' ****************************************************************************************
' Example of a COM class with a dual interface that wraps the API Save and Open file
' common dialogs and can be used with PB Automation. Needs PBWIN 8.x+
' ****************************************************************************************
#INCLUDE "Win32Api.inc"
#INCLUDE "ComDlg32.inc"
%DISPATCH_METHOD = &H1
%DISPATCH_PROPERTYGET = &H2
%DISPATCH_PROPERTYPUT = &H4
%DISPATCH_PROPERTYPUTREF = &H8
%DISPID_PROPERTYPUT = -3
' ****************************************************************************************
' DispGetParam function
' ****************************************************************************************
' Retrieves a parameter from the DISPPARAMS structure, checking both named parameters and
' positional parameters, and coerces the parameter to the specified type.
'
' *** Parameters ***
'
' pdispparams
' Pointer to the parameters passed to IDispatch::Invoke.
' position
' The position of the parameter in the parameter list. DispGetParam starts at the end of the
' array, so if position is 0, the last parameter in the array is returned.
' vtTarg
' The type the argument should be coerced to.
' pvarResult
' Pointer to the variant to pass the parameter into.
' puArgErr
' On return, pointer to the index of the argument that caused a DISP_E_TYPEMISMATCH error.
' This pointer is returned to Invoke to indicate the position of the argument in DISPPARAMS
' that caused the error.
'
' *** Return Value ***
'
' The return value obtained from the HRESULT is one of the following:
'
' Return value Meaning
' ------------ -----------------------------------------------------------------
' %S_OK Success.
' %DISP_E_BADVARTYPE The variant type vtTarg is not supported.
' %DISP_E_OVERFLOW The retrieved parameter could not be coerced to the specified type.
' %DISP_E_PARAMNOTFOUND The parameter indicated by position could not be found.
' %DISP_E_TYPEMISMATCH The argument could not be coerced to the specified type.
' %E_INVALIDARG One of the arguments was invalid.
' %E_OUTOFMEMORY Insufficient memory to complete operation.
'
' *** Comments ***
'
' The output parameter pvarResult must be a valid variant. Any existing contents are released
' in the standard way. The contents of the variant are freed with VariantFree.
' If you have used DispGetParam to get the right side of a property put operation, the second
' parameter should be %DISPID_PROPERTYPUT. For example:
'
' DispGetParam(pdispparams, %DISPID_PROPERTYPUT, %VT_BOOL, pvarResult, puArgErr)
'
' Named parameters cannot be accessed positionally, and vice versa.
' ****************************************************************************************
DECLARE FUNCTION DispGetParam LIB "OLEAUT32.DLL" ALIAS "DispGetParam" ( _
BYREF pdispparams AS DISPPARAMS, _
BYVAL position AS LONG, _
BYVAL vtTarg AS WORD, _
BYREF pvarResult AS VARIANT, _
BYREF puArgErr AS DWORD) AS LONG
' ****************************************************************************************
' ****************************************************************************************
' IDispatch virtual table
' ****************************************************************************************
TYPE TB_OpenSaveFileName_IDispatchVtbl
' === Iunknown methods ================================================================
QueryInterface AS DWORD ' Returns pointers to supported interfaces
AddRef AS DWORD ' Increments reference count
Release AS DWORD ' Decrements reference count
' === IDispatch methods ===============================================================
GetTypeInfoCount AS DWORD ' Retrieves the number of type descriptions
GetTypeInfo AS DWORD ' Retrieves a description of object's programmable interface
GetIDsOfNames AS DWORD ' Maps name of method or property to DispId
Invoke AS DWORD ' Calls one of the object's methods, or gets/sets one of its properties
' == Custom methods and properties ====================================================
GetDialogTitle AS DWORD ' GetDialogTitle property
SetDialogTitle AS DWORD ' SetDialogTitle property
GetFilter AS DWORD ' GetFilter property
SetFilter AS DWORD ' SetFilter property
GetDefaultExt AS DWORD ' GetDefaultExt property
SetDefaultExt AS DWORD ' SetDefaultExt property
GetInitDir AS DWORD ' GetinitDir property
SetInitDir AS DWORD ' SetInitDir property
GetFileName AS DWORD ' GetFileName property
SetFileName AS DWORD ' SetFileName property
GetFIleMustExist AS DWORD ' GetFileMustExist property
SetFileMustExist AS DWORD ' SetFileMustExist property
GetReadOnly AS DWORD ' GetReadOnly property
SetReadOnly AS DWORD ' SetReadOnly property
GetHideReadOnly AS DWORD ' GetHideReadOnly property
SetHideReadOnly AS DWORD ' SetHideReadOnly property
GetFiltertIndex AS DWORD ' GetFilterIndex property
SetFiltertIndex AS DWORD ' SetFilterIndex property
GetParent AS DWORD ' GetParent property
SetParent AS DWORD ' SetParent property
GetFlags AS DWORD ' GetFlags property
SetFlags AS DWORD ' SetFlags property
GetAllowMultiSelect AS DWORD ' GetFlags property
SetAllowMultiSelect AS DWORD ' SetFlags property
GetLongNames AS DWORD ' GetLongNames property
SetLongNames AS DWORD ' SetLongNames property
GetExplorerStyle AS DWORD ' GetExplorerStyle property
SetExplorerStyle AS DWORD ' SetExplorerStyle property
ShowOpen AS DWORD ' ShowOpen method
ShowSave AS DWORD ' ShowSave method
' === Private data ====================================================================
pVtblAddr AS DWORD ' Address of the virtual table
cRef AS DWORD ' Reference count
' === Custom data (add members here if needed) ========================================
szDialogTitle AS ASCIIZ * %MAX_PATH ' Dialog title
szFilter AS ASCIIZ * %MAX_PATH ' Filter
szDefaultExt AS ASCIIZ * 256 ' Default extension
szInitDir AS ASCIIZ * %MAX_PATH ' Initial directory
szFileName AS ASCIIZ * %OFN_FILEBUFFERSIZE ' FileName
fFileMustExist AS INTEGER ' File must exist flag
fReadOnly AS INTEGER ' Read only flag
fHideReadOnly AS INTEGER ' Hide read only flag
fAllowMultiSelect AS INTEGER ' Allow multiple selection flag
fLongNames AS INTEGER ' Show long names flag
fExplorerStyle AS INTEGER ' Explorer style flag
FilterIndex AS LONG ' Filter index
hParent AS DWORD ' Parent window
dwFlags AS LONG ' Other flags
END TYPE
' ****************************************************************************************
' ****************************************************************************************
' UI4 AddRef()
' Increments the reference count.
' ****************************************************************************************
FUNCTION TB_OpenSaveFileName_AddRef (BYVAL pthis AS TB_OpenSaveFileName_IDispatchVtbl PTR) AS DWORD
INCR @@pthis.cRef
FUNCTION = @@pthis.cRef
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' HRESULT QueryInterface([in] *GUID riid, [out] **VOID ppvObj)
' Returns the IUnknown of our class and increments the reference counter.
' ****************************************************************************************
FUNCTION TB_OpenSaveFileName_QueryInterface (BYVAL pthis AS TB_OpenSaveFileName_IDispatchVtbl PTR, BYREF riid AS GUID, BYREF ppvObj AS DWORD) AS LONG
' We have only one interface for now
ppvObj = pthis
TB_OpenSaveFileName_AddRef pthis
FUNCTION = %S_OK
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' UI4 Release()
' Decrements the reference count and releases the class when it reaches 0.
' ****************************************************************************************
FUNCTION TB_OpenSaveFileName_Release (BYVAL pthis AS TB_OpenSaveFileName_IDispatchVtbl PTR) AS DWORD
LOCAL pVtblAddr AS DWORD
IF @@pthis.cRef = 1 THEN
pVtblAddr = @@pthis.pVtblAddr
IF ISTRUE HeapFree(GetProcessHeap(), 0, BYVAL pVtblAddr) THEN
FUNCTION = 0
EXIT FUNCTION
ELSE
FUNCTION = @@pthis.cRef
EXIT FUNCTION
END IF
END IF
DECR @@pthis.cRef
FUNCTION = @@pthis.cRef
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' HRESULT GetTypeInfoCount([out] *UINT pctinfo)
' Retrieves the number of type information interfaces that an object provides (either 0 or 1).
' ****************************************************************************************
FUNCTION TB_OpenSaveFileName_GetTypeInfoCount (BYVAL pthis AS TB_OpenSaveFileName_IDispatchVtbl PTR, BYREF pctInfo AS DWORD) AS LONG
pctInfo = 0
FUNCTION = %S_OK
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' HRESULT GetTypeInfo([in] UINT itinfo, [in] UI4 lcid, [out] **VOID pptinfo)
' Retrieves the type information for an object, which can then be used to get the type
' information for an interface.
' ****************************************************************************************
FUNCTION TB_OpenSaveFileName_GetTypeInfo (BYVAL pthis AS TB_OpenSaveFileName_IDispatchVtbl PTR, BYVAL itinfo AS DWORD, BYVAL lcid AS DWORD, BYREF pptinfo AS DWORD) AS LONG
FUNCTION = %E_NOTIMPL
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' HRESULT GetIDsOfNames([in] *GUID riid, [in] **I1 rgszNames, [in] UINT cNames, [in] UI4 lcid, [out] *I4 rgdispid)
' Maps a single member and an optional set of argument names to a corresponding set of integer
' DISPIDs, which can be used on subsequent calls to IDispatch::Invoke.
' Note: This function is called when using late binding.
' ****************************************************************************************
FUNCTION TB_OpenSaveFileName_GetIDsOfNames (BYVAL pthis AS TB_OpenSaveFileName_IDispatchVtbl PTR, BYREF riid AS GUID, BYVAL rgszNames AS DWORD, BYVAL cNames AS DWORD, BYVAL lcid AS DWORD, BYREF rgdispid AS LONG) AS LONG
LOCAL strName AS STRING
LOCAL pNames AS STRING PTR
IF rgszNames <> 0 THEN
pNames = rgszNames
strName = ACODE$(@pNames[0])
END IF
Outputdebugstring STR$(cNames) & " - " & strName
SELECT CASE strName
CASE "DIALOGTITLE"
rgdispid = &H00000001
CASE "FILTER"
rgdispid = &H00000002
CASE "DEFAULTEXT"
rgdispid = &H00000003
CASE "INITDIR"
rgdispid = &H00000004
CASE "FILENAME"
rgdispid = &H00000005
CASE "FILEMUSTEXIST"
rgdispid = &H00000006
CASE "READONLY"
rgdispid = &H00000007
CASE "HIDEREADONLY"
rgdispid = &H00000008
CASE "FILTERINDEX"
rgdispid = &H00000009
CASE "PARENT"
rgdispid = &H0000000A
CASE "FLAGS"
rgdispid = &H0000000B
CASE "ALLOWMULTISELECT"
rgdispid = &H0000000C
CASE "LONGNAMES"
rgdispid = &H0000000D
CASE "EXPLORERSTYLE"
rgdispid = &H0000000E
CASE "SHOWOPEN"
rgdispid = &H0000000F
CASE "SHOWSAVE"
rgdispid = &H00000010
CASE ELSE
FUNCTION = %DISP_E_UNKNOWNNAME
EXIT FUNCTION
END SELECT
FUNCTION = %S_OK
END FUNCTION
' ****************************************************************************************
' *****************************************************************************************
' Puts the address of an object in a variant and marks it as containing a dispatch variable
' Useful when we have a pointer to an interface stored in a DWORD variable and we need to
' pass it to a function that expects a variant. We can't simply pass the pointer by value,
' because the variant must we of the type %VT_DISPATCH.
' *****************************************************************************************
SUB TB_OpenSaveFileName_MakeDispatchVariant (BYVAL lpObj AS DWORD, BYREF vObj AS VARIANT)
LOCAL lpvObj AS VARIANTAPI PTR ' Pointer to a VARIANTAPI structure
LET vObj = EMPTY ' Make sure is empty to avoid memory leaks
lpvObj = VARPTR(vObj) ' Get the VARIANT address
@lpvObj.vt = %VT_DISPATCH ' Mark it as containing a dispatch variable
@lpvObj.vd.pdispVal = lpObj ' Set the dispatch pointer address
TB_OpenSaveFileName_AddRef lpObj
END SUB
' *****************************************************************************************
' ****************************************************************************************
' Builds the IDispatch Virtual Table and returns the address of a pointer to it.
' ****************************************************************************************
FUNCTION TB_OpenSaveFileName_CreateInstance (BYREF oDispatch AS DISPATCH) AS LONG
LOCAL pVtbl AS TB_OpenSaveFileName_IDispatchVtbl PTR
LOCAL pUnk AS TB_OpenSaveFileName_IDispatchVtbl PTR
LOCAL vDispatch AS VARIANT
pVtbl = HeapAlloc(GetProcessHeap(), %HEAP_ZERO_MEMORY, SIZEOF(@pVtbl))
IF pVtbl = 0 THEN EXIT FUNCTION
@pVtbl.QueryInterface = CODEPTR(TB_OpenSaveFileName_QueryInterface)
@pVtbl.AddRef = CODEPTR(TB_OpenSaveFileName_AddRef)
@pVtbl.Release = CODEPTR(TB_OpenSaveFileName_Release)
@pVtbl.GetTypeInfoCount = CODEPTR(TB_OpenSaveFileName_GetTypeInfoCount)
@pVtbl.GetTypeInfo = CODEPTR(TB_OpenSaveFileName_GetTypeInfo)
@pVtbl.GetIDsOfNames = CODEPTR(TB_OpenSaveFileName_GetIDsOfNames)
@pVtbl.Invoke = CODEPTR(TB_OpenSaveFileName_Invoke)
@pVtbl.GetDialogTitle = CODEPTR(TB_OpenSaveFileName_GetDialogTitle)
@pVtbl.SetDialogTitle = CODEPTR(TB_OpenSaveFileName_SetDialogTitle)
@pVtbl.GetFilter = CODEPTR(TB_OpenSaveFileName_GetFilter)
@pVtbl.SetFilter = CODEPTR(TB_OpenSaveFileName_SetFilter)
@pVtbl.GetDefaultExt = CODEPTR(TB_OpenSaveFileName_GetDefaultExt)
@pVtbl.SetDefaultExt = CODEPTR(TB_OpenSaveFileName_SetDefaultExt)
@pVtbl.GetInitDir = CODEPTR(TB_OpenSaveFileName_GetInitDir)
@pVtbl.SetInitDir = CODEPTR(TB_OpenSaveFileName_SetInitDir)
@pVtbl.GetFileName = CODEPTR(TB_OpenSaveFileName_GetFileName)
@pVtbl.SetFileName = CODEPTR(TB_OpenSaveFileName_SetFileName)
@pVtbl.GetFileMustExist = CODEPTR(TB_OpenSaveFileName_GetFileMustExist)
@pVtbl.SetFileMustExist = CODEPTR(TB_OpenSaveFileName_SetFileMustExist)
@pVtbl.GetReadOnly = CODEPTR(TB_OpenSaveFileName_GetReadOnly)
@pVtbl.SetReadOnly = CODEPTR(TB_OpenSaveFileName_SetReadOnly)
@pVtbl.GetHideReadOnly = CODEPTR(TB_OpenSaveFileName_GetHideReadOnly)
@pVtbl.SetHideReadOnly = CODEPTR(TB_OpenSaveFileName_SetHideReadOnly)
@pVtbl.GetFiltertIndex = CODEPTR(TB_OpenSaveFileName_GetFilterIndex)
@pVtbl.SetFiltertIndex = CODEPTR(TB_OpenSaveFileName_SetFilterIndex)
@pVtbl.GetParent = CODEPTR(TB_OpenSaveFileName_GetParent)
@pVtbl.SetParent = CODEPTR(TB_OpenSaveFileName_SetParent)
@pVtbl.GetFlags = CODEPTR(TB_OpenSaveFileName_GetFlags)
@pVtbl.SetFlags = CODEPTR(TB_OpenSaveFileName_SetFlags)
@pVtbl.GetAllowMultiSelect = CODEPTR(TB_OpenSaveFileName_GetFlags)
@pVtbl.SetAllowMultiSelect = CODEPTR(TB_OpenSaveFileName_SetFlags)
@pVtbl.GetLongNames = CODEPTR(TB_OpenSaveFileName_GetLongNames)
@pVtbl.SetLongNames = CODEPTR(TB_OpenSaveFileName_SetLongNames)
@pVtbl.GetExplorerStyle = CODEPTR(TB_OpenSaveFileName_GetExplorerStyle)
@pVtbl.SetExplorerStyle = CODEPTR(TB_OpenSaveFileName_SetExplorerStyle)
@pVtbl.ShowOpen = CODEPTR(TB_OpenSaveFileName_ShowOpen)
@pVtbl.ShowSave = CODEPTR(TB_OpenSaveFileName_ShowSave)
@pVtbl.pVtblAddr = pVtbl
pUnk = VARPTR(@pVtbl.pVtblAddr)
TB_OpenSaveFileName_MakeDispatchVariant pUnk, vDispatch
oDispatch = vDispatch
vDispatch = EMPTY
FUNCTION = %TRUE
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' GetDialogTitle property
' Returns the string displayed in the title bar of the dialog box.
' ****************************************************************************************
FUNCTION TB_OpenSaveFileName_GetDialogTitle (BYVAL pthis AS TB_OpenSaveFileName_IDispatchVtbl PTR, BYREF strTitle AS STRING) AS LONG
strTitle = @@pthis.szDialogTitle
FUNCTION = %S_OK
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' SetDialogTitle property
' Returns the string displayed in the title bar of the dialog box.
' ****************************************************************************************
FUNCTION TB_OpenSaveFileName_SetDialogTitle (BYVAL pthis AS TB_OpenSaveFileName_IDispatchVtbl PTR, BYVAL strTitle AS STRING) AS LONG
@@pthis.szDialogTitle = strTitle
FUNCTION = %S_OK
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' GetFilter property
' Returns the filters that are displayed in the Type list box of a dialog box.
' ****************************************************************************************
FUNCTION TB_OpenSaveFileName_GetFilter (BYVAL pthis AS TB_OpenSaveFileName_IDispatchVtbl PTR, BYREF strFilter AS STRING) AS LONG
strFilter = @@pthis.szFilter
FUNCTION = %S_OK
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' SetFilter property
' Sets the filters that are displayed in the Type list box of a dialog box.
' ****************************************************************************************
FUNCTION TB_OpenSaveFileName_SetFilter (BYVAL pthis AS TB_OpenSaveFileName_IDispatchVtbl PTR, BYVAL strFilter AS STRING) AS LONG
@@pthis.szFilter = strFilter
FUNCTION = %S_OK
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' GetDefaultExt property
' Returns the default filename extension for the dialog box.
' ****************************************************************************************
FUNCTION TB_OpenSaveFileName_GetDefaultExt (BYVAL pthis AS TB_OpenSaveFileName_IDispatchVtbl PTR, BYREF strExt AS STRING) AS LONG
strExt = @@pthis.szDefaultExt
FUNCTION = %S_OK
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' SetDefaultExt property
' Sets the default filename extension for the dialog box.
' ****************************************************************************************
FUNCTION TB_OpenSaveFileName_SetDefaultExt (BYVAL pthis AS TB_OpenSaveFileName_IDispatchVtbl PTR, BYVAL strExt AS STRING) AS LONG
@@pthis.szDefaultExt = strExt
FUNCTION = %S_OK
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' GetInitDir property
' Returns the initial file directory.
' ****************************************************************************************
FUNCTION TB_OpenSaveFileName_GetinitDir (BYVAL pthis AS TB_OpenSaveFileName_IDispatchVtbl PTR, strDir AS STRING) AS LONG
strDir = @@pthis.szInitDir
FUNCTION = %S_OK
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' SetInitDir property
' Sets the initial file directory.
' ****************************************************************************************
FUNCTION TB_OpenSaveFileName_SetInitDir (BYVAL pthis AS TB_OpenSaveFileName_IDispatchVtbl PTR, BYVAL strDir AS STRING) AS LONG
@@pthis.szInitDir = strDir
FUNCTION = %S_OK
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' GetFileName property
' Returns the path and filename of a selected file.
' ****************************************************************************************
FUNCTION TB_OpenSaveFileName_GetFileName (BYVAL pthis AS TB_OpenSaveFileName_IDispatchVtbl PTR, BYREF strFileName AS STRING) AS LONG
strFileName = @@pthis.szFileName
FUNCTION = %S_OK
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' SetFileName property
' Sets the path and filename of a selected file.
' ****************************************************************************************
FUNCTION TB_OpenSaveFileName_SetFileName (BYVAL pthis AS TB_OpenSaveFileName_IDispatchVtbl PTR, BYVAL strFileName AS STRING) AS LONG
@@pthis.szFileName = strFileName
FUNCTION = %S_OK
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' GetFileMustExist property
' Returns the file must exist flag.
' ****************************************************************************************
FUNCTION TB_OpenSaveFileName_GetFileMustExist (BYVAL pthis AS TB_OpenSaveFileName_IDispatchVtbl PTR, BYREF fFileMustExist AS INTEGER) AS LONG
fFileMustExist = @@pthis.fFileMustExist
FUNCTION = %S_OK
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' SetFileMustExist property
' Sets the file must exist flag.
' ****************************************************************************************
FUNCTION TB_OpenSaveFileName_SetFileMustExist (BYVAL pthis AS TB_OpenSaveFileName_IDispatchVtbl PTR, BYVAL fFileMustExist AS INTEGER) AS LONG
@@pthis.fFileMustExist = fFileMustExist
FUNCTION = %S_OK
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' GetReadOnly property
' Returns the read only flag.
' ****************************************************************************************
FUNCTION TB_OpenSaveFileName_GetReadOnly (BYVAL pthis AS TB_OpenSaveFileName_IDispatchVtbl PTR, BYREF fReadOnly AS INTEGER) AS LONG
fReadOnly = @@pthis.fReadOnly
FUNCTION = %S_OK
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' SetReadOnly property
' Sets the read only flag.
' ****************************************************************************************
FUNCTION TB_OpenSaveFileName_SetReadOnly (BYVAL pthis AS TB_OpenSaveFileName_IDispatchVtbl PTR, BYVAL fReadOnly AS INTEGER) AS LONG
@@pthis.fReadOnly = fReadOnly
FUNCTION = %S_OK
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' GetHideReadOnly property
' Returns the hide read only flag.
' ****************************************************************************************
FUNCTION TB_OpenSaveFileName_GetHideReadOnly (BYVAL pthis AS TB_OpenSaveFileName_IDispatchVtbl PTR, BYREF fHideReadOnly AS INTEGER) AS LONG
fHideReadOnly = @@pthis.fHideReadOnly
FUNCTION = %S_OK
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' SetHieReadOnly property
' Sets the hide read only flag.
' ****************************************************************************************
FUNCTION TB_OpenSaveFileName_SetHideReadOnly (BYVAL pthis AS TB_OpenSaveFileName_IDispatchVtbl PTR, BYVAL fHideReadOnly AS INTEGER) AS LONG
@@pthis.fHideReadOnly = fHideReadOnly
FUNCTION = %S_OK
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' GetAllowMultiSelect property
' Returns the allow multiple selection flag.
' ****************************************************************************************
FUNCTION TB_OpenSaveFileName_GetAllowMultiSelect (BYVAL pthis AS TB_OpenSaveFileName_IDispatchVtbl PTR, BYREF fAllowMultiSelect AS INTEGER) AS LONG
fAllowMultiSelect = @@pthis.fAllowMultiSelect
FUNCTION = %S_OK
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' SetAllowMultiSelect property
' Sets the allow multiple selection flag.
' ****************************************************************************************
FUNCTION TB_OpenSaveFileName_SetAllowMultiSelect (BYVAL pthis AS TB_OpenSaveFileName_IDispatchVtbl PTR, BYVAL fAllowMultiSelect AS INTEGER) AS LONG
@@pthis.fAllowMultiSelect = fAllowMultiSelect
FUNCTION = %S_OK
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' GetLongNames property
' Returns the long names selection flag.
' ****************************************************************************************
FUNCTION TB_OpenSaveFileName_GetLongNames (BYVAL pthis AS TB_OpenSaveFileName_IDispatchVtbl PTR, BYREF fLongNames AS INTEGER) AS LONG
fLongNames = @@pthis.fLongNames
FUNCTION = %S_OK
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' SetLongNames property
' Sets the long names flag.
' ****************************************************************************************
FUNCTION TB_OpenSaveFileName_SetLongNames (BYVAL pthis AS TB_OpenSaveFileName_IDispatchVtbl PTR, BYVAL fLongNames AS INTEGER) AS LONG
@@pthis.fLongNames = fLongNames
FUNCTION = %S_OK
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' GetExplorerStyle property
' Returns the explorer style flag.
' ****************************************************************************************
FUNCTION TB_OpenSaveFileName_GetExplorerStyle (BYVAL pthis AS TB_OpenSaveFileName_IDispatchVtbl PTR, BYREF fExplorerStyle AS INTEGER) AS LONG
fExplorerStyle = @@pthis.fExplorerStyle
FUNCTION = %S_OK
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' GetExplorerStyle property
' Sets the explorer style flag.
' ****************************************************************************************
FUNCTION TB_OpenSaveFileName_SetExplorerStyle (BYVAL pthis AS TB_OpenSaveFileName_IDispatchVtbl PTR, BYVAL fExplorerStyle AS INTEGER) AS LONG
@@pthis.fExplorerStyle = fExplorerStyle
FUNCTION = %S_OK
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' GetFilterIndex property
' Returns the hide read only flag.
' ****************************************************************************************
FUNCTION TB_OpenSaveFileName_GetFilterIndex (BYVAL pthis AS TB_OpenSaveFileName_IDispatchVtbl PTR, BYREF FilterIndex AS LONG) AS LONG
FilterIndex = @@pthis.FilterIndex
FUNCTION = %S_OK
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' SetFilterIndex property
' Sets the hide read only flag.
' ****************************************************************************************
FUNCTION TB_OpenSaveFileName_SetFilterIndex (BYVAL pthis AS TB_OpenSaveFileName_IDispatchVtbl PTR, BYVAL FilterIndex AS LONG) AS LONG
IF FilterIndex < 1 THEN FilterIndex = 1
@@pthis.FilterIndex = FilterIndex
FUNCTION = %S_OK
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' GetParent property
' Returns the handle of the parent window.
' ****************************************************************************************
FUNCTION TB_OpenSaveFileName_GetParent (BYVAL pthis AS TB_OpenSaveFileName_IDispatchVtbl PTR, BYREF hParent AS DWORD) AS LONG
hParent = @@pthis.hParent
FUNCTION = %S_OK
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' SetParent property
' Sets the handle of the parent window.
' ****************************************************************************************
FUNCTION TB_OpenSaveFileName_SetParent (BYVAL pthis AS TB_OpenSaveFileName_IDispatchVtbl PTR, BYVAL hParent AS DWORD) AS LONG
@@pthis.hParent = hParent
FUNCTION = %S_OK
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' GetFlags property
' Returns the flags.
' ****************************************************************************************
FUNCTION TB_OpenSaveFileName_GetFlags (BYVAL pthis AS TB_OpenSaveFileName_IDispatchVtbl PTR, BYREF dwFlags AS DWORD) AS LONG
dwFlags = @@pthis.dwFlags
FUNCTION = %S_OK
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' SetFlags property
' Sets the flags.
' ****************************************************************************************
FUNCTION TB_OpenSaveFileName_SetFlags (BYVAL pthis AS TB_OpenSaveFileName_IDispatchVtbl PTR, BYVAL dwFlags AS DWORD) AS LONG
@@pthis.dwFLags = dwFlags
FUNCTION = %S_OK
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' ShowOpen method
' Shows the OpenFile dialog.
' ****************************************************************************************
FUNCTION TB_OpenSaveFileName_ShowOpen (BYVAL pthis AS TB_OpenSaveFileName_IDispatchVtbl PTR) AS LONG
LOCAL ix AS LONG
LOCAL ofn AS OPENFILENAME
LOCAL szFileTitle AS ASCIIZ * %MAX_PATH
LOCAL hr AS LONG
LOCAL sFilter AS STRING
LOCAL sInitialDir AS STRING
LOCAL sFileSpec AS STRING
LOCAL sCaption AS STRING
LOCAL sDefExtension AS STRING
LOCAL dwFLags AS DWORD
LOCAL hParent AS DWORD
LOCAL FilterIndex AS LONG
LOCAL fFileMustExist AS INTEGER
LOCAL fReadOnly AS INTEGER
LOCAL fHideReadOnly AS INTEGER
LOCAL fAllowMultiSelect AS INTEGER
LOCAL fLongNames AS INTEGER
LOCAL fExplorerStyle AS INTEGER
' Filter is a sequence of ASCIIZ strings with a final (extra) $NUL terminator
hr = TB_OpenSaveFileName_GetFilter(pthis, sFilter)
REPLACE "|" WITH $NUL IN sFilter
sFilter = sFilter + $NUL
hr = TB_OpenSaveFileName_GetinitDir(pthis, sInitialDir)
IF LEN(sInitialDir) = 0 THEN sInitialDir = CURDIR$
hr = TB_OpenSaveFileName_GetFileName(pthis, sFileSpec)
ix = INSTR(sFileSpec, $NUL)
IF ix THEN
sFileSpec = LEFT$(sFileSpec, ix) + SPACE$(%OFN_FILEBUFFERSIZE - ix)
ELSE
sFileSpec = sFileSpec + $NUL + SPACE$(%OFN_FILEBUFFERSIZE - (LEN(sFileSpec) + 1))
END IF
hr = TB_OpenSaveFileName_GetDialogTitle(pthis, sCaption)
hr = TB_OpenSaveFileName_GetDefaultExt(pthis, sDefExtension)
ofn.lStructSize = SIZEOF(ofn)
hr = TB_OpenSaveFileName_GetParent(pthis, hParent)
ofn.hWndOwner = hParent
ofn.lpstrFilter = STRPTR(sFilter)
hr = TB_OpenSaveFileName_GetFilterIndex(pthis, FilterIndex)
ofn.nFilterIndex = FilterIndex
ofn.lpstrFile = STRPTR(sFileSpec)
ofn.nMaxFile = LEN(sFileSpec)
ofn.lpstrFileTitle = VARPTR(szFileTitle)
ofn.nMaxFileTitle = SIZEOF(szFileTitle)
ofn.lpstrInitialDir = STRPTR(sInitialDir)
IF LEN(sCaption) THEN ofn.lpstrTitle = STRPTR(sCaption)
IF LEN(sDefExtension) THEN ofn.lpstrDefExt = STRPTR(sDefExtension)
hr = TB_OpenSaveFileName_GetFlags(pthis, dwFlags)
hr = TB_OpenSaveFileName_GetFileMustExist(pthis, fFileMustExist)
IF fFileMustExist THEN dwFLags = dwFLags OR %OFN_FILEMUSTEXIST
hr = TB_OpenSaveFileName_GetReadOnly(pthis, fReadOnly)
IF fReadOnly THEN dwFLags = dwFLags OR %OFN_READONLY
hr = TB_OpenSaveFileName_GetHideReadOnly(pthis, fHideReadOnly)
IF fHideReadOnly THEN dwFLags = dwFLags OR %OFN_HIDEREADONLY
hr = TB_OpenSaveFileName_GetAllowMultiSelect(pthis, fAllowMultiSelect)
IF fAllowMultiSelect THEN dwFLags = dwFLags OR %OFN_ALLOWMULTISELECT
hr = TB_OpenSaveFileName_GetLongNames (pthis, fLongNames)
IF fLongNames THEN dwFLags = dwFLags OR %OFN_LONGNAMES
hr = TB_OpenSaveFileName_GetExplorerStyle(pthis, fExplorerStyle)
IF fExplorerStyle THEN dwFLags = dwFLags OR %OFN_EXPLORER
ofn.Flags = dwFlags
FUNCTION = GetOpenFilename(ofn)
' Search for the end of the list
ix = INSTR(sFileSpec, $NUL & $NUL)
IF ix THEN
sFileSpec = LEFT$(sFileSpec, ix - 1)
ELSE
ix = INSTR(sFileSpec, $NUL)
IF ix THEN
sFileSpec = LEFT$(sFileSpec, ix - 1)
ELSE
sFileSpec = ""
END IF
END IF
' Replace nuls with "|" because we are going to store it in an ascciz string
REPLACE $NUL WITH "|" IN sFileSpec
sFileSpec = RTRIM$(sFileSpec)
hr = TB_OpenSaveFileName_SetFileName(pthis, sFileSpec)
hr = TB_OpenSaveFileName_SetFlags(pthis, ofn.Flags)
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' ShowSave method
' Shows the OpenFile dialog.
' ****************************************************************************************
FUNCTION TB_OpenSaveFileName_ShowSave (BYVAL pthis AS TB_OpenSaveFileName_IDispatchVtbl PTR) AS LONG
LOCAL ix AS LONG
LOCAL ofn AS OPENFILENAME
LOCAL szFileTitle AS ASCIIZ * %MAX_PATH
LOCAL hr AS LONG
LOCAL sFilter AS STRING
LOCAL sInitialDir AS STRING
LOCAL sFileSpec AS STRING
LOCAL sCaption AS STRING
LOCAL sDefExtension AS STRING
LOCAL dwFLags AS DWORD
LOCAL hParent AS DWORD
LOCAL FilterIndex AS LONG
LOCAL fFileMustExist AS INTEGER
LOCAL fReadOnly AS INTEGER
LOCAL fHideReadOnly AS INTEGER
LOCAL fAllowMultiSelect AS INTEGER
LOCAL fLongNames AS INTEGER
LOCAL fExplorerStyle AS INTEGER
' Filter is a sequence of ASCIIZ strings with a final (extra) $NUL terminator
REPLACE "|" WITH $NUL IN sFilter
sFilter = sFilter + $NUL
hr = TB_OpenSaveFileName_GetinitDir(pthis, sInitialDir)
IF LEN(sInitialDir) = 0 THEN sInitialDir = CURDIR$
hr = TB_OpenSaveFileName_GetFileName(pthis, sFileSpec)
IF LEN(sFileSpec) > %MAX_PATH THEN sFileSpec = LEFT$(sFileSpec, %MAX_PATH)
ix = INSTR(sFileSpec, $NUL)
IF ix THEN
sFileSpec = LEFT$(sFileSpec, ix) + SPACE$(%MAX_PATH - ix)
ELSE
sFileSpec = sFileSpec + $NUL + SPACE$(%MAX_PATH - LEN(sFileSpec))
END IF
hr = TB_OpenSaveFileName_GetDialogTitle(pthis, sCaption)
hr = TB_OpenSaveFileName_GetDefaultExt(pthis, sDefExtension)
ofn.lStructSize = SIZEOF(ofn)
hr = TB_OpenSaveFileName_GetParent(pthis, hParent)
ofn.hWndOwner = hparent
ofn.lpstrFilter = STRPTR(sFilter)
hr = TB_OpenSaveFileName_GetFilterIndex(pthis, FilterIndex)
ofn.nFilterIndex = FilterIndex
ofn.lpstrFile = STRPTR(sFileSpec)
ofn.nMaxFile = LEN(sFileSpec)
ofn.lpstrFileTitle = VARPTR(szFileTitle)
ofn.nMaxFileTitle = SIZEOF(szFileTitle)
ofn.lpstrInitialDir = STRPTR(sInitialDir)
IF LEN(sCaption) THEN ofn.lpstrTitle = STRPTR(sCaption)
IF LEN(sDefExtension) THEN ofn.lpstrDefExt = STRPTR(sDefExtension)
hr = TB_OpenSaveFileName_GetFlags(pthis, dwFlags)
hr = TB_OpenSaveFileName_GetFileMustExist(pthis, fFileMustExist)
IF fFileMustExist THEN dwFLags = dwFLags OR %OFN_FILEMUSTEXIST
hr = TB_OpenSaveFileName_GetReadOnly(pthis, fReadOnly)
IF fReadOnly THEN dwFLags = dwFLags OR %OFN_READONLY
hr = TB_OpenSaveFileName_GetHideReadOnly(pthis, fHideReadOnly)
IF fHideReadOnly THEN dwFLags = dwFLags OR %OFN_HIDEREADONLY
hr = TB_OpenSaveFileName_GetAllowMultiSelect(pthis, fAllowMultiSelect)
IF fAllowMultiSelect THEN dwFLags = dwFLags OR %OFN_ALLOWMULTISELECT
hr = TB_OpenSaveFileName_GetLongNames(pthis, fLongNames)
IF fLongNames THEN dwFLags = dwFLags OR %OFN_LONGNAMES
hr = TB_OpenSaveFileName_GetExplorerStyle(pthis, fExplorerStyle)
IF fExplorerStyle THEN dwFLags = dwFLags OR %OFN_EXPLORER
ofn.Flags = dwFlags
FUNCTION = GetSaveFilename(ofn)
ix = INSTR(sFileSpec, $NUL)
IF ix THEN
sFileSpec = LEFT$(sFileSpec, ix - 1)
ELSE
sFileSpec = ""
END IF
hr = TB_OpenSaveFileName_SetFileName(pthis, sFileSpec)
hr = TB_OpenSaveFileName_SetFlags(pthis, ofn.Flags)
END FUNCTION
' ****************************************************************************************
' ****************************************************************************************
' HRESULT Invoke([in] I4 dispidMember, [in] *GUID riid, [in] UI4 lcid, [in] UI2 wFlags, [in] *DISPPARAMS pdispparams, [out] *VARIANT pvarResult, [out] *EXCEPINFO pexcepinfo, [out] *UINT puArgErr)
' Note: PB ignores EXCEPINFO and puArgErr so we will also ignore them.
' ****************************************************************************************
FUNCTION TB_OpenSaveFileName_Invoke (BYVAL pthis AS TB_OpenSaveFileName_IDispatchVtbl PTR, BYVAL dispidMember AS LONG, BYREF riid AS GUID, _
BYVAL lcid AS DWORD, BYVAL wFlags AS WORD, BYREF pdispparams AS DISPPARAMS, BYREF pvarResult AS VARIANT, _
BYVAL pexcepinfo AS DWORD, BYREF puArgErr AS DWORD) AS LONG
LOCAL hr AS LONG ' // Standard hresult code
LOCAL uArgErr AS DWORD ' // Index of the argument that caused a %DISP_E_TYPEMISMATCH error.
LOCAL vPrm1 AS VARIANT ' // Variant parameter value
LOCAL prmString AS STRING ' // String parameter
LOCAL prmInteger AS INTEGER ' // Integer parameter
LOCAL prmLong AS LONG ' // Long parameter
LOCAL prmDword AS DWORD ' // Dword parameter
IF VARPTR(pvarResult) THEN pvarResult = EMPTY ' Empty any previous value
IF VARPTR(puArgErr) THEN puArgErr = 0 ' Ignore it
IF VARPTR(pdispparams) THEN
SELECT CASE AS LONG dispidMember
CASE &H00000001
IF (wFlags AND %DISPATCH_PROPERTYGET) = %DISPATCH_PROPERTYGET THEN
IF pDispparams.CountArgs <> 0 THEN
' This property doesn't have parameters
FUNCTION = %DISP_E_BADPARAMCOUNT
EXIT FUNCTION
ELSE
' Call the function and return the result
hr = TB_OpenSaveFileName_GetDialogTitle(pthis, prmString)
pvarResult = prmString
END IF
ELSEIF (wFlags AND %DISPATCH_PROPERTYPUT) = %DISPATCH_PROPERTYPUT THEN
IF pDispparams.CountArgs > 1 THEN
' This property only has one parameter
FUNCTION = %DISP_E_BADPARAMCOUNT
EXIT FUNCTION
ELSEIF pDispparams.CountArgs < 1 THEN
' This property has one parameter and is not optional
FUNCTION = %DISP_E_PARAMNOTOPTIONAL
EXIT FUNCTION
ELSE
' Check for errors and coerce the parameter to the specified type
hr = DispGetParam(pdispparams, %DISPID_PROPERTYPUT, %VT_BSTR, vPrm1, uArgErr)
IF hr <> %NOERROR THEN
' Return the error code
FUNCTION = hr
ELSE
' Call the function
hr = TB_OpenSaveFileName_SetDialogTitle(pthis, VARIANT$(vPrm1))
END IF
END IF
ELSE
FUNCTION = %E_INVALIDARG
END IF
CASE &H00000002
IF (wFlags AND %DISPATCH_PROPERTYGET) = %DISPATCH_PROPERTYGET THEN
IF pDispparams.CountArgs <> 0 THEN
' This property doesn't have parameters
FUNCTION = %DISP_E_BADPARAMCOUNT
EXIT FUNCTION
ELSE
' Call the function and return the result
hr = TB_OpenSaveFileName_GetFilter(pthis, prmString)
pVarResult = prmString
END IF
ELSEIF (wFlags AND %DISPATCH_PROPERTYPUT) = %DISPATCH_PROPERTYPUT THEN
IF pDispparams.CountArgs > 1 THEN
' This property only has one parameter
FUNCTION = %DISP_E_BADPARAMCOUNT
EXIT FUNCTION
ELSEIF pDispparams.CountArgs < 1 THEN
' This property has one parameter and is not optional
FUNCTION = %DISP_E_PARAMNOTOPTIONAL
EXIT FUNCTION
ELSE
' Check for errors and coerce the parameter to the specified type
hr = DispGetParam(pdispparams, %DISPID_PROPERTYPUT, %VT_BSTR, vPrm1, uArgErr)
IF hr <> %NOERROR THEN
' Return the error code
FUNCTION = hr
ELSE
' Call the function
hr = TB_OpenSaveFileName_SetFilter(pthis, VARIANT$(vPrm1))
END IF
END IF
ELSE
FUNCTION = %E_INVALIDARG
END IF
CASE &H00000003
IF (wFlags AND %DISPATCH_PROPERTYGET) = %DISPATCH_PROPERTYGET THEN
IF pDispparams.CountArgs <> 0 THEN
' This property doesn't have parameters
FUNCTION = %DISP_E_BADPARAMCOUNT
EXIT FUNCTION
ELSE
' Call the function and return the result
hr = TB_OpenSaveFileName_GetDefaultExt(pthis, prmString)
pvarResult = prmString
END IF
ELSEIF (wFlags AND %DISPATCH_PROPERTYPUT) = %DISPATCH_PROPERTYPUT THEN
IF pDispparams.CountArgs > 1 THEN
' This property only has one parameter
FUNCTION = %DISP_E_BADPARAMCOUNT
EXIT FUNCTION
ELSEIF pDispparams.CountArgs < 1 THEN
' This property has one parameter and is not optional
FUNCTION = %DISP_E_PARAMNOTOPTIONAL
EXIT FUNCTION
ELSE
' Check for errors and coerce the parameter to the specified type
hr = DispGetParam(pdispparams, %DISPID_PROPERTYPUT, %VT_BSTR, vPrm1, uArgErr)
IF hr <> %NOERROR THEN
' Return the error code
FUNCTION = hr
ELSE
' Call the function
hr = TB_OpenSaveFileName_SetDefaultExt(pthis, VARIANT$(vPrm1))
END IF
END IF
ELSE
FUNCTION = %E_INVALIDARG
END IF
CASE &H00000004
IF (wFlags AND %DISPATCH_PROPERTYGET) = %DISPATCH_PROPERTYGET THEN
' This property doesn't have parameters
IF pDispparams.CountArgs <> 0 THEN
FUNCTION = %DISP_E_BADPARAMCOUNT
EXIT FUNCTION
ELSE
' Call the function and return the result
hr = TB_OpenSaveFileName_GetInitDir(pthis, prmString)
pvarResult = prmString
END IF
ELSEIF (wFlags AND %DISPATCH_PROPERTYPUT) = %DISPATCH_PROPERTYPUT THEN
IF pDispparams.CountArgs > 1 THEN
' This property only has one parameter
FUNCTION = %DISP_E_BADPARAMCOUNT
EXIT FUNCTION
ELSEIF pDispparams.CountArgs < 1 THEN
' This property has one parameter and is not optional
FUNCTION = %DISP_E_PARAMNOTOPTIONAL
EXIT FUNCTION
ELSE
' Check for errors and coerce the parameter to the specified type
hr = DispGetParam(pdispparams, %DISPID_PROPERTYPUT, %VT_BSTR, vPrm1, uArgErr)
IF hr <> %NOERROR THEN
' Return the error code
FUNCTION = hr
ELSE
' Call the function
hr = TB_OpenSaveFileName_SetInitDir(pthis, VARIANT$(vPrm1))
END IF
END IF
ELSE
FUNCTION = %E_INVALIDARG
END IF
CASE &H00000005
IF (wFlags AND %DISPATCH_PROPERTYGET) = %DISPATCH_PROPERTYGET THEN
' Thi |