1a8264f100
git-svn-id: https://svn.code.sf.net/p/kolmck/code@104 91bb2d04-0c0c-4d2d-88a5-bbb6f4c1fa07
3463 lines
107 KiB
ObjectPascal
3463 lines
107 KiB
ObjectPascal
{=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
|
|
|
KKKKK KKKKK OOOOOOOOO LLLLL
|
|
KKKKK KKKKK OOOOOOOOOOOOO LLLLL
|
|
KKKKK KKKKK OOOOO OOOOO LLLLL
|
|
KKKKK KKKKK OOOOO OOOOO LLLLL
|
|
KKKKKKKKKK OOOOO OOOOO LLLLL
|
|
KKKKK KKKKK OOOOO OOOOO LLLLL
|
|
KKKKK KKKKK OOOOO OOOOO LLLLL
|
|
KKKKK KKKKK OOOOOOOOOOOOO LLLLLLLLLLLLL kkkkk
|
|
KKKKK KKKKK OOOOOOOOO LLLLLLLLLLLLL kkkkk
|
|
kkkkk
|
|
mmmmm mmmmm mmmmmm cccccccccccc kkkkk kkkkk
|
|
mmmmmmmm mmmmm mmmmm cccccc ccccc kkkkk kkkkk
|
|
mmmmmmmm mmmmm mmmmm cccccc kkkkkkkk
|
|
mmmmm mmmmm mmmmm cccccc ccccc kkkkk kkkkk
|
|
mmmmm mmmmm mmmmm cccccccccccc kkkkk kkkkk
|
|
|
|
Key Objects Library (C) 2000 by Kladov Vladimir.
|
|
KOL Mirror Classes Kit (C) 2000 by Kladov Vladimir.
|
|
}
|
|
unit mckObjs;
|
|
|
|
interface
|
|
|
|
{$I KOLDEF.INC}
|
|
|
|
uses KOL, Classes, Forms, Controls, Dialogs, Windows, Messages, extctrls,
|
|
stdctrls, comctrls, SysUtils, Graphics, mirror, ShellAPI,
|
|
buttons, mckFileFilterEditor,
|
|
//////////////////////////////////////////
|
|
{$IFDEF _D6orHigher} //
|
|
DesignIntf, DesignEditors //
|
|
{$ELSE} //
|
|
//////////////////////////////////////////
|
|
DsgnIntf
|
|
//////////////////////////////////////////
|
|
{$ENDIF} //
|
|
//////////////////////////////////////////
|
|
{$IFNDEF _D2} {$IFNDEF _d3}, imglist {$ENDIF} {$ENDIF},
|
|
TypInfo, menus;
|
|
|
|
type
|
|
//============================================================================
|
|
//---- MIRROR FOR A TIMER ----
|
|
//---- ÇÅÐÊÀËÎ ÄËß ÒÀÉÌÅÐÀ ----
|
|
TKOLTimer = class(TKOLObj)
|
|
private
|
|
FEnabled: Boolean;
|
|
FInterval: Integer;
|
|
FOnTimer: TOnEvent;
|
|
FPeriodic: Boolean;
|
|
FMultimedia: Boolean;
|
|
FResolution: Integer;
|
|
procedure SetEnabled(const Value: Boolean);
|
|
procedure SetInterval(const Value: Integer);
|
|
procedure SetOnTimer(const Value: TOnEvent);
|
|
procedure SetMultimedia(const Value: Boolean);
|
|
procedure SetPeriodic(const Value: Boolean);
|
|
procedure SetResolution(const Value: Integer);
|
|
protected
|
|
procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String );
|
|
override;
|
|
procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String );
|
|
override;
|
|
procedure AssignEvents( SL: TStringList; const AName: String ); override;
|
|
function P_AssignEvents( SL: TStringList; const AName: String; CheckOnly: Boolean ): Boolean; override;
|
|
procedure SetupLast( SL: TStringList; const AName, AParent, Prefix: String );
|
|
override;
|
|
procedure P_SetupLast( SL: TStringList; const AName, AParent, Prefix: String );
|
|
override;
|
|
public
|
|
function TypeName: String; override;
|
|
constructor Create( AOwner: TComponent ); override;
|
|
function Pcode_Generate: Boolean; override;
|
|
procedure P_DoProvideFakeType( SL: TStringList ); override;
|
|
published
|
|
property Interval: Integer read FInterval write SetInterval;
|
|
property Enabled: Boolean read FEnabled write SetEnabled;
|
|
property OnTimer: TOnEvent read FOnTimer write SetOnTimer;
|
|
property Multimedia: Boolean read FMultimedia write SetMultimedia;
|
|
property Resolution: Integer read FResolution write SetResolution;
|
|
property Periodic: Boolean read FPeriodic write SetPeriodic;
|
|
end;
|
|
|
|
//============================================================================
|
|
//---- MIRROR FOR A THREAD ----
|
|
//---- ÇÅÐÊÀËÎ ÄËß ÍÈÒÈ ----
|
|
TPriorityClass = ( pcNormal, pcIdle, pcHigh, pcRealTime );
|
|
TThreadPriority = ( tpNormal, tpBelowNormal, tpLowest, tpIdle, tpAboveNormal,
|
|
tpHighest, tpCritical );
|
|
|
|
TKOLThread = class(TKOLObj)
|
|
private
|
|
FPriorityClass: TPriorityClass;
|
|
FThreadPriority: TThreadPriority;
|
|
FOnExecute: TOnThreadExecute;
|
|
FOnSuspend: TObjectMethod;
|
|
FOnResume: TOnEvent;
|
|
FstartSuspended: Boolean;
|
|
F_AutoFree: Boolean;
|
|
FPriorityBoost: Boolean;
|
|
procedure SetPriorityClass(const Value: TPriorityClass);
|
|
procedure SetThreadPriority(const Value: TThreadPriority);
|
|
procedure SetOnExecute(const Value: TOnThreadExecute);
|
|
procedure SetOnSuspend(const Value: TObjectMethod);
|
|
procedure SetOnResume(const Value: TOnEvent);
|
|
procedure SetstartSuspended(const Value: Boolean);
|
|
procedure SetAutoFree(const Value: Boolean);
|
|
procedure SetPriorityBoost(const Value: Boolean);
|
|
protected
|
|
procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override;
|
|
procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override;
|
|
function NotAutoFree: Boolean; override;
|
|
function BestEventName: String; override;
|
|
public
|
|
procedure AssignEvents( SL: TStringList; const AName: String ); override;
|
|
function P_AssignEvents( SL: TStringList; const AName: String;
|
|
CheckOnly: Boolean ): Boolean; override;
|
|
constructor Create( AOwner: TComponent ); override;
|
|
function Pcode_Generate: Boolean; override;
|
|
published
|
|
property PriorityClass: TPriorityClass read FPriorityClass write SetPriorityClass;
|
|
property ThreadPriority: TThreadPriority read FThreadPriority write SetThreadPriority;
|
|
property OnExecute: TOnThreadExecute read FOnExecute write SetOnExecute;
|
|
property OnSuspend: TObjectMethod read FOnSuspend write SetOnSuspend;
|
|
property OnResume: TOnEvent read FOnResume write SetOnResume;
|
|
property startSuspended: Boolean read FstartSuspended write SetstartSuspended;
|
|
property AutoFree: Boolean read F_AutoFree write SetAutoFree;
|
|
property PriorityBoost: Boolean read FPriorityBoost write SetPriorityBoost;
|
|
end;
|
|
|
|
//============================================================================
|
|
//---- MIRROR FOR AN IMAGELIST ----
|
|
//---- ÇÅÐÊÀËÎ ÄËß ÑÏÈÑÊÀ ÐÈÑÓÍÊÎÂ ----
|
|
TKOLImageList = class(TKOLObj)
|
|
private
|
|
FImgWidth: Integer;
|
|
FImgHeight: Integer;
|
|
FCount: Integer;
|
|
FBitmap: TBitmap;
|
|
FSystemImageList: Boolean;
|
|
FTransparentColor: TColor;
|
|
FColors: TImageListColors;
|
|
FMasked: Boolean;
|
|
FBkColor: TColor;
|
|
FAllowCompression: Boolean;
|
|
FForce32bit: Boolean;
|
|
procedure SetImgHeight(Value: Integer);
|
|
procedure SetImgWidth(Value: Integer);
|
|
procedure SetCount(const Value: Integer);
|
|
procedure SetBitmap(const Value: TBitmap);
|
|
procedure SetSystemImageList(const Value: Boolean);
|
|
function GetBitmap: TBitmap;
|
|
procedure SetTransparentColor(const Value: TColor);
|
|
function GetTransparentColor: TColor;
|
|
procedure SetColors(const Value: TImageListColors);
|
|
procedure SetMasked(const Value: Boolean);
|
|
procedure SetBkColor(const Value: TColor);
|
|
function GetImageListHandle: THandle;
|
|
procedure AssignBitmapToKOLImgList;
|
|
procedure SetAllowCompression(const Value: Boolean);
|
|
procedure SetForce32bit(const Value: Boolean);
|
|
protected
|
|
FKOLImgList: PImageList;
|
|
procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override;
|
|
procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override;
|
|
//procedure BitmapChanged( Sender: TObject );
|
|
public
|
|
function Pcode_Generate: Boolean; override;
|
|
constructor Create( AOwner: TComponent ); override;
|
|
destructor Destroy; override;
|
|
procedure Clear;
|
|
procedure Assign( Value: TPersistent ); override;
|
|
property Handle: THandle read GetImageListHandle;
|
|
published
|
|
property ImgWidth: Integer read FImgWidth write SetImgWidth;
|
|
property ImgHeight: Integer read FImgHeight write SetImgHeight;
|
|
property Count: Integer read FCount write SetCount;
|
|
property bitmap: TBitmap read GetBitmap write SetBitmap;
|
|
property TransparentColor: TColor read GetTransparentColor write SetTransparentColor;
|
|
property systemimagelist: Boolean read FSystemImageList write SetSystemImageList;
|
|
property Colors: TImageListColors read FColors write SetColors;
|
|
property Masked: Boolean read FMasked write SetMasked;
|
|
property BkColor: TColor read FBkColor write SetBkColor;
|
|
property AllowCompression: Boolean read FAllowCompression write SetAllowCompression
|
|
default TRUE;
|
|
property Force32bit: Boolean read FForce32bit write SetForce32bit;
|
|
end;
|
|
|
|
TKOLImageListEditor = class(TComponentEditor)
|
|
private
|
|
protected
|
|
public
|
|
procedure Edit; override;
|
|
procedure ExecuteVerb(Index: Integer); override;
|
|
function GetVerb(Index: Integer): string; override;
|
|
function GetVerbCount: Integer; override;
|
|
end;
|
|
|
|
//----------------------------------------------------------------------------
|
|
//---- MIRROR FOR OPENSAVE FILE DIALOG ----
|
|
//---- ÇÅÐÊÀËÎ ÄËß ÄÈÀËÎÃÀ ÂÛÁÎÐÀ ÔÀÉËÀ ----
|
|
TKOLOpenSaveDialog = class(TKOLObj)
|
|
private
|
|
FOptions: TOpenSaveOptions;
|
|
FInitialDir: String;
|
|
FFilter: String;
|
|
FFilterIndex: Integer;
|
|
FTitle: String;
|
|
FDefExtension: String;
|
|
FOpenDialog: Boolean;
|
|
FTemplateName: String;
|
|
FNoPlaceBar: Boolean;
|
|
procedure SetOptions(const Value: TOpenSaveOptions);
|
|
procedure SetInitialDir(const Value: String);
|
|
procedure SetFilter(const Value: String);
|
|
procedure SetFilterIndex(const Value: Integer);
|
|
procedure SetTitle(const Value: String);
|
|
procedure SetDefExtension(const Value: String);
|
|
procedure SetOpenDialog(const Value: Boolean);
|
|
procedure SetTemplateName(const Value: String);
|
|
procedure SetNoPlaceBar(const Value: Boolean);
|
|
protected
|
|
procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override;
|
|
procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override;
|
|
procedure SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); override;
|
|
procedure P_SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); override;
|
|
public
|
|
constructor Create( AOwner: TComponent ); override;
|
|
function Pcode_Generate: Boolean; override;
|
|
published
|
|
property Options: TOpenSaveOptions read FOptions write SetOptions;
|
|
property NoPlaceBar: Boolean read FNoPlaceBar write SetNoPlaceBar;
|
|
property Title: String read FTitle write SetTitle;
|
|
property TemplateName: String read FTemplateName write SetTemplateName;
|
|
property InitialDir: String read FInitialDir write SetInitialDir;
|
|
property Filter: String read FFilter write SetFilter;
|
|
property FilterIndex: Integer read FFilterIndex write SetFilterIndex;
|
|
property DefExtension: String read FDefExtension write SetDefExtension;
|
|
property OpenDialog: Boolean read FOpenDialog write SetOpenDialog;
|
|
property Localizy;
|
|
end;
|
|
|
|
TKOLFileFilter = class( TStringProperty )
|
|
private
|
|
protected
|
|
public
|
|
function GetAttributes: TPropertyAttributes; override;
|
|
procedure Edit; override;
|
|
end;
|
|
|
|
//----------------------------------------------------------------------------
|
|
//---- MIRROR FOR OPENDIR DIALOG ----
|
|
//---- ÇÅÐÊÀËÎ ÄËß ÄÈÀËÎÃÀ ÂÛÁÎÐÀ ÄÈÐÅÊÒÎÐÈß ----
|
|
TKOLOpenDirDialog = class( TKOLObj )
|
|
private
|
|
FTitle: String;
|
|
FOptions: TOpenDirOptions;
|
|
FInitialPath: String;
|
|
FCenterOnScreen: Boolean;
|
|
FOnSelChanged: TOnODSelChange;
|
|
FAltDialog: Boolean;
|
|
procedure SetTitle(const Value: String);
|
|
procedure SetOptions(const Value: TOpenDirOptions);
|
|
procedure SetInitialPath(const Value: String);
|
|
procedure SetCenterOnScreen(const Value: Boolean);
|
|
procedure SetOnSelChanged(const Value: TOnODSelChange);
|
|
procedure SetAltDialog(const Value: Boolean);
|
|
protected
|
|
procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override;
|
|
procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override;
|
|
procedure SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); override;
|
|
procedure P_SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); override;
|
|
public
|
|
procedure AssignEvents( SL: TStringList; const AName: String ); override;
|
|
function P_AssignEvents( SL: TStringList; const AName: String;
|
|
CheckOnly: Boolean ): Boolean; override;
|
|
constructor Create( AOwner: TComponent ); override;
|
|
function TypeName: String; override;
|
|
function Pcode_Generate: Boolean; override;
|
|
function AdditionalUnits: String; override;
|
|
published
|
|
property Title: String read FTitle write SetTitle;
|
|
property Options: TOpenDirOptions read FOptions write SetOptions;
|
|
property InitialPath: String read FInitialPath write SetInitialPath;
|
|
property CenterOnScreen: Boolean read FCenterOnScreen write SetCenterOnScreen;
|
|
property OnSelChanged: TOnODSelChange read FOnSelChanged write SetOnSelChanged;
|
|
property Localizy;
|
|
property AltDialog: Boolean read FAltDialog write SetAltDialog;
|
|
end;
|
|
|
|
|
|
//----------------------------------------------------------------------------
|
|
//---- MIRROR FOR COLOR CHOOSING DIALOG ----
|
|
//---- ÇÅÐÊÀËÎ ÄËß ÄÈÀËÎÃÀ ÂÛÁÎÐÀ ÖÂÅÒÀ ----
|
|
TKOLColorDialog = class( TKOLObj )
|
|
private
|
|
FColorCustomOption: TColorCustomOption;
|
|
FCustomColors: array[ 1..16 ] of TColor;
|
|
procedure SetColorCustomOption(const Value: TColorCustomOption);
|
|
function GetCustomColor( const Index: Integer ): TColor;
|
|
procedure SetCustomColor(const Index: Integer; const Value: TColor);
|
|
protected
|
|
procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override;
|
|
procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override;
|
|
public
|
|
constructor Create( AOwner: TComponent ); override;
|
|
function Pcode_Generate: Boolean; override;
|
|
published
|
|
property ColorCustomOption: TColorCustomOption read FColorCustomOption write SetColorCustomOption;
|
|
property CustomColor1: TColor index 1 read GetCustomColor write SetCustomColor;
|
|
property CustomColor2: TColor index 2 read GetCustomColor write SetCustomColor;
|
|
property CustomColor3: TColor index 3 read GetCustomColor write SetCustomColor;
|
|
property CustomColor4: TColor index 4 read GetCustomColor write SetCustomColor;
|
|
property CustomColor5: TColor index 5 read GetCustomColor write SetCustomColor;
|
|
property CustomColor6: TColor index 6 read GetCustomColor write SetCustomColor;
|
|
property CustomColor7: TColor index 7 read GetCustomColor write SetCustomColor;
|
|
property CustomColor8: TColor index 8 read GetCustomColor write SetCustomColor;
|
|
property CustomColor9: TColor index 9 read GetCustomColor write SetCustomColor;
|
|
property CustomColor10: TColor index 10 read GetCustomColor write SetCustomColor;
|
|
property CustomColor11: TColor index 11 read GetCustomColor write SetCustomColor;
|
|
property CustomColor12: TColor index 12 read GetCustomColor write SetCustomColor;
|
|
property CustomColor13: TColor index 13 read GetCustomColor write SetCustomColor;
|
|
property CustomColor14: TColor index 14 read GetCustomColor write SetCustomColor;
|
|
property CustomColor15: TColor index 15 read GetCustomColor write SetCustomColor;
|
|
property CustomColor16: TColor index 16 read GetCustomColor write SetCustomColor;
|
|
end;
|
|
|
|
//----------------------------------------------------------------------------
|
|
//---- MIRROR FOR TRAY ICON ----
|
|
//---- ÇÅÐÊÀËÎ ÄËß ÈÊÎÍÊÈ Â ÒÐÅÅ ----
|
|
TKOLTrayIcon = class( TKOLObj )
|
|
private
|
|
FIcon: TIcon;
|
|
FActive: Boolean;
|
|
FTooltip: String;
|
|
FAutoRecreate: Boolean;
|
|
FOnMouse: TOnTrayIconMouse;
|
|
FNoAutoDeactivate: Boolean;
|
|
procedure SetIcon(const Value: TIcon);
|
|
procedure SetActive(const Value: Boolean);
|
|
procedure SetTooltip(const Value: String);
|
|
procedure SetAutoRecreate(const Value: Boolean);
|
|
procedure SetOnMouse(const Value: TOnTrayIconMouse);
|
|
procedure SetNoAutoDeactivate(const Value: Boolean);
|
|
protected
|
|
procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override;
|
|
procedure P_SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override;
|
|
procedure SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); override;
|
|
procedure P_SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); override;
|
|
procedure AssignEvents( SL: TStringList; const AName: String ); override;
|
|
function P_AssignEvents( SL: TStringList; const AName: String; CheckOnly: Boolean ): Boolean; override;
|
|
public
|
|
function Pcode_Generate: Boolean; override;
|
|
constructor Create( AOwner: TComponent ); override;
|
|
destructor Destroy; override;
|
|
published
|
|
property Icon: TIcon read FIcon write SetIcon;
|
|
property Active: Boolean read FActive write SetActive;
|
|
property NoAutoDeactivate: Boolean read FNoAutoDeactivate write SetNoAutoDeactivate;
|
|
property Tooltip: String read FTooltip write SetTooltip;
|
|
property AutoRecreate: Boolean read FAutoRecreate write SetAutoRecreate;
|
|
property OnMouse: TOnTrayIconMouse read FOnMouse write SetOnMouse;
|
|
property Localizy;
|
|
end;
|
|
|
|
|
|
type KOLTPixelFormat = KOL.TPixelFormat;
|
|
|
|
|
|
|
|
function CountSystemColorsUsedInBitmap( Bmp: KOL.PBitmap; ColorList: KOL.PList ): KOLTPixelFormat;
|
|
//function SaveBitmap( Bitmap: TBitmap; const Path: String ): Boolean;
|
|
procedure GenerateBitmapResource( Bitmap: TBitmap; const RsrcName, FileName: String;
|
|
var Updated: Boolean; AllowCompression: Boolean );
|
|
procedure GenerateIconResource( Icon: TIcon; const RsrcName, FileName: KOLString;
|
|
var Updated: Boolean );
|
|
procedure RemoveSelection( FD: IFormDesigner );
|
|
function String2Pascal( S: String; const Concatenator: String ): String;
|
|
function P_String2Pascal( S: String ): String;
|
|
//function GetBmpPixel( Bitmap: TBitmap; X, Y: Integer ): TColor;
|
|
|
|
procedure Register;
|
|
|
|
implementation
|
|
|
|
procedure Register;
|
|
begin
|
|
RegisterComponents( 'KOL', [ TKOLTimer, TKOLThread, TKOLImageList, TKOLMainMenu, TKOLPopupMenu,
|
|
TKOLOpenSaveDialog, TKOLOpenDirDialog, TKOLColorDialog,
|
|
TKOLTrayIcon ] );
|
|
RegisterComponentEditor( TKOLImageList, TKOLImageListEditor );
|
|
RegisterPropertyEditor( TypeInfo( String ), TKOLOpenSaveDialog, 'Filter',
|
|
TKOLFileFilter );
|
|
RegisterPropertyEditor( TypeInfo( TOnODSelChange ), TKOLOpenDirDialog, 'OnSelChanged', TKOLOnEventPropEditor );
|
|
RegisterPropertyEditor( TypeInfo( TOnTrayIconMouse ), nil, '', TKOLOnEventPropEditor );
|
|
end;
|
|
|
|
function String2PascalStr1( const S : String; const Concatenator: String ) : String;
|
|
var I, Strt : Integer;
|
|
function String2DoubleQuotas( const S : String ) : String;
|
|
var I, J : Integer;
|
|
begin
|
|
//if IndexOfChar( S, '''' ) <= 0 then
|
|
if pos( '''', S ) <= 0 then
|
|
Result := S
|
|
else
|
|
begin
|
|
J := 0;
|
|
for I := 1 to Length( S ) do
|
|
if S[ I ] = '''' then Inc( J );
|
|
SetLength( Result, Length( S ) + J );
|
|
J := 1;
|
|
for I := 1 to Length( S ) do
|
|
begin
|
|
Result[ J ] := S[ I ];
|
|
Inc( J );
|
|
if S[ I ] = '''' then
|
|
begin
|
|
Result[ J ] := '''';
|
|
Inc( J );
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
begin
|
|
Result := '';
|
|
if S = '' then
|
|
begin
|
|
Result := '''''';
|
|
exit;
|
|
end;
|
|
Strt := 1;
|
|
for I := 1 to Length( S ) + 1 do
|
|
begin
|
|
if (I > Length( S )) or (S[ I ] < ' ') then
|
|
begin
|
|
if (I > Strt) and (I > 1) then
|
|
begin
|
|
if Result <> '' then
|
|
Result := Result + Concatenator;
|
|
Result := Result + '''' + String2DoubleQuotas( Copy( S, Strt, I - Strt ) ) + '''';
|
|
end;
|
|
if I > Length( S ) then break;
|
|
if Result <> '' then
|
|
Result := Result + Concatenator
|
|
else
|
|
Result := Result + '''''' + Concatenator;
|
|
// Result := Result + '''''';
|
|
//if IndexOfChar(Concatenator, ',') > 0 then
|
|
if pos( ',', Concatenator ) > 0 then
|
|
Result := Result + IntToStr( Integer( S[ I ] ) )
|
|
else Result := Result + '#' + IntToStr( Integer( S[ I ] ) );
|
|
Strt := I + 1;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function String2Pascal( S: String; const Concatenator: String ): String;
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'String2Pascal', 0
|
|
@@e_signature:
|
|
end;
|
|
if Length( S ) > 0 then
|
|
begin
|
|
Result := '';
|
|
while S <> '' do
|
|
begin
|
|
if Result <> '' then
|
|
Result := Result + Concatenator;
|
|
Result := Result + String2PascalStr1( Copy( S, 1, 255 ), Concatenator );
|
|
S := Copy( S, 256, MaxInt );
|
|
end;
|
|
end
|
|
else
|
|
Result := '''''';
|
|
end;
|
|
|
|
function P_String2Pascal( S: String ): String;
|
|
var i: Integer;
|
|
begin
|
|
if S <> '' then
|
|
begin
|
|
if Length( S ) <= 64 then
|
|
Result := String2Pascal( S, ',' ) + ' #0'
|
|
else
|
|
begin
|
|
i := 1;
|
|
Result := '';
|
|
while i <= Length( S ) do
|
|
begin
|
|
Result := Result + String2Pascal( Copy( S, i, 64 ), ',' ) + #13#10;
|
|
inc( i, 64 );
|
|
end;
|
|
Result := Copy( Result, 1, Length( Result )-2 ) + ' #0';
|
|
end;
|
|
end
|
|
else
|
|
Result := ' #0';
|
|
end;
|
|
|
|
procedure RemoveSelection( FD: IFormDesigner );
|
|
{$IFDEF _D2orD3}
|
|
var L: TComponentList;
|
|
{$ENDIF}
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'RemoveSelection', 0
|
|
@@e_signature:
|
|
end;
|
|
try
|
|
{$IFDEF _D5orHigher}
|
|
FD.NoSelection;
|
|
{$ELSE}
|
|
{$IFDEF _D2orD3}
|
|
L := TComponentList.Create;
|
|
FD.SetSelections( L );
|
|
L.Free;
|
|
{$ELSE _D4}
|
|
FD.SetSelections( nil );
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
except
|
|
Rpt( '*/\* EXCEPTION - Could not remove current selection', WHITE );
|
|
end;
|
|
end;
|
|
|
|
function ColorsAreSystem16( ColorList: PList ): Boolean;
|
|
const SysColors: array[ 0..15 ] of TColor = ( 0, $800000, $8000, $808000, $80,
|
|
$800080, $8080, $808080, $C0C0C0, $FF0000, $FF00, $FFFF00, $FF, $FF00FF,
|
|
$FFFF, $FFFFFF );
|
|
var I, J: Integer;
|
|
C: TColor;
|
|
Found: Boolean;
|
|
begin
|
|
Result := TRUE;
|
|
for I := 0 to ColorList.Count-1 do
|
|
begin
|
|
C := TColor( ColorList.Items[ I ] );
|
|
Found := FALSE;
|
|
for J := 0 to 15 do
|
|
if SysColors[ J ] = C then
|
|
begin
|
|
Found := TRUE;
|
|
break;
|
|
end;
|
|
if not Found then
|
|
begin
|
|
Rpt( '***** Color ' + IntToHex( C, 8 ) + ' not found in system 16 colors',
|
|
WHITE );
|
|
Result := FALSE;
|
|
Exit;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function ColorsAreSystem256( ColorList: PList ): Boolean;
|
|
const SysColors8bit: array[ 0..255 ] of DWORD = ( $000000,
|
|
$C0DCC0, $800000, $808000, $008000, $008080, $000080, $800080, $808080,
|
|
$00FF00, $0000FF, $00FFFF, $C0DCC0, $000040, $400040, $000000, $A0A0A4,
|
|
$C0C0C0, $C0DCC0, $FFFBF0, $FFFBF0, $FFFBF0, $FFFBF0, $FFFFFF, $FF0000,
|
|
$FFFF00, $FF00FF, $FFFFFF, $A6CAF0, $402000, $004040, $202040, $202040,
|
|
$606040, $404040, $E08080, $E00080, $C0DCC0, $A0A0A4, $800000, $C02000,
|
|
$404000, $A04000, $E04000, $406000, $A06000, $E06000, $40A000, $202040,
|
|
$404040, $404040, $E06040, $A6CAF0, $C0DCC0, $40E000, $800000, $004000,
|
|
$604000, $C04000, $006000, $606000, $C06000, $00A000, $60A000, $A0A000,
|
|
$E0A000, $40C000, $A0C000, $E0C000, $A0E000, $00E040, $600040, $C00040,
|
|
$0000FF, $604040, $C04040, $006040, $606040, $C06040, $00A040, $C0A000,
|
|
$00C000, $60C000, $C0C000, $60E000, $C0E000, $0000FF, $A00040, $E00040,
|
|
$404040, $A04040, $E04040, $406040, $A06040, $E06040, $40A040, $60A040,
|
|
$C0A040, $00C040, $60C040, $C0C040, $40E040, $A0E040, $E0E040, $400080,
|
|
$A00080, $E00080, $404080, $A04080, $E04080, $406080, $A06080, $A0A040,
|
|
$E0A040, $40C040, $A0C040, $E0C040, $60E040, $C0E040, $000080, $600080,
|
|
$C00080, $004080, $604080, $C04080, $006080, $606080, $C06080, $00A080,
|
|
$A0C080, $E0C080, $40E080, $C0E080, $FF00FF, $A04080, $C00080, $404080,
|
|
$C04080, $006080, $604080, $C06080, $40A080, $A0A0A4, $E0A080, $40C080,
|
|
$C0C080, $00E080, $A0E080, $E000C0, $00A080, $A00080, $000080, $600080,
|
|
$E00080, $406080, $A06080, $E04080, $60A080, $C0A080, $00C080, $40C080,
|
|
$A0C080, $E0C080, $40E080, $A0E080, $E0E080, $400080, $A000C0, $004080,
|
|
$6040C0, $C040C0, $0060C0, $606080, $C060C0, $00A0C0, $60A0C0, $60C080,
|
|
$C0C080, $00E080, $60C080, $C0E080, $0000C0, $6000C0, $C000C0, $4040C0,
|
|
$A040C0, $E040C0, $4060C0, $A060C0, $E06080, $40A0C0, $A0A0C0, $C0A0C0,
|
|
$00A0C0, $60A0C0, $C0A0C0, $00C0C0, $60C0C0, $C0C0C0, $00FFFF, $60E080,
|
|
$C0DCC0, $4000C0, $A000C0, $4040C0, $A040C0, $FF00FF, $4060C0, $E0A0C0,
|
|
$40A0C0, $A0A0C0, $E0A0C0, $40C0C0, $A0C0C0, $E0A0C0, $40C0C0, $C0DCC0,
|
|
$FFFBF0, $6000C0, $0040C0, $6040C0, $C040C0, $0060C0, $6060C0, $A060C0,
|
|
$E060C0, $40A0C0, $A6CAF0, $E0A0C0, $40C0C0, $A6CAF0, $FFFBF0, $60C0C0,
|
|
$FFFFFF, $60E080, $6060C0, $A6CAF0, $606040, $808080, $C0C0C0, $C060C0,
|
|
$00A0C0, $60A0C0, $A6CAF0, $00FFFF, $60C0C0, $A6CAF0, $00FFFF, $A6CAF0,
|
|
$E06080, $E0E080, $E060C0, $A00040, $808080, $A0A0A4, $C0C0C0 );
|
|
var I, J: Integer;
|
|
C: DWORD;
|
|
begin
|
|
Result := FALSE;
|
|
for I := 0 to ColorList.Count-1 do
|
|
begin
|
|
C := DWORD( ColorList.Items[ I ] );
|
|
for J := 0 to 255 do
|
|
begin
|
|
if SysColors8bit[ J ] = C then
|
|
begin
|
|
C := 0;
|
|
break;
|
|
end;
|
|
end;
|
|
if C <> 0 then
|
|
begin
|
|
//Rpt( '~~~ color not found: ' + Int2Hex( C, 6 ), WHITE );
|
|
Exit;
|
|
end;
|
|
end;
|
|
Result := TRUE;
|
|
end;
|
|
|
|
function ColorsAre64K( ColorList: PList ): Boolean;
|
|
var I: Integer;
|
|
C: DWORD;
|
|
begin
|
|
Result := FALSE;
|
|
for I := 0 to ColorList.Count-1 do
|
|
begin
|
|
C := DWORD( ColorList.Items[ I ] );
|
|
if (C and $E0C0E0) <> C then
|
|
begin
|
|
//Rpt( '~~~ color not found: ' + Int2Hex( C, 6 ), WHITE );
|
|
Exit;
|
|
end;
|
|
end;
|
|
Result := TRUE;
|
|
end;
|
|
|
|
function CountSystemColorsUsedInBitmap( Bmp: KOL.PBitmap; ColorList: KOL.PList ): KOL.TPixelFormat;
|
|
var Y, X: Integer;
|
|
L: PDWORD;
|
|
C: TColor;
|
|
R, G, B: Byte;
|
|
not_use_16bpp: Boolean;
|
|
begin
|
|
Rpt( 'CountSystemColorsUsedInBitmap()', YELLOW );
|
|
ColorList.Clear;
|
|
ColorList.Capacity := 65537;
|
|
TRY
|
|
not_use_16bpp := FALSE;
|
|
for Y := 0 to Bmp.Height - 1 do
|
|
begin
|
|
L := Bmp.ScanLine[ Y ];
|
|
for X := 0 to Bmp.Width - 1 do
|
|
begin
|
|
C := L^ and $FFFFFF;
|
|
if ((C and $E0C0E0) <> C) and not not_use_16bpp then
|
|
begin
|
|
R := C and $FF;
|
|
G := (C and $FF00) shr 8;
|
|
B := C shr 16;
|
|
if ((R and $E0) <> R) and (R <> $FF) or
|
|
((G and $C0) <> G) and (G <> $FF) or
|
|
((B and $E0) <> B) and (B <> $FF) then
|
|
begin
|
|
//Result := KOL.pf24bit;
|
|
//Rpt( '~~~ color not found: ' + Int2Hex( C, 6 ), WHITE );
|
|
//Exit;
|
|
not_use_16bpp := TRUE;
|
|
end;
|
|
end;
|
|
if ColorList.IndexOf( Pointer( C ) ) < 0 then
|
|
begin
|
|
ColorList.Add( Pointer( C ) );
|
|
if ColorList.Count > 65536 then
|
|
begin
|
|
//Result := KOL.pf24bit;
|
|
//Rpt( '~~~~~ pf24bit (break) ~~~~~ (' + IntToStr( ColorList.Count ) +
|
|
// ')', WHITE );
|
|
//Exit;
|
|
not_use_16bpp := TRUE;
|
|
break;
|
|
end;
|
|
if not_use_16bpp and (ColorList.Count > 256) then
|
|
end;
|
|
Inc( L );
|
|
end;
|
|
end;
|
|
if (ColorList.Count <= 2) {and
|
|
((ColorList.Count = 0) or
|
|
(ColorList.Count > 0) and (DWORD(ColorList.Items[ 0 ]) and $FFFFFF = $FFFFFF) and
|
|
((ColorList.Count < 2) or
|
|
(ColorList.Count = 2) and (DWORD( ColorList.Items[ 1 ] ) and $FFFFFF = 0) ))} then
|
|
begin
|
|
Result := KOL.pf1bit;
|
|
Rpt( '~~~~~ pf1bit ~~~~~', WHITE );
|
|
end else if (ColorList.Count <= 16) {and ColorsAreSystem16( ColorList )} then
|
|
begin
|
|
Result := KOL.pf4bit;
|
|
Rpt( '~~~~~ pf4bit ~~~~~', WHITE );
|
|
end else if (ColorList.Count <= 256) {and ColorsAreSystem256( ColorList )} then
|
|
begin
|
|
Result := KOL.pf8bit;
|
|
Rpt( '~~~~~ pf8bit ~~~~~', WHITE );
|
|
end else if (ColorList.Count <= 65536) and not not_use_16bpp
|
|
and ColorsAre64K( ColorList ) then
|
|
begin
|
|
Result := KOL.pf16bit;
|
|
Rpt( '~~~~~ pf16bit ~~~~~', WHITE );
|
|
end
|
|
else
|
|
begin
|
|
Result := KOL.pf24bit;
|
|
Rpt( '~~~~~ pf24bit ~~~~~ (' + IntToStr( ColorList.Count ) + ')', WHITE );
|
|
end;
|
|
FINALLY
|
|
Rpt( '------ Colors in bitmap: ' + IntToStr( ColorList.Count ), YELLOW );
|
|
//ColorList.Free;
|
|
END;
|
|
end;
|
|
|
|
{$IFDEF _D2}
|
|
procedure GenerateBitmapResource( Bitmap: TBitmap; const RsrcName, FileName: String;
|
|
var Updated: Boolean );
|
|
var RL: TStringList;
|
|
Buf1, Buf2: PChar;
|
|
I, J: Integer;
|
|
F: THandle;
|
|
S: String;
|
|
KOLBmp: KOL.PBitmap;
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'GenerateBitmapResource', 0
|
|
@@e_signature:
|
|
end;
|
|
KOLBmp := NewDIBBitmap( Bitmap.Width, Bitmap.Height, KOL.pf32bit );
|
|
BitBlt( KOLBmp.Canvas.Handle, 0, 0, Bitmap.Width, Bitmap.Height,
|
|
Bitmap.Canvas.Handle, 0, 0, SRCCOPY );
|
|
KOLBmp.HandleType := KOL.bmDIB;
|
|
KOLBmp.PixelFormat := KOL.pf32bit;
|
|
KOLBmp.PixelFormat := CountSystemColorsUsedInBitmap( KOLBmp );
|
|
KOLBmp.SaveToFile( ProjectSourcePath + FileName + '.bmp' );
|
|
|
|
Buf1 := nil;
|
|
Buf2 := nil;
|
|
I := 0;
|
|
J := 0;
|
|
S := ProjectSourcePath + FileName + '.res';
|
|
if FileExists( S ) then
|
|
begin
|
|
I := FileSize( S );
|
|
if I > 0 then
|
|
begin
|
|
GetMem( Buf1, I );
|
|
F := KOL.FileCreate( S, ofOpenRead or ofShareDenyWrite or ofOpenExisting );
|
|
if F <> THandle( -1 ) then
|
|
begin
|
|
KOL.FileRead( F, Buf1^, I );
|
|
KOL.FileClose( F );
|
|
end;
|
|
end;
|
|
end;
|
|
RL := TStringList.Create;
|
|
RL.Add( UpperCase( RsrcName ) + ' BITMAP "' + FileName + '.bmp"' );
|
|
RL.SaveToFile( ProjectSourcePath + FileName + '.rc' );
|
|
RL.Free;
|
|
if not FileExists( ProjectSourcePath + FileName + '.rc' ) then
|
|
begin
|
|
ShowMessage( 'Can not save file: ' + ProjectSourcePath + FileName + '.rc' );
|
|
Exit;
|
|
end;
|
|
{ShellExecute( 0, 'open', PChar( ExtractFilePath( Application.ExeName ) + 'brcc32.exe' ),
|
|
PChar( ProjectSourcePath + FileName + '.rc' ), PChar( ProjectSourcePath ),
|
|
SW_HIDE );}
|
|
Rpt( 'Compiling resource ' + ProjectSourcePath + FileName + '.rc', WHITE );
|
|
if not ExecuteWait( ExtractFilePath( Application.ExeName ) + 'brcc32.exe',
|
|
'"' + ProjectSourcePath + FileName + '.rc"',
|
|
ProjectSourcePath, SW_HIDE, INFINITE, nil ) then
|
|
begin
|
|
Rpt( 'Can not compile resource with ' + ExtractFilePath( Application.ExeName ) + 'brcc32.exe', RED );
|
|
end;
|
|
if FileExists( S ) then
|
|
begin
|
|
J := FileSize( S );
|
|
if J > 0 then
|
|
begin
|
|
GetMem( Buf2, J );
|
|
F := KOL.FileCreate( S, ofOpenRead or ofShareDenyWrite or ofOpenExisting );
|
|
if F <> THandle( -1 ) then
|
|
begin
|
|
KOL.FileRead( F, Buf2^, J );
|
|
KOL.FileClose( F );
|
|
end;
|
|
end;
|
|
end;
|
|
if (Buf1 = nil) or (I <> J) or
|
|
(Buf2 <> nil) and not CompareMem( Buf1, Buf2, J ) then
|
|
begin
|
|
Rpt( 'Resource ' + FileName + ' changed.', WHITE );
|
|
Updated := TRUE;
|
|
end;
|
|
if Buf1 <> nil then FreeMem( Buf1 );
|
|
if Buf2 <> nil then FreeMem( Buf2 );
|
|
end;
|
|
|
|
{$ELSE not _D2}
|
|
|
|
procedure OptimizeKOLBitmapBeforeRLEEncoding( B: KOL.PBitmap );
|
|
var ColorCounts: array[ 0..255 ] of Integer;
|
|
x, y, N, i, M: Integer;
|
|
Src: PByte;
|
|
C1, C2: TColor;
|
|
Tmp: KOL.PBitmap;
|
|
begin
|
|
FillChar( ColorCounts, Sizeof( ColorCounts ), 0 );
|
|
N := 0;
|
|
for y := 0 to B.Height-1 do
|
|
begin
|
|
Src := B.ScanLine[y];
|
|
if B.PixelFormat = KOL.pf4bit then
|
|
begin
|
|
x := B.Width;
|
|
while x > 0 do
|
|
begin
|
|
inc( ColorCounts[ Src^ shr 4 ] );
|
|
if x > 1 then
|
|
inc( ColorCounts[ Src^ and 15 ] );
|
|
dec( x, 2 );
|
|
inc( Src );
|
|
end;
|
|
N := 16;
|
|
end else
|
|
begin
|
|
for x := B.Width downto 1 do
|
|
begin
|
|
inc( ColorCounts[ Src^ ] );
|
|
inc( Src );
|
|
end;
|
|
N := 256;
|
|
end;
|
|
end;
|
|
M := 0;
|
|
for i := 0 to N-1 do
|
|
begin
|
|
if ColorCounts[i] > ColorCounts[M] then
|
|
M := i;
|
|
end;
|
|
if M > 0 then
|
|
begin
|
|
C1 := B.DIBPalEntries[0];
|
|
C2 := B.DIBPalEntries[M];
|
|
Tmp := NewBitmap( 0, 0 );
|
|
TRY
|
|
Tmp.Assign( B );
|
|
B.DIBPalEntries[0] := C2;
|
|
B.DIBPalEntries[M] := C1;
|
|
Tmp.Draw( B.Canvas.Handle, 0, 0 );
|
|
FINALLY
|
|
Tmp.Free;
|
|
END;
|
|
end;
|
|
end;
|
|
|
|
// This version of GenerateBitmapResource provided by Alex Pravdin.
|
|
// It does not use brcc32.exe, and creates res-file directly, so
|
|
// it is fast and has no restrictions on bitmap format at all.
|
|
|
|
procedure GenerateBitmapResource( Bitmap: TBitmap; const RsrcName, FileName:
|
|
String; var Updated: Boolean; AllowCompression: Boolean );
|
|
var
|
|
HD1: packed record // First part of RESOURCEHEADER structure before
|
|
// Unicode string contained bitmap resource name
|
|
DataSize: cardinal;
|
|
HeaderSize: cardinal;
|
|
NFFFF: word;
|
|
DataType: word;
|
|
end;
|
|
|
|
HD2: packed record // Second part of RESOURCEHEADER
|
|
DataVersion: cardinal;
|
|
MemFlags: word;
|
|
PrimaryLang: byte;
|
|
SubLang: byte;
|
|
Version: cardinal;
|
|
Charact: cardinal;
|
|
end;
|
|
|
|
br, hFR, hFtm, DIBLen, WLen, RLen, tm: DWORD;
|
|
Buf1, Buf2: PByteArray;
|
|
FE: boolean;
|
|
Res: String;
|
|
Bmp: String;
|
|
tmStr: WideString;
|
|
|
|
KOLBmp: KOL.PBitmap;
|
|
KOLPF: KOL.TPixelFormat;
|
|
ColorList: KOL.PList;
|
|
N, i: Integer;
|
|
Mem, MemRLE: KOL.PStream;
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'GenerateBitmapResource', 0
|
|
@@e_signature:
|
|
end;
|
|
Res := ProjectSourcePath + FileName + '.res';
|
|
Bmp := ProjectSourcePath + FileName + '.bmp';
|
|
FE := FileExists( Res );
|
|
|
|
Rpt( 'Generating resource ' + RsrcName, YELLOW );
|
|
//Bitmap.SaveToFile( Bmp );
|
|
KOLBmp := KOL.NewDIBBitmap( Bitmap.Width, Bitmap.Height, KOL.pf32bit );
|
|
BitBlt( KOLBmp.Canvas.Handle, 0, 0, Bitmap.Width, Bitmap.Height,
|
|
Bitmap.Canvas.Handle, 0, 0, SRCCOPY );
|
|
KOLBmp.HandleType := KOL.bmDIB;
|
|
KOLBmp.PixelFormat := KOL.pf32bit;
|
|
ColorList := NewList;
|
|
TRY
|
|
KOLPF := CountSystemColorsUsedInBitmap( KOLBmp, ColorList );
|
|
if ColorList.Count > 0 then
|
|
begin
|
|
KOLBmp.PixelFormat := KOLPF;
|
|
KOLBmp.HandleType := KOL.bmDIB;
|
|
N := 0;
|
|
CASE KOLPF OF
|
|
KOL.pf1bit: N := 2;
|
|
KOL.pf4bit: N := 16;
|
|
KOL.pf8bit: N := 256;
|
|
END;
|
|
if N > 0 then
|
|
begin
|
|
for i := 0 to min( ColorList.Count, N )-1 do
|
|
begin
|
|
KOLBmp.DIBPalEntries[i] := Integer( ColorList.Items[i] );
|
|
end;
|
|
//
|
|
BitBlt( KOLBmp.Canvas.Handle, 0, 0, Bitmap.Width, Bitmap.Height,
|
|
Bitmap.Canvas.Handle, 0, 0, SRCCOPY );
|
|
//
|
|
end;
|
|
//KOLBmp.SaveToFile( Bmp );
|
|
Mem := NewMemoryStream;
|
|
MemRLE := NewMemoryStream;
|
|
TRY
|
|
if AllowCompression then
|
|
KOLBmp.CoreSaveToStream( Mem )
|
|
else KOLBmp.SaveToStream( Mem );
|
|
if (N > 0) and AllowCompression then
|
|
begin
|
|
if KOLPF = KOL.pf1bit then
|
|
KOLBmp.PixelFormat := KOL.pf4bit;
|
|
OptimizeKOLBitmapBeforeRLEEncoding( KOLBmp );
|
|
KOLBmp.RLESaveToStream( MemRLE );
|
|
end;
|
|
if (MemRLE.Size > 0) and (MemRLE.Size < Mem.Size) then
|
|
KOL.Swap( Integer( Mem ), Integer( MemRLE ) );
|
|
Mem.Position := 0;
|
|
Mem.SaveToFile( Bmp, 0, Mem.Size );
|
|
FINALLY
|
|
Mem.Free;
|
|
MemRLE.Free;
|
|
END;
|
|
end
|
|
else
|
|
begin
|
|
Bitmap.SaveToFile( Bmp );
|
|
end;
|
|
Rpt( 'Bitmap saved to ' + Bmp, YELLOW );
|
|
KOLBmp.Free;
|
|
FINALLY
|
|
ColorList.Free;
|
|
END;
|
|
|
|
if FE then
|
|
begin
|
|
DeleteFile( PChar( Res + '_tmp' ) );
|
|
CopyFile( PChar(Res), PChar( (Res+'_tmp') ), False );
|
|
end;
|
|
|
|
hFR := CreateFile( PChar(Res), GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ,
|
|
nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0 );
|
|
|
|
if hFR = INVALID_HANDLE_VALUE then begin
|
|
Rpt( 'Can not create file ' + Res + #13#10'Error: ' + SysErrorMessage( GetLastError ), RED );
|
|
Exit;
|
|
end;
|
|
|
|
hFtm := CreateFile( PChar(Bmp), GENERIC_READ, FILE_SHARE_READ, nil,
|
|
OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0 );
|
|
|
|
DIBLen := GetFileSize( hFtm, nil ) - 14{SizeOf( TBITMAPFILEHEADER )};
|
|
WLen := ( Length( RsrcName ) + 1 ) * 2;
|
|
|
|
HD1.DataSize := DIBLen;
|
|
HD1.HeaderSize := 12{SizeOf( HD1 )} + 16{SizeOf( HD2 )} + WLen;
|
|
HD1.NFFFF := $FFFF;
|
|
HD1.DataType := 2; // RT_BITMAP
|
|
HD2.DataVersion := 0;
|
|
HD2.MemFlags := 0;
|
|
HD2.PrimaryLang := LANG_NEUTRAL;
|
|
HD2.SubLang := SUBLANG_DEFAULT;
|
|
HD2.Version := 0;
|
|
HD2.Charact := 0;
|
|
|
|
RLen := HD1.HeaderSize + DIBLen + 32;
|
|
GetMem( Buf1, RLen );
|
|
FillChar( Buf1[0], RLen, 0 );
|
|
|
|
Buf1[4]:=$20; Buf1[8]:=$FF; Buf1[9]:=$FF; Buf1[12]:=$FF; Buf1[13]:=$FF;
|
|
|
|
tmStr := UpperCase( RsrcName ) + #0;
|
|
CopyMemory( @Buf1[32], @HD1, 12 );
|
|
CopyMemory( @Buf1[32+12], @tmStr[1], WLen );
|
|
CopyMemory( @Buf1[32+12+WLen], @HD2, 16 );
|
|
|
|
SetFilePointer( hFtm, 14{SizeOf( TBITMAPFILEHEADER )}, nil, FILE_BEGIN);
|
|
ReadFile( hFtm, Buf1[32+12+16+WLen], DIBLen, br, nil );
|
|
|
|
WriteFile( hFR, Buf1[0], RLen, br, nil );
|
|
CloseHandle( hFtm );
|
|
CloseHandle( hFR );
|
|
//------------------------------------------------
|
|
DeleteFile( Bmp );
|
|
|
|
if FE then begin
|
|
hFtm := CreateFile( PChar( (Res+'_tmp') ), GENERIC_READ,
|
|
FILE_SHARE_READ, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0 );
|
|
tm := GetFileSize( hFtm, nil );
|
|
GetMem( Buf2, tm );
|
|
ReadFile( hFtm, Buf2[0], tm, br, nil );
|
|
CloseHandle( hFtm );
|
|
DeleteFile( Res + '_tmp' );
|
|
if ( RLen <> tm ) or (not CompareMem( @Buf1[0], @Buf2[0], Min( RLen,
|
|
tm ) )) then begin
|
|
Rpt( 'Resource ' + Res + ' changed.', WHITE );
|
|
Updated := True;
|
|
end;
|
|
FreeMem( Buf2 );
|
|
end;
|
|
FreeMem( Buf1 );
|
|
|
|
end;
|
|
{$ENDIF}
|
|
|
|
function SaveIcon( Icon: TIcon; const Path: String ): Boolean;
|
|
var MS, MS2: TMemoryStream;
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'SaveIcon', 0
|
|
@@e_signature:
|
|
end;
|
|
Result := TRUE;
|
|
MS := TMemoryStream.Create;
|
|
MS2 := TMemoryStream.Create;
|
|
try
|
|
Icon.SaveToStream( MS );
|
|
if FileExists( Path ) then
|
|
begin
|
|
MS2.LoadFromFile( Path );
|
|
if (MS.Size = MS2.Size) and CompareMem( MS.Memory, MS2.Memory, MS.Size ) then
|
|
Exit;
|
|
if FileExists( Path + '.$$$' ) then
|
|
DeleteFile( Path + '.$$$' );
|
|
MoveFile( PChar( Path ), PChar( Path + '.$$$' ) );
|
|
end;
|
|
MS.Position := 0;
|
|
MS.SaveToFile( Path );
|
|
//Result := True;
|
|
//Rpt( 'Icon stored to ' + Path );
|
|
finally
|
|
MS.Free;
|
|
MS2.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure GenerateIconResource( Icon: TIcon; const RsrcName, FileName: KOLString;
|
|
var Updated: Boolean );
|
|
var RL: TStringList;
|
|
Buf1, Buf2: PKOLChar;
|
|
S: String;
|
|
I, J: Integer;
|
|
F: THandle;
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'GenerateIconResource', 0
|
|
@@e_signature:
|
|
end;
|
|
{if not SaveIcon( Icon, ProjectSourcePath + FileName + '.ico' )
|
|
and FileExists( ProjectSourcePath + FileName + '.res' ) then Exit;}
|
|
if not SaveIcon( Icon, ProjectSourcePath + FileName + '.ico' ) then
|
|
Exit;
|
|
RL := TStringList.Create;
|
|
RL.Add( KOLUpperCase( RsrcName ) + ' ICON "' + FileName + '.ico"' );
|
|
RL.SaveToFile( ProjectSourcePath + FileName + '.rc' );
|
|
RL.Free;
|
|
Buf1 := nil;
|
|
Buf2 := nil;
|
|
I := 0; J := 0;
|
|
S := ProjectSourcePath + FileName + '.res';
|
|
if FileExists( S ) then
|
|
begin
|
|
I := FileSize( S );
|
|
if I > 0 then
|
|
begin
|
|
GetMem( Buf1, I );
|
|
F := KOL.FileCreate( S, ofOpenRead or ofShareDenyWrite or ofOpenExisting );
|
|
if F <> THandle( -1 ) then
|
|
begin
|
|
KOL.FileRead( F, Buf1^, I );
|
|
KOL.FileClose( F );
|
|
end;
|
|
end;
|
|
end;
|
|
{ShellExecute( 0, 'open', PChar( ExtractFilePath( Application.ExeName ) + 'brcc32.exe' ),
|
|
PChar( ProjectSourcePath + FileName + '.rc' ), PChar( ProjectSourcePath ),
|
|
SW_HIDE );}
|
|
ExecuteWait( ExtractFilePath( Application.ExeName ) + 'brcc32.exe',
|
|
'"' + ProjectSourcePath + FileName + '.rc"',
|
|
ProjectSourcePath, SW_HIDE, INFINITE, nil );
|
|
if FileExists( S ) then
|
|
begin
|
|
J := FileSize( S );
|
|
if J > 0 then
|
|
begin
|
|
GetMem( Buf2, J );
|
|
F := KOL.FileCreate( S, ofOpenRead or ofShareDenyWrite or ofOpenExisting );
|
|
if F <> THandle( -1 ) then
|
|
begin
|
|
KOL.FileRead( F, Buf2^, J );
|
|
KOL.FileClose( F );
|
|
end;
|
|
end;
|
|
end;
|
|
if (Buf1 = nil) or (I <> J) or
|
|
(Buf2 <> nil) and not CompareMem( Buf1, Buf2, J ) then
|
|
begin
|
|
Updated := TRUE;
|
|
end;
|
|
if Buf1 <> nil then FreeMem( Buf1 );
|
|
if Buf2 <> nil then FreeMem( Buf2 );
|
|
end;
|
|
|
|
{ TKOLTimer }
|
|
|
|
procedure TKOLTimer.AssignEvents(SL: TStringList; const AName: String);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLTimer.AssignEvents', 0
|
|
@@e_signature:
|
|
end;
|
|
inherited;
|
|
DoAssignEvents( SL, AName, [ 'OnTimer' ], [ @OnTimer ] );
|
|
end;
|
|
|
|
constructor TKOLTimer.Create(AOwner: TComponent);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLTimer.Create', 0
|
|
@@e_signature:
|
|
end;
|
|
inherited;
|
|
fInterval := 1000;
|
|
fEnabled := True;
|
|
FPeriodic := TRUE;
|
|
FResolution := 0;
|
|
end;
|
|
|
|
function TKOLTimer.Pcode_Generate: Boolean;
|
|
begin
|
|
Result := TRUE;
|
|
end;
|
|
|
|
function TKOLTimer.P_AssignEvents(SL: TStringList; const AName: String; CheckOnly: Boolean): Boolean;
|
|
begin
|
|
Result := inherited P_AssignEvents( SL, AName, CheckOnly );
|
|
{P}SL.Add( ' //inherited P_AssignEvents called:' + IntToStr( Integer( Result ) ) );
|
|
if Result and CheckOnly then Exit;
|
|
if P_DoAssignEvents( SL, AName, [ 'OnTimer' ], [ @OnTimer ], [ FALSE ], CheckOnly )
|
|
and CheckOnly then Exit;
|
|
Result := FALSE;
|
|
end;
|
|
|
|
procedure TKOLTimer.P_DoProvideFakeType(SL: TStringList);
|
|
begin
|
|
if not Multimedia then
|
|
P_ProvideFakeType( SL, 'type TTimer_ = object(KOL.TTimer) end;' )
|
|
else
|
|
P_ProvideFakeType( SL, 'type TMMTimer_ = object(KOL.TMMTimer) end;' );
|
|
end;
|
|
|
|
procedure TKOLTimer.P_SetupFirst(SL: TStringList; const AName, AParent,
|
|
Prefix: String);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLTimer.SetupFirst', 0
|
|
@@e_signature:
|
|
end;
|
|
if Multimedia then
|
|
begin
|
|
//SL.Add( Prefix + AName + ' := NewMMTimer( ' + IntToStr( Interval ) + ' );' );
|
|
{P}SL.Add( ' L(' + IntToStr( Interval ) + ') NewMMTimer<1> ' +
|
|
' RESULT DUP LoadSELF ' +
|
|
'AddWord_Store ##T' + ParentKOLForm.formName + '.' + Name );
|
|
if not Periodic then
|
|
//SL.Add( Prefix + 'PMMTimer(' + AName + ').Periodic := FALSE;' );
|
|
{P}SL.Add( ' L(0) C1 TMMTimer_.SetPeriodic<2>' );
|
|
if Resolution > 0 then
|
|
//SL.Add( Prefix + 'PMMTimer(' + AName + ').Resolution := ' + IntToStr( Resolution ) + ';' );
|
|
{P}SL.Add( ' L(' + IntToStr( Resolution ) +
|
|
') C1 AddByte_Store #TMMTimer_.fResolution' );
|
|
end
|
|
else
|
|
//SL.Add( Prefix + AName + ' := NewTimer( ' + IntToStr( Interval ) + ' );' );
|
|
{P}SL.Add( ' L(' + IntToStr( Interval ) + ') NewTimer<1> ' +
|
|
' RESULT DUP LoadSELF ' +
|
|
'AddWord_Store ##T' + ParentKOLForm.formName + '.' + Name );
|
|
P_GenerateTag( SL, AName, Prefix );
|
|
end;
|
|
|
|
procedure TKOLTimer.P_SetupLast(SL: TStringList; const AName, AParent,
|
|
Prefix: String);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLTimer.P_SetupLast', 0
|
|
@@e_signature:
|
|
end;
|
|
if Enabled then
|
|
//SL.Add( Prefix + AName + '.Enabled := True;' );
|
|
begin
|
|
{P}SL.Add( ' L(1) ' +
|
|
'LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.formName + '.' + Name +
|
|
' TTimer_.SetEnabled<2>' );
|
|
end;
|
|
end;
|
|
|
|
procedure TKOLTimer.SetEnabled(const Value: Boolean);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLTimer.SetEnabled', 0
|
|
@@e_signature:
|
|
end;
|
|
FEnabled := Value;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLTimer.SetInterval(const Value: Integer);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLTimer.SetInterval', 0
|
|
@@e_signature:
|
|
end;
|
|
FInterval := Value;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLTimer.SetMultimedia(const Value: Boolean);
|
|
begin
|
|
FMultimedia := Value;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLTimer.SetOnTimer(const Value: TOnEvent);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLTimer.SetOnTimer', 0
|
|
@@e_signature:
|
|
end;
|
|
FOnTimer := Value;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLTimer.SetPeriodic(const Value: Boolean);
|
|
begin
|
|
FPeriodic := Value;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLTimer.SetResolution(const Value: Integer);
|
|
begin
|
|
FResolution := Value;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLTimer.SetupFirst(SL: TStringList; const AName,
|
|
AParent, Prefix: String);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLTimer.SetupFirst', 0
|
|
@@e_signature:
|
|
end;
|
|
if Multimedia then
|
|
begin
|
|
SL.Add( Prefix + AName + ' := NewMMTimer( ' + IntToStr( Interval ) + ' );' );
|
|
if not Periodic then
|
|
SL.Add( Prefix + 'PMMTimer(' + AName + ').Periodic := FALSE;' );
|
|
if Resolution > 0 then
|
|
SL.Add( Prefix + 'PMMTimer(' + AName + ').Resolution := ' + IntToStr( Resolution ) + ';' );
|
|
end
|
|
else
|
|
SL.Add( Prefix + AName + ' := NewTimer( ' + IntToStr( Interval ) + ' );' );
|
|
|
|
//AssignEvents( SL, AName );
|
|
GenerateTag( SL, AName, Prefix );
|
|
end;
|
|
|
|
procedure TKOLTimer.SetupLast(SL: TStringList; const AName,
|
|
AParent, Prefix: String);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLTimer.SetupLast', 0
|
|
@@e_signature:
|
|
end;
|
|
if Enabled then
|
|
SL.Add( Prefix + AName + '.Enabled := True;' );
|
|
end;
|
|
|
|
function TKOLTimer.TypeName: String;
|
|
begin
|
|
if Multimedia then Result := 'MMTimer'
|
|
else Result := inherited TypeName;
|
|
end;
|
|
|
|
{ TKOLImageList }
|
|
|
|
procedure TKOLImageList.Assign(Value: TPersistent);
|
|
var IL: TKOLImageList;
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLImageList.Assign', 0
|
|
@@e_signature:
|
|
end;
|
|
if (Value <> nil) and (Value is TKOLImageList) then
|
|
begin
|
|
IL := Value as TKOLImageList;
|
|
FImgWidth := IL.ImgWidth;
|
|
FImgHeight := IL.ImgHeight;
|
|
FCount := IL.Count;
|
|
FBitmap.Assign( IL.Bitmap );
|
|
FSystemImageList := IL.SystemImageList;
|
|
FTransparentColor := IL.TransparentColor;
|
|
end
|
|
else
|
|
inherited;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLImageList.AssignBitmapToKOLImgList;
|
|
var R: Integer;
|
|
TmpBmp: TBitmap;
|
|
begin
|
|
if FKOLImgList = nil then Exit;
|
|
if Bitmap <> nil then
|
|
begin
|
|
//Bitmap.SaveToFile( 'c:\test1.bmp' );
|
|
//ShowMessage( 'Bitmap.Handle=' + IntToStr( Bitmap.Handle ) );
|
|
FKOLImgList.Clear;
|
|
FKOLImgList.Colors := Colors;
|
|
//FKOLImgList.BkColor := Color2RGB( BkColor );
|
|
FKOLImgList.ImgWidth := ImgWidth;
|
|
FKOLImgList.ImgHeight := ImgHeight;
|
|
{$IFDEF _D3orHigher}
|
|
{Bitmap.HandleType := bmDIB;
|
|
Bitmap.PixelFormat := pf24bit;}
|
|
{$ENDIF}
|
|
//ShowMessage( Int2Hex( Color2RGB( BkColor ), 8 ) );
|
|
if not Bitmap.Empty then
|
|
begin
|
|
//Bitmap.SaveToFile( 'c:\test2.bmp' );
|
|
TmpBmp := TBitmap.Create;
|
|
TRY
|
|
TmpBmp.Assign( Bitmap );
|
|
if Masked then
|
|
R := FKOLImgList.AddMasked( TmpBmp.Handle, Color2RGB( TransparentColor ) )
|
|
else
|
|
begin
|
|
FKOLImgList.Masked := FALSE;
|
|
R := FKOLImgList.Add( TmpBmp.Handle, 0 );
|
|
end;
|
|
if R < 0 then
|
|
ShowMessage( 'Error adding bitmap: ' + SysErrorMessage( GetLastError ) )
|
|
else
|
|
begin
|
|
DoNotifyLinkedComponents( noChanged );
|
|
end;
|
|
FINALLY
|
|
TmpBmp.Free;
|
|
END;
|
|
//Bitmap.SaveToFile( 'c:\test3.bmp' );
|
|
//ShowMessage( 'Result := ' + IntToStr( R ) );
|
|
//ShowMessage( 'FKOLImgList.Handle=' + IntToStr( FKOLImgList.Handle ) );
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{procedure TKOLImageList.BitmapChanged(Sender: TObject);
|
|
begin
|
|
AssignBitmapToKOLImgList;
|
|
end;}
|
|
|
|
procedure TKOLImageList.Clear;
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLImageList.Clear', 0
|
|
@@e_signature:
|
|
end;
|
|
if FBitmap <> nil then
|
|
begin
|
|
FBitmap.Width := 0;
|
|
FBitmap.Height := 0;
|
|
end;
|
|
FCount := 0;
|
|
end;
|
|
|
|
constructor TKOLImageList.Create( AOwner: TComponent );
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLImageList.Create', 0
|
|
@@e_signature:
|
|
end;
|
|
inherited Create( AOwner );
|
|
FBkColor := clNone;
|
|
FBitmap := TBitmap.Create;
|
|
//FBitmap.OnChange := BitmapChanged;
|
|
FImgWidth := 32;
|
|
FImgHeight := 32;
|
|
FTransparentColor := clDefault;
|
|
FMasked := TRUE;
|
|
NeedFree := False; // ImageList in KOL destroyes self when its parent
|
|
// control is destroyed - automatically.
|
|
fCreationPriority := 10;
|
|
FAllowCompression := TRUE;
|
|
end;
|
|
|
|
destructor TKOLImageList.Destroy;
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLImageList.Destroy', 0
|
|
@@e_signature:
|
|
end;
|
|
FKOLImgList.Free;
|
|
FBitmap.Free;
|
|
inherited;
|
|
end;
|
|
|
|
function TKOLImageList.GetBitmap: TBitmap;
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLImageList.GetBitmap', 0
|
|
@@e_signature:
|
|
end;
|
|
if SystemImageList then
|
|
Result := nil
|
|
else
|
|
Result := FBitmap;
|
|
end;
|
|
|
|
function TKOLImageList.GetImageListHandle: THandle;
|
|
begin
|
|
if FKOLImgList = nil then
|
|
begin
|
|
FKOLImgList := NewImageList( nil );
|
|
AssignBitmapToKOLImgList;
|
|
end;
|
|
Result := FKOLImgList.Handle;
|
|
end;
|
|
|
|
function TKOLImageList.GetTransparentColor: TColor;
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLImageList.GetTransparentColor', 0
|
|
@@e_signature:
|
|
end;
|
|
Result := FTransparentColor;
|
|
if Result = clDefault then
|
|
if FBitmap <> nil then
|
|
if (FBitmap.Width <> 0) and (FBitmap.Height <> 0) then
|
|
Result := FBitmap.Canvas.Pixels[ 0, FBitmap.Height - 1 ];
|
|
end;
|
|
|
|
function TKOLImageList.Pcode_Generate: Boolean;
|
|
begin
|
|
Result := TRUE;
|
|
end;
|
|
|
|
procedure TKOLImageList.P_SetupFirst(SL: TStringList; const AName, AParent,
|
|
Prefix: String);
|
|
const Booleans: array[ Boolean ] of String = ( 'False', 'True' );
|
|
const ColorsValues: array[ TImageListColors ] of String = ( 'ilcColor', 'ilcColor4',
|
|
'ilcColor8', 'ilcColor16', 'ilcColor24', 'ilcColor32', 'ilcColorDDB',
|
|
'ilcDefault' );
|
|
var RsrcName, RsrcFile: String;
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLImageList.P_SetupFirst', 0
|
|
@@e_signature:
|
|
end;
|
|
//SL.Add( Prefix + AName + ' := NewImageList( ' + AParent + ' );' );
|
|
{P}SL.Add( ' DUP NewImageList<1> RESULT DUP LoadSELF AddWord_Store ##T' +
|
|
ParentKOLForm.FormName + '.' + Name );
|
|
P_GenerateTag( SL, AName, Prefix );
|
|
if SystemImageList then
|
|
//SL.Add( Prefix + AName + '.LoadSystemIcons( ' + Booleans[ ImgHeight = 16 ] + ' );' )
|
|
{P}SL.Add( ' L(' + IntToStr( Integer( ImgHeight = 16 ) ) + ') C1 ' +
|
|
' TImageList.LoadSystemIcons<2>' )
|
|
else
|
|
begin
|
|
if Colors <> ilcDefault then
|
|
//SL.Add( Prefix + AName + '.Colors := ' + ColorsValues[ Colors ] + ';' );
|
|
{P}SL.Add( ' L(' + IntToStr( Integer( Colors ) ) + ') C1 TImageList_.SetColors<2>' );
|
|
if not Masked then
|
|
begin
|
|
//SL.Add( Prefix + AName + '.Masked := FALSE;' );
|
|
{P}SL.Add( ' L(0) C1 TImageList_.SetMasked<2>' );
|
|
if BkColor <> clNone then
|
|
//SL.Add( Prefix + AName + '.BkColor := ' + Color2Str( BkColor ) + ';' );
|
|
{P}SL.Add( ' L($' + IntToHex( BkColor, 6 ) + ') C1 TImageList_.SetBkColor<2>' );
|
|
end;
|
|
if FImgWidth <> 32 then
|
|
//SL.Add( Prefix + ' ' + AName + '.ImgWidth := ' + IntToStr( FImgWidth ) + ';' );
|
|
{P}SL.Add( ' L(' + IntToStr( FImgWidth ) + ') C1 TImageList_.SetImgWidth<2>' );
|
|
if FImgHeight <> 32 then
|
|
//SL.Add( Prefix + ' ' + AName + '.ImgHeight := ' + IntToStr( FImgHeight ) + ';' );
|
|
{P}SL.Add( ' L(' + IntToStr( FImgHeight ) + ') C1 TImageList_.SetImgHeight<2>' );
|
|
end;
|
|
if (FBitmap.Width <> 0) and (FBitmap.Height <> 0) then
|
|
begin
|
|
if (FImgHeight = 32) and (FImgWidth <> FImgHeight) then
|
|
//SL.Add( Prefix + ' ' + AName + '.ImgWidth := ' + IntToStr( FImgWidth ) + ';' );
|
|
{P}SL.Add( ' L(' + IntToStr( FImgWidth ) + ') C1 TImageList_.SetImgWidth<2>' );
|
|
RsrcName := UpperCase( ParentKOLForm.FormName + '_' + Name );
|
|
RsrcFile := ParentKOLForm.FormName + '_' + Name;
|
|
SL.Add( Prefix + ' {$R ' + RsrcFile + '.res}' );
|
|
if Masked then
|
|
{SL.Add( Prefix + AName + '.AddMasked( LoadBmp( hInstance, ''' +
|
|
RsrcName + ''', ' +
|
|
AName + ' ), ' + Color2Str( TransparentColor ) + ' );' )}
|
|
{P}SL.Add( ' L($' + IntToHex( TransparentColor, 6 ) + ')' +
|
|
' C1 LoadStr ''' + RsrcName + ''' #0 LoadHInstance' +
|
|
' LoadBmp<3> RESULT' +
|
|
' C2 TImageList.AddMasked<3>' )
|
|
else
|
|
{SL.Add( Prefix + AName + '.Add( LoadBmp( hInstance, ''' +
|
|
RsrcName + ''', ' +
|
|
AName + ' ), 0 );' );}
|
|
{P}SL.Add( ' L(0) C1 LoadStr ''' + RsrcName + ''' #0 LoadHInstance' +
|
|
' LoadBmp<3> RESULT C2 TImageList.Add<3>' );
|
|
//Rpt( 'Generating resource: ' + ProjectSourcePath + RsrcFile + '.res' );
|
|
GenerateBitmapResource( FBitmap, RsrcName, RsrcFile, fUpdated, AllowCompression );
|
|
end;
|
|
end;
|
|
|
|
procedure TKOLImageList.SetAllowCompression(const Value: Boolean);
|
|
begin
|
|
if FAllowCompression = Value then Exit;
|
|
FAllowCompression := Value;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLImageList.SetBitmap(const Value: TBitmap);
|
|
{$IFDEF _D2}
|
|
var KOLBmp: KOL.PBitmap;
|
|
{$ENDIF}
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLImageList.SetBitmap', 0
|
|
@@e_signature:
|
|
end;
|
|
if FBitmap = Value then Exit;
|
|
FBitmap.Assign( Value );
|
|
if (FBitmap.Height <> 0) and (FBitmap.Width <> 0) then
|
|
begin
|
|
FImgHeight := FBitmap.Height;
|
|
{AK->}if FImgWidth<=0 then{<-AK} FImgWidth := FImgHeight;
|
|
FCount := FBitmap.Width div FImgWidth;
|
|
end;
|
|
{$IFDEF _D2}
|
|
KOLBmp := NewBitmap( Value.Width, Value.Height );
|
|
TRY
|
|
KOLBmp.HandleType := KOL.bmDIB;
|
|
KOLBmp.PixelFormat := KOL.pf32bit;
|
|
BitBlt( KOLBmp.Canvas.Handle, 0, 0, Value.Width, Value.Height,
|
|
Value.Canvas.Handle, 0, 0, SrcCopy );
|
|
case CountSystemColorsUsedInBitmap( KOLBmp ) of
|
|
KOL.pf1bit, KOL.pf4bit: Colors := ilcColor4;
|
|
KOL.pf8bit: Colors := ilcColor8;
|
|
KOL.pf32bit: Colors := ilcColor32;
|
|
else Colors := ilcColor24;
|
|
end;
|
|
FINALLY
|
|
KOLBmp.Free;
|
|
END;
|
|
{$ELSE}
|
|
if FBitmap.HandleType = bmDDB then
|
|
Colors := ilcColorDDB
|
|
else
|
|
begin
|
|
//if Colors = ilcDefault then
|
|
case FBitmap.PixelFormat of
|
|
pf1bit,
|
|
pf4bit: if Colors < ilcColor4 then Colors := ilcColor4;
|
|
pf8bit: if Colors < ilcColor8 then Colors := ilcColor8;
|
|
pf15bit, pf16bit: if Colors < ilcColor16 then Colors := ilcColor16;
|
|
pf32bit:if Colors < ilcColor32 then Colors := ilcColor32;
|
|
//pf24bit:
|
|
else if Colors < ilcColor24 then Colors := ilcColor24;
|
|
end;
|
|
end;
|
|
{$ENDIF}
|
|
if (FBitmap.Height <> 0) and (FBitmap.Width <> 0) then
|
|
begin
|
|
TransparentColor := FBitmap.Canvas.Pixels[ 0, FBitmap.Height - 1 ];
|
|
end;
|
|
if FKOLImgList <> nil then
|
|
AssignBitmapToKOLImgList;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLImageList.SetBkColor(const Value: TColor);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLImageList.SetBkColor', 0
|
|
@@e_signature:
|
|
end;
|
|
FBkColor := Value;
|
|
AssignBitmapToKOLImgList;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLImageList.SetColors(const Value: TImageListColors);
|
|
//{$IFDEF _D2}
|
|
var KOLBmp: KOL.PBitmap;
|
|
//{$ENDIF}
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLImageList.SetColors', 0
|
|
@@e_signature:
|
|
end;
|
|
if FColors = Value then Exit;
|
|
FColors := Value;
|
|
if FBitmap = nil then Exit;
|
|
if FBitmap.Width * FBitmap.Height = 0 then Exit;
|
|
//{$IFDEF _D2}
|
|
KOLBmp := NewBitmap( FBitmap.Width, FBitmap.Height );
|
|
TRY
|
|
KOLBmp.HandleType := KOL.bmDIB;
|
|
KOLBmp.PixelFormat := KOL.pf32bit;
|
|
BitBlt( KOLBmp.Canvas.Handle, 0, 0, FBitmap.Width, FBitmap.Height,
|
|
FBitmap.Canvas.Handle, 0, 0, SrcCopy );
|
|
case Value of
|
|
ilcColor4: KOLBmp.PixelFormat := KOL.pf4bit;
|
|
ilcColor8: KOLBmp.PixelFormat := KOL.pf8bit;
|
|
ilcColor24: KOLBmp.PixelFormat := KOL.pf24bit;
|
|
ilcColor32: KOLBmp.PixelFormat := KOL.pf32bit;
|
|
else KOLBmp.HandleType := KOL.bmDDB;
|
|
end;
|
|
FBitmap.Handle := KOLBmp.ReleaseHandle;
|
|
FINALLY
|
|
KOLBmp.Free;
|
|
END;
|
|
(*{$ELSE}
|
|
if Assigned( FBitmap ) then
|
|
begin
|
|
if FColors = ilcColorDDB then
|
|
FBitmap.HandleType := bmDDB
|
|
else
|
|
begin
|
|
FBitmap.HandleType := bmDIB;
|
|
case Value of
|
|
ilcColor4: FBitmap.PixelFormat := pf4bit;
|
|
ilcColor8: FBitmap.PixelFormat := pf8bit;
|
|
ilcColor24: FBitmap.PixelFormat := pf24bit;
|
|
ilcColor32: FBitmap.PixelFormat := pf32bit;
|
|
end;
|
|
end;
|
|
end;
|
|
{$ENDIF}*)
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLImageList.SetCount(const Value: Integer);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLImageList.SetCount', 0
|
|
@@e_signature:
|
|
end;
|
|
FCount := Value;
|
|
if Value > 0 then
|
|
begin
|
|
{AK->} if FImgWidth <= 0 then {<-AK} // change by Andrzej Kubaszek 28-Jan-2002
|
|
FImgWidth := FImgHeight;
|
|
if FBitmap <> nil then
|
|
if FBitmap.Width > 0 then
|
|
FImgWidth := FBitmap.Width div FCount;
|
|
end;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLImageList.SetForce32bit(const Value: Boolean);
|
|
begin
|
|
if FForce32bit = Value then Exit;
|
|
FForce32bit := Value;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLImageList.SetImgHeight(Value: Integer);
|
|
var I: Integer;
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLImageList.SetImgHeight', 0
|
|
@@e_signature:
|
|
end;
|
|
if Value < 0 then
|
|
Value := 0;
|
|
if SystemImageList then
|
|
if Value >= 32 then
|
|
Value := 32
|
|
else
|
|
Value := 16
|
|
else
|
|
if FBitmap <> nil then
|
|
begin
|
|
if not FBitmap.Empty then
|
|
if (FBitmap.Height <> 0) and (FBitmap.Width <> 0) then
|
|
if Value <> FBitmap.Height then
|
|
Value := FBitmap.Height;
|
|
end;
|
|
|
|
if FImgHeight = Value then Exit;
|
|
if Count > 0 then
|
|
if not( csLoading in ComponentState ) then
|
|
begin
|
|
I := MessageBox( 0, 'Changing image list height will lead to clearing it. Are ' +
|
|
'You sure You want to change height now?',
|
|
'TKOLImageList.ImgHeight change', MB_YESNO or
|
|
MB_DEFBUTTON2 or MB_SETFOREGROUND );
|
|
if I = ID_NO then Exit;
|
|
Clear;
|
|
end;
|
|
FImgHeight := Value;
|
|
if SystemImageList then
|
|
FImgWidth := FImgHeight;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLImageList.SetImgWidth(Value: Integer);
|
|
var I: Integer;
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLImageList.SetImgWidth', 0
|
|
@@e_signature:
|
|
end;
|
|
if Value < 0 then Value := 0;
|
|
if SystemImageList then
|
|
begin
|
|
if Value >= 32 then
|
|
Value := 32
|
|
else
|
|
Value := 16;
|
|
end
|
|
else
|
|
if FBitmap <> nil then
|
|
begin
|
|
if not FBitmap.Empty then
|
|
if (FBitmap.Width <> 0) and (FBitmap.Height <> 0) then
|
|
if Value > FBitmap.Width then
|
|
Value := FBitmap.Width;
|
|
end;
|
|
|
|
if FImgWidth = Value then Exit;
|
|
if Count > 0 then
|
|
if not( csLoading in ComponentState ) then
|
|
begin
|
|
I := MessageBox( 0, 'Changing image list width will lead to clearing it. Are ' +
|
|
'You sure You want to change width now?',
|
|
'TKOLImageList.ImgWidth change', MB_YESNO or
|
|
MB_DEFBUTTON2 or MB_SETFOREGROUND );
|
|
if I = ID_NO then Exit;
|
|
Clear;
|
|
end;
|
|
FImgWidth := Value;
|
|
if SystemImageList then
|
|
FImgHeight := FImgWidth;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLImageList.SetMasked(const Value: Boolean);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLImageList.SetMasked', 0
|
|
@@e_signature:
|
|
end;
|
|
FMasked := Value;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLImageList.SetSystemImageList(const Value: Boolean);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLImageList.SetSystemImageList', 0
|
|
@@e_signature:
|
|
end;
|
|
if Value = FSystemImageList then Exit;
|
|
FSystemImageList := Value;
|
|
if Value then
|
|
begin
|
|
Clear;
|
|
SetImgHeight( ImgHeight );
|
|
SetImgWidth( ImgHeight );
|
|
end
|
|
else
|
|
Clear;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLImageList.SetTransparentColor(const Value: TColor);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLImageList.SetTransparentColor', 0
|
|
@@e_signature:
|
|
end;
|
|
FTransparentColor := Value;
|
|
AssignBitmapToKOLImgList;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLImageList.SetupFirst(SL: TStringList; const AName,
|
|
AParent, Prefix: String);
|
|
const Booleans: array[ Boolean ] of String = ( 'False', 'True' );
|
|
const ColorsValues: array[ TImageListColors ] of String = ( 'ilcColor', 'ilcColor4',
|
|
'ilcColor8', 'ilcColor16', 'ilcColor24', 'ilcColor32', 'ilcColorDDB',
|
|
'ilcDefault' );
|
|
var RsrcName, RsrcFile, is32: String;
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLImageList.SetupFirst', 0
|
|
@@e_signature:
|
|
end;
|
|
SL.Add( Prefix + AName + ' := NewImageList( ' + AParent + ' );' );
|
|
|
|
GenerateTag( SL, AName, Prefix );
|
|
if SystemImageList then
|
|
SL.Add( Prefix + AName + '.LoadSystemIcons( ' + Booleans[ ImgHeight = 16 ] + ' );' )
|
|
else
|
|
begin
|
|
if Colors <> ilcDefault then
|
|
SL.Add( Prefix + AName + '.Colors := ' + ColorsValues[ Colors ] + ';' );
|
|
if not Masked then
|
|
begin
|
|
SL.Add( Prefix + AName + '.Masked := FALSE;' );
|
|
if BkColor <> clNone then
|
|
SL.Add( Prefix + AName + '.BkColor := ' + Color2Str( BkColor ) +
|
|
';' );
|
|
end;
|
|
if FImgWidth <> 32 then
|
|
SL.Add( Prefix + ' ' + AName + '.ImgWidth := ' + IntToStr( FImgWidth ) + ';' );
|
|
if FImgHeight <> 32 then
|
|
SL.Add( Prefix + ' ' + AName + '.ImgHeight := ' + IntToStr( FImgHeight ) + ';' );
|
|
end;
|
|
is32 := '';
|
|
if Force32bit then is32 := '32';
|
|
if (FBitmap.Width <> 0) and (FBitmap.Height <> 0) then
|
|
begin
|
|
if (FImgHeight = 32) and (FImgWidth <> FImgHeight) then
|
|
SL.Add( Prefix + ' ' + AName + '.ImgWidth := ' + IntToStr( FImgWidth ) + ';' );
|
|
RsrcName := UpperCase( ParentKOLForm.FormName + '_' + Name );
|
|
RsrcFile := ParentKOLForm.FormName + '_' + Name;
|
|
SL.Add( Prefix + ' {$R ' + RsrcFile + '.res}' );
|
|
if Masked then
|
|
SL.Add( Prefix + AName + '.AddMasked( LoadBmp' + is32 + '( hInstance, ''' +
|
|
RsrcName + ''', ' +
|
|
AName + ' ), ' + Color2Str( TransparentColor ) + ' );' )
|
|
else
|
|
SL.Add( Prefix + AName + '.Add( LoadBmp' + is32 + '( hInstance, ''' +
|
|
RsrcName + ''', ' +
|
|
AName + ' ), 0 );' );
|
|
//Rpt( 'Generating resource: ' + ProjectSourcePath + RsrcFile + '.res' );
|
|
GenerateBitmapResource( FBitmap, RsrcName, RsrcFile, fUpdated, AllowCompression );
|
|
end;
|
|
end;
|
|
|
|
{ TKOLImageListEditor }
|
|
|
|
procedure TKOLImageListEditor.Edit;
|
|
var IL: TImageList; //Invisible;
|
|
{$IFDEF _D6orHigher}
|
|
ILCE: IComponentEditor;
|
|
{$ELSE}
|
|
ILCE: TComponentEditor;
|
|
{$ENDIF}
|
|
ILH: THandle;
|
|
KIL: TKOLImageList;
|
|
KName: String;
|
|
I: Integer;
|
|
//TrColor: TColor;
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLImageListEditor.Edit', 0
|
|
@@e_signature:
|
|
end;
|
|
if Component = nil then Exit;
|
|
if not ( Component is TKOLImageList ) then Exit;
|
|
KIL := Component as TKOLImageList;
|
|
if KIL.SystemImageList then
|
|
begin
|
|
ShowMessage( 'It is not possible to edit system image list!' );
|
|
Exit;
|
|
end;
|
|
IL := TImageList{Invisible}.Create( {KIL.ParentForm} KIL );
|
|
KName := KIL.Name;
|
|
IL.Name := KName + '_edit';
|
|
{IL.Width := KIL.ImgWidth;
|
|
IL.Height := KIL.ImgHeight;}
|
|
try
|
|
|
|
{$IFNDEF _D2}
|
|
//KIL.Bitmap.HandleType := bmDIB;
|
|
CASE KIL.Colors OF
|
|
ilcColor4 : I := ILC_COLOR4;
|
|
ilcColor8 : I := ILC_COLOR8;
|
|
ilcColor16 : I := ILC_COLOR16;
|
|
ilcColor24 : I := ILC_COLOR24;
|
|
ilcColor32 : I := ILC_COLOR32;
|
|
else I := ILC_COLOR;
|
|
END;
|
|
{case KIL.Bitmap.PixelFormat of
|
|
pf1bit, pf4bit: I := ILC_COLOR4;
|
|
pf8bit: I := ILC_COLOR8;
|
|
pf15bit, pf16bit: I := ILC_COLOR16;
|
|
pf24bit: I := ILC_COLOR24;
|
|
pf32bit: I := ILC_COLOR32;
|
|
else I := ILC_COLOR;
|
|
end;}
|
|
{$ELSE}
|
|
I := ILC_COLOR;
|
|
{$ENDIF}
|
|
|
|
//I := ILC_COLOR8;
|
|
if KIL.TransparentColor = clNone then
|
|
ILH := ImageList_Create( KIL.ImgWidth, KIL.ImgHeight, I, KIL.Count, 1 )
|
|
else
|
|
ILH := ImageList_Create( KIL.ImgWidth, KIL.ImgHeight, I or ILC_MASK,
|
|
KIL.Count, 1 );
|
|
if ILH <> 0 then
|
|
begin
|
|
if KIL.Masked then
|
|
ImageList_AddMasked( ILH, KIL.Bitmap.Handle, Color2RGB( KIL.TransparentColor ) )
|
|
else
|
|
ImageList_Add( ILH, KIL.Bitmap.Handle, 0 );
|
|
{
|
|
if KIL.TransparentColor = clNone then
|
|
ImageList_Add( ILH, KIL.Bitmap.Handle, 0 )
|
|
else
|
|
begin
|
|
TrColor := KIL.TransparentColor;
|
|
Tmp := TBitmap.Create;
|
|
Tmp.Assign( KIL.Bitmap );
|
|
Tmp.Mask( TrColor );
|
|
try
|
|
//TrColor := KIL.Bitmap.TransparentColor;
|
|
//TrColor := KIL.Bitmap.Canvas.Pixels[ 0, KIL.Bitmap.Height - 1 ];
|
|
//ShowMessage( 'Èñïîëüçóåì ïðîçðà÷íûé öâåò: ' + Int2Hex( Color2RGB( TrColor ), 8 ) );
|
|
//ImageList_AddMasked( ILH, KIL.Bitmap.Handle, Color2RGB( TrColor ) );
|
|
ImageList_Add( ILH, KIL.Bitmap.Handle, Tmp.Handle );
|
|
finally
|
|
Tmp.Free;
|
|
end;
|
|
end;
|
|
}
|
|
IL.Handle := ILH;
|
|
IL.ShareImages := False;
|
|
//Rpt( 'Attempt to get component editor' );
|
|
ILCE := GetComponentEditor( IL, Designer );
|
|
if ILCE <> nil then
|
|
try
|
|
//Rpt( 'ILCE obtained, try to call editor' );
|
|
ILCE.Edit;
|
|
|
|
Rpt( 'Image list ' + KIL.Name + ' edited.', WHITE );
|
|
if KIL.Bitmap.Empty then
|
|
begin
|
|
KIL.Bitmap := TBitmap.Create;
|
|
//KIL.Bitmap.PixelFormat := pf24bit;
|
|
Rpt( 'Bitmap was empty - created.', WHITE );
|
|
end;
|
|
KIL.Bitmap.Height := IL.Height;
|
|
KIL.Bitmap.Width := IL.Width * IL.Count;
|
|
KIL.Bitmap.Canvas.Brush.Color := KIL.TransparentColor;
|
|
KIL.Bitmap.Canvas.FillRect( Rect( 0, 0, KIL.Bitmap.Width, KIL.Bitmap.Height ) );
|
|
for I := 0 to IL.Count - 1 do
|
|
IL.Draw( KIL.Bitmap.Canvas, I * IL.Width, 0, I );
|
|
|
|
|
|
KIL.FCount := IL.Count;
|
|
KIL.AssignBitmapToKOLImgList;
|
|
KIL.Change;
|
|
finally
|
|
{$IFNDEF _D6orHigher}
|
|
ILCE.Free;
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
finally
|
|
IL.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TKOLImageListEditor.ExecuteVerb(Index: Integer);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLImageListEditor.ExecuteVerb', 0
|
|
@@e_signature:
|
|
end;
|
|
Edit;
|
|
end;
|
|
|
|
function TKOLImageListEditor.GetVerb(Index: Integer): string;
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLImageListEditor.GetVerb', 0
|
|
@@e_signature:
|
|
end;
|
|
Result := '&Editor';
|
|
end;
|
|
|
|
function TKOLImageListEditor.GetVerbCount: Integer;
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLImageListEditor.GetVerbCount', 0
|
|
@@e_signature:
|
|
end;
|
|
Result := 1;
|
|
end;
|
|
|
|
{ TKOLOpenSaveDialog }
|
|
|
|
constructor TKOLOpenSaveDialog.Create(AOwner: TComponent);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLOpenSaveDialog.Create', 0
|
|
@@e_signature:
|
|
end;
|
|
inherited;
|
|
Options := DefOpenSaveDlgOptions;
|
|
OpenDialog := TRUE;
|
|
end;
|
|
|
|
function TKOLOpenSaveDialog.Pcode_Generate: Boolean;
|
|
begin
|
|
Result := TRUE;
|
|
end;
|
|
|
|
procedure TKOLOpenSaveDialog.P_SetupFirst(SL: TStringList; const AName,
|
|
AParent, Prefix: String);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLOpenSaveDialog.P_SetupFirst', 0
|
|
@@e_signature:
|
|
end;
|
|
(*S := '';
|
|
if Options <> DefOpenSaveDlgOptions then
|
|
begin
|
|
if OSCreatePrompt in Options then
|
|
S := 'OSCreatePrompt';
|
|
if OSExtensionDiffent in Options then
|
|
S := S + ', OSExtensionDiffent';
|
|
if OSFileMustExist in Options then
|
|
S := S + ', OSFileMustExist';
|
|
if OSHideReadonly in Options then
|
|
S := S + ', OSHideReadonly';
|
|
if OSNoChangedir in Options then
|
|
S := S + ', OSNoChangedir';
|
|
if OSNoReferenceLinks in Options then
|
|
S := S + ', OSNoReferenceLinks';
|
|
if OSAllowMultiSelect in Options then
|
|
S := S + ', OSAllowMultiSelect';
|
|
if OSNoNetworkButton in Options then
|
|
S := S + ', OSNoNetworkButton';
|
|
if OSNoReadonlyReturn in Options then
|
|
S := S + ', OSNoReadonlyReturn';
|
|
if OSOverwritePrompt in Options then
|
|
S := S + ', OSOverwritePrompt';
|
|
if OSPathMustExist in Options then
|
|
S := S + ', OSPathMustExist';
|
|
if OSReadonly in Options then
|
|
S := S + ', OSReadonly';
|
|
if OSNoValidate in Options then
|
|
S := S + ', OSNoValidate';
|
|
if OSTemplate in Options then
|
|
S := S + ', OSTemplate';
|
|
if OSHook in Options then
|
|
S := S + ', OSHook';
|
|
if S <> '' then
|
|
if S[ 1 ] = ',' then
|
|
S := Trim( Copy( S, 2, MaxInt ) );
|
|
end;
|
|
SL.Add( Prefix + AName + ' := NewOpenSaveDialog( ' + StringConstant( 'Title', Title )
|
|
+ ', ' + StringConstant( 'InitialDir', InitialDir ) + ', [ ' + S + ' ] );' );
|
|
*)
|
|
{P}SL.Add( ' L(' + IntToStr( PWord( @ Options )^ ) + ') ' +
|
|
P_StringConstant( 'InitialDir', InitialDir ) + ' C2R ' +
|
|
P_StringConstant( 'Title', Title ) + ' C2R ' +
|
|
' NewOpenSaveDialog<3> RESULT DUP LoadSELF AddWord_Store ##T' +
|
|
ParentKOLForm.FormName + '.' + Name +
|
|
' L(2) R2CN DelAnsiStr DelAnsiStr' );
|
|
//GenerateTag( SL, AName, Prefix );
|
|
{P}P_GenerateTag( SL, AName, Prefix );
|
|
if Filter <> '' then
|
|
//SL.Add( Prefix + ' ' + AName + '.Filter := ' + StringConstant( 'Filter', Filter ) + ';' );
|
|
{P}SL.Add( P_StringConstant( 'Filter', Filter ) +
|
|
' C2 AddByte_Store #TOpenSaveDialog_.FFilter DEL' );
|
|
if not OpenDialog then
|
|
//SL.Add( Prefix + ' ' + AName + '.OpenDialog := FALSE;' );
|
|
{P}SL.Add( ' L(0) C1 AddByte_StoreB #TOpenSaveDialog_.FOpenDialog' );
|
|
if DefExtension <> '' then
|
|
//SL.Add( Prefix + ' ' + AName + '.DefExtension := ' + StringConstant( 'DefExtension', DefExtension ) + ';' );
|
|
{P}SL.Add( P_StringConstant( 'DefExtension', DefExtension ) +
|
|
' C2 AddByte_Store #TOpenSaveDialog_.FDefExtension DEL' );
|
|
if TemplateName <> '' then
|
|
//SL.Add( Prefix + ' ' + AName + '.TemplateName := ' + StringConstant( 'TemplateName', TemplateName ) + ';' );
|
|
{P}SL.Add( P_StringConstant( 'TemplateName', TemplateName ) +
|
|
' C2 AddByte_Store #TOpenSaveDialog_.FTemplateName DEL' );
|
|
if NoPlaceBar then
|
|
begin
|
|
//SL.Add( '{$IFDEF OpenSaveDialog_Extended}' );
|
|
{P}SL.Add( ' IFDEF(OpenSaveDialog_Extended)' );
|
|
//SL.Add( Prefix + ' ' + AName + '.NoPlaceBar := TRUE;' );
|
|
{P}SL.Add( ' L(1) C1 AddByte_StoreB #TOpenSaveDialog_.NoPlaceBar' );
|
|
//SL.Add( '{$ENDIF}' );
|
|
{P}SL.Add( ' ENDIF' );
|
|
end;
|
|
|
|
end;
|
|
|
|
procedure TKOLOpenSaveDialog.P_SetupLast(SL: TStringList; const AName,
|
|
AParent, Prefix: String);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLOpenSaveDialog.SetupLast', 0
|
|
@@e_signature:
|
|
end;
|
|
//SL.Add( Prefix + ' ' + AName + '.WndOwner := Result.Form.GetWindowHandle;' );
|
|
P_ProvideFakeType( SL, 'type TOpenSaveDialog_ = object(TOpenSaveDialog) end;' );
|
|
{P}SL.Add( ' LoadSELF AddByte_LoadRef #T' + ParentKOLForm.FormName + '.Form' +
|
|
' TControl.GetWindowHandle<1> RESULT ' +
|
|
'LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.formName + '.' + Name +
|
|
' AddWord_Store ##TOpenSaveDialog_.fWnd' );
|
|
end;
|
|
|
|
procedure TKOLOpenSaveDialog.SetDefExtension(const Value: String);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLOpenSaveDialog.SetDefExtension', 0
|
|
@@e_signature:
|
|
end;
|
|
FDefExtension := Value;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLOpenSaveDialog.SetFilter(const Value: String);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLOpenSaveDialog.SetFilter', 0
|
|
@@e_signature:
|
|
end;
|
|
FFilter := Value;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLOpenSaveDialog.SetFilterIndex(const Value: Integer);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLOpenSaveDialog.SetFilterIndex', 0
|
|
@@e_signature:
|
|
end;
|
|
FFilterIndex := Value;
|
|
if FFilterIndex < 0 then
|
|
FFilterIndex := 0;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLOpenSaveDialog.SetInitialDir(const Value: String);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLOpenSaveDialog.SetInitialDir', 0
|
|
@@e_signature:
|
|
end;
|
|
FInitialDir := Value;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLOpenSaveDialog.SetNoPlaceBar(const Value: Boolean);
|
|
begin
|
|
FNoPlaceBar := Value;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLOpenSaveDialog.SetOpenDialog(const Value: Boolean);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLOpenSaveDialog.SetOpenDialog', 0
|
|
@@e_signature:
|
|
end;
|
|
FOpenDialog := Value;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLOpenSaveDialog.SetOptions(const Value: TOpenSaveOptions);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLOpenSaveDialog.SetOptions', 0
|
|
@@e_signature:
|
|
end;
|
|
FOptions := Value;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLOpenSaveDialog.SetTemplateName(const Value: String);
|
|
begin
|
|
FTemplateName := Value;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLOpenSaveDialog.SetTitle(const Value: String);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLOpenSaveDialog.SetTitle', 0
|
|
@@e_signature:
|
|
end;
|
|
FTitle := Value;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLOpenSaveDialog.SetupFirst(SL: TStringList; const AName,
|
|
AParent, Prefix: String);
|
|
var
|
|
{$IFDEF _D2009orHigher}
|
|
C, C2: WideString;
|
|
i : integer;
|
|
{$ELSE}
|
|
C: string;
|
|
{$ENDIF}
|
|
S: String;
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLOpenSaveDialog.SetupFirst', 0
|
|
@@e_signature:
|
|
end;
|
|
S := '';
|
|
if Options <> DefOpenSaveDlgOptions then
|
|
begin
|
|
if OSCreatePrompt in Options then
|
|
S := 'OSCreatePrompt';
|
|
if OSExtensionDiffent in Options then
|
|
S := S + ', OSExtensionDiffent';
|
|
if OSFileMustExist in Options then
|
|
S := S + ', OSFileMustExist';
|
|
if OSHideReadonly in Options then
|
|
S := S + ', OSHideReadonly';
|
|
if OSNoChangedir in Options then
|
|
S := S + ', OSNoChangedir';
|
|
if OSNoReferenceLinks in Options then
|
|
S := S + ', OSNoReferenceLinks';
|
|
if OSAllowMultiSelect in Options then
|
|
S := S + ', OSAllowMultiSelect';
|
|
if OSNoNetworkButton in Options then
|
|
S := S + ', OSNoNetworkButton';
|
|
if OSNoReadonlyReturn in Options then
|
|
S := S + ', OSNoReadonlyReturn';
|
|
if OSOverwritePrompt in Options then
|
|
S := S + ', OSOverwritePrompt';
|
|
if OSPathMustExist in Options then
|
|
S := S + ', OSPathMustExist';
|
|
if OSReadonly in Options then
|
|
S := S + ', OSReadonly';
|
|
if OSNoValidate in Options then
|
|
S := S + ', OSNoValidate';
|
|
if OSTemplate in Options then
|
|
S := S + ', OSTemplate';
|
|
if OSHook in Options then
|
|
S := S + ', OSHook';
|
|
if S <> '' then
|
|
if S[ 1 ] = ',' then
|
|
S := Trim( Copy( S, 2, MaxInt ) );
|
|
end;
|
|
|
|
if (ParentKOLForm <> nil) and ParentKOLForm.AssignTextToControls then
|
|
C := StringConstant( 'Title', Title )
|
|
else
|
|
C := '''''';
|
|
{$IFDEF _D2009orHigher}
|
|
C2 := '';
|
|
for i := 2 to Length(C) - 1 do C2 := C2 + '#'+IntToStr(ord(C[i]));
|
|
C := C2;
|
|
{$ENDIF}
|
|
if C = '' then C := '''''';
|
|
SL.Add( Prefix + AName + ' := NewOpenSaveDialog( ' + C
|
|
+ ', ' + StringConstant( 'InitialDir', InitialDir ) + ', [ ' + S + ' ] );' );
|
|
|
|
GenerateTag( SL, AName, Prefix );
|
|
if (Filter <> '') and (ParentKOLForm <> nil) and ParentKOLForm.AssignTextToControls then
|
|
SL.Add( Prefix + ' ' + AName + '.Filter := ' + StringConstant( 'Filter', Filter ) + ';' );
|
|
if not OpenDialog then
|
|
SL.Add( Prefix + ' ' + AName + '.OpenDialog := FALSE;' );
|
|
if DefExtension <> '' then
|
|
SL.Add( Prefix + ' ' + AName + '.DefExtension := ' + StringConstant( 'DefExtension', DefExtension ) + ';' );
|
|
if TemplateName <> '' then
|
|
SL.Add( Prefix + ' ' + AName + '.TemplateName := ' + StringConstant( 'TemplateName', TemplateName ) + ';' );
|
|
if NoPlaceBar then
|
|
begin
|
|
SL.Add( '{$IFDEF OpenSaveDialog_Extended}' );
|
|
SL.Add( Prefix + ' ' + AName + '.NoPlaceBar := TRUE;' );
|
|
SL.Add( '{$ENDIF}' );
|
|
end;
|
|
end;
|
|
|
|
{ TKOLFileFilter }
|
|
|
|
procedure TKOLOpenSaveDialog.SetupLast(SL: TStringList; const AName,
|
|
AParent, Prefix: String);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLOpenSaveDialog.SetupLast', 0
|
|
@@e_signature:
|
|
end;
|
|
SL.Add( Prefix + ' ' + AName + '.WndOwner := Result.Form.GetWindowHandle;' );
|
|
end;
|
|
|
|
{ TKOLFileFilter }
|
|
|
|
procedure TKOLFileFilter.Edit;
|
|
var Dlg: TfmFileFilterEditor;
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLFileFilter.Edit', 0
|
|
@@e_signature:
|
|
end;
|
|
if GetComponent( 0 ) = nil then Exit;
|
|
Dlg := TfmFileFilterEditor.Create( Application );
|
|
Dlg.Caption := (GetComponent( 0 ) as TComponent).Name + '.Filter';
|
|
Dlg.Filter := GetStrValue;
|
|
Dlg.ShowModal;
|
|
if Dlg.ModalResult = mrOK then
|
|
begin
|
|
SetStrValue( Dlg.Filter );
|
|
end;
|
|
Dlg.Free;
|
|
end;
|
|
|
|
function TKOLFileFilter.GetAttributes: TPropertyAttributes;
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLFileFilter.GetAttributes', 0
|
|
@@e_signature:
|
|
end;
|
|
Result := [ paDialog, paReadOnly ];
|
|
end;
|
|
|
|
{ TKOLOpenDirDialog }
|
|
|
|
function TKOLOpenDirDialog.AdditionalUnits: String;
|
|
begin
|
|
Result := '';
|
|
if AltDialog then
|
|
Result := ', KOLDirDlgEx';
|
|
end;
|
|
|
|
procedure TKOLOpenDirDialog.AssignEvents(SL: TStringList;
|
|
const AName: String);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLOpenDirDialog.AssignEvents', 0
|
|
@@e_signature:
|
|
end;
|
|
inherited;
|
|
if not AltDialog then
|
|
DoAssignEvents( SL, AName,
|
|
[ 'OnSelChanged' ],
|
|
[ @ OnSelChanged ] );
|
|
end;
|
|
|
|
constructor TKOLOpenDirDialog.Create(AOwner: TComponent);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLOpenDirDialog.Create', 0
|
|
@@e_signature:
|
|
end;
|
|
inherited;
|
|
Options := [ odOnlySystemDirs ];
|
|
end;
|
|
|
|
function TKOLOpenDirDialog.Pcode_Generate: Boolean;
|
|
begin
|
|
Result := TRUE;
|
|
end;
|
|
|
|
function TKOLOpenDirDialog.P_AssignEvents(SL: TStringList;
|
|
const AName: String; CheckOnly: Boolean): Boolean;
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLOpenDirDialog.P_AssignEvents', 0
|
|
@@e_signature:
|
|
end;
|
|
Result := inherited P_AssignEvents( SL, AName, CheckOnly );
|
|
if Result and CheckOnly then Exit;
|
|
if AltDialog then Exit;
|
|
|
|
if P_DoAssignEvents( SL, AName,
|
|
[ 'OnSelChanged' ],
|
|
[ @ OnSelChanged ],
|
|
[ TRUE ], CheckOnly ) then Exit;
|
|
Result := FALSE;
|
|
end;
|
|
|
|
procedure TKOLOpenDirDialog.P_SetupFirst(SL: TStringList; const AName,
|
|
AParent, Prefix: String);
|
|
//var S: String;
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLOpenDirDialog.P_SetupFirst', 0
|
|
@@e_signature:
|
|
end;
|
|
{if Options <> [ odOnlySystemDirs ] then
|
|
begin
|
|
S := '';
|
|
if odBrowseForComputer in Options then
|
|
S := 'odBrowseForComputer';
|
|
if odBrowseForPrinter in Options then
|
|
S := S + ', odBrowseForPrinter';
|
|
if odDontGoBelowDomain in Options then
|
|
S := S + ', odDontGoBelowDomain';
|
|
if odOnlyFileSystemAncestors in Options then
|
|
S := S + ', odOnlyFileSystemAncestors';
|
|
if odOnlySystemDirs in Options then
|
|
S := S + ', odOnlySystemDirs';
|
|
if odStatusText in Options then
|
|
S := S + ', odStatusText';
|
|
if odBrowseIncludeFiles in Options then
|
|
S := S + ', odBrowseIncludeFiles';
|
|
if odEditBox in Options then
|
|
S := S + ', odEditBox';
|
|
if odNewDialogStyle in Options then
|
|
S := S + ', odNewDialogStyle';
|
|
if S <> '' then
|
|
if S[ 1 ] = ',' then
|
|
S := Trim( Copy( S, 2, MaxInt ) );
|
|
end;
|
|
if AltDialog then
|
|
begin
|
|
SL.Add( Prefix + AName + ' := NewOpenDirDialogEx;' );
|
|
if Title <> '' then
|
|
SL.Add( Prefix + AName + '.Title := ' + StringConstant( 'Title', Title ) +
|
|
';' );
|
|
end
|
|
else
|
|
SL.Add( Prefix + AName + ' := NewOpenDirDialog( ' + StringConstant( 'Title', Title ) +
|
|
', [ ' + S + ' ] );' );}
|
|
if AltDialog then
|
|
begin
|
|
{P}SL.Add( ' NewOpenDirDialogEx<0> RESULT DUP LoadSELF AddWord_Store ##T' +
|
|
ParentKOLForm.FormName + '.' + Name );
|
|
if Title <> '' then
|
|
{P}SL.Add( P_StringConstant( 'Title', Title ) +
|
|
' C2 AddByte_Store #TOpenDirDialogEx_.Title DEL' );
|
|
end
|
|
else
|
|
begin
|
|
{P}SL.Add( ' L(' + IntToStr( PByte( @ Options )^ ) + ') ' +
|
|
P_StringConstant( 'Title', Title ) + ' C2R' +
|
|
' NewOpenDirDialog<2> RESULT DUP LoadSELF AddWord_Store ##T' +
|
|
ParentKOLForm.FormName + '.' + Name +
|
|
' R2C DelAnsiStr' );
|
|
end;
|
|
|
|
//GenerateTag( SL, AName, Prefix );
|
|
{P}P_GenerateTag( SL, AName, Prefix );
|
|
if InitialPath <> '' then
|
|
begin
|
|
//SL.Add( Prefix + ' ' + AName + '.InitialPath := ' + StringConstant( 'InitialPath', InitialPath )
|
|
// + ';' );
|
|
{P}SL.Add( P_StringConstant( 'InitialPath', InitialPath ) +
|
|
' C2 ' );
|
|
if AltDialog then
|
|
{P}SL.Add( ' TOpenDirDialogEx_.SetPath<2> DelAnsiStr' )
|
|
else
|
|
{P}SL.Add( ' TOpenDirDialog_.SetInitialPath<2> DelAnsiStr' );
|
|
end;
|
|
if CenterOnScreen and not AltDialog then
|
|
//SL.Add( Prefix + ' ' + AName + '.CenterOnScreen := TRUE;' );
|
|
{P}SL.Add( ' L(1) C1 TOpenDirDialog_.SetCenterOnScreen<2>' );
|
|
end;
|
|
|
|
procedure TKOLOpenDirDialog.P_SetupLast(SL: TStringList; const AName,
|
|
AParent, Prefix: String);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLOpenDirDialog.SetupLast', 0
|
|
@@e_signature:
|
|
end;
|
|
//SL.Add( Prefix + ' ' + AName + '.WndOwner := Result.Form.GetWindowHandle;' );
|
|
if AltDialog then
|
|
P_ProvideFakeType( SL, 'type TOpenDirDialogEx_ = object(TOpenDirDialogEx) end;' )
|
|
else
|
|
begin
|
|
P_ProvideFakeType( SL, 'type TOpenDirDialog_ = object(TOpenDirDialog) end;' );
|
|
{P}SL.Add( ' LoadSELF AddByte_LoadRef #T' + ParentKOLForm.formName + '.Form' );
|
|
{P}SL.Add( ' TControl.GetWindowHandle<1> RESULT ' +
|
|
'LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.formName + '.' + Name +
|
|
' AddWord_Store ##TOpenDirDialog_.fWnd' );
|
|
end;
|
|
end;
|
|
|
|
procedure TKOLOpenDirDialog.SetAltDialog(const Value: Boolean);
|
|
begin
|
|
FAltDialog := Value;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLOpenDirDialog.SetCenterOnScreen(const Value: Boolean);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLOpenDirDialog.SetCenterOnScreen', 0
|
|
@@e_signature:
|
|
end;
|
|
FCenterOnScreen := Value;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLOpenDirDialog.SetInitialPath(const Value: String);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLOpenDirDialog.SetInitialPath', 0
|
|
@@e_signature:
|
|
end;
|
|
FInitialPath := Value;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLOpenDirDialog.SetOnSelChanged(const Value: TOnODSelChange);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLOpenDirDialog.SetOnSelChanged', 0
|
|
@@e_signature:
|
|
end;
|
|
FOnSelChanged := Value;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLOpenDirDialog.SetOptions(const Value: TOpenDirOptions);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLOpenDirDialog.SetOptions', 0
|
|
@@e_signature:
|
|
end;
|
|
FOptions := Value;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLOpenDirDialog.SetTitle(const Value: String);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLOpenDirDialog.SetTitle', 0
|
|
@@e_signature:
|
|
end;
|
|
FTitle := Value;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLOpenDirDialog.SetupFirst(SL: TStringList; const AName,
|
|
AParent, Prefix: String);
|
|
var
|
|
{$IFDEF _D2009orHigher}
|
|
C, C2: WideString;
|
|
i : integer;
|
|
{$ELSE}
|
|
C: string;
|
|
{$ENDIF}
|
|
S: String;
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLOpenDirDialog.SetupFirst', 0
|
|
@@e_signature:
|
|
end;
|
|
if Options <> [ odOnlySystemDirs ] then
|
|
begin
|
|
S := '';
|
|
if odBrowseForComputer in Options then
|
|
S := 'odBrowseForComputer';
|
|
if odBrowseForPrinter in Options then
|
|
S := S + ', odBrowseForPrinter';
|
|
if odDontGoBelowDomain in Options then
|
|
S := S + ', odDontGoBelowDomain';
|
|
if odOnlyFileSystemAncestors in Options then
|
|
S := S + ', odOnlyFileSystemAncestors';
|
|
if odOnlySystemDirs in Options then
|
|
S := S + ', odOnlySystemDirs';
|
|
if odStatusText in Options then
|
|
S := S + ', odStatusText';
|
|
if odBrowseIncludeFiles in Options then
|
|
S := S + ', odBrowseIncludeFiles';
|
|
if odEditBox in Options then
|
|
S := S + ', odEditBox';
|
|
if odNewDialogStyle in Options then
|
|
S := S + ', odNewDialogStyle';
|
|
if S <> '' then
|
|
if S[ 1 ] = ',' then
|
|
S := Trim( Copy( S, 2, MaxInt ) );
|
|
end;
|
|
if AltDialog then
|
|
begin
|
|
SL.Add( Prefix + AName + ' := NewOpenDirDialogEx;' );
|
|
if (Title <> '') and (ParentKOLForm <> nil) and ParentKOLForm.AssignTextToControls then
|
|
begin
|
|
C := StringConstant( 'Title', Title );
|
|
{$IFDEF _D2009orHigher}
|
|
C2 := '';
|
|
for i := 2 to Length(C) - 1 do C2 := C2 + '#'+IntToStr(ord(C[i]));
|
|
C := C2;
|
|
{$ENDIF}
|
|
if C = '' then C := '''''';
|
|
SL.Add( Prefix + AName + '.Title := ' + C + ';' );
|
|
end;
|
|
end else
|
|
begin
|
|
if (ParentKOLForm <> nil) and ParentKOLForm.AssignTextToControls then
|
|
C := StringConstant( 'Title', Title )
|
|
else
|
|
C := '''''';
|
|
{$IFDEF _D2009orHigher}
|
|
C2 := '';
|
|
for i := 2 to Length(C) - 1 do C2 := C2 + '#'+IntToStr(ord(C[i]));
|
|
C := C2;
|
|
{$ENDIF}
|
|
if C = '' then C := '''''';
|
|
SL.Add( Prefix + AName + ' := NewOpenDirDialog( ' + C + ', [ ' + S + ' ] );' );
|
|
end;
|
|
|
|
GenerateTag( SL, AName, Prefix );
|
|
if InitialPath <> '' then
|
|
SL.Add( Prefix + ' ' + AName + '.InitialPath := ' + StringConstant( 'InitialPath', InitialPath )
|
|
+ ';' );
|
|
if CenterOnScreen and not AltDialog then
|
|
SL.Add( Prefix + ' ' + AName + '.CenterOnScreen := TRUE;' );
|
|
//AssignEvents( SL, AName );
|
|
end;
|
|
|
|
procedure TKOLOpenDirDialog.SetupLast(SL: TStringList; const AName,
|
|
AParent, Prefix: String);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLOpenDirDialog.SetupLast', 0
|
|
@@e_signature:
|
|
end;
|
|
if not AltDialog then
|
|
SL.Add( Prefix + ' ' + AName + '.WndOwner := Result.Form.GetWindowHandle;' );
|
|
end;
|
|
|
|
function TKOLOpenDirDialog.TypeName: String;
|
|
begin
|
|
Result := inherited TypeName;
|
|
if AltDialog then
|
|
Result := 'TOpenDirDialogEx';
|
|
end;
|
|
|
|
{ TKOLColorDialog }
|
|
|
|
constructor TKOLColorDialog.Create(AOwner: TComponent);
|
|
var I: Integer;
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLColorDialog.Create', 0
|
|
@@e_signature:
|
|
end;
|
|
inherited;
|
|
for I := 1 to 16 do
|
|
FCustomColors[ I ] := clWhite;
|
|
end;
|
|
|
|
function TKOLColorDialog.GetCustomColor( const Index: Integer ): TColor;
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLColorDialog.GetCustomColor', 0
|
|
@@e_signature:
|
|
end;
|
|
Result := FCustomColors[ Index ];
|
|
end;
|
|
|
|
function TKOLColorDialog.Pcode_Generate: Boolean;
|
|
begin
|
|
Result := TRUE;
|
|
end;
|
|
|
|
procedure TKOLColorDialog.P_SetupFirst(SL: TStringList; const AName,
|
|
AParent, Prefix: String);
|
|
var I: Integer;
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLColorDialog.P_SetupFirst', 0
|
|
@@e_signature:
|
|
end;
|
|
//SL.Add( Prefix + AName + ' := NewColorDialog( ' + ColorDialogOptions[ ColorCustomOption ] +
|
|
// ' );' );
|
|
{P}SL.Add( ' L(' + IntToStr( Integer( ColorCustomOption ) ) + ')' +
|
|
' NewColorDialog<1> RESULT' +
|
|
' DUP LoadSELF AddWord_Store ##T' + ParentKOLForm.FormName +
|
|
'.' + Name );
|
|
//GenerateTag( SL, AName, Prefix );
|
|
P_GenerateTag( SL, AName, Prefix );
|
|
for I := 1 to 16 do
|
|
begin
|
|
if FCustomColors[ I ] <> clWhite then
|
|
//SL.Add( Prefix + ' ' + AName + '.CustomColors[ ' + IntToStr( I ) + ' ] := ' +
|
|
// Color2Str( FCustomColors[ I ] ) + ';' );
|
|
{P}SL.Add( ' L(' + IntToStr( FCustomColors[ I ] ) + ')' +
|
|
' C2 L($' + IntToHex( I*4, 6 ) + ') AddWord_Store ##TColorDialog.' +
|
|
'CustomColors' );
|
|
end;
|
|
end;
|
|
|
|
procedure TKOLColorDialog.SetColorCustomOption(
|
|
const Value: TColorCustomOption);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLColorDialog.SetColorCustomOption', 0
|
|
@@e_signature:
|
|
end;
|
|
FColorCustomOption := Value;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLColorDialog.SetCustomColor(const Index: Integer;
|
|
const Value: TColor);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLColorDialog.SetCustomColor', 0
|
|
@@e_signature:
|
|
end;
|
|
FCustomColors[ Index ] := Value;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLColorDialog.SetupFirst(SL: TStringList; const AName, AParent,
|
|
Prefix: String);
|
|
const
|
|
ColorDialogOptions: array[ TColorCustomOption ] of String = ( 'ccoFullOpen',
|
|
'ccoShortOpen', 'ccoPreventFullOpen' );
|
|
var I: Integer;
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLColorDialog.SetupFirst', 0
|
|
@@e_signature:
|
|
end;
|
|
SL.Add( Prefix + AName + ' := NewColorDialog( ' + ColorDialogOptions[ ColorCustomOption ] +
|
|
' );' );
|
|
|
|
GenerateTag( SL, AName, Prefix );
|
|
for I := 1 to 16 do
|
|
begin
|
|
if FCustomColors[ I ] <> clWhite then
|
|
SL.Add( Prefix + ' ' + AName + '.CustomColors[ ' + IntToStr( I ) + ' ] := ' +
|
|
Color2Str( FCustomColors[ I ] ) + ';' );
|
|
end;
|
|
end;
|
|
|
|
{ TKOLTrayIcon }
|
|
|
|
procedure TKOLTrayIcon.AssignEvents(SL: TStringList; const AName: String);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLTrayIcon.AssignEvents', 0
|
|
@@e_signature:
|
|
end;
|
|
inherited;
|
|
DoAssignEvents( SL, AName,
|
|
[ 'OnMouse' ],
|
|
[ @ OnMouse ] );
|
|
end;
|
|
|
|
constructor TKOLTrayIcon.Create(AOwner: TComponent);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLTrayIcon.Create', 0
|
|
@@e_signature:
|
|
end;
|
|
inherited;
|
|
FIcon := TIcon.Create;
|
|
FActive := TRUE;
|
|
fCreationPriority := -10;
|
|
end;
|
|
|
|
destructor TKOLTrayIcon.Destroy;
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLTrayIcon.Destroy', 0
|
|
@@e_signature:
|
|
end;
|
|
FIcon.Free;
|
|
inherited;
|
|
end;
|
|
|
|
function TKOLTrayIcon.Pcode_Generate: Boolean;
|
|
begin
|
|
Result := TRUE;
|
|
end;
|
|
|
|
function TKOLTrayIcon.P_AssignEvents(SL: TStringList; const AName: String;
|
|
CheckOnly: Boolean): Boolean;
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLTrayIcon.P_AssignEvents', 0
|
|
@@e_signature:
|
|
end;
|
|
Result := inherited P_AssignEvents( SL, AName, CheckOnly );
|
|
if Result and CheckOnly then Exit;
|
|
if P_DoAssignEvents( SL, AName, [ 'OnMouse' ], [ @OnMouse ], [ FALSE ], CheckOnly )
|
|
and CheckOnly then Exit;
|
|
Result := FALSE;
|
|
end;
|
|
|
|
procedure TKOLTrayIcon.P_SetupFirst(SL: TStringList; const AName, AParent,
|
|
Prefix: String);
|
|
var RsrcName, RsrcFile: KOLString;
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLTrayIcon.SetupFirst', 0
|
|
@@e_signature:
|
|
end;
|
|
if not Icon.Empty then
|
|
begin
|
|
RsrcName := UpperCase( 'z' + ParentKOLForm.FormName + '_' + Name );
|
|
RsrcFile := ParentKOLForm.FormName + '_' + Name;
|
|
GenerateIconResource( Icon, RsrcName, RsrcFile, fUpdated );
|
|
SL.Add( Prefix + ' {$R ' + RsrcFile + '.RES}' );
|
|
end;
|
|
if Icon.Empty or not Active then
|
|
//SL.Add( Prefix + AName + ' := NewTrayIcon( Applet, 0 );' )
|
|
{P}SL.Add( ' L(0) LoadVar ####Applet NewTrayIcon<2> RESULT' +
|
|
' DUP LoadSELF AddWord_Store ##T' + ParentKOLForm.FormName +
|
|
'.' + Name )
|
|
else
|
|
//SL.Add( Prefix + AName + ' := NewTrayIcon( Applet, LoadIcon( hInstance, ' +
|
|
// String2Pascal( RsrcName, ' + ' ) + ' ) );' );
|
|
{P}SL.Add( ' LoadStr ''' + RsrcName + ''' #0 LoadHInstance' +
|
|
' LoadIcon<0> RESULT LoadVar ####Applet NewTrayIcon<2> RESULT' +
|
|
' DUP LoadSELF AddWord_Store ##T' + ParentKOLForm.FormName +
|
|
'.' + Name );
|
|
if not Active then
|
|
begin
|
|
//SL.Add( Prefix + AName + '.Active := FALSE;' );
|
|
{P}SL.Add( ' L(0) C1 TTrayIcon_.SetActive<2>' );
|
|
if not Icon.Empty then
|
|
//SL.Add( Prefix + AName + '.Icon := LoadIcon( hInstance, ' +
|
|
// String2Pascal( RsrcName, ' + ' ) + ' );' )
|
|
{P}SL.Add( ' LoadStr ''' + RsrcName + ''' #0 LoadHInstance' +
|
|
' LoadIcon<0> RESULT' +
|
|
' C1 TTrayIcon_.SetIcon<2>' );
|
|
end;
|
|
if NoAutoDeactivate then
|
|
//SL.Add( Prefix + AName + '.NoAutoDeactivate := TRUE;' );
|
|
{P}SL.Add( ' L(1) C1 AddByte_StoreB #TTrayIcon_.FNoAutoDeactivate' );
|
|
if Tooltip <> '' then
|
|
//SL.Add( Prefix + AName + '.Tooltip := ' + StringConstant( 'Tooltip', Tooltip ) + ';' );
|
|
{P}SL.Add( P_StringConstant( 'Tooltip', Tooltip ) +
|
|
' C2 TTrayIcon_.SetTooltip<2> DelAnsiStr' );
|
|
if AutoRecreate then
|
|
//SL.Add( Prefix + AName + '.AutoRecreate := TRUE;' );
|
|
{P}SL.Add( ' L(1) C1 TTrayIcon_.SetAutoRecreate<2>' );
|
|
//GenerateTag( SL, AName, Prefix );
|
|
P_GenerateTag( SL, AName, Prefix );
|
|
end;
|
|
|
|
procedure TKOLTrayIcon.P_SetupLast(SL: TStringList; const AName, AParent,
|
|
Prefix: String);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLTrayIcon.P_SetupLast', 0
|
|
@@e_signature:
|
|
end;
|
|
if Active then
|
|
//SL.Add( Prefix + AName + '.Active := TRUE;' );
|
|
begin
|
|
P_ProvideFakeType( SL, 'type TTrayIcon_ = object(TTrayIcon) end;' );
|
|
{P}SL.Add( ' L(1) ' +
|
|
'LoadSELF AddWord_LoadRef ##T' + ParentKOLForm.formName + '.' + Name +
|
|
' TTrayIcon_.SetActive<2>' );
|
|
end;
|
|
end;
|
|
|
|
procedure TKOLTrayIcon.SetActive(const Value: Boolean);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLTrayIcon.SetActive', 0
|
|
@@e_signature:
|
|
end;
|
|
FActive := Value;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLTrayIcon.SetAutoRecreate(const Value: Boolean);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLTrayIcon.SetAutoRecreate', 0
|
|
@@e_signature:
|
|
end;
|
|
FAutoRecreate := Value;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLTrayIcon.SetIcon(const Value: TIcon);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLTrayIcon.SetIcon', 0
|
|
@@e_signature:
|
|
end;
|
|
if Value <> nil then
|
|
FIcon.Assign( Value )
|
|
else
|
|
begin
|
|
FIcon.Free;
|
|
FIcon := TIcon.Create;
|
|
end;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLTrayIcon.SetNoAutoDeactivate(const Value: Boolean);
|
|
begin
|
|
FNoAutoDeactivate := Value;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLTrayIcon.SetOnMouse(const Value: TOnTrayIconMouse);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLTrayIcon.SetOnMouse', 0
|
|
@@e_signature:
|
|
end;
|
|
FOnMouse := Value;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLTrayIcon.SetTooltip(const Value: String);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLTrayIcon.SetTooltip', 0
|
|
@@e_signature:
|
|
end;
|
|
FTooltip := Value;
|
|
if Length( FTooltip ) > 64 then
|
|
FTooltip := Copy( FTooltip, 1, 64 ); // 64 characters maximum allowed
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLTrayIcon.SetupFirst(SL: TStringList; const AName, AParent,
|
|
Prefix: String);
|
|
var
|
|
{$IFDEF _D2009orHigher}
|
|
C, C2: WideString;
|
|
i : integer;
|
|
{$ELSE}
|
|
C: string;
|
|
{$ENDIF}
|
|
RsrcName, RsrcFile: String;
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLTrayIcon.SetupFirst', 0
|
|
@@e_signature:
|
|
end;
|
|
if not Icon.Empty then
|
|
begin
|
|
RsrcName := UpperCase( 'z' + ParentKOLForm.FormName + '_' + Name );
|
|
RsrcFile := ParentKOLForm.FormName + '_' + Name;
|
|
GenerateIconResource( Icon, RsrcName, RsrcFile, fUpdated );
|
|
SL.Add( Prefix + ' {$R ' + RsrcFile + '.RES}' );
|
|
end;
|
|
if Icon.Empty or not Active then
|
|
SL.Add( Prefix + AName + ' := NewTrayIcon( Applet, 0 );' )
|
|
else
|
|
SL.Add( Prefix + AName + ' := NewTrayIcon( Applet, LoadIcon( hInstance, ' +
|
|
String2Pascal( RsrcName, ' + ' ) + ' ) );' );
|
|
|
|
if not Active then
|
|
begin
|
|
SL.Add( Prefix + AName + '.Active := FALSE;' );
|
|
if not Icon.Empty then
|
|
SL.Add( Prefix + AName + '.Icon := LoadIcon( hInstance, ' +
|
|
String2Pascal( RsrcName, ' + ' ) + ' );' )
|
|
end;
|
|
if NoAutoDeactivate then
|
|
SL.Add( Prefix + AName + '.NoAutoDeactivate := TRUE;' );
|
|
if Tooltip <> '' then
|
|
begin
|
|
C := StringConstant( 'Tooltip', Tooltip );
|
|
{$IFDEF _D2009orHigher}
|
|
C2 := '';
|
|
for i := 2 to Length(C) - 1 do C2 := C2 + '#'+IntToStr(ord(C[i]));
|
|
C := C2;
|
|
{$ENDIF}
|
|
if C = '' then C := '''''';
|
|
SL.Add( Prefix + AName + '.Tooltip := ' + C + ';' );
|
|
end;
|
|
if AutoRecreate then
|
|
SL.Add( Prefix + AName + '.AutoRecreate := TRUE;' );
|
|
GenerateTag( SL, AName, Prefix );
|
|
end;
|
|
|
|
procedure TKOLTrayIcon.SetupLast(SL: TStringList; const AName, AParent,
|
|
Prefix: String);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLTrayIcon.SetupLast', 0
|
|
@@e_signature:
|
|
end;
|
|
if Active then
|
|
SL.Add( Prefix + AName + '.Active := TRUE;' );
|
|
end;
|
|
|
|
{ TKOLThread }
|
|
|
|
procedure TKOLThread.AssignEvents(SL: TStringList; const AName: String);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLThread.AssignEvents', 0
|
|
@@e_signature:
|
|
end;
|
|
//
|
|
end;
|
|
|
|
function TKOLThread.BestEventName: String;
|
|
begin
|
|
Result := 'OnExecute';
|
|
end;
|
|
|
|
constructor TKOLThread.Create( AOwner: TComponent );
|
|
begin
|
|
inherited;
|
|
FPriorityBoost := TRUE;
|
|
end;
|
|
|
|
function TKOLThread.NotAutoFree: Boolean;
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLThread.NotAutoFree', 0
|
|
@@e_signature:
|
|
end;
|
|
Result := F_AutoFree;
|
|
end;
|
|
|
|
function TKOLThread.Pcode_Generate: Boolean;
|
|
begin
|
|
Result := TRUE;
|
|
end;
|
|
|
|
function TKOLThread.P_AssignEvents(SL: TStringList; const AName: String;
|
|
CheckOnly: Boolean): Boolean;
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLThread.P_AssignEvents', 0
|
|
@@e_signature:
|
|
end;
|
|
Result := FALSE;
|
|
end;
|
|
|
|
procedure TKOLThread.P_SetupFirst(SL: TStringList; const AName, AParent,
|
|
Prefix: String);
|
|
//var S: String;
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLThread.P_SetupFirst', 0
|
|
@@e_signature:
|
|
end;
|
|
P_ProvideFakeType( SL, 'type TThread_ = object(TThread) end;' );
|
|
if startSuspended or (@OnSuspend <> nil) or
|
|
(@OnResume <> nil) or (@OnDestroy <> nil) or
|
|
AutoFree or (PriorityClass <> pcNormal) or (ThreadPriority <> tpNormal)
|
|
or (Tag <> 0) then
|
|
begin
|
|
if AutoFree then
|
|
//SL.Add( Prefix + AName + ' := NewThreadAutoFree( nil );' )
|
|
{P}SL.Add( ' L(0) NewThreadAutoFree<1> RESULT DUP LoadSELF AddWord_Store ##T' +
|
|
ParentKOLForm.formName + '.' + Name )
|
|
else
|
|
//SL.Add( Prefix + AName + ' := NewThread;' );
|
|
{P}SL.Add( ' NewThread<0> RESULT DUP LoadSELF AddWord_Store ##T' +
|
|
ParentKOLForm.formName + '.' + Name );
|
|
P_SetupName( SL );
|
|
if @OnExecute <> nil then
|
|
//SL.Add( Prefix + AName + '.OnExecute := Result.' +
|
|
// ParentForm.MethodName( @OnExecute ) + ';' );
|
|
{P}SL.Add( ' Load4 ####T' + ParentKOLForm.FormName +
|
|
'.' + ParentForm.MethodName( @ OnExecute ) +
|
|
' C1 AddByte_Store #TThread_.FOnExecute.TMethod.Code' +
|
|
' LoadSELF C1 AddByte_Store #TThread_.FOnExecute.TMethod.Data' );
|
|
if @OnSuspend <> nil then
|
|
//SL.Add( Prefix + AName + '.OnSuspend := Result.' +
|
|
// ParentForm.MethodName( @OnSuspend ) + ';' );
|
|
{P}SL.Add( ' Load4 ####T' + ParentKOLForm.formName +
|
|
'.' + ParentForm.MethodName( @OnSuspend ) +
|
|
' C1 AddByte_Store #TThread_.FOnSuspend.TMethod.Code' +
|
|
' LoadSELF C1 AddByte_Store #TThread_.FOnSuspend.TMethod.Data' );
|
|
if @OnResume <> nil then
|
|
//SL.Add( Prefix + AName + '.OnResume := Result.' +
|
|
// ParentForm.MethodName( @OnResume ) + ';' );
|
|
{P}SL.Add( ' Load4 ####T' + ParentKOLForm.FormName +
|
|
'.' + ParentForm.MethodName( @OnResume ) +
|
|
' C1 AddByte_Store #TThread_.FOnResume.TMethod.Code' +
|
|
' LoadSELF C1 AddByte_Store #TThread_.FOnResume.TMethod.Data' );
|
|
if @OnDestroy <> nil then
|
|
//SL.Add( Prefix + AName + '.OnDestroy := Result.' +
|
|
// ParentForm.MethodName( @OnDestroy ) + ';' );
|
|
{P}SL.Add( ' Load4 ####T' + ParentKOLForm.FormName +
|
|
'.' + ParentForm.MethodName( @OnDestroy ) +
|
|
' C1 AddByte_Store #TThread_.FOnDestroy.TMethod.Code' +
|
|
' LoadSELF C1 AddByte_Store #TThread_.FOnDestroy.TMethod.Data' );
|
|
if PriorityClass <> pcNormal then
|
|
//SL.Add( Prefix + AName + '.PriorityClass := ' +
|
|
// PriorityClasses[ PriorityClass ] + ';' );
|
|
{P}SL.Add( ' L(' + IntToStr( Integer( PriorityClass ) ) + ')' +
|
|
' C1 TThread_.SetPriorityClass<2>' );
|
|
if ThreadPriority <> tpNormal then
|
|
//SL.Add( Prefix + AName + '.ThreadPriority := ' +
|
|
// ThreadPriorities[ ThreadPriority ] + ';' );
|
|
{P}SL.Add( ' L(' + IntToStr( Integer( ThreadPriority ) ) + ')' +
|
|
' C1 TThread_.SetThreadPriority<2>' );
|
|
GenerateTag( SL, AName, Prefix );
|
|
if not startSuspended then
|
|
//SL.Add( Prefix + AName + '.Resume;' );
|
|
{P}SL.Add( ' DUP TThread.Resume<1>' );
|
|
end
|
|
else
|
|
begin
|
|
{S := 'nil';
|
|
if @OnExecute <> nil then
|
|
S := 'Result.' + ParentForm.MethodName( @OnExecute );
|
|
SL.Add( Prefix + AName + ' := NewThreadEx( ' + S + ' );' );}
|
|
if @OnExecute <> nil then
|
|
{P}SL.Add( ' LoadSELF Load4 ####T' + ParentKOLForm.FormName + '.' +
|
|
ParentForm.MethodName( @OnExecute ) )
|
|
else
|
|
{P}SL.Add( ' L(0) L(0)' );
|
|
{P}SL.Add( ' NewThreadEx<0> RESULT DUP LoadSELF AddWord_Store ##T' +
|
|
ParentKOLForm.FormName + '.' + Name );
|
|
end;
|
|
if not PriorityBoost then
|
|
//SL.Add( Prefix + AName + '.PriorityBoost := FALSE;' );
|
|
{P}SL.Add( ' L(0) C1 TThread_.SetPriorityBoost<2>' );
|
|
end;
|
|
|
|
procedure TKOLThread.SetAutoFree(const Value: Boolean);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLThread.SetAutoFree', 0
|
|
@@e_signature:
|
|
end;
|
|
F_AutoFree := Value;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLThread.SetOnExecute(const Value: TOnThreadExecute);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLThread.SetOnExecute', 0
|
|
@@e_signature:
|
|
end;
|
|
FOnExecute := Value;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLThread.SetOnResume(const Value: TOnEvent);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLThread.SetOnResume', 0
|
|
@@e_signature:
|
|
end;
|
|
FOnResume := Value;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLThread.SetOnSuspend(const Value: TObjectMethod);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLThread.SetOnSuspend', 0
|
|
@@e_signature:
|
|
end;
|
|
FOnSuspend := Value;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLThread.SetPriorityBoost(const Value: Boolean);
|
|
begin
|
|
FPriorityBoost := Value;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLThread.SetPriorityClass(const Value: TPriorityClass);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLThread.SetPriorityClass', 0
|
|
@@e_signature:
|
|
end;
|
|
FPriorityClass := Value;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLThread.SetstartSuspended(const Value: Boolean);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLThread.SetstartSuspended', 0
|
|
@@e_signature:
|
|
end;
|
|
FstartSuspended := Value;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLThread.SetThreadPriority(const Value: TThreadPriority);
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLThread.SetThreadPriority', 0
|
|
@@e_signature:
|
|
end;
|
|
FThreadPriority := Value;
|
|
Change;
|
|
end;
|
|
|
|
procedure TKOLThread.SetupFirst(SL: TStringList; const AName, AParent,
|
|
Prefix: String);
|
|
const PriorityClasses: array[ TPriorityClass ] of String =
|
|
( 'NORMAL_PRIORITY_CLASS', 'IDLE_PRIORITY_CLASS', 'HIGH_PRIORITY_CLASS',
|
|
'REALTIME_PRIORITY_CLASS' );
|
|
ThreadPriorities: array[ TThreadPriority ] of String =
|
|
( 'THREAD_PRIORITY_NORMAL', 'THREAD_PRIORITY_BELOW_NORMAL',
|
|
'THREAD_PRIORITY_LOWEST', 'THREAD_PRIORITY_IDLE',
|
|
'THREAD_PRIORITY_ABOVE_NORMAL', 'THREAD_PRIORITY_HIGHEST',
|
|
'THREAD_PRIORITY_CRITICAL' );
|
|
var S: String;
|
|
begin
|
|
asm
|
|
jmp @@e_signature
|
|
DB '#$signature$#', 0
|
|
DB 'TKOLThread.SetupFirst', 0
|
|
@@e_signature:
|
|
end;
|
|
if startSuspended or (@OnSuspend <> nil) or
|
|
(@OnResume <> nil) or (@OnDestroy <> nil) or
|
|
AutoFree or (PriorityClass <> pcNormal) or (ThreadPriority <> tpNormal)
|
|
or (Tag <> 0) then
|
|
begin
|
|
if AutoFree then
|
|
SL.Add( Prefix + AName + ' := NewThreadAutoFree( nil );' )
|
|
else
|
|
SL.Add( Prefix + AName + ' := NewThread;' );
|
|
SetupName( SL, AName, AParent, Prefix );
|
|
if @OnExecute <> nil then
|
|
SL.Add( Prefix + AName + '.OnExecute := Result.' +
|
|
ParentForm.MethodName( @OnExecute ) + ';' );
|
|
if @OnSuspend <> nil then
|
|
SL.Add( Prefix + AName + '.OnSuspend := Result.' +
|
|
ParentForm.MethodName( @OnSuspend ) + ';' );
|
|
if @OnResume <> nil then
|
|
SL.Add( Prefix + AName + '.OnResume := Result.' +
|
|
ParentForm.MethodName( @OnResume ) + ';' );
|
|
if @OnDestroy <> nil then
|
|
SL.Add( Prefix + AName + '.OnDestroy := Result.' +
|
|
ParentForm.MethodName( @OnDestroy ) + ';' );
|
|
if PriorityClass <> pcNormal then
|
|
SL.Add( Prefix + AName + '.PriorityClass := ' +
|
|
PriorityClasses[ PriorityClass ] + ';' );
|
|
if ThreadPriority <> tpNormal then
|
|
SL.Add( Prefix + AName + '.ThreadPriority := ' +
|
|
ThreadPriorities[ ThreadPriority ] + ';' );
|
|
GenerateTag( SL, AName, Prefix );
|
|
if not startSuspended then
|
|
SL.Add( Prefix + AName + '.Resume;' );
|
|
end
|
|
else
|
|
begin
|
|
S := 'nil';
|
|
if @OnExecute <> nil then
|
|
S := 'Result.' + ParentForm.MethodName( @OnExecute );
|
|
SL.Add( Prefix + AName + ' := NewThreadEx( ' + S + ' );' );
|
|
end;
|
|
if not PriorityBoost then
|
|
SL.Add( Prefix + AName + '.PriorityBoost := FALSE;' );
|
|
end;
|
|
|
|
end.
|