! This software THERM.F90 is part of the Compaq Visual Fortran kit.
! 
! 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 "dialog-based" Fortran application using
! the Visual Fortran Dialog Functions.  The main window of the application
! is a dialog box.  This program uses a Spin control, a Slider control, a
! Progress bar control, and Picture controls.  It also demonstrates using
! multiple modeless dialog boxes.
!
! The basic structure of this application was generated using the Fortran
! Windows Application project wizard.
!
!
!  FUNCTIONS:
!	WinMain()        - Entry point for the application;
!                      displays the main window; processes the message loop
!	ThermSub()	     - Callback routine for the main dialog box
!	ThermApply()     - Callback routine for the APPLY button
!	ThermSpin()      - Callback routine for the spin control
!	ThermSlider()    - Callback routine for the slider control
!	ThermScroll()    - Callback routine for the scroll bar
!	ThermEdit()      - Callback routine for the edit box
!	ThermometerSub() - Callback routine for the thermometer dialog box
!

!****************************************************************************
!
!  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 dflib
	use dfwin
	use dflogm
	use ThermGlobals

	implicit none

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

	include 'resource.fd'

	external ThermSub
	external ThermApply
	external ThermSpin
	external ThermSlider
	external ThermScroll
	external ThermEdit
	external ThermometerSub

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


	ghInstance = hInstance
	ghModule = GetModuleHandle(NULL)

	! Create the main dialog box and set up the controls and callbacks
	lret = DlgInit(IDD_THERM_DIALOG, dlg)
	lret = DlgSetSub(dlg, IDD_THERM_DIALOG, ThermSub)
	lret = DlgSetSub(dlg, IDM_APPLY, ThermApply)
	lret = DlgSetSub(dlg, IDC_SPIN1, ThermSpin)
	lret = DlgSetSub(dlg, IDC_SLIDER1, ThermSlider)
	lret = DlgSetSub(dlg, IDC_SCROLLBAR1, ThermScroll)
	lret = DlgSetSub(dlg, IDC_EDIT1, ThermEdit, DLG_LOSEFOCUS)

	lret = DlgSet(dlg, IDC_SPIN1, 32)
	lret = DlgSet(dlg, IDC_SLIDER1, 10, DLG_TICKFREQ)
	lret = DlgSet(dlg, IDC_SCROLLBAR1, 20, DLG_BIGSTEP)

	lret = DlgSet(dlg, IDC_SPIN1, 32, DLG_RANGEMIN)
	lret = DlgSet(dlg, IDC_SLIDER1, 32, DLG_RANGEMIN)
	lret = DlgSet(dlg, IDC_SCROLLBAR1, 32, DLG_RANGEMIN)
	lret = DlgSet(dlg, IDC_SPIN1, 212, DLG_RANGEMAX)
	lret = DlgSet(dlg, IDC_SLIDER1, 212, DLG_RANGEMAX)
	lret = DlgSet(dlg, IDC_SCROLLBAR1, 212, DLG_RANGEMAX)
	lret = DlgModeless(dlg, nCmdShow)

	! Create the thermometer dialog box and set up the controls and callbacks
	lret = DlgInit(IDD_THERMOMETER, dlg_thermometer)
	lret = DlgSetSub(dlg_thermometer, IDD_THERMOMETER, ThermometerSub)
	lret = DlgSet(dlg_thermometer, IDC_PROGRESS1, 32, DLG_RANGEMIN)
	lret = DlgSet(dlg_thermometer, IDC_PROGRESS1, 212, DLG_RANGEMAX)
	lret = DlgSet(dlg_thermometer, IDC_PROGRESS1, 32)
	lret = DlgModeless(dlg_thermometer, nCmdShow)

	! Read and process messsages
	do while( GetMessage (mesg, NULL, 0, 0) ) 
	   ! Note that DlgIsDlgMessage must be called in order to give
	   ! the dialog box first chance at the message.
	   if ( DlgIsDlgMessage(mesg) .EQV. .FALSE. ) then
		   lret = TranslateMessage( mesg )
		   ret  = DispatchMessage( mesg )
	   end if
	end do

	! Cleanup dialog box memory
	call DlgUninit(dlg)

	WinMain = mesg.wParam
	return

99999 &

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

end 

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

SUBROUTINE ThermSub( dlg, id, callbacktype )
!DEC$ ATTRIBUTES DEFAULT :: ThermSub

  use dfwin
  use dflogm

  implicit none

  include 'resource.fd'

  type (dialog) dlg
  integer id, callbacktype

  ! When the user presses the "Exit" button, the default callback
  ! calls DLGEXIT which calls this callback with 
  ! callbacktype == dlg_destroy.  We call PostQuitMessage to cause
  ! the message loop in WinMain to terminate.
  if (callbacktype == dlg_destroy) then
	call PostQuitMessage(0)
  endif

  END SUBROUTINE ThermSub

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

SUBROUTINE ThermApply( dlg, id, callbacktype )
!DEC$ ATTRIBUTES DEFAULT :: ThermApply

  use dflogm
  use ThermGlobals

  implicit none

  include 'resource.fd'

  type (dialog) dlg
  integer id, callbacktype

  integer pos, status
  type (dialog) modaldlg
  logical lstatus

  if (callbacktype == dlg_clicked) then
		! Set the value of the thermometer to match the controls
		status = dlgget(dlg, IDC_SPIN1, pos)
		status = dlgset(dlg_thermometer, IDC_PROGRESS1, pos)
		! If the temp is 212, display a modal box
		if (pos .eq. 212) then
			lstatus = DlgInit(IDD_MODALDIALOG, modaldlg)
			status = DlgModal(modaldlg)
			call DlgUninit(modaldlg)
		endif
  endif

  END SUBROUTINE ThermApply

!****************************************************************************
!
!  FUNCTION: ThermSpin ( dlg, id, callbacktype )
!
!  PURPOSE:  Dialog box callback for the Spin control
!
!  COMMENTS:
!
!****************************************************************************

SUBROUTINE ThermSpin( dlg, id, callbacktype )
!DEC$ ATTRIBUTES DEFAULT :: ThermSpin

  use dflogm

  implicit none

  include 'resource.fd'

  type (dialog) dlg
  integer id, callbacktype
  logical*4 status
  integer pos
  character*3 textpos

  if (callbacktype == dlg_change) then
		! Set the values of other controls to match the change
		status = dlgget(dlg, id, pos)
		write(textpos, "(I3)") pos
		status = dlgset(dlg, IDC_CURRENTVALUE, textpos)
		status = dlgset(dlg, IDC_SLIDER1, pos)
		status = dlgset(dlg, IDC_SCROLLBAR1, pos)
  endif

  END SUBROUTINE ThermSpin


!****************************************************************************
!
!  FUNCTION: ThermSlider ( dlg, id, callbacktype )
!
!  PURPOSE:  Dialog box callback for Slider Bar
!
!  COMMENTS:
!
!****************************************************************************

SUBROUTINE ThermSlider( dlg, id, callbacktype )
!DEC$ ATTRIBUTES DEFAULT :: ThermSlider

  use dflogm

  implicit none

  include 'resource.fd'

  type (dialog) dlg
  integer id, callbacktype
  logical*4 status
  integer pos
  character*3 textpos

  if (callbacktype == dlg_change) then
		! Set the values of other controls to match the change
		status = dlgget(dlg, id, pos)
		write(textpos, "(I3)") pos
		status = dlgset(dlg, IDC_CURRENTVALUE, textpos)
		status = dlgset(dlg, IDC_SPIN1, pos)
		status = dlgset(dlg, IDC_SCROLLBAR1, pos)
  endif

  END SUBROUTINE ThermSlider


!****************************************************************************
!
!  FUNCTION: ThermScroll ( dlg, id, callbacktype )
!
!  PURPOSE:  Dialog box callback for Scroll Bar
!
!  COMMENTS:
!
!****************************************************************************

SUBROUTINE ThermScroll( dlg, id, callbacktype )
!DEC$ ATTRIBUTES DEFAULT :: ThermScroll

  use dflogm

  implicit none

  include 'resource.fd'

  type (dialog) dlg
  integer id, callbacktype
  logical*4 status
  integer pos
  character*3 textpos

  if (callbacktype == dlg_change) then
		! Set the values of other controls to match the change
		status = dlgget(dlg, id, pos)
		write(textpos, "(I3)") pos
		status = dlgset(dlg, IDC_CURRENTVALUE, textpos)
		status = dlgset(dlg, IDC_SLIDER1, pos)
		status = dlgset(dlg, IDC_SPIN1, pos)
  endif

  END SUBROUTINE ThermScroll



!****************************************************************************
!
!  FUNCTION: ThermEdit ( dlg, id, callbacktype )
!
!  PURPOSE:  Dialog box callback for Edit box
!
!  COMMENTS:
!
!****************************************************************************

SUBROUTINE ThermEdit( dlg, id, callbacktype )
!DEC$ ATTRIBUTES DEFAULT :: ThermEdit

  use dflogm

  implicit none

  include 'resource.fd'

  type (dialog) dlg
  integer id, callbacktype
  logical*4 status
  integer pos
  character*3 textpos

  if (callbacktype == dlg_losefocus) then
		! Set the values of other controls to match the change
		status = dlgget(dlg, id, textpos)
		read(textpos, "(I3)") pos
		status = dlgset(dlg, IDC_CURRENTVALUE, textpos)
		status = dlgset(dlg, IDC_SLIDER1, pos)
		status = dlgset(dlg, IDC_SPIN1, pos)
		status = dlgset(dlg, IDC_SCROLLBAR1, pos)
  endif

  END SUBROUTINE ThermEdit


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

SUBROUTINE ThermometerSub( dlg, id, callbacktype )
!DEC$ ATTRIBUTES DEFAULT :: ThermometerSub

  use dfwin
  use dflogm

  implicit none

  include 'resource.fd'

  type (dialog) dlg
  integer id, callbacktype

  integer*4			    cref
  logical*4				lret

  if (callbacktype == dlg_init) then
	! Change the color of the Progress bar to red
	! NOTE:  The following message succeeds only if Internet Explorer 4.0
	!        or later is installed
	cref = #FF		! Red
    lret = DlgSendCtrlMessage(dlg, IDC_PROGRESS1, PBM_SETBARCOLOR, 0, cref)
  endif

  END SUBROUTINE ThermometerSub
