mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-07-20 12:25:59 +02:00
869 lines
26 KiB
PHP
869 lines
26 KiB
PHP
{%MainUnit win32int.pp}
|
|
|
|
{
|
|
*****************************************************************************
|
|
This file is part of the Lazarus Component Library (LCL)
|
|
|
|
See the file COPYING.modifiedLGPL.txt, included in this distribution,
|
|
for details about the license.
|
|
*****************************************************************************
|
|
}
|
|
|
|
{$IFOPT C-}
|
|
// Uncomment for local trace
|
|
// {$C+}
|
|
// {$DEFINE ASSERT_IS_ON}
|
|
{$ENDIF}
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TWin32WidgetSet.Create
|
|
Params: None
|
|
Returns: Nothing
|
|
|
|
Constructor for the class.
|
|
------------------------------------------------------------------------------}
|
|
constructor TWin32WidgetSet.Create;
|
|
begin
|
|
FPendingWaitHandlerIndex := -1;
|
|
inherited Create;
|
|
FTimerData := TFpList.Create;
|
|
FMetrics.cbSize := SizeOf(FMetrics);
|
|
FMetricsFailed := not Windows.SystemParametersInfo(SPI_GETNONCLIENTMETRICS,
|
|
SizeOf(FMetrics), @FMetrics, 0);
|
|
if FMetricsFailed then
|
|
begin
|
|
FMetrics.iMenuHeight := GetSystemMetrics(SM_CYMENU);
|
|
FDefaultFont := GetStockObject(DEFAULT_GUI_FONT);
|
|
end
|
|
else
|
|
begin
|
|
FDefaultFont := Windows.CreateFontIndirect(FMetrics.lfMessageFont);
|
|
end;
|
|
OnClipBoardRequest := nil;
|
|
Pointer(InitCommonControlsEx) := GetProcAddress(GetModuleHandle(comctl32), 'InitCommonControlsEx');
|
|
FCommonControlsVersion := GetFileVersion(comctl32);
|
|
FDotsPatternBitmap := 0;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TWin32WidgetSet.Destroy
|
|
Params: None
|
|
Returns: Nothing
|
|
|
|
Destructor for the class.
|
|
------------------------------------------------------------------------------}
|
|
destructor TWin32WidgetSet.Destroy;
|
|
var
|
|
n: integer;
|
|
TimerInfo : PWin32TimerInfo;
|
|
begin
|
|
n := FTimerData.Count;
|
|
if (n > 0) then
|
|
begin
|
|
DebugLn(Format('[TWin32WidgetSet.Destroy] WARNING: There are %d TimerInfo structures left, I''ll free them' ,[n]));
|
|
while (n > 0) do
|
|
begin
|
|
dec(n);
|
|
TimerInfo := PWin32Timerinfo(FTimerData[n]);
|
|
Dispose(TimerInfo);
|
|
FTimerData.Delete(n);
|
|
end;
|
|
end;
|
|
|
|
FTimerData.Free;
|
|
|
|
if FDotsPatternBitmap <> 0 then
|
|
DeleteObject(FDotsPatternBitmap);
|
|
|
|
if FAppHandle <> 0 then
|
|
begin
|
|
{$ifdef RedirectDestroyMessages}
|
|
SetWindowLongPtrW(FAppHandle, GWL_WNDPROC, PtrInt(@DestroyWindowProc));
|
|
{$endif}
|
|
DestroyWindow(FAppHandle);
|
|
end;
|
|
Windows.UnregisterClassW(@ClsNameW, System.HInstance);
|
|
Windows.UnregisterClassW(@ClsHintNameW, System.HInstance);
|
|
if FDefaultFont <> 0 then
|
|
Windows.DeleteObject(FDefaultFont);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TWin32WidgetSet.DCSetAntialiasing(CanvasHandle: HDC; AEnabled: Boolean);
|
|
begin
|
|
if AEnabled then SetStretchBltMode(CanvasHandle, HALFTONE)
|
|
else SetStretchBltMode(CanvasHandle, COLORONCOLOR);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TWin32WidgetSet.AppInit
|
|
Params: None
|
|
Returns: Nothing
|
|
|
|
Initialize Windows
|
|
------------------------------------------------------------------------------}
|
|
procedure TWin32WidgetSet.AppInit(var ScreenInfo: TScreenInfo);
|
|
const
|
|
Win32ClassesToInit: array[0..5] of DWord = (ICC_DATE_CLASSES,
|
|
ICC_UPDOWN_CLASS, ICC_TAB_CLASSES, ICC_PROGRESS_CLASS, ICC_BAR_CLASSES,
|
|
ICC_PAGESCROLLER_CLASS);
|
|
Done: boolean = False;
|
|
var
|
|
ICC: TINITCOMMONCONTROLSEX;
|
|
Handle: HWND;
|
|
DC: HDC;
|
|
AIcon: HICON;
|
|
i: integer;
|
|
begin
|
|
if Done then
|
|
exit;
|
|
Done := True;
|
|
if not WinRegister then
|
|
begin
|
|
DebugLn('Trace:Win32Object.Init - Register Failed');
|
|
Exit;
|
|
end;
|
|
|
|
OleInitialize(nil);
|
|
//TODO: Remove when the WS interface is implemented
|
|
// Common controls only need to be initialized when used
|
|
// So they are initialized in the CreateHandle for common controls
|
|
InitCommonControls;
|
|
if InitCommonControlsEx <> nil then
|
|
begin
|
|
ICC.dwSize := SizeOf(TINITCOMMONCONTROLSEX);
|
|
for i := Low(Win32ClassesToInit) to High(Win32ClassesToInit) do
|
|
begin
|
|
ICC.dwICC := Win32ClassesToInit[i];
|
|
InitCommonControlsEx(@ICC);
|
|
end;
|
|
end;
|
|
|
|
// Create parent of all windows, 'button on taskbar'
|
|
if not IsLibrary then
|
|
begin
|
|
CreateAppHandle;
|
|
// set nice main icon
|
|
AIcon := Windows.LoadIcon(MainInstance, 'MAINICON');
|
|
AppSetIcon(AIcon, AIcon);
|
|
end;
|
|
|
|
// initialize ScreenInfo
|
|
Handle := GetDesktopWindow;
|
|
DC := Windows.GetDC(Handle);
|
|
ScreenInfo.PixelsPerInchX := GetDeviceCaps(DC, LOGPIXELSX);
|
|
ScreenInfo.PixelsPerInchY := GetDeviceCaps(DC, LOGPIXELSY);
|
|
ScreenInfo.ColorDepth := GetDeviceCaps(DC, BITSPIXEL);
|
|
Windows.ReleaseDC(Handle, DC);
|
|
|
|
// Thread.Synchronize support
|
|
WakeMainThread := @HandleWakeMainThread;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TWin32WidgetSet.AppMinimize
|
|
Params: None
|
|
Returns: Nothing
|
|
|
|
Minimizes the whole application to the taskbar
|
|
------------------------------------------------------------------------------}
|
|
procedure TWin32WidgetSet.AppMinimize;
|
|
var
|
|
AForm: TCustomForm;
|
|
i: Integer;
|
|
begin
|
|
FAppMinimizing := True;
|
|
// issue #26463
|
|
if Assigned(Application) and Application.MainFormOnTaskBar
|
|
and Assigned(Application.MainForm) and Application.MainForm.HandleAllocated then
|
|
begin
|
|
HidePopups(Application.MainFormHandle);
|
|
Application.MainForm.WindowState := wsMinimized;
|
|
end
|
|
else
|
|
if Assigned(Application) and (Application.ModalLevel > 0) then
|
|
begin
|
|
for i := Screen.CustomFormZOrderCount - 1 downto 0 do
|
|
begin
|
|
AForm := Screen.CustomFormsZOrdered[i];
|
|
if AForm.HandleAllocated and AForm.Visible and (fsModal in AForm.FormState) then
|
|
ShowWindow(AForm.Handle, SW_SHOWMINIMIZED);
|
|
end;
|
|
ShowWindow(Win32WidgetSet.AppHandle, SW_SHOWMINNOACTIVE);
|
|
end
|
|
else
|
|
Windows.SendMessage(FAppHandle, WM_SYSCOMMAND, SC_MINIMIZE, 0);
|
|
|
|
FAppMinimizing := False;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TWin32WidgetSet.AppRestore
|
|
Params: None
|
|
Returns: Nothing
|
|
|
|
Restore minimized whole application from taskbar
|
|
------------------------------------------------------------------------------}
|
|
procedure TWin32WidgetSet.AppRestore;
|
|
var
|
|
AForm: TCustomForm;
|
|
i: Integer;
|
|
begin
|
|
// issue #26463
|
|
if Assigned(Application) and Application.MainFormOnTaskBar
|
|
and Assigned(Application.MainForm) and Application.MainForm.HandleAllocated then
|
|
begin
|
|
ShowWindow(Application.MainForm.Handle, SW_RESTORE);
|
|
RestorePopups;
|
|
if (Screen.ActiveControl<>nil) and Screen.ActiveControl.HandleAllocated then
|
|
SetFocus(Screen.ActiveControl.Handle);
|
|
end
|
|
else
|
|
if Assigned(Application) and (Application.ModalLevel > 0) then
|
|
begin
|
|
ShowWindow(FAppHandle, SW_RESTORE);
|
|
for i := Screen.CustomFormZOrderCount - 1 downto 0 do
|
|
begin
|
|
AForm := Screen.CustomFormsZOrdered[i];
|
|
if AForm.HandleAllocated and AForm.Visible and (fsModal in AForm.FormState) then
|
|
begin
|
|
ShowWindow(AForm.Handle, SW_RESTORE);
|
|
end;
|
|
end;
|
|
end
|
|
else
|
|
Windows.SendMessage(FAppHandle, WM_SYSCOMMAND, SC_RESTORE, 0);
|
|
end;
|
|
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TWin32WidgetSet.AppBringToFront
|
|
Params: None
|
|
Returns: Nothing
|
|
|
|
Brings the entire application on top of all other non-topmost programs
|
|
------------------------------------------------------------------------------}
|
|
procedure TWin32WidgetSet.AppBringToFront;
|
|
var
|
|
Window: HWND;
|
|
begin
|
|
if Application.MainFormOnTaskBar and (Application.MainFormHandle<>0) then
|
|
Window := GetLastActivePopup(Application.MainFormHandle)
|
|
else
|
|
Window := GetLastActivePopup(AppHandle);
|
|
if not((Window <> 0) and IsWindowVisible(Window) and IsWindowEnabled(Window)) then
|
|
begin
|
|
if Assigned(Screen) and Assigned(Screen.ActiveCustomForm) and Screen.ActiveCustomForm.HandleAllocated then
|
|
Window := Screen.ActiveCustomForm.Handle
|
|
else
|
|
if Assigned(Application) and Application.MainFormOnTaskBar then
|
|
Window := Application.MainFormHandle
|
|
else
|
|
Window := FAppHandle;
|
|
end;
|
|
if (Window <> 0) and IsWindowVisible(Window) and IsWindowEnabled(Window) then
|
|
Windows.SetForegroundWindow(Window);
|
|
end;
|
|
|
|
procedure TWin32WidgetSet.SetDesigning(AComponent: TComponent);
|
|
begin
|
|
//if Data<>nil then EnableWindow((AComponent As TWinControl).Handle, boolean(Data^));
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TWin32WidgetSet.SetCallback
|
|
Params: Msg - message for which to set a callback
|
|
Sender - object to which callback will be sent
|
|
Returns: nothing
|
|
|
|
Applies a Message to the sender
|
|
------------------------------------------------------------------------------}
|
|
procedure TWin32WidgetSet.SetCallback(Msg: LongInt; Sender: TObject);
|
|
var
|
|
Window: HWnd;
|
|
begin
|
|
if Sender is TControlCanvas then
|
|
Window := TControlCanvas(Sender).Handle
|
|
else
|
|
Window := TWinControl(Sender).Handle;
|
|
|
|
if Window = 0 then Exit;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TWin32WidgetSet.RemoveCallbacks
|
|
Params: Sender - object from which to remove callbacks
|
|
Returns: nothing
|
|
|
|
Removes Call Back Signals from the sender
|
|
------------------------------------------------------------------------------}
|
|
procedure TWin32WidgetSet.RemoveCallbacks(Sender: TObject);
|
|
var
|
|
Window: HWnd;
|
|
begin
|
|
if Sender is TControlCanvas then
|
|
Window := TControlCanvas(Sender).Handle
|
|
else
|
|
if Sender is TCustomForm then
|
|
Window := TCustomForm(Sender).Handle
|
|
else
|
|
Window := (Sender as TWinControl).Handle;
|
|
|
|
if Window = 0 then Exit;
|
|
end;
|
|
|
|
function TWin32WidgetSet.InitStockFont(AFont: TObject; AStockFont: TStockFont): Boolean;
|
|
var
|
|
Font: TFont absolute AFont;
|
|
LogFont: TLogFont;
|
|
|
|
procedure AssignDefault;
|
|
var
|
|
LogFont: TLogFont;
|
|
begin
|
|
GetObject(DefaultFont, SizeOf(LogFont), @LogFont);
|
|
Font.Assign(LogFont);
|
|
end;
|
|
|
|
begin
|
|
case AStockFont of
|
|
sfSystem:
|
|
AssignDefault;
|
|
sfHint:
|
|
begin
|
|
if FMetricsFailed then
|
|
AssignDefault
|
|
else
|
|
Font.Assign(FMetrics.lfStatusFont);
|
|
Font.Color := clInfoText;
|
|
end;
|
|
sfIcon:
|
|
begin
|
|
if SystemParametersInfo(SPI_GETICONTITLELOGFONT, SizeOf(LogFont), @LogFont, 0) then
|
|
Font.Assign(LogFont)
|
|
else
|
|
AssignDefault
|
|
end;
|
|
sfMenu:
|
|
begin
|
|
if FMetricsFailed then
|
|
AssignDefault
|
|
else
|
|
Font.Assign(FMetrics.lfMenuFont);
|
|
Font.Color := clMenuText;
|
|
end;
|
|
end;
|
|
Result := True;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TWin32WidgetSet.AppProcessMessages
|
|
Params: None
|
|
Returns: Nothing
|
|
|
|
Handle all pending messages
|
|
------------------------------------------------------------------------------}
|
|
procedure TWin32WidgetSet.AppProcessMessages;
|
|
var
|
|
AMessage: TMsg;
|
|
retVal, index: dword;
|
|
pHandles: Windows.LPHANDLE;
|
|
|
|
procedure CallWaitHandler;
|
|
begin
|
|
FWaitHandlers[index].OnEvent(FWaitHandlers[index].UserData, 0);
|
|
end;
|
|
|
|
begin
|
|
repeat
|
|
if FPendingWaitHandlerIndex >= 0 then
|
|
begin
|
|
index := FPendingWaitHandlerIndex;
|
|
FPendingWaitHandlerIndex := -1;
|
|
CallWaitHandler;
|
|
end;
|
|
{$ifdef DEBUG_ASYNCEVENTS}
|
|
if Length(FWaitHandles) > 0 then
|
|
DebugLn('[ProcessMessages] WaitHandleCount=', IntToStr(FWaitHandleCount),
|
|
', WaitHandle[0]=', IntToHex(FWaitHandles[0], 8));
|
|
{$endif}
|
|
if FWaitHandleCount > 0 then
|
|
pHandles := @FWaitHandles[0]
|
|
else
|
|
pHandles := nil;
|
|
retVal := Windows.MsgWaitForMultipleObjects(FWaitHandleCount,
|
|
pHandles, False, 0, QS_ALLINPUT);
|
|
if (retVal < WAIT_OBJECT_0 + FWaitHandleCount) then
|
|
begin
|
|
index := retVal-WAIT_OBJECT_0;
|
|
CallWaitHandler;
|
|
end else
|
|
if retVal = WAIT_OBJECT_0 + FWaitHandleCount then
|
|
begin
|
|
AMessage := Default(TMsg);
|
|
while PeekMessage(AMessage, HWnd(nil), 0, 0, PM_REMOVE) do
|
|
begin
|
|
if AMessage.message = WM_QUIT then
|
|
begin
|
|
PostQuitMessage(AMessage.wParam);
|
|
break;
|
|
end;
|
|
// Handle MDI form accelerators
|
|
if Assigned(Application) and
|
|
Assigned(Application.MainForm) and
|
|
(Application.MainForm.FormStyle=fsMDIForm) and
|
|
TranslateMDISysAccel(Win32WidgetSet.MDIClientHandle, @AMessage)
|
|
then begin
|
|
// handled by TranslateMDISysAccel
|
|
end else begin
|
|
TranslateMessage(@AMessage);
|
|
DispatchMessageW(@AMessage);
|
|
end;
|
|
end;
|
|
end else
|
|
if retVal = WAIT_TIMEOUT then
|
|
begin
|
|
// check for pending to-be synchronized methods
|
|
CheckSynchronize;
|
|
CheckPipeEvents;
|
|
break;
|
|
end else
|
|
if retVal = $FFFFFFFF then
|
|
begin
|
|
DebugLn('[TWin32WidgetSet.AppProcessMessages] MsgWaitForMultipleObjects returned: ', IntToStr(GetLastError));
|
|
break;
|
|
end;
|
|
until false;
|
|
end;
|
|
|
|
procedure TWin32WidgetSet.CheckPipeEvents;
|
|
var
|
|
lHandler: PPipeEventInfo;
|
|
lBytesAvail: dword;
|
|
SomethingChanged: Boolean;
|
|
ChangedCount:integer;
|
|
begin
|
|
lHandler := FWaitPipeHandlers;
|
|
ChangedCount:=0;
|
|
while (lHandler <> nil) and (ChangedCount<10) do
|
|
begin
|
|
SomethingChanged:=true;
|
|
if Windows.PeekNamedPipe(lHandler^.Handle, nil, 0, nil, @lBytesAvail, nil) then
|
|
begin
|
|
if lBytesAvail <> 0 then
|
|
lHandler^.OnEvent(lHandler^.UserData, [prDataAvailable])
|
|
else
|
|
SomethingChanged := false;
|
|
end else
|
|
lHandler^.OnEvent(lHandler^.UserData, [prBroken]);
|
|
if SomethingChanged then
|
|
lHandler := FWaitPipeHandlers
|
|
else begin
|
|
lHandler := lHandler^.Next;
|
|
ChangedCount := 0;
|
|
end;
|
|
inc(ChangedCount);
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TWin32WidgetSet.AppWaitMessage
|
|
Params: None
|
|
Returns: Nothing
|
|
|
|
Passes execution control to Windows
|
|
------------------------------------------------------------------------------}
|
|
procedure TWin32WidgetSet.AppWaitMessage;
|
|
var
|
|
retVal, timeout: DWord;
|
|
pHandles: Windows.LPHANDLE;
|
|
begin
|
|
RedrawMenus;
|
|
if FWaitPipeHandlers <> nil then
|
|
timeout := 100
|
|
else
|
|
timeout := INFINITE;
|
|
if FWaitHandleCount > 0 then
|
|
pHandles := @FWaitHandles[0]
|
|
else
|
|
pHandles := nil;
|
|
retVal := Windows.MsgWaitForMultipleObjects(FWaitHandleCount, pHandles,
|
|
false, timeout, QS_ALLINPUT);
|
|
if (retVal < WAIT_OBJECT_0 + FWaitHandleCount) then
|
|
FPendingWaitHandlerIndex := retVal - WAIT_OBJECT_0;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TWin32WidgetSet.AppTerminate
|
|
Params: None
|
|
Returns: Nothing
|
|
|
|
Tells Windows to halt and destroy
|
|
------------------------------------------------------------------------------}
|
|
procedure TWin32WidgetSet.AppTerminate;
|
|
begin
|
|
OleUninitialize;
|
|
end;
|
|
|
|
procedure TWin32WidgetSet.AppSetIcon(const Small, Big: HICON);
|
|
begin
|
|
if FAppHandle <> 0 then
|
|
begin
|
|
Windows.SendMessage(FAppHandle, WM_SETICON, ICON_SMALL, LPARAM(Small));
|
|
SetClassLongPtr(FAppHandle, GCL_HICONSM, LONG_PTR(Small));
|
|
|
|
Windows.SendMessage(FAppHandle, WM_SETICON, ICON_BIG, LPARAM(Big));
|
|
SetClassLongPtr(FAppHandle, GCL_HICON, LONG_PTR(Big));
|
|
end;
|
|
end;
|
|
|
|
procedure TWin32WidgetSet.AppSetTitle(const ATitle: string);
|
|
begin
|
|
if FAppHandle <> 0 then
|
|
begin
|
|
Windows.SetWindowTextW(FAppHandle, PWideChar(UTF8ToUTF16(ATitle)));
|
|
end;
|
|
end;
|
|
|
|
procedure TWin32WidgetSet.AppSetVisible(const AVisible: Boolean);
|
|
begin
|
|
if (FAppHandle <> 0) and not (Assigned(Application) and Application.MainFormOnTaskBar) then
|
|
begin
|
|
if AVisible then
|
|
Windows.ShowWindow(FAppHandle, SW_SHOW)
|
|
else
|
|
Windows.ShowWindow(FAppHandle, SW_HIDE);
|
|
end;
|
|
end;
|
|
|
|
function TWin32WidgetSet.AppRemoveStayOnTopFlags(const ASystemTopAlso: Boolean = False): Boolean;
|
|
begin
|
|
if not IsLibrary then
|
|
RemoveStayOnTopFlags(FAppHandle, ASystemTopAlso);
|
|
Result := True;
|
|
end;
|
|
|
|
function TWin32WidgetSet.AppRestoreStayOnTopFlags(const ASystemTopAlso: Boolean = False): Boolean;
|
|
begin
|
|
if not IsLibrary then
|
|
RestoreStayOnTopFlags(FAppHandle);
|
|
Result := True;
|
|
end;
|
|
|
|
procedure TWin32WidgetSet.AppSetMainFormOnTaskBar(const DoSet: Boolean);
|
|
begin
|
|
// 1. Update the visibility of the TaskBar window
|
|
if DoSet then
|
|
ShowWindow(AppHandle, SW_HIDE)
|
|
else
|
|
ShowWindow(AppHandle, SW_SHOW);
|
|
// 2. Recreate the main form - so it will (not) have an own taskbar item and WndParent = 0 (AppHandle)
|
|
if Assigned(Application.MainForm) and Application.MainForm.HandleAllocated then
|
|
RecreateWnd(Application.MainForm);
|
|
end;
|
|
|
|
procedure TWin32WidgetSet.AppSetupMainForm(AMainForm: TObject);
|
|
var
|
|
// AMainForm is guaranteed to be a TCustomForm
|
|
MainForm: TCustomForm absolute AMainForm;
|
|
begin
|
|
//Handle CmdShow parameter when invoked from a shortcut.
|
|
case System.CmdShow of
|
|
SW_SHOWNORMAL: ; //don't alter WindowState
|
|
SW_SHOWMINNOACTIVE,
|
|
SW_SHOWMINIMIZED,
|
|
SW_MINIMIZE: MainForm.WindowState := wsMinimized;
|
|
SW_SHOWMAXIMIZED: MainForm.WindowState := wsMaximized;
|
|
SW_SHOWFULLSCREEN: MainForm.WindowState := wsFullScreen;
|
|
end;
|
|
end;
|
|
|
|
function TWin32WidgetSet.LCLPlatform: TLCLPlatform;
|
|
begin
|
|
Result:= lpWin32;
|
|
end;
|
|
|
|
function TWin32WidgetSet.GetLCLCapability(ACapability: TLCLCapability): PtrUInt;
|
|
begin
|
|
case ACapability of
|
|
lcAsyncProcess: Result := LCL_CAPABILITY_YES;
|
|
lcModalWindow: Result := LCL_CAPABILITY_NO;
|
|
lcDragDockStartOnTitleClick: Result := LCL_CAPABILITY_YES;
|
|
lcApplicationWindow: Result := LCL_CAPABILITY_YES;
|
|
lcLMHelpSupport: Result := LCL_CAPABILITY_YES;
|
|
lcNeedMininimizeAppWithMainForm: Result := LCL_CAPABILITY_NO;
|
|
lcSendsUTF8KeyPress: Result := LCL_CAPABILITY_YES;
|
|
lcTransparentWindow: Result := LCL_CAPABILITY_YES;
|
|
lcAllowChildControlsInNativeControls: Result := LCL_CAPABILITY_YES;
|
|
lcTextHint:
|
|
begin
|
|
if (ComCtlVersion >= ComCtlVersionIE6) then
|
|
Result := LCL_CAPABILITY_YES
|
|
else
|
|
Result := LCL_CAPABILITY_NO;
|
|
end;
|
|
else
|
|
Result := inherited;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function: CreateTimer
|
|
Params: Interval:
|
|
TimerFunc: Callback
|
|
Returns: a Timer id (use this ID to destroy timer)
|
|
|
|
Design: A timer which calls TimerCallBackProc, is created.
|
|
The TimerCallBackProc calls the TimerFunc.
|
|
------------------------------------------------------------------------------}
|
|
function TWin32WidgetSet.CreateTimer(Interval: integer; TimerFunc: TWSTimerProc) : THandle;
|
|
var
|
|
TimerInfo: PWin32TimerInfo;
|
|
begin
|
|
Result := 0;
|
|
if (Interval > 0) and (TimerFunc <> nil) then begin
|
|
New(TimerInfo);
|
|
TimerInfo^.TimerFunc := TimerFunc;
|
|
TimerInfo^.TimerID := Win32Extra.SetTimer(0, 0, Interval, @TimerCallBackProc);
|
|
if TimerInfo^.TimerID=0 then
|
|
dispose(TimerInfo)
|
|
else begin
|
|
FTimerData.Add(TimerInfo);
|
|
Result := TimerInfo^.TimerID;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function: DestroyTimer
|
|
Params: TimerHandle
|
|
Returns:
|
|
------------------------------------------------------------------------------}
|
|
function TWin32WidgetSet.DestroyTimer(TimerHandle: THandle) : boolean;
|
|
var
|
|
n : integer;
|
|
TimerInfo : PWin32Timerinfo;
|
|
begin
|
|
Result:= false;
|
|
n := FTimerData.Count;
|
|
while (n>0) do begin
|
|
dec(n);
|
|
TimerInfo := FTimerData[n];
|
|
if (TimerInfo^.TimerID=UINT_PTR(TimerHandle)) then
|
|
begin
|
|
Result := Boolean(Win32Extra.KillTimer(0, UINT_PTR(TimerHandle)));
|
|
FTimerData.Delete(n);
|
|
Dispose(TimerInfo);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TWin32WidgetSet.HandleWakeMainThread(Sender: TObject);
|
|
begin
|
|
// wake up GUI thread by sending a message to it
|
|
if FAppHandle <> 0 then
|
|
Windows.PostMessage(FAppHandle, WM_NULL, 0, 0);
|
|
end;
|
|
|
|
procedure TWin32WidgetSet.UpdateMDIClientBounds;
|
|
|
|
function CalculateClientArea: TRect;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
Result := Rect(0, 0, 0, 0);
|
|
Windows.GetClientRect(Application.MainFormHandle, Result);
|
|
for I := 0 to Application.MainForm.ControlCount - 1 do
|
|
if Application.MainForm.Controls[I].Visible then
|
|
case Application.MainForm.Controls[I].Align of
|
|
alLeft: Inc(Result.Left, Application.MainForm.Controls[I].Width);
|
|
alTop: Inc(Result.Top, Application.MainForm.Controls[I].Height);
|
|
alRight: Dec(Result.Right, Application.MainForm.Controls[I].Width);
|
|
alBottom: Dec(Result.Bottom, Application.MainForm.Controls[I].Height);
|
|
end;
|
|
end;
|
|
|
|
var
|
|
R: TRect;
|
|
begin
|
|
if not (Assigned(Application.MainForm) and (Application.MainForm.FormStyle=fsMDIForm)) then Exit;
|
|
R := CalculateClientArea;
|
|
MoveWindow(Win32WidgetSet.MDIClientHandle, R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top, True);
|
|
end;
|
|
|
|
{ Private methods (in no significant order) }
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TWin32WidgetSet.WinRegister
|
|
Params: None
|
|
Returns: If the window was successfully registered
|
|
|
|
Registers the main window class
|
|
------------------------------------------------------------------------------}
|
|
function TWin32WidgetSet.WinRegister: Boolean;
|
|
var
|
|
WindowClassW: WndClassW;
|
|
begin
|
|
with WindowClassW do
|
|
begin
|
|
Style := CS_DBLCLKS;
|
|
LPFnWndProc := @WindowProc;
|
|
CbClsExtra := 0;
|
|
CbWndExtra := 0;
|
|
hInstance := System.HInstance;
|
|
hIcon := Windows.LoadIcon(MainInstance, 'MAINICON');
|
|
if hIcon = 0 then
|
|
hIcon := Windows.LoadIcon(0, IDI_APPLICATION);
|
|
hCursor := Windows.LoadCursor(0, IDC_ARROW);
|
|
hbrBackground := 0;
|
|
LPSzMenuName := nil;
|
|
LPSzClassName := @ClsNameW;
|
|
end;
|
|
Result := Windows.RegisterClassW(@WindowClassW) <> 0;
|
|
if Result then
|
|
begin
|
|
with WindowClassW do
|
|
begin
|
|
style := style or CS_SAVEBITS;
|
|
if WindowsVersion >= wvXP then
|
|
style := style or CS_DROPSHADOW;
|
|
hIcon := 0;
|
|
hbrBackground := 0;
|
|
LPSzClassName := @ClsHintNameW;
|
|
end;
|
|
Result := Windows.RegisterClassW(@WindowClassW) <> 0;
|
|
end;
|
|
end;
|
|
|
|
procedure TWin32WidgetSet.CreateAppHandle;
|
|
var
|
|
SysMenu: HMENU;
|
|
begin
|
|
FAppHandle := CreateWindowW(@ClsNameW,
|
|
PWideChar(UTF8ToUTF16(Application.Title)),
|
|
WS_POPUP or WS_CLIPSIBLINGS or WS_SYSMENU or WS_MINIMIZEBOX,
|
|
0, {Windows.GetSystemMetrics(SM_CXSCREEN) div 2,}
|
|
0, {Windows.GetSystemMetrics(SM_CYSCREEN) div 2,}
|
|
0, 0, HWND(nil), HMENU(nil), HInstance, nil);
|
|
AllocWindowInfo(FAppHandle);
|
|
// remove useless menuitems from sysmenu
|
|
SysMenu := Windows.GetSystemMenu(FAppHandle, False);
|
|
Windows.DeleteMenu(SysMenu, SC_MAXIMIZE, MF_BYCOMMAND);
|
|
Windows.DeleteMenu(SysMenu, SC_SIZE, MF_BYCOMMAND);
|
|
Windows.DeleteMenu(SysMenu, SC_MOVE, MF_BYCOMMAND);
|
|
end;
|
|
|
|
function TWin32WidgetSet.GetMDIClientHandle: HWND;
|
|
const
|
|
MDIClientW: array[0..9] of WideChar = ('M', 'D', 'I', 'C', 'L', 'I', 'E', 'N', 'T', #0);
|
|
var
|
|
CCS: TCLIENTCREATESTRUCT;
|
|
begin
|
|
if (FMDIClientHandle=0) and
|
|
Assigned(Application) and
|
|
Assigned(Application.MainForm) and
|
|
(Application.MainForm.FormStyle=fsMDIForm) then
|
|
begin
|
|
CCS.hWindowMenu := 0;
|
|
CCS.idFirstChild := 0;
|
|
FMDIClientHandle := CreateWindowW(@MDIClientW, nil,
|
|
WS_CHILD or WS_CLIPCHILDREN or WS_CLIPSIBLINGS or WS_VSCROLL or WS_HSCROLL,
|
|
0, 0, 0, 0, Application.MainForm.Handle, 0, HInstance, @CCS);
|
|
ShowWindow(FMDIClientHandle, SW_SHOW);
|
|
end;
|
|
Result := FMDIClientHandle;
|
|
end;
|
|
|
|
function TWin32WidgetSet.CreateThemeServices: TThemeServices;
|
|
begin
|
|
Result := TWin32ThemeServices.Create;
|
|
end;
|
|
|
|
function TWin32WidgetSet.GetAppHandle: THandle;
|
|
begin
|
|
Result:= FAppHandle;
|
|
end;
|
|
|
|
procedure TWin32WidgetSet.SetAppHandle(const AValue: THandle);
|
|
begin
|
|
// Do it only if handle is not yet created (for example for DLL initialization)
|
|
FAppHandle := AValue;
|
|
end;
|
|
|
|
function TWin32WidgetSet.GetDotsPatternBitmap: HBitmap;
|
|
const
|
|
Dots: array[0..3] of Word = ($55, $AA, $55, $AA);
|
|
begin
|
|
if FDotsPatternBitmap = 0 then
|
|
FDotsPatternBitmap := CreateBitmap(4, 4, 1, 1, @Dots);
|
|
Result := FDotsPatternBitmap;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TWin32WidgetSet.DCReDraw
|
|
Params: CanvasHandle - HDC to redraw
|
|
Returns: Nothing
|
|
|
|
Redraws (the window of) a canvas
|
|
------------------------------------------------------------------------------}
|
|
procedure TWin32WidgetSet.DCRedraw(CanvasHandle: HDC);
|
|
begin
|
|
// TODO: implement me!
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TWin32WidgetSet.SetPixel
|
|
Params: Canvas - canvas to set color on
|
|
X, Y - position
|
|
AColor - new color for specified position
|
|
Returns: nothing
|
|
|
|
Set the color of the specified pixel on the canvas
|
|
------------------------------------------------------------------------------}
|
|
var
|
|
IntSetPixel : function (DC:HDC; X, Y:longint; cl:Windows.COLORREF):Windows.COLORREF; stdcall = nil;
|
|
IntSendMessage : function(HandleWnd: HWND; Msg: Cardinal; WParam: WParam; LParam: LParam): LResult; stdcall = nil;
|
|
|
|
function VistaSetPixel(DC:HDC; X,Y:longint; cl:Windows.COLORREF):Windows.COLORREF; stdcall;
|
|
var
|
|
pen, oldpen: HPEN;
|
|
p : Windows.TPOINT;
|
|
begin
|
|
if x and $100=0 then
|
|
Result:=Windows.SetPixel(DC,X,Y,cl)
|
|
else
|
|
begin
|
|
pen := Windows.CreatePen(PS_SOLID, 1, ColorToRGB(cl));
|
|
oldpen := Windows.SelectObject(DC, pen);
|
|
Windows.MoveToEx(DC, X, Y, @p);
|
|
Windows.LineTo(DC, X, Y + 1);
|
|
Windows.SelectObject(DC, oldpen);
|
|
Windows.DeleteObject(pen);
|
|
Windows.MoveToEx(DC, P.X, P.Y, nil);
|
|
Result:=cl;
|
|
end;
|
|
end;
|
|
|
|
procedure TWin32WidgetSet.DCSetPixel(CanvasHandle: HDC; X, Y: integer; AColor: TGraphicsColor);
|
|
begin
|
|
IntSetPixel(CanvasHandle, X, Y, ColorToRGB(AColor));
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TWin32WidgetSet.GetPixel
|
|
Params: Canvas - canvas to get color from
|
|
X, Y - position
|
|
Returns: Color at specified point
|
|
|
|
Get the color of the specified pixel on the canvas
|
|
-----------------------------------------------------------------------------}
|
|
function TWin32WidgetSet.DCGetPixel(CanvasHandle: HDC; X, Y: integer): TGraphicsColor;
|
|
begin
|
|
Result := Windows.GetPixel(CanvasHandle, X, Y);
|
|
end;
|
|
|
|
{$IFDEF ASSERT_IS_ON}
|
|
{$UNDEF ASSERT_IS_ON}
|
|
{$C-}
|
|
{$ENDIF}
|