paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-18 14:29:34 +02:00
Code Issues Packages Projects Releases Wiki Activity

MG: win32 interface patch from Keith Bowes

Browse Source 
git-svn-id: trunk@325 -
This commit is contained in:
lazarus 2001-08-02 12:58:35 +00:00
parent 986ebbd048
commit f1dd977018
14 changed files with 4866 additions and 517 deletions

6
.gitattributes vendored
View File

@ -80,7 +80,10 @@ ide/include/freebsd/lazconf.inc svneol=native#text/pascal
ide/include/linux/lazconf.inc svneol=native#text/pascal
ide/include/win32/lazconf.inc svneol=native#text/pascal
ide/keymapping.pp svneol=native#text/pascal
ide/lazarus.bmp -text svneol=native#image/bmp
ide/lazarus.ico -text svneol=native#image/x-icon
ide/lazarus.pp svneol=native#text/pascal
ide/lazarus.rc svneol=native#text/plain
ide/lazarus_dci.lrs svneol=native#text/pascal
ide/lazconf.pp svneol=native#text/pascal
ide/lazres.pp svneol=native#text/pascal
@ -312,8 +315,11 @@ lcl/interfaces/qt/test/qt.pp svneol=native#text/pascal
lcl/interfaces/qt/test/test.pp svneol=native#text/pascal
lcl/interfaces/win32/interfaces.pp svneol=native#text/pascal
lcl/interfaces/win32/win32callback.inc svneol=native#text/pascal
lcl/interfaces/win32/win32def.pp svneol=native#text/pascal
lcl/interfaces/win32/win32int.pp svneol=native#text/pascal
lcl/interfaces/win32/win32object.inc svneol=native#text/pascal
lcl/interfaces/win32/win32proc.inc svneol=native#text/pascal
lcl/interfaces/win32/winext.pas svneol=native#text/pascal
lcl/lazqueue.pp svneol=native#text/pascal
lcl/lcllinux.pp svneol=native#text/pascal
lcl/lmessages.pp svneol=native#text/pascal

8
Makefile.fpc
View File

@ -49,3 +49,11 @@ tools: lcl components
$(MAKE) -C tools
all: lcl components ide
# Win32-specific rules
win32:
$(MAKE) lazarus.res
$(MAKE) .PHONY LCLPLATFORM=win32 OPT=-dSUPPORTS_RESOURCES
lazarus.res: lazarus.rc
windres -i lazarus.rc -o lazarus.res

BIN
ide/lazarus.bmp Normal file
View File

Binary file not shown.
Side by Side

After

(image error) Size: 3.1 KiB

BIN
ide/lazarus.ico Normal file
View File

Binary file not shown.
Side by Side

After

(image error) Size: 3.2 KiB

7
ide/lazarus.pp
View File

@ -24,6 +24,10 @@ program lazarus;
{$mode objfpc}{$H+}
{$IFDEF SUPPORTS_RESOURCES}
{$R *.res}
{$ENDIF}
uses
Forms,
Splash,
@ -59,6 +63,9 @@ end.
{
$Log$
Revision 1.20 2001/08/02 12:58:35 lazarus
MG: win32 interface patch from Keith Bowes
Revision 1.19 2001/06/04 07:50:42 lazarus
MG: close application object in gtkint.pp

1
ide/lazarus.rc Normal file
View File

@ -0,0 +1 @@
100 ICON "lazarus.ico"

1311
lcl/interfaces/win32/Makefile Normal file
View File

File diff suppressed because it is too large Load Diff

42
lcl/interfaces/win32/Makefile.fpc Normal file
View File

@ -0,0 +1,42 @@
# $Id$
#
# Makefile.fpc for Lazarus for Free Pascal
#
[targets]
units=interfaces
[require]
rtl=1
options=-Or -gl
packages=fcl gtk
[clean]
units=$(notdir $(basename $(wildcard $(UNITTARGETDIR)/*$(PPUEXT))))
# not with the lazarusmake.ini
files=$(wildcard $(UNITTARGETDIR)/*$(OEXT)) $(wildcard $(UNITTARGETDIR)/*$(PPUEXT))
[dirs]
# target dir needs to be . or a full path otherwise the
# unittargetdir will be corrupt
# not with the lazarusmake.ini
# targetdir=.
unittargetdir=../../units/win32
unitdir=$(UNITTARGETDIR) ../../units
incdir=.
[install]
units=$(notdir $(basename $(wildcard $(UNITTARGETDIR)/*$(PPUEXT))))
packagename=win32interface
[libs]
[presettings]
[defaults]
[rules]
all:
$(MAKE) --assume-new=interfaces$(PASEXT) interfaces$(PPUEXT)

867
lcl/interfaces/win32/win32callback.inc
View File

File diff suppressed because it is too large Load Diff

135
lcl/interfaces/win32/win32def.pp Normal file
View File

@ -0,0 +1,135 @@
{ $Id$
------------------------------
gtkdef.pp - Type definitions
------------------------------
@created(Wed Jan 24st WET 2001)
@lastmod($Date$)
@author(Marc Weustink <marc@@lazarus.dommelstein.net>)
This unit contains type definitions needed in the GTK <-> LCL interface
/***************************************************************************
* *
* This program is free software; you can redistribute it and/or modify *
* it under the terms of the GNU General Public License as published by *
* the Free Software Foundation; either version 2 of the License, or *
* (at your option) any later version. *
* *
***************************************************************************/
}
unit win32def;
{$mode objfpc}
{$LONGSTRINGS ON}
interface
uses
Windows, WinExt, LCLLinux, VclGlobals, Classes;
type
TGDIType = (gdiBitmap, gdiBrush, gdiFont, gdiPen, gdiRegion);
TGDIBitmapType = (gbBitmap, gbPixmap, gbImage);
PGDIRGB = ^TGDIRGB;
TGDIRGB = record
Red,
Green,
Blue: Byte;
end;
PGDIRawImage = ^TGDIRawImage;
TGDIRawImage = record
Height,
Width: Integer;
Depth: Byte;
Data: array[0..0] of TGDIRGB;
end;
PGDIObject = ^TGDIObject;
TGDIObject = record
case GDIType: TGDIType of
gdiBitmap: (
GDIBitmapMaskObject: HICON {PGdkPixmap};
case GDIBitmapType: TGDIBitmapType of
gbBitmap: (GDIBitmapObject: HBITMAP {PGdkBitmap});
gbPixmap: (GDIPixmapObject: HICON {PGdkPixmap});
gbImage : (GDIRawImageObject: PGDIRawImage);
);
gdiBrush: (
GDIBrushColor: COLORREF {TGdkColor};
GDIBrushFill: COLORREF {TGdkFill};
GDIBrushPixMap: HICON {PGdkPixmap};
);
gdiFont: (
GDIFontObject: HFONT {PGdkFont};
LogFont: TLogFont; // for now font info is stored as well, later query font params
);
gdiPen: (
GDIPenColor: COLORREF {TGdkColor};
GDIPenWidth: Integer;
GDIPenStyle: Word;
);
gdiRegion: (
);
end;
// move to class ??
PDeviceContext = ^TDeviceContext;
TDeviceContext = record
hWnd: HWND;
GC: HDC {pgdkGC}; // Not sure of Win32 equiv.
Drawable: PHandle {PGDKDrawable}; // Not sure of Win32 equiv.
PenPos: TPoint;
CurrentBitmap: PGdiObject;
CurrentFont: PGdiObject;
CurrentPen: PGdiObject;
CurrentBrush: PGdiObject;
CurrentTextColor: COLORREF {TGdkColor};
CurrentBackColor: COLORREF {TGdkColor};
SavedContext: PDeviceContext; // linked list of saved DCs
end;
// Info needed by the API of a HWND (=Widget)
PWinControlInfo = ^TWinControlInfo;
TWinControlInfo = record
ImplementationWidget: HWND; // used to be "fixed" or "core-child"
UpdateRect: TRect; // used by LM_Paint, beginpaint etc
WndProc: Integer; // window data
Style: Integer;
ExStyle: Integer;
UserData: Integer;
end;
implementation
end.
{ =============================================================================
$Log$
Revision 1.1 2001/08/02 12:58:35 lazarus
MG: win32 interface patch from Keith Bowes
Revision 1.3 2001/03/27 21:12:54 lazarus
MWE:
+ Turned on longstrings
+ modified memotest to add lines
Revision 1.2 2001/01/25 21:38:57 lazarus
MWE:
* fixed lil bug I commetted yesterday (listbox crash)
Revision 1.1 2001/01/24 23:26:40 lazarus
MWE:
= moved some types to gtkdef
+ added WinWidgetInfo
+ added some initialization to Application.Create
}

224
lcl/interfaces/win32/win32int.pp
View File

@ -20,6 +20,7 @@
unit Win32Int;
{$mode objfpc}
{$LONGSTRINGS ON}
interface
@ -27,90 +28,111 @@ interface
{$ASSERTIONS ON}
{$endif}
uses Windows, Strings, sysutils, lmessages, Classes, Controls, dialogs, vclGlobals, forms,
extctrls,InterfaceBase;
uses
Windows, Strings, WinExt, InterfaceBase, sysutils, lmessages,
Classes, Controls, extctrls, forms, dialogs, VclGlobals,
stdctrls, comctrls, LCLLinux, win32def, DynHashArray;
const
csAlignment = 1;
csBox = 2;
csButton = 3;
csComboBox = 4;
csCheckbox = 5;
csEdit = 6;
csForm= 7;
csgLabel = 8;
csgtkTable = 9;
csHScrollBar = 10;
csListView = 11;
csMainForm = 12;
csMemo = 13;
csMenu = 14;
csMenuBar = 15;
csMenuItem = 16;
csNotebook = 17;
csFileDialog = 18;
csRadioButton = 19;
csScrolledWindow= 20;
csSpinedit = 21;
csStatusBar = 22;
csTable = 23;
csToggleBox = 24;
csVScrollBar = 25;
csFrame = 26;
csButtonBox = 27; //Not yet used
csCanvas = 28;
csGroupBox = 29;
csFont = 30;
csPen = 31;
csBrush = 32;
csTimer = 33;
csPage = 34;
csColorDialog = 35;
Var AppName : PChar;
FormClassName : PChar;
Const
ClsName = 'MainWinClass';
Type
TAlignment = Record // New record to create a virtual alignment control
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;
TWin32Object = Class(TInterfaceBase)
private
// function GetFixed(Widget : Pointer) : PgtkFixed;
Function WinRegister: Boolean;
FKeyStateList: TList; // Keeps track of which keys are pressed
FDeviceContexts: TDynHashArray;
FGDIObjects: TDynHashArray;
FMessageQueue: TList;
FToolTipWindow: HWND;
FAccelGroup: HACCEL;
FTimerData : TList; // keeps track of timer evenet structures
{ New fields for the Win32 target }
FMenu: HMENU; // Main menu/menu bar
FSubMenu: HMENU; // current sub menu
FControlIndex: Cardinal; // Win32-API control index.
FParentWindow: HWND; // The parent window
FSender: TObject; // The sender
FMessage: MSG; // The Windows message
FHkProc: HHOOK; // Hooking procedure
FAlignment: TAlignment; // Tracks alignment
{ End of new fields }
FStockNullBrush: HBRUSH;
FStockBlackBrush: HBRUSH;
FStockLtGrayBrush: HBRUSH;
FStockGrayBrush: HBRUSH;
FStockDkGrayBrush: HBRUSH;
FStockWhiteBrush: HBRUSH;
procedure CreateComponent(Sender : TObject);
procedure AddChild(Parent,Child : Pointer; Left,Top: Integer);
procedure ResizeChild(Parent,Child : Pointer; Left,Top,Width,Height : Integer);
procedure ResizeChild(Sender : TObject; Left,Top,Width,Height : Integer);
function GetLabel(CompStyle: Integer; P : Pointer) : String;
procedure AssignSelf(Child ,Data : Pointer);
procedure ReDraw(Child : Pointer);
Procedure SetCursor(Sender : TObject);
function IsValidDC(const DC: HDC): Boolean;
function IsValidGDIObject(const GDIObject: HGDIOBJ): Boolean;
function IsValidGDIObjectType(const GDIObject: HGDIOBJ; const GDIType: TGDIType): Boolean;
function NewGDIObject(const GDIType: TGDIType): PGdiObject;
function NewDC: PDeviceContext;
function CreateDefaultBrush: PGdiObject;
function CreateDefaultFont: PGdiObject;
function CreateDefaultPen: PGdiObject;
procedure ShowHide(Sender : TObject);
procedure AddNBPage(Parent,Child: TObject; Index: Integer);
procedure RemoveNBPage(Parent: TObject; Index: Integer);
procedure SetText(Child,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;
procedure SetName(Child ,Data : Pointer);
procedure ShowHide(CompStyle : Integer; P : Pointer ; visible : boolean);
procedure AddNBPage(Parent,Child: Pointer; Index: Integer);
procedure RemoveNBPage(Parent,Child: Pointer; Index: Integer);
procedure SetText(Child,Data : Pointer);
procedure GetFontinfo(Sender : TObject; Data : Pointer);
procedure DrawFillRect(Child,Data : Pointer);
procedure DrawRect(Child,Data : Pointer);
procedure DrawLine(Child,Data : Pointer);
procedure DrawText(Child,Data : Pointer);
procedure SetColor(Sender : TObject);
protected
public
procedure SetLabel(CompStyle : Integer; Var P : Pointer; Str1 : String);
constructor Create;
destructor Destroy; override;
procedure SetLabel(Sender : TObject; Data : Pointer);
Function GetText(Sender: TControl; Var Data: String): Boolean; Override;
function IntSendMessage3(LM_Message : Integer; Sender : TObject; data : pointer) : integer; override;
procedure SetCallback(Msg : LongInt; Sender : TObject); override;
procedure DoEvents; override;
procedure HandleEvents; override;
procedure AppTerminate; override;
procedure Init; override;
function UpdateHint(Sender: TObject): Integer; override;
function RecreateWnd(Sender: TObject): Integer; override;
Procedure MessageBox(Message, Title: String; Flags: Cardinal);
procedure IntSendMessage(LM_Message : Integer; CompStyle : Integer; Var P : Pointer; Val1 : Integer; Var Str1 : String);
function IntSendMessage2( LM_Message : Integer; Parent,Child, Data : Pointer) : Integer;
function IntSendMessage3(LM_Message : Integer; Sender : TObject; data : pointer) : integer;
procedure SetCallback(Msg : LongInt; Sender : TObject);
procedure RemoveCallbacks(Sender : TControl);
procedure DoEvents;
procedure HandleEvents;
procedure AppTerminate;
procedure Init; override;
end;
wPointer = Pointer;
@ -127,6 +149,32 @@ Type
parent : PWin32Control;
end;
PTabInfo = ^TTabInfo;
TTabInfo = Record
Caption: PChar;
Index: Cardinal;
End;
TWin32KeyType = (WIN32_KEY_PRESS, WIN32_KEY_RELEASE);
PWin32KeyEvent = ^TWin32KeyEvent;
TWin32KeyEvent = Record
KeyVal: Word;
Length: Integer;
Send_Event: Integer;
State: Integer;
TheString: String;
TheType: TWin32KeyType;
Window: HWND;
End;
TWin32ListStringList = Class(TList)
Constructor Create(Wnd: TObject);
Sorted: Boolean;
End;
TWin32CListStringList = Class(TWin32ListStringList)
End;
TEventProc = record
Name : String[25];
CallBack : Procedure(Data : TObject);
@ -134,18 +182,72 @@ Type
End;
CallbackProcedure = Procedure (Data : Pointer);
TCbFunc = Function(Win32Control: PWin32Control; Event: Pointer; Data: Pointer): Boolean;
PCbFunc = ^TCbFunc;
pTRect = ^TRect;
procedure EventTrace(message : string; data : pointer);
procedure EventTrace(message : string; data : pointer);
Implementation
uses Graphics;
uses Graphics, buttons, Menus, CListBox;
Const
IcoExt: String = '.ico';
Var
FromCBProc: Boolean;
LMessage: Integer;
const
KEYMAP_VKUNKNOWN = $10000;
KEYMAP_TOGGLE = $20000;
KEYMAP_EXTENDED = $40000;
type
{ lazarus GtkInterface definition for additional timer data, not in gtk }
PWin32ITimerInfo = ^TWin32ITimerinfo;
TWin32ITimerInfo = record
Handle : hWND;
IDEvent : Integer;
TimerFunc: TFNTimerProc;
end;
Constructor TWin32ListStringList.Create(Wnd: TObject);
Begin
Inherited Create;
End;
{$I win32proc.inc}
{$I win32callback.inc}
{$I win32object.inc}
end.
var
n: Integer;
initialization
{gtk_handler_quark := g_quark_from_static_string('gtk-signal-handlers');
Target_Table[0].Target := 'STRING';
Target_Table[0].Flags := 0;
Target_Table[0].Info := TARGET_STRING;
Target_Table[1].Target := 'text/plain';
Target_Table[1].Flags := 0;
Target_Table[1].Info := TARGET_STRING;
Target_Table[2].Target := 'application/x-rootwin-drop';
Target_Table[2].Flags := 0;
Target_Table[2].Info := TARGET_ROOTWIN;
MCaptureHandle := 0;}
end.

2140
lcl/interfaces/win32/win32object.inc
View File

File diff suppressed because it is too large Load Diff

529
lcl/interfaces/win32/win32proc.inc Normal file
View File

@ -0,0 +1,529 @@
(******************************************************************************
Misc Support Functs
******************************************************************************
used by:
GTKObject
GTKWinAPI
GTKCallback
******************************************************************************)
{$IFOPT C-}
// Uncomment for local trace
// {$C+}
// {$DEFINE ASSERT_IS_ON}
{$ENDIF}
{------------------------------------------------------------------------------
Function: NewGDIRawImage
Params: Width, Height: Size of the image
Depth: Depth of the image
Returns: a GDIRawImage
Creates a RawImage
------------------------------------------------------------------------------}
function NewGDIRawImage(const AWidth, AHeight: Integer; const ADepth: Byte): PGDIRawImage;
begin
Result := AllocMem(SizeOf(TGDIRawImage) + ((AWidth * AHeight) - 1) * SizeOf(TGDIRGB));
with Result^ do
begin
Height := AHeight;
Width := AWidth;
Depth := ADepth;
end;
end;
{------------------------------------------------------------------------------
Function: CopyDCData
Params: DestinationDC: a dc to copy data to
SourceDC: a dc to copy data from
Returns: True if succesfu
Creates a copy DC from the given DC
------------------------------------------------------------------------------}
function CopyDCData(const DestinationDC, SourceDC: PDeviceContext): Boolean;
begin
Assert(False, Format('Trace:> [CopyDCData] DestDC:0x%x, SourceDC:0x%x', [Integer(DestinationDC), Integer(SourceDC)]));
Result := (DestinationDC <> nil) and (SourceDC <> nil);
if Result
then begin
with DestinationDC^ do
begin
hWnd := SourceDC^.hWnd;
Drawable := SourceDC^.Drawable;
if (SourceDC^.GC = HDC(Nil)) or (Drawable = Nil) then
GC := HDC(Nil)
else
begin
end;
PenPos := SourceDC^.PenPos;
CurrentBitmap := SourceDC^.CurrentBitmap;
CurrentFont := SourceDC^.CurrentFont;
CurrentPen := SourceDC^.CurrentPen;
CurrentBrush := SourceDC^.CurrentBrush;
CurrentTextColor := SourceDC^.CurrentTextColor;
CurrentBackColor := SourceDC^.CurrentBackColor;
SavedContext := nil;
end;
end;
Assert(False, Format('Trace:< [CopyDCData] DestDC:0x%x, SourceDC:0x%x --> %d', [Integer(DestinationDC), Integer(SourceDC), Integer(Result)]));
end;
{------------------------------------------------------------------------------
Procedure: SelectGDKBrushProps
Params: DC: a (LCL)devicecontext
Returns: Nothing
Sets the forecolor and fill according to the brush
------------------------------------------------------------------------------}
procedure SelectWin32BrushProps(const DC: HDC);
var
LB: LogBrush;
begin
with LB, PDeviceContext(DC)^, CurrentBrush^ do
begin
Assert(False, 'TODO: Code SelectWin32BrushProps');
//Assert(False, Format('Trace: [SelectGDKBrushProps] Fill: %d | Color --> pixel: %d, red: 0x%x, green: 0x%x, blue: 0x%x', [Integer(GDIBrushFill), GDIBrushColor.Pixel, GDIBrushColor.Red, GDIBrushColor.Green, GDIBrushColor.Blue]));
LBStyle := GDIBrushFill;
LBColor := GDIBrushColor;
SelectObject(GC, CreateBrushIndirect(TagLogBrush(LB)));
SetBkColor(GC, CurrentBackCOlor);
//TODO: Brush pixmap
end;
end;
{------------------------------------------------------------------------------
Procedure: SelectGDKPenProps
Params: DC: a (LCL)devicecontext
Returns: Nothing
Sets the forecolor and fill according to the pen
------------------------------------------------------------------------------}
procedure SelectWin32PenProps(const DC: HDC);
begin
Assert(False, 'TODO: Code SelectWin32PenProps');
end;
{------------------------------------------------------------------------------
Procedure: SelectGDKTextProps
Params: DC: a (LCL)devicecontext
Returns: Nothing
Sets the forecolor and fill according to the Textcolor
------------------------------------------------------------------------------}
procedure SelectWin32TextProps(const DC: HDC);
begin
Assert(False, 'TODO: Code SelectWin32TextProps');
end;
{------------------------------------------------------------------------------
Procedure: GTKEventState2ShiftState
Params: KeyState: The gtk keystate
Returns: the TShiftState for the given KeyState
GTKEventState2ShiftState converts a GTK event state to a LCL/Delphi TShiftState
------------------------------------------------------------------------------}
function GTKEventState2ShiftState(KeyState: Word): TShiftState;
begin
Assert(False, 'TRACE: Using function GTKEventState2ShiftState which isn''t implemented yet');
end;
{------------------------------------------------------------------------------
Procedure: GetGTKKeyInfo
Params: Event: Requested info
KeyCode: the ASCII key code of the eventkey
VirtualKey: the virtual key code of the eventkey
SysKey: True if the key is a syskey
Extended: True if the key is an extended key
Toggle: True if the key is a toggle key and its value is on
Returns: Nothing
GetGTKKeyInfo returns information about the given key event
------------------------------------------------------------------------------}
procedure GetWin32KeyInfo(const Event: PWin32KeyEvent; var KeyCode, VirtualKey: Word; var SysKey, Extended, Toggle: Boolean);
var
TempKeyCode: Word;
CtrlDown: Boolean;
begin
Assert(False, 'TRACE: Using function GetWin32KeyInfo which isn''t implemented yet');
KeyCode := Word(Ord(Integer(Event)));
VirtualKey := MapVirtualKey(KeyCode, 1);
TempKeyCode := KeyCode;
SysKey := SysKey;
CtrlDown := GetAsyncKeyState(VK_CONTROL) <> 0;
Extended := (VirtualKey = VK_LSHIFT) Or (VirtualKey = VK_RSHIFT) Or (VirtualKey = VK_LCONTROL) Or (VirtualKey = VK_RCONTROL) Or (VirtualKey = VK_LMENU) Or (VirtualKey = VK_RMENU);
Toggle := False;
Assert(False, Format('Trace:[GetGTKKeyInfo] Event^.KeyVal %d, Event^.State %d, KeyCode %d, VirtualKey %d, SysKey %d, Extended %d, CtrlDown %d', [Integer(Event^.KeyVal), Integer(Event^.State), Integer(KeyCode), Integer(VirtualKey), Integer(SysKey), Integer(Extended), Integer(CtrlDown)]));
end;
{------------------------------------------------------------------------------
Procedure: DeliverMessage
Params: Message: the message to process
Returns: True if handled
Generic function whih calls the WindowProc if defined, otherwise the
dispatcher
------------------------------------------------------------------------------}
function DeliverMessage(const Target: Pointer; var Message): Integer;
begin
if Target=nil then writeln('[DeliverMessage] nil');
if TObject(Target) is TControl
then begin
TControl(Target).WindowProc(TLMessage(Message));
end else begin
TObject(Target).Dispatch(TLMessage(Message));
end;
Result := TLMessage(Message).Result;
end;
{------------------------------------------------------------------------------
Function: ObjectToGTKObject
Params: AObject: A LCL Object
Returns: The GTKObject of the given object
Returns the GTKObject of the given object, nil if no object available
------------------------------------------------------------------------------}
function ObjectToHWND(const AObject: TObject): HWND;
var
handle : HWND;
begin
if not assigned (AObject) then
begin
assert (false, 'TRACE: [ObjectToGtkObject] Object not assigned');
handle := 0
end
else if (AObject is TWinControl) then
begin
if TWinControl (AObject).HandleAllocated then handle := TWinControl(AObject).Handle
end
else if (AObject is TMenuItem) then
begin
if TMenuItem(AObject).HandleAllocated then handle := TMenuItem(AObject).Handle
end
else if (AObject is TMenu) then
begin
if TMenu(AObject).HandleAllocated then handle := TMenu(AObject).Items.Handle
end
else if (AObject is TCommonDialog) then
begin
{if TCommonDialog(AObject).HandleAllocated then } handle := TCommonDialog(AObject).Handle
end
else begin
Assert(False, Format('Trace: [ObjectToGtkObject] Message received with unhandled class-type <%s>', [AObject.ClassName]));
handle := 0;
end;
result := handle;
if handle = 0 then Assert (false, 'Trace: [ObjectToGtkObject]****** Warning: handle = 0 *******');
end;
(***********************************************************************
Widget member functions
************************************************************************)
// ----------------------------------------------------------------------
// Creates a WinWidget info structure for the given widget
// Info needed by the API of a HWND (=Widget)
//
// This structure obsoletes:
// "core-child", "fixed", "class"
// ----------------------------------------------------------------------
function CreateControlInfo(const Win32Control: PWin32Control): PWinControlInfo;
begin
Assert(False, 'TRACE: Using function CreateControlInfo which isn''t implemented yet');
if Win32Control = nil then
begin
Result := nil;
end
else
begin
New(Result);
FillChar(Result^, SizeOf(Result^), 0);
SetProp(Win32Control^.Window, 'Control_Info', Result);
end;
end;
function GetControlInfo(const Control: PWin32Control; const Create: Boolean): PWinControlInfo;
begin
Assert(False, 'TRACE: Using function GetControlInfo which isn''t implemented yet');
if Control = nil
then begin
Result := nil;
end
else begin
Result := PWinControlInfo(GetProp(Control^.Window, 'Control_Info'));
if (Result = nil) and (Create)
then Result := CreateControlInfo(Control);
end;
end;
// ----------------------------------------------------------------------
// the core_child widget points to the actual widget which implements the
// functionality we needed. It is mainly used in composed controls like
// a listbox. In that case the core_child is the listbox, where a scrolling
// widget is main.
// ----------------------------------------------------------------------
function GetCoreChildControl(const Control: TObject): TObject;
begin
Assert(False, 'TRACE: Using function GetCoreChildControl which isn''t implemented yet');
Result := TObject(GetProp((Control As TWinControl).Handle, 'Core_Child'));
if Result = TObject(nil) then Result := Control;
end;
procedure SetCoreChildControl(const ParentControl, ChildControl: TObject);
begin
Assert(False, 'TRACE: Using function SetCoreChildControl which isn''t implemented yet');
if (ParentControl <> TObject(nil)) and (ChildControl <> TObject(nil)) then
SetProp((ParentControl As TWinControl).Handle, 'Core_Child', @ChildControl);
end;
// ----------------------------------------------------------------------
// the main widget is the widget passed as handle to the winAPI
// main data is stored in the fixed form to get a reference to its parent
// ----------------------------------------------------------------------
function GetMainControl(const Control: HWnd): Handle;
begin
Assert(False, 'TRACE: Using function GetMainControl which isn''t implemented yet');
Result := Handle(GetProp(Control, 'Main'));
if Result = Handle(nil) then Result := Handle(Control);
end;
procedure SetMainControl(const ParentControl, ChildControl: HWnd);
begin
Assert(False, 'TRACE: Using function SetMainControl which isn''t implemented yet');
if (ParentControl <> HWND(nil)) and (ChildControl <> HWND(nil)) then
SetProp(ChildControl, 'Main', Pointer(ParentControl));
end;
// ----------------------------------------------------------------------
// the fixed widget is the container for controls. By default a widget
// scales/places a control. whith the use of a fixed we can place them.
// ----------------------------------------------------------------------
function GetFixedControl(const Control: HWnd): Handle;
begin
Assert(False, 'TRACE: Using function GetFixedControl which isn''t implemented yet');
Result := Integer(GetProp(Control, 'Fixed'));
end;
procedure SetFixedControl(const ParentControl, FixedControl: HWnd);
begin
Assert(False, 'TRACE: Using function SetFixedControl which isn''t implemented yet');
if (ParentControl <> HWND(nil)) and (FixedControl <> HWND(nil)) then
SetProp(ParentControl, 'Fixed', Pointer(FixedControl));
end;
// ----------------------------------------------------------------------
// Some need the LCLobject which created this widget.
//
// MWE: IMO this shouldn't be needed
// ----------------------------------------------------------------------
procedure SetLCLObject(const Control: HWnd; const AnObject: TObject);
begin
Assert(False, 'TRACE: Using function SetLCLObject which isn''t implemented yet');
if (Control <> HWnd(Nil)) then
SetProp(Control, 'Class', @AnObject);
end;
function GetLCLObject(const Control: HWnd): TObject;
begin
Assert(False, 'TRACE: Using function GetLCLObject which isn''t implemented yet');
Result := TObject(GetProp(Control, 'Class'));
end;
// ----------------------------------------------------------------------
// The Accelgroup and AccelKey is needed by menus
// ----------------------------------------------------------------------
procedure SetAccelGroup(const Control: HWnd; const AnAccelGroup: Pointer);
begin
Assert(False, 'TRACE: Using function SetAccelGroup which isn''t implemented yet');
end;
function GetAccelGroup(const Control: Hwnd): HACCEL;
begin
Assert(False, 'TRACE: Using function GetAccelGroup which isn''t implemented yet');
end;
procedure SetAccelKey(const Control: HWnd; const AKey: Integer);
begin
Assert(False, 'TRACE: Using function SetAccelKey which isn''t implemented yet');
if (Control <> Hwnd(Nil)) then
SetProp(Control, 'AccelKey', Pointer(AKey));
end;
function GetAccelKey(const Control: HWnd): Integer;
begin
Assert(False, 'TRACE: Using function GetAccelKey which isn''t implemented yet');
Result := Integer(GetProp(Control, 'AccelKey'));
end;
{$IFDEF ASSERT_IS_ON}
{$UNDEF ASSERT_IS_ON}
{$C-}
{$ENDIF}
{ =============================================================================
$Log$
Revision 1.1 2001/08/02 12:58:35 lazarus
MG: win32 interface patch from Keith Bowes
Revision 1.14 2001/03/21 23:48:29 lazarus
MG: fixed window positions
Revision 1.12 2001/03/19 14:44:22 lazarus
MG: fixed many unreleased DC and GDIObj bugs
Revision 1.10 2001/01/25 21:38:57 lazarus
MWE:
* fixed lil bug I commetted yesterday (listbox crash)
Revision 1.9 2001/01/24 23:26:40 lazarus
MWE:
= moved some types to gtkdef
+ added WinWidgetInfo
+ added some initialization to Application.Create
Revision 1.8 2001/01/23 23:33:55 lazarus
MWE:
- Removed old LM_InvalidateRect
- did some cleanup in old code
+ added some comments on gtkobject data (gtkproc)
Revision 1.7 2001/01/08 21:59:36 lazarus
MWE:
~ applieed patch from Peter Vreman to reflect compiler fix
Revision 1.6 2000/12/19 18:43:13 lazarus
Removed IDEEDITOR. This causes the PROJECT class to not function.
Saving projects no longer works.
I added TSourceNotebook and TSourceEditor. They do all the work for saving/closing/opening units. Somethings work but they are in early development.
Shane
Revision 1.5 2000/10/09 22:50:32 lazarus
MWE:
* fixed some selection code
+ Added selection sample
Revision 1.4 2000/09/10 23:08:31 lazarus
MWE:
+ Added CreateCompatibeleBitamp function
+ Updated TWinControl.WMPaint
+ Added some checks to avoid gtk/gdk errors
- Removed no fixed warning from GetDC
- Removed some output
Revision 1.3 2000/08/10 10:55:45 lazarus
Changed TCustomDialog to TCommonDialog
Shane
Revision 1.2 2000/07/30 21:48:34 lazarus
MWE:
= Moved ObjectToGTKObject to GTKProc unit
* Fixed array checking in LoadPixmap
= Moved LM_SETENABLED to API func EnableWindow and EnableMenuItem
~ Some cleanup
Revision 1.1 2000/07/13 10:28:29 michael
+ Initial import
Revision 1.8 2000/06/29 18:08:56 lazarus
Shane
Looking for the editor problem I made a few changes. I changed everything back to the original though.
Revision 1.7 2000/06/19 18:21:22 lazarus
Spinedit was never getting created
Shane
Revision 1.6 2000/06/14 21:51:27 lazarus
MWE:
+ Added menu accelerators. Not finished
Revision 1.5 2000/05/11 22:04:16 lazarus
MWE:
+ Added messagequeue
* Recoded SendMessage and Peekmessage
+ Added postmessage
+ added DeliverPostMessage
Revision 1.4 2000/05/10 22:52:58 lazarus
MWE:
= Moved some global api stuf to gtkobject
Revision 1.3 2000/05/10 01:45:12 lazarus
Replaced writelns with Asserts.
Put ERROR and WARNING messages back to writelns. CAW
Revision 1.2 2000/05/08 15:56:59 lazarus
MWE:
+ Added support for mwedit92 in Makefiles
* Fixed bug # and #5 (Fillrect)
* Fixed labelsize in ApiWizz
+ Added a call to the resize event in WMWindowPosChanged
Revision 1.1 2000/03/30 22:51:42 lazarus
MWE:
Moved from ../../lcl
Revision 1.11 2000/03/30 21:57:44 lazarus
MWE:
+ Added some general functions to Get/Set the Main/Fixed/CoreChild
widget
+ Started with graphic scalig/depth stuff. This is way from finished
Hans-Joachim Ott <hjott@compuserve.com>:
+ Added some improvements for TMEMO
Revision 1.10 2000/03/19 23:01:43 lazarus
MWE:
= Changed splashscreen loading/colordepth
= Chenged Save/RestoreDC to platform dependent, since they are
relative to a DC
Revision 1.9 2000/03/16 23:58:46 lazarus
MWE:
Added TPixmap for XPM support
Revision 1.8 2000/03/08 23:57:38 lazarus
MWE:
Added SetSysColors
Fixed TEdit text bug (thanks to hans-joachim ott <hjott@compuserve.com>)
Finished GetKeyState
Added changes from Peter Dyson <peter@skel.demon.co.uk>
- a new GetSysColor
- some improvements on ExTextOut
Revision 1.7 2000/03/03 22:58:26 lazarus
MWE:
Fixed focussing problem.
LM-FOCUS was bound to the wrong signal
Added GetKeyState api func.
Now LCL knows if shift/trl/alt is pressed (might be handy for keyboard
selections ;-)
Revision 1.6 2000/01/22 20:07:47 lazarus
Some cleanups. It needs much more cleanup than this.
Worked around a compiler bug (?) in mwCustomEdit.
Reverted some changes to font generation and increased font size.
Revision 1.5 1999/09/17 14:58:54 lazarus
Changes made to editor.pp
Can now press END and some other similiar keys work. Typing works,
but doesn't paint correctly yet.
Revision 1.4 1999/07/31 06:39:30 lazarus
Modified the IntSendMessage3 to include a data variable. It isn't used
yet but will help in merging the Message2 and Message3 features.
Adjusted TColor routines to match Delphi color format
Added a TGdkColorToTColor routine in gtkproc.inc
Finished the TColorDialog added to comDialog example. MAH
}

113
lcl/interfaces/win32/winext.pas Normal file
View File

@ -0,0 +1,113 @@
Unit WinExt;
{ winext.pas: Extra Win32 code that's not in the RTL. }
{ Copyright (C) 2001 Keith Bowes. }
{ This unit is licensed under the GNU LGPL.
See http://www.gnu.org/copyleft/lesser.html for details. }
{$LONGSTRINGS ON}
{$MODE OBJFPC}
{$PACKRECORDS C}
{$SMARTLINK ON}
{$TYPEDADDRESS ON}
Interface
Uses SysUtils, Windows;
{ Types not included in system.pp }
Type
{ Pointer to TObject }
PObject = ^TObject;
{ Win32 API records not included in windows.pp }
Type
{ Record for the @link(GetComboBoxInfo) function }
COMBOBOXINFO = Record
cbSize, stateButton: DWORD;
rcItem, rcButton: RECT;
hwndCombo, hwndItem, hwndList: HWND;
End;
{ Pointer to @link(COMBOBOXINFO) }
PComboBoxInfo = ^COMBOBOXINFO;
{ Win32 API constants not included in windows.pp }
Const
{ Recommended modal-dialog style }
DSC_MODAL = WS_POPUP Or WS_SYSMENU Or WS_CAPTION Or DS_MODALFRAME;
{ Recommended modeless-dialog style }
DSC_MODELESS = WS_POPUP Or WS_CAPTION Or WS_BORDER Or WS_SYSMENU;
{ The windows' direct parent window }
GA_PARENT = 1;
{ The windows' root window }
GA_ROOT = 2;
{ The windows' owner }
GA_ROOTOWNER = 3;
{ Application starting cursor }
IDC_APPSTARTING = 32650;
{ Hand cursor }
IDC_HAND = 32649;
{ Get the progress bar range }
PBM_GETRANGE = 1031;
{ Smooth progrss bar }
PBS_SMOOTH = 1;
{ Vertical progress bar }
PBS_VERTICAL = 4;
{ Left-to-right reading text }
WS_EX_LTRLEADING = 0;
{ Win32 API functions not included in windows.pp }
{ Get the ancestor at level Flag of window HWnd }
Function GetAncestor(Const HWnd: HWND; Const Flag: UINT): HWND; StdCall; External 'user32';
{ Get information about combo box hwndCombo and place in pcbi }
Function GetComboBoxInfo(Const hwndCombo: HWND; pcbi: PCOMBOBOXINFO): BOOL; StdCall; External 'user32';
{ Miscellaneous functions }
{ Convert string Str to a PChar }
Function StrToPChar(Const Str: String): PChar;
Implementation
{$PACKRECORDS NORMAL}
Type
TStrArray = Array[1..2] Of Char;
PStrArray = ^TStrArray;
Var
ArLen: Cardinal;
StrArray: PStrArray;
{ Function StrToPChar: Converts a String to a PChar without using a
buffer.
Parameters:
* Str: String to convert.
Returns: A PChar equivalent of the input string.
}
Function StrToPChar(Const Str: String): PChar;
Var
I: Cardinal;
Begin
StrArray := Nil;
ArLen := SizeOf(Str) * Length(Str);
GetMem(StrArray, ArLen);
For I := 1 To Length(Str) Do
StrArray^[I] := Str[I];
Result := PChar(StrArray);
End;
Initialization
ArLen := 0;
StrArray := Nil;
Finalization
If ArLen <> 0 Then
FreeMem(StrArray, ArLen);
StrArray := Nil;
End.