! Limited implemention of AUTOSetPropertyByID to allow setting a property by reference ! ! use myAUTO ! ! exposes myAUTOSetPropertyByID which can be invoked using ifauto's invokeargs or a T_DISPARGS structure ! ! Note: this file should NOT be compiled with /warn:interfaces module myAUTOParameters use ifwinty integer, public, parameter :: DISPID = LONG integer, public, parameter :: HRESULT = LONG end module myAUTOParameters module myAUTO use myAUTOParameters implicit none private interface myAUTOSetPropertyByID module procedure :: myAUTOSetPropertyByID$IA,myAUTOSetPropertyByID$DP end interface public myAUTOSetPropertyByID contains function myAUTOSetPropertyByID$IA($object,memid,invokeargs,by_ref) result (h_result) integer(INT_PTR_KIND()), intent(in) :: $object integer(DISPID), intent(in) :: memid integer(INT_PTR_KIND()), intent(in) :: invokeargs logical, intent(in) :: by_ref integer(HRESULT) :: h_result !DEC$ if defined(_M_IX86) type :: invoke_args_t sequence integer(INT_PTR_KIND()) :: not_known_1 ! Bodge to account for unknown and padding bytes, 32 bit integer(LONG) :: count integer(INT_PTR_KIND()) :: first_arg_ptr end type type :: invoke_arg_t sequence integer(INT_PTR_KIND()) :: name_ptr integer(LONG) :: not_known_1 ! Bodge to account for unknown and padding bytes, 32 bit type(VARIANT) :: arg integer(LONG) :: not_known_2(7) ! Bodge to account for unknown and padding bytes, 32 bit integer(INT_PTR_KIND()) :: next_arg_ptr end type !DEC$ elseif defined (_M_X64) type :: invoke_args_t integer(INT_PTR_KIND()) :: not_known_1 ! Bodge to account for unknown and padding bytes, 64 bit integer(LONG) :: count integer(LONG) :: not_known_2 ! Bodge to account for unknown and padding bytes, 64 bit integer(INT_PTR_KIND()) :: first_arg_ptr end type type :: invoke_arg_t sequence integer(INT_PTR_KIND()) :: name_ptr type(VARIANT) :: arg integer(LONG) :: not_known_1(12) ! Bodge to account for unknown and padding bytes, 64 bit integer(INT_PTR_KIND()) :: next_arg_ptr end type !DEC$ endif type(invoke_args_t) :: invoke_args pointer(invoke_args_ptr,invoke_args) type(invoke_arg_t) :: invoke_arg pointer(invoke_arg_ptr,invoke_arg) type(T_DISPPARAMS) :: dispparams type(VARIANT), allocatable :: args(:) integer :: i_arg invoke_args_ptr = invokeargs allocate(args(invoke_args%count)) invoke_arg_ptr = invoke_args%first_arg_ptr do i_arg = 1,invoke_args%count args(i_arg) = invoke_arg%arg invoke_arg_ptr = invoke_arg%next_arg_ptr end do dispparams%cArgs = invoke_args%count dispparams%rgvarg = Loc(args) h_result = myAUTOSetPropertyByID$DP($object,memid,dispparams,by_ref) deallocate(args) end function myAUTOSetPropertyByID$IA function myAUTOSetPropertyByID$DP($object,memid,dispparams,by_ref) result (h_result) integer(INT_PTR_KIND()), intent(in) :: $object integer(DISPID), intent(in) :: memid type(T_DISPPARAMS) :: dispparams logical, intent(in) :: by_ref integer(HRESULT) :: h_result interface function myAUTO_IDispatchInvoke$LP(this,Invoke,memid,dispparams,flags) import integer(HRESULT) :: myAUTO_IDispatchInvoke integer(INT_PTR_KIND()) :: this integer(INT_PTR_KIND()), intent(in) :: Invoke !DEC$ ATTRIBUTES VALUE :: Invoke integer(DISPID), intent(in) :: memid type(T_DISPPARAMS) :: dispparams integer(WORD) :: flags end function myAUTO_IDispatchInvoke$LP end interface type(T_IDispatch) :: idispatch pointer(idispatch_ptr,idispatch) type(T_IDispatchVtbl) :: idispatch_vtbl pointer(idispatch_vtbl_ptr,idispatch_vtbl) integer(LONG) :: named_args integer(WORD) :: flags idispatch_ptr = $object idispatch_vtbl_ptr = idispatch%lpVtbl if (by_ref) then flags = DISPATCH_PROPERTYPUTREF else flags = DISPATCH_PROPERTYPUT end if named_args = DISPID_PROPERTYPUT dispparams%cNamedArgs = 1 dispparams%rgdispidNamedArgs = Loc(named_args) h_result = myAUTO_IDispatchInvoke$LP($object,idispatch_vtbl%Invoke,memid,dispparams,flags) end function myAUTOSetPropertyByID$DP end module myAUTO function myAUTO_IDispatchInvoke$LP(this,Invoke,memid,dispparams,flags) result (h_result) ! IDispatch::Invoke, limited to putting a property with no returned error info. use myAUTOParameters integer(INT_PTR_KIND()) :: this integer(DISPID), intent(in) :: memid type(T_DISPPARAMS) :: dispparams integer(HRESULT) :: h_result integer(WORD) :: flags type(T_GUID), parameter :: GUID_NULL = T_GUID(0_ULONG,0_USHORT,0_USHORT,Repeat(Char(0),8)) interface function Invoke(this,dispIdMember,riid,lcid,wFlags,pDispParams,pVarResult,pExcepInfo,puArgErr) !DEC$ ATTRIBUTES DEFAULT, STDCALL :: Invoke use myAUTOParameters integer(HRESULT) :: Invoke integer(INT_PTR_KIND()) :: this integer(DISPID) :: dispIdMember type(T_GUID) :: riid !DEC$ ATTRIBUTES REFERENCE :: riid integer(DWORD) :: lcid integer(WORD) :: wFlags type(T_DISPPARAMS) :: pDispParams !DEC$ ATTRIBUTES REFERENCE :: pDispParams type(VARIANT) :: pVarResult !DEC$ ATTRIBUTES REFERENCE, ALLOW_NULL :: pVarResult type(T_EXCEPINFO) :: pExcepInfo !DEC$ ATTRIBUTES REFERENCE, ALLOW_NULL :: pExcepInfo integer(UINT) :: puArgErr !DEC$ ATTRIBUTES REFERENCE, ALLOW_NULL :: puArgErr end function Invoke end interface h_result = Invoke(this,memid,GUID_NULL,LOCALE_SYSTEM_DEFAULT,flags,dispparams,NULL,NULL,NULL) end function myAUTO_IDispatchInvoke$LP