xpmenu.pas

一套非常好用的delphi控件,方便程序员工作

  i      : integer;
  NewForm: TCustomForm;

begin
  Result := false;
  // If the main XPMenu was destroyed then it posted this message to the application, so
  // that all still existing XPMenus know that the role of the main XPMenu is vacant. The
  // XPMenu that gets this message first will be the new main XPMenu.
  if Message.Msg = WM_MAINXPMENURELEASED then
  begin
    // check first, if the role of the main XPMenu is still vacant
    if MainXPMenu = nil then
    begin
      MainXPMenu := self;
      // Enable subclassing if the former main XPMenu also subclassed forms
      FDisableSubclassing := (Message.WParam = 1);
      CollectForms;
    end;
  end;

  if FPendingFormsList.Count > 0 then begin
    for i := 0 to FPendingFormsList.Count - 1 do begin
      NewForm := TCustomForm(FPendingFormsList[i]);
      FFormList.Add(NewForm);
      InitItems(NewForm, FActive, true);
    end;
    FPendingFormsList.Clear;
  end;
end;

// Collect all forms of the application and subclass them
procedure TXPMenu.CollectForms;
var
  Cnt: integer;
begin
  if not FDisableSubclassing and not(csDesigning in ComponentState) then
  begin
    for Cnt := 0 to Screen.FormCount - 1 do
    begin
      if FFormList.IndexOf(Screen.Forms[Cnt]) < 0 then
        FFormList.Add(Screen.Forms[Cnt]);
      InitItems(Screen.Forms[Cnt] as TWinControl, FActive, true);
    end;
  end;
end;

procedure TXPMenu.MakeMainXPMenu;
begin
  MainXPMenu.DisableSubclassing := true;
  MainXPMenu := Self;
  CollectForms;
end;
// ----- end ur -----

{to check for new sub items}
procedure TXPMenu.ActivateMenuItem(MenuItem: TMenuItem);

  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);
  for i := 0 to MenuItem.Parent.Count -1 do
  begin
    Activate(MenuItem.Parent.Items[i]);
    for j := 0 to MenuItem.Parent.Items[i].Count - 1 do
      ActivateMenuItem(MenuItem.Parent.Items[i].Items[j]);
  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;

//type
//  TMenuItemCast = class(TMenuItem);

// 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 := S;
    TMainMenu(Comp).Items[0].Caption := Copy(S, 1, Length(S)-1);
//   windows.DrawMenuBar(TMainMenu(Comp).WindowHandle) ;
  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;
      //Activate(TPopupMenu(Comp).Items[x]);
      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 (xcButton 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))
       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;


          end;

        if Update then
        begin
         // if Comp is TWinControl then    //Cause error with non wincontrol
            TControl(Comp).invalidate    //in TControlSubClass.ControlSubClass
         // else
         //   TControl(Comp).Update;
        end;

      end;


  // Recursive call for possible containers.

  // Added by Uwe Runkel, [e-mail]
  // Do recursive call for RadioGroups
  if (((Comp is TCustomRadioGroup)) and (xccGroupBox in FXPContainers)) then
    self.InitItems(Comp as TWinControl, Enable, Update);
  // ----- end ur -----

////  {$IFDEF VER5U}
  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);
////  {$ENDIF}

end;

procedure TXPMenu.DrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect;
  Selected: Boolean);
begin
  if FActive then
    MenueDrawItem(Sender, ACanvas, ARect, Selected);
end;



function TXPMenu.GetImageExtent(MenuItem: TMenuItem): TPoint;
var
  HasImgLstBitmap: boolean;
  B: TBitmap;
  FTopMenu: boolean;
begin
  FTopMenu := false;
  B := TBitmap.Create;
  try
    B.Width := 0;
    B.Height := 0;
    Result.x := 0;
    Result.Y := 0;
    HasImgLstBitmap := false;

    {Changes MMK TForm and TFrame}
    if (FForm is TForm) and ((FForm as TForm).Menu <> nil) then
      if MenuItem.GetParentComponent.Name = (FForm as TForm).Menu.Name then
      begin
        FTopMenu := true;
        if (FForm as TForm).Menu.Images <> nil then
          if MenuItem.ImageIndex <> -1 then
            HasImgLstBitmap := true;

      end;

    {End Changes}


    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 FTopMenu then
      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;
  OSVersionInfo: TOSVersionInfo;
begin
  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('&');

    P := GetImageExtent(TMenuItem(Sender));
//    if P.X > 0 then
//      if not (TMenuItem(Sender).parent.Name = '') then//"Pedro Miguel Cunha" <[e-mail]>(merging menus)
        W := W + P.x ;


    //Add 8 pixels for win2k
    if (FForm is TForm) and ((FForm as TForm).Menu <> nil) then
      if TMenuItem(Sender).GetParentComponent.Name = (FForm as TForm).Menu.Name then
      begin  //FTopMenu := true;
        GetVersionEx(OSVersionInfo);
        if OSVersionInfo.dwPlatformId = VER_PLATFORM_WIN32_NT then
          Inc(W, 8);
      end;

    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;