← Back to branch summary

~ubuntu-branches/ubuntu/saucy/lazarus/saucy

« back to all changes in this revision

Viewing changes to lcl/interfaces/win32/win32wsmenus.pp

  • Committer: Package Import Robot
  • Author(s): Paul Gevers, Abou Al Montacir, Bart Martens, Paul Gevers
  • Date: 2013-06-08 14:12:17 UTC
  • mfrom: (1.1.9)
  • Revision ID: package-import@ubuntu.com-20130608141217-7k0cy9id8ifcnutc
Tags: 1.0.8+dfsg-1
http://bugs.debian.org/708695
[ Abou Al Montacir ]
* New upstream major release and multiple maintenace release offering many
  fixes and new features marking a new milestone for the Lazarus development
  and its stability level.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_fixes_branch
* LCL changes:
  - LCL is now a normal package.
      + Platform independent parts of the LCL are now in the package LCLBase
      + LCL is automatically recompiled when switching the target platform,
        unless pre-compiled binaries for this target are already installed.
      + No impact on existing projects.
      + Linker options needed by LCL are no more added to projects that do
        not use the LCL package.
  - Minor changes in LCL basic classes behaviour
      + TCustomForm.Create raises an exception if a form resource is not
        found.
      + TNotebook and TPage: a new implementation of these classes was added.
      + TDBNavigator: It is now possible to have focusable buttons by setting
        Options = [navFocusableButtons] and TabStop = True, useful for
        accessibility and for devices with neither mouse nor touch screen.
      + Names of TControlBorderSpacing.GetSideSpace and GetSpace were swapped
        and are now consistent. GetSideSpace = Around + GetSpace.
      + TForm.WindowState=wsFullscreen was added
      + TCanvas.TextFitInfo was added to calculate how many characters will
        fit into a specified Width. Useful for word-wrapping calculations.
      + TControl.GetColorResolvingParent and
        TControl.GetRGBColorResolvingParent were added, simplifying the work
        to obtain the final color of the control while resolving clDefault
        and the ParentColor.
      + LCLIntf.GetTextExtentExPoint now has a good default implementation
        which works in any platform not providing a specific implementation.
        However, Widgetset specific implementation is better, when available.
      + TTabControl was reorganized. Now it has the correct class hierarchy
        and inherits from TCustomTabControl as it should.
  - New unit in the LCL:
      + lazdialogs.pas: adds non-native versions of various native dialogs,
        for example TLazOpenDialog, TLazSaveDialog, TLazSelectDirectoryDialog.
        It is used by widgetsets which either do not have a native dialog, or
        do not wish to use it because it is limited. These dialogs can also be
        used by user applications directly.
      + lazdeviceapis.pas: offers an interface to more hardware devices such
        as the accelerometer, GPS, etc. See LazDeviceAPIs
      + lazcanvas.pas: provides a TFPImageCanvas descendent implementing
        drawing in a LCL-compatible way, but 100% in Pascal.
      + lazregions.pas. LazRegions is a wholly Pascal implementation of
        regions for canvas clipping, event clipping, finding in which control
        of a region tree one an event should reach, for drawing polygons, etc.
      + customdrawncontrols.pas, customdrawndrawers.pas,
        customdrawn_common.pas, customdrawn_android.pas and
        customdrawn_winxp.pas: are the Lazarus Custom Drawn Controls -controls
        which imitate the standard LCL ones, but with the difference that they
        are non-native and support skinning.
  - New APIs added to the LCL to improve support of accessibility software
    such as screen readers.
* IDE changes:
  - Many improvments.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/New_IDE_features_since#v1.0_.282012-08-29.29
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes#IDE_Changes
* Debugger / Editor changes:
  - Added pascal sources and breakpoints to the disassembler
  - Added threads dialog.
* Components changes:
  - TAChart: many fixes and new features
  - CodeTool: support Delphi style generics and new syntax extensions.
  - AggPas: removed to honor free licencing. (Closes: Bug#708695)
[Bart Martens]
* New debian/watch file fixing issues with upstream RC release.
[Abou Al Montacir]
* Avoid changing files in .pc hidden directory, these are used by quilt for
  internal purpose and could lead to surprises during build.
[Paul Gevers]
* Updated get-orig-source target and it compinion script orig-tar.sh so that they
  repack the source file, allowing bug 708695 to be fixed.

Show diffs side-by-side

added added

removed removed

Lines of Context:
lcl/interfaces/win32/win32wsmenus.pp
1
 
{ $Id: win32wsmenus.pp 31043 2011-06-04 11:57:04Z juha $}
 
1
{ $Id: win32wsmenus.pp 35911 2012-03-13 00:58:52Z paul $}
2
2
{
3
3
 *****************************************************************************
4
4
 *                              Win32WSMenus.pp                              *
38
38
////////////////////////////////////////////////////
39
39
  WSMenus, WSLCLClasses, WSProc,
40
40
  Windows, Controls, Classes, SysUtils, Win32Int, Win32Proc, Win32WSImgList,
41
 
  InterfaceBase, LCLProc, Themes, Win32UxTheme, TmSchema, Win32Themes, Win32Extra,
 
41
  InterfaceBase, LCLProc, Themes, UxTheme, Win32Themes, Win32Extra,
42
42
  FileUtil;
43
43
 
44
44
type
52
52
    class procedure DestroyHandle(const AMenuItem: TMenuItem); override;
53
53
    class procedure SetCaption(const AMenuItem: TMenuItem; const ACaption: string); override;
54
54
    class function SetCheck(const AMenuItem: TMenuItem; const Checked: boolean): boolean; override;
55
 
    class procedure SetShortCut(const AMenuItem: TMenuItem; const OldShortCut, NewShortCut: TShortCut); override;
 
55
    class procedure SetShortCut(const AMenuItem: TMenuItem; const ShortCutK1, ShortCutK2: TShortCut); override;
56
56
    class function SetEnable(const AMenuItem: TMenuItem; const Enabled: boolean): boolean; override;
57
57
    class function SetRightJustify(const AMenuItem: TMenuItem; const Justified: boolean): boolean; override;
58
58
    class procedure UpdateMenuIcon(const AMenuItem: TMenuItem; const HasIcon: Boolean; const AIcon: Graphics.TBitmap); override;
82
82
 
83
83
  function MenuItemSize(AMenuItem: TMenuItem; AHDC: HDC): TSize;
84
84
  procedure DrawMenuItem(const AMenuItem: TMenuItem; const AHDC: HDC; const ARect: Windows.RECT; const ItemAction, ItemState: UINT);
85
 
  function FindMenuItemAccelerator(const ACharCode: char; const AMenuHandle: HMENU): integer;
 
85
  function FindMenuItemAccelerator(const ACharCode: word; const AMenuHandle: HMENU): integer;
86
86
  procedure DrawMenuItemIcon(const AMenuItem: TMenuItem; const AHDC: HDC;
87
87
    const ImageRect: TRect; const ASelected: Boolean);
88
88
 
93
93
{ helper routines }
94
94
 
95
95
const
96
 
  SpaceBetweenIcons = 5;
 
96
  SpaceNextToCheckMark = 2; // Used by Windows for check bitmap
 
97
  SpaceNextToIcon      = 5; // Our custom spacing for bitmaps bigger than check mark
97
98
 
98
99
  // define the size of the MENUITEMINFO structure used by older Windows
99
100
  // versions (95, NT4) to keep the compatibility with them
162
163
  Result := IntToStr(GetLastError) + ' : ' + UTF8ToConsole(AnsiToUtf8(GetLastErrorText(GetLastError)));
163
164
end;
164
165
 
165
 
(* Returns index of the character in the menu item caption that is displayed
166
 
   as underlined and is therefore the hot key of the menu item.
167
 
   If the caption does not contain any underlined character, 0 is returned.
168
 
   If there are more "underscored" characters in the caption, the last one is returned.
169
 
   Does some Windows API function exists which can do the same?
170
 
   AnUnderlinedChar - character which tells that tne following character should be underlined
171
 
   ACaption - menu item caption which is parsed *)
172
 
function SearchMenuItemHotKeyIndex(const AnUnderlinedChar: char; ACaption: string): integer;
173
 
var
174
 
  position: integer;
175
 
begin
176
 
  position := pos(AnUnderlinedChar, ACaption);
177
 
  Result := 0;
178
 
  // if aChar is on the last position then there is nothing to underscore, ignore this character
179
 
  while (position > 0) and (position < length(ACaption)) do
180
 
  begin
181
 
    // two 'AnUnderlinedChar' characters together are not valid hot key, they are replaced by one
182
 
    if ACaption[position + 1] <> AnUnderlinedChar then
183
 
      Result := position + 1;
184
 
    position := posEx(AnUnderlinedChar, ACaption, position + 2);
185
 
  end;
186
 
end;
187
 
 
188
 
function FindMenuItemAccelerator(const ACharCode: char; const AMenuHandle: HMENU): integer;
 
166
function FindMenuItemAccelerator(const ACharCode: word; const AMenuHandle: HMENU): integer;
189
167
var
190
168
  MenuItemIndex: integer;
191
169
  ItemInfo: MENUITEMINFO;
192
170
  FirstMenuItem: TMenuItem;
193
171
  SiblingMenuItem: TMenuItem;
194
 
  HotKeyIndex: integer;
195
172
  i: integer;
196
173
begin
197
174
  Result := MakeLResult(0, MNC_IGNORE);
205
182
  while (i < FirstMenuItem.Parent.Count) and (MenuItemIndex < 0) do
206
183
  begin
207
184
    SiblingMenuItem := FirstMenuItem.Parent.Items[i];
208
 
    HotKeyIndex := SearchMenuItemHotKeyIndex('&', SiblingMenuItem.Caption);
209
 
    if (HotKeyIndex > 0) and (Upcase(ACharCode) = Upcase(SiblingMenuItem.Caption[HotKeyIndex])) then
 
185
    if IsAccel(ACharCode, SiblingMenuItem.Caption) then
210
186
      MenuItemIndex := SiblingMenuItem.MenuVisibleIndex;
211
187
    inc(i);
212
188
  end;
215
191
end;
216
192
 
217
193
function GetMenuItemFont(const AFlags: TCaptionFlagsSet): HFONT;
218
 
var 
 
194
var
219
195
  lf: LOGFONT;
220
196
  ncm: NONCLIENTMETRICS;
221
197
begin
238
214
  Result := CreateFontIndirect(@lf);
239
215
end;
240
216
 
 
217
(* Get the menu item shortcut text *)
 
218
function MenuItemShortCut(const AMenuItem: TMenuItem): string;
 
219
begin
 
220
  Result := ShortCutToText(AMenuItem.ShortCut);
 
221
  if AMenuItem.ShortCutKey2 <> scNone then
 
222
    Result := Result + ', ' + ShortCutToText(AMenuItem.ShortCutKey2);
 
223
end;
 
224
 
241
225
(* Get the menu item caption including shortcut *)
242
226
function CompleteMenuItemCaption(const AMenuItem: TMenuItem; Spacing: String): string;
243
227
begin
244
228
  Result := AMenuItem.Caption;
245
229
  if AMenuItem.ShortCut <> scNone then
246
 
    Result := Result + Spacing + ShortCutToText(AMenuItem.ShortCut);
 
230
    Result := Result + Spacing + MenuItemShortCut(AMenuItem);
247
231
end;
248
232
 
249
233
(* Get the maximum length of the given string in pixels *)
250
 
function StringSize(const aCaption: String; const aHDC: HDC; const aDecoration:TCaptionFlagsSet): TSize;
 
234
function StringSize(const aCaption: String; const aHDC: HDC): TSize;
251
235
var
252
 
  oldFont: HFONT;
253
 
  newFont: HFONT;
254
236
  tmpRect: Windows.RECT;
255
237
{$ifdef WindowsUnicodeSupport}
256
238
  AnsiBuffer: ansistring;
258
240
{$endif WindowsUnicodeSupport}
259
241
begin
260
242
  FillChar(tmpRect, SizeOf(tmpRect), 0);
261
 
  newFont := GetMenuItemFont(aDecoration);
262
 
  oldFont := SelectObject(aHDC, newFont);
263
243
{$ifdef WindowsUnicodeSupport}
264
244
  if UnicodeEnabledOS then
265
245
  begin
274
254
{$else}
275
255
  DrawText(aHDC, pChar(aCaption), length(aCaption), @TmpRect, DT_CALCRECT);
276
256
{$endif}
277
 
  SelectObject(aHDC, oldFont);
278
 
  DeleteObject(newFont);
279
257
  Result.cx := TmpRect.right - TmpRect.left;
280
258
  Result.cy := TmpRect.Bottom - TmpRect.Top;
281
259
end;
282
 
  
283
 
function CheckSpace(AMenuItem: TMenuItem): integer;
 
260
 
 
261
function GetAverageCharSize(AHDC: HDC): TSize;
 
262
const
 
263
  alph: AnsiString = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz';
284
264
var
285
 
  i: integer;
 
265
  sz: SIZE;
 
266
  tm: TEXTMETRIC;
286
267
begin
287
 
  Result := 0;
288
 
  if AMenuItem.IsInMenuBar then
289
 
  begin
290
 
    if AMenuItem.Checked then
291
 
      Result := GetSystemMetrics(SM_CXMENUCHECK);
292
 
  end
293
 
  else
294
 
  begin
295
 
    for i := 0 to AMenuItem.Parent.Count - 1 do
296
 
    begin
297
 
      if AMenuItem.Parent.Items[i].Checked then
298
 
      begin
299
 
        Result := GetSystemMetrics(SM_CXMENUCHECK);
300
 
        break;
301
 
      end;
302
 
    end;
303
 
  end;
 
268
  if GetTextMetrics(AHDC, @tm) = False then
 
269
    Result.cy := 0
 
270
  else
 
271
    Result.cy := WORD(tm.tmHeight);
 
272
 
 
273
  if GetTextExtentPoint(AHDC, @alph[1], 52, @sz) = False then
 
274
    Result.cx := 0
 
275
  else
 
276
    Result.cx := (sz.cx div 26 + 1) div 2;
304
277
end;
305
278
 
306
279
function MenuIconWidth(const AMenuItem: TMenuItem): integer;
329
302
  end;
330
303
end;
331
304
 
332
 
function LeftCaptionPosition(const AMenuItem: TMenuItem): integer;
 
305
procedure GetNonTextSpace(const AMenuItem: TMenuItem;
 
306
                          AvgCharWidth: Integer;
 
307
                          out LeftSpace, RightSpace: Integer);
333
308
var
334
 
  ImageWidth: Integer;
 
309
  Space: Integer = SpaceNextToCheckMark;
 
310
  CheckMarkWidth: Integer;
335
311
begin
336
 
  // If we have Check and Icon then we use only width of Icon
337
 
  // we draw our MenuItem so: space Image space Caption
338
 
  ImageWidth := MenuIconWidth(AMenuItem);
339
 
  if ImageWidth = 0 then
340
 
    ImageWidth := CheckSpace(aMenuItem);
341
 
 
342
 
  Result := SpaceBetweenIcons;
343
 
 
344
 
  inc(Result, ImageWidth);
345
 
 
346
 
  if not aMenuItem.IsInMenuBar or (ImageWidth <> 0) then
347
 
    inc(Result, SpaceBetweenIcons);
 
312
  // If we have Check and Icon then we use only width of Icon.
 
313
  // We draw our MenuItem so: space Image space Caption.
 
314
  // Items not in menu bar always have enough space for a check mark.
 
315
 
 
316
  CheckMarkWidth := GetSystemMetrics(SM_CXMENUCHECK);
 
317
  LeftSpace := MenuIconWidth(AMenuItem);
 
318
 
 
319
  if LeftSpace > 0 then
 
320
  begin
 
321
    if not AMenuItem.IsInMenuBar then
 
322
    begin
 
323
      if LeftSpace < CheckMarkWidth then
 
324
        LeftSpace := CheckMarkWidth
 
325
      else
 
326
      if LeftSpace > CheckMarkWidth then
 
327
        Space := SpaceNextToIcon;
 
328
    end;
 
329
  end
 
330
  else
 
331
  begin
 
332
    if not AMenuItem.IsInMenuBar or AMenuItem.Checked then
 
333
      LeftSpace := CheckMarkWidth;
 
334
  end;
 
335
 
 
336
  if LeftSpace > 0 then
 
337
  begin
 
338
    // Space to the left of the icon or check.
 
339
    if not AMenuItem.IsInMenuBar then
 
340
      Inc(LeftSpace, Space);
 
341
    // Space between icon or check and caption.
 
342
    if AMenuItem.Caption <> '' then
 
343
      Inc(LeftSpace, Space);
 
344
  end;
 
345
 
 
346
  if AMenuItem.IsInMenuBar then
 
347
    RightSpace := 0
 
348
  else
 
349
    RightSpace := CheckMarkWidth + AvgCharWidth;
 
350
 
 
351
  if AMenuItem.Caption <> '' then
 
352
  begin
 
353
    if AMenuItem.IsInMenuBar then
 
354
    begin
 
355
      Inc(LeftSpace, AvgCharWidth);
 
356
      Inc(RightSpace, AvgCharWidth);
 
357
    end
 
358
    else
 
359
    begin
 
360
      // Space on the right side of the text.
 
361
      Inc(RightSpace, SpaceNextToCheckMark);
 
362
    end;
 
363
  end;
348
364
end;
349
365
 
350
366
function TopPosition(const aMenuItemHeight: integer; const anElementHeight: integer): integer;
400
416
 
401
417
    if AMenuItem.ShortCut <> scNone then
402
418
    begin;
403
 
      W := UTF8ToUTF16(ShortCutToText(AMenuItem.ShortCut));
 
419
      W := UTF8ToUTF16(MenuItemShortCut(AMenuItem));
404
420
      GetThemeTextExtent(Theme, DC, MENU_POPUPITEM, 0, PWideChar(W), Length(W),
405
421
        DT_SINGLELINE or DT_LEFT, nil, TextRect);
406
422
      Result.ShortCustSize.cx := TextRect.Right - TextRect.Left;
761
777
        TextRect.Left := TextRect.Right - Metrics.ShortCustSize.cx;
762
778
        TextFlags := TextFlags xor DT_LEFT or DT_RIGHT;
763
779
      end;
764
 
 
765
 
      ThemeDrawText(AHDC, Details, ShortCutToText(AMenuItem.ShortCut), TextRect, TextFlags, 0);
 
780
      ThemeDrawText(AHDC, Details, MenuItemShortCut(AMenuItem), TextRect, TextFlags, 0);
766
781
    end;
767
782
    // exlude menu item rectangle to prevent drawing by windows after us
768
783
    if AMenuItem.Count > 0 then
774
789
 
775
790
function MenuItemSize(AMenuItem: TMenuItem; AHDC: HDC): TSize;
776
791
var
777
 
  decoration: TCaptionFlagsSet;
778
 
  minimumHeight: Integer;
 
792
  LeftSpace, RightSpace: Integer;
 
793
  oldFont: HFONT;
 
794
  newFont: HFONT;
 
795
  AvgCharSize: TSize;
779
796
begin
780
797
  if IsVistaMenu then
781
798
  begin
787
804
  end;
788
805
 
789
806
  if AMenuItem.Default then
790
 
    decoration := [cfBold]
791
 
  else
792
 
    decoration := [];
793
 
    
794
 
  Result := StringSize(CompleteMenuItemCaption(AMenuItem, '  '), AHDC, decoration);
795
 
  inc(Result.cx, LeftCaptionPosition(AMenuItem));
796
 
 
797
 
  if not AMenuItem.IsInMenuBar then
798
 
    inc(Result.cx, SpaceBetweenIcons)
799
 
  else
800
 
    dec(Result.cx, SpaceBetweenIcons);
801
 
 
802
 
  if (AMenuItem.ShortCut <> scNone) then
803
 
    Inc(Result.cx, SpaceBetweenIcons);
804
 
 
805
 
  minimumHeight := GetSystemMetrics(SM_CYMENU);
806
 
  if not AMenuItem.IsInMenuBar then
807
 
    Dec(minimumHeight, 2);
 
807
    newFont := GetMenuItemFont([cfBold])
 
808
  else
 
809
    newFont := GetMenuItemFont([]);
 
810
  oldFont := SelectObject(aHDC, newFont);
 
811
  AvgCharSize := GetAverageCharSize(AHDC);
 
812
 
 
813
  Result := StringSize(CompleteMenuItemCaption(AMenuItem, EmptyStr), AHDC);
 
814
 
 
815
  // Space between text and shortcut.
 
816
  if AMenuItem.ShortCut <> scNone then
 
817
    inc(Result.cx, AvgCharSize.cx);
 
818
 
 
819
  GetNonTextSpace(AMenuItem, AvgCharSize.cx, LeftSpace, RightSpace);
 
820
  inc(Result.cx, LeftSpace + RightSpace);
 
821
 
 
822
  // Windows adds additional space to value returned from WM_MEASUREITEM
 
823
  // for owner drawn menus. This is to negate that.
 
824
  Dec(Result.cx, AvgCharSize.cx * 2);
 
825
 
 
826
  // As for height of items in menu bar, regardless of what is set here,
 
827
  // Windows seems to always use SM_CYMENUSIZE (space for a border is included).
 
828
 
808
829
  if AMenuItem.IsLine then
809
 
    Result.cy := 10 // it is a separator
 
830
    Result.cy := GetSystemMetrics(SM_CYMENUSIZE) div 2 // it is a separator
810
831
  else
811
832
  begin
812
 
    if AMenuItem.hasIcon then
813
 
      Result.cy := Max(Result.cy, aMenuItem.GetIconSize.y);
814
 
    Inc(Result.cy, 2);
815
 
    if Result.cy < minimumHeight then
816
 
      Result.cy := minimumHeight;
 
833
    if AMenuItem.IsInMenuBar then
 
834
    begin
 
835
      Result.cy := Max(Result.cy, GetSystemMetrics(SM_CYMENUSIZE));
 
836
      if AMenuItem.hasIcon then
 
837
        Result.cy := Max(Result.cy, aMenuItem.GetIconSize.y);
 
838
    end
 
839
    else
 
840
    begin
 
841
      Result.cy := Max(Result.cy + 2, AvgCharSize.cy + 4);
 
842
      if AMenuItem.hasIcon then
 
843
        Result.cy := Max(Result.cy, aMenuItem.GetIconSize.y + 2);
 
844
    end;
817
845
  end;
 
846
 
 
847
  SelectObject(aHDC, oldFont);
 
848
  DeleteObject(newFont);
818
849
end;
819
850
 
820
851
function IsFlatMenus: Boolean; inline;
875
906
procedure DrawSeparator(const AHDC: HDC; const ARect: Windows.RECT);
876
907
var
877
908
  separatorRect: Windows.RECT;
 
909
  space: Integer;
878
910
begin
879
 
  separatorRect.left := ARect.left;
880
 
  separatorRect.right := ARect.right;
881
 
  separatorRect.top := (ARect.top + ARect.bottom ) div 2 - 1;
882
 
  separatorRect.bottom := separatorRect.top + 2;
883
 
  DrawEdge(aHDC, separatorRect, BDR_SUNKENOUTER, BF_RECT);
 
911
  if IsFlatMenus then
 
912
    space := 3
 
913
  else
 
914
    space := 1;
 
915
 
 
916
  separatorRect.Left  := ARect.Left  + space;
 
917
  separatorRect.Right := ARect.Right - space;
 
918
  separatorRect.Top   := ARect.Top + GetSystemMetrics(SM_CYMENUSIZE) div 4 - 1;
 
919
  DrawEdge(AHDC, separatorRect, EDGE_ETCHED, BF_TOP);
884
920
end;
885
921
 
886
 
procedure DrawMenuItemCheckMark(const aMenuItem: TMenuItem; const aHDC: HDC; const aRect: Windows.RECT; const aSelected: boolean);
 
922
procedure DrawMenuItemCheckMark(const aMenuItem: TMenuItem; const aHDC: HDC;
 
923
  const aRect: Windows.RECT; const aSelected: boolean; AvgCharWidth: Integer);
887
924
var
888
925
  checkMarkWidth: integer;
889
926
  checkMarkHeight: integer;
893
930
  checkMarkShape: integer;
894
931
  checkMarkRect: Windows.RECT;
895
932
  x:Integer;
 
933
  space: Integer;
896
934
begin
897
935
  hdcMem := CreateCompatibleDC(aHDC);
898
936
  checkMarkWidth := GetSystemMetrics(SM_CXMENUCHECK);
908
946
  else
909
947
    checkMarkShape := DFCS_MENUCHECK;
910
948
  DrawFrameControl(hdcMem, @checkMarkRect, DFC_MENU, checkMarkShape);
 
949
  if aMenuItem.IsInMenuBar then
 
950
    space := AvgCharWidth
 
951
  else
 
952
    space := SpaceNextToCheckMark;
911
953
  if aMenuItem.GetIsRightToLeft then
912
 
    x := aRect.Right - checkMarkWidth - spaceBetweenIcons
 
954
    x := aRect.Right - checkMarkWidth - space
913
955
  else
914
 
    x := aRect.left + spaceBetweenIcons;
 
956
    x := aRect.left + space;
915
957
  BitBlt(aHDC, x, aRect.top + topPosition(aRect.bottom - aRect.top, checkMarkRect.bottom - checkMarkRect.top), checkMarkWidth, checkMarkHeight, hdcMem, 0, 0, SRCCOPY);
916
958
  SelectObject(hdcMem, oldBitmap);
917
959
  DeleteObject(monoBitmap);
919
961
end;
920
962
 
921
963
procedure DrawMenuItemText(const AMenuItem: TMenuItem; const AHDC: HDC;
922
 
  ARect: TRect; const ASelected, ANoAccel: boolean; ItemState: UINT);
 
964
  ARect: TRect; const ASelected, ANoAccel: boolean; ItemState: UINT;
 
965
  AvgCharWidth: Integer);
923
966
var
924
967
  crText: COLORREF;
925
968
  crBkgnd: COLORREF;
926
 
  TmpHeight: integer;
927
 
  oldFont: HFONT;
928
 
  newFont: HFONT;
929
 
  decoration: TCaptionFlagsSet;
 
969
  oldBkMode: Longint;
930
970
  shortCutText: string;
931
 
  WorkRect: Windows.RECT;
932
971
  IsRightToLeft: Boolean;
933
972
  etoFlags: Cardinal;
934
973
  dtFlags: DWord;
936
975
  AnsiBuffer: ansistring;
937
976
  WideBuffer: widestring;
938
977
{$endif WindowsUnicodeSupport}
 
978
  LeftSpace, RightSpace: Integer;
939
979
begin
940
980
  crText := TextColorMenu(ItemState, AMenuItem.IsInMenuBar, AMenuItem.Enabled);
941
981
  crBkgnd := BackgroundColorMenu(ItemState, AMenuItem.IsInMenuBar);
942
982
  SetTextColor(AHDC, crText);
943
983
  SetBkColor(AHDC, crBkgnd);
944
984
 
945
 
  if AMenuItem.Default then
946
 
    decoration := [cfBold]
947
 
  else
948
 
    decoration := [];
949
 
    
950
 
  newFont := GetMenuItemFont(decoration);
951
 
  oldFont := SelectObject(AHDC, newFont);
952
985
  IsRightToLeft := AMenuItem.GetIsRightToLeft;
953
 
 
954
986
  etoFlags := ETO_OPAQUE;
955
 
  dtFlags := DT_EXPANDTABS;
 
987
  // DT_LEFT is default because its value is 0
 
988
  dtFlags := DT_EXPANDTABS or DT_VCENTER or DT_SINGLELINE;
956
989
  if ANoAccel then
957
990
    dtFlags := dtFlags or DT_HIDEPREFIX;
958
991
  if IsRightToLeft then
967
1000
  if AMenuItem.IsInMenuBar and not IsFlatMenus then
968
1001
  begin
969
1002
    if (ItemState and ODS_SELECTED) <> 0 then
970
 
      DrawEdge(AHDC, ARect, BDR_SUNKENOUTER, BF_RECT or BF_ADJUST)
 
1003
    begin
 
1004
      DrawEdge(AHDC, ARect, BDR_SUNKENOUTER, BF_RECT);
 
1005
 
 
1006
      // Adjust caption position when menu is open.
 
1007
      OffsetRect(ARect, 1, 1);
 
1008
    end
971
1009
    else
972
1010
    if (ItemState and ODS_HOTLIGHT) <> 0 then
973
1011
      DrawEdge(AHDC, ARect, BDR_RAISEDINNER, BF_RECT);
974
1012
  end;
975
1013
 
976
 
  TmpHeight := ARect.Bottom - ARect.Top;
 
1014
  GetNonTextSpace(AMenuItem, AvgCharWidth, LeftSpace, RightSpace);
 
1015
 
 
1016
  if IsRightToLeft then
 
1017
  begin
 
1018
    Dec(ARect.Right, LeftSpace);
 
1019
    Inc(ARect.Left, RightSpace);
 
1020
  end
 
1021
  else
 
1022
  begin
 
1023
    Inc(ARect.Left, LeftSpace);
 
1024
    Dec(ARect.Right, RightSpace);
 
1025
  end;
 
1026
 
 
1027
  // Move text up by 1 pixel otherwise it is too low.
 
1028
  Dec(ARect.Top, 1);
 
1029
  Dec(ARect.Bottom, 1);
 
1030
 
 
1031
  oldBkMode := SetBkMode(AHDC, TRANSPARENT);
977
1032
 
978
1033
{$ifdef WindowsUnicodeSupport}
979
1034
  if UnicodeEnabledOS then
980
1035
  begin
981
1036
    WideBuffer := UTF8ToUTF16(AMenuItem.Caption);
982
 
    DrawTextW(AHDC, PWideChar(WideBuffer), length(WideBuffer), @WorkRect, DT_CALCRECT);
 
1037
    DrawTextW(AHDC, PWideChar(WideBuffer), Length(WideBuffer), @ARect, dtFlags);
983
1038
  end
984
1039
  else
985
1040
  begin
986
1041
    AnsiBuffer := Utf8ToAnsi(AMenuItem.Caption);
987
 
    DrawText(AHDC, PChar(AnsiBuffer), length(AnsiBuffer), @WorkRect, DT_CALCRECT);
988
 
  end;
989
 
{$else}
990
 
  DrawText(AHDC, PChar(AMenuItem.Caption), length(AMenuItem.Caption), @WorkRect, DT_CALCRECT);
991
 
{$endif}
992
 
 
993
 
  if IsRightToLeft then
994
 
    Dec(ARect.Right, LeftCaptionPosition(AMenuItem))
995
 
  else
996
 
    Inc(ARect.Left, LeftCaptionPosition(AMenuItem));
997
 
  Inc(ARect.Top, TopPosition(TmpHeight, WorkRect.Bottom - WorkRect.Top));
998
 
 
999
 
{$ifdef WindowsUnicodeSupport}
1000
 
  if UnicodeEnabledOS then
1001
 
    DrawTextW(AHDC, PWideChar(WideBuffer), Length(WideBuffer), @ARect, dtFlags)
1002
 
  else
1003
1042
    DrawText(AHDC, PChar(AnsiBuffer), Length(AnsiBuffer), @ARect, dtFlags);
 
1043
  end;
1004
1044
{$else}
1005
1045
  DrawText(AHDC, PChar(AMenuItem.Caption), Length(AMenuItem.Caption), @ARect, dtFlags);
1006
1046
{$endif}
1007
1047
 
1008
1048
  if AMenuItem.ShortCut <> scNone then
1009
1049
  begin
1010
 
    shortCutText := ShortCutToText(AMenuItem.ShortCut);
 
1050
    dtFlags := DT_VCENTER or DT_SINGLELINE;
 
1051
    shortCutText := MenuItemShortCut(AMenuItem);
1011
1052
    if IsRightToLeft then
1012
 
    begin
1013
 
      Inc(ARect.Left, GetSystemMetrics(SM_CXMENUCHECK));
1014
 
      dtFlags := DT_LEFT;
1015
 
    end
 
1053
      dtFlags := dtFlags or DT_LEFT
1016
1054
    else
1017
 
    begin
1018
 
      Dec(ARect.Right, GetSystemMetrics(SM_CXMENUCHECK));
1019
 
      dtFlags := DT_RIGHT;
1020
 
    end;
 
1055
      dtFlags := dtFlags or DT_RIGHT;
1021
1056
 
1022
1057
    {$ifdef WindowsUnicodeSupport}
1023
1058
      if UnicodeEnabledOS then
1034
1069
      DrawText(AHDC, PChar(shortCutText), Length(shortCutText), @ARect, dtFlags);
1035
1070
    {$endif}
1036
1071
  end;
1037
 
  SelectObject(AHDC, oldFont);
1038
 
  DeleteObject(newFont);
 
1072
 
 
1073
  SetBkMode(AHDC, oldBkMode);
1039
1074
end;
1040
1075
 
1041
1076
procedure DrawMenuItemIcon(const AMenuItem: TMenuItem; const AHDC: HDC;
1081
1116
  const ARect: TRect; const ASelected, AChecked: boolean);
1082
1117
var
1083
1118
  x: Integer;
 
1119
  Space: Integer = SpaceNextToCheckMark;
1084
1120
  ImageRect: TRect;
1085
1121
  IconSize: TPoint;
 
1122
  checkMarkWidth: integer;
1086
1123
begin
1087
1124
  IconSize := AMenuItem.GetIconSize;
 
1125
  checkMarkWidth := GetSystemMetrics(SM_CXMENUCHECK);
 
1126
  if not AMenuItem.IsInMenuBar then
 
1127
  begin
 
1128
    if IconSize.x < checkMarkWidth then
 
1129
    begin
 
1130
      // Center the icon horizontally inside check mark space.
 
1131
      Inc(Space, TopPosition(checkMarkWidth, IconSize.x));
 
1132
    end
 
1133
    else
 
1134
    if IconSize.x > checkMarkWidth then
 
1135
    begin
 
1136
      Space := SpaceNextToIcon;
 
1137
    end;
 
1138
  end;
 
1139
 
1088
1140
  if AMenuItem.GetIsRightToLeft then
1089
 
    x := ARect.Right - IconSize.x - spaceBetweenIcons
 
1141
    x := ARect.Right - IconSize.x - Space
1090
1142
  else
1091
 
    x := ARect.Left + spaceBetweenIcons;
 
1143
    x := ARect.Left + Space;
1092
1144
 
1093
1145
  ImageRect := Rect(x, ARect.top + TopPosition(ARect.Bottom - ARect.Top, IconSize.y),
1094
1146
                    IconSize.x, IconSize.y);
1103
1155
  DrawMenuItemIcon(AMenuItem, AHDC, ImageRect, ASelected);
1104
1156
end;
1105
1157
 
 
1158
procedure DrawClassicMenuItem(const AMenuItem: TMenuItem; const AHDC: HDC;
 
1159
  const ARect: Windows.RECT; const ASelected, ANoAccel: boolean; ItemState: UINT);
 
1160
var
 
1161
  oldFont: HFONT;
 
1162
  newFont: HFONT;
 
1163
  AvgCharWidth: Integer;
 
1164
begin
 
1165
  if AMenuItem.IsLine then
 
1166
    DrawSeparator(AHDC, ARect)
 
1167
  else
 
1168
  begin
 
1169
    if AMenuItem.Default then
 
1170
      newFont := GetMenuItemFont([cfBold])
 
1171
    else
 
1172
      newFont := GetMenuItemFont([]);
 
1173
    oldFont := SelectObject(AHDC, newFont);
 
1174
    AvgCharWidth := GetAverageCharSize(AHDC).cx;
 
1175
 
 
1176
    DrawMenuItemText(AMenuItem, AHDC, ARect, ASelected, ANoAccel, ItemState, AvgCharWidth);
 
1177
    if aMenuItem.HasIcon then
 
1178
      DrawClassicMenuItemIcon(AMenuItem, AHDC, ARect, ASelected, AMenuItem.Checked)
 
1179
    else
 
1180
    if AMenuItem.Checked then
 
1181
      DrawMenuItemCheckMark(AMenuItem, AHDC, ARect, ASelected, AvgCharWidth);
 
1182
 
 
1183
    SelectObject(AHDC, oldFont);
 
1184
    DeleteObject(newFont);
 
1185
  end;
 
1186
end;
 
1187
 
1106
1188
procedure DrawMenuItem(const AMenuItem: TMenuItem; const AHDC: HDC; const ARect: Windows.RECT; const ItemAction, ItemState: UINT);
1107
1189
var
1108
1190
  ASelected, ANoAccel: Boolean;
1122
1204
      DrawVistaMenuBar(AMenuItem, AHDC, ARect, ASelected, ANoAccel, ItemAction, ItemState)
1123
1205
    else
1124
1206
      DrawVistaPopupMenu(AMenuItem, AHDC, ARect, ASelected, ANoAccel);
1125
 
    Exit;
1126
 
  end;
1127
 
 
1128
 
  if aMenuItem.IsLine then
1129
 
    DrawSeparator(AHDC, ARect)
 
1207
  end
1130
1208
  else
1131
 
  begin
1132
 
    DrawMenuItemText(AMenuItem, AHDC, ARect, ASelected, ANoAccel, ItemState);
1133
 
    if aMenuItem.HasIcon then
1134
 
      DrawClassicMenuItemIcon(AMenuItem, AHDC, ARect, ASelected, AMenuItem.Checked)
1135
 
    else
1136
 
    if AMenuItem.Checked then
1137
 
      DrawMenuItemCheckMark(AMenuItem, AHDC, ARect, ASelected);
1138
 
  end;
 
1209
    DrawClassicMenuItem(AMenuItem, AHDC, ARect, ASelected, ANoAccel, ItemState);
1139
1210
end;
1140
1211
 
1141
1212
procedure TriggerFormUpdate(const AMenuItem: TMenuItem);
1368
1439
  UpdateCaption(AMenuItem, aCaption);
1369
1440
end;
1370
1441
 
1371
 
class function TWin32WSMenuItem.SetCheck(const AMenuItem: TMenuItem;
1372
 
  const Checked: boolean): boolean;
 
1442
class function TWin32WSMenuItem.SetCheck(const AMenuItem: TMenuItem; const Checked: boolean): boolean;
1373
1443
begin
1374
1444
  UpdateCaption(AMenuItem, aMenuItem.Caption);
1375
1445
  Result := Checked;
1376
1446
end;
1377
1447
 
1378
 
class procedure TWin32WSMenuItem.SetShortCut(const AMenuItem: TMenuItem;
1379
 
  const OldShortCut, NewShortCut: TShortCut);
 
1448
class procedure TWin32WSMenuItem.SetShortCut(const AMenuItem: TMenuItem; const ShortCutK1, ShortCutK2: TShortCut);
1380
1449
begin
1381
1450
  UpdateCaption(AMenuItem, aMenuItem.Caption);
1382
1451
end;
1449
1518
  );
1450
1519
begin
1451
1520
  MenuHandle := APopupMenu.Handle;
1452
 
  AppHandle := TWin32WidgetSet(WidgetSet).AppHandle;
 
1521
  AppHandle := Win32WidgetSet.AppHandle;
1453
1522
  GetWin32WindowInfo(AppHandle)^.PopupMenu := APopupMenu;
1454
1523
  TrackPopupMenuEx(MenuHandle,
1455
1524
    lAlignment[APopupMenu.Alignment, APopupMenu.IsRightToLeft] or lTrackButtons[APopupMenu.TrackButton],