mirror of
https://github.com/ngeor/Chameleon.git
synced 2025-12-19 09:53:43 +01:00
441 lines
12 KiB
ObjectPascal
441 lines
12 KiB
ObjectPascal
unit DfmEngine;
|
|
|
|
{$MODE Delphi}
|
|
|
|
interface
|
|
|
|
uses Windows, Messages, SysUtils, Classes, Forms, Graphics,
|
|
Writers;
|
|
|
|
type
|
|
PEnumParams = ^TEnumParams;
|
|
|
|
TEnumParams = record
|
|
List: TList;
|
|
ParentWnd: HWND;
|
|
end;
|
|
|
|
TKnownControl = (
|
|
kcUnknown, kcButton, kcCheckBox, kcComboBox, kcEdit,
|
|
kcGroupBox, kcImage, kcLabel, kcListBox, kcListView,
|
|
kcPanel, kcRadioButton, kcStatusBar, kcTreeView
|
|
);
|
|
TKnownControls = set of TKnownControl;
|
|
TKnownControlHandlerProc = procedure(wnd: HWND; style: integer) of object;
|
|
|
|
TDfmBuilder = class
|
|
private
|
|
PasList: TStrings;
|
|
dfm1: TDfmWriter;
|
|
Counts: array[TKnownControl] of integer;
|
|
CtlType: TKnownControl;
|
|
procedure DispatchHandle(wnd: HWND; style: integer);
|
|
procedure HandleUnknown(wnd: HWND; style: integer);
|
|
procedure HandleButton(wnd: HWND; style: integer);
|
|
procedure HandleCheckBox(wnd: HWND; style: integer);
|
|
procedure HandleComboBox(wnd: HWND; style: integer);
|
|
procedure HandleEdit(wnd: HWND; style: integer);
|
|
procedure HandleGroupBox(wnd: HWND; style: integer);
|
|
procedure HandleImage(wnd: HWND; style: integer);
|
|
procedure HandleLabel(wnd: HWND; style: integer);
|
|
procedure HandleListBox(wnd: HWND; style: integer);
|
|
procedure HandleListView(wnd: HWND; style: integer);
|
|
procedure HandlePanel(wnd: HWND; style: integer);
|
|
procedure HandleRadioButton(wnd: HWND; style: integer);
|
|
procedure HandleStatusBar(wnd: HWND; style: integer);
|
|
procedure HandleTreeView(wnd: HWND; style: integer);
|
|
procedure PreHandleCtl(wnd: HWND);
|
|
procedure WriteDecl;
|
|
public
|
|
constructor Create(APasList: TStrings);
|
|
procedure Build(OutStream: TStream; const frmName: string; wnd: HWND);
|
|
end;
|
|
|
|
const
|
|
KCNames: array[TKnownControl] of string = (
|
|
'Unknown', 'Button', 'CheckBox', 'ComboBox', 'Edit',
|
|
'GroupBox', 'Image', 'Label', 'ListBox', 'ListView',
|
|
'Panel', 'RadioButton', 'StatusBar', 'TreeView'
|
|
);
|
|
|
|
KCClassNames: array[TKnownControl] of string = (
|
|
'TPanel', 'TButton', 'TCheckBox', 'TComboBox', 'TEdit',
|
|
'TGroupBox', 'TImage', 'TLabel', 'TListBox', 'TListView',
|
|
'TPanel', 'TRadioButton', 'TStatusBar', 'TTreeView'
|
|
);
|
|
|
|
function BitTest(Value, Mask: integer): boolean;
|
|
function GetWndText(wnd: HWND): string;
|
|
function EnumChildrenProc(wnd: HWND; lp: LPARAM): BOOL; stdcall;
|
|
procedure WriteBitmapData(dfm1: TDfmWriter; bmp: HBITMAP; BelongsToPicture: boolean; const Name: string);
|
|
procedure WriteIconData(dfm1: TDfmWriter; icon: HICON; BelongsToPicture: boolean; const Name: string);
|
|
|
|
implementation
|
|
|
|
function BitTest(Value, Mask: integer): boolean;
|
|
begin
|
|
Result := (Value and Mask) = Mask;
|
|
end;
|
|
|
|
function GetWndText(wnd: HWND): string;
|
|
var
|
|
len: integer;
|
|
begin
|
|
len := GetWindowTextLength(wnd);
|
|
SetLength(Result, len);
|
|
GetWindowText(wnd, PChar(Result), len + 1);
|
|
end;
|
|
|
|
function EnumChildrenProc(wnd: HWND; lp: LPARAM): BOOL; stdcall;
|
|
var
|
|
p: PEnumParams;
|
|
begin
|
|
p := PEnumParams(lp);
|
|
if GetParent(wnd) = p^.ParentWnd then
|
|
p^.List.Add(Pointer(wnd));
|
|
Result := True;
|
|
end;
|
|
|
|
function GetBorderIconsStr(ABorderIcons: TBorderIcons): string;
|
|
const
|
|
biStr: array [TBorderIcon] of string = (
|
|
'biSystemMenu', 'biMinimize', 'biMaximize', 'biHelp');
|
|
var
|
|
k: TBorderIcon;
|
|
begin
|
|
if ABorderIcons = [] then
|
|
begin
|
|
Result := '[]';
|
|
Exit;
|
|
end;
|
|
Result := '[';
|
|
for k := biSystemMenu to biHelp do
|
|
if k in ABorderIcons then
|
|
Result := Result + biStr[k] + ',';
|
|
Result[Length(Result)] := ']';
|
|
end;
|
|
|
|
|
|
constructor TDfmBuilder.Create(APasList: TStrings);
|
|
begin
|
|
inherited Create;
|
|
PasList := APasList;
|
|
end;
|
|
|
|
procedure TDfmBuilder.Build(OutStream: TStream; const frmName: string; wnd: HWND);
|
|
var
|
|
InStream: TMemoryStream;
|
|
childlist: TList;
|
|
i: integer;
|
|
style, exstyle: longint;
|
|
wndX: HWND;
|
|
EnumParams: TEnumParams;
|
|
|
|
procedure WriteBorderIcons;
|
|
var
|
|
bi: TBorderIcons;
|
|
s: string;
|
|
begin
|
|
bi := [];
|
|
if BitTest(style, WS_SYSMENU) then
|
|
Include(bi, biSystemMenu);
|
|
if BitTest(style, WS_MINIMIZEBOX) then
|
|
Include(bi, biMinimize);
|
|
if BitTest(style, WS_MAXIMIZEBOX) then
|
|
Include(bi, biMaximize);
|
|
if BitTest(exstyle, WS_EX_CONTEXTHELP) then
|
|
Include(bi, biHelp);
|
|
s := GetBorderIconsStr(bi);
|
|
dfm1.WriteCustomProp('BorderIcons', s);
|
|
end;
|
|
|
|
begin
|
|
// Initialize
|
|
FillChar(Counts, sizeof(Counts), #0);
|
|
InStream := TMemoryStream.Create;
|
|
Dfm1 := TDfmWriter.Create(InStream);
|
|
childlist := TList.Create;
|
|
|
|
dfm1.WriteLn('object ' + frmName + ': T' + frmName);
|
|
exstyle := GetWindowLong(wnd, GWL_EXSTYLE);
|
|
dfm1.Ident := 2;
|
|
dfm1.WritePlacement(wnd, 0);
|
|
WriteBorderIcons;
|
|
dfm1.WriteStringProp('Caption', GetWndText(wnd));
|
|
dfm1.WriteCustomProp('Font.Charset', 'GREEK_CHARSET');
|
|
dfm1.WriteColorProp('Font.Color', clWindowText);
|
|
dfm1.WriteIntProp('Font.Height', -11);
|
|
dfm1.WriteStringProp('Font.Name', 'MS Sans Serif');
|
|
dfm1.WriteCustomProp('Font.Style', '[]');
|
|
WriteIconData(dfm1, SendMessage(wnd, WM_GETICON, 0, 0), False, 'Icon.Data');
|
|
dfm1.WriteIntProp('PixelsPerInch', 96);
|
|
dfm1.WriteIntProp('TextHeight', 13);
|
|
|
|
// write the children
|
|
EnumParams.List := childlist;
|
|
EnumParams.ParentWnd := wnd;
|
|
EnumChildWindows(wnd, @EnumChildrenProc, integer(@EnumParams));
|
|
for i := 0 to childlist.Count - 1 do
|
|
begin
|
|
wndX := HWND(childlist[i]);
|
|
PreHandleCtl(wndX);
|
|
end;
|
|
dfm1.Ident := 0;
|
|
dfm1.WriteLn('end');
|
|
InStream.Position := 0;
|
|
|
|
ObjectTextToResource(InStream, OutStream);
|
|
|
|
// finalization
|
|
childlist.Free;
|
|
DFM1.Free;
|
|
end;
|
|
|
|
procedure TDfmBuilder.HandleUnknown(wnd: HWND; style: integer);
|
|
var
|
|
class_name: array [0..100] of char;
|
|
childlist: TList;
|
|
EnumParams: TEnumParams;
|
|
i: integer;
|
|
begin
|
|
// since we don't know what window we're after write the class name
|
|
GetClassName(wnd, class_name, 100);
|
|
dfm1.WriteStringProp('Caption', class_name);
|
|
childlist := TList.Create;
|
|
EnumParams.List := childlist;
|
|
EnumParams.ParentWnd := wnd;
|
|
EnumChildWindows(wnd, @EnumChildrenProc, integer(@EnumParams));
|
|
for i := 0 to childlist.Count - 1 do
|
|
begin
|
|
PreHandleCtl(HWND(childlist[i]));
|
|
end;
|
|
childlist.Free;
|
|
end;
|
|
|
|
procedure TDfmBuilder.HandleButton(wnd: HWND; style: integer);
|
|
begin
|
|
dfm1.WriteStringProp('Caption', GetWndText(wnd));
|
|
dfm1.WriteBoolProp('Default', BitTest(style, BS_DEFPUSHBUTTON));
|
|
end;
|
|
|
|
procedure TDfmBuilder.HandleCheckBox(wnd: HWND; style: integer);
|
|
const
|
|
CheckedStr: array [0..2] of string = ('cbUnchecked', 'cbChecked', 'cbGrayed');
|
|
var
|
|
state: integer;
|
|
allowgrayed: boolean;
|
|
begin
|
|
allowgrayed := BitTest(style, BS_3STATE) or BitTest(style, BS_AUTO3STATE);
|
|
state := SendMessage(wnd, BM_GETCHECK, 0, 0);
|
|
dfm1.WriteBoolProp('AllowGrayed', allowgrayed);
|
|
dfm1.WriteStringProp('Caption', GetWndText(wnd));
|
|
dfm1.WriteCustomProp('State', CheckedStr[state]);
|
|
end;
|
|
|
|
procedure TDfmBuilder.HandleComboBox(wnd: HWND; style: integer);
|
|
begin
|
|
end;
|
|
|
|
procedure TDfmBuilder.HandleEdit(wnd: HWND; style: integer);
|
|
begin
|
|
dfm1.WriteStringProp('Text', GetWndText(wnd));
|
|
end;
|
|
|
|
procedure TDfmBuilder.HandleGroupBox(wnd: HWND; style: integer);
|
|
begin
|
|
end;
|
|
|
|
procedure TDfmBuilder.HandleImage(wnd: HWND; style: integer);
|
|
var
|
|
h: THANDLE;
|
|
OnlyIcon: boolean;
|
|
begin
|
|
OnlyIcon := BitTest(style, SS_ICON);
|
|
if OnlyIcon then
|
|
begin
|
|
h := SendMessage(wnd, STM_GETICON, 0, 0);
|
|
WriteIconData(dfm1, h, True, 'Picture.Data');
|
|
end
|
|
else
|
|
begin
|
|
h := SendMessage(wnd, STM_GETIMAGE, IMAGE_BITMAP, 0);
|
|
if h <> 0 then
|
|
WriteBitmapData(dfm1, h, True, 'Picture.Data')
|
|
else
|
|
begin
|
|
h := SendMessage(wnd, STM_GETIMAGE, IMAGE_ICON, 0);
|
|
WriteIconData(dfm1, h, True, 'Picture.Data');
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TDfmBuilder.HandleLabel(wnd: HWND; style: integer);
|
|
begin
|
|
dfm1.WriteBoolProp('AutoSize', False);
|
|
dfm1.WriteStringProp('Caption', GetWndText(wnd));
|
|
dfm1.WriteBoolProp('WordWrap', True);
|
|
end;
|
|
|
|
procedure TDfmBuilder.HandleListBox(wnd: HWND; style: integer);
|
|
begin
|
|
end;
|
|
|
|
procedure TDfmBuilder.HandleListView(wnd: HWND; style: integer);
|
|
begin
|
|
end;
|
|
|
|
procedure TDfmBuilder.HandlePanel(wnd: HWND; style: integer);
|
|
begin
|
|
end;
|
|
|
|
procedure TDfmBuilder.HandleRadioButton(wnd: HWND; style: integer);
|
|
begin
|
|
end;
|
|
|
|
procedure TDfmBuilder.HandleStatusBar(wnd: HWND; style: integer);
|
|
begin
|
|
end;
|
|
|
|
procedure TDfmBuilder.HandleTreeView(wnd: HWND; style: integer);
|
|
begin
|
|
end;
|
|
|
|
procedure WriteBitmapData(dfm1: TDfmWriter; bmp: HBITMAP; BelongsToPicture: boolean; const Name: string);
|
|
var
|
|
b: TBitmap;
|
|
Memory: TTextWriter;
|
|
Size, Offset: integer;
|
|
begin
|
|
b := TBitmap.Create;
|
|
Memory := TTextWriter.Create(TMemoryStream.Create);
|
|
try
|
|
b.Handle := CopyImage(bmp, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG);
|
|
|
|
if BelongsToPicture then
|
|
Memory.WriteString('TBitmap');
|
|
size := 0;
|
|
Offset := Memory.Stream.Position;
|
|
Memory.Stream.Write(size, SizeOf(size));
|
|
b.SaveToStream(Memory.Stream);
|
|
Memory.Stream.Position := Offset;
|
|
size := Memory.Stream.Size - sizeof(size) - Offset;
|
|
Memory.Stream.Write(size, SizeOf(size));
|
|
Memory.Stream.Position := 0;
|
|
|
|
dfm1.Write(Name + ' = {');
|
|
dfm1.Ident := dfm1.Ident + 2;
|
|
dfm1.WriteBinaryAsText(Memory.Stream);
|
|
dfm1.Ident := dfm1.Ident - 2;
|
|
dfm1.WriteLn('}');
|
|
finally
|
|
b.Handle := 0;
|
|
b.Free;
|
|
Memory.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure WriteIconData(dfm1: TDfmWriter; icon: HICON; BelongsToPicture: boolean; const Name: string);
|
|
var
|
|
i: TIcon;
|
|
k: TTextWriter;
|
|
begin
|
|
if icon = 0 then
|
|
Exit;
|
|
i := TIcon.Create;
|
|
k := TTextWriter.Create(TMemoryStream.Create);
|
|
try
|
|
i.Handle := CopyIcon(icon);
|
|
if BelongsToPicture then
|
|
k.WriteString('TIcon');
|
|
i.SaveToStream(k.Stream);
|
|
k.Stream.Position := 0;
|
|
|
|
dfm1.Write(Name + ' = {');
|
|
dfm1.Ident := dfm1.Ident + 2;
|
|
dfm1.WriteBinaryAsText(k.Stream);
|
|
dfm1.WriteLn('}');
|
|
dfm1.Ident := dfm1.Ident - 2;
|
|
|
|
finally
|
|
i.Free;
|
|
k.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TDfmBuilder.WriteDecl;
|
|
var
|
|
s: string;
|
|
begin
|
|
Inc(Counts[CtlType]);
|
|
s := KCNames[CtlType] + IntToStr(Counts[CtlType]) + ': ' + KCClassNames[CtlType];
|
|
PasList.Add(s + ';');
|
|
dfm1.WriteLn('object ' + s);
|
|
dfm1.Ident := dfm1.Ident + 2;
|
|
end;
|
|
|
|
procedure TDfmBuilder.DispatchHandle(wnd: HWND; style: integer);
|
|
begin
|
|
case CtlType of
|
|
kcUnknown: HandleUnknown(wnd, style);
|
|
kcButton: HandleButton(wnd, style);
|
|
kcCheckBox: HandleCheckBox(wnd, style);
|
|
kcComboBox: HandleComboBox(wnd, style);
|
|
kcEdit: HandleEdit(wnd, style);
|
|
kcGroupBox: HandleGroupBox(wnd, style);
|
|
kcImage: HandleImage(wnd, style);
|
|
kcLabel: HandleLabel(wnd, style);
|
|
kcListBox: HandleListBox(wnd, style);
|
|
kcListView: HandleListView(wnd, style);
|
|
kcPanel: HandlePanel(wnd, style);
|
|
kcRadioButton: HandleRadioButton(wnd, style);
|
|
kcStatusBar: HandleStatusBar(wnd, style);
|
|
kcTreeView: HandleTreeView(wnd, style);
|
|
end;
|
|
end;
|
|
|
|
procedure TDfmBuilder.PreHandleCtl(wnd: HWND);
|
|
var
|
|
class_name: array [0..100] of char;
|
|
style: integer;
|
|
begin
|
|
GetClassName(wnd, class_name, 100);
|
|
style := GetWindowLong(wnd, GWL_STYLE);
|
|
if StrIComp(class_name, 'Static') = 0 then
|
|
begin
|
|
if BitTest(style, SS_BITMAP) or BitTest(style, SS_ICON) then
|
|
CtlType := kcImage
|
|
else
|
|
CtlType := kcLabel;
|
|
end
|
|
else if StrIComp(class_name, 'Button') = 0 then
|
|
begin
|
|
if BitTest(style, BS_GROUPBOX) then
|
|
CtlType := kcGroupBox
|
|
else if BitTest(style, BS_RADIOBUTTON) or BitTest(style, BS_AUTORADIOBUTTON) then
|
|
CtlType := kcRadioButton
|
|
else if BitTest(style, BS_CHECKBOX) or BitTest(style, BS_AUTOCHECKBOX) or
|
|
BitTest(style, BS_3STATE) or BitTest(style, BS_AUTO3STATE) then
|
|
CtlType := kcCheckBox
|
|
else
|
|
CtlType := kcButton;
|
|
end
|
|
else if StrIComp(class_name, 'ComboBox') = 0 then
|
|
CtlType := kcComboBox
|
|
else if StrIComp(class_name, 'ListBox') = 0 then
|
|
CtlType := kcListBox
|
|
else if StrIComp(class_name, 'Edit') = 0 then
|
|
CtlType := kcEdit
|
|
else if StrIComp(class_name, 'msctls_statusbar32') = 0 then
|
|
CtlType := kcStatusBar
|
|
else
|
|
CtlType := kcUnknown;
|
|
|
|
WriteDecl;
|
|
dfm1.WritePlacement(wnd, GetParent(wnd));
|
|
DispatchHandle(wnd, style);
|
|
dfm1.Ident := dfm1.Ident - 2;
|
|
dfm1.WriteLn('end');
|
|
end;
|
|
|
|
end.
|