home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 1998 April A / Pcwk4a98.iso / PROGRAM / DELPHI16 / Calmira / Src / SRC / STRTPROP.PAS < prev    next >
Pascal/Delphi Source File  |  1997-02-17  |  15KB  |  508 lines
  1. {**************************************************************************}
  2. {                                                                          }
  3. {    Calmira shell for Microsoft« Windows(TM) 3.1                          }
  4. {    Source Release 1.0                                                    }
  5. {    Copyright (C) 1997  Li-Hsin Huang                                     }
  6. {                                                                          }
  7. {    This program is free software; you can redistribute it and/or modify  }
  8. {    it under the terms of the GNU General Public License as published by  }
  9. {    the Free Software Foundation; either version 2 of the License, or     }
  10. {    (at your option) any later version.                                   }
  11. {                                                                          }
  12. {    This program is distributed in the hope that it will be useful,       }
  13. {    but WITHOUT ANY WARRANTY; without even the implied warranty of        }
  14. {    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         }
  15. {    GNU General Public License for more details.                          }
  16. {                                                                          }
  17. {    You should have received a copy of the GNU General Public License     }
  18. {    along with this program; if not, write to the Free Software           }
  19. {    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.             }
  20. {                                                                          }
  21. {**************************************************************************}
  22.  
  23. unit Strtprop;
  24.  
  25. { Start Menu Properties Dialog
  26.  
  27.   The main control is a TOutline that contains a copy of the start
  28.   menu.  Each outline node contains a pointer to a dynamic 255 char
  29.   string that stores additional data.  The string size is fixed
  30.   because TOutlineNode's Data property cannot be used easily with
  31.   AssignStr, which requires a var parameter.
  32. }
  33.  
  34. interface
  35.  
  36. uses WinTypes, WinProcs, Classes, Graphics, Forms, Controls, Buttons,
  37.   StdCtrls, Menus, Grids, Outline, TabNotBk, SysUtils, Chklist, StylSped,
  38.   Scrtree, Messages, CalMsgs, CalForm, Settings;
  39.  
  40. type
  41.   TStartPropDlg = class(TCalForm)
  42.     OKBtn: TBitBtn;
  43.     CancelBtn: TBitBtn;
  44.     Notebook: TTabbedNotebook;
  45.     OutlineMenu: TPopupMenu;
  46.     AddItem: TMenuItem;
  47.     InsertItem: TMenuItem;
  48.     EditItem: TMenuItem;
  49.     DeleteItem: TMenuItem;
  50.     ExpandItem: TMenuItem;
  51.     CollapseItem: TMenuItem;
  52.     N1: TMenuItem;
  53.     Convert: TMenuItem;
  54.     AddBtn: TStyleSpeed;
  55.     InsertBtn: TStyleSpeed;
  56.     EditBtn: TStyleSpeed;
  57.     DeleteBtn: TStyleSpeed;
  58.     ExpandBtn: TStyleSpeed;
  59.     CollapseBtn: TStyleSpeed;
  60.     ConvertBtn: TStyleSpeed;
  61.     PrefList: TCheckList;
  62.     Outline: TScrollTree;
  63.     Modified: TCheckBox;
  64.     BitBtn1: TBitBtn;
  65.     procedure OutlineDragDrop(Sender, Source: TObject; X, Y: Integer);
  66.     procedure OutlineDragOver(Sender, Source: TObject; X, Y: Integer;
  67.       State: TDragState; var Accept: Boolean);
  68.     procedure OutlineEndDrag(Sender, Target: TObject; X, Y: Integer);
  69.     procedure OutlineMouseDown(Sender: TObject; Button: TMouseButton;
  70.       Shift: TShiftState; X, Y: Integer);
  71.     procedure AddItemClick(Sender: TObject);
  72.     procedure InsertItemClick(Sender: TObject);
  73.     procedure EditItemClick(Sender: TObject);
  74.     procedure DeleteItemClick(Sender: TObject);
  75.     procedure ExpandItemClick(Sender: TObject);
  76.     procedure CollapseItemClick(Sender: TObject);
  77.     procedure ConvertClick(Sender: TObject);
  78.     procedure FormCreate(Sender: TObject);
  79.     procedure OKBtnClick(Sender: TObject);
  80.     procedure FormDestroy(Sender: TObject);
  81.     procedure FormClose(Sender: TObject; var Action: TCloseAction);
  82.     procedure OutlineDrawItem(Control: TWinControl; Index: Integer;
  83.       Rect: TRect; State: TOwnerDrawState);
  84.     procedure CancelBtnClick(Sender: TObject);
  85.     procedure PrefListClick(Sender: TObject);
  86.   private
  87.     { Private declarations }
  88.     DragItem : Longint;
  89.     {procedure UpdateMenuTree;}
  90.     procedure ConvertProgItem(Sender : TObject;
  91.      const group, caption: TFilename; const data: string);
  92.     function AddOutlineNode(index : Longint;
  93.       const cap, data : string; Op: TAttachMode): Longint;
  94.     procedure DisposeNode(node : TOutlineNode);
  95.   public
  96.     { Public declarations }
  97.     procedure Configure;
  98.     procedure SettingsChanged(Changes : TSettingChanges); override;
  99.   end;
  100.  
  101. var
  102.   StartPropDlg: TStartPropDlg;
  103.   NewStartItems : TStringList;
  104.  
  105. implementation
  106.  
  107. {$R *.DFM}
  108.  
  109. uses Start, ProgConv, MenuEdit, MultiGrd, IconWin, Directry,
  110.   Sys, MiscUtil, Dialogs, Strings;
  111.  
  112.  
  113. procedure TStartPropDlg.OutlineDragDrop(Sender, Source: TObject; X,
  114.   Y: Integer);
  115. const
  116.   Attach: array[Boolean] of TAttachMode = (oaInsert, oaAddChild);
  117. var
  118.   dest : Longint;
  119.   i : Integer;
  120. begin
  121.   Outline.DropFocus := -1;
  122.   dest := Outline.GetItemAt(X, Y);
  123.  
  124.   { Handle drops from icon windows or from outline itself }
  125.  
  126.   if Source is TMultiGrid then
  127.     with (TMultiGrid(Source).Owner as TIconWindow).CompileSelection(False) do
  128.       for i := 0 to Count-1 do
  129.         with  TDirItem(Items[i]) do
  130.           AddOutlineNode(dest, GetTitle, GetStartInfo, oaAddChild)
  131.  
  132.   else with Outline, Items[DragItem] do begin
  133.     { Strange things seem to happen without BeginUpdate/EndUpdate! }
  134.     BeginUpdate;
  135.     if GetAsyncKeyState(VK_CONTROL) < 0 then
  136.       AddOutlineNode(dest, Text,
  137.         PString(Data)^, Attach[GetAsyncKeyState(VK_MENU) < 0])
  138.     else begin
  139.       Collapse;
  140.       MoveTo(dest, Attach[GetAsyncKeyState(VK_MENU) < 0]);
  141.     end;
  142.     EndUpdate;
  143.   end;
  144.   Modified.Checked := True;
  145. end;
  146.  
  147.  
  148. procedure TStartPropDlg.OutlineDragOver(Sender, Source: TObject; X,
  149.   Y: Integer; State: TDragState; var Accept: Boolean);
  150. begin
  151.   Accept := ((Sender = Source) or
  152.              (Source is TMultiGrid) and (Source <> SysWindow.Grid))
  153.              and (Outline.GetItemAt(X, Y) > 0);
  154.  
  155.   with Outline do
  156.     if not Accept or (State = dsDragLeave) then DropFocus := -1
  157.     else DropFocus := GetCellAt(X, Y);
  158. end;
  159.  
  160.  
  161. procedure TStartPropDlg.OutlineEndDrag(Sender, Target: TObject; X,
  162.   Y: Integer);
  163. begin
  164.   ClipCursor(nil);
  165. end;
  166.  
  167.  
  168. procedure TStartPropDlg.OutlineMouseDown(Sender: TObject;
  169.   Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  170. var
  171.   r : TRect;
  172.   i : Longint;
  173.   p : TPoint;
  174. begin
  175.   if ssDouble in Shift then
  176.     Exit
  177.  
  178.   else if Button = mbRight then with Outline do begin
  179.     { Select the item under the cursor and popup menu }
  180.     if GetCaptureControl <> nil then Exit;
  181.     i := GetItem(X, Y);
  182.     if i > 0 then SelectedItem := i;
  183.     GetCursorPos(p);
  184.     OutlineMenu.Popup(p.X, p.Y);
  185.   end
  186.  
  187.   else with Outline do begin
  188.     { Pre-determine whether the item should be moved depending on
  189.       the Alt key, restrict the cursor to the outline and start
  190.       drag }
  191.     DragItem := GetItem(X, Y);
  192.     if DragItem > 0 then begin
  193.       with ClientRect do begin
  194.         r.TopLeft := ClientToScreen(TopLeft);
  195.         r.BottomRight := ClientToScreen(Bottomright);
  196.         ClipCursor(@r);
  197.       end;
  198.       BeginDrag(False);
  199.     end;
  200.   end
  201. end;
  202.  
  203.  
  204. procedure TStartPropDlg.AddItemClick(Sender: TObject);
  205. begin
  206.   with MenuEditDlg do
  207.   if EditItem('Add menu item', '', ';;;;') = mrOK then
  208.     AddOutlineNode(Outline.SelectedItem, CaptionEdit.Text, DataString, oaInsert);
  209. end;
  210.  
  211.  
  212. procedure TStartPropDlg.InsertItemClick(Sender: TObject);
  213. begin
  214.   with Outline, MenuEditDlg do
  215.     if SelectedItem = 0 then AddItem.Click else
  216.       if EditItem('Insert menu item', '', ';;;;') = mrOK then
  217.         AddOutlineNode(SelectedItem, CaptionEdit.Text, DataString, oaAddChild);
  218. end;
  219.  
  220.  
  221. procedure TStartPropDlg.EditItemClick(Sender: TObject);
  222. var
  223.   node : TOutlineNode;
  224. begin
  225.   with Outline, MenuEditDlg do
  226.     if (SelectedItem > 0) then begin
  227.       node := Items[SelectedItem];
  228.       if EditItem('Menu item properties', node.Text,
  229.       PString(node.Data)^) = mrOK then begin
  230.         PString(node.Data)^ := DataString;
  231.         node.Text := CaptionEdit.Text;
  232.         Modified.Checked := True;
  233.       end;
  234.     end;
  235. end;
  236.  
  237.  
  238. procedure TStartPropDlg.DisposeNode(node : TOutlineNode);
  239. var i : Longint;
  240. begin
  241.   { Recursive procedure to free dynamic strings }
  242.  
  243.   Dispose(PString(node.Data));
  244.   i := node.GetFirstChild;
  245.   while i <> -1 do begin
  246.     DisposeNode(Outline.Items[i]);
  247.     i := node.GetNextChild(i);
  248.   end;
  249. end;
  250.  
  251.  
  252. procedure TStartPropDlg.DeleteItemClick(Sender: TObject);
  253. var
  254.   node: TOutlineNode;
  255.   i : Longint;
  256. begin
  257.   with Outline do
  258.     if SelectedItem > 0 then begin
  259.       node := Items[SelectedItem];
  260.       if node.HasItems and (MsgDialog('Delete this menu?',
  261.         mtConfirmation, [mbYes, mbNo], 0) <> mrYes) then Exit;
  262.  
  263.       DisposeNode(node);
  264.  
  265.       { If a node is deleted when its previous sibling is expanded,
  266.         the TOutline code often crashes }
  267.       node.Collapse;
  268.       i := node.Parent.GetPrevChild(SelectedItem);
  269.       if i > 0 then Items[i].Collapse;
  270.       Delete(SelectedItem);
  271.       Modified.Checked := True;
  272.     end;
  273. end;
  274.  
  275.  
  276. procedure TStartPropDlg.ExpandItemClick(Sender: TObject);
  277. begin
  278.   Outline.FullExpand;
  279. end;
  280.  
  281.  
  282. procedure TStartPropDlg.CollapseItemClick(Sender: TObject);
  283. begin
  284.   Outline.FullCollapse;
  285. end;
  286.  
  287.  
  288. procedure TStartPropDlg.ConvertClick(Sender: TObject);
  289. begin
  290.   with TConvertDlg.Create(Application) do
  291.   try
  292.     OnConvertProg := ConvertProgItem;
  293.     ShowModal;
  294.   finally
  295.     Free;
  296.   end;
  297. end;
  298.  
  299.  
  300. procedure TStartPropDlg.ConvertProgItem(Sender : TObject;
  301.   const group, caption: TFilename; const data: string);
  302. var
  303.   i, parentnode: Longint;
  304. begin
  305.   with Outline do begin
  306.     { Find existing submenu containing the group }
  307.     parentnode := GetTextItem(group);
  308.  
  309.     if parentnode = 0 then begin
  310.       { Create a new group node and add the item to it }
  311.       AddOutlineNode(0, group, ';;;;', oaInsert);
  312.       AddOutlineNode(GetTextItem(group), caption, data, oaAddChild);
  313.     end
  314.  
  315.     else begin
  316.       { An existing group has been found.  Now look for a matching
  317.         menu item, and update it if found.  Otherwise, just add
  318.         another item }
  319.  
  320.       i := Items[parentnode].GetFirstChild;
  321.       while i <> -1 do
  322.         if CompareText(Items[i].Text, caption) = 0 then begin
  323.           PString(Items[i].Data)^ := data;
  324.           Exit;
  325.         end
  326.         else i := Items[parentnode].GetNextChild(i);
  327.  
  328.       AddOutlineNode(parentnode, caption, data, oaAddChild);
  329.     end;
  330.   end;
  331. end;
  332.  
  333.  
  334.  
  335. procedure TStartPropDlg.FormCreate(Sender: TObject);
  336. var i: Integer;
  337. begin
  338.   { A menu editor dialog is created here to speed up editing }
  339.   Notebook.PageIndex := 0;
  340.   MenuEditDlg := TMenuEditDlg.Create(Application);
  341.   StartMenu.AssignToOutline(Outline);
  342.  
  343.   with NewStartItems do begin
  344.     for i := 0 to Count-1 do AddOutlineNode(0,
  345.       GetStrKey(Strings[i]), GetStrValue(Strings[i]), oaAdd);
  346.     Clear;
  347.   end;
  348.  
  349.   Outline.SetUpdateState(False);
  350.   Outline.Canvas.Font.Assign(Font);
  351.   PrefList.SetData([StartMenu3D, BoldSelect,
  352.     ShellStartup, StartMouseUp]);
  353.   Configure;
  354.   {UpdateMenuTree;}
  355. end;
  356.  
  357.  
  358. function TStartPropDlg.AddOutlineNode(index : Longint;
  359.   const cap, data : string; Op: TAttachMode): Longint;
  360. var
  361.   p: PString;
  362. begin
  363.   { Add a new outline node with a dynamic string as the Data }
  364.   Modified.Checked := True;
  365.   New(p);
  366.   p^ := data;
  367.   case Op of
  368.     oaAdd      : Result := Outline.AddObject(index, cap, p);
  369.     oaAddChild : Result := Outline.AddChildObject(index, cap, p);
  370.     oaInsert   : Result := Outline.InsertObject(index, cap, p);
  371.   end;
  372. end;
  373.  
  374.  
  375. procedure TStartPropDlg.OKBtnClick(Sender: TObject);
  376. begin
  377.   PrefList.GetData([@StartMenu3D, @BoldSelect,
  378.     @ShellStartup, @StartMouseUp]);
  379.  
  380.   SaveStartProp;
  381.   StartMenu.Configure;
  382.   PostMessage(TaskbarWindow, WM_CALMIRA, CM_TASKCONFIG, 0);
  383.  
  384.   if Modified.Checked then StartMenu.RebuildFromOutline(Outline);
  385.   Close;
  386.   AnnounceSettingsChanged([scStartMenu]);
  387. end;
  388.  
  389.  
  390. procedure TStartPropDlg.FormDestroy(Sender: TObject);
  391. var
  392.   i: Longint;
  393. begin
  394.   with Outline do
  395.     for i := 1 to ItemCount do Dispose(PString(Items[i].Data));
  396.  
  397.   MenuEditDlg.Free;
  398.   MenuEditDlg := nil;
  399.   StartPropDlg := nil;
  400. end;
  401.  
  402.  
  403. procedure TStartPropDlg.FormClose(Sender: TObject;
  404.   var Action: TCloseAction);
  405. begin
  406.   Action := caFree;
  407. end;
  408.  
  409.  
  410. procedure TStartPropDlg.OutlineDrawItem(Control: TWinControl;
  411.   Index: Integer; Rect: TRect; State: TOwnerDrawState);
  412. var
  413.   item: TOutlineNode;
  414.   x, y : Integer;
  415. begin
  416.   { Fast outline drawing with no BrushCopy.  Unlike the tree view,
  417.     (see TREE.PAS) there are no disadvantages here because all the
  418.     pictures are square or rectangular, so no transparency is
  419.     needed }
  420.  
  421.   with Outline do begin
  422.     index := GetItem(0, Rect.Top);
  423.     item := Items[index];
  424.     x := Rect.Left + item.Level * 20 + 4;
  425.     y := (Rect.Top + Rect.Bottom) div 2;
  426.  
  427.     with Canvas do begin
  428.       if odSelected in State then Brush.Color := clHighlight
  429.       else Brush.Color := Color;
  430.       FillRect(Rect);
  431.  
  432.       if item.HasItems then
  433.         if item.Expanded then Draw(x+1, Rect.Top+2, PictureOpen)
  434.         else Draw(x+1, Rect.Top+2, PictureClosed)
  435.       else
  436.         Draw(x+1, Rect.Top+4, PictureLeaf);
  437.  
  438.       TextOut(x + 19, Rect.Top+1, item.Text);
  439.  
  440.       { Draw horizontal line connecting node to branch }
  441.  
  442.       MoveTo(x - 4, y);
  443.       Dec(x, 16);
  444.       LineTo(x, y);
  445.  
  446.       { Draw vertical line, it's length depending on whether
  447.         this node has additional siblings }
  448.  
  449.       if Item.Parent.GetLastChild = Item.Index then
  450.         LineTo(x, Rect.Top-1)
  451.       else begin
  452.         MoveTo(x, Rect.Top);
  453.         LineTo(x, Rect.Bottom);
  454.       end;
  455.  
  456.       { Loop back to the root through all parent nodes, drawing a
  457.         vertical line if the parent has child nodes to be drawn
  458.         below this node }
  459.  
  460.       item := item.Parent;
  461.  
  462.       while (Item <> nil) and (Item.Parent <> nil) do begin
  463.         Dec(x, 20);
  464.         if Item.Parent.GetLastChild > Item.Index then begin
  465.           MoveTo(x, Rect.Top);
  466.           LineTo(x, Rect.Bottom);
  467.         end;
  468.         item := item.Parent;
  469.       end;
  470.     end;
  471.   end;
  472. end;
  473.  
  474.  
  475. procedure TStartPropDlg.CancelBtnClick(Sender: TObject);
  476. begin
  477.   Close;
  478. end;
  479.  
  480. procedure TStartPropDlg.SettingsChanged(Changes : TSettingChanges);
  481. begin
  482.   if [scDesktop, scDisplay, scSystem] * Changes <> [] then Configure;
  483. end;
  484.  
  485.  
  486. procedure TStartPropDlg.Configure;
  487. begin
  488.   Outline.ThumbTracking := TrackThumb;
  489.   Outline.ItemHeight := LineHeight;
  490. end;
  491.  
  492.  
  493. procedure TStartPropDlg.PrefListClick(Sender: TObject);
  494. begin
  495.   if PrefList.ItemIndex = 0 then Modified.Checked := True;
  496. end;
  497.  
  498.  
  499. procedure DoneStartProp; far;
  500. begin
  501.   NewStartItems.Free;
  502. end;
  503.  
  504. initialization
  505.   NewStartItems := TStringList.Create;
  506.   AddExitProc(DoneStartProp);
  507. end.
  508.