lazarus/lcl/interfaces/customdrawn/customdrawnwsforms_win.inc
2011-11-24 14:37:46 +00:00

586 lines
20 KiB
PHP
Raw Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

{$MainForm customdrawnwsforms.pp}
type
TWinControlAccess = class(TWinControl)
end;
{ TCDWSCustomForm }
class procedure TCDWSCustomForm.BackendAddCDWinControlToForm(const AForm: TCustomForm; ACDWinControl: TCDWinControl);
var
WindowInfo: PWindowInfo;
begin
WindowInfo := GetWindowInfo(AForm.Handle);
if WindowInfo^.Children = nil then WindowInfo^.Children := TFPList.Create;
WindowInfo^.Children.Add(ACDWinControl);
end;
class function TCDWSCustomForm.BackendGetCDWinControlList(const AForm: TCustomForm): TFPList;
var
WindowInfo: PWindowInfo;
begin
WindowInfo := GetWindowInfo(AForm.Handle);
if WindowInfo^.Children = nil then WindowInfo^.Children := TFPList.Create;
Result := WindowInfo^.Children;
end;
class function TCDWSCustomForm.CalcBorderIconsFlags(const AForm: TCustomForm): dword;
var
BorderIcons: TBorderIcons;
begin
Result := 0;
BorderIcons := AForm.BorderIcons;
if (biSystemMenu in BorderIcons) or (csDesigning in AForm.ComponentState) then
Result := Result or WS_SYSMENU;
if GetDesigningBorderStyle(AForm) in [bsNone, bsSingle, bsSizeable] then
begin
if biMinimize in BorderIcons then
Result := Result or WS_MINIMIZEBOX;
if biMaximize in BorderIcons then
Result := Result or WS_MAXIMIZEBOX;
end;
end;
class function TCDWSCustomForm.CalcBorderIconsFlagsEx(const AForm: TCustomForm): DWORD;
var
BorderIcons: TBorderIcons;
begin
Result := 0;
BorderIcons := AForm.BorderIcons;
if GetDesigningBorderStyle(AForm) in [bsSingle, bsSizeable, bsDialog] then
begin
if biHelp in BorderIcons then
Result := Result or WS_EX_CONTEXTHELP;
end;
end;
class procedure TCDWSCustomForm.CalcFormWindowFlags(const AForm: TCustomForm;
var Flags, FlagsEx: dword);
begin
// clear all styles which can be set by border style and icons
Flags := Flags and not (WS_POPUP or WS_BORDER or WS_CAPTION or WS_THICKFRAME or
WS_DLGFRAME or WS_MINIMIZEBOX or WS_MAXIMIZEBOX or WS_SYSMENU);
FlagsEx := FlagsEx and not (WS_EX_DLGMODALFRAME or WS_EX_WINDOWEDGE or
WS_EX_TOOLWINDOW or WS_EX_CONTEXTHELP);
// set border style flags
Flags := Flags or CalcBorderStyleFlags(AForm);
FlagsEx := FlagsEx or CalcBorderStyleFlagsEx(AForm);
if (AForm.FormStyle in fsAllStayOnTop) and not (csDesigning in AForm.ComponentState) then
FlagsEx := FlagsEx or WS_EX_TOPMOST;
Flags := Flags or CalcBorderIconsFlags(AForm);
FlagsEx := FlagsEx or CalcBorderIconsFlagsEx(AForm);
end;
class procedure TCDWSCustomForm.CalculateDialogPosition(var Params: TCreateWindowExParams;
Bounds: TRect; lForm: TCustomForm);
begin
if lForm.Position in [poDefault, poDefaultPosOnly] then
begin
Params.Left := CW_USEDEFAULT;
Params.Top := CW_USEDEFAULT;
end
else
begin
Params.Left := Bounds.Left;
Params.Top := Bounds.Top;
end;
if lForm.Position in [poDefault, poDefaultSizeOnly] then
begin
Params.Width := CW_USEDEFAULT;
Params.Height := CW_USEDEFAULT;
end
else
begin
Params.Width := Bounds.Right - Bounds.Left;
Params.Height := Bounds.Bottom - Bounds.Top;
end;
end;
class function TCDWSCustomForm.GetDesigningBorderStyle(const AForm: TCustomForm): TFormBorderStyle;
begin
if csDesigning in AForm.ComponentState then
Result := bsSizeable
else
Result := AForm.BorderStyle;
end;
class function TCDWSCustomForm.CalcBorderStyleFlags(const AForm: TCustomForm): DWORD;
begin
Result := WS_CLIPCHILDREN or WS_CLIPSIBLINGS;
case GetDesigningBorderStyle(AForm) of
bsSizeable, bsSizeToolWin:
Result := Result or (WS_OVERLAPPED or WS_THICKFRAME or WS_CAPTION);
bsSingle, bsToolWindow:
Result := Result or (WS_OVERLAPPED or WS_BORDER or WS_CAPTION);
bsDialog:
Result := Result or (WS_POPUP or WS_BORDER or WS_CAPTION);
bsNone:
if (AForm.Parent = nil) and (AForm.ParentWindow = 0) then
Result := Result or WS_POPUP;
end;
end;
class function TCDWSCustomForm.CalcBorderStyleFlagsEx(const AForm: TCustomForm): DWORD;
begin
Result := 0;
case GetDesigningBorderStyle(AForm) of
bsDialog:
Result := WS_EX_DLGMODALFRAME or WS_EX_WINDOWEDGE;
bsToolWindow, bsSizeToolWin:
Result := WS_EX_TOOLWINDOW;
end;
end;
class procedure TCDWSCustomForm.AdjustFormBounds(const AForm: TCustomForm; out SizeRect: TRect);
begin
// the LCL defines the size of a form without border, win32 with.
// -> adjust size according to BorderStyle
SizeRect := AForm.BoundsRect;
Windows.AdjustWindowRectEx(@SizeRect, CalcBorderStyleFlags(AForm) or CalcBorderIconsFlags(AForm),
False, CalcBorderStyleFlagsEx(AForm) or CalcBorderIconsFlagsEx(AForm));
end;
class procedure TCDWSCustomForm.WSWinControl_SetBounds(const AWinControl: TWinControl;
const ALeft, ATop, AWidth, AHeight: Integer);
var
IntfLeft, IntfTop, IntfWidth, IntfHeight: integer;
suppressMove: boolean;
Handle: HWND;
WindowPlacement: TWINDOWPLACEMENT;
begin
{$ifdef VerboseCDForms}
DebugLn(Format('[TCDWSCustomForm.WSWinControl_SetBounds] AWinControl=%x'
+ ' ALeft=%d ATop=%d AWidth=%d AHeight=%d',
[PtrInt(AWinControl), ALeft, ATop, AWidth, AHeight]));
{$endif}
IntfLeft := ALeft;
IntfTop := ATop;
IntfWidth := AWidth;
IntfHeight := AHeight;
LCLBoundsToWin32Bounds(AWinControl, IntfLeft, IntfTop, IntfWidth, IntfHeight);
{$IFDEF VerboseCDForms}
DebugLn('[TCDWSCustomForm.WSWinControl_SetBounds] A ', dbgsName(AWinControl),
' LCL=',Format('%d, %d, %d, %d', [ALeft,ATop,AWidth,AHeight]),
' Win32=',Format('%d, %d, %d, %d', [IntfLeft,IntfTop,IntfWidth,IntfHeight])
);
{$ENDIF}
suppressMove := False;
AdaptBounds(AWinControl, IntfLeft, IntfTop, IntfWidth, IntfHeight, suppressMove);
if not suppressMove then
begin
Handle := AWinControl.Handle;
WindowPlacement.length := SizeOf(WindowPlacement);
if IsIconic(Handle) and GetWindowPlacement(Handle, @WindowPlacement) then
begin
WindowPlacement.rcNormalPosition := Bounds(IntfLeft, IntfTop, IntfWidth, IntfHeight);
SetWindowPlacement(Handle, @WindowPlacement);
end
else
Windows.SetWindowPos(Handle, 0, IntfLeft, IntfTop, IntfWidth, IntfHeight, SWP_NOZORDER or SWP_NOACTIVATE);
end;
LCLControlSizeNeedsUpdate(AWinControl, True);
end;
{------------------------------------------------------------------------------
Method: TCDWSCustomForm.CreateHandle
Params: None
Returns: Nothing
Creates a Windows CE Form, initializes it according to it´s properties and shows it
------------------------------------------------------------------------------}
class function TCDWSCustomForm.CreateHandle(const AWinControl: TWinControl;
const AParams: TCreateParams): TLCLIntfHandle;
var
Params: TCreateWindowExParams;
lForm: TCustomForm absolute AWinControl;
Bounds: TRect;
SystemMenu: HMenu;
begin
{$ifdef VerboseCDForms}
DebugLn(Format(':>[TCDWSCustomForm.CreateHandle] AWincontrol=%x left=%d Top=%d'
+ ' Width=%d Height=%d', [PtrInt(AWincontrol), AWinControl.Top, AWinControl.Left,
AParams.Width, AParams.Height]));
{$endif}
// general initialization of Params
PrepareCreateWindow(AWinControl, AParams, Params);
// customization of Params
with Params do
begin
if (Parent = 0) then
begin
if not Application.MainFormOnTaskBar then
Parent := CDWidgetSet.AppHandle
else
if (AWinControl <> Application.MainForm) then
begin
if Assigned(Application.MainForm) and Application.MainForm.HandleAllocated then
Parent := Application.MainFormHandle
else
Parent := CDWidgetSet.AppHandle;
end;
end;
CalcFormWindowFlags(lForm, Flags, FlagsEx);
pClassName := @ClsName[0];
WindowTitle := StrCaption;
AdjustFormBounds(lForm, Bounds);
if (lForm.Position in [poDefault, poDefaultPosOnly]) and not (csDesigning in lForm.ComponentState) then
begin
Left := CW_USEDEFAULT;
Top := CW_USEDEFAULT;
end
else
begin
Left := Bounds.Left;
Top := Bounds.Top;
end;
if (lForm.Position in [poDefault, poDefaultSizeOnly]) and not (csDesigning in lForm.ComponentState) then
begin
Width := CW_USEDEFAULT;
Height := CW_USEDEFAULT;
end
else
begin
Width := Bounds.Right - Bounds.Left;
Height := Bounds.Bottom - Bounds.Top;
end;
//SubClassWndProc := @CustomFormWndProc;
if not (csDesigning in lForm.ComponentState) and lForm.AlphaBlend then
FlagsEx := FlagsEx or WS_EX_LAYERED;
end;
//SetStdBiDiModeParams(AWinControl, Params);
// create window
FinishCreateWindow(AWinControl, Params, False);
Result := Params.Window;
// remove system menu items for bsDialog
if (lForm.BorderStyle = bsDialog) and not (csDesigning in lForm.ComponentState) then
begin
SystemMenu := GetSystemMenu(Result, False);
DeleteMenu(SystemMenu, SC_RESTORE, MF_BYCOMMAND);
DeleteMenu(SystemMenu, SC_SIZE, MF_BYCOMMAND);
DeleteMenu(SystemMenu, SC_MINIMIZE, MF_BYCOMMAND);
DeleteMenu(SystemMenu, SC_MAXIMIZE, MF_BYCOMMAND);
DeleteMenu(SystemMenu, 1, MF_BYPOSITION); // remove the separator between move and close
end;
// Beginning with Windows 2000 the UI in an application may hide focus
// rectangles and accelerator key indication. According to msdn we need to
// initialize all root windows with this message
if WindowsVersion >= wv2000 then
Windows.SendMessage(Result, WM_CHANGEUISTATE,
MakeWParam(UIS_INITIALIZE, UISF_HIDEFOCUS or UISF_HIDEACCEL), 0);
{$ifdef VerboseCDForms}
DebugLn(Format(':<[TCDWSCustomForm.CreateHandle] Result=%x',
[PtrInt(Result)]));
{$endif}
end;
(*var
Params: TCreateWindowExParams;
LForm : TCustomForm;
BorderStyle: TFormBorderStyle;
WR: Windows.RECT;
lWinBounds, lOldLCLBounds, lNewLCLBounds: TRect;
begin
{$ifdef VerboseWinCE}
DebugLn('TWinCEWSCustomForm.CreateHandle');
{$endif}
// general initialization of Params
PrepareCreateWindow(AWinControl, AParams, Params);
// customization of Params
with Params do
begin
// Different from win32
SubClassWndProc := nil; // Otherwise crash in wince, works in win32
BorderStyle := TCustomForm(AWinControl).BorderStyle;
// Same as in win32
lForm := TCustomForm(AWinControl);
CalcFormWindowFlags(lForm, Flags, FlagsEx);
pClassName := @ClsName;
WindowTitle := StrCaption;
// Get the difference between the client and window sizes
lWinBounds := lForm.BoundsRect;
Windows.AdjustWindowRectEx(@lWinBounds, Flags, false, FlagsEx);
if Application.ApplicationType in [atPDA, atKeyPadDevice, atDefault] then
begin
// Gets the work area
Windows.SystemParametersInfo(SPI_GETWORKAREA, 0, @WR, 0);
{ The position and size of common windows is ignored on PDA mode,
and a position and size that covers the whole workarea excluding
the menu is used. The Workarea size automatically excludes the
Taskbar.
Simply using CM_USEDEFAULT produces a too large Height, which
covers the menus. So the workarea size is detected (which ignores
the Taskbar).
In some devices subtracting the menu size seams to work better, but
others, if no menu is present, it's a big problem.
}
if (BorderStyle <> bsDialog) and (BorderStyle <> bsNone) then
begin
Left := WR.Left;
Top := WR.Top;
Height := WR.Bottom - WR.Top;
Width := WR.Right - WR.Left;
// Update the position of the window for the LCL
AWinControl.BoundsRect := Bounds(
Params.Left, Params.Top, Params.Width, Params.Height);
end
else if (BorderStyle = bsDialog) then
{
For dialogs, the window is put in the middle of the screen.
On normal dialogs we need to take into consideration the size of
the window decoration.
For the Top and Left coordinates, using CM_USEDEFAULT produces
a wrong and bad result. Using the Workarea rectagle works fine
for most devices, but not all, so we put the dialog in the center.
}
begin
Top := WR.Top + (WR.Bottom - WR.Top) div 2
- (lWinBounds.Bottom - lWinBounds.Top) div 2;
Left := WR.Left + (WR.Right - WR.Left) div 2
- (lWinBounds.Right - lWinBounds.Left) div 2;
Height := lWinBounds.Bottom - lWinBounds.Top;
Width := lWinBounds.Right - lWinBounds.Left;
// Update the position of the window for the LCL
lOldLCLBounds := lForm.BoundsRect;
lNewLCLBounds.Left := Params.Left - (lWinBounds.Left - lOldLCLBounds.Left);
lNewLCLBounds.Top := Params.Top - (lWinBounds.Top - lOldLCLBounds.Top);
lNewLCLBounds.Right := Params.Left + Params.Width
- (lWinBounds.Right - lOldLCLBounds.Right);
lNewLCLBounds.Bottom := Params.Top + Params.Height
- (lWinBounds.Bottom - lOldLCLBounds.Bottom);
AWinControl.BoundsRect := lNewLCLBounds;
end
else { BorderStyle = bsNone }
{ On borderless Windows we allow the user full control of the
window position
}
begin
CalculateDialogPosition(Params, lWinBounds, lForm);
end;
end
else
begin
{ On Desktop mode we need to take into consideration the size of
the window decoration }
CalculateDialogPosition(Params, lWinBounds, lForm);
end;
end;
// create window
FinishCreateWindow(AWinControl, Params, false);
Result := Params.Window;
{$if defined(VerboseWinCE) or defined(VerboseSizeMsg)}
DebugLn('Window Handle = ' + IntToStr(Result));
{$endif}
end; *)
class procedure TCDWSCustomForm.DestroyHandle(const AWinControl: TWinControl);
begin
end;
class procedure TCDWSCustomForm.SetBorderIcons(const AForm: TCustomForm;
const ABorderIcons: TBorderIcons);
begin
UpdateWindowStyle(AForm.Handle, CalcBorderIconsFlags(AForm),
WS_SYSMENU or WS_MINIMIZEBOX or WS_MAXIMIZEBOX);
end;
class procedure TCDWSCustomForm.SetFormBorderStyle(const AForm: TCustomForm;
const AFormBorderStyle: TFormBorderStyle);
begin
RecreateWnd(AForm);
end;
class procedure TCDWSCustomForm.SetBounds(const AWinControl: TWinControl;
const ALeft, ATop, AWidth, AHeight: Integer);
var
AForm: TCustomForm absolute AWinControl;
CurRect, SizeRect: Windows.RECT;
L, T, W, H: Integer;
begin
{$ifdef VerboseCDForms}
DebugLn(Format('[TCDWSCustomForm.SetBounds] AWinControl=%x'
+ ' ALeft=%d ATop=%d AWidth=%d AHeight=%d',
[PtrInt(AWinControl), ALeft, ATop, AWidth, AHeight]));
{$endif}
// the LCL defines the size of a form without border, win32 with.
// -> adjust size according to BorderStyle
SizeRect := Bounds(ALeft, ATop, AWidth, AHeight);
Windows.AdjustWindowRectEx(@SizeRect, CalcBorderStyleFlags(AForm) or CalcBorderIconsFlags(AForm),
False, CalcBorderStyleFlagsEx(AForm) or CalcBorderIconsFlagsEx(AForm));
L := ALeft;
T := ATop;
W := SizeRect.Right - SizeRect.Left;
H := SizeRect.Bottom - SizeRect.Top;
// we are calling setbounds in TWinControl.Initialize
// if position is default it will be changed to designed. We do not want this.
if wcfInitializing in TWinControlAccess(AWinControl).FWinControlFlags then
begin
if Windows.GetWindowRect(AForm.Handle, CurRect) then
begin
if AForm.Position in [poDefault, poDefaultPosOnly] then
begin
L := CurRect.Left;
T := CurRect.Top;
end;
if AForm.Position in [poDefault, poDefaultSizeOnly] then
begin
W := CurRect.Right - CurRect.Left;
H := CurRect.Bottom - CurRect.Top;
end;
end;
end;
// rect adjusted, pass to inherited to do real work
WSWinControl_SetBounds(AWinControl, L, T, W, H);
end;
(*var
SizeRect: Windows.RECT;
BorderStyle: TFormBorderStyle;
WR: Windows.RECT;
begin
{ User selected LCL window size }
SizeRect.Top := ATop;
SizeRect.Left := ALeft;
SizeRect.Bottom := ATop + AHeight;
SizeRect.Right := ALeft + AWidth;
BorderStyle := TCustomForm(AWinControl).BorderStyle;
{ Verifies if the size should be overriden, acording to the ApplicationType }
if (Application.ApplicationType in [atPDA, atKeyPadDevice, atDefault]) then
begin
{ We should never move forms which are in full-screen mode }
if (BorderStyle <> bsDialog) and (BorderStyle <> bsNone) then Exit;
{ For dialogs, the window is put in the middle of the screen. }
if (BorderStyle = bsDialog) then
begin
Windows.SystemParametersInfo(SPI_GETWORKAREA, 0, @WR, 0);
SizeRect.Top := WR.Top + (WR.Bottom - WR.Top) div 2
- AHeight div 2;
SizeRect.Left := WR.Left + (WR.Right - WR.Left) div 2
- AWidth div 2;
SizeRect.Bottom := SizeRect.Top + AHeight;
SizeRect.Right := SizeRect.Left + AWidth;
end;
{ On borderless Windows we allow the user full control of the window position }
end;
{ the LCL defines the size of a form without border, CDapi with.
-> adjust size according to BorderStyle
Must be done after setting sizeRect }
Windows.AdjustWindowRectEx(@SizeRect, BorderStyleToWinAPIFlags(
BorderStyle), false, BorderStyleToWinAPIFlagsEx(TCustomForm(AWinControl), BorderStyle));
// rect adjusted, pass to inherited to do real work
TCDWSWinControl.SetBounds(AWinControl, SizeRect.Left, SizeRect.Top,
SizeRect.Right - SizeRect.Left, SizeRect.Bottom - SizeRect.Top);
{$IFDEF VerboseSizeMsg}
DebugLn(
Format('[TCDWSCustomForm.SetBounds]: Name:%s Request x:%d y:%d w:%d h:%d'
+ ' SizeRect x:%d y:%d w:%d h:%d',
[AWinControl.Name, ALeft, ATop, AWidth, AHeight,
SizeRect.Left, SizeRect.Top,
SizeRect.Right - SizeRect.Left, SizeRect.Bottom - SizeRect.Top]));
{$ENDIF}
end; *)
class procedure TCDWSCustomForm.SetIcon(const AForm: TCustomForm; const Small, Big: HICON);
begin
if not WSCheckHandleAllocated(AForm, 'SetIcon') then
Exit;
Windows.SendMessage(AForm.Handle, WM_SETICON, ICON_SMALL, LPARAM(Small));
Windows.SendMessage(AForm.Handle, WM_SETICON, ICON_BIG, LPARAM(Big));
end;
class procedure TCDWSCustomForm.SetShowInTaskbar(const AForm: TCustomForm;
const AValue: TShowInTaskbar);
begin
if not WSCheckHandleAllocated(AForm, 'SetShowInTaskbar') then
Exit;
if (Application <> nil) and (AForm = Application.MainForm) then
Exit;
RecreateWnd(AForm);
end;
class procedure TCDWSCustomForm.ShowModal(const ACustomForm: TCustomForm);
begin
Windows.ShowWindow(ACustomForm.Handle, SW_SHOW);
Windows.BringWindowToTop(ACustomForm.Handle);
end;
class procedure TCDWSCustomForm.ShowHide(const AWinControl: TWinControl);
const
VisibilityToFlag: array[Boolean] of UINT = (SWP_HIDEWINDOW, SWP_SHOWWINDOW);
begin
Windows.SetWindowPos(AWinControl.Handle, 0, 0, 0, 0, 0,
SWP_NOSIZE or SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE or VisibilityToFlag[AWinControl.HandleObjectShouldBeVisible])
end;
class function TCDWSCustomForm.GetText(const AWinControl: TWinControl; var AText: String): Boolean;
begin
AText := '';
end;
class function TCDWSCustomForm.GetTextLen(const AWinControl: TWinControl; var ALength: Integer): Boolean;
var
S: String;
begin
Result := GetText(AWinControl, S);
if Result
then ALength := Length(S);
end;
class procedure TCDWSCustomForm.SetText(const AWinControl: TWinControl; const AText: String);
begin
if not WSCheckHandleAllocated(AWincontrol, 'SetText') then Exit;
Windows.SetWindowTextW(AWinControl.Handle, PWideChar(UTF8Decode(AText)));
end;
class function TCDWSCustomForm.GetClientBounds(const AWincontrol: TWinControl; var ARect: TRect): Boolean;
begin
{$ifdef VerboseCDForms}
DebugLn(':>[TCDWSCustomForm.GetClientBounds]');
{$endif}
Result := LCLIntf.GetClientBounds(AWincontrol.Handle, ARect);
{$ifdef VerboseCDForms}
DebugLn(Format(':<[TCDWSCustomForm.GetClientBounds] AWincontrol=%x Rect.left=%d Rect.Top=%d'
+ ' Rect.Width=%d Rect.Height=%d', [PtrInt(AWincontrol), ARect.Top, ARect.Left,
ARect.Right-ARect.Left, ARect.Bottom-ARect.Top]));
{$endif}
end;
class function TCDWSCustomForm.GetClientRect(const AWincontrol: TWinControl; var ARect: TRect): Boolean;
begin
{$ifdef VerboseCDForms}
DebugLn('[TCDWSCustomForm.GetClientRect]');
{$endif}
Result := LCLIntf.GetClientRect(AWincontrol.Handle, ARect);
end;