← Back to branch summary

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

« back to all changes in this revision

Viewing changes to lcl/interfaces/win32/win32proc.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/win32proc.pp
52
52
    PWinControl: TWinControl; // control to paint for
53
53
    AWinControl: TWinControl; // control associated with (for buddy controls)
54
54
    List: TStrings;
55
 
    StayOnTopList: TList;     // a list of windows that were normalized when showing modal
 
55
    StayOnTopList: TFPList;   // a list of windows that were normalized when showing modal
 
56
    MaxLength: integer;
 
57
    MouseX, MouseY: smallint; // noticing spurious WM_MOUSEMOVE messages
 
58
    DispInfoTextA: array [0..LV_DISP_INFO_COUNT-1] of AnsiString; // buffer for ListView LVN_GETDISPINFO notification
 
59
    DispInfoTextW: array [0..LV_DISP_INFO_COUNT-1] of WideString; // it's recommended to keep buffer unchanged
 
60
    DispInfoIndex: Integer;                    // between 2 calls of LVN_GETDISPINFO
 
61
    DrawItemIndex: integer;   // in case of listbox, when handling WM_DRAWITEM
 
62
    DrawItemSelected: boolean;// whether this item is selected LB_GETSEL not uptodate yet
56
63
    needParentPaint: boolean; // has a tabpage as parent, and is winxp themed
57
64
    isTabPage: boolean;       // is window of tabpage
58
65
    isComboEdit: boolean;     // is buddy of combobox, the edit control
59
66
    isChildEdit: boolean;     // is buddy edit of a control
60
67
    ThemedCustomDraw: boolean;// controls needs themed drawing in wm_notify/nm_customdraw
61
 
    MaxLength: integer;
62
 
    DrawItemIndex: integer;   // in case of listbox, when handling WM_DRAWITEM
63
 
    DrawItemSelected: boolean;// whether this item is selected LB_GETSEL not uptodate yet
64
 
    MouseX, MouseY: smallint; // noticing spurious WM_MOUSEMOVE messages
65
 
    DispInfoTextA: array [0..LV_DISP_INFO_COUNT-1] of AnsiString; // buffer for ListView LVN_GETDISPINFO notification
66
 
    DispInfoTextW: array [0..LV_DISP_INFO_COUNT-1] of WideString; // it's recommended to keep buffer unchanged
67
 
    DispInfoIndex: Integer;                    // between 2 calls of LVN_GETDISPINFO  
68
68
    IMEComposed: Boolean;
69
69
    case integer of
70
70
      0: (spinValue: Double);
76
76
 
77
77
function WM_To_String(WM_Message: Integer): string;
78
78
function WindowPosFlagsToString(Flags: UINT): string;
79
 
procedure EventTrace(Message: String; Data: TObject);
80
 
procedure AssertEx(const Message: String; const PassErr: Boolean;
81
 
  const Severity: Byte);
82
 
procedure AssertEx(const PassErr: Boolean; const Message: String);
83
 
procedure AssertEx(const Message: String);
84
 
function GetShiftState: TShiftState;
85
 
procedure CallEvent(const Target: TObject; Event: TNotifyEvent;
86
 
  const Data: Pointer; const EventType: TEventType);
87
79
function ObjectToHWND(const AObject: TObject): HWND;
88
 
function LCLControlSizeNeedsUpdate(Sender: TWinControl;
89
 
  SendSizeMsgOnDiff: boolean): boolean;
90
 
function GetLCLClientBoundsOffset(Sender: TObject; var ORect: TRect): boolean;
91
 
function GetLCLClientBoundsOffset(Handle: HWnd; var Rect: TRect): boolean;
92
 
procedure LCLBoundsToWin32Bounds(Sender: TObject;
93
 
  var Left, Top, Width, Height: Integer);
 
80
function LCLControlSizeNeedsUpdate(Sender: TWinControl; SendSizeMsgOnDiff: boolean): boolean;
 
81
function GetLCLClientBoundsOffset(Sender: TObject; out ORect: TRect): boolean;
 
82
function GetLCLClientBoundsOffset(Handle: HWnd; out Rect: TRect): boolean;
 
83
procedure LCLBoundsToWin32Bounds(Sender: TObject; var Left, Top, Width, Height: Integer);
94
84
procedure Win32PosToLCLPos(Sender: TObject; var Left, Top: SmallInt);
95
85
procedure GetWin32ControlPos(Window, Parent: HWND; var Left, Top: integer);
96
86
 
97
87
procedure UpdateWindowStyle(Handle: HWnd; Style: integer; StyleMask: integer);
98
 
function BorderStyleToWin32Flags(Style: TFormBorderStyle): DWORD;
99
 
function BorderStyleToWin32FlagsEx(Style: TFormBorderStyle): DWORD;
100
 
function GetDesigningBorderStyle(const AForm: TCustomForm): TFormBorderStyle;
101
88
 
102
89
function AllocWindowInfo(Window: HWND): PWin32WindowInfo;
103
90
function DisposeWindowInfo(Window: HWND): boolean;
104
91
function GetWin32WindowInfo(Window: HWND): PWin32WindowInfo;
105
92
 
106
 
procedure RemoveStayOnTopFlags(Window: HWND; ASystemTopAlso: Boolean = False);
107
 
procedure RestoreStayOnTopFlags(Window: HWND);
 
93
procedure RemoveStayOnTopFlags(AppHandle: HWND; ASystemTopAlso: Boolean = False);
 
94
procedure RestoreStayOnTopFlags(AppHandle: HWND);
 
95
procedure HidePopups(AppHandle: HWND);
 
96
procedure RestorePopups;
 
97
function LookupTopWindow(AppHandle: HWND): HWND;
108
98
 
109
99
procedure AddToChangedMenus(Window: HWnd);
110
100
procedure RedrawMenus;
134
124
type 
135
125
  PStayOnTopWindowsInfo = ^TStayOnTopWindowsInfo;
136
126
  TStayOnTopWindowsInfo = record
137
 
    AppWindow: HWND;
 
127
    AppHandle: HWND;
 
128
    StayOnTopList: TFPList;
138
129
    SystemTopAlso: Boolean;
139
 
    StayOnTopList: TList;
 
130
  end;
 
131
 
 
132
  PPopupOwnersWindowInfo = ^TPopupOwnersWindowInfo;
 
133
  TPopupOwnersWindowInfo = record
 
134
    AppHandle: HWND;
 
135
    OwnersList: TFPList;
 
136
  end;
 
137
 
 
138
  PLookupTopWindowInfo = ^TLookupTopWindowInfo;
 
139
  TLookupTopWindowInfo = record
 
140
    AppHandle: HWND;
 
141
    TopWindow: HWND;
140
142
  end;
141
143
  
142
144
  TWindowsVersion = (
158
160
var
159
161
  DefaultWindowInfo: TWin32WindowInfo;
160
162
  WindowInfoAtom: ATOM;
161
 
  ChangedMenus: TList; // list of HWNDs which menus needs to be redrawn
 
163
  ChangedMenus: TFPList; // list of HWNDs which menus needs to be redrawn
162
164
  UnicodeEnabledOS: Boolean = False;
163
165
 
164
166
  WindowsVersion: TWindowsVersion = wvUnknown;
167
169
implementation
168
170
 
169
171
uses
170
 
  LCLStrConsts, Dialogs, StdCtrls, ExtCtrls,
 
172
  LCLStrConsts, Dialogs, StdCtrls, ExtCtrls, ComCtrls,
171
173
  LCLIntf; //remove this unit when GetWindowSize is moved to TWSWinControl
172
174
 
173
175
{$IFOPT C-}
178
180
 
179
181
var
180
182
  InRemoveStayOnTopFlags: Integer = 0;
 
183
  PopupOwnersList: TFPList = nil;
181
184
{------------------------------------------------------------------------------
182
185
  function: WM_To_String
183
186
  Params: WM_Message - a WinDows message
280
283
    // edit control messages start (todo: add more if needed)
281
284
    $00B0: Result := 'EM_GETSEL';
282
285
    $00B1: Result := 'EM_SETSEL';
 
286
    $00B2: Result := 'EM_GETRECT';
 
287
    $00B3: Result := 'EM_SETRECT';
 
288
    $00B4: Result := 'EM_SETRECTNP';
 
289
    $00B5: Result := 'EM_SCROLL';
 
290
    $00B6: Result := 'EM_LINESCROLL';
283
291
    $00B7: Result := 'EM_SCROLLCARET';
 
292
    $00B8: Result := 'EM_GETMODIFY';
 
293
    $00B9: Result := 'EM_SETMODIFY';
 
294
    $00BA: Result := 'EM_GETLINECOUNT';
 
295
    $00BB: Result := 'EM_LINEINDEX';
 
296
    $00BC: Result := 'EM_SETHANDLE';
 
297
    $00BD: Result := 'EM_GETHANDLE';
 
298
    $00BE: Result := 'EM_GETTHUMB';
 
299
    $00C1: Result := 'EM_LINELENGTH';
 
300
    $00C2: Result := 'EM_REPLACESEL';
 
301
    $00C4: Result := 'EM_GETLINE';
284
302
    $00C5: Result := 'EM_LIMITTEXT';
 
303
    $00C6: Result := 'EM_CANUNDO';
 
304
    $00C7: Result := 'EM_UNDO';
 
305
    $00C8: Result := 'EM_FMTLINES';
 
306
    $00C9: Result := 'EM_LINEFROMCHAR';
 
307
    $00CB: Result := 'EM_SETTABSTOPS';
285
308
    $00CC: Result := 'EM_SETPASSWORDCHAR';
 
309
    $00CD: Result := 'EM_EMPTYUNDOBUFFER';
 
310
    $00CE: Result := 'EM_GETFIRSTVISIBLELINE';
286
311
    $00CF: Result := 'EM_SETREADONLY';
 
312
    $00D0: Result := 'EM_SETWORDBREAKPROC';
 
313
    $00D1: Result := 'EM_GETWORDBREAKPROC';
 
314
    $00D2: Result := 'EM_GETPASSWORDCHAR';
 
315
    $00D3: Result := 'EM_SETMARGINS';
 
316
    $00D4: Result := 'EM_GETMARGINS';
 
317
    $00D5: Result := 'EM_GETLIMITTEXT';
 
318
    $00D6: Result := 'EM_POSFROMCHAR';
 
319
    $00D7: Result := 'EM_CHARFROMPOS';
287
320
    // edit control messages end
288
321
    // scrollbar control messages start
289
322
    $00E0: Result := 'SBM_SETPOS';
524
557
  Result := FlagsStr;
525
558
end;
526
559
 
527
 
 
528
 
{------------------------------------------------------------------------------
529
 
  procedure: EventTrace
530
 
  Params: Message - Event name
531
 
          Data    - Object which fired this event
532
 
  Returns: Nothing
533
 
 
534
 
  Displays a trace about an event
535
 
 ------------------------------------------------------------------------------}
536
 
procedure EventTrace(Message: String; Data: TObject);
537
 
begin
538
 
  if Data = nil then
539
 
    Assert(False, Format('Trace:Event [%S] fired', [Message]))
540
 
  else
541
 
    Assert(False, Format('Trace:Event [%S] fired for %S',[Message, Data.Classname]));
542
 
end;
543
 
 
544
 
{------------------------------------------------------------------------------
545
 
  function: AssertEx
546
 
  Params: Message  - Message sent
547
 
          PassErr  - Pass error to a catching procedure (default: False)
548
 
          Severity - How severe is the error on a scale from 0 to 3
549
 
                     (default: 0)
550
 
  Returns: Nothing
551
 
 
552
 
  An expanded, better version of Assert
553
 
 ------------------------------------------------------------------------------}
554
 
procedure AssertEx(const Message: String; const PassErr: Boolean; const Severity: Byte);
555
 
begin
556
 
  Case Severity Of
557
 
    0:
558
 
    begin
559
 
      Assert(PassErr, Message);
560
 
    end;
561
 
    1:
562
 
    begin
563
 
      Assert(PassErr, Format('Trace:%S', [Message]));
564
 
    end;
565
 
    2:
566
 
    begin
567
 
      Case IsConsole Of
568
 
        True:
569
 
        begin
570
 
          WriteLn(rsWin32Warning, Message);
571
 
        end;
572
 
        False:
573
 
        begin
574
 
          MessageBox(0, PChar(Message), PChar(rsWin32Warning), MB_OK);
575
 
        end;
576
 
      end;
577
 
    end;
578
 
    3:
579
 
    begin
580
 
      Case IsConsole Of
581
 
        True:
582
 
        begin
583
 
          WriteLn(rsWin32Error, Message);
584
 
        end;
585
 
        False:
586
 
        begin
587
 
          MessageBox(0, PChar(Message), nil, MB_OK);
588
 
        end;
589
 
      end;
590
 
    end;
591
 
  end;
592
 
end;
593
 
 
594
 
procedure AssertEx(const PassErr: Boolean; const Message: String);
595
 
begin
596
 
  AssertEx(Message, PassErr, 0);
597
 
end;
598
 
 
599
 
procedure AssertEx(const Message: String);
600
 
begin
601
 
  AssertEx(Message, False, 0);
602
 
end;
603
 
 
604
 
{------------------------------------------------------------------------------
605
 
  function: GetShiftState
606
 
  Params: None
607
 
  Returns: A shift state
608
 
 
609
 
  Creates a TShiftState set based on the status when the function was called.
610
 
 ------------------------------------------------------------------------------}
611
 
function GetShiftState: TShiftState;
612
 
begin
613
 
  Result := [];
614
 
  // NOTE: it may be better to use GetAsyncKeyState
615
 
  // if GetKeyState AND $8000 <> 0 then down (e.g. shift)
616
 
  // if GetKeyState AND 1 <> 0, then toggled on (e.g. num lock)
617
 
  if (GetKeyState(VK_SHIFT) and $8000) <> 0 then
618
 
    Result := Result + [ssShift];
619
 
  if (GetKeyState(VK_CAPITAL) and 1) <> 0 then
620
 
    Result := Result + [ssCaps];
621
 
  if (GetKeyState(VK_CONTROL) and $8000) <> 0 then
622
 
    Result := Result + [ssCtrl];
623
 
  if (GetKeyState(VK_MENU) and $8000) <> 0 then
624
 
    Result := Result + [ssAlt];
625
 
  if (GetKeyState(VK_NUMLOCK) and 1) <> 0 then
626
 
    Result := Result + [ssNum];
627
 
  //TODO: ssSuper
628
 
  if (GetKeyState(VK_SCROLL) and 1) <> 0 then
629
 
    Result := Result + [ssScroll];
630
 
  // GetKeyState takes mouse button swap into account (GetAsyncKeyState doesn't),
631
 
  // so no need to test GetSystemMetrics(SM_SWAPBUTTON)
632
 
  if (GetKeyState(VK_LBUTTON) and $8000) <> 0 then
633
 
    Result := Result + [ssLeft];
634
 
  if (GetKeyState(VK_MBUTTON) and $8000) <> 0 then
635
 
    Result := Result + [ssMiddle];
636
 
  if (GetKeyState(VK_RBUTTON) and $8000) <> 0 then
637
 
    Result := Result + [ssRight];
638
 
  //TODO: ssAltGr
639
 
end;
640
 
 
641
560
{------------------------------------------------------------------------------
642
561
  procedure: GetWin32KeyInfo
643
562
  Params:  Event      - Requested info
655
574
const
656
575
  MVK_UNIFY_SIDES = 1;
657
576
begin
658
 
  Assert(False, 'TRACE:Using function GetWin32KeyInfo which isn''t implemented yet');
659
577
  KeyCode := Word(Event);
660
578
  VirtualKey := MapVirtualKey(KeyCode, MVK_UNIFY_SIDES);
661
579
  SysKey := (VirtualKey = VK_SHIFT) Or (VirtualKey = VK_CONTROL) Or (VirtualKey = VK_MENU);
664
582
end;
665
583
}
666
584
 
667
 
{-----------------------------------------------------------------------------
668
 
  procedure: CallEvent
669
 
  Params: Target    - the object for which the event will be called
670
 
          Event     - event to call
671
 
          Data      - misc data
672
 
          EventType - the type of event
673
 
  Returns: Nothing
674
 
 
675
 
  Calls an event
676
 
-------------------------------------------------------------------------------}
677
 
procedure CallEvent(const Target: TObject; Event: TNotifyEvent; const Data: Pointer; const EventType: TEventType);
678
 
begin
679
 
  if Assigned(Target) And Assigned(Event) then
680
 
  begin
681
 
    Case EventType Of
682
 
      etNotify:
683
 
      begin
684
 
        Event(Target);
685
 
      end;
686
 
    end;
687
 
  end;
688
 
end;
689
 
 
690
585
{------------------------------------------------------------------------------
691
586
  function: ObjectToHWND
692
587
  Params: AObject - An LCL Object
695
590
  Returns the Window handle of the given object, 0 if no object available
696
591
 ------------------------------------------------------------------------------}
697
592
function ObjectToHWND(const AObject: TObject): HWND;
698
 
var
699
 
  Handle: HWND;
700
593
begin
701
 
  Handle := 0;
 
594
  Result := 0;
702
595
  if not assigned(AObject) then
703
596
    Assert (False, 'TRACE:[ObjectToHWND] Object not assigned')
704
597
  else
705
598
  if (AObject is TWinControl) then
706
599
  begin
707
600
    if TWinControl(AObject).HandleAllocated then
708
 
      Handle := TWinControl(AObject).Handle
 
601
      Result := TWinControl(AObject).Handle
709
602
  end
710
603
  else
711
604
  if (AObject is TMenuItem) then
712
605
  begin
713
606
    if TMenuItem(AObject).HandleAllocated then
714
 
      Handle := TMenuItem(AObject).Handle
 
607
      Result := TMenuItem(AObject).Handle
715
608
  end
716
609
  else
717
610
  if (AObject is TMenu) then
718
611
  begin
719
612
    if TMenu(AObject).HandleAllocated then
720
 
      Handle := TMenu(AObject).Items.Handle
 
613
      Result := TMenu(AObject).Items.Handle
721
614
  end
722
615
  else
723
616
  if (AObject is TCommonDialog) then
724
617
  begin
725
618
    {if TCommonDialog(AObject).HandleAllocated then }
726
 
    Handle := TCommonDialog(AObject).Handle
727
 
  end
728
 
  else
729
 
    Assert(False, Format('Trace:[ObjectToHWND] Message received With unhandled class-type <%s>', [AObject.ClassName]));
730
 
 
731
 
  Result := Handle;
732
 
  if Handle = 0 then
733
 
    Assert(False, 'Trace:[ObjectToHWND]****** Warning: handle = 0 *******');
 
619
    Result := TCommonDialog(AObject).Handle
 
620
  end;
734
621
end;
735
622
 
736
623
(***********************************************************************
772
659
end;
773
660
 
774
661
{-------------------------------------------------------------------------------
775
 
  function GetLCLClientOriginOffset(Sender: TObject;
776
 
    var LeftOffset, TopOffset: integer): boolean;
 
662
  function GetLCLClientBoundsOffset(Sender: TObject; out ORect: TRect): boolean;
777
663
 
778
664
  Returns the difference between the client origin of a win32 handle
779
665
  and the definition of the LCL counterpart.
783
669
    height.
784
670
  It is used in GetClientBounds to define LCL bounds from win32 bounds.
785
671
-------------------------------------------------------------------------------}
786
 
function GetLCLClientBoundsOffset(Sender: TObject; var ORect: TRect): boolean;
 
672
function GetLCLClientBoundsOffset(Sender: TObject; out ORect: TRect): boolean;
787
673
var
788
 
  TM: TextMetricA;
 
674
  TM: Windows.TextMetric;
789
675
  DC: HDC;
790
676
  Handle: HWND;
791
 
  TheWinControl: TWinControl;
 
677
  TheWinControl: TWinControl absolute Sender;
792
678
  ARect: TRect;
793
679
begin
794
680
  Result := False;
795
 
  if (Sender = nil) or (not (Sender is TWinControl)) then exit;
796
 
  TheWinControl := TWinControl(Sender);
 
681
  if not (Sender is TWinControl) then exit;
797
682
  if not TheWinControl.HandleAllocated then exit;
798
683
  Handle := TheWinControl.Handle;
799
684
  FillChar(ORect, SizeOf(ORect), 0);
800
685
  if TheWinControl is TScrollingWinControl then
 
686
  begin
 
687
    {$ifdef RedirectDestroyMessages}
 
688
    with TScrollingWinControl(TheWinControl) do
 
689
    begin
 
690
      OffsetRect(ORect, -HorzScrollBar.Position, -VertScrollBar.Position);
 
691
    end;
 
692
    {$else}
801
693
    with TScrollingWinControl(TheWinControl) do
802
694
    begin
803
695
      if HorzScrollBar <> nil then
813
705
        ORect.Bottom := -VertScrollBar.Position;
814
706
      end;
815
707
    end;
 
708
    {$endif}
 
709
  end else
816
710
  if (TheWinControl is TCustomGroupBox) then
817
711
  begin
818
712
    // The client area of a groupbox under winapi is the whole size, including
820
714
    // -> Adjust the position
821
715
    // add the upper frame with the caption
822
716
    DC := Windows.GetDC(Handle);
823
 
    GetTextMetrics(DC, TM);
 
717
    Windows.GetTextMetrics(DC, TM);
824
718
    ORect.Top := TM.TMHeight;
825
719
    Windows.ReleaseDC(Handle, DC);
826
720
    // add the left, right and bottom frame borders
828
722
    ORect.Right := -2;
829
723
    ORect.Bottom := -2;
830
724
  end else
831
 
  if TheWinControl is TCustomNoteBook then
 
725
  if TheWinControl is TCustomTabControl then
832
726
  begin
833
727
    // Can't use complete client rect in win32 interface, top part contains the tabs
834
728
    Windows.GetClientRect(Handle, @ARect);
847
741
  Result := True;
848
742
end;
849
743
 
850
 
function GetLCLClientBoundsOffset(Handle: HWnd; var Rect: TRect): boolean;
 
744
function GetLCLClientBoundsOffset(Handle: HWnd; out Rect: TRect): boolean;
851
745
var
852
746
  OwnerObject: TObject;
853
747
begin
904
798
  SetWindowLong(Handle, GWL_STYLE, NewStyle);
905
799
end;
906
800
 
907
 
function BorderStyleToWin32Flags(Style: TFormBorderStyle): DWORD;
908
 
begin
909
 
  Result := WS_CLIPCHILDREN or WS_CLIPSIBLINGS;
910
 
  case Style of
911
 
  bsSizeable, bsSizeToolWin:
912
 
    Result := Result or (WS_OVERLAPPED or WS_THICKFRAME or WS_CAPTION);
913
 
  bsSingle, bsToolWindow:
914
 
    Result := Result or (WS_OVERLAPPED or WS_BORDER or WS_CAPTION);
915
 
  bsDialog:
916
 
    Result := Result or (WS_POPUP or WS_BORDER or WS_CAPTION);
917
 
  bsNone:
918
 
    Result := Result or WS_POPUP;
919
 
  end;
920
 
end;
921
 
 
922
 
function BorderStyleToWin32FlagsEx(Style: TFormBorderStyle): DWORD;
923
 
begin
924
 
  Result := 0;
925
 
  case Style of
926
 
    bsDialog:
927
 
      Result := WS_EX_DLGMODALFRAME or WS_EX_WINDOWEDGE;
928
 
    bsToolWindow, bsSizeToolWin:
929
 
      Result := WS_EX_TOOLWINDOW;
930
 
  end;
931
 
end;
932
 
 
933
 
function GetDesigningBorderStyle(const AForm: TCustomForm): TFormBorderStyle;
934
 
{$NOTE Belongs in Win32WSForms, but is needed in windowproc}
935
 
begin
936
 
  if csDesigning in AForm.ComponentState then
937
 
    Result := bsSizeable
938
 
  else
939
 
    Result := AForm.BorderStyle;
940
 
end;
941
 
 
942
801
function AllocWindowInfo(Window: HWND): PWin32WindowInfo;
943
802
var
944
803
  WindowInfo: PWin32WindowInfo;
955
814
  WindowInfo: PWin32WindowInfo;
956
815
begin
957
816
  WindowInfo := PWin32WindowInfo(Windows.GetProp(Window, PChar(PtrUInt(WindowInfoAtom))));
958
 
  Result := Windows.RemoveProp(Window, PChar(PtrUInt(WindowInfoAtom)))<>0;
 
817
  Result := Windows.RemoveProp(Window, PChar(PtrUInt(WindowInfoAtom))) <> 0;
959
818
  if Result then
960
819
  begin
961
820
    WindowInfo^.StayOnTopList.Free;
972
831
 
973
832
function EnumStayOnTopRemove(Handle: HWND; Param: LPARAM): WINBOOL; stdcall;
974
833
var
975
 
  AStyle: DWord;
976
834
  StayOnTopWindowsInfo: PStayOnTopWindowsInfo absolute Param;
977
835
  lWindowInfo: PWin32WindowInfo;
978
836
  lWinControl: TWinControl;
979
837
begin
980
838
  Result := True;
981
 
  AStyle := GetWindowLong(Handle, GWL_EXSTYLE);
982
 
  if (AStyle and WS_EX_TOPMOST) <> 0 then // if stay on top then
 
839
  if ((GetWindowLong(Handle, GWL_EXSTYLE) and WS_EX_TOPMOST) <> 0) then
983
840
  begin
984
841
    // Don't remove system-wide stay on top, unless desired
985
842
    if not StayOnTopWindowsInfo^.SystemTopAlso then
986
843
    begin
987
844
      lWindowInfo := GetWin32WindowInfo(Handle);
988
 
      if (lWindowInfo <> nil) then
 
845
      if Assigned(lWindowInfo) then
989
846
      begin
990
847
        lWinControl := lWindowInfo^.WinControl;
991
 
        if (lWinControl <> nil) and (lWinControl is TCustomForm)
992
 
        and (TCustomForm(lWinControl).FormStyle = fsSystemStayOnTop) then
 
848
        if (lWinControl is TCustomForm) and
 
849
          (TCustomForm(lWinControl).FormStyle = fsSystemStayOnTop) then
993
850
        Exit;
994
851
      end;
995
852
    end;
996
853
 
997
854
    StayOnTopWindowsInfo^.StayOnTopList.Add(Pointer(Handle));
998
 
    SetWindowPos(Handle, HWND_NOTOPMOST, 0, 0, 0, 0,
999
 
      SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_NOOWNERZORDER or SWP_NOSENDCHANGING);
1000
855
  end;
1001
856
end;
1002
857
 
1003
 
procedure RemoveStayOnTopFlags(Window: HWND; ASystemTopAlso: Boolean = False);
 
858
procedure RemoveStayOnTopFlags(AppHandle: HWND; ASystemTopAlso: Boolean = False);
1004
859
var
1005
860
  StayOnTopWindowsInfo: PStayOnTopWindowsInfo;
1006
861
  WindowInfo: PWin32WindowInfo;
 
862
  I: Integer;
1007
863
begin
1008
 
  // WriteLn('RemoveStayOnTopFlags 1');
 
864
  //WriteLn('RemoveStayOnTopFlags ', InRemoveStayOnTopFlags);
1009
865
  if InRemoveStayOnTopFlags = 0 then
1010
866
  begin
1011
867
    New(StayOnTopWindowsInfo);
1012
 
    StayOnTopWindowsInfo^.AppWindow := Window;
 
868
    StayOnTopWindowsInfo^.AppHandle := AppHandle;
1013
869
    StayOnTopWindowsInfo^.SystemTopAlso := ASystemTopAlso;
1014
 
    StayOnTopWindowsInfo^.StayOnTopList := TList.Create;
1015
 
    WindowInfo := GetWin32WindowInfo(Window);
 
870
    StayOnTopWindowsInfo^.StayOnTopList := TFPList.Create;
 
871
    WindowInfo := GetWin32WindowInfo(AppHandle);
1016
872
    WindowInfo^.StayOnTopList := StayOnTopWindowsInfo^.StayOnTopList;
1017
 
    EnumThreadWindows(GetWindowThreadProcessId(Window, nil),
 
873
    EnumThreadWindows(GetWindowThreadProcessId(AppHandle, nil),
1018
874
      @EnumStayOnTopRemove, LPARAM(StayOnTopWindowsInfo));
 
875
    for I := 0 to WindowInfo^.StayOnTopList.Count - 1 do
 
876
      SetWindowPos(HWND(WindowInfo^.StayOnTopList[I]), HWND_NOTOPMOST, 0, 0, 0, 0,
 
877
        SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_NOOWNERZORDER or SWP_DRAWFRAME);
1019
878
    Dispose(StayOnTopWindowsInfo);
1020
879
  end;
1021
880
  inc(InRemoveStayOnTopFlags);
1022
 
  // WriteLn('RemoveStayOnTopFlags 2');
1023
881
end;
1024
882
 
1025
 
procedure RestoreStayOnTopFlags(Window: HWND);
 
883
procedure RestoreStayOnTopFlags(AppHandle: HWND);
1026
884
var
1027
885
  WindowInfo: PWin32WindowInfo;
1028
886
  I: integer;
1029
887
begin
1030
 
  // WriteLn('RestoreStayOnTopFlags 1');
 
888
  //WriteLn('RestoreStayOnTopFlags ', InRemoveStayOnTopFlags);
1031
889
  if InRemoveStayOnTopFlags = 1 then
1032
890
  begin
1033
 
    WindowInfo := GetWin32WindowInfo(Window);
 
891
    WindowInfo := GetWin32WindowInfo(AppHandle);
1034
892
    if WindowInfo^.StayOnTopList <> nil then
1035
893
    begin
1036
894
      for I := 0 to WindowInfo^.StayOnTopList.Count - 1 do
1037
895
        SetWindowPos(HWND(WindowInfo^.StayOnTopList.Items[I]),
1038
896
          HWND_TOPMOST, 0, 0, 0, 0,
1039
 
          SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_NOOWNERZORDER or SWP_NOSENDCHANGING);
 
897
          SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_NOOWNERZORDER or SWP_DRAWFRAME);
1040
898
      FreeAndNil(WindowInfo^.StayOnTopList);
1041
899
    end;
1042
900
  end;
1043
901
  if InRemoveStayOnTopFlags > 0 then
1044
902
    dec(InRemoveStayOnTopFlags);
1045
 
  // WriteLn('RestoreStayOnTopFlags 2');
1046
 
end;
1047
 
 
 
903
end;
 
904
 
 
905
function EnumHidePopups(Handle: HWND; Param: LPARAM): WINBOOL; stdcall;
 
906
var
 
907
  Owner: HWND;
 
908
begin
 
909
  Owner := GetWindow(Handle, GW_OWNER);
 
910
  if (Owner <> 0) and (Owner <> PPopupOwnersWindowInfo(Param)^.AppHandle) then
 
911
    PPopupOwnersWindowInfo(Param)^.OwnersList.Add(Pointer(Owner));
 
912
  Result := True;
 
913
end;
 
914
 
 
915
procedure HidePopups(AppHandle: HWND);
 
916
var
 
917
  i: Integer;
 
918
  Info: PPopupOwnersWindowInfo;
 
919
begin
 
920
  if not Assigned(PopupOwnersList) then
 
921
  begin
 
922
    PopupOwnersList := TFPList.Create;
 
923
    New(Info);
 
924
    try
 
925
      Info^.AppHandle := AppHandle;
 
926
      Info^.OwnersList := PopupOwnersList;
 
927
      EnumThreadWindows(GetWindowThreadProcessId(Application.MainFormHandle, nil),
 
928
        @EnumHidePopups, LPARAM(Info));
 
929
      for i := 0 to PopupOwnersList.Count - 1 do
 
930
        ShowOwnedPopups(HWND(PopupOwnersList[i]), False);
 
931
    finally
 
932
      Dispose(Info);
 
933
    end;
 
934
  end;
 
935
end;
 
936
 
 
937
procedure RestorePopups;
 
938
var
 
939
  i: Integer;
 
940
begin
 
941
  if Assigned(PopupOwnersList) then
 
942
  begin
 
943
    for i := 0 to PopupOwnersList.Count - 1 do
 
944
      ShowOwnedPopups(HWND(PopupOwnersList[i]), True);
 
945
    FreeAndNil(PopupOwnersList);
 
946
  end;
 
947
end;
 
948
 
 
949
function EnumLookupTopWindow(Handle: HWND; Param: LPARAM): WINBOOL; stdcall;
 
950
begin
 
951
  Result := True;
 
952
  if IsWindowVisible(Handle) and IsWindowEnabled(Handle) then
 
953
  begin
 
954
    with PLookupTopWindowInfo(Param)^ do
 
955
    begin
 
956
      if (Handle = AppHandle) or (Handle = TopWindow) then
 
957
        Exit;
 
958
      if GetWindowLong(Handle, GWL_EXSTYLE) and WS_EX_TOPMOST <> 0 then
 
959
      begin
 
960
        // we've found the top most window => stop
 
961
        TopWindow := Handle;
 
962
        Result := False;
 
963
      end
 
964
      else
 
965
      if TopWindow = 0 then
 
966
        TopWindow := Handle;
 
967
    end;
 
968
  end;
 
969
end;
 
970
 
 
971
function LookupTopWindow(AppHandle: HWND): HWND;
 
972
var
 
973
  Info: PLookupTopWindowInfo;
 
974
begin
 
975
  New(Info);
 
976
  Info^.AppHandle := AppHandle;
 
977
  Info^.TopWindow := 0;
 
978
  EnumThreadWindows(GetWindowThreadProcessId(AppHandle, nil),
 
979
      @EnumLookupTopWindow, LPARAM(Info));
 
980
  Result := Info^.TopWindow;
 
981
  if Result = 0 then
 
982
    Result := AppHandle;
 
983
  Dispose(Info);
 
984
end;
1048
985
 
1049
986
{-------------------------------------------------------------------------------
1050
987
  procedure AddToChangedMenus(Window: HWnd);
1716
1653
  FillChar(DefaultWindowInfo, sizeof(DefaultWindowInfo), 0);
1717
1654
  DefaultWindowInfo.DrawItemIndex := -1;
1718
1655
  WindowInfoAtom := Windows.GlobalAddAtom('WindowInfo');
1719
 
  ChangedMenus := TList.Create;
 
1656
  ChangedMenus := TFPList.Create;
1720
1657
 
1721
1658
  {$ifdef WindowsUnicodeSupport}
1722
1659
  UnicodeEnabledOS := (Win32Platform = VER_PLATFORM_WIN32_NT);
1737
1674
  Windows.GlobalDeleteAtom(WindowInfoAtom);
1738
1675
  WindowInfoAtom := 0;
1739
1676
  ChangedMenus.Free;
 
1677
  FreeAndNil(PopupOwnersList);
1740
1678
 
1741
1679
end.