rxmenus.pas

rxlib2.75控件包

{$ENDIF}
              Exit;
            end;
{$IFDEF WIN32}
      WM_HELP:
        with PHelpInfo(Message.LParam)^ do begin
          for I := 0 to Count - 1 do
            if TRxPopupMenu(Items[I]).Handle = hItemHandle then begin
              ContextID := TMenu(Items[I]).GetHelpContext(iCtrlID, True);
              if ContextID = 0 then
                ContextID := TMenu(Items[I]).GetHelpContext(hItemHandle, False);
              if Screen.ActiveForm = nil then Exit;
              if (biHelp in Screen.ActiveForm.BorderIcons) then
                Application.HelpCommand(HELP_CONTEXTPOPUP, ContextID)
              else
                Application.HelpContext(ContextID);
              Exit;
            end;
        end;
{$ELSE}
      WM_ENTERIDLE:
        if (TWMEnterIdle(Message).Source = MSGF_MENU) and
          (GetKeyState(VK_F1) < 0) and (FMenuHelp <> 0) then
        begin
          Application.HelpContext(FMenuHelp);
          FMenuHelp := 0;
          Exit;
        end;
{$ENDIF WIN32}
    end;
    with Message do Result := DefWindowProc(Window, Msg, wParam, lParam);
  except
    Application.HandleException(Self);
  end;
end;

procedure TPopupList.Add(Popup: TPopupMenu);
begin
  if Count = 0 then Window := Classes.AllocateHWnd(WndProc);
  inherited Add(Popup);
end;

procedure TPopupList.Remove(Popup: TPopupMenu);
begin
  inherited Remove(Popup);
  if Count = 0 then Classes.DeallocateHWnd(Window);
end;

{ TRxPopupMenu }

constructor TRxPopupMenu.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  if PopupList = nil then
    PopupList := TPopupList.Create;
  FShowCheckMarks := True;
  FCanvas := TControlCanvas.Create;
  FCursor := crDefault;
  PopupList.Add(Self);
{$IFDEF WIN32}
  FImageChangeLink := TChangeLink.Create;
  FImageChangeLink.OnChange := ImageListChange;
{$ENDIF}
{$IFDEF RX_D4}
  FPopupPoint := Point(-1, -1);
{$ENDIF}
end;

destructor TRxPopupMenu.Destroy;
begin
{$IFDEF WIN32}
  FImageChangeLink.Free;
{$ENDIF}
  SetStyle(msStandard);
  PopupList.Remove(Self);
  FCanvas.Free;
  inherited Destroy;
end;

procedure TRxPopupMenu.Loaded;
begin
  inherited Loaded;
  if IsOwnerDrawMenu then RefreshMenu(True);
end;

{$IFDEF WIN32}
procedure TRxPopupMenu.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if Operation = opRemove then begin
    if AComponent = FImages then SetImages(nil);
  end;
end;

procedure TRxPopupMenu.ImageListChange(Sender: TObject);
begin
  if Sender = FImages then RefreshMenu(IsOwnerDrawMenu);
end;

procedure TRxPopupMenu.SetImages(Value: TImageList);
var
  OldOwnerDraw: Boolean;
begin
  OldOwnerDraw := IsOwnerDrawMenu;
  if FImages <> nil then FImages.UnregisterChanges(FImageChangeLink);
  FImages := Value;
  if Value <> nil then begin
    FImages.RegisterChanges(FImageChangeLink);
    FImages.FreeNotification(Self);
  end;
  if IsOwnerDrawMenu <> OldOwnerDraw then RefreshMenu(not OldOwnerDraw);
end;
{$ENDIF}

{$IFDEF RX_D4}
function FindPopupControl(const Pos: TPoint): TControl;
var
  Window: TWinControl;
begin
  Result := nil;
  Window := FindVCLWindow(Pos);
  if Window <> nil then begin
    Result := Window.ControlAtPos(Pos, False);
    if Result = nil then Result := Window;
  end;
end;

procedure TRxPopupMenu.SetBiDiModeFromPopupControl;
var
  AControl: TControl;
begin
  if not SysLocale.MiddleEast then Exit;
  if FParentBiDiMode then begin
    AControl := FindPopupControl(FPopupPoint);
    if AControl <> nil then
      BiDiMode := AControl.BiDiMode
    else
      BiDiMode := Application.BiDiMode;
  end;
end;

function TRxPopupMenu.UseRightToLeftAlignment: Boolean;
var
  AControl: TControl;
begin
  Result := False;
  if not SysLocale.MiddleEast then Exit;
  if FParentBiDiMode then begin
    AControl := FindPopupControl(FPopupPoint);
    if AControl <> nil then
      Result := AControl.UseRightToLeftAlignment
    else
      Result := Application.UseRightToLeftAlignment;
  end
  else Result := (BiDiMode = bdRightToLeft);
end;
{$ENDIF RX_D4}

procedure TRxPopupMenu.Popup(X, Y: Integer);
const
{$IFDEF RX_D4}
  Flags: array[Boolean, TPopupAlignment] of Word =
    ((TPM_LEFTALIGN, TPM_RIGHTALIGN, TPM_CENTERALIGN),
     (TPM_RIGHTALIGN, TPM_LEFTALIGN, TPM_CENTERALIGN));
  Buttons: array[TTrackButton] of Word = (TPM_RIGHTBUTTON, TPM_LEFTBUTTON);
{$ELSE}
  Flags: array[TPopupAlignment] of Word = (TPM_LEFTALIGN, TPM_RIGHTALIGN,
    TPM_CENTERALIGN);
{$ENDIF}
var
  FOnPopup: TNotifyEvent;
begin
{$IFDEF RX_D4}
  FPopupPoint := Point(X, Y);
  FParentBiDiMode := ParentBiDiMode;
  try
    SetBiDiModeFromPopupControl;
{$ENDIF}
    FOnPopup := OnPopup;
    if Assigned(FOnPopup) then FOnPopup(Self);
    if IsOwnerDrawMenu then RefreshMenu(True);
{$IFNDEF WIN32}
    PopupList.FMenuHelp := HelpContext;
{$ENDIF}
{$IFDEF RX_D4}
    AdjustBiDiBehavior;
    TrackPopupMenu(Items.Handle,
      Flags[UseRightToLeftAlignment, Alignment] or Buttons[TrackButton], X, Y,
      0 { reserved }, PopupList.Window, nil);
  finally
    ParentBiDiMode := FParentBiDiMode;
  end;
{$ELSE}
  TrackPopupMenu(Items.Handle, Flags[Alignment] or TPM_RIGHTBUTTON, X, Y,
    0 { reserved }, PopupList.Window, nil);
{$ENDIF}
end;

procedure TRxPopupMenu.Refresh;
begin
  RefreshMenu(IsOwnerDrawMenu);
end;

function TRxPopupMenu.IsOwnerDrawMenu: Boolean;
begin
  Result := (FStyle <> msStandard)
    {$IFDEF WIN32} or (Assigned(FImages) and (FImages.Count > 0)) {$ENDIF};
end;

procedure TRxPopupMenu.RefreshMenu(AOwnerDraw: Boolean);
{$IFDEF RX_D4}
begin
  Self.OwnerDraw := AOwnerDraw and not (csDesigning in ComponentState);
{$ELSE}
var
  I: Integer;
begin
  if not (csDesigning in ComponentState) then
    for I := 0 to Items.Count - 1 do
      RefreshMenuItem(Items[I], AOwnerDraw);
{$ENDIF}
end;

procedure TRxPopupMenu.SetStyle(Value: TRxMenuStyle);
begin
  if FStyle <> Value then begin
    FStyle := Value;
    RefreshMenu(IsOwnerDrawMenu);
  end;
end;

procedure TRxPopupMenu.DefaultDrawItem(Item: TMenuItem; Rect: TRect;
  State: TMenuOwnerDrawState);
var
  Graphic: TGraphic;
  BackColor: TColor;
  NumGlyphs {$IFDEF WIN32}, ImageIndex {$ENDIF}: Integer;
begin
  if Canvas.Handle <> 0 then begin
    Graphic := nil;
    BackColor := Canvas.Brush.Color;
    NumGlyphs := 1;
    GetItemParams(Item, State, Canvas.Font, BackColor, Graphic, NumGlyphs);
{$IFDEF WIN32}
{$IFDEF RX_D4}
    ImageIndex := Item.ImageIndex;
{$ELSE}
    ImageIndex := -1;
{$ENDIF}
    GetImageIndex(Item, State, ImageIndex);
{$ENDIF}
    DrawMenuItem(Self, Item, Graphic, NumGlyphs, Canvas, FShowCheckMarks,
      BtnStyle(Style), Rect, FMinTextOffset, State
      {$IFDEF WIN32}, FImages, ImageIndex {$ENDIF});
  end;
end;

procedure TRxPopupMenu.DrawItem(Item: TMenuItem; Rect: TRect;
  State: TMenuOwnerDrawState);
var
  Graphic: TGraphic;
  BackColor: TColor;
  NumGlyphs {$IFDEF WIN32}, ImageIndex {$ENDIF}: Integer;
begin
  if Canvas.Handle <> 0 then begin
    Graphic := nil;
    BackColor := Canvas.Brush.Color;
    NumGlyphs := 1;
    GetItemParams(Item, State, Canvas.Font, BackColor, Graphic, NumGlyphs);
    if BackColor <> clNone then begin
      Canvas.Brush.Color := BackColor;
      Canvas.FillRect(Rect);
    end;
    if Assigned(FOnDrawItem) then FOnDrawItem(Self, Item, Rect, State)
    else begin
{$IFDEF WIN32}
{$IFDEF RX_D4}
      ImageIndex := Item.ImageIndex;
{$ELSE}
      ImageIndex := -1;
{$ENDIF}
      GetImageIndex(Item, State, ImageIndex);
{$ENDIF}
      DrawMenuItem(Self, Item, Graphic, NumGlyphs, Canvas, FShowCheckMarks,
        BtnStyle(Style), Rect, FMinTextOffset, State
        {$IFDEF WIN32}, FImages, ImageIndex {$ENDIF});
    end;
  end;
end;

procedure TRxPopupMenu.MeasureItem(Item: TMenuItem; var Width, Height: Integer);
begin
  if Assigned(FOnMeasureItem) then FOnMeasureItem(Self, Item, Width, Height)
end;

procedure TRxPopupMenu.WndMessage(Sender: TObject; var AMsg: TMessage;
  var Handled: Boolean);
begin
  if IsOwnerDrawMenu then MenuWndMessage(Self, AMsg, Handled);
end;

procedure TRxPopupMenu.GetItemParams(Item: TMenuItem; State: TMenuOwnerDrawState;
  AFont: TFont; var Color: TColor; var Graphic: TGraphic; var NumGlyphs: Integer);
begin
  if Assigned(FOnGetItemParams) then
    FOnGetItemParams(Self, Item, State, AFont, Color, Graphic, NumGlyphs);
  if (Item <> nil) and (Item.Caption = Separator) then Graphic := nil;
end;

{$IFDEF WIN32}
procedure TRxPopupMenu.GetImageIndex(Item: TMenuItem; State: TMenuOwnerDrawState;
  var ImageIndex: Integer);
begin
  if Assigned(FImages) and (Item <> nil) and (Item.Caption <> Separator) and
    Assigned(FOnGetImageIndex) then
    FOnGetImageIndex(Self, Item, State, ImageIndex);
end;
{$ENDIF}

procedure TRxPopupMenu.DefaultDrawMargin(ARect: TRect; StartColor,
  EndColor: TColor);
var
  R: Integer;
begin
  with ARect do begin
    if NewStyleControls then R := Right - 3
    else R := Right;
    GradientFillRect(Canvas, Rect(Left, Top, R, Bottom), StartColor,
      EndColor, fdTopToBottom, 32);
    if NewStyleControls then begin
      MenuLine(Canvas, clBtnShadow, Right - 2, Top, Right - 2, Bottom);
      MenuLine(Canvas, clBtnHighlight, Right - 1, Top, Right - 1, Bottom);
    end;
  end;
end;

procedure TRxPopupMenu.DrawMargin(ARect: TRect);
begin
  if Assigned(FOnDrawMargin) then FOnDrawMargin(Self, ARect)
  else begin
    DefaultDrawMargin(ARect, DefMarginColor, RGB(
      GetRValue(DefMarginColor) div 4,
      GetGValue(DefMarginColor) div 4,
      GetBValue(DefMarginColor) div 4));
  end;
end;

procedure TRxPopupMenu.WMDrawItem(var Message: TWMDrawItem);
var
  State: TMenuOwnerDrawState;
  SaveIndex: Integer;
  Item: TMenuItem;
  MarginRect: TRect;
begin
  with Message.DrawItemStruct^ do begin
{$IFDEF WIN32}
    State := TMenuOwnerDrawState(WordRec(LongRec(itemState).Lo).Lo);
{$ELSE}
    State := TMenuOwnerDrawState(WordRec(itemState).Lo);
{$ENDIF}
    Item := TMenuItem(Pointer(itemData));
    if Assigned(Item) and
      (FindItem(Item.Command, fkCommand) = Item) then
    begin
      SaveIndex := SaveDC(hDC);
      try
        FCanvas.Handle := hDC;
        if (Item.Parent = Self.Items) and (FLeftMargin > 0) then
          if (itemAction = ODA_DRAWENTIRE) then begin
            MarginRect := FCanvas.ClipRect;
            MarginRect.Left := 0;
            MarginRect.Right := FLeftMargin;
            DrawMargin(MarginRect);
          end;
        SetDefaultMenuFont(FCanvas.Font);
        FCanvas.Font.Color := clMenuText;
        FCanvas.Brush.Color := clMenu;
{$IFDEF WIN32}
        if mdDefault in State then
          FCanvas.Font.Style := FCanvas.Font.Style + [fsBold];
{$ENDIF}
        if (mdSelected in State) {$IFDEF WIN32} and
          not (Style in [msBtnLowered, msBtnRaised]) {$ENDIF} then
        begin
          FCanvas.Brush.Color := clHighlight;
          FCanvas.Font.Color := clHighlightText;
        end;
        if (Item.Parent = Self.Items) then
          Inc(rcItem.Left, LeftMargin + 1);
        with rcItem do
          IntersectClipRect(FCanvas.Handle, Left, Top, Right, Bottom);
        DrawItem(Item, rcItem, State);
        FCanvas.Handle := 0;
      finally
        RestoreDC(hDC, SaveIndex);
      end;
    end;
  end;
end;

procedure TRxPopupMenu.WMMeasureItem(var Message: TWMMeasureItem);
var
  Item: TMenuItem;
  Graphic: TGraphic;
  BackColor: TColor;
  NumGlyphs {$IFDEF WIN32}, ImageIndex {$ENDIF}: Integer;
begin
  with Message.MeasureItemStruct^ do begin
    Item := TMenuItem(Pointer(itemData));
    if Assigned(Item) and (FindItem(Item.Command, fkCommand) = Item) then
    begin
      FCanvas.Handle := GetDC(0);
      try
        SetDefaultMenuFont(FCanvas.Font);
{$IFDEF WIN32}
        if Item.Default then
          FCanvas.Font.Style := FCanvas.Font.Style + [fsBold];
{$ENDIF}
        Graphic := nil;
        BackColor := Canvas.Brush.Color;
        NumGlyphs := 1;
        GetItemParams(Item, [], FCanvas.Font, BackColor, Graphic, NumGlyphs);
{$IFDEF WIN32}
{$IFDEF RX_D4}
        ImageIndex := Item.ImageIndex;
{$ELSE}
        ImageIndex := -1;
{$ENDIF}
        GetImageIndex(Item, [], ImageIndex);
{$ENDIF}
        MenuMeasureItem(Self, Item, FCanvas, FShowCheckMarks, Graphic,
          NumGlyphs, Integer(itemWidth), Integer(itemHeight), FMinTextOffset
          {$IFDEF WIN32}, FImages, ImageIndex {$ENDIF});
        MeasureItem(Item, Integer(itemWidth), Integer(itemHeight));
        if (Item.Parent = Self.Items) then
          Inc(itemWidth, LeftMargin + 1);
      finally
        ReleaseDC(0, FCanvas.Handle);
        FCanvas.Handle := 0;
      end;
    end;
  end;
end;

{$IFNDEF WIN32}
procedure FreePopupList; far;
begin
  if PopupList <> nil then begin
    PopupList.Free;
    PopupList := nil;
  end;
end;
{$ENDIF}

initialization
  PopupList := nil;
{$IFDEF WIN32}
finalization
  if PopupList <> nil then PopupList.Free;
{$ELSE}
  AddExitProc(FreePopupList);
{$ENDIF}
end.