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

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

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

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

01function WinMain (hCurrentInst, hPreviousInst, lpszCmdLine, nCmdShow)
02    !DEC$ ATTRIBUTES STDCALL,DECORATE,ALIAS:"WinMain" :: WinMain
03    use Windows_MDL9966
04    implicit none
05 
06    integer(SINT) :: WinMain
07    integer(HANDLE), intent(IN) :: hCurrentInst, hPreviousInst
08    integer(LPCSTR), intent(IN) :: lpszCmdLine
09    integer(SINT), intent(IN) :: nCmdShow
10 
11    integer(HANDLE) :: hWnd ! Window
12    integer(HANDLE) :: hInstance
13    integer(SINT) :: ret,retclass
14    integer(BOOL) :: bret,AllocConsole_ret
15    type(T_MSG) :: msg      ! Message
16    type(T_WNDCLASSEX)::wndclass
17    character(len=*), parameter :: szClassName = "Windows"C
18     
19    AllocConsole_ret=AllocConsole()！
20    ! 创建控制台在这里
21    if(AllocConsole_ret/=0) print *,'创建控制台成功'
22 
23hInstance = GetModuleHandle(NULL)
24    wndclass.cbSize = sizeof(wndclass)
25    wndclass.style = CS_OWNDC
26    wndclass.lpfnWndProc = loc(WindowProc)
27    wndclass.cbClsExtra = 0
28    wndclass.cbWndExtra = 0
29    wndclass.hInstance = hInstance
30    wndclass.hIcon = LoadIcon(0_HANDLE, int(IDI_WINLOGO,LPVOID))
31    wndclass.hCursor = LoadCursor(0_HANDLE, int(IDC_ARROW,LPVOID))
32    wndclass.hbrBackground = (COLOR_WINDOW + 1) !NULL
33    wndclass.lpszMenuName = NULL
34    wndclass.lpszClassName = loc(szClassName)
35    wndclass.hIconSm = NULL
36 
37    retclass = RegisterClassEx(wndclass)
38     
39    if(retclass/=0) print *,'RegisterClass成功'
40 
41    WinMain = 0
42    hWnd = CreateWindowEx(0,&
43    szClassName, &
44    'hello' // CHAR(0), &
45    WS_OVERLAPPEDWINDOW, 200,0,400,400,&
46    NULL,&
47    NULL,&
48    hInstance,&
49    null&
50    )
51    if (hwnd == NULL) return
52 
53    bret = ShowWindow(hWND, SW_SHOW)
54    bret = UpdateWindow(hWnd)
55 
56    mainloop: do while (Isrun)！
57        if (PeekMessage(msg, hWnd, 0, 0, PM_REMOVE) /= 0) then
58            if (msg%message == WM_QUIT) exit mainloop
59            bret = TranslateMessage(msg)
60            bret = DispatchMessage(msg)
61        end if
62        call sleep(10) ! sleep for 10ms
63    end do mainloop
64 
65    return
66 
67    end function WinMain

回调函数

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

01    module Windows_MDL9966
02 
03    use IFWINA ! Alternate version of ifwin that renames MSFWIN$ routines that conflict with QuickWin
04    use, intrinsic :: ISO_C_BINDING
05     
06    logical :: Isrun = .TRUE.
07     
08    contains
09    integer(LONG) function WindowProc (hWnd, uMsg, wParam, lParam)
10    use IFWINA ! Alternate version of ifwin that renames MSFWIN$ routines that conflict with QuickWin
11    use, intrinsic :: ISO_C_BINDING
12    !DEC$ ATTRIBUTES STDCALL :: WindowProc
13    integer(HANDLE) :: hWnd    ! Window handle
14    integer(UINT) :: uMsg      ! Message
15    integer(fWPARAM) :: wParam ! Message parameter
16    integer(fLPARAM) :: lParam ! Message parameter
17    integer(HANDLE) :: hret
18    integer(BOOL):: rectret
19    integer(SINT) :: DrawTextret
20    type(T_PAINTSTRUCT) :: ps
21    type(T_RECT)::rect
22     
23    WindowProc = FALSE
24 
25    select case (uMsg)
26 
27    case (WM_CLOSE)
28        Isrun = .false.
29        call PostQuitMessage(0)
30        return
31         
32    case (WM_PAINT) 
33hret = BeginPaint(hWnd, ps)
34        rectret=GetClientRect(hwnd, rect)
35        DrawTextret=DrawText( hret, "Hello, 这是我自己的窗口!"//char(0), -1, rect,&
36        IOR(DT_SINGLELINE, IOR( DT_CENTER , DT_VCENTER )))
37        hret = EndPaint(hWnd, ps)
38        if(hret==1) print *,'窗体重绘'
39        return
40 
41    end select
42 
43    ! Not ours to handle  
44    WindowProc = DefWindowProc( hWnd, uMsg, wParam, lParam )
45 
46    end function WindowProc
47     
48    end module Windows_MDL9966

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

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

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

001module Windows_MDL
002 
003use IFWINA ! Alternate version of ifwin that renames MSFWIN$ routines that conflict with QuickWin
004use, intrinsic :: ISO_C_BINDING
005integer(HANDLE) :: hThread1,hThread2
006logical :: Isrun = .TRUE.
007 
008contains
009integer(LONG) function WindowProc (hWnd, uMsg, wParam, lParam)
010use IFWINA ! Alternate version of ifwin that renames MSFWIN$ routines that conflict with QuickWin
011use, intrinsic :: ISO_C_BINDING
012!DEC$ ATTRIBUTES STDCALL :: WindowProc
013integer(HANDLE) :: hWnd    ! Window handle
014integer(UINT) :: uMsg      ! Message
015integer(fWPARAM) :: wParam ! Message parameter
016integer(fLPARAM) :: lParam ! Message parameter
017integer(HANDLE) :: hret
018integer(BOOL):: rectret
019integer(SINT) :: DrawTextret
020type(T_PAINTSTRUCT) :: ps
021type(T_RECT)::rect
022 
023WindowProc = FALSE
024 
025select case (uMsg)
026 
027case (WM_CLOSE)
028    Isrun = .false.
029    hret=closehandle(hThread1)
030    hret=closehandle(hThread2)
031    call PostQuitMessage(0)
032    return
033     
034case (WM_PAINT)  !         //处理窗口区域无效时发来的消息
035    hret = BeginPaint(hWnd, ps)
036    rectret=GetClientRect(hwnd, rect)
037    DrawTextret=DrawText( hret, "Hello, 这是我自己的窗口!"//char(0), -1, rect,&
038    IOR(DT_SINGLELINE, IOR( DT_CENTER , DT_VCENTER )))
039    hret = EndPaint(hWnd, ps)
040    if(hret==1) print *,'窗体重绘'
041    return
042 
043end select
044 
045! Not ours to handle  
046WindowProc = DefWindowProc( hWnd, uMsg, wParam, lParam )
047 
048end function WindowProc
049 
050 
051integer(LONG) function Test_ThreadProc1(lpParam)
052!DEC$ ATTRIBUTES STDCALL:: Test_ThreadProc1
053integer,intent(in)::lpParam
054do while(.true.)
055print *,'this is Thread 1'
056call sleep(100)
057end do
058Test_ThreadProc1=10000
059end function Test_ThreadProc1
060 
061integer(LONG) function Test_ThreadProc2(lpParam)
062!DEC$ ATTRIBUTES STDCALL:: Test_ThreadProc2
063integer,intent(in)::lpParam
064do while(.true.)
065print *,'this is Thread 2'
066call sleep(100)
067end do
068Test_ThreadProc2=10000
069end function Test_ThreadProc2
070 
071 
072end module Windows_MDL
073 
074 
075function WinMain (hCurrentInst, hPreviousInst, lpszCmdLine, nCmdShow)
076!DEC$ ATTRIBUTES STDCALL,DECORATE,ALIAS:"WinMain" :: WinMain
077use Windows_MDL
078implicit none
079 
080integer(SINT) :: WinMain
081integer(HANDLE), intent(IN) :: hCurrentInst, hPreviousInst
082integer(LPCSTR), intent(IN) :: lpszCmdLine
083integer(SINT), intent(IN) :: nCmdShow
084 
085integer(HANDLE) :: hWnd ! Window
086integer(HANDLE) :: hInstance
087integer(SINT) :: ret,retclass
088integer(BOOL) :: bret,AllocConsole_ret
089type(T_MSG) :: msg      ! Message
090type(T_WNDCLASSEX)::wndclass
091character(len=*), parameter :: szClassName = "Windows"C
092 
093 
094 
095AllocConsole_ret=AllocConsole()
096 
097if(AllocConsole_ret/=0) print *,'创建控制台成功'
098hThread1=CreateThread(NULL,0,loc(Test_ThreadProc1),NULL,0,NULL)
099hThread2=CreateThread(NULL,0,loc(Test_ThreadProc2),NULL,0,NULL)
100 
101 
102 
103hInstance = GetModuleHandle(NULL)
104wndclass.cbSize = sizeof(wndclass)
105wndclass.style = CS_OWNDC
106wndclass.lpfnWndProc = loc(WindowProc)
107wndclass.cbClsExtra = 0
108wndclass.cbWndExtra = 0
109wndclass.hInstance = hInstance
110wndclass.hIcon = LoadIcon(0_HANDLE, int(IDI_WINLOGO,LPVOID))
111wndclass.hCursor = LoadCursor(0_HANDLE, int(IDC_ARROW,LPVOID))
112wndclass.hbrBackground = (COLOR_WINDOW + 1) !NULL
113wndclass.lpszMenuName = NULL
114wndclass.lpszClassName = loc(szClassName)
115wndclass.hIconSm = NULL
116 
117retclass = RegisterClassEx(wndclass)
118 
119if(retclass/=0) print *,'RegisterClass成功'
120 
121WinMain = 0
122hWnd = CreateWindowEx(0,&
123szClassName, &
124'hello' // CHAR(0), &
125WS_OVERLAPPEDWINDOW, 200,0,400,400,&
126NULL,&
127NULL,&
128hInstance,&
129null&
130)
131if (hwnd == NULL) return
132 
133bret = ShowWindow(hWND, SW_SHOW)
134bret = UpdateWindow(hWnd)
135 
136mainloop: do while (Isrun)
137     
138    if (PeekMessage(msg, hWnd, 0, 0, PM_REMOVE) /= 0) then
139        if (msg%message == WM_QUIT) exit mainloop
140        bret = TranslateMessage(msg)
141        bret = DispatchMessage(msg)
142    end if
143    call sleep(10) ! sleep for 10ms
144end do mainloop
145 
146return
147 
148end function WinMain