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
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
QQ截图20161105160501.jpg (51.56 KB, 下载次数: 201)
| 欢迎光临 Fortran Coder (http://bbs.fcode.cn/) | Powered by Discuz! X3.2 |
