home *** CD-ROM | disk | FTP | other *** search
/ Stars of Shareware: Programmierung / SOURCE.mdf / programm / windows / c / mobjm260 / winmenu.pa_ / winmenu.pa
Encoding:
Text File  |  1994-09-06  |  11.2 KB  |  345 lines
  1. (*********************************************************************)
  2. (*                                                                   *)
  3. (*          Microworks ObjectMate 2.52                                                        *)
  4. (*                                                                   *)
  5. (*     Windows Interface Develpment Kit for the Borland Languages.   *)
  6. (*                                                                   *)
  7. (*         WINMENU.PAS : 3D Ownerdraw menu demonstration                     *)
  8. (*                                                                                                                             *)
  9. (*     Copyright 1992-94 Microworks Sydney, Australia.                 *)
  10. (*                                                                   *)
  11. (*********************************************************************)
  12.  
  13. (* WinMenu implements 3-dimensional ownerdraw menu's that let you change the
  14.  * menu text font and highlight and text highlight colors.
  15.  *)
  16.  
  17. program WinMenu;
  18.  
  19. uses WinTypes, WinProcs, CommDlg, ODMenu, SFX200,
  20.          {$IFDEF Ver15}
  21.              WObjects;
  22.          {$ELSE}
  23.              Objects, OWindows, ODialogs;
  24.          {$ENDIF}
  25.  
  26. {$R Winmenu.res}
  27.  
  28. const
  29.  
  30.     {*** Menu Item ID's ***}
  31.     CM_ITEM1           = 101;
  32.     CM_ITEM2           = 102;
  33.     CM_ITEM3        = 103;
  34.     CM_ITEM4        = 104;
  35.     CM_EXIT         = 105;
  36.     CM_FONT         = 106;
  37.     CM_COLOR        = 107;
  38.     CM_COLORTEXT    = 109;
  39.     CM_ABOUT        = 110;
  40.     AppName : PChar = 'MenuWindow';
  41.  
  42. type
  43.  
  44.     PAboutDialog = ^TAboutDialog;
  45.     TAboutDialog = object(TDialog)
  46.         procedure SetupWindow; virtual;
  47.     end;
  48.  
  49.     PMenuWindow = ^TMenuWindow;
  50.     TMenuWindow = object(TSFXWindow)
  51.         Font      : HFont;
  52.         Color     : LongInt;
  53.         TextColor : LongInt;
  54.         LogFont   : TLogFont;
  55.         Menu      : HMenu;
  56.         SubMenu   : HMenu;
  57.         constructor Init(AParent: PWindowsObject; AName: PChar);
  58.         destructor Done; virtual;
  59.         function  GetClassName : PChar; virtual;
  60.         procedure GetWindowClass(var AWndClass: TWndClass); virtual;
  61.         procedure SetUpWindow; virtual;
  62.         procedure Create3DMenus;
  63.         procedure WMCommand (var Msg: TMessage); virtual wm_First + wm_Command;
  64.         procedure WMMeasureItem (var Msg: TMessage); virtual wm_First + wm_MeasureItem;
  65.         procedure WMDrawItem (var Msg: TMessage); virtual wm_First + wm_DrawItem;
  66.         procedure WMMenuChar (var Msg: TMessage); virtual wm_First + wm_MenuChar;
  67.         procedure CMExitWindow (var Msg: TMessage); virtual cm_First + cm_Exit;
  68.         procedure CMFont (var Msg: TMessage); virtual cm_First + cm_Font;
  69.         procedure CMColor (var Msg: TMessage); virtual cm_First + cm_Color;
  70.         procedure CMColorText (var Msg: TMessage); virtual cm_First + cm_ColorText;
  71.         procedure CMAbout (var Msg: TMessage); virtual cm_First + cm_About;
  72.     end;
  73.  
  74.     PMenuApp = ^TMenuApp;
  75.     TMenuApp = object(TApplication)
  76.         procedure InitMainWindow; virtual;
  77.     end;
  78.  
  79. {********** TMenuApp **********}
  80.  
  81. procedure TMenuApp.InitMainWindow;
  82. begin
  83.     MainWindow := New(PMenuWindow, Init(nil, 'WinMenu - 3D Menu Demonstration'));
  84. end;
  85.  
  86. {********** TMenuWindow **********}
  87.  
  88. constructor TMenuWindow.Init(AParent: PWindowsObject; AName: PChar);
  89. begin
  90.     TSFXWindow.Init(AParent, AName);
  91.     {Attr.Style := Attr.Style or mws_SFXFrame or mws_SFXCaption;}
  92.     {Attr.Style := Attr.Style or mws_Raised3DFrame or mws_SFXCaption;}
  93.     {Attr.Style := Attr.Style or mws_Raised3DGlaze or mws_SFXCaption;}
  94.     Attr.Style := Attr.Style or mws_Raised3DSteel or mws_SFXCaption;
  95.     Attr.Menu := LoadMenu(HInstance, 'WinMenu');
  96.     Color := 0;
  97.     TextColor := 0;
  98.  
  99.     { Set up fine system font for menu items }
  100.     Font := GetStockObject(SYSTEM_FONT);
  101.     GetObject(Font, SizeOf(TLogFont), @LogFont);
  102.     LogFont.lfWeight := FW_NORMAL;
  103.     lstrcpy(LogFont.lfFaceName, 'MS Sans Serif');
  104.     Font := CreateFontIndirect(LogFont);
  105. end;
  106.  
  107. destructor TMenuWindow.Done;
  108. begin
  109.     EraseObject(Font);
  110.     TSFXWindow.Done;
  111. end;
  112.  
  113. function TMenuWindow.GetClassName;
  114. begin
  115.     GetClassName := AppName;
  116. end;
  117.  
  118. procedure TMenuWindow.GetWindowClass(var AWndClass: TWndClass);
  119. begin
  120.     TSFXWindow.GetWindowClass(AWndClass);
  121.     AWndclass.hIcon := LoadIcon(HInstance, 'WinMenu');
  122. end;
  123.  
  124. procedure TMenuWindow.SetUpWindow;
  125. begin
  126.     TSFXWindow.SetUpWindow;
  127.     Create3DMenus;
  128. end;
  129.  
  130. procedure TMenuWindow.Create3DMenus;
  131. begin
  132.     (* Since the system menu rarely gets modified, Set3DSystemMenu can be used to
  133.      * automatically set up a basic ownerdraw system menu.
  134.      *)
  135.     Set3DSystemMenu(HWindow, 'WinMenu');
  136.  
  137.     { Create popup submenu with ownerdraw items }
  138.     SubMenu := CreatePopupMenu;
  139.     AppendMenu(SubMenu, mf_OwnerDraw, CM_Item1, 'SubMenu Item &A');
  140.     AppendMenu(SubMenu, mf_OwnerDraw, CM_Item2, 'SubMenu Item &B');
  141.     AppendMenu(SubMenu, mf_OwnerDraw or mf_Checked, CM_Item3, 'SubMenu Item &C');
  142.     AppendMenu(SubMenu, mf_OwnerDraw, CM_Item4, 'SubMenu Item &D');
  143.  
  144.     { Modify main menu to display ownerdraw items }
  145.     Menu := GetSubMenu(Attr.Menu, 0);
  146.     ModifyMenu(Menu, 0, MF_BYPOSITION or MF_OWNERDRAW, CM_ITEM1, 'Menu Item &A');
  147.     ModifyMenu(Menu, 1, MF_BYPOSITION or MF_OWNERDRAW, CM_ITEM2, 'Menu Item &B');
  148.     ModifyMenu(Menu, 2, MF_BYPOSITION or MF_OWNERDRAW, CM_ITEM3, 'Menu Item &C');
  149.     ModifyMenu(Menu, 3, MF_BYPOSITION or MF_OWNERDRAW or MF_Checked, CM_ITEM4, 'Menu Item &D');
  150.     ModifyMenu(Menu, 5, MF_BYPOSITION or MF_OWNERDRAW, CM_Exit, '&Exit WinMenu');
  151.     Menu := GetSubMenu(Attr.Menu, 1);
  152.     ModifyMenu(Menu, 0, MF_BYPOSITION or MF_OWNERDRAW, CM_ITEM1, 'Menu Item &A');
  153.     ModifyMenu(Menu, 1, MF_BYPOSITION or MF_OWNERDRAW, CM_ITEM2, 'Menu Item &B');
  154.     ModifyMenu(Menu, 2, MF_BYPOSITION or MF_OWNERDRAW or MF_POPUP, SubMenu, '&Sub Menu');
  155.     ModifyMenu(Menu, 3, MF_BYPOSITION or MF_OWNERDRAW, CM_ITEM4, 'Menu Item &D');
  156.     Menu := GetSubMenu(Attr.Menu, 2);
  157.     ModifyMenu(Menu, 0, MF_BYPOSITION or MF_OWNERDRAW, CM_ITEM1, 'Menu Item &A');
  158.     ModifyMenu(Menu, 1, MF_BYPOSITION or MF_OWNERDRAW, CM_ITEM2, 'Menu Item &B');
  159.     ModifyMenu(Menu, 2, MF_BYPOSITION or MF_OWNERDRAW, CM_ITEM3, 'Menu Item &C');
  160.     ModifyMenu(Menu, 3, MF_BYPOSITION or MF_OWNERDRAW or MF_POPUP, SubMenu, '&Sub Menu');
  161.     Menu := GetSubMenu(Attr.Menu, 3);
  162.     ModifyMenu(Menu, 0, MF_BYPOSITION or MF_OWNERDRAW, CM_FONT, 'Menu &Font');
  163.     ModifyMenu(Menu, 1, MF_BYPOSITION or MF_OWNERDRAW, CM_COLOR, 'Hilite &Color');
  164.     ModifyMenu(Menu, 2, MF_BYPOSITION or MF_OWNERDRAW, CM_COLORTEXT, 'Hilite &Text Color');
  165.     Menu := GetSubMenu(Attr.Menu, 4);
  166.     ModifyMenu(Menu, 0, MF_BYPOSITION or MF_OWNERDRAW, CM_ABOUT, '&About WinMenu');
  167. end;
  168.  
  169. procedure TMenuWindow.WMCommand (var Msg: TMessage);
  170. var
  171.     MsgText : PChar;
  172. begin
  173.     MsgText := nil;
  174.     with Msg do
  175.     begin
  176.         if wParam = CM_ITEM1 then
  177.             MsgText := 'You selected item A'
  178.         else
  179.         if wParam = CM_ITEM2 then
  180.             MsgText := 'You selected item B'
  181.         else
  182.         if wParam = CM_ITEM3 then
  183.             MsgText := 'You selected item C'
  184.         else
  185.         if wParam = CM_ITEM4 then
  186.             MsgText := 'You selected item D'
  187.         else
  188.             TSFXWindow.WMCommand(Msg);
  189.         if MsgText <> nil then
  190.             SFXMsgBox(HWindow, MsgText, 'Information', MB_ICONINFORMATION, 0);
  191.     end;
  192. end;
  193.  
  194. procedure TMenuWindow.WMDrawItem (var Msg:tMessage);
  195. begin
  196.     (* Pass WMDrawItem onto DrawMenuItem. If you don't want the user to
  197.      * change fonts and highlight colors you can use the default zero
  198.      * values for Font, Color and TextColor.
  199.      *)
  200.     if PDrawItemStruct(Msg.lParam)^.CtlType = ODT_MENU then
  201.         DrawMenuItem(PDrawItemStruct(Msg.lParam), Font, Color, TextColor);
  202. end;
  203.  
  204. procedure TMenuWindow.WMMeasureItem (var Msg: TMessage);
  205. begin
  206.     (* The same font handle passed to DrawMenuItem must be passed to MeasureMenuItem
  207.      *)
  208.     if PMeasureItemStruct(Msg.lParam)^.CtlType = ODT_MENU then
  209.         MeasureMenuItem(HWindow, PMeasureItemStruct(Msg.lParam), Font);
  210. end;
  211.  
  212. procedure TMenuWindow.WMMenuChar (var Msg: TMessage);
  213. begin
  214.     (* A mnemonic is the undelined letter in the text of a menu item. When a menu
  215.      * is active the user can select a menu item by pressing the key that corresponds
  216.      * to the item's underlined letter. Ownerdraw menus don't process standard menu
  217.      * mnemonics so you must trap the WM_MENUCHAR message and process them yourself.
  218.      * A WM_MENUCHAR message is sent when a menu is active and the user presses a key.
  219.      * wParam is the key's ascii character, the LOWORD of lParam is the menu type,
  220.      * either MF_POPUP or MF_SYSMENU and the HIWORD of lParam is the handle of the
  221.      * menu. The return value must be a long integer specifying the menu item's zero
  222.      * based position in its LOWORD and '2' in its HIWORD.
  223.      *
  224.      * Since the system menu rarely gets modified, ProcessSystemChar can be used to
  225.      * automatically handle system menu mnemonics.
  226.      *)
  227.     if Msg.lParamLo and mf_SysMenu <> 0 then
  228.         Msg.Result := ProcessSystemChar(Msg.wParam)
  229.     else
  230.     if Msg.lParamHi = SubMenu then
  231.     begin
  232.         case Msg.wParam of
  233.             65, 97  : Msg.Result := MakeLong(0, 2);
  234.             66, 98  : Msg.Result := MakeLong(1, 2);
  235.             67, 99  : Msg.Result := MakeLong(2, 2);
  236.             68, 100 : Msg.Result := MakeLong(3, 2);
  237.         end;
  238.     end
  239.     else
  240.     if Msg.lParamHi = GetSubMenu(Attr.Menu, 0) then
  241.     begin
  242.         case Msg.wParam of
  243.             65, 97  : Msg.Result := MakeLong(0, 2);
  244.             66, 98  : Msg.Result := MakeLong(1, 2);
  245.             67, 99  : Msg.Result := MakeLong(2, 2);
  246.             68, 100 : Msg.Result := MakeLong(3, 2);
  247.             69, 101 : Msg.Result := MakeLong(5, 2);
  248.         end;
  249.     end
  250.     else
  251.     if Msg.lParamHi = GetSubMenu(Attr.Menu, 1) then
  252.     begin
  253.         case Msg.wParam of
  254.             65, 97  : Msg.Result := MakeLong(0, 2);
  255.             66, 98  : Msg.Result := MakeLong(1, 2);
  256.             83, 115 : Msg.Result := MakeLong(2, 2);
  257.             68, 100  : Msg.Result := MakeLong(3, 2);
  258.         end;
  259.     end
  260.     else
  261.     if Msg.lParamHi = GetSubMenu(Attr.Menu, 2) then
  262.     begin
  263.         case Msg.wParam of
  264.             65, 97  : Msg.Result := MakeLong(0, 2);
  265.             66, 98  : Msg.Result := MakeLong(1, 2);
  266.             67, 99 : Msg.Result := MakeLong(2, 2);
  267.             83, 115 : Msg.Result := MakeLong(3, 2);
  268.         end;
  269.     end
  270.     else
  271.     if Msg.lParamHi = GetSubMenu(Attr.Menu, 3) then
  272.     begin
  273.         case Msg.wParam of
  274.             70, 102 : Msg.Result := MakeLong(0, 2);
  275.             67, 99  : Msg.Result := MakeLong(1, 2);
  276.             84, 116 : Msg.Result := MakeLong(2, 2);
  277.         end;
  278.     end;
  279. end;
  280.  
  281. procedure TMenuWindow.CMExitWindow (var Msg: TMessage);
  282. begin
  283.     CloseWindow;
  284. end;
  285.  
  286. procedure TMenuWindow.CMFont (var Msg: TMessage);
  287. var
  288.     FontColor : LongInt;
  289.     Template  : Integer;
  290. begin
  291.     Fontcolor := 0;
  292.     Template := GetSFXTemplateId('SFX3DDlg', DLG_EXFONT);
  293.     if SFXChooseFont(HWindow, LogFont, 0, Template, True, FontColor) then
  294.     begin
  295.         EraseObject(Font);
  296.         Font := CreateFontIndirect(LogFont);
  297.         DestroyMenu(Attr.Menu);
  298.         Attr.Menu := LoadMenu(HInstance, 'WinMenu');
  299.         Create3DMenus;
  300.     end;
  301. end;
  302.  
  303. procedure TMenuWindow.CMColor (var Msg: TMessage);
  304. var
  305.     CCFlags : LongInt;
  306.     Template : Integer;
  307. begin
  308.     CCFlags := CC_RGBINIT;
  309.     Template := GetSFXTemplateId('SFX3DDlg', DLG_EXCOLOR);
  310.     SFXChooseColor(HWindow, Color, CCFlags, Template, TRUE, nil);
  311. end;
  312.  
  313. procedure TMenuWindow.CMColorText (var Msg: TMessage);
  314. var
  315.     CCFlags : LongInt;
  316.     Template : Integer;
  317. begin
  318.     CCFlags := CC_RGBINIT;
  319.     Template := GetSFXTemplateId('SFX3DDlg', DLG_EXCOLOR);
  320.     SFXChooseColor(HWindow, TextColor, CCFlags, Template, TRUE, nil);
  321. end;
  322.  
  323. procedure TMenuWindow.CMAbout (var Msg: TMessage);
  324. begin
  325.     Application^.ExecDialog(New(PAboutDialog, Init(@Self, 'AboutDialog')));
  326. end;
  327.  
  328. {********** TAboutDialog **********}
  329.  
  330. procedure TAboutDialog.SetUpWindow;
  331. begin
  332.     TDialog.Setupwindow;
  333.     CenterWindow(Parent^.HWindow, HWindow);
  334. end;
  335.  
  336. {********** Main program **********}
  337.  
  338. var
  339.     App: TMenuApp;
  340. begin
  341.     App.Init(AppName);
  342.     App.Run;
  343.     App.Done;
  344. end.
  345.