mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-06-01 23:12:42 +02:00
68321456bb
- Removed some logs * Changed mainloop to a callback through the interface git-svn-id: trunk@7585 -
278 lines
9.1 KiB
ObjectPascal
278 lines
9.1 KiB
ObjectPascal
{ $Id$ }
|
|
{
|
|
/***************************************************************************
|
|
WIN32INT.pp - Win32Interface Object
|
|
-------------------
|
|
|
|
|
|
|
|
***************************************************************************/
|
|
|
|
*****************************************************************************
|
|
* *
|
|
* This file is part of the Lazarus Component Library (LCL) *
|
|
* *
|
|
* See the file COPYING.LCL, included in this distribution, *
|
|
* for details about the copyright. *
|
|
* *
|
|
* This program is distributed in the hope that it will be useful, *
|
|
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
|
|
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
|
|
* *
|
|
*****************************************************************************
|
|
}
|
|
|
|
Unit Win32Int;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
Interface
|
|
|
|
{$IFDEF Trace}
|
|
{$ASSERTIONS ON}
|
|
{$ENDIF}
|
|
|
|
// defining the following will print all messages as they are being handled
|
|
// valuable for investigation of message trees / interrelations
|
|
{ $define MSG_DEBUG}
|
|
|
|
{
|
|
When editing this unit list, be sure to keep Windows listed first to ensure
|
|
successful compilation.
|
|
}
|
|
Uses
|
|
Windows, Classes, ComCtrls, Controls, Buttons, Dialogs, DynHashArray,
|
|
ExtCtrls, Forms, GraphMath, GraphType, InterfaceBase, LCLIntf, LCLType,
|
|
LMessages, StdCtrls, SysUtils, Win32Def, Graphics, Menus;
|
|
|
|
const
|
|
|
|
IDC_ARROW = MakeIntResource(32512);
|
|
IDC_IBEAM = MakeIntResource(32513);
|
|
IDC_WAIT = MakeIntResource(32514);
|
|
IDC_CROSS = MakeIntResource(32515);
|
|
IDC_UPARROW = MakeIntResource(32516);
|
|
IDC_SIZE = MakeIntResource(32640);
|
|
IDC_ICON = MakeIntResource(32641);
|
|
IDC_SIZENWSE = MakeIntResource(32642);
|
|
IDC_SIZENESW = MakeIntResource(32643);
|
|
IDC_SIZEWE = MakeIntResource(32644);
|
|
IDC_SIZENS = MakeIntResource(32645);
|
|
IDC_SIZEALL = MakeIntResource(32646);
|
|
IDC_NO = MakeIntResource(32648);
|
|
IDC_HAND = MakeIntResource(32649);
|
|
IDC_APPSTARTING = MakeIntResource(32650);
|
|
IDC_HELP = MakeIntResource(32651);
|
|
|
|
{
|
|
These are add-ons, don't exist in windows itself!
|
|
IDC_NODROP = MakeIntResource(32767);
|
|
IDC_DRAG = MakeIntResource(32766);
|
|
IDC_HSPLIT = MakeIntResource(32765);
|
|
IDC_VSPLIT = MakeIntResource(32764);
|
|
IDC_MULTIDRAG = MakeIntResource(32763);
|
|
IDC_SQLWAIT = MakeIntResource(32762);
|
|
IDC_HANDPT = MakeIntResource(32761);
|
|
}
|
|
IDC_NODROP = IDC_NO;
|
|
IDC_DRAG = IDC_ARROW;
|
|
IDC_HSPLIT = IDC_SIZEWE;
|
|
IDC_VSPLIT = IDC_SIZENS;
|
|
IDC_MULTIDRAG = IDC_ARROW;
|
|
IDC_SQLWAIT = IDC_WAIT;
|
|
IDC_HANDPT = IDC_HAND;
|
|
|
|
LclCursorToWin32CursorMap: array[crLow..crHigh] of PChar = (
|
|
// uni-direction cursors are mapped to bidirection win32 cursors
|
|
IDC_SIZENWSE, IDC_SIZENS, IDC_SIZENESW, IDC_SIZEWE, IDC_SIZEWE,
|
|
IDC_SIZENESW, IDC_SIZENS, IDC_SIZENWSE, IDC_SIZEALL, IDC_HANDPT, IDC_HELP,
|
|
IDC_APPSTARTING, IDC_NO, IDC_SQLWAIT, IDC_MULTIDRAG, IDC_VSPLIT,
|
|
IDC_HSPLIT, IDC_NODROP, IDC_DRAG, IDC_WAIT, IDC_UPARROW, IDC_SIZEWE,
|
|
IDC_SIZENWSE, IDC_SIZENS, IDC_SIZENESW, IDC_SIZE, IDC_IBEAM, IDC_CROSS,
|
|
IDC_ARROW, IDC_ARROW, IDC_ARROW);
|
|
|
|
{ month picker, date picker, time picker, updown }
|
|
ICC_DATE_CLASSES = $00000100;
|
|
|
|
Type
|
|
PInitCommonControlsEx = ^TInitCommonControlsEx;
|
|
TInitCommonControlsEx = packed record
|
|
dwSize: dword;
|
|
dwICC: dword;
|
|
end;
|
|
|
|
{ Win32 interface-object class }
|
|
TWin32WidgetSet = Class(TWidgetSet)
|
|
Private
|
|
// The parent of all windows, represents the button of the taskbar
|
|
// This window is also the owner of the clipboard.
|
|
// Assoc. windowproc also acts as handler for popup menus
|
|
FAppHandle: HWND;
|
|
|
|
FMetrics: TNonClientMetrics;
|
|
FMetricsFailed: Boolean;
|
|
|
|
FStockNullBrush: HBRUSH;
|
|
FStockBlackBrush: HBRUSH;
|
|
FStockLtGrayBrush: HBRUSH;
|
|
FStockGrayBrush: HBRUSH;
|
|
FStockDkGrayBrush: HBRUSH;
|
|
FStockWhiteBrush: HBRUSH;
|
|
|
|
FStatusFont: HFONT;
|
|
FMessageFont: HFONT;
|
|
|
|
FThemesActive: boolean;
|
|
FThemeLibrary: HMODULE;
|
|
IsThemeActive: function: LongBool; stdcall;
|
|
IsAppThemed: function: LongBool; stdcall;
|
|
InitCommonControlsEx: function(ICC: PInitCommonControlsEx): LongBool; stdcall;
|
|
|
|
Procedure AssignSelf(Window: HWnd; Data: Pointer);
|
|
|
|
procedure AllocAndCopy(const BitmapInfo: Windows.TBitmap; const BitmapHandle: HBITMAP;
|
|
const SrcRect: TRect; var Data: PByte; var Size: Cardinal);
|
|
procedure FillRawImageDescriptionColors(Desc: PRawImageDescription);
|
|
procedure FillRawImageDescription(const BitmapInfo: Windows.TBitmap;
|
|
Desc: PRawImageDescription);
|
|
|
|
Function WinRegister: Boolean;
|
|
Procedure PaintPixmap(Surface: TObject; PixmapData: Pointer);
|
|
Procedure NormalizeIconName(Var IconName: String);
|
|
Procedure NormalizeIconName(Var IconName: PChar);
|
|
|
|
Public
|
|
{ Creates a callback of Lazarus message Msg for Sender }
|
|
Procedure SetCallback(Msg: LongInt; Sender: TObject); virtual;
|
|
{ Removes all callbacks for Sender }
|
|
Procedure RemoveCallbacks(Sender: TObject); virtual;
|
|
|
|
{ Constructor of the class }
|
|
Constructor Create;
|
|
{ Destructor of the class }
|
|
Destructor Destroy; Override;
|
|
{ Initialize the API }
|
|
procedure AppInit(var ScreenInfo: TScreenInfo); override;
|
|
procedure AppMinimize; override;
|
|
procedure AppBringToFront; override;
|
|
procedure DCSetPixel(CanvasHandle: HDC; X, Y: integer; AColor: TGraphicsColor); override;
|
|
function DCGetPixel(CanvasHandle: HDC; X, Y: integer): TGraphicsColor; override;
|
|
procedure DCRedraw(CanvasHandle: HDC); override;
|
|
procedure SetDesigning(AComponent: TComponent); override;
|
|
procedure AppProcessMessages; override;
|
|
procedure AppWaitMessage; override;
|
|
Procedure AppTerminate; Override;
|
|
procedure ShowHide(Sender: TObject);
|
|
Function InitHintFont(HintFont: TObject): Boolean; Override;
|
|
Procedure AttachMenuToWindow(AMenuObject: TComponent); Override;
|
|
procedure UpdateThemesActive;
|
|
|
|
// create and destroy
|
|
function CreateComponent(Sender : TObject): THandle; override;
|
|
function CreateTimer(Interval: integer; TimerFunc: TFNTimerProc) : integer; override;
|
|
function DestroyTimer(TimerHandle: Integer) : boolean; override;
|
|
|
|
// thread synchronize support
|
|
procedure HandleWakeMainThread(Sender: TObject);
|
|
|
|
{$I win32winapih.inc}
|
|
{$I win32lclintfh.inc}
|
|
|
|
property AppHandle: HWND read FAppHandle;
|
|
property MessageFont: HFONT read FMessageFont;
|
|
property ThemesActive: boolean read FThemesActive;
|
|
End;
|
|
|
|
{$I win32listslh.inc}
|
|
|
|
const
|
|
BOOL_RESULT: Array[Boolean] Of String = ('False', 'True');
|
|
ClsName: array[0..6] of char = 'Window'#0;
|
|
EditClsName: array[0..4] of char = 'Edit'#0;
|
|
ButtonClsName: array[0..6] of char = 'Button'#0;
|
|
ComboboxClsName: array[0..8] of char = 'ComboBox'#0;
|
|
TabControlClsName: array[0..15] of char = 'SysTabControl32'#0;
|
|
|
|
{ export for widgetset implementation }
|
|
|
|
function WindowProc(Window: HWnd; Msg: UInt; WParam: Windows.WParam;
|
|
LParam: Windows.LParam): LResult; stdcall;
|
|
function ComboBoxWindowProc(Window: HWnd; Msg: UInt; WParam: Windows.WParam;
|
|
LParam: Windows.LParam): LResult; stdcall;
|
|
function CallDefaultWindowProc(Window: HWnd; Msg: UInt; WParam: Windows.WParam;
|
|
LParam: Windows.LParam): LResult;
|
|
|
|
Implementation
|
|
|
|
Uses
|
|
Win32Proc,
|
|
////////////////////////////////////////////////////
|
|
// I M P O R T A N T
|
|
////////////////////////////////////////////////////
|
|
// To get as litle as posible circles,
|
|
// uncomment only those units with implementation
|
|
////////////////////////////////////////////////////
|
|
// Win32WSActnList,
|
|
Win32WSArrow,
|
|
Win32WSButtons,
|
|
Win32WSCalendar,
|
|
Win32WSCheckLst,
|
|
// Win32WSCListBox,
|
|
Win32WSComCtrls,
|
|
Win32WSControls,
|
|
// Win32WSDbCtrls,
|
|
// Win32WSDBGrids,
|
|
Win32WSDialogs,
|
|
// Win32WSDirSel,
|
|
// Win32WSEditBtn,
|
|
Win32WSExtCtrls,
|
|
// Win32WSExtDlgs,
|
|
// Win32WSFileCtrl,
|
|
Win32WSForms,
|
|
// Win32WSGrids,
|
|
// Win32WSImgList,
|
|
// Win32WSMaskEdit,
|
|
Win32WSMenus,
|
|
// Win32WSPairSplitter,
|
|
Win32WSSpin,
|
|
Win32WSStdCtrls,
|
|
// Win32WSToolwin,
|
|
////////////////////////////////////////////////////
|
|
Arrow, Calendar, CListBox, Spin, CheckLst, WinExt, LclProc;
|
|
|
|
type
|
|
TMouseDownFocusStatus = (mfNone, mfFocusSense, mfFocusChanged);
|
|
|
|
var
|
|
MouseDownTime: dword;
|
|
MouseDownPos: TPoint;
|
|
MouseDownWindow: HWND;
|
|
MouseDownFocusWindow: HWND;
|
|
MouseDownFocusStatus: TMouseDownFocusStatus;
|
|
OnClipBoardRequest: TClipboardRequestEvent;
|
|
|
|
{$I win32listsl.inc}
|
|
{$I win32callback.inc}
|
|
{$I win32object.inc}
|
|
{$I win32winapi.inc}
|
|
{$I win32lclintf.inc}
|
|
|
|
Initialization
|
|
|
|
Assert(False, 'Trace:win32int.pp - Initialization');
|
|
{$ifdef MSG_DEBUG}
|
|
MessageStackDepth := '';
|
|
{$endif}
|
|
EraseBkgndStack := 0;
|
|
{ initialize mousedownclick to far before double click time }
|
|
MouseDownFocusStatus := mfNone;
|
|
MouseDownTime := GetTickCount - 5000;
|
|
MouseDownWindow := 0;
|
|
|
|
|
|
finalization
|
|
|
|
Assert(False, 'Trace:win32int.pp - Finalization');
|
|
|
|
end.
|