!  VFCaller.f90 
!
! 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 client that uses COM
! ErrorInfo objects
!
!  FUNCTIONS:
!   WinMain()      - Entry point for the application;
!                    displays the main window; processes the message loop
!   VFCallerSub()  - Callback routine for the main dialog box
!   VFCallerApply()- Callback routine for the APPLY button
!

!****************************************************************************
!
!  FUNCTION: WinMain( hInstance, hPrevInstance, lpszCmdLine, nCmdShow )
!
!  PURPOSE:  Entry point for the application
!
!  COMMENTS: Displays the main window and processes the message loop
!
!****************************************************************************

integer*4 function WinMain( hInstance, hPrevInstance, lpszCmdLine, nCmdShow )
!DEC$ IF DEFINED(_X86_)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_WinMain@16' :: WinMain
!DEC$ ELSE
!DEC$ ATTRIBUTES STDCALL, ALIAS : 'WinMain' :: WinMain
!DEC$ ENDIF

    use user32
    use kernel32
    use dflogm
    use dfcom
    use dfauto
    use VFCallerGlobals
    use AToI

    implicit none

    integer*4 hInstance
    integer*4 hPrevInstance
    integer*4 lpszCmdLine
    integer*4 nCmdShow

    include 'resource.fd'

    external VFCallerSub
    external VFCallerApply

    ! Variables
    type (T_MSG)            mesg
    integer*4               ret
    logical*4               lret


    ghInstance = hInstance
    ghModule = GetModuleHandle(NULL)
    ghwndMain = NULL
    gObj = NULL
    call COMINITIALIZE(ret)

    ! Create an object
    call COMCreateObject(CLSID_AToI, CLSCTX_SERVER, IID_IAToI, gObj, ret)
    if (ret < 0) then
        ret = MessageBox(NULL, "Error creating AToI object", "Error", MB_OK)
        WinMain = -1
        return
    end if

    lret = DlgInit(IDD_VFCALLER_DIALOG, gdlg)
    if (lret == .FALSE.) goto 99999
    lret = DlgSetSub(gdlg, IDD_VFCALLER_DIALOG, VFCallerSub)
    lret = DlgSetSub(gdlg, IDM_APPLY, VFCallerApply)
    lret = DlgModeless(gdlg, nCmdShow)
    if (lret == .FALSE.) goto 99999

    ! Read and process messsages
    do while( GetMessage (mesg, NULL, 0, 0) ) 
       if ( DlgIsDlgMessage(mesg) .EQV. .FALSE. ) then
           lret = TranslateMessage( mesg )
           ret  = DispatchMessage( mesg )
       end if
    end do
    call DlgUninit(gdlg)
    ret = COMReleaseObject(gObj);
    call COMUNINITIALIZE()

    WinMain = mesg.wParam
    return

99999 &

    ret = MessageBox(ghwndMain, "Error initializing application VFCaller"C, &
                     "Error"C, MB_OK)
    call COMUNINITIALIZE()
    WinMain = 0

end 

!****************************************************************************
!
!  FUNCTION: VFCallerSub ( dlg, id, callbacktype )
!
!  PURPOSE:  Dialog box callback for initialization and destroy
!
!  COMMENTS:
!
!****************************************************************************

SUBROUTINE VFCallerSub( dlg, id, callbacktype )

  use user32
  use dflogm
  use dfcom
  use dfauto

  implicit none

  include 'resource.fd'

  type (dialog) dlg
  integer id, callbacktype

  logical lret

  if (callbacktype == dlg_init) then
    lret = DlgSet(dlg, IDC_COMBO_TYPE, "VT_BSTR")
  else if (callbacktype == dlg_destroy) then
    call PostQuitMessage(0)
  endif

  END SUBROUTINE VFCallerSub

!****************************************************************************
!
!  FUNCTION: VFCallerApply ( dlg, id, callbacktype )
!
!  PURPOSE:  Dialog box callback for APPLY button
!
!  COMMENTS:
!
!****************************************************************************

SUBROUTINE VFCallerApply( dlg, id, callbacktype )

  use dflogm
  use dfcom
  use dfauto
  use VFCallerGlobals
  use AToI
  use ErrorInfo

  implicit none

  include 'resource.fd'

    interface
        integer function GetErrorInfo(reserved, pperrinfo)
        !dec$ attributes stdcall, alias:"_GetErrorInfo@8" :: GetErrorInfo
            integer, intent(in) :: reserved
            !dec$ attributes value :: reserved
            integer, intent(out) :: pperrinfo
            !dec$ attributes reference :: pperrinfo
        end function
    end interface

  type (dialog) dlg
  integer id, callbacktype

  type(VARIANT) Str
  integer Int
  character(20) text
  character(20) vartype
  character(100) desc
  character(100) source
  integer ret, ret2, supports
  logical lret
  real Flt
  integer IErrorInfoPtr
  integer ISupportErrorInfoPtr

  if (callbacktype == dlg_clicked) then
      lret = DlgGet(dlg, IDC_EDIT_VALUE, text)
      lret = DlgGet(dlg, IDC_COMBO_TYPE, vartype)
      if (vartype == "VT_BSTR") then
        Str%vt = VT_BSTR
        Str%vu%PTR_VAL = ConvertStringToBSTR(TRIM(text))
      else if (vartype == "VT_I4") then
        Str%vt = VT_I4
        READ (text, *, iostat=ret) Int
        Str%vu%LONG_VAL = Int
      else if (vartype == "VT_R4") then
        Str%vt = VT_R4
        READ (text, *, iostat=ret) Flt
        Str%vu%FLOAT_VAL = Flt
      end if
	  ret = $IAToI_AToI(gObj, Str, Int)
	  ret2 = VariantClear(Str)
      desc = ""
      source = ""
      if (ret < 0) then
        !  Ask if the interface supports ErrorInfo
        supports = E_FAIL
        call COMQueryInterface(gObj, IID_ISupportErrorInfo, ISupportErrorInfoPtr, ret)
        if (.not. (ret < 0)) then
            supports = $ISupportErrorInfo_InterfaceSupportsErrorInfo(ISupportErrorInfoPtr, IID_IAToI)
            ret = COMReleaseObject(ISupportErrorInfoPtr)
        end if

        if (supports == S_OK) then
            !  Get the current error object
            ret = GetErrorInfo(0, IErrorInfoPtr)
            if (ret == S_OK) then
  			    ret = $IErrorInfo_GetDescription(IErrorInfoPtr, desc)
  			    ret = $IErrorInfo_GetSource(IErrorInfoPtr, source)
                ret = COMReleaseObject(IErrorInfoPtr);
            end if
        end if
      end if
      lret = DlgSet(dlg, IDC_EDIT_DESCRIPTION, desc)
      lret = DlgSet(dlg, IDC_EDIT_SOURCE, source)
      WRITE(text, *) Int
      lret = DlgSet(dlg, IDC_RETURN_VALUE, text)
  endif

  END SUBROUTINE VFCallerApply


