cmpmenudesigner.pas

學習資料網上下載

  ControlStyle := ControlStyle + [csReflector];
  DoubleBuffered := True;
  fItems := TDesignerMenuItem.Create (self);
  fPositionSnapshot := TList.Create;
end;

(*----------------------------------------------------------------------*
 | TBaseMenuDesigner.DeleteItem ()                                      |
 |                                                                      |
 | Delete an item.  Select the nearest item if the currently selected   |
 | one is deleted                                                       |
 *----------------------------------------------------------------------*)
procedure TBaseMenuDesigner.DeleteItem(item: TMenuItem);
var
  selIdx : Integer;
  parent : TMenuItem;
begin
  if Assigned (item) then
  begin
    selIDx := -1;
    if fSelectedItem = item then
    begin
      parent := item.Parent;
      if parent <> Nil then
        selIdx := parent.IndexOf (item)
    end
    else
      parent := Nil;

    item.Free;

    if Assigned (parent) then
    begin
      while (selIdx <> -1) and (selIdx >= parent.Count)  do
        Dec (selIdx);

      if selIdx <> -1 then
        SelectedItem  := parent.Items [selIdx]
      else
        SelectedItem := Parent
    end
    else
      SelectedItem := Nil;

    Invalidate
  end
end;

(*----------------------------------------------------------------------*
 | TBaseMenuDesigner.Destroy ()                                         |
 |                                                                      |
 | Destructor for the designer                                          |
 *----------------------------------------------------------------------*)
destructor TBaseMenuDesigner.Destroy;
begin
  fPositionSnapshot.Free;
  inherited;
end;

(*----------------------------------------------------------------------*
 | TBaseMenuDesigner.DoChangeSelectedItem ()                            |
 |                                                                      |
 | Internally set the selected item, take a position snapshot, and      |
 | raise an event if necessary.                                         |
 *----------------------------------------------------------------------*)
procedure TBaseMenuDesigner.DoChangeSelectedItem(value: TMenuItem);
begin
  fSelectedItem := value;

  TakeSnapshot;

  if Assigned (fOnSelectedItemChange) and Assigned (fSelectedItem) and not (csDestroying in ComponentState) then
    OnSelectedItemChange (self);
end;

(*----------------------------------------------------------------------*
 | TBaseMenuDesigner.DrawItem                                           |
 |                                                                      |
 | Draw an item.                                                        |
 |                                                                      |
 | Parmeters:                                                           |
 |   item : TMenuItem                   The item to draw                |
 |   x : Integer                        Horizontal position             |
 |   stw : Integer                      Caption width.  -1 to calculate.|
 |   shw : Integer                      Shortcut width                  |
 |   leftMargin : Integer               Left margin                     |
 |   rightMargin : Integer              Right Margin                    |
 |   sth : Integer                      Item height                     |
 |   vert : boolean                     True if popup or drop down.     |
 |                                      False if main menu.             |
 |                                                                      |
 | nb.  If 'Vert' is set, the bo0unding rectangle is shrunk to avoid    |
 | the edge borders, and '-' captions display a full 'Center Line'      |
 |                                                                      |
 | The function returns the horizontal position for the next menu item. |
 | If vert is set this is meaningless                                   |
 *----------------------------------------------------------------------*)
procedure TBaseMenuDesigner.DoEnter;
begin
  inherited;
  Invalidate
end;

procedure TBaseMenuDesigner.DoExit;
begin
  inherited;
  Invalidate
end;

function TBaseMenuDesigner.DrawItem(item: TMenuITem; x, y, stw, shw, leftMargin, rightMargin, sth : Integer; vert: boolean) : Integer;
var
  st, s1 : string;
  params : TDrawTextParams;
  r : TRect;
  extent, oldMode : Integer;
  b : TBitmap;

// -----------------------------------------------------------------------
// Helper function draws string in correct color, depending on item params
  procedure DrawStr (left : Integer; const st : string);
  var
    r : TRect;
    defFColor : TColor;
  begin
    oldMode := SetBkMode (Canvas.Handle, TRANSPARENT);
    defFColor := Canvas.Font.Color;
    try
      r := Rect (left, y, extent, y + sth);
      if not Item.Enabled then                  // Get the correct font color
      begin
        Canvas.Font.Color := clBtnHighlight;    // Disabled item.  Draw highlight then
        OffsetRect (r, 1, 1)                    // shadow below
      end
      else
        if TDesignerMenuItem (Item).Selected and Focused then
          Canvas.Font.Color := clHighlightText;

                                                // Draw the text

      DrawTextEx (Canvas.Handle, PChar (st), -1, r, DT_LEFT or DT_SINGLELINE or DT_EXPANDTABS or DT_VCENTER, @params);

      if Item.Checked then                      // Draw a tick if it's checked
      begin
        b := TBitmap.Create;
        try
          b.Height := sth - 2;
          b.Width := b.Height;
          DrawFrameControl (b.Canvas.Handle, RECT (0, 2, sth - 2, sth), DFC_MENU, DFCS_MENUCHECK);
          b.TransparentColor := clWhite;
          b.Transparent := True;

          Canvas.Draw (r.Left, r.Top + 1, b)
        finally
          b.Free
        end
      end;

      if not Item.Enabled then
      begin
        Canvas.Font.Color := clBtnShadow;       // Draw shadow if not enabled
        r := Rect (left, y, extent, y + sth);
        DrawTextEx (Canvas.Handle, PChar (st), -1, r, DT_LEFT or DT_SINGLELINE or DT_EXPANDTABS or DT_VCENTER, @params);
      end
    finally
      Canvas.Font.Color := defFColor;
      SetBkMode (Canvas.Handle, oldMode)
    end
  end;

begin
  FillChar (params, sizeof (params), 0);        // Set up DrawTextEx params
  params.cbSize := sizeof (params);
  params.iLeftMargin := leftMargin;
  params.iRightMargin := rightMargin;
  params.iTabLength := 0;

  st := ExtractCaption (item.Caption);          // Extract caption & shortcut
  s1 := ExtractShortcut (item.Caption);

  if stw = -1 then                              // Calculate string width if required (horiz menus)
    stw := DrawTextWidth (leftMargin, RightMargin, st);

  if vert then                                  // Adjust x for popup/droppdown borders
    Inc (x, GetSystemMetrics (SM_CXEDGE));

  extent := x + stw + shw;                      // Get width of highlight rectangle

  if vert then                                  // Adjust width for popup/dropdown menus
    Dec (extent, 2 * GetSystemMetrics (SM_CXEDGE));

  r := Rect (x, y, extent, y + sth);            // Get highlight rectangle

  if TDesignerMenuItem (Item).Selected then
    if Focused then    // Get correct brush color...
      Canvas.Brush.Color := clHighlight
    else
      Canvas.Brush.Color := clBtnShadow
  else
    Canvas.Brush.Color := Color;

  Canvas.FillRect (r);                          // .. and fill the background

  if st <> '-' then                             // Draw the main caption
    DrawStr (x, st);

  if vert then
  begin
    if st = '-' then                            // Draw a separator if necessary
    begin
      r.Bottom := y + sth div 2;
      DrawEdge (Canvas.Handle, r, EDGE_ETCHED, BF_BOTTOM);
    end
    else if s1 <> '' then                       // Draw the shortcut
      DrawStr (x + stw, s1);
  end;
  result := extent
end;

(*----------------------------------------------------------------------*
 | TBaseMenuDesigner.DrawTextWidth                                      |
 |                                                                      |
 | Return the width of a bounding rectangle that can contain a string   |
 | including a right and left margin.                                   |
 *----------------------------------------------------------------------*)
function TBaseMenuDesigner.DrawTextWidth(lm, rm : Integer; const st: string): Integer;
var
  r : TRect;
  params : TDrawTextParams;
begin
  if st = '' then
    result := lm + rm
  else
  begin
    r := Rect (0, 0, 0, 0);

    FillChar (params, sizeof (params), 0);
    params.cbSize := sizeof (params);
    params.iLeftMargin := lm;
    params.iRightMargin := rm;
    params.iTabLength := 0;

    // nb.  DT_CALCRECT ensures that the text isn't actually drawn - just the rect is returned.
    DrawTextEx (Canvas.Handle, PChar (st), Length (st), r, DT_LEFT or DT_SINGLELINE or DT_CALCRECT, @params);
    result := r.Right
  end
end;

function TBaseMenuDesigner.GetSelectedItem: TMenuItem;
begin
  if fSelectedItem is TDesignerMenuItem then
    result := TDesignerMenuItem (fSelectedItem)
  else
    result := Nil
end;

function TBaseMenuDesigner.GetSnapshotItem: TMenuItem;
var
  i, v : Integer;
  p : TMenuItem;
begin
  p := fItems;
  for i := 0 to fPositionSnapshot.Count - 1 do
  begin
    if not Assigned (p) then break;
    v := Integer (fPositionSnapshot [i]);
    if v <> -1 then
      p := p.Items [v]
  end;

  result := p;
end;

function TBaseMenuDesigner.InsertItem(beforeItem: TMenuItem): TMenuItem;
var
  idx : Integer;
begin
  if Assigned (beforeItem) and Assigned (beforeItem.Parent) then
  begin
    idx := beforeItem.Parent.IndexOf (beforeItem);
    result := AddChildItemAt (beforeItem.parent, idx);
    SelectedItem := result
  end
  else
    result := Nil
end;

function TBaseMenuDesigner.ItemAt(X, Y: Integer): TMenuItem;
begin
  result := Nil
end;

function TBaseMenuDesigner.ItemAtOffset(items : TMenuItem; XOffset, YOffset, X,
  Y: Integer): TMenuItem;
var
  w, m, h : Integer;
  r : TRect;
  i, lh, ew : Integer;
  item : TMenuItem;

begin
  result := Nil;
  CalcItemsSize (items, w, m, h);

  r.Left := XOffset;
  r.Right := XOffset + w + m;
  r.top := YOffset;
  r.bottom := YOffset + h;

  lh := GetSystemMetrics (SM_CYMENU);
  ew := GetSystemMetrics (SM_CXEDGE);

  Inc (YOffset, menuTopMargin);

  for i := 0 to items.Count - 1 do
  begin
    item := items.Items [i];

    r.Top := YOffset;
    r.Bottom := YOffset + lh;
    r.Left := XOffset + ew;
    r.Right := XOffset + w + m - ew;

    if PtInRect (r, Point (X, Y)) then
    begin
      result := item;
      break
    end;

    if (item.Count > 0) and TDesignerMenuItem (Item).Selected then
      result := ItemAtOffset (item, XOffset + w + m, YOffset, X, Y);

    YOffset := YOffset + lh;
  end
end;

procedure TBaseMenuDesigner.KeyDown(var Key: Word; Shift: TShiftState);
var
  vertMenu, vertParent : boolean;
  parent, grandparent : TMenuItem;
  gidx, idx : Integer;
begin
  if Assigned (SelectedItem) and Assigned (selectedItem.Parent) then
  begin
    parent := SelectedItem.Parent;
    grandparent := parent.parent;
    idx := parent.IndexOf (SelectedItem);
    vertMenu := not ((self is TMenuDesigner) and not Assigned (grandparent));
    vertParent := not ((self is TMenuDesigner) and Assigned (grandparent) and not Assigned (grandparent.parent));

    if not vertParent then
      gidx := grandparent.IndexOf (parent)
    else
      gidx := 0;

    case Key of
      VK_RIGHT :
        if vertMenu then
        begin
          if SelectedItem.Count > 0 then
            SelectedItem := SelectedItem.Items [0]
          else
            if (not vertParent) and (gidx < grandparent.Count - 1) then
              SelectedItem := grandparent.Items [gidx + 1]
        end
        else
          if idx = parent.Count - 1 then
            SelectedItem := parent.Items [0]
          else
            SelectedItem := parent.Items [idx + 1];

      VK_LEFT :
        if vertMenu then
        begin
          if (idx = 0) and vertParent then
            SelectedItem := parent
          else
            if (not vertParent) and (gidx > 0) then
              SelectedItem := grandparent.Items [gidx - 1]
        end
        else
          if idx = 0 then
            SelectedItem := parent.Items [parent.Count - 1]
          else
            SelectedItem := parent.Items [idx - 1];

        VK_UP :