!
!  AToITY.f90 - This module contains definitions of the AToI class
!
!  Generated by the Visual Fortran COM Server Wizard on
!  11/08/00 at 15:04:33.
!
!   DO NOT EDIT THIS FILE!
!
!  This file is re-generated every time the object hierarchy is changed.
!

module AToI_Types

    use AToI_USE
    use dfwinty

    !  Strings used in registering class
    character*11, parameter :: AToI_CLASS_NAME = ("AToI Class")
    character*14, parameter :: AToI_PROGID = ("ErrorInfo.AToI")
    character*3,  parameter :: AToI_VERSION = ("1.0")
    character*10, parameter :: AToI_THREADING_MODEL = ("APARTMENT")

    ! CLSIDs        
    TYPE (GUID), PARAMETER :: CLSID_AToI = &
        GUID(#6B87E426, #B586, #11D4, &
        CHAR('AB'X)//CHAR('D9'X)//CHAR('44'X)//CHAR('45'X)// &
        CHAR('53'X)//CHAR('54'X)//CHAR('00'X)//CHAR('00'X))
                                                
    ! IIDs      
    ! Per Interface
    TYPE (GUID), PARAMETER :: IID_IAToI = &
        GUID(#6B87E427, #B586, #11D4, &
        CHAR('AB'X)//CHAR('D9'X)//CHAR('44'X)//CHAR('45'X)// &
        CHAR('53'X)//CHAR('54'X)//CHAR('00'X)//CHAR('00'X))
    TYPE (GUID), PARAMETER :: IID_ISupportErrorInfo = &
        GUID(#DF0B3D60, #548F, #101B, &
        CHAR('8E'X)//CHAR('65'X)//CHAR('08'X)//CHAR('00'X)// &
        CHAR('2B'X)//CHAR('2B'X)//CHAR('D1'X)//CHAR('19'X))

    !  This is the per-instance data of the class
    ! Per Interface
    type IAToI_Ptr
        sequence
        type (IAToI_Vtbl), pointer :: pVtbl
        type (AToI_InternalData), pointer :: pInternalData
    end type IAToI_Ptr
    type ISupportErrorInfo_Ptr
        sequence
        type (ISupportErrorInfo_Vtbl), pointer :: pVtbl
        type (AToI_InternalData), pointer :: pInternalData
    end type ISupportErrorInfo_Ptr

    type AToI_InternalData
        sequence
        type (AToI_InstanceData), pointer :: pInstanceData
        type (AToI_Data), pointer :: pStart
        integer refCount
    end type AToI_InternalData

    type AToI_Data
        sequence
    ! Per Interface
        type (IAToI_ptr) IAToI_InternalData
        type (ISupportErrorInfo_ptr) ISupportErrorInfo_InternalData
        type (AToI_InternalData) InternalData
    end type AToI_Data

    ! Per Interface
    !  All methods must return integer(LONG) (an HRESULT)
    !  All methods must take as their first argument, the instance
    !  data type by reference
    type IAToI_Vtbl
        sequence
        ! IUnknown Methods
        integer(INT_PTR_KIND()) QueryInterface
        integer(INT_PTR_KIND()) AddRef
        integer(INT_PTR_KIND()) Release
        ! IDispatch Methods
        integer(INT_PTR_KIND()) GetTypeInfoCount
        integer(INT_PTR_KIND()) GetTypeInfo
        integer(INT_PTR_KIND()) GetIDsOfNames
        integer(INT_PTR_KIND()) Invoke
        !  IAToI Methods
        integer(INT_PTR_KIND()) AToI
    end type IAToI_Vtbl
    type ISupportErrorInfo_Vtbl
        sequence
        ! IUnknown Methods
        integer(INT_PTR_KIND()) QueryInterface
        integer(INT_PTR_KIND()) AddRef
        integer(INT_PTR_KIND()) Release
        !  ISupportErrorInfo Methods
        integer(INT_PTR_KIND()) InterfaceSupportsErrorInfo
    end type ISupportErrorInfo_Vtbl

  contains

    !  IUnknown implementation for all interfaces of the class

    function AToI_QueryInterface (pData, riid, ppv) result (r)
    !DEC$ ATTRIBUTES STDCALL :: AToI_QueryInterface
        use dfwinty
        use dfcom
        implicit none

        type (IAToI_Ptr) pData
        !dec$ attributes reference :: pData
        type(GUID), INTENT(IN) :: riid
        !dec$ attributes reference :: riid
        integer(INT_PTR_KIND()), INTENT(OUT) :: ppv
        !dec$ attributes reference :: ppv
        integer(LONG) r

        r = S_OK
        ppv = NULL

        !  Ensure that they are requesting a supported interface
        !  NOTE:  All requests for IUnknown MUST return the same pointer (per COM)
        if (COMIsEqualGUID(riid, IID_IUnknown)) then
            ppv = loc(pData % pInternalData % pStart % IAToI_InternalData)
        !  Per interface
        else if (COMIsEqualGUID(riid, IID_IAToI)) then
            ppv = loc(pData % pInternalData % pStart % IAToI_InternalData)
        else if (COMIsEqualGUID(riid, IID_IDispatch)) then
            ppv = loc(pData % pInternalData % pStart % IAToI_InternalData)
        else if (COMIsEqualGUID(riid, IID_ISupportErrorInfo)) then
            ppv = loc(pData % pInternalData % pStart % ISupportErrorInfo_InternalData)
        end if

        if (ppv == NULL) then
            r = E_UNEXPECTED 
            return
        end if

        pData % pInternalData % refCount = &
            pData % pInternalData % refCount + 1

    end function 

    function AToI_AddRef (pData) result (r)
    !DEC$ ATTRIBUTES STDCALL :: AToI_AddRef
        use dfwinty
        implicit none

        type (IAToI_Ptr) pData
        !dec$ attributes reference :: pData
        integer r

        pData % pInternalData % refCount = &
            pData % pInternalData % refCount + 1
        r = pData % pInternalData % refCount

    end function 

    function AToI_Release (pData) result (r)
    !DEC$ ATTRIBUTES STDCALL :: AToI_Release
        use dfwinty
        use ErrorInfo_global
        implicit none

        type (IAToI_Ptr) pData
        !dec$ attributes reference :: pData
        integer r

        type (AToI_Data),  pointer :: pAToIData
        integer status

        pData % pInternalData % refCount = &
            pData % pInternalData % refCount - 1
        r = pData % pInternalData % refCount
        if (pData % pInternalData % refCount == 0) then
            !  Time to delete ourself....
            pAToIData => pData % pInternalData % pStart
            !  Call the "destructor"
            call AToI_DESTRUCTOR(pAToIData % InternalData % pInstanceData)
            !  Per interface
            deallocate (pAToIData % IAToI_InternalData % pVtbl)
            deallocate (pAToIData % ISupportErrorInfo_InternalData % pVtbl)
            deallocate (pAToIData % InternalData % pInstanceData)
            deallocate (pAToIData)
            status = ServerUnlock()
        end if

    end function 


    !  IDispatch implementation for IAToI

    function AToI_GetTypeInfoCount(pData, pctinfo) result (hresult)
        !DEC$ ATTRIBUTES STDCALL :: AToI_GetTypeInfoCount
        implicit none
        type (IAToI_Ptr) pData
        !dec$ attributes reference :: pData
        integer(LONG), INTENT(OUT) :: pctinfo
        !dec$ attributes reference :: pctinfo
        integer(LONG) hresult

        hresult = S_OK
        pctinfo = 1

    end function

    function AToI_GetTypeInfo(pData, iTInfo, lcid, ppTInfo) result (hresult)
        !DEC$ ATTRIBUTES STDCALL :: AToI_GetTypeInfo
        use dfwinty
        use ErrorInfo_global
        use kernel32
        use oleaut32
        use dfcom
        implicit none
        type (IAToI_Ptr) pData
        !dec$ attributes reference :: pData
        integer, INTENT(IN) :: iTInfo
        !dec$ attributes value :: iTInfo
        integer, INTENT(IN) :: lcid
        !dec$ attributes value :: lcid
        integer(INT_PTR_KIND()), INTENT(OUT) :: ppTInfo
        !dec$ attributes reference :: ppTInfo
        integer(LONG) hresult

        interface
            function GetTypeInfoOfGuid(pITypeLib, rguid, ppTInfo) result (hresult)
            !DEC$ ATTRIBUTES DEFAULT :: GetTypeInfoOfGuid
            !DEC$IF DEFINED(_X86_)
            !DEC$ ATTRIBUTES STDCALL, ALIAS:'_GetTypeInfoOfGuid@8' :: GetTypeInfoOfGuid
            !DEC$ ELSE
            !DEC$ ATTRIBUTES STDCALL, ALIAS:'GetTypeInfoOfGuid' :: GetTypeInfoOfGuid
            !DEC$ ENDIF
                use dfwinty
                integer(INT_PTR_KIND()) pITypeLib
                !dec$ attributes value :: pITypeLib
                TYPE (GUID), INTENT(IN) :: rguid 
                !dec$ attributes reference :: rguid
                integer(INT_PTR_KIND()), INTENT(OUT) :: ppTInfo
                !dec$ attributes reference :: ppTInfo
                integer(LONG) hresult
            end function
        end interface
		POINTER(GetTypeInfoOfGuid_PTR, GetTypeInfoOfGuid)	! routine pointer

        integer(INT_PTR_KIND()) pITypeLib    ! ITypeLib*
		INTEGER(INT_PTR_KIND()) $VTBL		 ! ITypeLib Function Table
		POINTER($VPTR, $VTBL)
        integer res

        hresult = S_OK
        if (iTInfo /= 0) then
            hresult = TYPE_E_ELEMENTNOTFOUND
            return
        end if
        ppTInfo = gAToIITypeInfo
        
        !  Get the type information if we don't already have it
        !  NOTE:  This code will always return the ITypeInfo of the
        !         first LCID that is found
        if (gAToIITypeInfo == NULL) then
            call EnterCriticalSection(loc(gGlobalCriticalSection))
            if (gAToIITypeInfo == NULL) then
                hresult = LoadRegTypeLib(GUID_TypeLib_ErrorInfo, 1, 0, lcid, pITypeLib)
                if (hresult < 0) then
                    call LeaveCriticalSection(loc(gGlobalCriticalSection))
                    return
                end if
				$VPTR = pITypeLib
				$VPTR = $VTBL + (6 * INT_PTR_KIND()) ! Add GetTypeInfoOfGuid routine offset
				GetTypeInfoOfGuid_PTR = $VTBL
                hresult = GetTypeInfoOfGuid(pITypeLib, IID_IAToI, gAToIITypeInfo)
                res = COMReleaseObject(pITypelib)
                if (hresult < 0) then
                    call LeaveCriticalSection(loc(gGlobalCriticalSection))
                    return
                end if
            end if
            call LeaveCriticalSection(loc(gGlobalCriticalSection))
            ppTInfo = gAToIITypeInfo
        end if
        res = COMAddObjectReference(gAToIITypeInfo)

    end function

    function AToI_GetIDsOfNames(pData, riid, rgszNames, cNames, lcid, rgDispID) result (hresult)
        !DEC$ ATTRIBUTES STDCALL :: AToI_GetIDsOfNames
        use dfwinty
        use ErrorInfo_global
        use dfcom
        implicit none
        type (IAToI_Ptr) pData
        !dec$ attributes reference :: pData
        TYPE (GUID), INTENT(IN)    :: riid 
        !dec$ attributes reference :: riid
        integer(INT_PTR_KIND()), INTENT(IN) :: rgszNames
        !dec$ attributes value :: rgszNames
        integer, INTENT(IN) :: cNames
        !dec$ attributes value :: cNames
        integer, INTENT(IN) :: lcid
        !dec$ attributes value :: lcid
        integer(LONG), DIMENSION(:), INTENT(OUT) :: rgDispID
        !dec$ attributes reference :: rgDispID
        integer(LONG) hresult

        interface
            function DispGetIDsOfNames(pITypeInfo, rgszNames, cNames, rgDispID) result (hresult)
            !DEC$ ATTRIBUTES DEFAULT :: DispGetIDsOfNames
            !DEC$IF DEFINED(_X86_)
            !DEC$ ATTRIBUTES STDCALL, ALIAS:'_DispGetIDsOfNames@16' :: DispGetIDsOfNames
            !DEC$ ELSE
            !DEC$ ATTRIBUTES STDCALL, ALIAS:'DispGetIDsOfNames' :: DispGetIDsOfNames
            !DEC$ ENDIF
                use dfwinty
                integer(INT_PTR_KIND()) pITypeInfo
                !dec$ attributes value :: pITypeInfo
                integer(INT_PTR_KIND()), INTENT(IN) :: rgszNames
                !dec$ attributes value :: rgszNames
                integer, INTENT(IN) :: cNames
                !dec$ attributes value :: cNames
                integer(LONG), DIMENSION(:), INTENT(OUT) :: rgDispID
                !dec$ attributes reference :: rgDispID
                integer(LONG) hresult
            end function
        end interface

   		TYPE (GUID), PARAMETER :: IID_NULL = &
			GUID(#00000000, #0000, #0000, &
			  CHAR('00'X)//CHAR('00'X)//CHAR('00'X)//CHAR('00'X)// &
			  CHAR('00'X)//CHAR('00'X)//CHAR('00'X)//CHAR('00'X))
        integer(INT_PTR_KIND()) pTInfo 
        integer res

        hresult = S_OK

        !  The riid argument must be IID_NULL
        if (.not. COMIsEqualGUID(riid, IID_NULL)) then
            hresult = DISP_E_UNKNOWNINTERFACE
            return
        end if

        !  Get the ITypeInfo pointer
        hresult = AToI_GetTypeInfo(pData, 0, lcid, pTInfo)
        if (hresult < 0) return

        !  Call DispGetIDsOfNames
        hresult = DispGetIDsOfNames(pTInfo, rgszNames, cNames, rgDispID)
        res = COMReleaseObject(pTInfo)

    end function

    function AToI_Invoke(pData, dispidMember, riid, lcid, &
        wFlags, pparams, pvarResult, pexcepinfo, puArgErr) result (hresult)
        !DEC$ ATTRIBUTES STDCALL :: AToI_Invoke
        use dfwinty
        use ErrorInfo_global
        use dfcom
        implicit none
        type (IAToI_Ptr) pData
        !dec$ attributes reference :: pData
        integer(LONG), INTENT(IN) :: dispidMember
        !dec$ attributes value :: dispidMember
        TYPE (GUID), INTENT(IN)    :: riid 
        !dec$ attributes reference :: riid
        integer, INTENT(IN) :: lcid
        !dec$ attributes value :: lcid
        integer(2), INTENT(IN) :: wFlags
        !dec$ attributes value :: wFlags
        TYPE(T_DISPPARAMS), INTENT(INOUT) :: pparams
        !dec$ attributes reference :: pparams
        TYPE(VARIANT), INTENT(OUT) :: pvarResult
        !dec$ attributes reference :: pvarResult
        TYPE(T_EXCEPINFO), INTENT(OUT) :: pexcepinfo
        !dec$ attributes reference :: pexcepinfo
        integer, INTENT(OUT) :: puArgErr
        !dec$ attributes reference :: puArgErr
        integer(LONG) hresult

        interface
            function DispInvoke(pInterface, pTInfo, dispidMember, &
                wFlags, pparams, pvarResult, pexcepinfo, puArgErr) result (hresult)
            !DEC$ ATTRIBUTES DEFAULT :: DispInvoke
            !DEC$IF DEFINED(_X86_)
            !DEC$ ATTRIBUTES STDCALL, ALIAS:'_DispInvoke@32' :: DispInvoke
            !DEC$ ELSE
            !DEC$ ATTRIBUTES STDCALL, ALIAS:'DispInvoke' :: DispInvoke
            !DEC$ ENDIF
                use dfwinty
                integer(INT_PTR_KIND()) pInterface
                !dec$ attributes value :: pInterface
                integer(INT_PTR_KIND()) pTInfo
                !dec$ attributes value :: pTInfo
                integer(LONG), INTENT(IN) :: dispidMember
                !dec$ attributes value :: dispidMember
                integer(2), INTENT(IN) :: wFlags
                !dec$ attributes value :: wFlags
                TYPE(T_DISPPARAMS), INTENT(INOUT) :: pparams
                !dec$ attributes reference :: pparams
                TYPE(VARIANT), INTENT(OUT) :: pvarResult
                !dec$ attributes reference :: pvarResult
                TYPE(T_EXCEPINFO), INTENT(OUT) :: pexcepinfo
                !dec$ attributes reference :: pexcepinfo
                integer, INTENT(OUT) :: puArgErr
                !dec$ attributes reference :: puArgErr
                integer(LONG) hresult
            end function
        end interface

   		TYPE (GUID), PARAMETER :: IID_NULL = &
			GUID(#00000000, #0000, #0000, &
			  CHAR('00'X)//CHAR('00'X)//CHAR('00'X)//CHAR('00'X)// &
			  CHAR('00'X)//CHAR('00'X)//CHAR('00'X)//CHAR('00'X))
        integer(INT_PTR_KIND()) pTInfo 
        integer res

        hresult = S_OK

        !  The riid argument must be IID_NULL
        if (.not. COMIsEqualGUID(riid, IID_NULL)) then
            hresult = DISP_E_UNKNOWNINTERFACE
            return
        end if

        !  Get the ITypeInfo pointer
        hresult = AToI_GetTypeInfo(pData, 0, lcid, pTInfo)
        if (hresult < 0) return

        !  Call DispInvoke
        hresult = DispInvoke(loc(pdata), pTInfo, dispidMember, &
                wFlags, pparams, pvarResult, pexcepinfo, puArgErr)
        res = COMReleaseObject(pTInfo)

    end function

end module




