!!---------------------------------------------------------------------------- !! WINDEMO.F90 for LF95 5.60 --- June 2000 !! !! This FORTRAN source file is intended to demonstrate a few of the Win32 !! API calls which can be made from Fortran code compiled with Lahey Fortran 95 !! !! Compile with: lf95 windemo2.f90 WinDemo.rc -win -ml winapi -out WinDemo.exe !!---------------------------------------------------------------------------- ! WINDEMO.F90 Copyright(c) 1994 - 2000, Lahey Computer Systems, Inc. ! Copying for sale requires permission from Lahey Computers Systems. ! Otherwise, distribution of all or part of this file is permitted ! if these four lines are included. ! module constants_module implicit none integer, parameter :: large_int_kind = 4 integer, parameter :: large_real_kind = 8 end module constants_module module windows_module implicit none ! WinAPI funtions dll_import GetModuleHandleA dll_import LoadIconA, LoadCursorA, GetStockObject dll_import GetMessageA, TranslateMessage, DispatchMessageA dll_import PostQuitMessage, DefWindowProcA dll_import RegisterClassA, UnregisterClassA dll_import CreateDialogParamA, DialogBoxParamA, EndDialog dll_import SendDlgItemMessageA, SetWindowTextA dll_import CreateWindowExA, DestroyWindow, ShowWindow dll_import UpdateWindow dll_import MoveWindow integer :: GetModuleHandleA integer :: LoadIconA, LoadCursorA, GetStockObject logical :: GetMessageA integer :: DefWindowProcA integer :: RegisterClassA, UnregisterClassA integer :: CreateDialogParamA, DialogBoxParamA integer :: SendDlgItemMessageA integer :: CreateWindowExA logical :: ShowWindow, UpdateWindow logical :: MoveWindow ! Constants used by WinAPI functions integer, parameter :: TRUE=1 integer, parameter :: FALSE=0 integer:: ModuleHandle integer, PARAMETER :: NULL = 0 integer, parameter :: WM_COMMAND = 273 integer, parameter :: WM_DESTROY = 2 integer, parameter :: WM_INITDIALOG = 272 integer, parameter :: LB_RESETCONTENT = 388 integer, parameter :: WM_SYSCOMMAND = 274 integer, parameter :: SC_CLOSE = 61536 integer, parameter :: IDOK = 1 integer, parameter :: LB_ADDSTRING = 384 integer, parameter :: IDI_APPLICATION = 32512 integer, parameter :: IDC_ARROW = 32512 integer, parameter :: WHITE_BRUSH = 0 integer, parameter :: CW_USEDEFAULT = 32768 integer, parameter :: SW_SHOWMAXIMIZED = 3 integer, parameter :: WS_MINIMIZEBOX = 131072 integer, parameter :: WS_MAXIMIZEBOX = 65536 integer, parameter :: WS_CAPTION = 12582912 ! WS_BORDER | WS_DLGFRAME integer, parameter :: WS_SYSMENU = 524288 integer, parameter :: WS_THICKFRAME = 262144 integer, parameter :: WS_OVERLAPPED = 0 integer, parameter :: WS_OVERLAPPEDWINDOW = ior(WS_OVERLAPPED, & ior(WS_CAPTION, ior(WS_SYSMENU, ior(WS_THICKFRAME, & ior(WS_MINIMIZEBOX, WS_MAXIMIZEBOX))))) ! These parameters must match #defines in windemo.rc integer, parameter :: IDM_QUIT=101 integer, parameter :: IDM_FACTORIAL=110 integer, parameter :: IDM_ABOUT=200 integer, parameter :: IDC_LIST1=1001 type WNDCLASS sequence integer :: style integer :: lpfnWndProc integer :: cbClsExtra integer :: cbWndExtra integer :: hInstance integer :: hIcon integer :: hCursor integer :: hbrBackground integer :: lpszMenuName integer :: lpszClassName end type WNDCLASS type MSG sequence integer, dimension(6):: msgdata end type MSG contains integer function WndProc(hwndByValue, messageByValue, & & wParamByValue, lParamByValue) implicit none integer :: hwnd, message, wParam, lParam, & & hwndByValue, messageByValue, wParamByValue, lParamByvalue integer :: result hwnd=offset(hwndByValue) message=offset(messageByValue) wParam=offset(wParamByValue) lParam=offset(lParamByValue) WndProc=0 select case(message) case (WM_COMMAND) select case(wParam) case (IDM_QUIT) call DestroyWindow(carg(hwnd)) case (IDM_ABOUT) result=DialogBoxParamA( & & carg(ModuleHandle), & & carg("AboutBox"), & & carg(hwnd), & & ModalDlgProc, & & carg(wParam)) case default result=DialogBoxParamA( & & carg(ModuleHandle), & & carg("Results"), & & carg(hwnd), & & ModalDlgProc, & & carg(wParam)) end select case (WM_DESTROY) call PostQuitMessage(carg(0)) case default WndProc=DefWindowProcA(carg(hwnd), carg(message), & & carg(wParam), carg(lParam)) end select return end function WndProc integer function ModalDlgProc(hwndByValue, messageByValue, & & wParamByValue, lParamByValue) implicit none integer :: hwnd, message, wParam, lParam, & & hwndByValue, messageByValue, wParamByValue, lParamByvalue integer :: result hwnd=offset(hwndByValue) message=offset(messageByValue) wParam=offset(wParamByValue) lParam=offset(lParamByValue) ModalDlgProc = FALSE select case(message) case (WM_INITDIALOG) select case (lParam) case (IDM_FACTORIAL) result = SendDlgItemMessageA(carg(hwnd), & & carg(IDC_LIST1), & & carg(LB_RESETCONTENT), & & carg(0), & & carg(0) ) call factorial_demo(hwnd) end select ModalDlgProc = TRUE case (WM_SYSCOMMAND) if (wParam.eq.SC_CLOSE) then call EndDialog(carg(hwnd), carg(TRUE)) ModalDlgProc = TRUE endif case (WM_COMMAND) if (wParam.eq.IDOK) then call EndDialog(carg(hwnd), carg(TRUE)) ModalDlgProc = TRUE endif end select end function ModalDlgProc subroutine print(hwnd, string) implicit none integer :: hwnd character (len=*):: string integer :: result result=SendDlgItemMessageA(carg(hwnd), & & carg(IDC_LIST1), & & carg(LB_ADDSTRING), & & carg(0), & & carg(string) & & ) return end subroutine print end module windows_module program lahey_windows_demo use windows_module implicit none integer :: result character(len=9) :: szMenuName = "DemoMenu" // char(0) character(len=11):: szClassName = "DemoClass" // char(0) character(len=30):: szWindowName = "Lahey Fortran 90 Windows Demo"& & // char(0) type(WNDCLASS) :: wc type(MSG) :: message integer :: hwnd logical :: flag ModuleHandle=GetModuleHandleA(carg(NULL)) wc%style = 0 wc%lpfnWndProc = offset(WndProc) wc%cbClsExtra = 0 wc%cbWndExtra = 0 wc%hInstance = ModuleHandle wc%hIcon = LoadIconA(carg(NULL), carg(IDI_APPLICATION)) wc%hCursor = LoadCursorA(carg(NULL), carg(IDC_ARROW)) wc%hbrBackGround = GetStockObject(carg(WHITE_BRUSH)) wc%lpszMenuName = offset(szMenuName) wc%lpszClassName = offset(szClassName) result = RegisterClassA(wc) hwnd=CreateWindowExA(carg(NULL), carg(szClassName), & & carg(szWindowName), & & carg(WS_OVERLAPPEDWINDOW), & & carg(CW_USEDEFAULT), carg(CW_USEDEFAULT), & & carg(CW_USEDEFAULT), carg(CW_USEDEFAULT), & & carg(NULL), CARG(NULL), CARG(ModuleHandle), & & carg(NULL)) flag=ShowWindow(carg(hwnd), carg(SW_SHOWMAXIMIZED)) flag=UpdateWindow(carg(hwnd)) do while (GetMessageA(message, carg(NULL), carg(0), carg(0))) call TranslateMessage(message) call DispatchMessageA(message) enddo result = UnregisterClassA(carg(szClassName), carg(ModuleHandle)) stop end program lahey_windows_demo subroutine factorial_demo(hwnd) use windows_module use constants_module implicit none integer, intent(in) :: hwnd integer(kind=large_int_kind) :: i,f integer(kind=large_int_kind),external :: factorial character(len=80):: string call SetWindowTextA(carg(hwnd),carg("Factorials...")) call print(hwnd, & & " This routine calculates and prints out the") call print(hwnd, & & " factorials of the integers from 1 through 12.") call print(hwnd, " ") do i=1, 12 f = factorial(i) write (string,"(' n = ',I2.1, & & ' factorial(n) = ',I9.1)") i,f call print(hwnd,string) end do return end subroutine factorial_demo recursive function factorial(n) result(factresult) use windows_module use constants_module implicit none integer(kind=large_int_kind) :: factresult integer(kind=large_int_kind), intent(in) :: n if (n .eq. 1) then factresult = 1 else factresult = n * factorial(n - 1) end if return end function factorial