コンソールからWindowを開く。

コンソールアプリから、Windowを開きます。
一般的には、メインルーチンでWinMainをCALLすればよいだけです。引数の多くはほぼ意味を持ちません。

□コマンドライン引数を渡さないような最小形式のメインプログラムは以下のようになります。

=====================================================================
PROGRAM doswin
USE subs
IMPLICIT NONE
INTEGER (HANDLE)   :: hDOS, hInstance, hPrevInstance
INTEGER (LPSTR)    :: lpszCmdLine
INTEGER (SINT)     :: nCmdShow
INTEGER (KIND = 4) :: iret
iret = WinMain( Z'4000', NULL, NULL, SW_SHOWNORMAL ) ! hInstance is always 4000h in 32bit windows
STOP
END PROGRAM doswin
=====================================================================

□コマンドライン引数や定数などを正規の手続きで得て引数として渡す場合。

出力例

MODULE win
USE ifwinty
IMPLICIT NONE
CONTAINS
!-----------------------------------------------------
INTEGER (KIND = 4) FUNCTION WinMain( hInstance, hPrevInstance, lpszCmdLine, nCmdShow)
USE user32
USE ifwinty
IMPLICIT NONE
INTEGER (HANDLE), INTENT(IN) :: hInstance, hPrevInstance 
INTEGER (LPSTR) , INTENT(IN) :: lpszCmdLine
INTEGER (SINT)  , INTENT(IN) :: nCmdShow

! Variables
TYPE (T_WNDCLASS) :: wc
TYPE (T_MSG)      :: mesg
INTEGER (HANDLE)  :: hWndMain
INTEGER (BOOL)    :: iretb
CHARACTER (LEN = 256) :: ClassName

ClassName = "Fortran"C
!  Init   Main window
WinMain = -1 ! Error code 
wc%lpszClassName = LOC(ClassName)
wc%lpfnWndProc   = LOC(MainWndProc)               ! CALLBACK procedure name
wc%style         = IOR(CS_VREDRAW , CS_HREDRAW)
wc%hInstance     = hInstance
wc%hIcon         = NULL   
wc%hCursor       = LoadCursor( NULL, IDC_ARROW )
wc%hbrBackground = ( COLOR_WINDOW + 1 )
IF (RegisterClass(wc) == 0) RETURN

!Init instance
WinMain = -2 ! Error code 
hWndMain = CreateWindowEx(  0, ClassName,              &
                     "FORTRAN DOS Window"C,            &
                     INT(WS_OVERLAPPEDWINDOW),         &
                     CW_USEDEFAULT, CW_USEDEFAULT,     &
                     CW_USEDEFAULT, CW_USEDEFAULT,     &
                     0,                                &
                     0,                                &
                  NULL,                                &
                  NULL                                 )
IF (hWndMain == 0) RETURN
iretb = ShowWindow( hWndMain, nCmdShow )
iretb = UpdateWindow( hWndMain )

! Message Loop : Main Loop
DO WHILE ( GetMessage (mesg, NULL, 0, 0) ) 
 iretb = TranslateMessage( mesg )
 iretb = DispatchMessage( mesg )
END DO

WinMain = mesg%wParam
RETURN
END FUNCTION WinMain
!----------------------------------------------------------
INTEGER (LRESULT) FUNCTION MainWndProc( hWnd, mesg, wParam, lParam )
!DEC$ ATTRIBUTES STDCALL, DECORATE, ALIAS : 'MainWndProc' :: MainWndProc
USE user32
USE gdi32
IMPLICIT NONE
INTEGER (HANDLE) , INTENT(IN) :: hWnd
INTEGER (UINT)   , INTENT(IN) :: mesg
INTEGER (fwParam), INTENT(IN) :: wParam
INTEGER (flParam), INTENT(IN) :: lParam
!
MainWndProc = 0
SELECT CASE ( mesg )
   CASE (WM_CREATE)
     
   CASE (WM_DESTROY)
     CALL PostQuitMessage( 0 )
   CASE (WM_LBUTTONDOWN)
     WRITE(*, *) 'LBUTTONDOWN'
   CASE (WM_RBUTTONDOWN)
     WRITE(*, *) 'RBUTTONDOWN'
   CASE DEFAULT
     MainWndProc = DefWindowProc( hWnd, mesg, wParam, lParam )
END SELECT 
RETURN
END FUNCTION MainWndProc
!---------------------------------------------------------------------------
END MODULE win
!===========================================================================
MODULE subs
USE win
CONTAINS
!---------------------------------------------------------------------------
INTEGER (HANDLE) FUNCTION get_dos_handle()
IMPLICIT NONE
 INTERFACE
 FUNCTION GetConsoleWindow() ! not exist in INTEL Fortran
 USE ifwinty
 INTEGER (HANDLE) :: GetConsoleWindow
 !DEC$ ATTRIBUTES DEFAULT, STDCALL, DECORATE, ALIAS:'GetConsoleWindow' :: GetConsoleWindow
 END FUNCTION
 END INTERFACE
 get_dos_handle = GetConsoleWindow()
RETURN
END FUNCTION get_dos_handle
!-------------------------------------------------------------------------
INTEGER (HANDLE) FUNCTION get_win_handle()
USE kernel32, ONLY : GetModuleHandle
IMPLICIT NONE
get_win_handle = GetModuleHandle(NULL)
RETURN
END FUNCTION get_win_handle
!--------------------------------------------------------------------------
END MODULE subs
!==========================================================================
PROGRAM doswin
USE subs
IMPLICIT NONE
INTEGER (HANDLE)   :: hDOS, hInstance, hPrevInstance
INTEGER (LPSTR)    :: lpszCmdLine
INTEGER (SINT)     :: nCmdShow
INTEGER (KIND = 4) :: iret
CHARACTER (LEN = 1024) :: text, buff
INTEGER :: i, n, nlen
hDOS      = get_dos_handle()
hInstance = get_win_handle()
n = COMMAND_ARGUMENT_COUNT()              ! Fortran2003
text = ''
DO i = 1, n
 CALL GET_COMMAND_ARGUMENT(i, buff, nlen) ! Fortran2003
 text = TRIM(text) // ' ' // buff(1:nlen) ! Insert a space between args 
END DO
text = TRIM(text(2:)) // ''C              ! delete first space : add NULL (C style)  
print '(2Z10, 2a)', hDOS, hInstance, ':', TRIM(text)
lpszCmdLine = LOC(text)                   ! LOC non-standard : address of text
nCmdShow    = SW_SHOWNORMAL
iret = WinMain( hInstance, hPrevInstance, lpszCmdLine, nCmdShow)
STOP
END PROGRAM doswin