home *** CD-ROM | disk | FTP | other *** search
/ PC World 2003 February / PCWorld_2003-02_cd.bin / Software / Topware / devpascal / examples / WinMenu / Menu.pp next >
Encoding:
Text File  |  2000-09-13  |  7.7 KB  |  309 lines
  1. {   $Id: menu.pp,v 1.7 2000/01/21 00:44:51 peter Exp $
  2.   Copyright (c) 1999 by Michael van Canneyt
  3.  
  4.   Win32 menu creation example.
  5. }
  6.  
  7. program MenuDemo;
  8. {$MODE DELPHI}
  9.  
  10. Uses Strings,Windows;
  11.  
  12. Const AppName = 'MenuDemo';
  13.  
  14. Var AMessage: Msg;
  15.     hWindow,hStatus,Hedit: HWnd;
  16.     WindowClass: WndClass;
  17.     Menu: hMenu;
  18.  
  19. Const
  20.   EditMenus: Array[201..203] Of pchar = ('Cut','copy','paste');
  21.  
  22. Type
  23.   TFileName = Array[0..Max_Path] Of Char;
  24.  
  25. Function SelectFile(Var FName:TFileName; Open:Boolean): Boolean;
  26.  
  27. Const
  28.   Filter: PChar = 'Text files (*.txt)'#0'*.txt'#0'All files (*.*)'#0'*.*'#0;
  29.   Ext: PChar = 'txt';
  30.  
  31. Var
  32.   NameRec: OpenFileName;
  33. Begin
  34.   FillChar(NameRec,SizeOf(NameRec),0);
  35.   FName[0] := #0;
  36.   With NameRec Do
  37.     Begin
  38.       LStructSize := SizeOf(NameRec);
  39.       HWndOwner := HWindow;
  40.       LpStrFilter := Filter;
  41.       LpStrFile := @FName;
  42.       NMaxFile := Max_Path;
  43.       Flags := OFN_Explorer Or OFN_HideReadOnly;
  44.       If Open Then
  45.         Begin
  46.           Flags := Flags Or OFN_FileMustExist;
  47.         End;
  48.       LpStrDefExt := Ext;
  49.     End;
  50.   If Open Then
  51.       SelectFile := GetOpenFileName(@NameRec)
  52.   Else
  53.       SelectFile := GetSaveFileName(@NameRec);
  54. End;
  55.  
  56. Procedure SaveText;
  57.  
  58. Var Len: Longint;
  59.     P: PChar;
  60.     F: File;
  61.     FName: TFileName;
  62. Begin
  63.   If SelectFile(FName,False) Then
  64.     Begin
  65.       Assign(F,@FName);
  66.       Rewrite(F,1);
  67.       Len := GetWindowTextLength(HEdit);
  68.       GetMem(P,Len+1);
  69.       P[Len] := #0;
  70.       If Len>0 Then
  71.         Begin
  72.           GetWindowText(HEdit,P,Len+1);
  73.           BlockWrite(F,P^,Len);
  74.         End;
  75.       Close(F);
  76.       FreeMem(P,Len+1);
  77.     End;
  78. End;
  79.  
  80. Procedure AskSave;
  81. Begin
  82.   If MessageBox(HWindow,'Save text?','Edited',MB_IconQuestion Or MB_YesNo)=IdYes Then
  83.     Begin
  84.       SaveText;
  85.     End;
  86. End;
  87.  
  88. Procedure LoadText;
  89.  
  90. Var
  91.   FName: TFileName;
  92.   F: File;
  93.   Len: LongInt;
  94.   P: PChar;
  95. Begin
  96.   AskSave;
  97.   If SelectFile(FName,True) Then
  98.     Begin
  99.       Assign(F,@FName);
  100.       Reset(F,1);
  101.       Len := FileSize(F);
  102.       GetMem(P,Len+1);
  103.       P[Len] := #0;
  104.       If Len>0 Then BlockRead(F,P^,Len);
  105.       Close(F);
  106.       SetWindowText(HEdit,P);
  107.       FreeMem(P,Len+1);
  108.     End;
  109. End;
  110.  
  111. Procedure NewText;
  112.  
  113. Const
  114.   Empty: PChar = '';
  115. Begin
  116.   AskSave;
  117.   SendMessage(HEdit,WM_SetText,1,LongInt(Empty));
  118. End;
  119.  
  120. Function WindowProc (Window:HWnd;AMessage,WParam,LParam:Longint): Longint;
  121. stdcall;
  122. export;
  123.  
  124. Var ps: paintstruct;
  125.     r: rect;
  126.     StatH: Word;
  127.     nrmenu : longint;
  128. Begin
  129.   WindowProc := 0;
  130.   Case AMessage Of
  131.     wm_Paint:
  132.               Begin
  133.                 BeginPaint(Window,@ps);
  134.                 GetClientRect(Window,@r);
  135.                 EndPaint(Window,ps);
  136.                 Exit;
  137.               End;
  138.     wm_Close:
  139.               Begin
  140.                 AskSave;
  141.               End;
  142.     wm_Destroy:
  143.                 Begin
  144.                   PostQuitMessage (0);
  145.                   Exit;
  146.                 End;
  147.     wm_Size:
  148.              Begin
  149.                GetClientRect(HStatus,@R);
  150.                StatH := R.Bottom-R.Top;
  151.                GetClientRect(Window,@R);
  152.                MoveWindow (hStatus,r.left,r.bottom-StatH,r.right,r.bottom,true);
  153.                MoveWindow (HEdit,0,0,r.right-r.left,r.bottom-r.top-StatH,true);
  154.              End;
  155.     wm_Command:
  156.                 Begin
  157.                   NrMenu := WParam And $FFFF;
  158.                   Case NrMenu Of
  159.                     101 : NewText;
  160.                     102 : LoadText;
  161.                     103 : SaveText;
  162.                     104 : PostMessage(Window,WM_Close,0,0);
  163.                     201..203: MessageBox(Window,EditMenus[NrMenu],
  164.                                          'Edit operation not implemented',MB_OK Or
  165.                                          MB_IconInformation);
  166.                   End;
  167.                 End;
  168.   End;
  169.   WindowProc := DefWindowProc(Window,AMessage,WParam,LParam);
  170. End;
  171.  
  172. Function WinRegister: Boolean;
  173. Begin
  174.   With WindowClass Do
  175.     Begin
  176.       Style := cs_hRedraw Or cs_vRedraw;
  177.       lpfnWndProc := WndProc(@WindowProc);
  178.       cbClsExtra := 0;
  179.       cbWndExtra := 0;
  180.       hInstance := system.MainInstance;
  181.       hIcon := LoadIcon (0,idi_Application);
  182.       hCursor := LoadCursor (0,idc_Arrow);
  183.       hbrBackground := GetStockObject(GRAY_BRUSH);
  184.       lpszMenuName := 'Files';
  185.       lpszClassName := AppName;
  186.     End;
  187.   Result := RegisterClass (WindowClass)<>0;
  188. End;
  189.  
  190. Function EditCreate(ParentWindow,Status:HWnd): HWnd;
  191.  
  192. Const
  193.   CS_Start = WS_Child or WS_HScroll or WS_VScroll or ES_MultiLine or ES_Left;
  194.   EdiTText: PChar = '';
  195.  
  196. Var
  197.   HEdit: HWND;
  198.   R: TRect;
  199.   StatH: Word;
  200. {                                             rev 1.5 : comment out
  201.   Procedure AddText (S:String);
  202.   begin
  203.     S:=S+#0;
  204.     SendMessage(HEdit,em_replacesel,0,longint(pchar(@S[1])));
  205.   end;
  206. }
  207. Begin
  208.   GetClientRect(Status,@R);
  209.   StatH := R.Bottom-R.Top;
  210.   GetClientRect(ParentWindow,@R);
  211.   HEdit := CreateWindow ('EDIT',EditText,CS_Start,0,0,
  212.                        R.Right-R.Left,R.Bottom-R.top-StatH,ParentWindow,0,
  213.                        System.MainInstance,Nil);
  214.   If HEdit<>0 Then
  215.     Begin
  216.       ShowWindow(Hedit,cmdShow);
  217.       UpdateWindow(HEdit);
  218.     End;
  219.   Result := HEdit;
  220. End;
  221.  
  222. Function WinCreate: HWnd;
  223.  
  224. Var hWindow: HWnd;
  225.     SubMenu: hMenu;
  226. Begin
  227.   hWindow := CreateWindow (AppName,'MenuDemo',ws_OverlappedWindow,
  228.                          cw_UseDefault,cw_UseDefault,cw_UseDefault,
  229.                          cw_UseDefault,0,0,system.MainInstance,Nil);
  230.   If hWindow<>0 Then
  231.     Begin
  232.       Menu := CreateMenu;
  233.       SubMenu := CreateMenu;
  234.       AppendMenu(Submenu,MF_STRING,101,'&New...');
  235.       AppendMenu(Submenu,MF_STRING,102,'&Open...');
  236.       AppendMenu(Submenu,MF_STRING,103,'&Save...');
  237.       AppendMenu(Submenu,MF_SEPARATOR,0,Nil);
  238.       AppendMenu(SubMenu,MF_String,104,'E&xit');
  239.       AppendMenu(Menu,MF_POPUP,SubMenu,'&Files');
  240.       SubMenu := CreateMenu;
  241.       AppendMenu(SubMenu,MF_String,201,'&Cut');
  242.       AppendMenu(SubMenu,MF_String,202,'&Copy');
  243.       AppendMenu(SubMenu,MF_STRING,203,'&Paste');
  244.       AppendMenu(Menu,MF_POPUP,SubMenu,'&Edit');
  245.       SubMenu := CreateMenu;
  246.       AppendMenu(SubMenu,MF_String,301,'&Settings');
  247.       AppendMenu(Menu,MF_POPUP,SubMenu,'&Options');
  248.       AppendMenu(Menu,MF_STRING,0,'&Help');
  249.       SetMenu(hWindow,menu);
  250.       ShowWindow(hWindow,CmdShow);
  251.       UpdateWindow(hWindow);
  252.     End;
  253.   Result := hWindow;
  254. End;
  255.  
  256. Function StatusCreate (parent:hwnd): HWnd;
  257. Begin
  258.   StatusCreate := CreateStatusWindow (WS_CHILD Or WS_VISIBLE,'Ready...',parent,$7712);
  259. End;
  260.  
  261. Begin
  262.   If Not WinRegister Then
  263.     Begin
  264.       MessageBox (0,'Register failed',Nil, mb_Ok);
  265.     End
  266.   Else
  267.     Begin
  268.       hWindow := WinCreate;
  269.       If longint(hWindow)=0 Then
  270.         Begin
  271.           MessageBox (0,'WinCreate failed',Nil,MB_OK);
  272.         End
  273.       Else
  274.         Begin
  275.           HStatus := statuscreate(hwindow);
  276.           HEdit := EditCreate(HWindow,HStatus);
  277.           While GetMessage(@AMessage,0,0,0) Do
  278.           Begin
  279.             TranslateMessage(AMessage);
  280.             DispatchMessage(AMessage);
  281.           End;
  282.           Halt(AMessage.wParam);
  283.         End;
  284.     End;
  285. End.
  286.  
  287. {
  288.   $Log: menu.pp,v $
  289.   Revision 1.7  2000/01/21 00:44:51  peter
  290.     * remove unused vars
  291.     * renamed to .pp
  292.  
  293.   Revision 1.6  1999/08/10 08:21:45  michael
  294.   + Log keyword placement correction.
  295.  
  296.   Revision 1.5  1999/08/10 08:20:49  michael
  297.    + Enhancements by G÷ran Andersson
  298.  
  299.   Revision 1.4  1999/07/16 12:20:57  michael
  300.   + Added saving in fixed file
  301.  
  302.   Revision 1.3  1999/06/28 16:15:11  peter
  303.     * fixed dup id
  304.  
  305.   Revision 1.2  1999/05/03 18:04:39  peter
  306.     * updates
  307.  
  308. }
  309.