tntmenus.pas

Make your Delphi application UNICODE enabled.

  procedure DrawMenuText(BiDi: Boolean);
  var
    ImageList: TCustomImageList;
    DrawImage, DrawGlyph: Boolean;
    GlyphRect, SaveRect: TRect;
    DrawStyle: Longint;
    Selected: Boolean;
    Win98Plus: Boolean;
    Win2K: Boolean;
  begin
    ImageList := GetImageList;
    Selected := odSelected in State;
    Win98Plus := (Win32MajorVersion > 4) or
      ((Win32MajorVersion = 4) and (Win32MinorVersion > 0));
    Win2K := (Win32MajorVersion > 4) and (Win32Platform = VER_PLATFORM_WIN32_NT);
    with ACanvas do
    begin
      GlyphRect.Left := ARect.Left + 1;
      DrawImage := (ImageList <> nil) and ((ImageIndex > -1) and
        (ImageIndex < ImageList.Count) or Checked and ((not MenuItemHasBitmap(Self)) or
        Bitmap.Empty));
      if DrawImage or MenuItemHasBitmap(Self) and not Bitmap.Empty then
      begin
        DrawGlyph := True;
        if DrawImage then
          GlyphRect.Right := GlyphRect.Left + ImageList.Width
        else begin
          { Need to add BitmapWidth/Height properties for TMenuItem if we're to
            support them.  Right now let's hardcode them to 16x16. }
          GlyphRect.Right := GlyphRect.Left + 16;
        end;
        { Draw background pattern brush if selected }
        if Checked then
        begin
          Inc(GlyphRect.Right);
          if not Selected then
            Brush.Bitmap := AllocPatternBitmap(clBtnFace, clBtnHighlight);
          Inc(GlyphRect.Left);
        end;
        if Checked then
          Dec(GlyphRect.Right);
      end else begin
        if (ImageList <> nil) and (not TopLevel) then
          GlyphRect.Right := GlyphRect.Left + ImageList.Width
        else
          GlyphRect.Right := GlyphRect.Left;
        DrawGlyph := False;
      end;
      if BiDi then begin
        SaveRect := GlyphRect;
        GlyphRect.Left := ARect.Right - (SaveRect.Right - ARect.Left);
        GlyphRect.Right := ARect.Right - (SaveRect.Left - ARect.Left);
      end;
      with GlyphRect do begin
        Dec(Left);
        Inc(Right, 2);
      end;
      if Selected then begin
        if DrawGlyph then begin
          if BiDi then
            ARect.Right := GlyphRect.Left - 1
          else
            ARect.Left := GlyphRect.Right + 1;
        end;
        if not (Win98Plus and TopLevel) then
          Brush.Color := clHighlight;
      end;
      if TopLevel and Win98Plus and (not Selected)
      {$IFDEF COMPILER_7_UP}
      and (not Win32PlatformIsXP)
      {$ENDIF}
      then
        OffsetRect(ARect, 0, -1);
      if not (Selected and DrawGlyph) then begin
        if BiDi then
          ARect.Right := GlyphRect.Left - 1
        else
          ARect.Left := GlyphRect.Right + 1;
      end;
      Inc(ARect.Left, 2);
      Dec(ARect.Right, 1);
      DrawStyle := DT_EXPANDTABS or DT_SINGLELINE or GetAlignmentDrawStyle;
      if Win2K and (odNoAccel in State) then
        DrawStyle := DrawStyle or DT_HIDEPREFIX;
      { Calculate vertical layout }
      SaveRect := ARect;
      if odDefault in State then
        Font.Style := [fsBold];
      DoDrawText(ACanvas, Caption, ARect, Selected, DrawStyle or DT_CALCRECT or DT_NOCLIP);
      if BiDi then begin
        { the DT_CALCRECT does not take into account alignment }
        ARect.Left := SaveRect.Left;
        ARect.Right := SaveRect.Right;
      end;
      OffsetRect(ARect, 0, ((SaveRect.Bottom - SaveRect.Top) - (ARect.Bottom - ARect.Top)) div 2);
      if TopLevel and Selected and Win98Plus
      {$IFDEF COMPILER_7_UP}
      and (not Win32PlatformIsXP)
      {$ENDIF}
      then
        OffsetRect(ARect, 1, 0);
      DoDrawText(ACanvas, Caption, ARect, Selected, DrawStyle);
      if (ShortCut <> scNone) and not TopLevel then
      begin
        if BiDi then begin
          ARect.Left := 10;
          ARect.Right := ARect.Left + WideCanvasTextWidth(ACanvas, WideShortCutToText(ShortCut));
        end else begin
          ARect.Left := ARect.Right;
          ARect.Right := SaveRect.Right - 10;
        end;
        DoDrawText(ACanvas, WideShortCutToText(ShortCut), ARect, Selected, DT_RIGHT);
      end;
    end;
  end;

var
  ParentMenu: TMenu;
  SaveCaption: WideString;
  SaveShortCut: TShortCut;
begin
  ParentMenu := GetParentMenu;
  if (not Win32PlatformIsUnicode)
  or (Self.IsLine)
  or (     (ParentMenu <> nil) and (ParentMenu.OwnerDraw or (GetImageList <> nil))
       and (Assigned(OnAdvancedDrawItem) or Assigned(OnDrawItem))    ) then
    inherited
  else begin
    SaveCaption := Caption;
    SaveShortCut := ShortCut;
    try
      FIgnoreMenuChanged := True;
      try
        Caption := '';
        ShortCut := scNone;
      finally
        FIgnoreMenuChanged := False;
      end;
      inherited;
    finally
      FIgnoreMenuChanged := True;
      try
        Caption := SaveCaption;
        ShortCut := SaveShortcut;
      finally
        FIgnoreMenuChanged := False;
      end;
    end;
    DrawMenuText((ParentMenu <> nil) and (ParentMenu.IsRightToLeft))
  end;
end;

procedure TTntMenuItem.DoDrawText(ACanvas: TCanvas; const ACaption: WideString;
  var Rect: TRect; Selected: Boolean; Flags: Longint);
var
  Text: WideString;
  ParentMenu: TMenu;
begin
  if (not Win32PlatformIsUnicode)
  or (IsLine) then
    inherited DoDrawText(ACanvas, ACaption, Rect, Selected, Flags)
  else begin
    ParentMenu := GetParentMenu;
    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;
    Text := ACaption;
    if (Flags and DT_CALCRECT <> 0) and ((Text = '') or
      (Text[1] = cHotkeyPrefix) and (Text[2] = #0)) then Text := Text + ' ';
    with ACanvas do
    begin
      Brush.Style := bsClear;
      if Default then
        Font.Style := Font.Style + [fsBold];
      if not Enabled then
      begin
        if not Selected then
        begin
          OffsetRect(Rect, 1, 1);
          Font.Color := clBtnHighlight;
          Tnt_DrawTextW(Handle, PWideChar(Text), Length(Text), Rect, Flags);
          OffsetRect(Rect, -1, -1);
        end;
        if Selected and (ColorToRGB(clHighlight) = ColorToRGB(clBtnShadow)) then
          Font.Color := clBtnHighlight else
          Font.Color := clBtnShadow;
      end;
      Tnt_DrawTextW(Handle, PWideChar(Text), Length(Text), Rect, Flags);
    end;
  end;
end;

function TTntMenuItem.MeasureItemTextWidth(ACanvas: TCanvas; const Text: WideString): Integer;
var
  R: TRect;
begin
  FillChar(R, SizeOf(R), 0);
  DoDrawText(ACanvas, Text, R, False,
    GetAlignmentDrawStyle or DT_EXPANDTABS or DT_SINGLELINE or DT_NOCLIP or DT_CALCRECT);
  Result := R.Right - R.Left;
end;

procedure TTntMenuItem.MeasureItem(ACanvas: TCanvas; var Width, Height: Integer);
var
  SaveMeasureItemEvent: TMenuMeasureItemEvent;
begin
  if (not Win32PlatformIsUnicode)
  or (Self.IsLine) then
    inherited
  else begin
    SaveMeasureItemEvent := inherited OnMeasureItem;
    try
      inherited OnMeasureItem := nil;
      inherited;
      Inc(Width, MeasureItemTextWidth(ACanvas, Caption));
      Dec(Width, MeasureItemTextWidth(ACanvas, inherited Caption));
      if ShortCut <> scNone then begin
        Inc(Width, MeasureItemTextWidth(ACanvas, WideShortCutToText(ShortCut)));
        Dec(Width, MeasureItemTextWidth(ACanvas, ShortCutToText{TNT-ALLOW ShortCutToText}(ShortCut)));
      end;
    finally
      inherited OnMeasureItem := SaveMeasureItemEvent;
    end;
    if Assigned(OnMeasureItem) then OnMeasureItem(Self, ACanvas, Width, Height);
  end;
end;

function TTntMenuItem.Find(ACaption: WideString): TMenuItem{TNT-ALLOW TMenuItem};
var
  I: Integer;
begin
  Result := nil;
  ACaption := WideStripHotkey(ACaption);
  for I := 0 to Count - 1 do
    if WideSameText(ACaption, WideStripHotkey(WideGetMenuItemCaption(Items[I]))) then
    begin
      Result := Items[I];
      System.Break;
    end;
end;

function TTntMenuItem.GetActionLinkClass: TMenuActionLinkClass;
begin
  Result := TTntMenuActionLink;
end;

procedure TTntMenuItem.ActionChange(Sender: TObject; CheckDefaults: Boolean);
begin
  if (Sender is TCustomAction{TNT-ALLOW TCustomAction}) and Supports(Sender, ITntAction) then begin
    if not CheckDefaults or (Caption = '') then
      Caption := TntAction_GetCaption(TCustomAction{TNT-ALLOW TCustomAction}(Sender));
    if not CheckDefaults or (Hint = '') then
      Hint := TntAction_GetHint(TCustomAction{TNT-ALLOW TCustomAction}(Sender));
  end;
  inherited;
end;

{ TTntMainMenu }

{$IFDEF COMPILER_9_UP}
function TTntMainMenu.CreateMenuItem: TMenuItem{TNT-ALLOW TMenuItem};
begin
  Result := TTntMenuItem.Create(Self);
end;
{$ENDIF}

procedure TTntMainMenu.DoChange(Source: TMenuItem{TNT-ALLOW TMenuItem}; Rebuild: Boolean);
begin
  inherited;
  UpdateMenuItems(Items, Self);
  if (THackMenuItem(Items).FMerged <> nil) then begin
    UpdateMenuItems(THackMenuItem(Items).FMerged, Self);
  end;
end;

{ TTntPopupMenu }

constructor TTntPopupMenu.Create(AOwner: TComponent);
begin
  inherited;
  PopupList.Remove(Self);
  TntPopupList.Add(Self);
end;

{$IFDEF COMPILER_9_UP}
function TTntPopupMenu.CreateMenuItem: TMenuItem{TNT-ALLOW TMenuItem};
begin
  Result := TTntMenuItem.Create(Self);
end;
{$ENDIF}

destructor TTntPopupMenu.Destroy;
begin
  TntPopupList.Remove(Self);
  PopupList.Add(Self);
  inherited;
end;

procedure TTntPopupMenu.DoChange(Source: TMenuItem{TNT-ALLOW TMenuItem}; Rebuild: Boolean);
begin
  inherited;
  UpdateMenuItems(Items, Self);
end;

procedure TTntPopupMenu.Popup(X, Y: Integer);
begin
  Menus.PopupList := TntPopupList;
  try
    inherited;
  finally
    Menus.PopupList := TntPopupList.SavedPopupList;
  end;
end;

{ TTntPopupList }

procedure TTntPopupList.WndProc(var Message: TMessage);
var
  I, Item: Integer;
  MenuItem: TMenuItem{TNT-ALLOW TMenuItem};
  FindKind: TFindItemKind;
begin
  case Message.Msg of
    WM_ENTERMENULOOP:
      begin
        Menus.PopupList := SavedPopupList;
        for i := 0 to Count - 1 do
          FixMenuBiDiProblem(Items[i]);
      end;
    WM_MENUSELECT:
      with TWMMenuSelect(Message) do
      begin
        FindKind := fkCommand;
        if MenuFlag and MF_POPUP <> 0 then FindKind := fkHandle;
        for I := 0 to Count - 1 do
        begin
          if FindKind = fkHandle then
          begin
            if Menu <> 0 then
              Item := Integer(GetSubMenu(Menu, IDItem)) else
              Item := -1;
          end
          else
            Item := IDItem;
          MenuItem := TPopupMenu{TNT-ALLOW TPopupMenu}(Items[I]).FindItem(Item, FindKind);
          if MenuItem <> nil then
          begin
            TntApplication.Hint := WideGetLongHint(WideGetMenuItemHint(MenuItem));
            Exit;
          end;
        end;
        TntApplication.Hint := '';
      end;
  end;
  inherited;
end;

initialization
  TntPopupList := TTntPopupList.Create;
  TntPopupList.SavedPopupList := Menus.PopupList;

finalization
  TntPopupList.Free;

end.