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

   1 {   $Id$
   2   Copyright (c) 1999 by Michael van Canneyt
   3
   4   Win32 menu creation example.
   5 }
   6
   7 { Changes by G”ran Andersson:                                  major
   8   const FileMenus[] removed
   9   const filename removed
  10   type TFileName added
  11   SelectFile() added                                           *
  12   LoadText() added                                             *
  13   SaveText():
  14     SelectFile used                                            *
  15     uses GetWindowTextLength & GetWindowText
  16     also saves empty files
  17     uses untyped file
  18     FreeMem frees Len+1, not Len
  19   AskSave() added                                              *
  20   NewText() added                                              *
  21   WindowProc():
  22     WM_Close added
  23     WM_Size don't assumes StatH=16
  24     WM_Command 101 calls NewText
  25     WM_Command 102 calls LoadText
  26     WM_Command 104 issues a WM_Close instead of doing a Halt
  27   WinRegister():
  28     with structure used
  29   EditCreate():
  30     takes Status object as parameter
  31     const EditText changed to empty string
  32     unused variable DC removed
  33     WS_HScroll & WS_VScroll added to const CS_Start
  34     ES_AutoHScroll & ES_AutoVScroll removed from CS_Start
  35     don't assumes StatH=16
  36     AddText() commented out
  37   WinCreate():
  38     menu creation moved inside if structure
  39     Options menu item uses the newly created SubMenu
  40   main:
  41     slight structure change (avoid unneccesary Exit)
  42     call to StatusCreate before EditCreate
  43
  44 2do:
  45   make edit panel always active
  46   add 3d inner bevel to edit panel
  47   window background color : white
  48   only ask to save if edited
  49   cut
  50   copy
  51   paste
  52   settings
  53   help
  54 }
  55
  56 Program menudemo;
  57 {$APPTYPE GUI}
  58 {$MODE DELPHI}
  59
  60 Uses Strings,Windows;
  61
  62 Const AppName = 'MenuDemo';
  63
  64 Var AMessage: Msg;
  65     hWindow,hStatus,Hedit: HWnd;
  66     WindowClass: WndClass;
  67     Menu: hMenu;
  68
  69 Const
  70   EditMenus: Array[201..203] Of pchar = ('Cut','copy','paste');
  71
  72 Type
  73   TFileName = Array[0..Max_Path] Of Char;
  74
  75 Function SelectFile(Var FName:TFileName; Open:Boolean): Boolean;
  76
  77 Const
  78   Filter: PChar = 'Text files (*.txt)'#0'*.txt'#0'All files (*.*)'#0'*.*'#0;
  79   Ext: PChar = 'txt';
  80
  81 Var
  82   NameRec: OpenFileName;
  83 Begin
  84   FillChar(NameRec,SizeOf(NameRec),0);
  85   FName[0] := #0;
  86   With NameRec Do
  87     Begin
  88       LStructSize := SizeOf(NameRec);
  89       HWndOwner := HWindow;
  90       LpStrFilter := Filter;
  91       LpStrFile := @FName;
  92       NMaxFile := Max_Path;
  93       Flags := OFN_Explorer Or OFN_HideReadOnly;
  94       If Open Then
  95         Begin
  96           Flags := Flags Or OFN_FileMustExist;
  97         End;
  98       LpStrDefExt := Ext;
  99     End;
 100   If Open Then
 101       SelectFile := GetOpenFileName(@NameRec)
 102   Else
 103       SelectFile := GetSaveFileName(@NameRec);
 104 End;
 105
 106 Procedure SaveText;
 107
 108 Var Len: Longint;
 109     P: PChar;
 110     F: File;
 111     FName: TFileName;
 112 Begin
 113   If SelectFile(FName,False) Then
 114     Begin
 115       Assign(F,@FName);
 116       Rewrite(F,1);
 117       Len := GetWindowTextLength(HEdit);
 118       GetMem(P,Len+1);
 119       P[Len] := #0;
 120       If Len>0 Then
 121         Begin
 122           GetWindowText(HEdit,P,Len+1);
 123           BlockWrite(F,P^,Len);
 124         End;
 125       Close(F);
 126       FreeMem(P,Len+1);
 127     End;
 128 End;
 129
 130 Procedure AskSave;
 131 Begin
 132   If MessageBox(HWindow,'Save text?','Edited',MB_IconQuestion Or MB_YesNo)=IdYes Then
 133     Begin
 134       SaveText;
 135     End;
 136 End;
 137
 138 Procedure LoadText;
 139
 140 Var
 141   FName: TFileName;
 142   F: File;
 143   Len: LongInt;
 144   P: PChar;
 145 Begin
 146   AskSave;
 147   If SelectFile(FName,True) Then
 148     Begin
 149       Assign(F,@FName);
 150       Reset(F,1);
 151       Len := FileSize(F);
 152       GetMem(P,Len+1);
 153       P[Len] := #0;
 154       If Len>0 Then BlockRead(F,P^,Len);
 155       Close(F);
 156       SetWindowText(HEdit,P);
 157       FreeMem(P,Len+1);
 158     End;
 159 End;
 160
 161 Procedure NewText;
 162
 163 Const
 164   Empty: PChar = '';
 165 Begin
 166   AskSave;
 167   SendMessage(HEdit,WM_SetText,1,LongInt(Empty));
 168 End;
 169
 170 Function WindowProc (Window:HWnd;AMessage,WParam,LParam:Longint): Longint;
 171 stdcall;
 172 export;
 173
 174 Var ps: paintstruct;
 175     r: rect;
 176     StatH: Word;
 177     nrmenu : longint;
 178 Begin
 179   WindowProc := 0;
 180   Case AMessage Of
 181     wm_Paint:
 182               Begin
 183                 BeginPaint(Window,@ps);
 184                 GetClientRect(Window,@r);
 185                 EndPaint(Window,ps);
 186                 Exit;
 187               End;
 188     wm_Close:
 189               Begin
 190                 AskSave;
 191               End;
 192     wm_Destroy:
 193                 Begin
 194                   PostQuitMessage (0);
 195                   Exit;
 196                 End;
 197     wm_Size:
 198              Begin
 199                GetClientRect(HStatus,@R);
 200                StatH := R.Bottom-R.Top;
 201                GetClientRect(Window,@R);
 202                MoveWindow (hStatus,r.left,r.bottom-StatH,r.right,r.bottom,true);
 203                MoveWindow (HEdit,0,0,r.right-r.left,r.bottom-r.top-StatH,true);
 204              End;
 205     wm_Command:
 206                 Begin
 207                   NrMenu := WParam And $FFFF;
 208                   Case NrMenu Of
 209                     101 : NewText;
 210                     102 : LoadText;
 211                     103 : SaveText;
 212                     104 : PostMessage(Window,WM_Close,0,0);
 213                     201..203: MessageBox(Window,EditMenus[NrMenu],
 214                                          'Edit operation not implemented',MB_OK Or
 215                                          MB_IconInformation);
 216                   End;
 217                 End;
 218   End;
 219   WindowProc := DefWindowProc(Window,AMessage,WParam,LParam);
 220 End;
 221
 222 Function WinRegister: Boolean;
 223 Begin
 224   With WindowClass Do
 225     Begin
 226       Style := cs_hRedraw Or cs_vRedraw;
 227       lpfnWndProc := WndProc(@WindowProc);
 228       cbClsExtra := 0;
 229       cbWndExtra := 0;
 230       hInstance := system.MainInstance;
 231       hIcon := LoadIcon (0,idi_Application);
 232       hCursor := LoadCursor (0,idc_Arrow);
 233       hbrBackground := GetStockObject(GRAY_BRUSH);
 234       lpszMenuName := 'Files';
 235       lpszClassName := AppName;
 236     End;
 237   Result := RegisterClass (WindowClass)<>0;
 238 End;
 239
 240 Function EditCreate(ParentWindow,Status:HWnd): HWnd;
 241
 242 Const
 243   CS_Start = WS_Child or WS_HScroll or WS_VScroll or ES_MultiLine or ES_Left;
 244   EdiTText: PChar = '';
 245
 246 Var
 247   HEdit: HWND;
 248   R: TRect;
 249   StatH: Word;
 250 {                                             rev 1.5 : comment out
 251   Procedure AddText (S:String);
 252   begin
 253     S:=S+#0;
 254     SendMessage(HEdit,em_replacesel,0,longint(pchar(@S[1])));
 255   end;
 256 }
 257 Begin
 258   GetClientRect(Status,@R);
 259   StatH := R.Bottom-R.Top;
 260   GetClientRect(ParentWindow,@R);
 261   HEdit := CreateWindow ('EDIT',EditText,CS_Start,0,0,
 262                        R.Right-R.Left,R.Bottom-R.top-StatH,ParentWindow,0,
 263                        System.MainInstance,Nil);
 264   If HEdit<>0 Then
 265     Begin
 266       ShowWindow(Hedit,cmdShow);
 267       UpdateWindow(HEdit);
 268     End;
 269   Result := HEdit;
 270 End;
 271
 272 Function WinCreate: HWnd;
 273
 274 Var hWindow: HWnd;
 275     SubMenu: hMenu;
 276 Begin
 277   hWindow := CreateWindow (AppName,'MenuDemo',ws_OverlappedWindow,
 278                          cw_UseDefault,cw_UseDefault,cw_UseDefault,
 279                          cw_UseDefault,0,0,system.MainInstance,Nil);
 280   If hWindow<>0 Then
 281     Begin
 282       Menu := CreateMenu;
 283       SubMenu := CreateMenu;
 284       AppendMenu(Submenu,MF_STRING,101,'&New...');
 285       AppendMenu(Submenu,MF_STRING,102,'&Open...');
 286       AppendMenu(Submenu,MF_STRING,103,'&Save...');
 287       AppendMenu(Submenu,MF_SEPARATOR,0,Nil);
 288       AppendMenu(SubMenu,MF_String,104,'E&xit');
 289       AppendMenu(Menu,MF_POPUP,SubMenu,'&Files');
 290       SubMenu := CreateMenu;
 291       AppendMenu(SubMenu,MF_String,201,'&Cut');
 292       AppendMenu(SubMenu,MF_String,202,'&Copy');
 293       AppendMenu(SubMenu,MF_STRING,203,'&Paste');
 294       AppendMenu(Menu,MF_POPUP,SubMenu,'&Edit');
 295       SubMenu := CreateMenu;
 296       AppendMenu(SubMenu,MF_String,301,'&Settings');
 297       AppendMenu(Menu,MF_POPUP,SubMenu,'&Options');
 298       AppendMenu(Menu,MF_STRING,0,'&Help');
 299       SetMenu(hWindow,menu);
 300       ShowWindow(hWindow,CmdShow);
 301       UpdateWindow(hWindow);
 302     End;
 303   Result := hWindow;
 304 End;
 305
 306 Function StatusCreate (parent:hwnd): HWnd;
 307 Begin
 308   StatusCreate := CreateStatusWindow (WS_CHILD Or WS_VISIBLE,'Ready...',parent,$7712);
 309 End;
 310
 311 Begin
 312   If Not WinRegister Then
 313     Begin
 314       MessageBox (0,'Register failed',Nil, mb_Ok);
 315     End
 316   Else
 317     Begin
 318       hWindow := WinCreate;
 319       If longint(hWindow)=0 Then
 320         Begin
 321           MessageBox (0,'WinCreate failed',Nil,MB_OK);
 322         End
 323       Else
 324         Begin
 325           HStatus := statuscreate(hwindow);
 326           HEdit := EditCreate(HWindow,HStatus);
 327           While GetMessage(@AMessage,0,0,0) Do
 328           Begin
 329             TranslateMessage(AMessage);
 330             DispatchMessage(AMessage);
 331           End;
 332           Halt(AMessage.wParam);
 333         End;
 334     End;
 335 End.
 336
 337 {
 338   $Log$
 339   Revision 1.1  2002/02/19 08:24:26  sasu
 340   Initial revision
 341
 342   Revision 1.1  2000/07/13 06:30:21  michael
 343   + Initial import
 344
 345   Revision 1.7  2000/01/21 00:44:51  peter
 346     * remove unused vars
 347     * renamed to .pp
 348
 349   Revision 1.6  1999/08/10 08:21:45  michael
 350   + Log keyword placement correction.
 351
 352   Revision 1.5  1999/08/10 08:20:49  michael
 353    + Enhancements by Göran Andersson
 354
 355   Revision 1.4  1999/07/16 12:20:57  michael
 356   + Added saving in fixed file
 357
 358   Revision 1.3  1999/06/28 16:15:11  peter
 359     * fixed dup id
 360
 361   Revision 1.2  1999/05/03 18:04:39  peter
 362     * updates
 363
 364 }