! This program demonstrates a number of programming idioms for use
!   with DIGITAL Visual Fortran.  They are as follows:
!
! *Menu Driven Feature
!   There are two menu items that control this QuickWin program.
!
!   After initialization, the main program goes to sleep.
!   If you click on the menu item Start Work, a simulated computation 
!   (the Work Task) is performed in a separate thread.
!	If you click on the menu item Stop Work, this thread is terminated.
!
! *Getting Control on Exit from QuickWin Programs
!
!   To replace the built-in "exit" controls from the basic QuickWin
!     program with your own EXIT procedure, you must take several steps:
!   
!   1) Eliminate the File/Exit menu item
!
!   Delete the Exit/Crtl-C menu item with
!
!   ires = deletemenuqq(1,3)
!
!   and then substitute your own menu item routine to perform
!   the exit function.  
!
!   2) Eliminate the System/Close menu item
!
!   Use the following code for this.
! 
!       hmenu = getsystemmenu(hframe,.false.)
!       status = deletemenu(hmenu, SC_CLOSE, MF_BYCOMMAND) !close
!       status = deletemenu(hmenu, 5, MF_BYPOSITION) !and seperator bar
!
!   3) Get Rid of Alt+F4
!
!   Must set a windows hook procedure to discard
!   WM_SYSCOMMAND/SC_CLOSE messages.  See the code for details.
!
! *Use of status bar to indicate program progress
!
!   This program uses the QuickWin status bar and asterisks to indicate
!    progress towards completion of the Work Task.
!
    Program MenuDriven
	 use dflib
	 use dfwin
	 integer(4) status, hframe, hmenu
	 external UserExit, StartWorkProc, StopWorkProc
     integer*4 hookhandle, primarythreadid,isrunning, stoprun
	 common hookhandle, primarythreadid, isrunning, stoprun
!set up name for our hook routine 
     interface
      integer*4 function CBTProc(nCode, wParam, lParam) 
	!DEC$ IF DEFINED (_X86_)
	    !DEC$ ATTRIBUTES STDCALL, ALIAS: '_CBTProc@12' :: CBTProc
	    !DEC$ else
	    !DEC$ ATTRIBUTES STDCALL, ALIAS: '_CBTProc' :: CBTProc
	    !DEC$ endif 
	    integer*4 nCode           ! hook code 
	    integer*4 wParam          ! removal flag 
	    integer*4 lParam          ! address of structure with message
      end function
	 end interface

     open(10,file='user')

! Step 1
!   get rid of File/Exit menu item
     ires = deletemenuqq(1,3)

!   and put in our own exit handler
!   and start and stop handlers
! 
	 status = appendmenuqq(1,$MENUSEPARATOR, ''C, NUL)
	 status = appendmenuqq(1,$MENUENABLED,'&StartWork'C,StartWorkProc)
	 status = appendmenuqq(1,$MENUENABLED,'&StopWork'C,StopWorkProc)
	 status = appendmenuqq(1,$MENUSEPARATOR, ''C, NUL)
	 status = appendmenuqq(1,$MENUENABLED,'UserE&xit'C,UserExit)
	

! Step 2
!      remove the close item from the framewindow 
!      system menu.
     hframe = gethwndqq(QWIN$FRAMEWINDOW)
	 hmenu = getsystemmenu(hframe,.false.)
	 status = deletemenu(hmenu, SC_CLOSE, MF_BYCOMMAND) !remove close
	 status = deletemenu(hmenu, 5, MF_BYPOSITION) !and seperator bar
	

! Step 3
!   Get Rid of Alt+F4 by setting a windows hook to trap it.
	 hookhandle = SetWindowsHookEX(WH_CBT,& 
          loc(CBTProc), 0, primarythreadid)                        
     if(hookhandle .eq. 0) then
     write(10,*) 'ERROR: could not set hook'
     stop 
     endif

     status = setexitqq(QWIN$EXITNOPERSIST)

     write(10,*) 'Initialization Stage Complete - Use File/StartWork to start work thread'

  10 continue 
     call sleepqq(5000) ! Sleep for 5 seconds
	 goto 10            ! and spin away
     end


     Subroutine UserExit(item_checked)
	 use dflib
     use dfwin
     integer*4 hookhandle, primarythreadid,isrunning, stoprun
	 common hookhandle, primarythreadid, isrunning, stoprun
	 logical item_checked
     integer i
     i = messageboxqq('Press OK to Exit'C,'Confirm Exit'C,&
		  MB$OKCANCEL+MB$DEFBUTTON2)
     if(i.eq.MB$IDOK) then
       if(isrunning.ne.0) then
	   !probably want to warn user here
       call StopWorkProc(i)  
       endif
	! free hook resources before quitting
       status = UnhookWindowsHookEx(hookhandle)
	   stop
	   return
	 endif
	 end  

     Subroutine StartWorkProc(item_checked)
	 use dflib
     use dfmt
	 external WorkProc
     integer*4 hookhandle, primarythreadid,isrunning, stoprun
	 common hookhandle, primarythreadid, isrunning, stoprun
	 logical item_checked
     integer i
     if(isrunning.ne.0) then
       i = messageboxqq('Already Running'C,'Ok'C,&
		    MB$OK+MB$DEFBUTTON2)
       if(i.eq.MB$IDOK) then
	 !return always
	 return
       else
	     return
       endif
	 else
	   stoprun = 0
       isrunning = 1
       ThreadHandle = CreateThread(0,0,WorkProc,%val(i), &
		      CREATE_SUSPENDED, j )
       retlog = SetThreadPriority(ThreadHandle, THREAD_PRIORITY_BELOW_NORMAL )
       retint = ResumeThread(ThreadHandle)
     endif
     return
	 
	 end  

     Subroutine StopWorkProc(item_checked)
	 use dflib
     use dfwin
     integer*4 hookhandle, primarythreadid,isrunning, stoprun
	 common hookhandle, primarythreadid, isrunning, stoprun
	 logical item_checked
     integer i

     stoprun = 1
       
     return
	 end  


     integer(4) function WorkProc( dumarg)
      USE DFLIB
	  USE DFMT

	  integer(4) dumarg, i, retint, hwn
      LOGICAL retlog
	  CHARACTER(50) prog
      integer*4 hookhandle, primarythreadid,isrunning, stoprun
      common hookhandle, primarythreadid, isrunning, stoprun

! internal QuickWin routine to set status bar at screen bottom
      interface 
       integer*4 function setstatusbar(msg)
	!DEC$ IF DEFINED (_X86_)
    !dec$ attributes C, alias: "__QWINTSetStatusBar" :: setstatusbar
	!DEC$ else
    !dec$ attributes C, alias: "_QWINTSetStatusBar" :: setstatusbar
	!DEC$ endif 
       integer msg ! to hold address of string
       end function setstatusbar
      end interface

      do i = 1,49
	  prog(i:i) =" "
	  enddo
      prog(50:50) = CHAR(0) ! null terminate
   
      write(10,*) 'Starting Work'
! show progress
	  do i = 1,30
      call sleepqq(500) ! sleep a half a second
      prog(i:i) ="*"
      retint = setstatusbar(%loc(prog))
      if(stoprun.ne.0) then
	    write(10,*) "Aborting Work"
		goto 999
      endif
	  enddo

 999  isrunning = 0 ! indicate completion
      stoprun = 0
      WorkProc = 0
      retint = setstatusbar(0) !free any string storage
      write(10,*) 'Stopping Work'

      call ExitThread(0)
    end function


    integer*4 function CBTProc(nCode, wParam, lParam) 
	use dflib
	use dfwin

	!DEC$ IF DEFINED (_X86_)
	!DEC$ ATTRIBUTES STDCALL, ALIAS: '_CBTProc@12' :: CBTProc
	!DEC$ else
	!DEC$ ATTRIBUTES STDCALL, ALIAS: '_CBTProc' :: CBTProc
	!DEC$ endif 

	integer*4 nCode           ! hook code 
	integer*4 wParam          ! SC_????? submessage
	integer*4 lParam          ! NA for our purposes

    integer*4 hookhandle, primarythreadid,isrunning, stoprun
    common hookhandle, primarythreadid, isrunning, stoprun
 
    if((nCode.eq.HCBT_SYSCOMMAND).and.(wParam.eq.SC_CLOSE)) then
     CBTProc = 1 ! we have processed the message so discard it. 
	 return
	endif
    
   !with more than one hook procedure need to call CallNextHookEx.
   !with just one,  CBTProc = 0 works just fine
   !CBTProc = CallNextHookEx(hookhandle, nCode, wParam, lParam)

    CBTProc = 0 ! we did nothing so continue processing the message   
    return
    end function CBTProc

    logical*4 function initialsettings()
    use dfwin
    integer*4 hookhandle, primarythreadid,isrunning, stoprun
    common hookhandle, primarythreadid, isrunning, stoprun
    !we must use this tricky way to get the thread id
    !of the primary thread that handles the windows
    !messages.
    primarythreadid = GetCurrentThreadId()
    initialsettings = .true.
    end