development/compilers/freepascal/demo/win32/edit.pp

   1 {
   2   $Id$
   3   Copyright (c) 1999 by Michael van Canneyt and Goran Andersson
   4
   5   Win32 editor example.
   6 }
   7
   8 { Derived from menu.pp
   9
  10 Changes by Goeran Andersson:
  11
  12   2000.02.24
  13     Handles WM_DrawBkgnd to reduce flicker
  14     Changes to also compile in FPC mode
  15
  16 Changes by Morten Skovrup:
  17
  18   2000-02-21
  19     Change font
  20     Modified statusbar
  21
  22 Changes by Goeran Andersson:
  23
  24   2000.02.20
  25     Sends focus to editor
  26
  27   2000.02.19
  28     Client edge added to editor
  29     Changes to also compile in FPC mode
  30     Handles Edit modify flag
  31     Undo menu item added
  32     Key codes added to edit menu
  33     Undo, Cut, Copy & Paste implemented
  34     WM_Paint sections commented
  35
  36   1999.08.10
  37     LoadText() added
  38     NewText() added
  39     File selector added
  40     Asks to save file
  41     Empty files works
  42     EditCreate styles corrected
  43 }
  44
  45 Program editdemo;
  46
  47 {$APPTYPE GUI}
  48
  49 Uses
  50   Strings,Windows;
  51
  52 Const
  53   AppName = 'EditDemo';
  54
  55 Type
  56   TFileName = Array[0..Max_Path] Of Char;
  57
  58 Var
  59   AMessage              : Msg;
  60   HWindow,HStatus,HEdit : HWnd;
  61   TheFont               : HFont;
  62   TheLogFont            : TLogFont;
  63   TheColor              : DWORD;
  64   FileName              : TFileName;
  65
  66 {********************************************************************}
  67
  68 Procedure SetStatusText(Num : Integer; Const Text : string);
  69 var
  70   StatText : array[0..255] of Char;
  71 begin
  72   if Num = 0 then
  73     StatText[0] := ' '  // Add space to text in first item
  74   else
  75     StatText[0] := #9;  // Center the rest
  76   StrPCopy(@StatText[1],Text);
  77   SendMessage(HStatus,SB_SETTEXT,Num,LongInt(@StatText));
  78 end;
  79
  80 {********************************************************************}
  81
  82 Function SelectFile(Var FName:TFileName; Open:Boolean): Boolean;
  83 Const
  84   Filter : PChar = 'Text files (*.txt)'#0'*.txt'#0+
  85                    'All files (*.*)'#0'*.*'#0#0;
  86   Ext    : PChar = 'txt';
  87 Var
  88   NameRec : OpenFileName;
  89 Begin
  90   FillChar(NameRec,SizeOf(NameRec),0);
  91   FName[0] := #0;
  92   With NameRec Do
  93     Begin
  94       LStructSize := SizeOf(NameRec);
  95       HWndOwner   := HWindow;
  96       LpStrFilter := Filter;
  97       LpStrFile   := @FName;
  98       NMaxFile    := Max_Path;
  99       Flags       := OFN_Explorer Or OFN_HideReadOnly;
 100       If Open Then
 101         Begin
 102           Flags := Flags Or OFN_FileMustExist;
 103         End;
 104       LpStrDefExt := Ext;
 105     End;
 106   If Open Then
 107       SelectFile := GetOpenFileName(@NameRec)
 108   Else
 109       SelectFile := GetSaveFileName(@NameRec);
 110 End;
 111
 112 {********************************************************************}
 113
 114 Procedure SaveText;
 115 Var
 116   Len   : Longint;
 117   P     : PChar;
 118   F     : File;
 119   FName : TFileName;
 120 Begin
 121   If SelectFile(FName,False) Then
 122     Begin
 123       Assign(F,@FName);
 124       Rewrite(F,1);
 125       Len := GetWindowTextLength(HEdit);
 126       GetMem(P,Len+1);
 127       P[Len] := #0;
 128       If Len>0 Then
 129         Begin
 130           GetWindowText(HEdit,P,Len+1);
 131           BlockWrite(F,P^,Len);
 132         End;
 133       Close(F);
 134       FreeMem(P,Len+1);
 135       StrCopy(FileName,FName);
 136       SetStatusText(0,StrPas(FileName));
 137       SetStatusText(1,'');
 138       SendMessage(HEdit,EM_SetModify,0,0);
 139     End;
 140 End;
 141
 142 {********************************************************************}
 143
 144 Procedure AskSave;
 145 Const
 146   BoxType = MB_IconQuestion Or MB_YesNo;
 147 Begin
 148   If SendMessage(HEdit,EM_GetModify,0,0)<>0 Then
 149     Begin
 150       If MessageBox(HWindow,'Save text?','Edited',BoxType)=IdYes Then
 151         Begin
 152           SaveText;
 153         End;
 154     End;
 155 End;
 156
 157 {********************************************************************}
 158
 159 Procedure LoadText;
 160 Var
 161   F     : File;
 162   Len   : LongInt;
 163   P     : PChar;
 164 Begin
 165   AskSave;
 166   If SelectFile(FileName,True) Then
 167     Begin
 168       Assign(F,@FileName);
 169       Reset(F,1);
 170       Len := FileSize(F);
 171       GetMem(P,Len+1);
 172       P[Len] := #0;
 173       If Len>0 Then BlockRead(F,P^,Len);
 174       Close(F);
 175       SetWindowText(HEdit,P);
 176       SendMessage(HEdit,EM_SetModify,0,0);
 177       FreeMem(P,Len+1);
 178       SetStatusText(0,StrPas(FileName));
 179       SetStatusText(1,'');
 180     End;
 181 End;
 182
 183 {********************************************************************}
 184
 185 Procedure NewText;
 186 Const
 187   Empty : PChar = '';
 188 Begin
 189   AskSave;
 190   FileName := 'Unsaved';
 191   SetStatusText(0,StrPas(FileName));
 192   SendMessage(HEdit,WM_SetText,1,LongInt(Empty));
 193   SendMessage(HEdit,EM_SetModify,0,0);
 194 End;
 195
 196 {********************************************************************}
 197
 198 procedure SelectFont;
 199 var
 200   ChooseFontRec : TChooseFont;
 201 begin
 202   with ChooseFontRec do
 203     begin
 204       lStructSize    := SizeOf(ChooseFontRec);
 205       hwndOwner      := HWindow;
 206       hDC            := 0;
 207       lpLogFont      := @TheLogFont;
 208       iPointSize     := 0;
 209       Flags          := CF_INITTOLOGFONTSTRUCT or CF_SCREENFONTS or CF_EFFECTS;
 210       rgbColors      := TheColor;
 211       lCustData      := 0;
 212       lpfnHook       := nil;
 213       lpTemplateName := nil;
 214       hInstance      := 0;
 215       lpszStyle      := nil;
 216       nFontType      := 0;
 217       nSizeMin       := 0;
 218       nSizeMax       := 0;
 219     end;
 220   if ChooseFont(@ChooseFontRec) then
 221     begin
 222       DeleteObject(TheFont);
 223       TheColor := ChooseFontRec.rgbColors;
 224       TheFont  := CreateFontIndirect(@TheLogFont);
 225       SendMessage(HEdit,WM_SETFONT,TheFont,1);
 226     end;
 227 end;
 228
 229 {********************************************************************}
 230
 231 Function WindowProc (Window:HWnd;AMessage,WParam,LParam:Longint): Longint;
 232 stdcall; export;
 233 Var
 234   R        : rect;
 235   StatH    : Word;
 236   NrMenu   : Longint;
 237   NotiCode : LongInt;
 238 Begin
 239   WindowProc := 0;
 240   Case AMessage Of
 241     wm_Close:
 242       Begin
 243         AskSave;
 244       End;
 245     wm_Destroy:
 246       Begin
 247         PostQuitMessage (0);
 248         Exit;
 249       End;
 250     wm_SetFocus:
 251       Begin
 252         SetFocus(HEdit);
 253       End;
 254     WM_EraseBkgnd:
 255       Begin
 256         Exit(1);
 257       End;
 258     wm_Size:
 259       Begin
 260         GetClientRect(HStatus,@R);
 261         StatH := R.Bottom-R.Top;
 262         GetClientRect(Window,@R);
 263         MoveWindow (HEdit,0,0,R.Right,R.Bottom-StatH,False);
 264         MoveWindow (HStatus,0,R.Bottom-StatH,R.Right,R.Bottom,False);
 265       End;
 266     wm_Command:
 267       Begin
 268         NotiCode := HiWord(WParam);
 269         Case NotiCode of
 270           en_Change     : //Editor has changed
 271             Begin
 272               If SendMessage(HEdit,EM_GetModify,0,0)<>0 then
 273                 SetStatusText(1,'Modified')
 274               Else
 275                 SetStatusText(1,'');
 276             End;
 277           Else
 278             Begin //Menu item
 279               NrMenu := LoWord(WParam);
 280               Case NrMenu Of
 281                 101 : NewText;
 282                 102 : LoadText;
 283                 103 : SaveText;
 284                 104 : PostMessage(Window,WM_Close,0,0);
 285                 201 : SendMessage(HEdit,WM_Undo,0,0);
 286                 202 : SendMessage(HEdit,WM_Cut,0,0);
 287                 203 : SendMessage(HEdit,WM_Copy,0,0);
 288                 204 : SendMessage(HEdit,WM_Paste,0,0);
 289                 301 : SelectFont;
 290                 401 : MessageBox(Window,'Help','Not implemented',
 291                                  MB_OK Or MB_IconInformation);
 292               End;
 293             End;
 294         End;
 295       End;
 296     wm_CtlColorEdit :
 297       Begin
 298         SetTextColor(WParam,TheColor);
 299         Exit(GetSysColorBrush(COLOR_WINDOW));
 300       End;
 301   End;
 302   WindowProc := DefWindowProc(Window,AMessage,WParam,LParam);
 303 End;
 304
 305 {********************************************************************}
 306
 307 Function WinRegister: Boolean;
 308 Var
 309   WindowClass : WndClass;
 310 Begin
 311   With WindowClass Do
 312     Begin
 313       Style         := cs_hRedraw Or cs_vRedraw;
 314       lpfnWndProc   := WndProc(@WindowProc);
 315       cbClsExtra    := 0;
 316       cbWndExtra    := 0;
 317       hInstance     := system.MainInstance;
 318       hIcon         := LoadIcon (0,idi_Application);
 319       hCursor       := LoadCursor (0,idc_Arrow);
 320       hbrBackground := GetStockObject(GRAY_BRUSH);
 321       lpszMenuName  := Nil;
 322       lpszClassName := AppName;
 323     End;
 324   WinRegister := RegisterClass (WindowClass)<>0;
 325 End;
 326
 327 {********************************************************************}
 328
 329 Function EditCreate(ParentWindow,Status:HWnd): HWnd;
 330 Const
 331   CS_Start = WS_Child or WS_HScroll or WS_VScroll or ES_MultiLine or ES_Left;
 332   CS_Ex    = WS_EX_ClientEdge;
 333   EdiTText : PChar = '';
 334 Var
 335   HEdit : HWND;
 336   R     : TRect;
 337   StatH : Word;
 338 Begin
 339   GetClientRect(Status,@R);
 340   StatH := R.Bottom-R.Top;
 341   GetClientRect(ParentWindow,@R);
 342   HEdit := CreateWindowEx (CS_Ex,'EDIT',EditText,CS_Start,0,0,
 343                            R.Right-R.Left,R.Bottom-R.Top-StatH,ParentWindow,0,
 344                            MainInstance,Nil);
 345   If HEdit<>0 Then
 346     Begin
 347       //Set Courier new as default font
 348       with TheLogFont do
 349         begin
 350           lfHeight         := 0;                // Default logical height of font
 351           lfWidth          := 0;                // Default logical average character width
 352           lfEscapement     := 0;                // angle of escapement
 353           lfOrientation    := 0;                // base-line orientation angle
 354           lfWeight         := FW_NORMAL;        // font weight
 355           lfItalic         := 0;                // italic attribute flag
 356           lfUnderline      := 0;                // underline attribute flag
 357           lfStrikeOut      := 0;                // strikeout attribute flag
 358           lfCharSet        := DEFAULT_CHARSET;  // character set identifier
 359           lfOutPrecision   := OUT_DEFAULT_PRECIS;  // output precision
 360           lfClipPrecision  := CLIP_DEFAULT_PRECIS; // clipping precision
 361           lfQuality        := DEFAULT_QUALITY;     // output quality
 362           lfPitchAndFamily := DEFAULT_PITCH;    // pitch and family
 363           Strcopy(lfFaceName,'Courier New');    // pointer to typeface name string
 364         end;
 365       TheColor := GetSysColor(COLOR_WINDOWTEXT);
 366       TheFont  := CreateFontIndirect(@TheLogFont);
 367       SendMessage(HEdit,WM_SETFONT,TheFont,1);
 368       ShowWindow(Hedit,SW_Show);
 369       UpdateWindow(HEdit);
 370     End;
 371   EditCreate := HEdit;
 372 End;
 373
 374 {********************************************************************}
 375
 376 Function WinCreate: HWnd;
 377
 378 Var hWindow : HWnd;
 379     Menu    : hMenu;
 380     SubMenu : hMenu;
 381 Begin
 382   hWindow := CreateWindow (AppName,'EditDemo',ws_OverlappedWindow,
 383                            cw_UseDefault,cw_UseDefault,cw_UseDefault,
 384                            cw_UseDefault,0,0,MainInstance,Nil);
 385   If hWindow<>0 Then
 386     Begin
 387       Menu := CreateMenu;
 388       SubMenu := CreateMenu;
 389       AppendMenu(Submenu,MF_STRING,101,'&New...');
 390       AppendMenu(Submenu,MF_STRING,102,'&Open...');
 391       AppendMenu(Submenu,MF_STRING,103,'&Save...');
 392       AppendMenu(Submenu,MF_SEPARATOR,0,Nil);
 393       AppendMenu(SubMenu,MF_String,104,'E&xit');
 394       AppendMenu(Menu,MF_POPUP,SubMenu,'&File');
 395       SubMenu := CreateMenu;
 396       AppendMenu(SubMenu,MF_String,201,'&Undo'#8'Ctrl+Z');
 397       AppendMenu(Submenu,MF_SEPARATOR,0,Nil);
 398       AppendMenu(SubMenu,MF_String,202,'&Cut'#8'Ctrl+X');
 399       AppendMenu(SubMenu,MF_String,203,'&Copy'#8'Ctrl+C');
 400       AppendMenu(SubMenu,MF_STRING,204,'&Paste'#8'Ctrl+V');
 401       AppendMenu(Menu,MF_POPUP,SubMenu,'&Edit');
 402       SubMenu := CreateMenu;
 403       AppendMenu(SubMenu,MF_String,301,'&Font...');
 404       AppendMenu(Menu,MF_POPUP,SubMenu,'&Options');
 405       AppendMenu(Menu,MF_STRING,401,'&Help');
 406       SetMenu(hWindow,menu);
 407       ShowWindow(hWindow,SW_Show);
 408       UpdateWindow(hWindow);
 409     End;
 410   WinCreate := hWindow;
 411 End;
 412
 413 {********************************************************************}
 414
 415 Function StatusCreate (parent:hwnd): HWnd;
 416 var
 417   AWnd   : HWnd;
 418   Edges  : array[1..2] of LongInt;
 419 Begin
 420   FileName := 'Unsaved';
 421   AWnd := CreateStatusWindow(WS_CHILD or WS_VISIBLE,FileName,Parent,$7712);
 422   // Create items:
 423   if AWnd <> 0 then
 424     begin
 425       Edges[1] := 400;
 426       Edges[2] := 500;
 427       SendMessage(AWnd,SB_SETPARTS,2,LongInt(@Edges));
 428     end;
 429   StatusCreate := AWnd;
 430 End;
 431
 432 {********************************************************************}
 433
 434 Begin
 435   If Not WinRegister Then
 436     Begin
 437       MessageBox (0,'Register failed',Nil, mb_Ok);
 438     End
 439   Else
 440     Begin
 441       hWindow := WinCreate;
 442       If longint(hWindow)=0 Then
 443         Begin
 444           MessageBox (0,'WinCreate failed',Nil,MB_OK);
 445         End
 446       Else
 447         Begin
 448           HStatus := statuscreate(hwindow);
 449           HEdit := EditCreate(HWindow,HStatus);
 450           SetFocus(HEdit);
 451           While GetMessage(@AMessage,0,0,0) Do
 452             Begin
 453               TranslateMessage(AMessage);
 454               DispatchMessage(AMessage);
 455             End;
 456           DeleteObject(TheFont);
 457           Halt(AMessage.wParam);
 458         End;
 459     End;
 460 End.
 461
 462 {
 463   $Log$
 464   Revision 1.1  2002/02/19 08:24:25  sasu
 465   Initial revision
 466
 467   Revision 1.1  2000/07/13 06:30:20  michael
 468   + Initial import
 469
 470   Revision 1.3  2000/07/11 08:51:05  michael
 471   + Fixed Font handling
 472
 473   Revision 1.2  2000/02/27 21:07:58  florian
 474     * updated version from Goran and Morton
 475
 476   Revision 1.1  2000/02/20 20:33:37  florian
 477     * Initial revision
 478
 479 }