xpmenu.pas

这是一个门禁系统的应用程序,用 delphi编写,希望与大家交流.

    FForm.Update;
    if XPMenuManager.FXPMenuList.Count = 0 then
      DoneControls;
  end;

  FFont.Free;
  inherited;
end;

//add by:
//liyang <[e-mail]> ,2002-07-19
//Pedro Miguel Cunha <[e-mail]>- 02 Apr 2002
procedure TXPMenu.Loaded;
begin
  inherited Loaded;

// Add the XPMenu to the XPMenuManager
  if Assigned(XPMenuManager) and not(csDesigning in ComponentState) then
    XPMenuManager.Add(Self);
end;

{to check for new sub items}
procedure TXPMenu.ActivateMenuItem(MenuItem: TMenuItem; SubMenus: boolean); // +jt

  procedure Activate(MenuItem: TMenuItem);
  begin
    if (MenuItem.Tag <> 999) then
    if addr(MenuItem.OnDrawItem) <> addr(TXPMenu.DrawItem) then
    begin
      if (not assigned(MenuItem.OnDrawItem)) or (FOverrideOwnerDraw) then
        MenuItem.OnDrawItem := DrawItem;
      if (not assigned(MenuItem.OnMeasureItem)) or (FOverrideOwnerDraw) then
        MenuItem.OnMeasureItem := MeasureItem;
    end
  end;

var
  i{, j}: integer;
begin

  Activate(MenuItem);
  if (SubMenus=true) then // +jt
  begin
   for i := 0 to MenuItem.Count -1 do
   begin
     ActivateMenuItem(MenuItem.Items[i],true);
   end;
 end;
end;

procedure TXPMenu.InitItems(wForm: TWinControl; Enable, Update: boolean );
var
  i: integer;
  Comp: TComponent;
begin
  for i := 0 to wForm.ComponentCount - 1 do
  begin
    Comp := wForm.Components[i];
    InitItem(Comp, Enable, Update); // Tom: "Thomas Knoblauch" <[e-mail]> 27.08
  end;
end;

procedure TXPMenu.InitComponent(Comp: TComponent); // Tom: for external (by the main program) use without parameters. "Thomas Knoblauch" <[e-mail]> 27.08
begin
  if FActive then InitItem(Comp, true, true);
end;



// Tom: "Thomas Knoblauch" <[e-mail]> 27.08
procedure TXPMenu.InitItem(Comp: TComponent; Enable, Update: boolean );
  procedure Activate(MenuItem: TMenuItem);
  begin
    if Enable then
    begin
      if (MenuItem.Tag <> 999) then
      begin
        if (not assigned(MenuItem.OnDrawItem)) or (FOverrideOwnerDraw) then
          MenuItem.OnDrawItem := DrawItem;
        if (not assigned(MenuItem.OnMeasureItem)) or (FOverrideOwnerDraw) then
          MenuItem.OnMeasureItem := MeasureItem;
      end;
    end
    else
    begin
      if addr(MenuItem.OnDrawItem) = addr(TXPMenu.DrawItem) then
        MenuItem.OnDrawItem := nil;
      if addr(MenuItem.OnMeasureItem) = addr(TXPMenu.MeasureItem) then
        MenuItem.OnMeasureItem := nil;
    end;
  end;

  procedure ItrateMenu(MenuItem: TMenuItem);
  var
    i: integer;
  begin
    Activate(MenuItem);
    for i := 0 to MenuItem.Count - 1 do
    begin
      ItrateMenu(MenuItem.Items[i]);
    end;
  end;

var
  x: integer;
  s: string;

begin
  if (Comp is TMainMenu) and (xcMainMenu in XPControls) and (TMainMenu(Comp).Tag <> 999)then
  begin
    for x := 0 to TMainMenu(Comp).Items.Count - 1 do
    begin
      TMainMenu(Comp).OwnerDraw := Enable;
      //Activate(TMainMenu(Comp).Items[x]);
      ItrateMenu(TMainMenu(Comp).Items[x]);
    end;
   // Selly way to force top menu in other forms to repaint
    S := TMainMenu(Comp).Items[0].Caption;
    TMainMenu(Comp).Items[0].Caption := '';
    TMainMenu(Comp).Items[0].Caption := S;
  end;

  if (Comp is TPopupMenu) and (xcPopupMenu in XPControls) then
  begin
    for x := 0 to TPopupMenu(Comp).Items.Count - 1 do
    begin
      TPopupMenu(Comp).OwnerDraw := Enable;
      ItrateMenu(TPopupMenu(Comp).Items[x]);

    end;
  end;

  {$IFDEF VER5U}
  if (Comp is TToolBar) and (xcToolBar in FXPControls) then
    if not (csDesigning in ComponentState) then
    begin
      if not TToolBar(Comp).Flat then
        TToolBar(Comp).Flat := true;

      if Enable then
      begin
        for x := 0 to TToolBar(Comp).ButtonCount - 1 do
          if (not assigned(TToolBar(Comp).OnCustomDrawButton))
            or (FOverrideOwnerDraw) then
          begin
            TToolBar(Comp).OnCustomDrawButton :=
              ToolBarDrawButton;

          end;
      end
      else
      begin
        if addr(TToolBar(Comp).OnCustomDrawButton) =
          addr(TXPMenu.ToolBarDrawButton) then
        TToolBar(Comp).OnCustomDrawButton := nil;
      end;
      if Update then
        TToolBar(Comp).Invalidate;
    end;
  {$ENDIF}

  if (Comp is TControlBar) and (xcControlBar in FXPControls) then
    if not (csDesigning in ComponentState) then
    begin
      if Enable then
      begin
        if (not assigned(TControlBar(Comp).OnBandPaint))
          or (FOverrideOwnerDraw) then
        begin
          TControlBar(Comp).OnBandPaint := ControlBarPaint;
        end;
      end
      else
      begin
        if addr(TControlBar(Comp).OnBandPaint) =
          addr(TXPMenu.ControlBarPaint) then
        TControlBar(Comp).OnBandPaint := nil;
      end;
      if Update then
        TControlBar(Comp).Invalidate;
    end;

  if not (csDesigning in ComponentState) then
    if {$IFDEF VER6U}
       ((Comp is TCustomCombo) and (xcCombo in FXPControls)) or
       ((Comp is TCustomLabeledEdit) and (xcEdit in FXPControls)) or

       {$ELSE}
       ((Comp is TCustomComboBox) and (xcCombo in FXPControls)) or
       {$ENDIF}
       ((Comp is TEdit) and (xcEdit in FXPControls)) or
       ((Comp.ClassName = 'TMaskEdit') and (xcMaskEdit in FXPControls)) or
       ((Comp.ClassName = 'TDBEdit') and (xcMaskEdit in FXPControls)) or
       ((Comp is TCustomMemo) and (xcMemo in FXPControls)) or
       ((Comp is TCustomRichEdit) and (xcRichEdit in FXPControls)) or
       ((Comp is TCustomCheckBox) and (xcCheckBox in FXPControls)) or
       ((Comp is TRadioButton) and (xcRadioButton in FXPControls)) or
       ((Comp.ClassName = 'TBitBtn') and (xcBitBtn in FXPControls)) or
       ((Comp.ClassName = 'TButton') and (xcButton in FXPControls)) or
       ((Comp.ClassName = 'TUpDown') and (xcUpDown in FXPControls)) or
       ((Comp is TSpeedButton) and (xcSpeedButton in FXPControls)) or
       ((Comp is TCustomPanel) and (xcPanel in FXPControls)) or
       ((Comp.ClassName = 'TDBNavigator') and (xcButton in FXPControls)) or
       ((Comp.ClassName = 'TDBLookupComboBox') and (xcButton in FXPControls)) or
       ((Comp is TCustomGroupBox) and (xcGroupBox in FXPControls)) or
       ((Comp is TCustomListBox) and (xcListBox in FXPControls)) or
       ((Comp is TCustomTreeView) and (xcTreeView in FXPControls)) or
       ((Comp is TCustomListView) and (xcListView in FXPControls)) or
       ((Comp is TProgressBar) and (xcProgressBar in FXPControls)) or
       ((Comp is TCustomHotKey) and (xcHotKey in FXPControls))
       then
      if ((TControl(Comp).Parent is TToolbar) and (xccToolBar in FXPContainers))or
         ((TControl(Comp).Parent is TCoolbar) and (xccCoolbar in FXPContainers)) or
         ((TControl(Comp).Parent is TCustomPanel) and (xccPanel in FXPContainers)) or
         ((TControl(Comp).Parent is TControlbar) and (xccControlbar in FXPContainers)) or
         ((TControl(Comp).Parent is TScrollBox) and (xccScrollBox in FXPContainers)) or
         ((TControl(Comp).Parent is TCustomGroupBox) and (xccGroupBox in FXPContainers)) or
         ((TControl(Comp).Parent is TTabSheet) and (xccTabSheet in FXPContainers)) or
         ((TControl(Comp).Parent is TTabControl) and (xccTabSheet in FXPContainers)) or
         ((TControl(Comp).Parent.ClassName = 'TdxTabSheet') and (xccTabSheet in FXPContainers)) or //DeveloperExpress
         ((TControl(Comp).Parent is TPageScroller)  and (xccPageScroller in FXPContainers)) or
         {$IFDEF VER5U}
         ((TControl(Comp).Parent is TCustomFrame)  and (xccFrame in FXPContainers)) or
         {$ENDIF}
         ((TControl(Comp).Parent.ClassName = 'TDBCtrlPanel')  and (xccFrame in FXPContainers)) or
         ((TControl(Comp).Parent is TCustomForm) and (xccForm in FXPContainers))


         then
      begin
        if (Enable) and (Comp.Tag <> 999) and (TControl(Comp).Parent.Tag <> 999) then
                                    {skip if Control/Control.parent.tag = 999}
          with TControlSubClass.Create(Self)  do
          begin
            Control := TControl(Comp);
            if Addr(Control.WindowProc) <> Addr(TControlSubClass.ControlSubClass) then
            begin
              orgWindowProc := Control.WindowProc;
              Control.WindowProc := ControlSubClass;
            end;
            XPMenu := self;

            if (Control is TCustomEdit) then
            begin
              FCtl3D := TEdit(Control).Ctl3D;
              FBorderStyle := TRichEdit(Control).BorderStyle;
            end;
            if Control.ClassName = 'TDBLookupComboBox' then
            begin
              FCtl3D := TComboBox(Control).Ctl3D;
            end;
            if (Control is TCustomListBox) then
            begin
              FCtl3D := TListBox(Control).Ctl3D;
              FBorderStyle := TListBox(Control).BorderStyle;
            end;
            if (Control is TCustomListView) then begin
              FCtl3D := TListView(Control).Ctl3D;
              FBorderStyle := TListView(Control).BorderStyle;
            end;
            if (Control is TCustomTreeView) then begin
              FCtl3D := TTreeView(Control).Ctl3D;
              FBorderStyle := TTreeView(Control).BorderStyle;
            end;

          end;

        if Update then
        begin
          TControl(Comp).invalidate    //in TControlSubClass.ControlSubClass
        end;

      end;

  // Recursive call for possible containers.


  // Do recursive call for RadioGroups
  if (((Comp is TCustomRadioGroup)) and (xccGroupBox in FXPContainers)) then
    self.InitItems(Comp as TWinControl, Enable, Update);


  if {$IFDEF VER5U}((Comp is TCustomFrame) and (xccFrame in FXPContainers))
     or {$ENDIF}(Comp.ClassName = 'TDBNavigator')
   or (Comp is TCustomForm) then  //By Geir Wikran <[e-mail]>
    self.InitItems(Comp as TWinControl, Enable, Update);


end;

procedure TXPMenu.DrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect;
  Selected: Boolean);
begin
  try  //"Steve Rice" <[e-mail]>
    if FActive then
      MenueDrawItem(Sender, ACanvas, ARect, Selected);
  except
  end;
end;

function TXPMenu.GetImageExtent(MenuItem: TMenuItem; FTopMenu: TMenu): TPoint;
var
  HasImgLstBitmap: boolean;
  B: TBitmap;
begin
  B := TBitmap.Create;
  try
    B.Width := 0;
    B.Height := 0;
    Result.x := 0;
    Result.Y := 0;
    HasImgLstBitmap := false;
// +jt
    if Assigned(FTopMenu) then
   begin
     if FTopMenu.Images <> nil then
       if MenuItem.ImageIndex <> -1 then
         HasImgLstBitmap := true;
    end;
    if (MenuItem.Parent.GetParentMenu.Images <> nil)
    {$IFDEF VER5U}
    or (MenuItem.Parent.SubMenuImages <> nil)
    {$ENDIF}
    then
    begin
      if MenuItem.ImageIndex <> -1 then
        HasImgLstBitmap := true
      else
        HasImgLstBitmap := false;
    end;

    if HasImgLstBitmap then
    begin
    {$IFDEF VER5U}
      if MenuItem.Parent.SubMenuImages <> nil then
        MenuItem.Parent.SubMenuImages.GetBitmap(MenuItem.ImageIndex, B)
      else
    {$ENDIF}
        MenuItem.Parent.GetParentMenu.Images.GetBitmap(MenuItem.ImageIndex, B)
    end
    else
      if MenuItem.Bitmap.Width > 0 then
        B.Assign(TBitmap(MenuItem.Bitmap));

    Result.x := B.Width;
    Result.Y := B.Height;

    if not Assigned(FTopMenu) then // +jt
      if Result.x < FIconWidth then
        Result.x := FIconWidth;
  finally
    B.Free;
  end;
end;

procedure TXPMenu.MeasureItem(Sender: TObject; ACanvas: TCanvas;
  var Width, Height: Integer);
var
  s: string;
  W, H: integer;
  P: TPoint;
  IsLine: boolean;
  FTopMenu: boolean; // +jt
  FMenu: TMenu; // +jt
  i: integer; // +jt
begin
 
 FTopMenu:=false; //+jt
  if FActive then
  begin
    S := TMenuItem(Sender).Caption;

    if S = '-' then IsLine := true else IsLine := false;
    if IsLine then
      S := '';

    if Trim(ShortCutToText(TMenuItem(Sender).ShortCut)) <> '' then
      S := S + ShortCutToText(TMenuItem(Sender).ShortCut) + 'WWW';

    ACanvas.Font.Assign(FFont);
    W := ACanvas.TextWidth(s);
    Inc(W, 5);
    if pos('&', s) > 0 then
      W := W - ACanvas.TextWidth('&');

// +jt
    FMenu := TMenuItem(Sender).Parent.GetParentMenu;
    if FMenu is TMainMenu then
   begin
     for i := 0 to TMenuItem(Sender).GetParentMenu.Items.Count - 1 do
       if TMenuItem(Sender).GetParentMenu.Items[i] = TMenuItem(Sender) then
       begin
         FTopMenu := True;
         break;
       end
   end;
   if not FTopMenu then FMenu := nil;
   if(not FTopMenu) and (TMenuItem(Sender).Count>0) then Inc(W,6); // +jt
// +jt

    P := GetImageExtent(TMenuItem(Sender), FMenu); // +jt
    W := W + P.x ;


    if Width < W then
      Width := W;

    if IsLine then
      Height := 4
    else
    begin
      H := ACanvas.TextHeight(s) + Round(ACanvas.TextHeight(s) * 0.75);
      if P.y + 6 > H then
        H := P.y + 6;

      if Height < H then
        Height := H;
    end;
  end;

end;

procedure TXPMenu.MenueDrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect;
  Selected: Boolean);
var
  txt: string;
  B: TBitmap;
  IconRect, TextRect, CheckedRect: TRect;
  FillRect: TRect; // +jt
  i, X1, X2: integer;
  TextFormat: integer;
  HasImgLstBitmap: boolean;
  HasBitmap: boolean;
  FMenuItem: TMenuItem;
  FMenu: TMenu;
  FTopMenu: boolean;
  IsLine: boolean;
  ImgListHandle: HImageList;  {Commctrl.pas}
  ImgIndex: integer;