paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-05-28 06:23:43 +02:00
Code Issues Packages Projects Releases Wiki Activity
dbcda8ed24
lazarus/lcl/interfaces/win32/win32int.pp

269 lines
8.4 KiB
ObjectPascal
Raw Blame History

{
/***************************************************************************
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;
{$H+}
Interface
{$IFDEF Trace}
{$ASSERTIONS ON}
{$ENDIF}
{
When editing this unit list, be sure to keep Windows listed first to ensure
successful compilation.
}
Uses
Windows, Classes, ComCtrls, Controls, Dialogs, DynHashArray, ExtCtrls, Forms,
GraphMath, GraphType, InterfaceBase, LCLLinux, LCLType, LMessages,
StdCtrls, SysUtils, VCLGlobals, Win32Def;
Type
{ Virtual alignment-control record }
TAlignment = Record
Parent: HWnd; // Parent Control
Self: HWnd; // Virtual control handle of alignment
XAlign: Integer; // Horizontal alignment
YAlign: Integer; // Vertical alignment
XScale: Real; // Horizontal scaling
YScale: Real; // Vertical scaling
End;
{ Win32 interface-object class }
TWin32Object = Class(TInterfaceBase)
Private
FKeyStateList: TList; // Keeps track of which keys are pressed
FDeviceContexts: TDynHashArray;
FGDIObjects: TDynHashArray;
FMessageQueue: TList;
FToolTipWindow: HWND;
FTimerWindow: HWND;
FAccelGroup: HACCEL;
FControlIndex: Cardinal; // Win32-API control index
FMainForm: TForm;
FMenu: HMENU; // Main menu/menu bar
FParentWindow: HWND; // The parent window
FSubMenu: HMENU; // current sub menu
FStockNullBrush: HBRUSH;
FStockBlackBrush: HBRUSH;
FStockLtGrayBrush: HBRUSH;
FStockGrayBrush: HBRUSH;
FStockDkGrayBrush: HBRUSH;
FStockWhiteBrush: HBRUSH;
Procedure CreateComponent(Sender: TObject);
Function RecreateWnd(Sender: TObject): Integer; virtual;
Function GetText(Sender: TComponent; var Data: String): Boolean; virtual;
Procedure SetLabel(Sender: TObject; Data: Pointer);
Procedure AddChild(Parent, Child: HWND);
Procedure ResizeChild(Sender: TObject; Left, Top, Width, Height: Integer);
Procedure AssignSelf(Window: HWnd; Data: Pointer);
Procedure ReDraw(Child: TObject);
Procedure SetCursor(Sender: TObject);
Procedure SetLimitText(Window: HWND; Limit: Word);
Procedure ShowHide(Sender: TObject);
Procedure AddNBPage(Parent, Child: TObject; Index: Integer);
Procedure RemoveNBPage(Parent: TObject; Index: Integer);
Procedure SetText(Window: HWND; Data: Pointer);
Procedure SetColor(Sender : TObject);
Procedure SetPixel(Sender: TObject; Data: Pointer);
Procedure GetPixel(Sender: TObject; Data: Pointer);
Function GetValue (Sender: TObject; Data: Pointer): Integer;
Function SetValue (Sender: TObject; Data: Pointer): Integer;
Function SetProperties (Sender: TObject): Integer;
Procedure AttachMenu(Sender: TObject);
Function WinRegister: Boolean;
Function TimerWinRegister: Boolean;
Procedure SetName(Window: HWND; Value: PChar);
Procedure SetOwner(Window: HWND; Owner: TObject);
Procedure PaintPixmap(Surface: TObject; PixmapData: Pointer);
Procedure NormalizeIconName(Var IconName: String);
Procedure NormalizeIconName(Var IconName: PChar);
Procedure CreateCommonDialog(Sender: TCommonDialog);
{ 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;
Public
{ Constructor of the class }
Constructor Create;
{ Destructor of the class }
Destructor Destroy; Override;
{ Initialize the API }
Procedure AppInit; Override;
Function IntSendMessage3(LM_Message: Integer; Sender: TObject; Data: Pointer) : Integer; Override;
Procedure HandleEvents; Override;
Procedure WaitMessage; Override;
Procedure AppTerminate; Override;
function CreateTimer(Interval: integer; TimerFunc: TFNTimerProc) : integer; override;
function DestroyTimer(TimerHandle: integer) : boolean; override;
{$I win32winapih.inc}
End;
{$I win32listslh.inc}
{ Asserts a trace for event named Message in the object Data }
Procedure EventTrace(Message: String; Data: TObject);
Implementation
Uses
Arrow, Buttons, Calendar, CListBox, Graphics, Menus, Process, Spin, WinExt;
{$I win32listsl.inc}
Type
TEventType = (etNotify, etKey, etKeyPress, etMouseWheeel, etMouseUpDown);
{ Linked list of objects for events }
PLazObject = ^TLazObject;
TLazObject = Record
Parent: TObject;
Messages: TList;
Next: PLazObject;
End;
{$IFDEF VER1_1}
TMsgArray = Array Of Integer;
{$ELSE}
TMsgArray = Array[0..1] Of Integer;
{$ENDIF}
Const
BOOL_RESULT: Array[Boolean] Of String = ('False', 'True');
ClsName : array[0..20] of char = 'LazarusForm'#0;
TimerClsName : array[0..20] of char = 'LCLTimerWindow'#0;
Var
WndList: TList;
{$I win32proc.inc}
{$I win32callback.inc}
{$I win32object.inc}
{$I win32winapi.inc}
Initialization
Assert(False, 'Trace:win32int.pp - Initialization');
WndList := TList.Create;
Finalization
Assert(False, 'Trace:win32int.pp - Finalization');
WndList.Free;
WndList := Nil;
End.
{ =============================================================================
$Log$
Revision 1.24 2002/02/09 01:48:23 mattias
renamed TinterfaceObject.Init to AppInit and TWinControls can now contain childs in gtk
Revision 1.23 2002/12/04 20:39:16 mattias
patch from Vincent: clean ups and fixed crash on destroying window
Revision 1.22 2002/12/03 09:15:15 mattias
cleaned up
Revision 1.21 2002/11/26 20:51:05 mattias
applied clipbrd patch from Vincent
Revision 1.20 2002/11/23 13:48:48 mattias
added Timer patch from Vincent Snijders
Revision 1.19 2002/11/15 23:43:54 mattias
applied patch from Karl Brandt
Revision 1.18 2002/10/27 19:59:03 lazarus
AJ: fixed compiling
Revision 1.17 2002/10/26 15:15:55 lazarus
MG: broke LCL<->interface circles
Revision 1.16 2002/08/08 18:05:48 lazarus
MG: added graphics extensions from Andrew Johnson
Revision 1.15 2002/05/31 13:10:49 lazarus
Keith: Code cleanup.
Revision 1.14 2002/05/10 07:43:48 lazarus
MG: updated licenses
Revision 1.13 2002/04/03 03:41:29 lazarus
Keith:
* Removed more obsolete code
* Compiles again!
Revision 1.12 2002/04/03 01:52:42 lazarus
Keith: Removed obsolete code, in preperation of a pending TWin32Object cleanup
Revision 1.11 2002/02/07 08:35:12 lazarus
Keith: Fixed persistent label captions and a few less noticable things
Revision 1.10 2002/02/03 06:06:25 lazarus
Keith: Fixed Win32 compilation problems
Revision 1.9 2002/02/01 10:13:09 lazarus
Keith: Fixes for Win32
Revision 1.8 2002/01/31 09:32:07 lazarus
Keith:
* Open and save dialogs can now coexist in apps (however, only one of each type of common dialog can be used per app :( )
* Fixed make all
* Fixed crash in Windows 98/ME
Revision 1.7 2002/01/25 19:42:56 lazarus
Keith: Improved events and common dialogs on Win32
Revision 1.6 2002/01/17 03:17:44 lazarus
Keith: Fixed TPage creation
Revision 1.5 2002/01/05 13:16:09 lazarus
MG: win32 interface update from Keith Bowes
Revision 1.4 2001/11/01 22:40:13 lazarus
MG: applied Keith Bowes win32 interface updates
Revision 1.3 2001/08/02 12:58:35 lazarus
MG: win32 interface patch from Keith Bowes
Revision 1.2 2000/12/12 14:16:43 lazarus
Updated OI from Mattias
Shane
Revision 1.1 2000/07/13 10:28:29 michael
+ Initial import
}
Reference in New Issue View Git Blame Copy Permalink