论坛 › 编程工具交流 › Intel Fortran 调用API函数创建窗体，同时创建控制台输出（

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

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

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

回调函数
    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 所以推荐创建 多线程
实现多线程 代码如下
    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

fcode 发表于 2016-11-5 16:12:50

用这种原生的 Win API 就是很麻烦。简简单单的一个窗口，动辄百十行代码。

还是出门左转找 C#，QT，Delphi 这些吧

查看完整版本: Intel Fortran 调用API函数创建窗体，同时创建控制台输出（