rxmenus.pas

rxlib2.75控件包

          for I := 0 to C - 1 do begin
            PrepareItemInfo;
            MenuItemInfo.dwTypeData := CCaption;
            GetMenuItemInfo(MenuHandle, I, True, MenuItemInfo);
            if MenuItemInfo.wID = MenuItem.Command then begin
              ItemID := I;
              Break;
            end;
          end;
        end;
        if ItemID < 0 then Exit;
        with MenuItem do
          MenuItemInfo.fType := IRadios[RadioItem] or IBreaks[Break] or
            ISeparators[Caption = Separator] or IOwnerDraw[OwnerDraw];
        MenuItemInfo.dwTypeData := CCaption;
        DeleteMenu(MenuHandle, MenuItem.Command, MF_BYCOMMAND);
        InsertMenuItem(MenuHandle, ItemID, True, MenuItemInfo);
      end;
    end
    else
{$ENDIF WIN32}
    begin
      if OwnerDraw then begin
        ModifyMenu(MenuHandle, MenuItem.Command, NewFlags or MF_OWNERDRAW and
          not MF_STRING, ItemID, PChar(MenuItem));
      end
      else begin
        ModifyMenu(MenuHandle, MenuItem.Command, NewFlags, ItemID, CCaption);
      end;
    end;
    for I := 0 to MenuItem.Count - 1 do
      RefreshMenuItem(MenuItem.Items[I], OwnerDraw);
  end;
end;
{$ENDIF RX_D4}

procedure SetDefaultMenuFont(AFont: TFont);
{$IFDEF WIN32}
var
  NCMetrics: TNonCLientMetrics;
{$ENDIF}
begin
{$IFDEF WIN32}
  if NewStyleControls then begin
    NCMetrics.cbSize := SizeOf(TNonCLientMetrics);
    if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @NCMetrics, 0) then
    begin
      AFont.Handle := CreateFontIndirect(NCMetrics.lfMenuFont);
      Exit;
    end;
  end;
{$ENDIF}
  with AFont do begin
    if NewStyleControls then Name := 'MS Sans Serif'
    else Name := 'System';
    Size := 8;
    Color := clMenuText;
    Style := [];
  end;
  AFont.Color := clMenuText;
end;

function GetDefItemHeight: Integer;
begin
  Result := GetSystemMetrics(SM_CYMENU);
  if NewStyleControls then Dec(Result, 2);
end;

function GetMarginOffset: Integer;
begin
  Result := Round(LoWord(GetMenuCheckMarkDimensions) * 0.3);
end;

procedure MenuLine(Canvas: TCanvas; C: TColor; X1, Y1, X2, Y2: Integer);
begin
  with Canvas do begin
    Pen.Color := C;
    MoveTo(X1, Y1);
    LineTo(X2, Y2);
  end;
end;

procedure DrawDisabledBitmap(Canvas: TCanvas; X, Y: Integer; Bitmap: TBitmap;
  State: TMenuOwnerDrawState);
const
  ROP_DSPDxax = $00E20746;
var
  Bmp: TBitmap;
  GrayColor, SaveColor: TColor;
  IsHighlight: Boolean;
begin
  if (mdSelected in State) then GrayColor := clGrayText
  else GrayColor := clBtnShadow;
  IsHighlight := NewStyleControls and ((not (mdSelected in State)) or
    (GetNearestColor(Canvas.Handle, ColorToRGB(clGrayText)) =
    GetNearestColor(Canvas.Handle, ColorToRGB(clHighlight))));
  if Bitmap.Monochrome then begin
    SaveColor := Canvas.Brush.Color;
    try
      if IsHighlight then begin
        Canvas.Brush.Color := clBtnHighlight;
        SetTextColor(Canvas.Handle, clWhite);
        SetBkColor(Canvas.Handle, clBlack);
        BitBlt(Canvas.Handle, X + 1, Y + 1, Bitmap.Width, Bitmap.Height,
          Bitmap.Canvas.Handle, 0, 0, ROP_DSPDxax);
      end;
      Canvas.Brush.Color := GrayColor;
      SetTextColor(Canvas.Handle, clWhite);
      SetBkColor(Canvas.Handle, clBlack);
      BitBlt(Canvas.Handle, X, Y, Bitmap.Width, Bitmap.Height,
        Bitmap.Canvas.Handle, 0, 0, ROP_DSPDxax);
    finally
      Canvas.Brush.Color := SaveColor;
    end;
  end
  else begin
    Bmp := CreateDisabledBitmapEx(Bitmap, clBlack, clMenu,
      clBtnHighlight, GrayColor, IsHighlight);
    try
      DrawBitmapTransparent(Canvas, X, Y, Bmp, clMenu);
    finally
      Bmp.Free;
    end;
  end;
end;

procedure DrawMenuBitmap(Canvas: TCanvas; X, Y: Integer; Bitmap: TBitmap;
  IsColor: Boolean; State: TMenuOwnerDrawState);
begin
  if (mdDisabled in State) then
    DrawDisabledBitmap(Canvas, X, Y, Bitmap, State)
  else begin
    if Bitmap.Monochrome and not IsColor then
      BitBlt(Canvas.Handle, X, Y, Bitmap.Width, Bitmap.Height,
        Bitmap.Canvas.Handle, 0, 0, SRCCOPY)
    else
      DrawBitmapTransparent(Canvas, X, Y, Bitmap, Bitmap.TransparentColor
        and not PaletteMask);
  end;
end;

procedure DrawMenuItem(AMenu: TMenu; Item: TMenuItem; Glyph: TGraphic;
  NumGlyphs: Integer; Canvas: TCanvas; ShowCheck: Boolean; Buttons: TBtnStyle;
  Rect: TRect; MinOffset: {$IFDEF RX_D4} Integer {$ELSE} Cardinal {$ENDIF};
  State: TMenuOwnerDrawState {$IFDEF WIN32}; Images: TImageList;
  ImageIndex: Integer {$ENDIF});
var
  Left, LineTop, MaxWidth, I, W: Integer;
  CheckSize: Longint;
  BtnRect: TRect;
  IsPopup, DrawHighlight, DrawLowered: Boolean;
  GrayColor: TColor;
  Bmp: TBitmap;
{$IFDEF WIN32}
  Ico: HIcon;
  H: Integer;
{$ENDIF}
{$IFDEF RX_D4}
  ParentMenu: TMenu;
{$ENDIF}

  procedure MenuTextOut(X, Y: Integer; const Text: string; Flags: Longint);
  var
    R: TRect;
  begin
    if Length(Text) = 0 then Exit;
{$IFDEF RX_D4}
    if (ParentMenu <> nil) and (ParentMenu.IsRightToLeft) then begin
      if Flags and DT_LEFT = DT_LEFT then
        Flags := Flags and (not DT_LEFT) or DT_RIGHT
      else if Flags and DT_RIGHT = DT_RIGHT then
        Flags := Flags and (not DT_RIGHT) or DT_LEFT;
      Flags := Flags or DT_RTLREADING;
    end;
{$ENDIF}
    R := Rect; R.Left := X; R.Top := Y;
    if (mdDisabled in State) then begin
      if DrawHighlight then begin
        Canvas.Font.Color := clBtnHighlight;
        OffsetRect(R, 1, 1);
        DrawText(Canvas.Handle, @Text[1], Length(Text), R, Flags);
        OffsetRect(R, -1, -1);
      end;
      Canvas.Font.Color := GrayColor;
    end;
    DrawText(Canvas.Handle, @Text[1], Length(Text), R, Flags)
  end;

  procedure DrawCheckImage(X, Y: Integer);
  begin
    Bmp := TBitmap.Create;
    try
{$IFDEF WIN32}
      with Bmp do begin
        Width := LoWord(CheckSize);
        Height := HiWord(CheckSize);
      end;
      if Item.RadioItem then begin
        with Bmp do begin
          DrawFrameControl(Canvas.Handle, Bounds(0, 0, Width, Height),
            DFC_MENU, DFCS_MENUBULLET);
          Monochrome := True;
        end;
      end
      else begin
        with Bmp do begin
          DrawFrameControl(Canvas.Handle, Bounds(0, 0, Width, Height),
            DFC_MENU, DFCS_MENUCHECK);
          Monochrome := True;
        end;
      end;
{$ELSE}
      Bmp.Handle := LoadBitmap(0, PChar(32760));
{$ENDIF}
      DrawMenuBitmap(Canvas, X, Y, Bmp, DrawLowered, State);
    finally
      Bmp.Free;
    end;
  end;

  procedure DrawGlyphCheck(ARect: TRect);
  var
    SaveColor: TColor;
    Bmp: TBitmap;
  begin
    InflateRect(ARect, 0, -1);
    SaveColor := Canvas.Brush.Color;
    try
      if not (mdSelected in State) then
{$IFDEF RX_D4}
        Bmp := AllocPatternBitmap(clMenu, clBtnHighlight)
{$ELSE}
        Bmp := CreateTwoColorsBrushPattern(clMenu, clBtnHighlight)
{$ENDIF}
      else Bmp := nil;
      try
        if Bmp <> nil then Canvas.Brush.Bitmap := Bmp
        else Canvas.Brush.Color := clMenu;
        Canvas.FillRect(ARect);
      finally
        Canvas.Brush.Bitmap := nil;
{$IFNDEF RX_D4}
        Bmp.Free;
{$ENDIF}
      end;
    finally
      Canvas.Brush.Color := SaveColor;
    end;
    Frame3D(Canvas, ARect, GrayColor, clBtnHighlight, 1);
  end;

{$IFDEF WIN32}
  function UseImages: Boolean;
  begin
    Result := Assigned(Images) and (ImageIndex >= 0) and
      (ImageIndex < Images.Count) and Images.HandleAllocated;
  end;
{$ENDIF}

begin
  IsPopup := IsItemPopup(Item);
  
  DrawLowered := Item.Checked and IsPopup and not (ShowCheck or
    (Buttons in [bsLowered, bsRaised]));
  DrawHighlight := NewStyleControls and (not (mdSelected in State) or
    (Buttons in [bsLowered, bsRaised]) or (not IsPopup and
    (Buttons = bsOffice)) or
    (GetNearestColor(Canvas.Handle, ColorToRGB(clGrayText)) =
    GetNearestColor(Canvas.Handle, ColorToRGB(clHighlight))));
  if (mdSelected in State) and not (Buttons in [bsLowered, bsRaised]) then
    GrayColor := clGrayText
  else GrayColor := clBtnShadow;
  if IsPopup then begin
    if ShowCheck then
      CheckSize := GetMenuCheckMarkDimensions
    else
      CheckSize := 2;
    Left := 2 * GetMarginOffset + LoWord(CheckSize);
  end
  else begin
    MinOffset := 0;
    CheckSize := 0;
    Left := GetMarginOffset + 2;
  end;
  if (Buttons <> bsNone) and (mdSelected in State) then begin
    case Buttons of
      bsLowered: Frame3D(Canvas, Rect, clBtnShadow, clBtnHighlight, 1);
      bsRaised: Frame3D(Canvas, Rect, clBtnHighlight, clBtnShadow, 1);
      bsOffice:
        if not IsPopup then
          Frame3D(Canvas, Rect, clBtnShadow, clBtnHighlight, 1);
    end;
  end;
  if Assigned(Item) then begin
{$IFDEF RX_D4}
    ParentMenu := Item.GetParentMenu;
{$ENDIF}
    if Item.Checked and ShowCheck and IsPopup then begin
      DrawCheckImage(Rect.Left + (Left - LoWord(CheckSize)) div 2,
        (Rect.Bottom + Rect.Top - HiWord(CheckSize)) div 2);
    end;
{$IFDEF WIN32}
    if Assigned(Images) and IsPopup then
      MinOffset := Max(MinOffset, Images.Width + AddWidth);
{$ENDIF}
    if not ShowCheck and (Assigned(Glyph) or (MinOffset > 0)) then
      if Buttons = bsOffice then Left := 1
      else Left := GetMarginOffset;
{$IFDEF WIN32}
    if UseImages then begin
      W := Images.Width + AddWidth;
      if W < Integer(MinOffset) then W := MinOffset;
      BtnRect := Bounds(Rect.Left + Left - 1, Rect.Top, W + 2,
        Rect.Bottom - Rect.Top);
      if DrawLowered then DrawGlyphCheck(BtnRect)
      else if (mdSelected in State) and IsPopup and (Buttons = bsOffice) and
        not ShowCheck then
      begin
        Frame3D(Canvas, BtnRect, clBtnHighlight, GrayColor, 1);
      end;
      if (mdDisabled in State) then
        ImageListDrawDisabled(Images, Canvas, Rect.Left + Left +
          (W - Images.Width) div 2, (Rect.Bottom + Rect.Top -
          Images.Height) div 2, ImageIndex, clBtnHighlight, GrayColor,
          DrawHighlight)
      else ImageList_Draw(Images.Handle, ImageIndex, Canvas.Handle,
        Rect.Left + Left + (W - Images.Width) div 2, (Rect.Bottom +
        Rect.Top - Images.Height) div 2, ILD_NORMAL);
      Inc(Left, W + GetMarginOffset);
    end else
{$ENDIF}
    if Assigned(Glyph) and not Glyph.Empty and (Item.Caption <> Separator) then
    begin
      W := Glyph.Width;
      if (Glyph is TBitmap) and (NumGlyphs in [2..5]) then
        W := W div NumGlyphs;
      W := Max(W + AddWidth, MinOffset);
{$IFDEF WIN32}
      if not (Glyph is TIcon) then
{$ENDIF}
      begin
        BtnRect := Bounds(Rect.Left + Left - 1, Rect.Top, W + 2,
          Rect.Bottom - Rect.Top);
        if DrawLowered then DrawGlyphCheck(BtnRect)
        else if (mdSelected in State) and IsPopup and (Buttons = bsOffice) and
          not ShowCheck then
        begin
          Frame3D(Canvas, BtnRect, clBtnHighlight, GrayColor, 1);
        end;
      end;
      if Glyph is TBitmap then begin
        if (NumGlyphs in [2..5]) then begin
          I := 0;
          if (mdDisabled in State) then I := 1
          else if (mdChecked in State) then I := 3
          else if (mdSelected in State) then I := 2;
          if I > NumGlyphs - 1 then I := 0;
          Bmp := TBitmap.Create;
          try
            AssignBitmapCell(Glyph, Bmp, NumGlyphs, 1, I);
            DrawMenuBitmap(Canvas, Rect.Left + Left + (W - Bmp.Width) div 2,
              (Rect.Bottom + Rect.Top - Bmp.Height) div 2, Bmp, DrawLowered,
              State - [mdDisabled]);
          finally
            Bmp.Free;
          end;
        end
        else DrawMenuBitmap(Canvas, Rect.Left + Left + (W - Glyph.Width) div 2,
          (Rect.Bottom + Rect.Top - Glyph.Height) div 2, TBitmap(Glyph),
          DrawLowered, State);
        Inc(Left, W + GetMarginOffset);
      end
{$IFDEF WIN32}
      else if Glyph is TIcon then begin
        Ico := CreateRealSizeIcon(TIcon(Glyph));
        try
          GetIconSize(Ico, W, H);
          I := Max(W + AddWidth, MinOffset);
          BtnRect := Bounds(Rect.Left + Left - 1, Rect.Top, I + 2,
            Rect.Bottom - Rect.Top);
          if DrawLowered then DrawGlyphCheck(BtnRect)
          else if (mdSelected in State) and IsPopup and (Buttons = bsOffice) and
            not ShowCheck then
          begin
            Frame3D(Canvas, BtnRect, clBtnHighlight, GrayColor, 1);
          end;
          DrawIconEx(Canvas.Handle, Rect.Left + Left + (I - W) div 2,
            (Rect.Top + Rect.Bottom - H) div 2, Ico, W, H, 0, 0, DI_NORMAL);
          Inc(Left, I + GetMarginOffset);
        finally
          DestroyIcon(Ico);
        end;
      end
{$ENDIF}
      else begin
        Canvas.Draw(Rect.Left + Left + (W - Glyph.Width) div 2,
          (Rect.Bottom + Rect.Top - Glyph.Height) div 2, Glyph);
        Inc(Left, W + GetMarginOffset);
      end;
    end
    else if (MinOffset > 0) then begin
      BtnRect := Bounds(Rect.Left + Left - 1, Rect.Top, MinOffset + 2,
        Rect.Bottom - Rect.Top);
      if DrawLowered then begin
        DrawGlyphCheck(BtnRect);
        CheckSize := GetMenuCheckMarkDimensions;
        DrawCheckImage(BtnRect.Left + 2 + (MinOffset - LoWord(CheckSize)) div 2,
          (Rect.Bottom + Rect.Top - HiWord(CheckSize)) div 2 + 1);
      end
      else if (mdSelected in State) and IsPopup and (Buttons = bsOffice) and
        not ShowCheck then
      begin
        Frame3D(Canvas, BtnRect, clBtnHighlight, GrayColor, 1);
      end;
      Inc(Left, MinOffset + GetMarginOffset);
    end;
    if Item.Caption = Separator then begin
      LineTop := (Rect.Top + Rect.Bottom) div 2 - 1;
      if NewStyleControls then begin
        Canvas.Pen.Width := 1;
        MenuLine(Canvas, clBtnShadow, Rect.Left, LineTop, Rect.Right, LineTop);
        MenuLine(Canvas, clBtnHighlight, Rect.Left, LineTop + 1, Rect.Right, LineTop + 1);
      end
      else begin
        Canvas.Pen.Width := 2;
        MenuLine(Canvas, clMenuText, Rect.Left, LineTop + 1, Rect.Right, LineTop + 1);
      end;
    end
    else begin
      MaxWidth := Canvas.TextWidth(DelChars(Item.Caption, '&') + Tab);
      if (Item.Parent <> nil) and (Item.ShortCut <> scNone) then begin
        for I := 0 to Item.Parent.Count - 1 do
          MaxWidth := Max(Canvas.TextWidth(DelChars(Item.Parent.Items[I].Caption,
            '&') + Tab), MaxWidth);
      end;
      Canvas.Brush.Style := bsClear;
      LineTop := (Rect.Bottom + Rect.Top - Canvas.TextHeight('Ay')) div 2;
      MenuTextOut(Rect.Left + Left, LineTop, Item.Caption, DT_EXPANDTABS or
        DT_LEFT or DT_SINGLELINE);
      if (Item.ShortCut <> scNone) and (Item.Count = 0) and IsPopup then begin
        MenuTextOut(Rect.Left + Left + MaxWidth, LineTop,
          ShortCutToText(Item.ShortCut), DT_EXPANDTABS or DT_LEFT or
          DT_SINGLELINE);
      end;
    end;
  end;
end;

procedure MenuMeasureItem(AMenu: TMenu; Item: TMenuItem; Canvas: TCanvas;
  ShowCheck: Boolean; Glyph: TGraphic; NumGlyphs: Integer; var ItemWidth,
  ItemHeight: Integer; MinOffset: Cardinal {$IFDEF WIN32}; Images: TImageList;
  ImageIndex: Integer {$ENDIF});
var
  IsPopup: Boolean;
  W, H: Integer;
{$IFDEF WIN32}
  Ico: HIcon;
{$ENDIF}

  function GetTextWidth(Item: TMenuItem): Integer;
  var
    I, MaxW: Integer;
  begin
    if IsPopup then begin
      Result := Canvas.TextWidth(DelChars(Item.Caption, '&') + Tab);