在FP中没有包含VCL(并不是不能用),所以写GUI的程序就需要调用大量的WINDOWS API,所以也就比较麻烦,下面是FP自带的例子,可以直接在FP1.9.8WIN版本下编译通过,我也改了中间一些菜单玩~{ $Id: edit.pp,v 1.3 2002/09/07 15:06:35 peter Exp $ Copyright (c) 1999 by Michael van Canneyt and Goran Andersson Win32 editor example.}{ Derived from menu.ppChanges by Goeran Andersson: 2000.02.24 Handles WM_DrawBkgnd to reduce flicker Changes to also compile in FPC modeChanges by Morten Skovrup: 2000-02-21 Change font Modified statusbarChanges by Goeran Andersson: 2000.02.20 Sends focus to editor 2000.02.19 Client edge added to editor Changes to also compile in FPC mode Handles Edit modify flag Undo menu item added Key codes added to edit menu Undo, Cut, Copy & Paste implemented WM_Paint sections commented 1999.08.10 LoadText() added NewText() added File selector added Asks to save file Empty files works EditCreate styles corrected}Program editdemo;{$APPTYPE GUI}Uses Strings,Windows;Const AppName = 'EditDemo';Type TFileName = Array[0..Max_Path] Of Char;Var AMessage : Msg; HWindow,HStatus,HEdit : HWnd; TheFont : HFont; TheLogFont : TLogFont; TheColor : DWORD; FileName : TFileName;{********************************************************************}Procedure SetStatusText(Num : Integer; Const Text : string);var StatText : array[0..255] of Char;begin if Num = 0 then StatText[0] := ' ' // Add space to text in first item else StatText[0] := #9; // Center the rest StrPCopy(@StatText[1],Text); SendMessage(HStatus,SB_SETTEXT,WPARAM(Num),LPARAM(@StatText));end;{********************************************************************}Function SelectFile(Var FName:TFileName; Open:Boolean): Boolean;Const Filter : PChar = 'Text files (*.txt)'#0'*.txt'
#0+ 'All files (*.*)'#
0'*.*'
#0#
0; Ext : PChar = 'txt';Var NameRec : OpenFileName;Begin FillChar(NameRec,SizeOf(NameRec),0); FName[0] := #0; With NameRec Do Begin LStructSize := SizeOf(NameRec); HWndOwner := HWindow; LpStrFilter := Filter; LpStrFile := @FName; NMaxFile := Max_Path; Flags := OFN_Explorer Or OFN_HideReadOnly; If Open Then Begin Flags := Flags Or OFN_FileMustExist; End; LpStrDefExt := Ext; End; If Open Then SelectFile := GetOpenFileName(@NameRec) Else SelectFile := GetSaveFileName(@NameRec);End;{********************************************************************}Procedure SaveText;Var Len : Longint; P : PChar; F : File; FName : TFileName;Begin If SelectFile(FName,False) Then Begin Assign(F,@FName); Rewrite(F,1); Len := GetWindowTextLength(HEdit); GetMem(P,Len+1);

P[Len] := #0; If Len>0 Then Begin GetWindowText(HEdit,P,Len+1); BlockWrite(F,P^,Len); End; Close(F); FreeMem(P,Len+1); StrCopy(FileName,FName); SetStatusText(0,StrPas(FileName)); SetStatusText(1,''); SendMessage(HEdit,EM_SetModify,0,0); End;End;{********************************************************************}Procedure AskSave;Const BoxType = MB_IconQuestion Or MB_YesNo;Begin If SendMessage(HEdit,EM_GetModify,0,0)<>0 Then Begin If MessageBox(HWindow,'保存文件?','编辑的',BoxType)=IdYes Then Begin SaveText; End; End;End;{********************************************************************}Procedure LoadText;Var F : File; Len : LongInt; P : PChar;Begin AskSave; If SelectFile(FileName,True) Then Begin Assign(F,@FileName); Reset(F,1); Len := FileSize(F); GetMem(P,Len+1); P[Len] := #0; If Len>0 Then BlockRead(F,P^,Len); Close(F); SetWindowText(HEdit,P); SendMessage(HEdit,EM_SetModify,0,0); FreeMem(P,Len+1); SetStatusText(0,StrPas(FileName)); SetStatusText(1,''); End;End;{********************************************************************}Procedure NewText;Const Empty : PChar = '';Begin AskSave; FileName := '未保存'; SetStatusText(0,StrPas(FileName)); SendMessage(HEdit,WM_SetText,1,LRESULT(Empty)); SendMessage(HEdit,EM_SetModify,0,0);End;{********************************************************************}procedure SelectFont;var ChooseFontRec : TChooseFont;begin with ChooseFontRec do begin lStructSize := SizeOf(ChooseFontRec); hwndOwner := HWindow; hDC := 0; lpLogFont := @TheLogFont; iPointSize := 0; Flags := CF_INITTOLOGFONTSTRUCT or CF_SCREENFONTS or CF_EFFECTS; rgbColors := TheColor; lCustData := 0; lpfnHook := nil; lpTemplateName := nil; hInstance := 0; lpszStyle := nil; nFontType := 0; nSizeMin := 0; nSizeMax := 0; end; if ChooseFont(@ChooseFontRec) then begin DeleteObject(TheFont); TheColor := ChooseFontRec.rgbColors; TheFont := CreateFontIndirect(@TheLogFont); SendMessage(HEdit,WM_SETFONT,WPARAM(TheFont),1); end;end;{********************************************************************}Function WindowProc (Window:HWnd;AMessage: UINT;WParam:WPARAM; LParam:LPARAM): LRESULT;stdcall; export;Var R : rect; StatH : LONG; NrMenu : Longint; NotiCode : LongInt;Begin WindowProc := 0; Case AMessage Of wm_Close: Begin AskSave; End; wm_Destroy: Begin PostQuitMessage (0); Exit; End; wm_SetFocus: Begin SetFocus(HEdit); End;

WM_EraseBkgnd: Begin Exit(1); End; wm_Size: Begin GetClientRect(HStatus,@R); StatH := R.Bottom-R.Top; GetClientRect(Window,@R); MoveWindow (HEdit,0,0,R.Right,R.Bottom-StatH,False); MoveWindow (HStatus,0,R.Bottom-StatH,R.Right,R.Bottom,False); End; wm_Command: Begin NotiCode := HiWord(WParam); Case NotiCode of en_Change : //Editor has changed Begin If SendMessage(HEdit,EM_GetModify,0,0)<>0 then SetStatusText(1,'已修改') Else SetStatusText(1,''); End; Else Begin //Menu item NrMenu := LoWord(WParam); Case NrMenu Of 101 : NewText; 102 : LoadText; 103 : SaveText; 104 : PostMessage(Window,WM_Close,0,0); 201 : SendMessage(HEdit,WM_Undo,0,0); 202 : SendMessage(HEdit,WM_Cut,0,0); 203 : SendMessage(HEdit,WM_Copy,0,0); 204 : SendMessage(HEdit,WM_Paste,0,0); 301 : SelectFont; 401 : MessageBox(Window,'巫山霏云汉化','帮助', MB_OK Or MB_IconInformation); End; End; End; End; wm_CtlColorEdit : Begin SetTextColor(WParam,TheColor); Exit(GetSysColorBrush(COLOR_WINDOW)); End; End; WindowProc := DefWindowProc(Window,AMessage,WParam,LParam);End;{********************************************************************}Function WinRegister: Boolean;Var WindowClass : WndClass;Begin With WindowClass Do Begin Style := cs_hRedraw Or cs_vRedraw; lpfnWndProc := WndProc(@WindowProc); cbClsExtra := 0; cbWndExtra := 0; hInstance := system.MainInstance; hIcon := LoadIcon (0,idi_Application); hCursor := LoadCursor (0,idc_Arrow); hbrBackground := GetStockObject(GRAY_BRUSH); lpszMenuName := Nil; lpszClassName := AppName; End; WinRegister := RegisterClass (WindowClass)<>0;End;{********************************************************************}Function EditCreate(ParentWindow,Status:HWnd): HWnd;Const CS_Start = WS_Child or WS_HScroll or WS_VScroll or ES_MultiLine or ES_Left; CS_Ex = WS_EX_ClientEdge; EdiTText : PChar = '';Var HEdit : HWND; R : TRect; StatH : Word;Begin GetClientRect(Status,@R); StatH := R.Bottom-R.Top; GetClientRect(ParentWindow,@R); HEdit := CreateWindowEx (CS_Ex,'EDIT',EditText,CS_Start,0,0, R.Right-R.Left,R.Bottom-R.Top-StatH,ParentWindow,0, MainInstance,Nil); If HEdit<>0 Then Begin //Set Courier new as default font with TheLogFont do begin lfHeight := 0; // Default logical height of font

lfWidth := 0; // Default logical average character width lfEscapement := 0; // angle of escapement lfOrientation := 0; // base-line orientation angle lfWeight := FW_NORMAL; // font weight lfItalic := 0; // italic attribute flag lfUnderline := 0; // underline attribute flag lfStrikeOut := 0; // strikeout attribute flag lfCharSet := DEFAULT_CHARSET; // character set identifier lfOutPrecision := OUT_DEFAULT_PRECIS; // output precision lfClipPrecision := CLIP_DEFAULT_PRECIS; // clipping precision lfQuality := DEFAULT_QUALITY; // output quality lfPitchAndFamily := DEFAULT_PITCH; // pitch and family Strcopy(lfFaceName,'Courier New'); // pointer to typeface name string end; TheColor := GetSysColor(COLOR_WINDOWTEXT); TheFont := CreateFontIndirect(@TheLogFont); SendMessage(HEdit,WM_SETFONT,WPARAM(TheFont),1); ShowWindow(Hedit,SW_Show); UpdateWindow(HEdit); End; EditCreate := HEdit;End;{********************************************************************}Function WinCreate: HWnd;Var hWindow : HWnd; Menu : hMenu; SubMenu : hMenu;Begin hWindow := CreateWindow (AppName,'EditDemo',ws_OverlappedWindow, cw_UseDefault,cw_UseDefault,cw_UseDefault, cw_UseDefault,0,0,MainInstance,Nil); If hWindow<>0 Then Begin Menu := CreateMenu; SubMenu := CreateMenu; AppendMenu(Submenu,MF_STRING,101,'新建(&N)...'); AppendMenu(Submenu,MF_STRING,102,'打开(&O)...'); AppendMenu(Submenu,MF_STRING,103,'保存(&S)...'); AppendMenu(Submenu,MF_SEPARATOR,0,Nil); AppendMenu(SubMenu,MF_String,104,'退出(&X)'); AppendMenu(Menu,MF_POPUP,SubMenu,'文件(&F)'); SubMenu := CreateMenu; AppendMenu(SubMenu,MF_String,201,'撤消(&Z)'#8'Ctrl+Z'); AppendMenu(Submenu,MF_SEPARATOR,0,Nil); AppendMenu(SubMenu,MF_String,202,'剪切(&C)'#8'Ctrl+X'); AppendMenu(SubMenu,MF_String,203,'复制(&C)'#8'Ctrl+C'); AppendMenu(SubMenu,MF_STRING,204,'粘贴(&P)'#8'Ctrl+V'); AppendMenu(Menu,MF_POPUP,SubMenu,'编辑(&E)'); SubMenu := CreateMenu; AppendMenu(SubMenu,MF_String,301,'字体(&F)...'); AppendMenu(Menu,MF_POPUP,SubMenu,'选项(&O)'); AppendMenu(Menu,MF_STRING,401,'帮助(&H)'); SetMenu(hWindow,menu); ShowWindow(hWindow,SW_Show); UpdateWindow(hWindow); End; WinCreate := hWindow;End;{********************************************************************}Function StatusCreate (parent:hwnd): HWnd;var AWnd : HWnd; Edges : array[1..2] of LongInt;Begin FileName := '未保存'; AWnd := CreateStatusWindow(WS_CHILD or WS_VISIBLE,FileName,Parent,$7712); // Create items: if AWnd <> 0 then begin Edges[1] := 400; Edges[2] := 500; SendMessage(AWnd,SB_SETPARTS,2,LPARAM(@Edges)); end; StatusCreate := AWnd;End;{********************************************************************}Begin If Not WinRegister Then Begin MessageBox (0,'Register failed',Nil, mb_Ok); End Else Begin hWindow := WinCreate; If longint(hWindow)=0 Then Begin MessageBox (0,'WinCreate failed',Nil,MB_OK); End Else Begin HStatus := statuscreate(hwindow); HEdit := EditCreate(HWindow,HStatus); SetFocus(HEdit); While GetMessage(@AMessage,0,0,0) Do Begin TranslateMessage(AMessage); DispatchMessage(AMessage); End; DeleteObject(TheFont); Halt(AMessage.wParam); End; End;End.{ $Log: edit.pp,v $ Revision 1.3 2002/09/07 15:06:35 peter * old logs removed and tabs fixed}

佩服我 好像什么都看不懂

只能看懂一点点

????????????????????????

佩服佩服啊，竟然能用pascal编译出文本编译器。

没啥意思，只不过闲来无事练手用吧

～～～～～～～～～～晕了要

。。。我只是将FP中样例程序略做修改贴出来而已。。。还是希望大家喜欢咯

还是用delphi简单...

厉害！

不就是用object pascal进行Win32 SDK开发

有意思么？这样开发不累？开发软件是为了解决问题，不是用来炫耀技术的，用过时的pascal,VCL开发windows程序，真有手淫的感觉

简单

请问什么是GUI？

Free Pascal中WINDOWS的GUI界面编写这个是好东东

不要看不起Delphi，windows下二进制的GUI程序，除了MFC那个难用的东西，还有别的吗？VCL一点都不过时，或者说，业内在这个方面这些年一直都没有进展

哇！Pascal竟然能写Windows的UI！！！