!
!  UIAToI.f90 - This file contains the implementation of the
!                    IAToI methods
!
! This software is provided as an example that demonstrates a particular
! feature/function of the licensed product. The software is not intended to
! provide a complete solution to any application problem but rather is provided
! as a teaching mechanism.
! 
! Users may incorporate any part of this sample into their own source after 
! making appropriate changes to make it suitable for the intended application.
!
! This sample program demonstrates a Fortran COM Server that supports COM
! ErrorInfo objects


    !  This routine initializes an ErrorInfo object

    subroutine VFSetErrorInfo(description, source, iid, &
                              helpfile, helpcontext)
        use ErrorInfo
        implicit none
        character(len=*) description
        character(len=*) source
        type(guid)    iid
        character(len=*) helpfile
        integer*4     helpcontext

        integer(INT_PTR_KIND())       ICreateErrorInfoPtr
        integer(INT_PTR_KIND())       IErrorInfoPtr
        integer       hresult
        integer       bstr

        interface
            integer function CreateErrorInfo(pperrinfo)
            !dec$ attributes stdcall, alias:"_CreateErrorInfo@4" :: CreateErrorInfo
                integer(INT_PTR_KIND()), intent(out) :: pperrinfo
                !dec$ attributes reference :: pperrinfo
            end function
            integer function SetErrorInfo(reserved, pperrinfo)
            !dec$ attributes stdcall, alias:"_SetErrorInfo@8" :: SetErrorInfo
                integer, intent(in) :: reserved
                !dec$ attributes value :: reserved
                integer(INT_PTR_KIND()), intent(in) :: pperrinfo
                !dec$ attributes value :: pperrinfo
            end function
        end interface

        hresult = CreateErrorInfo(ICreateErrorInfoPtr)
        if (.not. (hresult < 0)) then
    		bstr = ConvertStringToBSTR(description)
            hresult = $ICreateErrorInfo_SetDescription(ICreateErrorInfoPtr, bstr)
			call SysFreeString(bstr)
    		bstr = ConvertStringToBSTR(source)
            hresult = $ICreateErrorInfo_SetSource(ICreateErrorInfoPtr, bstr)
			call SysFreeString(bstr)
            hresult = $ICreateErrorInfo_SetGUID(ICreateErrorInfoPtr, iid)
            if (helpfile /= "") then
        		bstr = ConvertStringToBSTR(helpfile)
                hresult = $ICreateErrorInfo_SetHelpFile(ICreateErrorInfoPtr, bstr)
                hresult = $ICreateErrorInfo_SetHelpContext(ICreateErrorInfoPtr, helpcontext)
				call SysFreeString(bstr)
            endif
            call COMQueryInterface(ICreateErrorInfoPtr, IID_IErrorInfo, IErrorInfoPtr, hresult)
            if (.not. (hresult < 0)) then
                hresult = SetErrorInfo(0, IErrorInfoPtr)
                hresult = COMReleaseObject(IErrorInfoPtr)
            end if
            hresult = COMReleaseObject(ICreateErrorInfoPtr)
        end if

    end subroutine

    function IAToI_AToI( ObjectData ,&
             Str,&
			 Int) result (hresult)
        use AToI_Types
		use dfcom
        implicit none
        type(AToI_InstanceData) ObjectData
        !dec$ attributes reference :: ObjectData
        TYPE(VARIANT), intent(in) :: Str
        INTEGER(4), intent(out) :: Int
        integer(LONG) hresult
        character(20) text
        integer retint

        hresult = S_OK
        Int = 0

		!  Convert the string to an integer
		!  NOTE:  We could use VariantChangeType here but that doesn't 
		!         fit the example...

        !  Check for a Variant type of VT_BSTR
        if (Str%vt /= VT_BSTR) then
            call VFSetErrorInfo("Invalid VARIANT datatype",  &
                "IAToI::AToI", IID_IAToI, "", 0)
            hresult = E_INVALIDARG
			return
        end if

        !  Convert the string to an integer using an internal read
		retint = ConvertBSTRToString(Str%vu%PTR_VAL, text)
        READ (text, *, iostat=retint) Int
        if (retint /= 0) then
            call VFSetErrorInfo("Invalid integer value",  &
                "IAToI::AToI", IID_IAToI, "", 0)
            hresult = E_INVALIDARG
			return
        end if

    end function
