! This software DLLPRGRS.f90 is part of the 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 using the Visual Fortran Dialog Procedures
! in a DLL.  The public routines in the DLL can be called to:
!  o  DisplayProgressBox - Display a dialog box containing a progress bar 
!  o  SetProgress - Set the current progress bar value
!  o  DestroyProgressBox - Destroy the dialog box
! Two examples projects, CallCon and CallDlg, are provided that call the
! public routines in this DLL.
!

!
!  M O D U L E S
!

!  Module containing definitions used in the public interfaces

module ProgressBoxTypes
  
  use dflogm

  !  Global variables
  integer ghinst

  !  PBContext type used in calls
  type :: PBContext
    sequence 
    type (dialog), pointer :: PBDlg
    integer                   hwndParent
    logical                   bCancelButton
    integer                   iProgress
    logical                   bEnableParent
    logical                   bCancelled
  end type

  !  Status return values 
  integer, parameter, public :: PBStatus_OK         = 1
  integer, parameter, public :: PBStatus_Failed     = -1
  integer, parameter, public :: PBStatus_Aborted    = -2

end module

!  Module containing the public interfaces

module ProgressBox
  use ProgressBoxTypes

  interface
    integer function DisplayProgressBox(    &
                    context,            &
                    hwndParent,         &
                    title,              &
                    bCancelButton ) 
    !DEC$ ATTRIBUTES DLLEXPORT::DisplayProgressBox
        use ProgressBoxTypes
      ! Arguments
        type(PBContext) context
        integer hwndParent
        character*(*) title
        logical bCancelButton
    end function
    integer function SetProgress ( context, value )
    !DEC$ ATTRIBUTES DLLEXPORT::SetProgress
        use ProgressBoxTypes
      ! Arguments
        type(PBContext) context
        integer value
    end function
    integer function DestroyProgressBox( context )
    !DEC$ ATTRIBUTES DLLEXPORT::DestroyProgressBox
        use ProgressBoxTypes
      ! Arguments
        type(PBContext) context
    end function
  end interface

end module


!
!  P U B L I C   R O U T I N E S
!

!****************************************************************************
!
!  FUNCTION: DisplayProgressBox ( context, hwndParent, title, bCancelButton ) 
!
!  PURPOSE:  This routine must be called first.  It creates and displays
!            the progress dialog box.  If a parent window handle is
!            provided, it becomes the parent of the progress dialog box.
!            This routine also disables the parent window for the duration
!            of progress dialog box.  This makes the progress dialog box
!            act as if it were modal, even though we use DlgModeless to 
!            display the box.  If bCancelButton is .TRUE., the dialog box
!            contains a Cancel button that the user can select to cancel
!            the operation. 
!
!****************************************************************************

integer function DisplayProgressBox(    &
                    context,            &
                    hwndParent,         &
                    title,              &
                    bCancelButton ) 
  !DEC$ ATTRIBUTES DLLEXPORT::DisplayProgressBox
    use ProgressBoxTypes
    use user32

    implicit none

  ! Arguments
    type(PBContext) context
    integer hwndParent
    character*(*) title
    logical bCancelButton

  ! Variables
	include 'resource.fd'
    external PBDlgSub
    external CancelSub
    logical lret
    integer hwnd

  ! Body of DisplayProgressBox

    DisplayProgressBox = PBStatus_OK

  ! Initialize the context structure
    allocate( context % PBDlg )
    context % bCancelButton = bCancelButton
    context % hwndParent = hwndParent
    context % bCancelled = .FALSE.
    context % iProgress = 0

  ! Initialize the progress dialog box
    lret = DlgInitWithResourceHandle( IDD_PROGRESS_DIALOG, ghinst, context % PBDlg )
    if ( .not. lret ) then
        DisplayProgressBox = PBStatus_Failed
        return 
    end if
    CALL DLGSETTITLE( context % PBDlg, title )
    lret = DlgSetSub( context % PBDlg, IDD_PROGRESS_DIALOG, PBDlgSub)
    if ( .not. lret ) then
        DisplayProgressBox = PBStatus_Failed
        return 
    end if
    lret = DlgSetSub( context % PBDlg, IDCANCEL, CancelSub)
    if ( .not. lret ) then
        DisplayProgressBox = PBStatus_Failed
        return 
    end if

  !  Disable the parent window
	context % bEnableParent = .FALSE.
	if ( hwndParent .ne. 0 ) then
        lret = IsWindowEnabled( hwndParent )
        if ( lret ) then
		    lret = EnableWindow( hwndParent, .FALSE. )
    	    context % bEnableParent = .TRUE.
        end if
    end if

  !  Display the progress dialog box
    lret = DlgModeless( context % PBDlg, SW_SHOWNORMAL, hwndParent)
    if ( .not. lret ) then
        DisplayProgressBox = PBStatus_Failed
        return 
    end if

  !  Display the Cancel button if the caller requested it
    if ( bCancelButton ) then
	    hwnd = GetDlgItem( context % PBDlg % hwnd, IDCANCEL )
        lret = ShowWindow( hwnd, SW_SHOWNA )
    end if

  !  Save the address of the context block as a property of the window
  !  We will retrieve it from there in our callbacks
    lret = SetProp( context % PBDlg % hwnd, "PBContext", %loc(context) )

end function DisplayProgressBox

!****************************************************************************
!
!  FUNCTION: SetProgress ( context, value ) 
!
!  PURPOSE:  This routine is called to update the value of the progress
!            bar.  This routine should be called frequently in order to
!            keep the user interface responsive.  This routine has it
!            own Windows message loop that processes all of the messages
!            currently in the queue.  If the user has pressed the Cancel
!            button, this routine returns PBStatus_Aborted.
!
!****************************************************************************

integer function SetProgress ( context, value )
  !DEC$ ATTRIBUTES DLLEXPORT::SetProgress
    use ProgressBoxTypes
    use dfwinty
    use user32

    implicit none

  ! Arguments
    type(PBContext) context
    integer value

  ! Variables
	include 'resource.fd'
	type (T_MSG) mesg
    logical lret
    logical lNotQuit
    integer iret

  ! Body of SetProgress
    SetProgress = PBStatus_OK

  ! Set the value of the Progress Bar
    lret = DlgSet( context % PBDlg, IDC_PROGRESS1, value )
    context % iProgress = value

  ! Dispatch all pending window messages
	lNotQuit = .true.
	do while ( lNotQuit .and. (PeekMessage(mesg, 0, 0, 0, PM_NOREMOVE) .ne. 0) )

		lNotQuit = GetMessage(mesg, NULL, 0, 0)
		if (lNotQuit) then
			if ( DlgIsDlgMessage(mesg) .EQV. .FALSE. ) then
			   lret = TranslateMessage( mesg )
			   iret = DispatchMessage( mesg )
			end if
        end if
 
      ! Check to see if the user pressed the Cancel button
        if ( context % bCancelled ) then
            context % bCancelled = .FALSE.      ! Reset
            SetProgress = PBStatus_Aborted
            return
        end if

	end do

end function SetProgress

!****************************************************************************
!
!  FUNCTION: DestroyProgressBox ( context ) 
!
!  PURPOSE:  This routine must be called last.  It destroys
!            the progress dialog box.  If a parent window handle was
!            provided, it re-enables the parent window.
!
!****************************************************************************

integer function DestroyProgressBox( context )
  !DEC$ ATTRIBUTES DLLEXPORT::DestroyProgressBox
    use ProgressBoxTypes
    use user32

    implicit none

  ! Arguments
    type(PBContext) context

  ! Variables
    logical lret

  ! Body of DestroyProgressBox

    DestroyProgressBox = PBStatus_OK

  ! Enable the parent window
	if ( context % bEnableParent ) then
	    lret = EnableWindow( context % hwndParent, .TRUE. )
    end if

  ! Free the dialog structure
    call DlgExit( context % PBDlg )
    call DlgUninit( context % PBDlg )
    deallocate( context % PBDlg )

end function DestroyProgressBox

!********************************************************************
!   FUNCTION: DllMain(HANDLE, DWORD, LPVOID)
!
!   PURPOSE:  DllMain is called by Windows when
!     the DLL is initialized, Thread Attached, and other times.
!     Refer to SDK documentation, as to the different ways this
!     may be called.
!
!     The DllMain function should perform additional initialization
!     tasks required by the DLL.  DllMain should return a value of 1
!     if the initialization is successful.
!
!*********************************************************************

integer(4) function DllMain (hInst, ul_reason_being_called, lpReserved)
!DEC$ IF DEFINED(_X86_)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_DllMain@12' :: DllMain
!DEC$ ELSE
!DEC$ ATTRIBUTES STDCALL, ALIAS : 'DllMain' :: DllMain
!DEC$ ENDIF
    use ProgressBox

    implicit none

  ! Arguments
    integer(4) hInst
    integer(4) ul_reason_being_called
    integer(4) lpReserved

  !  Save the module instance handle in a global variable
    ghinst =  hInst
  !  Return 1 to indicate success
    DllMain = 1
    return

end function DllMain

!
!  P R I V A T E   R O U T I N E S
!

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

subroutine PBDlgSub( dlg, id, callbacktype )
!DEC$ ATTRIBUTES DEFAULT :: PBDlgSub

    use ProgressBox
    use user32

    implicit none

    ! Arguments
    type (dialog) dlg
    integer id, callbacktype

    ! Variables
    type(PBContext) context
    pointer ( pc, context )
    integer iret

    if (callbacktype == dlg_destroy) then
        !  Remove the window property
        pc = GetProp( dlg % hwnd, "PBContext" )
        iret = RemoveProp( context % PBDlg % hwnd, "PBContext" )
    endif

end subroutine PBDlgSub

!****************************************************************************
!
!  FUNCTION: CancelSub ( dlg, id, callbacktype )
!
!  PURPOSE:  Callback for the Cancel button
!
!****************************************************************************

subroutine CancelSub( dlg, id, callbacktype )
!DEC$ ATTRIBUTES DEFAULT :: CancelSub

    use ProgressBox
    use user32

    implicit none

  ! Arguments
    type (dialog) dlg
    integer id, callbacktype

  ! Variables
    type(PBContext) context
    pointer ( pc, context )
    integer iret

  ! Set the bCancelled flag in the context block.  
  ! SetProgress checks this flag and returns PBStatus_Aborted
    if (callbacktype == dlg_clicked) then
        !  Get the "context" window property
        pc = GetProp( dlg % hwnd, "PBContext" )
        context % bCancelled = .TRUE.
    endif

end subroutine CancelSub
