pascal/kolmck
pascal/kolmck
1
0
Fork 0
Code Issues Releases Activity
a62124de84
kolmck/mckObjs.pas

3311 lines
102 KiB
ObjectPascal
Raw Normal View History

Первая ревизия основана на 2.88+ =) отличия от 2.88: + procedure TControl.TBClear; {* |<#toolbar> Deletes all buttons. Dufa } + property TControl.TBButtonLParam[const Idx: Integer]: DWORD read TBGetButtonLParam write TBSetButtonLParam; {* |<#toolbar> Allows to access/change LParam. Dufa } + добавлен MCKfakeClasses200x.inc для исправления глюка с ложными МСК варнингами(в версиях 2006-2009) // Dufa * DefFont = Tahoma * procedure TDirList.ScanDirectory исправлена утечка памяти // Dufa * function TControl.WndProcTransparent исправлено "странное" поведение приложения, при кол-во форм >= 2 // Galkov * procedure TControl.SetCurIndex устранен AV // Galkov * visual_xp_styles.inc: function IsManifestFilePresent : boolean; исправлена ошибка при работе с библиотеками //Dufa *** возможно что-то забыл.... %) git-svn-id: https://svn.code.sf.net/p/kolmck/code@3 91bb2d04-0c0c-4d2d-88a5-bbb6f4c1fa07
2009-08-05 20:45:57 +03:00
{=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
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;
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;
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;
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 ): KOLTPixelFormat;
//function SaveBitmap( Bitmap: TBitmap; const Path: String ): Boolean;
procedure GenerateBitmapResource( Bitmap: TBitmap; const RsrcName, FileName: String;
var Updated: Boolean );
procedure GenerateIconResource( Icon: TIcon; const RsrcName, FileName: String;
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
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 pos( ',', Concatenator ) > 0 then
Result := Result + Int2Str( Integer( S[ I ] ) )
else
Result := Result + '#' + Int2Str( 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 ' + Int2Hex( 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 ): KOL.TPixelFormat;
var Y, X: Integer;
L: PDWORD;
ColorList: KOL.PList;
C: TColor;
R, G, B: Byte;
begin
ColorList := NewList;
ColorList.Capacity := 65537;
TRY
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 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;
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;
end;
end;
Inc( L );
end;
end;
//Rpt( '------ Colors in bitmap: ' + IntToStr( ColorList.Count ) );
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 ColorsAre64K( ColorList ) then
begin
Result := KOL.pf16bit;
//Rpt( '~~~~~ pf16bit ~~~~~', WHITE );
end
else
begin
Result := KOL.pf24bit;
//Rpt( '~~~~~ pf32bit ~~~~~ (' + IntToStr( ColorList.Count ) + ')', WHITE );
end;
FINALLY
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}
// 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 );
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, Bmp: string;
tmStr: WideString;
KOLBmp: KOL.PBitmap;
KOLPF: KOL.TPixelFormat;
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 );
//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;
KOLPF := CountSystemColorsUsedInBitmap( KOLBmp );
KOLBmp.PixelFormat := KOLPF;
KOLBmp.SaveToFile( Bmp );
KOLBmp.Free;
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: String;
var Updated: Boolean );
var RL: TStringList;
Buf1, Buf2: PChar;
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( UpperCase( 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;
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 );
end;
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
case FBitmap.PixelFormat of
pf1bit,
pf4bit: Colors := ilcColor4;
pf8bit: Colors := ilcColor8;
pf32bit: Colors := ilcColor32;
//pf24bit:
else 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.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: 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;
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( hInstance, ''' +
RsrcName + ''', ' +
AName + ' ), ' + Color2Str( TransparentColor ) + ' );' )
else
SL.Add( Prefix + AName + '.Add( LoadBmp( hInstance, ''' +
RsrcName + ''', ' +
AName + ' ), 0 );' );
//Rpt( 'Generating resource: ' + ProjectSourcePath + RsrcFile + '.res' );
GenerateBitmapResource( FBitmap, RsrcName, RsrcFile, fUpdated );
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;
C := StringConstant( 'Title', Title );
{$IFDEF _D2009orHigher}
C2 := '';
for i := 2 to Length(C) - 1 do C2 := C2 + '#'+int2str(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 <> '' 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 <> '' then
begin
C := StringConstant( 'Title', Title );
{$IFDEF _D2009orHigher}
C2 := '';
for i := 2 to Length(C) - 1 do C2 := C2 + '#'+int2str(ord(C[i]));
C := C2;
{$ENDIF}
if C = '' then C := '''''';
SL.Add( Prefix + AName + '.Title := ' + C + ';' );
end;
end
else
begin
C := StringConstant( 'Title', Title );
{$IFDEF _D2009orHigher}
C2 := '';
for i := 2 to Length(C) - 1 do C2 := C2 + '#'+int2str(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: 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 );' )
{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 + '#'+int2str(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.
Reference in New Issue Copy Permalink