-- 作者:lm_lxt
-- 发布时间:2008/5/6 15:58:52
--
这个版块里有一些源程序,应该对你有所帮助. 这里再贴上一段程序,作一些修改就可以满足你的要求: !********************************************************************************** !*******************************(第0部分)程序说明模块****************************** !********************************************************************************** !这是用fortran语言开发的一个最简单的windows程序 !程序用来显示一行文本,并且解决高效率重画的问题 !下表是Win32和Fortran数据类型的等价关系: !┏━━━━━━━━━━━━━━┳━━━━━━━━━━━━━━━━━┓ !│ Win32 Data Type │ Equivalent Fortran Data Type │ !│ BOOL, BOOLEAN │ LOGICAL(4) │ !│ BYTE │ BYTE │ !│ CHAR, CCHAR, UCHAR │ CHARACTER │ !│ COLORREF │ INTEGER(4) │ !│ DWORD, INT, LONG, ULONG│ INTEGER(4) │ !│ SHORT, USHORT, WORD │ INTEGER(2) │ !│ FLOAT │ REAL(4) │ !│ All Handles │ INTEGER(4) │ !│ All Pointers (LP*, P*) │ INTEGER(4) (Integer Pointers)│ !┗━━━━━━━━━━━━━━┻━━━━━━━━━━━━━━━━━┛ ! !********************************************************************************** !****************************(第一部分)有用的数据模块****************************** !********************************************************************************** ! module Constant use dFwin logical*4 results !存储函数的返回值 logical*4 IsDrawing !用来判断是否开始画线 integer*4 i integer*4 X !文本的输出位置 integer*4 Y integer*4 maxX !显示器的分辨率 integer*4 maxY character*100 string !存储将要输出的文本 integer*4 memdc !存储兼容的设备描述表的句柄 integer*4 hbit !存储指定的设备描述表兼容的位图的句柄 integer*4 hbrush !存储画刷的句柄 end module Constant ! !********************************************************************************** !****************************(第二部分)主函数部分********************************** !********************************************************************************** ! integer function WinMain( hInstance, hPrevInstance, lpszCmdLine, nCmdShow ) !DEC$ IF DEFINED(_X86_) !DEC$ ATTRIBUTES STDCALL, ALIAS : \'_WinMain@16\' :: WinMain !DEC$ ELSE !DEC$ ATTRIBUTES STDCALL, ALIAS : \'WinMain\' :: WinMain !DEC$ ENDIF !包含有用的模块 use Constant !定义函数的传递参数 integer*4 hInstance !定义当前实例句柄 integer*4 hPrevInstance !定义句柄,永远是NULL型 integer*4 nCmdShow !定义程序执行的时候窗口的显示方式 integer*4 lpszCmdLine !指向字符串的指针 !=================================================== !定义函数接口,注意这一段是必须的 interface integer*4 function MainWndProc ( hwnd, mesg, wParam, lParam ) !DEC$ IF DEFINED(_X86_) !DEC$ ATTRIBUTES STDCALL, ALIAS : \'_MainWndProc@16\' :: MainWndProc !DEC$ ELSE !DEC$ ATTRIBUTES STDCALL, ALIAS : \'MainWndProc\' :: MainWndProc !DEC$ ENDIF integer*4 hwnd integer*4 mesg integer*4 wParam integer*4 lParam end function end interface !=================================================== type (T_WNDCLASS) wc !定义窗口的结构体类数据,确定窗口的特征 type (T_MSG) mesg !定义消息的结构体类数据 integer*4 hWnd !定义程序窗口的句柄 integer*4 COLOR !定义窗口的背景颜色 character*100 lpszClassName !定义窗口类的名字 character*100 lpszAppName !定义窗口的名字,即窗口的标题 COLOR=13 !用来改变窗口的背景颜色,从1-20颜色会变化 IsDrawing = .false. !用来判断是否开始画线 lpszClassName ="Generic"C lpszAppName ="WINDOWS程序的框架"C open(unit=10,file=\'hello.dat\') !指定窗口的特征 if(hPrevInstance .eq. 0) then wc%lpszClassName = LOC(lpszClassName) !指定窗口类的名字 wc%lpfnWndProc = LOC(MainWndProc) !指定窗口函数的地址 wc%style = 0 !指定窗口的类型 wc%hInstance = hInstance !指定当前实例句柄 wc%hIcon = LoadIcon( NULL, IDI_WINLOGO) !指定窗口的图标 wc%hCursor = LoadCursor( NULL, IDC_CROSS ) !指定鼠标光标 wc%hbrBackground = ( COLOR_WINDOW+COLOR ) !指定窗口的背景颜色 wc%lpszMenuName = NULL !指定窗口主菜单的名字 wc%cbClsExtra = 0 !没有额外的信息提供 wc%cbWndExtra = 0 !没有额外的信息提供 i = RegisterClass(wc) !让系统注册窗口,即告知系统窗口的特征是什么样的 end if !创建窗口 hWnd = CreateWindowEx( 0, & !扩展的窗口风格 lpszClassName, & !窗口类的名字 lpszAppName, & !窗口的标题 INT(WS_OVERLAPPEDWINDOW), & !窗口的类型 CW_USEDEFAULT, & !窗口左上角的X坐标 0, & !窗口左上角的Y坐标 CW_USEDEFAULT, & !窗口的宽度 0, & !窗口的高度 NULL, & !父窗口的句柄 NULL, & !主菜单的句柄 hInstance, & !当前实例句柄 NULL & !附加信息的指针 ) !显示窗口 i = ShowWindow( hWnd, SW_MAXIMIZE) i = UpdateWindow( hWnd ) !进入消息循环 do while( GetMessage (mesg, NULL, 0, 0) .NEQV. .FALSE.) i = TranslateMessage( mesg ) i = DispatchMessage( mesg ) end do WinMain = mesg%wParam return end ! !********************************************************************************** !****************************(第三部分)窗口函数部分******************************** !********************************************************************************** ! integer function MainWndProc ( hWnd, mesg, wParam, lParam ) !DEC$ IF DEFINED(_X86_) !DEC$ ATTRIBUTES STDCALL, ALIAS : \'_MainWndProc@16\' :: MainWndProc !DEC$ ELSE !DEC$ ATTRIBUTES STDCALL, ALIAS : \'MainWndProc\' :: MainWndProc !DEC$ ENDIF use Constant integer*4 hWnd !窗口的句柄 integer*4 mesg !消息类结构体 integer*4 wParam !消息相关的附加信息 integer*4 lParam !消息相关的附加信息 integer*4 hdc !当前设备描述表的句柄 integer*4 StartX, StartY !线段起点 integer*4 EndX, EndY !线段终点 integer*4 EndXX, EndYY !鼠标的当前位置 integer*4 hredpen !线段的颜色句柄 type (T_TEXTMETRIC) tm !定义当前字体信息的T_TEXTMETRIC结构体 type (T_SIZE) size !定义包含字符串宽度和高度信息的T_SIZE结构体 type (T_PAINTSTRUCT) paintstruct !定义包含窗口显示信息的T_PAINTSTRUCT结构体
logical*4 F,T F=.false. T=.true. X=0 Y=0 !进行消息的处理 select case ( mesg ) case( WM_CREATE ) !创建虚拟窗口 maxX = GetSystemMetrics( SM_CXSCREEN ) !获得屏幕分辨率 maxY = GetSystemMetrics( SM_CYSCREEN ) hdc = GetDC( hWnd ) memdc = CreateCompatibleDC( hdc ) !创建兼容的设备描述表 hbit = CreateCompatibleBitmap( hdc,maxX,maxY ) !创建一个与指定的设备描述表兼容的位图 i = SelectObject( memdc,hbit ) hbrush = GetStockObject(WHITE_BRUSH) i = SelectObject( memdc,hbrush ) results = PatBlt( memdc,0,0,maxX,maxY,PATCOPY ) !用所选画刷的颜色和图案来填充矩形 hredpen = CreatePen( PS_SOLID,1,RGB(0,0,255) ) !创建红色的,实线形画笔 i = SetBkMode(memdc,TRANSPARENT) !输出文本与窗体色彩一样 i = SelectObject(memdc,hredpen) i = ReleaseDC(hWnd,hdc) case ( WM_LBUTTONDOWN ) if(IsDrawing.EQ..FALSE.)then StartX = LOWORD(lParam) StartY = HIWORD(lParam) results = MoveToEx(memdc,StartX,StartY,NULL) endif IsDrawing = .true. EndX = LOWORD(lParam) EndY = HIWORD(lParam) write(10,*)endx,endy results = MSFWIN$LineTo(memdc,EndX,EndY) results = InvalidateRect(hwnd,NULL,F) !更新物理窗口 case ( WM_RBUTTONDOWN ) IsDrawing = .false. case ( WM_MOUSEMOVE ) EndXX = LOWORD(lParam) EndYY = HIWORD(lParam) i = MSFWIN$SetTextColor(memdc,RGB(255,0,0)) !文字颜色 results = GetTextMetrics(memdc,tm) results = PatBlt(memdc,X,Y,150,tm%tmHeight,PATCOPY) write(string,"(\'屏幕坐标:\'I4 \'x\' I4)") EndXX, EndYY results = TextOut(memdc,X,Y,string,LEN(string)) results = InvalidateRect(hwnd,NULL,F) !更新物理窗口 case( WM_PAINT ) hdc = BeginPaint( hwnd,paintstruct ) result = BitBlt(hdc, & paintstruct%rcPaint%left, & paintstruct%rcPaint%top, & paintstruct%rcPaint%right-paintstruct%rcPaint%left, & paintstruct%rcPaint%bottom-paintstruct%rcPaint%top, & memdc, & paintstruct%rcPaint%left, & paintstruct%rcPaint%top, & SRCCOPY) !将虚拟窗口中的内容复制到物理窗口中 hdc=EndPaint(hwnd,paintstruct) case ( WM_DESTROY ) !如果关闭窗口,则退出应用程序 results = DeleteDC(memdc) results = DeleteObject(hredpen) call PostQuitMessage( 0 ) case default !其他信息系统自己处理 MainWndProc = DefWindowProc( hWnd, mesg, wParam, lParam ) end select return end
|