Intel Fortran 调用API函数创建窗体，同时创建控制台输出（

mdl9966 · 发表于 2016-11-5 15:48:55

看到论坛有人写过窗体绘制云图，利用控制台输出，这里利用windows API 实现该功能
源码如下

[Fortran] 纯文本查看 复制代码

function WinMain (hCurrentInst, hPreviousInst, lpszCmdLine, nCmdShow)
    !DEC$ ATTRIBUTES STDCALL,DECORATE,ALIAS:"WinMain" :: WinMain
    use Windows_MDL9966
    implicit none

    integer(SINT) :: WinMain
    integer(HANDLE), intent(IN) :: hCurrentInst, hPreviousInst
    integer(LPCSTR), intent(IN) :: lpszCmdLine
    integer(SINT), intent(IN) :: nCmdShow

    integer(HANDLE) :: hWnd ! Window
    integer(HANDLE) :: hInstance
    integer(SINT) :: ret,retclass
    integer(BOOL) :: bret,AllocConsole_ret
    type(T_MSG) :: msg      ! Message
    type(T_WNDCLASSEX)::wndclass
    character(len=*), parameter :: szClassName = "Windows"C
    
    AllocConsole_ret=AllocConsole()！
    ! 创建控制台在这里
    if(AllocConsole_ret/=0) print *,'创建控制台成功'

hInstance = GetModuleHandle(NULL)
    wndclass.cbSize = sizeof(wndclass)
    wndclass.style = CS_OWNDC
    wndclass.lpfnWndProc = loc(WindowProc)
    wndclass.cbClsExtra = 0
    wndclass.cbWndExtra = 0
    wndclass.hInstance = hInstance
    wndclass.hIcon = LoadIcon(0_HANDLE, int(IDI_WINLOGO,LPVOID))
    wndclass.hCursor = LoadCursor(0_HANDLE, int(IDC_ARROW,LPVOID))
    wndclass.hbrBackground = (COLOR_WINDOW + 1) !NULL
    wndclass.lpszMenuName = NULL
    wndclass.lpszClassName = loc(szClassName)
    wndclass.hIconSm = NULL

    retclass = RegisterClassEx(wndclass)
    
    if(retclass/=0) print *,'RegisterClass成功'

    WinMain = 0
    hWnd = CreateWindowEx(0,&
    szClassName, &
    'hello' // CHAR(0), &
    WS_OVERLAPPEDWINDOW, 200,0,400,400,&
    NULL,&
    NULL,&
    hInstance,&
    null&
    )
    if (hwnd == NULL) return

    bret = ShowWindow(hWND, SW_SHOW)
    bret = UpdateWindow(hWnd)

    mainloop: do while (Isrun)！
        if (PeekMessage(msg, hWnd, 0, 0, PM_REMOVE) /= 0) then
            if (msg%message == WM_QUIT) exit mainloop
            bret = TranslateMessage(msg)
            bret = DispatchMessage(msg)
        end if
        call sleep(10) ! sleep for 10ms
    end do mainloop

    return

    end function WinMain

回调函数

[Fortran] 纯文本查看 复制代码

    module Windows_MDL9966

    use IFWINA ! Alternate version of ifwin that renames MSFWIN$ routines that conflict with QuickWin
    use, intrinsic :: ISO_C_BINDING
    
    logical :: Isrun = .TRUE. 
    
    contains
    integer(LONG) function WindowProc (hWnd, uMsg, wParam, lParam)
    use IFWINA ! Alternate version of ifwin that renames MSFWIN$ routines that conflict with QuickWin
    use, intrinsic :: ISO_C_BINDING
    !DEC$ ATTRIBUTES STDCALL :: WindowProc
    integer(HANDLE) :: hWnd    ! Window handle
    integer(UINT) :: uMsg      ! Message
    integer(fWPARAM) :: wParam ! Message parameter
    integer(fLPARAM) :: lParam ! Message parameter
    integer(HANDLE) :: hret
    integer(BOOL):: rectret
    integer(SINT) :: DrawTextret
    type(T_PAINTSTRUCT) :: ps
    type(T_RECT)::rect
    
    WindowProc = FALSE

    select case (uMsg)

    case (WM_CLOSE)
        Isrun = .false.
        call PostQuitMessage(0)
        return
        
    case (WM_PAINT)  
hret = BeginPaint(hWnd, ps)
        rectret=GetClientRect(hwnd, rect) 
        DrawTextret=DrawText( hret, "Hello, 这是我自己的窗口!"//char(0), -1, rect,&
        IOR(DT_SINGLELINE, IOR( DT_CENTER , DT_VCENTER ))) 
        hret = EndPaint(hWnd, ps)
        if(hret==1) print *,'窗体重绘'
        return 

    end select

    ! Not ours to handle  
    WindowProc = DefWindowProc( hWnd, uMsg, wParam, lParam )

    end function WindowProc
    
    end module Windows_MDL9966

mdl9966 · 发表于 2016-11-5 16:05:42

这是可能会出现一些麻烦，UI 所以推荐创建多线程
实现多线程代码如下

[Fortran] 纯文本查看 复制代码

    module Windows_MDL

    use IFWINA ! Alternate version of ifwin that renames MSFWIN$ routines that conflict with QuickWin
    use, intrinsic :: ISO_C_BINDING
    integer(HANDLE) :: hThread1,hThread2
    logical :: Isrun = .TRUE. 

    contains
    integer(LONG) function WindowProc (hWnd, uMsg, wParam, lParam)
    use IFWINA ! Alternate version of ifwin that renames MSFWIN$ routines that conflict with QuickWin
    use, intrinsic :: ISO_C_BINDING
    !DEC$ ATTRIBUTES STDCALL :: WindowProc
    integer(HANDLE) :: hWnd    ! Window handle
    integer(UINT) :: uMsg      ! Message
    integer(fWPARAM) :: wParam ! Message parameter
    integer(fLPARAM) :: lParam ! Message parameter
    integer(HANDLE) :: hret
    integer(BOOL):: rectret
    integer(SINT) :: DrawTextret
    type(T_PAINTSTRUCT) :: ps
    type(T_RECT)::rect
    
    WindowProc = FALSE

    select case (uMsg)

    case (WM_CLOSE)
        Isrun = .false.
        hret=closehandle(hThread1)
        hret=closehandle(hThread2)
        call PostQuitMessage(0)
        return
        
    case (WM_PAINT)  !         //处理窗口区域无效时发来的消息
        hret = BeginPaint(hWnd, ps)
        rectret=GetClientRect(hwnd, rect) 
        DrawTextret=DrawText( hret, "Hello, 这是我自己的窗口!"//char(0), -1, rect,&
        IOR(DT_SINGLELINE, IOR( DT_CENTER , DT_VCENTER ))) 
        hret = EndPaint(hWnd, ps)
        if(hret==1) print *,'窗体重绘'
        return 

    end select

    ! Not ours to handle  
    WindowProc = DefWindowProc( hWnd, uMsg, wParam, lParam )

    end function WindowProc
   
    
    integer(LONG) function Test_ThreadProc1(lpParam) 
    !DEC$ ATTRIBUTES STDCALL:: Test_ThreadProc1
    integer,intent(in)::lpParam
    do while(.true.)
    print *,'this is Thread 1'
    call sleep(100)
    end do
    Test_ThreadProc1=10000
    end function Test_ThreadProc1
    
    integer(LONG) function Test_ThreadProc2(lpParam) 
    !DEC$ ATTRIBUTES STDCALL:: Test_ThreadProc2
    integer,intent(in)::lpParam
    do while(.true.)
    print *,'this is Thread 2'
    call sleep(100)
    end do
    Test_ThreadProc2=10000
    end function Test_ThreadProc2
    
    
    end module Windows_MDL


    function WinMain (hCurrentInst, hPreviousInst, lpszCmdLine, nCmdShow)
    !DEC$ ATTRIBUTES STDCALL,DECORATE,ALIAS:"WinMain" :: WinMain
    use Windows_MDL
    implicit none

    integer(SINT) :: WinMain
    integer(HANDLE), intent(IN) :: hCurrentInst, hPreviousInst
    integer(LPCSTR), intent(IN) :: lpszCmdLine
    integer(SINT), intent(IN) :: nCmdShow

    integer(HANDLE) :: hWnd ! Window
    integer(HANDLE) :: hInstance
    integer(SINT) :: ret,retclass
    integer(BOOL) :: bret,AllocConsole_ret
    type(T_MSG) :: msg      ! Message
    type(T_WNDCLASSEX)::wndclass
    character(len=*), parameter :: szClassName = "Windows"C
    
    
    
    AllocConsole_ret=AllocConsole()
    
    if(AllocConsole_ret/=0) print *,'创建控制台成功'
    hThread1=CreateThread(NULL,0,loc(Test_ThreadProc1),NULL,0,NULL)
    hThread2=CreateThread(NULL,0,loc(Test_ThreadProc2),NULL,0,NULL)
    
    
    
    hInstance = GetModuleHandle(NULL)
    wndclass.cbSize = sizeof(wndclass)
    wndclass.style = CS_OWNDC
    wndclass.lpfnWndProc = loc(WindowProc)
    wndclass.cbClsExtra = 0
    wndclass.cbWndExtra = 0
    wndclass.hInstance = hInstance
    wndclass.hIcon = LoadIcon(0_HANDLE, int(IDI_WINLOGO,LPVOID))
    wndclass.hCursor = LoadCursor(0_HANDLE, int(IDC_ARROW,LPVOID))
    wndclass.hbrBackground = (COLOR_WINDOW + 1) !NULL
    wndclass.lpszMenuName = NULL
    wndclass.lpszClassName = loc(szClassName)
    wndclass.hIconSm = NULL

    retclass = RegisterClassEx(wndclass)
    
    if(retclass/=0) print *,'RegisterClass成功'

    WinMain = 0
    hWnd = CreateWindowEx(0,&
    szClassName, &
    'hello' // CHAR(0), &
    WS_OVERLAPPEDWINDOW, 200,0,400,400,&
    NULL,&
    NULL,&
    hInstance,&
    null&
    )
    if (hwnd == NULL) return

    bret = ShowWindow(hWND, SW_SHOW)
    bret = UpdateWindow(hWnd)

    mainloop: do while (Isrun)
        
        if (PeekMessage(msg, hWnd, 0, 0, PM_REMOVE) /= 0) then
            if (msg%message == WM_QUIT) exit mainloop
            bret = TranslateMessage(msg)
            bret = DispatchMessage(msg)
        end if
        call sleep(10) ! sleep for 10ms
    end do mainloop

    return

    end function WinMain