git-svn-id: https://svn.code.sf.net/p/kolmck/code@7 91bb2d04-0c0c-4d2d-88a5-bbb6f4c1fa07
This commit is contained in:
dkolmck
5608
Addons/MZLib.pas
Normal file
5608
Addons/MZLib.pas
Normal file
File diff suppressed because it is too large
Load Diff
361
Addons/Mmx.pas
Normal file
361
Addons/Mmx.pas
Normal file
@@ -0,0 +1,361 @@
|
||||
unit Mmx;
|
||||
{* MMX support unit. By Vladimir Kladov, 2003. }
|
||||
|
||||
interface
|
||||
|
||||
{$I KOLDEF.INC}
|
||||
|
||||
uses
|
||||
Windows, Kol;
|
||||
|
||||
type
|
||||
TCpuId = ( cpuNew486, cpuMMX, cpuMMX_Plus, cpu3DNow, cpu3DNow_Plus,
|
||||
cpuSSE, cpuSSE2 );
|
||||
{* Enumeration type to represent CPU type.
|
||||
cpuOld486: Old 486 Processor and earlier
|
||||
cpuNew486: New 486 Processor to Pentium1 without MMX
|
||||
cpuMMX : MMX supported (but not SSE or SSE2)
|
||||
cpuSSE : MMX and SSE supported (but not SSE2)
|
||||
cpuSSE2 : MMX, SSE and SSE2 supported
|
||||
}
|
||||
|
||||
TCpuCaps = set of TCpuId;
|
||||
|
||||
function GetCPUType: TCpuCaps;
|
||||
{* Checks CPU (Intel PC x86 Architecture) for MMX support.
|
||||
|<p><p>
|
||||
|
||||
Use following constants in shuffle commands (like "pshufw") as third operand
|
||||
to instruct to which locations (0,1,2,3) source parts should be placed: }
|
||||
const
|
||||
SH0000 = $00;
|
||||
SH0001 = $01;
|
||||
SH0002 = $02;
|
||||
SH0003 = $03;
|
||||
SH0010 = $04;
|
||||
SH0011 = $05;
|
||||
SH0012 = $06;
|
||||
SH0013 = $07;
|
||||
SH0020 = $08;
|
||||
SH0021 = $09;
|
||||
SH0022 = $0A;
|
||||
SH0023 = $0B;
|
||||
SH0030 = $0C;
|
||||
SH0031 = $0D;
|
||||
SH0032 = $0E;
|
||||
SH0033 = $0F;
|
||||
SH0100 = $10;
|
||||
SH0101 = $11;
|
||||
SH0102 = $12;
|
||||
SH0103 = $13;
|
||||
SH0110 = $14;
|
||||
SH0111 = $15;
|
||||
SH0112 = $16;
|
||||
SH0113 = $17;
|
||||
SH0120 = $18;
|
||||
SH0121 = $19;
|
||||
SH0122 = $1A;
|
||||
SH0123 = $1B;
|
||||
SH0130 = $1C;
|
||||
SH0131 = $1D;
|
||||
SH0132 = $1E;
|
||||
SH0133 = $1F;
|
||||
SH0200 = $20;
|
||||
SH0201 = $21;
|
||||
SH0202 = $22;
|
||||
SH0203 = $23;
|
||||
SH0210 = $24;
|
||||
SH0211 = $25;
|
||||
SH0212 = $26;
|
||||
SH0213 = $27;
|
||||
SH0220 = $28;
|
||||
SH0221 = $29;
|
||||
SH0222 = $2A;
|
||||
SH0223 = $2B;
|
||||
SH0230 = $2C;
|
||||
SH0231 = $2D;
|
||||
SH0232 = $2E;
|
||||
SH0233 = $2F;
|
||||
SH0300 = $30;
|
||||
SH0301 = $31;
|
||||
SH0302 = $32;
|
||||
SH0303 = $33;
|
||||
SH0310 = $34;
|
||||
SH0311 = $35;
|
||||
SH0312 = $36;
|
||||
SH0313 = $37;
|
||||
SH0320 = $38;
|
||||
SH0321 = $39;
|
||||
SH0322 = $3A;
|
||||
SH0323 = $3B;
|
||||
SH0330 = $3C;
|
||||
SH0331 = $3D;
|
||||
SH0332 = $3E;
|
||||
SH0333 = $3F;
|
||||
SH1000 = $40;
|
||||
SH1001 = $41;
|
||||
SH1002 = $42;
|
||||
SH1003 = $43;
|
||||
SH1010 = $44;
|
||||
SH1011 = $45;
|
||||
SH1012 = $46;
|
||||
SH1013 = $47;
|
||||
SH1020 = $48;
|
||||
SH1021 = $49;
|
||||
SH1022 = $4A;
|
||||
SH1023 = $4B;
|
||||
SH1030 = $4C;
|
||||
SH1031 = $4D;
|
||||
SH1032 = $4E;
|
||||
SH1033 = $4F;
|
||||
SH1100 = $50;
|
||||
SH1101 = $51;
|
||||
SH1102 = $52;
|
||||
SH1103 = $53;
|
||||
SH1110 = $54;
|
||||
SH1111 = $55;
|
||||
SH1112 = $56;
|
||||
SH1113 = $57;
|
||||
SH1120 = $58;
|
||||
SH1121 = $59;
|
||||
SH1122 = $5A;
|
||||
SH1123 = $5B;
|
||||
SH1130 = $5C;
|
||||
SH1131 = $5D;
|
||||
SH1132 = $5E;
|
||||
SH1133 = $5F;
|
||||
SH1200 = $60;
|
||||
SH1201 = $61;
|
||||
SH1202 = $62;
|
||||
SH1203 = $63;
|
||||
SH1210 = $64;
|
||||
SH1211 = $65;
|
||||
SH1212 = $66;
|
||||
SH1213 = $67;
|
||||
SH1220 = $68;
|
||||
SH1221 = $69;
|
||||
SH1222 = $6A;
|
||||
SH1223 = $6B;
|
||||
SH1230 = $6C;
|
||||
SH1231 = $6D;
|
||||
SH1232 = $6E;
|
||||
SH1233 = $6F;
|
||||
SH1300 = $70;
|
||||
SH1301 = $71;
|
||||
SH1302 = $72;
|
||||
SH1303 = $73;
|
||||
SH1310 = $74;
|
||||
SH1311 = $75;
|
||||
SH1312 = $76;
|
||||
SH1313 = $77;
|
||||
SH1320 = $78;
|
||||
SH1321 = $79;
|
||||
SH1322 = $7A;
|
||||
SH1323 = $7B;
|
||||
SH1330 = $7C;
|
||||
SH1331 = $7D;
|
||||
SH1332 = $7E;
|
||||
SH1333 = $7F;
|
||||
SH2000 = $80;
|
||||
SH2001 = $81;
|
||||
SH2002 = $82;
|
||||
SH2003 = $83;
|
||||
SH2010 = $84;
|
||||
SH2011 = $85;
|
||||
SH2012 = $86;
|
||||
SH2013 = $87;
|
||||
SH2020 = $88;
|
||||
SH2021 = $89;
|
||||
SH2022 = $8A;
|
||||
SH2023 = $8B;
|
||||
SH2030 = $8C;
|
||||
SH2031 = $8D;
|
||||
SH2032 = $8E;
|
||||
SH2033 = $8F;
|
||||
SH2100 = $90;
|
||||
SH2101 = $91;
|
||||
SH2102 = $92;
|
||||
SH2103 = $93;
|
||||
SH2110 = $94;
|
||||
SH2111 = $95;
|
||||
SH2112 = $96;
|
||||
SH2113 = $97;
|
||||
SH2120 = $98;
|
||||
SH2121 = $99;
|
||||
SH2122 = $9A;
|
||||
SH2123 = $9B;
|
||||
SH2130 = $9C;
|
||||
SH2131 = $9D;
|
||||
SH2132 = $9E;
|
||||
SH2133 = $9F;
|
||||
SH2200 = $A0;
|
||||
SH2201 = $A1;
|
||||
SH2202 = $A2;
|
||||
SH2203 = $A3;
|
||||
SH2210 = $A4;
|
||||
SH2211 = $A5;
|
||||
SH2212 = $A6;
|
||||
SH2213 = $A7;
|
||||
SH2220 = $A8;
|
||||
SH2221 = $A9;
|
||||
SH2222 = $AA;
|
||||
SH2223 = $AB;
|
||||
SH2230 = $AC;
|
||||
SH2231 = $AD;
|
||||
SH2232 = $AE;
|
||||
SH2233 = $AF;
|
||||
SH2300 = $B0;
|
||||
SH2301 = $B1;
|
||||
SH2302 = $B2;
|
||||
SH2303 = $B3;
|
||||
SH2310 = $B4;
|
||||
SH2311 = $B5;
|
||||
SH2312 = $B6;
|
||||
SH2313 = $B7;
|
||||
SH2320 = $B8;
|
||||
SH2321 = $B9;
|
||||
SH2322 = $BA;
|
||||
SH2323 = $BB;
|
||||
SH2330 = $BC;
|
||||
SH2331 = $BD;
|
||||
SH2332 = $BE;
|
||||
SH2333 = $BF;
|
||||
SH3000 = $C0;
|
||||
SH3001 = $C1;
|
||||
SH3002 = $C2;
|
||||
SH3003 = $C3;
|
||||
SH3010 = $C4;
|
||||
SH3011 = $C5;
|
||||
SH3012 = $C6;
|
||||
SH3013 = $C7;
|
||||
SH3020 = $C8;
|
||||
SH3021 = $C9;
|
||||
SH3022 = $CA;
|
||||
SH3023 = $CB;
|
||||
SH3030 = $CC;
|
||||
SH3031 = $CD;
|
||||
SH3032 = $CE;
|
||||
SH3033 = $CF;
|
||||
SH3100 = $D0;
|
||||
SH3101 = $D1;
|
||||
SH3102 = $D2;
|
||||
SH3103 = $D3;
|
||||
SH3110 = $D4;
|
||||
SH3111 = $D5;
|
||||
SH3112 = $D6;
|
||||
SH3113 = $D7;
|
||||
SH3120 = $D8;
|
||||
SH3121 = $D9;
|
||||
SH3122 = $DA;
|
||||
SH3123 = $DB;
|
||||
SH3130 = $DC;
|
||||
SH3131 = $DD;
|
||||
SH3132 = $DE;
|
||||
SH3133 = $DF;
|
||||
SH3200 = $E0;
|
||||
SH3201 = $E1;
|
||||
SH3202 = $E2;
|
||||
SH3203 = $E3;
|
||||
SH3210 = $E4;
|
||||
SH3211 = $E5;
|
||||
SH3212 = $E6;
|
||||
SH3213 = $E7;
|
||||
SH3220 = $E8;
|
||||
SH3221 = $E9;
|
||||
SH3222 = $EA;
|
||||
SH3223 = $EB;
|
||||
SH3230 = $EC;
|
||||
SH3231 = $ED;
|
||||
SH3232 = $EE;
|
||||
SH3233 = $EF;
|
||||
SH3300 = $F0;
|
||||
SH3301 = $F1;
|
||||
SH3302 = $F2;
|
||||
SH3303 = $F3;
|
||||
SH3310 = $F4;
|
||||
SH3311 = $F5;
|
||||
SH3312 = $F6;
|
||||
SH3313 = $F7;
|
||||
SH3320 = $F8;
|
||||
SH3321 = $F9;
|
||||
SH3322 = $FA;
|
||||
SH3323 = $FB;
|
||||
SH3330 = $FC;
|
||||
SH3331 = $FD;
|
||||
SH3332 = $FE;
|
||||
SH3333 = $FF;
|
||||
|
||||
implementation
|
||||
|
||||
var cpu: TCpuCaps = [ ];
|
||||
|
||||
function GetCPUType: TCpuCaps;
|
||||
var I, J: Integer;
|
||||
Vend1: array[ 0..3 ] of Char;
|
||||
begin
|
||||
Result := cpu; // old 486 and earlier
|
||||
if Result <> [] then Exit;
|
||||
I := 0;
|
||||
asm // check if bit 21 of EFLAGS can be set and reset
|
||||
PUSHFD
|
||||
POP EAX
|
||||
OR EAX, 1 shl 21
|
||||
PUSH EAX
|
||||
POPFD
|
||||
PUSHFD
|
||||
POP EAX
|
||||
TEST EAX, 1 shl 21
|
||||
JZ @@1
|
||||
AND EAX, not( 1 shl 21 )
|
||||
PUSH EAX
|
||||
POPFD
|
||||
PUSHFD
|
||||
POP EAX
|
||||
TEST EAX, 1 shl 21
|
||||
JNZ @@1
|
||||
INC [ I ]
|
||||
@@1:
|
||||
end;
|
||||
if I = 0 then Exit; // CPUID not supported
|
||||
Include( Result, cpuNew486 ); // at least cpuNew486
|
||||
asm // get CPU features flags using CPUID command
|
||||
PUSH EBX
|
||||
MOV EAX, 0
|
||||
DB $0F, $A2 //CPUID : EAX, EBX, EDX and ECX are changed!!!
|
||||
MOV [ Vend1 ], EBX
|
||||
|
||||
MOV EAX, 1
|
||||
DB $0F, $A2 //CPUID : EAX, EBX, EDX and ECX are changed!!!
|
||||
MOV [ I ], EDX // I := features information
|
||||
POP EBX
|
||||
end;
|
||||
if (I and (1 shl 23)) = 0 then Exit; // MMX not supported at all
|
||||
Include( Result, cpuMMX ); // MMX supported.
|
||||
if Vend1 = 'Auth' then // AuthenticAMD ?
|
||||
begin
|
||||
asm
|
||||
PUSH EBX
|
||||
MOV EAX, $80000001
|
||||
DB $0F, $A2 //CPUID : EAX, EBX, EDX and ECX are changed!!!
|
||||
MOV [ J ], EDX
|
||||
POP EBX
|
||||
end;
|
||||
if (J and (1 shl 22)) <> 0 then
|
||||
Include( Result, cpuMMX_Plus ); // MMX+ supported.
|
||||
if (J and (1 shl 31)) <> 0 then
|
||||
begin
|
||||
Include( Result, cpu3DNow ); // 3DNow! supported.
|
||||
if (J and (1 shl 30)) <> 0 then
|
||||
Include( Result, cpu3DNow_Plus );// 3DNow!+ supported.
|
||||
end;
|
||||
end;
|
||||
if (I and (1 shl 25)) <> 0 then
|
||||
begin
|
||||
Include( Result, cpuSSE ); // SSE supported.
|
||||
if (I and (1 shl 26)) <> 0 then
|
||||
Include( Result, cpuSSE2 ); // SSE2 supported.
|
||||
end;
|
||||
cpu := Result;
|
||||
end;
|
||||
|
||||
end.
|
||||
261
Addons/OLETable.pas
Normal file
261
Addons/OLETable.pas
Normal file
@@ -0,0 +1,261 @@
|
||||
unit OLETable;
|
||||
|
||||
interface
|
||||
|
||||
uses KOLEdb, KOL, ListEdit, Windows, Messages;
|
||||
|
||||
type
|
||||
TKOLDataSource = PDataSource;
|
||||
TKOLSession = PSession;
|
||||
TKOLQuery = PQuery;
|
||||
|
||||
PListData =^TListData;
|
||||
TKOLListData = PListData;
|
||||
TListData = object(TObj)
|
||||
Owner: PControl;
|
||||
LView: PControl;
|
||||
OWind: longint;
|
||||
NWind: longint;
|
||||
fRowC: TOnEvent;
|
||||
fQuer: PQuery;
|
||||
protected
|
||||
destructor destroy; virtual;
|
||||
procedure NewWndProc(var Msg: TMessage);
|
||||
function GetColor: TColor;
|
||||
procedure SetColor(C: TColor);
|
||||
function GetCtl3D: boolean;
|
||||
procedure SetCtl3D(C: boolean);
|
||||
function GetCursor: HIcon;
|
||||
procedure SetCursor(C: HIcon);
|
||||
function GetEnabled: boolean;
|
||||
procedure SetEnabled(E: boolean);
|
||||
function GetTransparent: boolean;
|
||||
procedure SetTransparent(T: boolean);
|
||||
function GetVisible: boolean;
|
||||
procedure SetVisible(V: boolean);
|
||||
function GetFont: PGraphicTool;
|
||||
function GetTextBkColor: TColor;
|
||||
procedure SetTextBkColor(C: TColor);
|
||||
function GetBkColor: TColor;
|
||||
procedure SetBkColor(C: TColor);
|
||||
public
|
||||
function SetAlign( AAlign: TControlAlign ): PListData;
|
||||
function SetPosition(X, Y: integer): PListData;
|
||||
function SetSize(X, Y: integer): PListData;
|
||||
function CenterOnParent: PListData;
|
||||
|
||||
procedure Open;
|
||||
procedure LVColAdd( const aText: String; aalign: TTextAlign; aWidth: Integer );
|
||||
|
||||
property Color: TColor read GetColor write SetColor;
|
||||
property Ctl3D: boolean read GetCtl3D write SetCtl3D;
|
||||
property Cursor: HIcon read GetCursor write SetCursor;
|
||||
property Enabled: boolean read GetEnabled write SetEnabled;
|
||||
property Transparent: boolean read GetTransparent write SetTransparent;
|
||||
property Visible: boolean read GetVisible write SetVisible;
|
||||
property Font: PGraphicTool read GetFont;
|
||||
property LVTextBkColor: TColor read GetTextBkColor write SetTextBkColor;
|
||||
property LVBkColor: TColor read GetBkColor write SetBkColor;
|
||||
|
||||
property Query: PQuery read fQuer write fQuer;
|
||||
property OnRowChanged: TOnEvent read fRowC write fRowC;
|
||||
end;
|
||||
|
||||
function NewKOLTable(s: string): PDataSource;
|
||||
function NewListData(AParent: PControl; Style: TListViewStyle; Options: TListViewOptions;
|
||||
ImageListSmall, ImageListNormal, ImageListState: PImageList): PListData;
|
||||
|
||||
implementation
|
||||
|
||||
uses objects;
|
||||
|
||||
function NewKOLTable;
|
||||
begin
|
||||
Result := NewDataSource(s);
|
||||
end;
|
||||
|
||||
function NewListData;
|
||||
begin
|
||||
New(Result, Create);
|
||||
Aparent.Add2AutoFree(Result);
|
||||
Result.Owner := Aparent;
|
||||
Result.LView := NewListEdit(AParent, Style, Options, ImageListSmall, ImageListNormal, ImageListState);
|
||||
Result.fQuer := nil;
|
||||
Result.OWind := GetWindowLong(Aparent.Handle, GWL_WNDPROC);
|
||||
Result.NWind := LongInt(MakeObjectInstance(Result.NewWndProc));
|
||||
SetWindowLong(Aparent.Handle, GWL_WNDPROC, Result.NWind);
|
||||
end;
|
||||
|
||||
destructor TListData.destroy;
|
||||
begin
|
||||
SetWindowLong(Owner.Handle, GWL_WNDPROC, OWind);
|
||||
FreeObjectInstance(pointer(NWind));
|
||||
inherited;
|
||||
end;
|
||||
|
||||
procedure TListData.NewWndProc;
|
||||
var i: integer;
|
||||
n: integer;
|
||||
begin
|
||||
case Msg.Msg of
|
||||
WM_ROWCHANG:
|
||||
begin
|
||||
n := LView.LVCurItem;
|
||||
fQuer.CurIndex := LView.LVItemData[n];
|
||||
for i := 1 to fQuer.ColCount - 1 do begin
|
||||
fQuer.FieldAsStr[i] := LView.LVItems[n, i - 1];
|
||||
LView.LVItems[n, i - 1] := fQuer.FieldAsStr[i];
|
||||
end;
|
||||
fQuer.Post;
|
||||
if Assigned(fRowC) then fRowC(@self);
|
||||
end;
|
||||
end;
|
||||
Msg.Result := CallWindowProc(Pointer(OWind), Owner.Handle, Msg.Msg, Msg.wParam, Msg.lParam);
|
||||
end;
|
||||
|
||||
function TListData.SetAlign;
|
||||
begin
|
||||
Result := @self;
|
||||
LView.SetAlign(AAlign);
|
||||
end;
|
||||
|
||||
function TListData.SetPosition;
|
||||
begin
|
||||
Result := @self;
|
||||
LView.Left := X;
|
||||
LView.Top := Y;
|
||||
end;
|
||||
|
||||
function TListData.SetSize;
|
||||
begin
|
||||
Result := @self;
|
||||
LView.Width := X;
|
||||
LView.Height := Y;
|
||||
end;
|
||||
|
||||
function TListData.CenterOnParent;
|
||||
begin
|
||||
Result := @self;
|
||||
LView.CenterOnParent;
|
||||
end;
|
||||
|
||||
function TListData.GetColor;
|
||||
begin
|
||||
Result := LView.Color;
|
||||
end;
|
||||
|
||||
procedure TListData.SetColor;
|
||||
begin
|
||||
LView.Color := C;
|
||||
end;
|
||||
|
||||
function TListData.GetCtl3D;
|
||||
begin
|
||||
Result := LView.Ctl3D;
|
||||
end;
|
||||
|
||||
procedure TListData.SetCtl3D;
|
||||
begin
|
||||
LView.Ctl3D := C;
|
||||
end;
|
||||
|
||||
function TListData.GetCursor;
|
||||
begin
|
||||
Result := LView.Cursor;
|
||||
end;
|
||||
|
||||
procedure TListData.SetCursor;
|
||||
begin
|
||||
LView.Cursor := C;
|
||||
end;
|
||||
|
||||
function TListData.GetEnabled;
|
||||
begin
|
||||
Result := LView.Enabled;
|
||||
end;
|
||||
|
||||
procedure TListData.SetEnabled;
|
||||
begin
|
||||
LView.Enabled := E;
|
||||
end;
|
||||
|
||||
function TListData.GetTransparent;
|
||||
begin
|
||||
Result := LView.Transparent;
|
||||
end;
|
||||
|
||||
procedure TListData.SetTransparent;
|
||||
begin
|
||||
LView.Transparent := T;
|
||||
end;
|
||||
|
||||
function TListData.GetVisible;
|
||||
begin
|
||||
Result := LView.Visible;
|
||||
end;
|
||||
|
||||
procedure TListData.SetVisible;
|
||||
begin
|
||||
LView.Visible := V;
|
||||
end;
|
||||
|
||||
function TListData.GetFont;
|
||||
begin
|
||||
Result := LView.Font;
|
||||
end;
|
||||
|
||||
procedure TListData.LVColAdd;
|
||||
begin
|
||||
LView.LVColAdd(aText, aAlign, aWidth);
|
||||
end;
|
||||
|
||||
function TListData.GetTextBkColor;
|
||||
begin
|
||||
Result := LView.LVTextBkColor;
|
||||
end;
|
||||
|
||||
procedure TListData.SetTextBkColor;
|
||||
begin
|
||||
LView.LVTextBkColor := C;
|
||||
end;
|
||||
|
||||
function TListData.GetBkColor;
|
||||
begin
|
||||
Result := LView.LVBkColor;
|
||||
end;
|
||||
|
||||
procedure TListData.SetBkColor;
|
||||
begin
|
||||
LView.LVBkColor := C;
|
||||
end;
|
||||
|
||||
procedure TListData.Open;
|
||||
var i: integer;
|
||||
n: integer;
|
||||
s: string;
|
||||
d: double;
|
||||
f: integer;
|
||||
begin
|
||||
if fQuer <> nil then begin
|
||||
if fQuer.Session.DataSource.Initialized then begin
|
||||
fQuer.Open;
|
||||
fQuer.First;
|
||||
f := fQuer.FirstColumn;
|
||||
while not fQuer.EOF do begin
|
||||
s := fQuer.FieldAsStr[f];
|
||||
i := LView.LVItemAdd(s);
|
||||
LView.LVItemData[i] := fQuer.CurIndex;
|
||||
for n := f + 1 to fQuer.ColCount - 1 do begin
|
||||
try
|
||||
LView.LVItems[i, n - f] := fQuer.FieldAsStr[n];
|
||||
except
|
||||
LView.LVItems[i, n - f] := '';
|
||||
end;
|
||||
end;
|
||||
fQuer.Next;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
260
Addons/Objects.pas
Normal file
260
Addons/Objects.pas
Normal file
@@ -0,0 +1,260 @@
|
||||
unit objects;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
KOL, Windows, Messages;
|
||||
|
||||
type
|
||||
TWndMethod = procedure(var Message: TMessage) of object;
|
||||
|
||||
function MakeObjectInstance(Method: TWndMethod): Pointer;
|
||||
procedure FreeObjectInstance(ObjectInstance: Pointer);
|
||||
function AllocateHWnd(Method: TWndMethod): HWND;
|
||||
procedure DeallocateHWnd(Wnd: HWND);
|
||||
function IncColor(C: TColor; D: integer): TColor;
|
||||
procedure AjustBitmap(const M: KOL.PBitmap; S, C: TColor);
|
||||
|
||||
implementation
|
||||
|
||||
type
|
||||
PObjectInstance = ^TObjectInstance;
|
||||
TObjectInstance = packed record
|
||||
Code: Byte;
|
||||
Offset: Integer;
|
||||
case Integer of
|
||||
0: (Next: PObjectInstance);
|
||||
1: (Method: TWndMethod);
|
||||
end;
|
||||
|
||||
type
|
||||
PInstanceBlock = ^TInstanceBlock;
|
||||
TInstanceBlock = packed record
|
||||
Next: PInstanceBlock;
|
||||
Code: array[1..2] of Byte;
|
||||
WndProcPtr: Pointer;
|
||||
Instances: array[0..100] of TObjectInstance;
|
||||
end;
|
||||
|
||||
var
|
||||
InstBlockList: PInstanceBlock;
|
||||
InstBlockCount: integer;
|
||||
InstFreeList: PObjectInstance;
|
||||
|
||||
{ Standard window procedure }
|
||||
{ In ECX = Address of method pointer }
|
||||
{ Out EAX = Result }
|
||||
|
||||
function StdWndProc(Window: HWND; Message, WParam: Longint;
|
||||
LParam: Longint): Longint; stdcall; assembler;
|
||||
asm
|
||||
XOR EAX,EAX
|
||||
PUSH EAX
|
||||
PUSH LParam
|
||||
PUSH WParam
|
||||
PUSH Message
|
||||
MOV EDX,ESP
|
||||
MOV EAX,[ECX].Longint[4]
|
||||
CALL [ECX].Pointer
|
||||
ADD ESP,12
|
||||
POP EAX
|
||||
end;
|
||||
|
||||
{ Allocate an object instance }
|
||||
|
||||
function CalcJmpOffset(Src, Dest: Pointer): Longint;
|
||||
begin
|
||||
Result := Longint(Dest) - (Longint(Src) + 5);
|
||||
end;
|
||||
|
||||
function MakeObjectInstance(Method: TWndMethod): Pointer;
|
||||
const
|
||||
BlockCode: array[1..2] of Byte = (
|
||||
$59, { POP ECX }
|
||||
$E9); { JMP StdWndProc }
|
||||
PageSize = 4096;
|
||||
var
|
||||
Block: PInstanceBlock;
|
||||
Instance: PObjectInstance;
|
||||
begin
|
||||
if InstFreeList = nil then
|
||||
begin
|
||||
Block := VirtualAlloc(nil, PageSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
|
||||
Block^.Next := InstBlockList;
|
||||
Move(BlockCode, Block^.Code, SizeOf(BlockCode));
|
||||
Block^.WndProcPtr := Pointer(CalcJmpOffset(@Block^.Code[2], @StdWndProc));
|
||||
Instance := @Block^.Instances;
|
||||
repeat
|
||||
Instance^.Code := $E8; { CALL NEAR PTR Offset }
|
||||
Instance^.Offset := CalcJmpOffset(Instance, @Block^.Code);
|
||||
Instance^.Next := InstFreeList;
|
||||
InstFreeList := Instance;
|
||||
Inc(Longint(Instance), SizeOf(TObjectInstance));
|
||||
until Longint(Instance) - Longint(Block) >= SizeOf(TInstanceBlock);
|
||||
InstBlockList := Block;
|
||||
end;
|
||||
Result := InstFreeList;
|
||||
Instance := InstFreeList;
|
||||
InstFreeList := Instance^.Next;
|
||||
Instance^.Method := Method;
|
||||
inc(InstBlockCount);
|
||||
end;
|
||||
|
||||
{ Free an object instance }
|
||||
|
||||
procedure FreeObjectInstance(ObjectInstance: Pointer);
|
||||
begin
|
||||
if (ObjectInstance <> nil) and (InstBlockCount > 0) then
|
||||
begin
|
||||
PObjectInstance(ObjectInstance)^.Next := InstFreeList;
|
||||
InstFreeList := ObjectInstance;
|
||||
Dec(InstBlockCount);
|
||||
if InstBlockCount = 0 then begin
|
||||
VirtualFree(InstBlockList, 0, MEM_RELEASE);
|
||||
InstBlockList := nil;
|
||||
ObjectInstance := nil;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
var
|
||||
UtilWindowClass: TWndClass = (
|
||||
style: 0;
|
||||
lpfnWndProc: @DefWindowProc;
|
||||
cbClsExtra: 0;
|
||||
cbWndExtra: 0;
|
||||
hInstance: 0;
|
||||
hIcon: 0;
|
||||
hCursor: 0;
|
||||
hbrBackground: 0;
|
||||
lpszMenuName: nil;
|
||||
lpszClassName: 'KOLFakeUtilWindow');
|
||||
|
||||
function AllocateHWnd(Method: TWndMethod): HWND;
|
||||
var
|
||||
TempClass: TWndClass;
|
||||
ClassRegistered: Boolean;
|
||||
begin
|
||||
UtilWindowClass.hInstance := HInstance;
|
||||
ClassRegistered := GetClassInfo(HInstance, UtilWindowClass.lpszClassName,
|
||||
TempClass);
|
||||
if not ClassRegistered or (TempClass.lpfnWndProc <> @DefWindowProc) then
|
||||
begin
|
||||
if ClassRegistered then
|
||||
Windows.UnregisterClass(UtilWindowClass.lpszClassName, HInstance);
|
||||
Windows.RegisterClass(UtilWindowClass);
|
||||
end;
|
||||
Result := CreateWindowEx(WS_EX_TOOLWINDOW, UtilWindowClass.lpszClassName,
|
||||
'', WS_POPUP {!0}, 0, 0, 0, 0, 0, 0, HInstance, nil);
|
||||
if Assigned(Method) then
|
||||
SetWindowLong(Result, GWL_WNDPROC, Longint(MakeObjectInstance(Method)));
|
||||
end;
|
||||
|
||||
procedure DeallocateHWnd(Wnd: HWND);
|
||||
var
|
||||
Instance: Pointer;
|
||||
begin
|
||||
Instance := Pointer(GetWindowLong(Wnd, GWL_WNDPROC));
|
||||
DestroyWindow(Wnd);
|
||||
if Instance <> @DefWindowProc then FreeObjectInstance(Instance);
|
||||
end;
|
||||
|
||||
procedure SplitColor(C: TColor; var r, g, b: integer);
|
||||
begin
|
||||
b := (c and $FF0000) shr 16;
|
||||
g := (c and $00FF00) shr 08;
|
||||
r := (c and $0000FF) shr 00;
|
||||
end;
|
||||
|
||||
procedure AjustBitmap;
|
||||
var i, j: integer;
|
||||
t: KOL.PBitmap;
|
||||
r,
|
||||
g,
|
||||
b,
|
||||
r2,
|
||||
g2,
|
||||
b2: integer;
|
||||
p: PRGBTriple;
|
||||
|
||||
function CalcColor(c1, c2, c3: integer): integer;
|
||||
begin
|
||||
if c1 = c3 then begin
|
||||
Result := c2;
|
||||
exit;
|
||||
end;
|
||||
|
||||
if c1 = 0 then begin
|
||||
Result := 0;
|
||||
exit;
|
||||
end;
|
||||
|
||||
{ Result := 255 * c1 div c3 - c1 * (255 - c1) * (255 - c2) div c3 div (255 - c3);
|
||||
exit;}
|
||||
|
||||
Result := c1 * c2 div c3;
|
||||
if c2 = 0 then Result := c1 * 150 div 255;
|
||||
if Result > 255 then Result := 255;
|
||||
if Result < 50 then Result := Result + 50;
|
||||
{ exit;
|
||||
a := trunc(x1 * 3);
|
||||
a := c1 * (255 - c1) * c2 * (255 - c2) div c3 div (255 - c3);
|
||||
a := 255 * 255 - 4 * a;
|
||||
try
|
||||
x1 := Trunc((255 - sqrt(a)) / 2);
|
||||
x2 := Trunc((255 + sqrt(a)) / 2);
|
||||
if x1 > x2 then Result := Trunc(x1)
|
||||
else Result := Trunc(x2);
|
||||
except
|
||||
Result := 0;
|
||||
end;}
|
||||
end;
|
||||
|
||||
begin
|
||||
if s = c then exit;
|
||||
if m.Width = 0 then exit;
|
||||
if m.Height = 0 then exit;
|
||||
t := NewBitmap(m.Width, m.Height);
|
||||
m.PixelFormat := pf24bit;
|
||||
t.Assign(m);
|
||||
SplitColor(Color2RGB(s), r, g, b);
|
||||
if r = 0 then r := 1;
|
||||
if g = 0 then g := 1;
|
||||
if b = 0 then b := 1;
|
||||
SplitColor(Color2RGB(c), r2, g2, b2);
|
||||
for j := 0 to t.Height - 1 do begin
|
||||
p := t.scanline[j];
|
||||
for i := 0 to t.Width - 1 do begin
|
||||
p.rgbtRed := CalcColor(p.rgbtRed, r2, r);
|
||||
p.rgbtGreen := CalcColor(p.rgbtGreen, g2, g);
|
||||
p.rgbtBlue := CalcColor(p.rgbtBlue, b2, b);
|
||||
inc(p);
|
||||
end;
|
||||
end;
|
||||
m.Assign(t);
|
||||
t.Free;
|
||||
end;
|
||||
|
||||
function IncColor;
|
||||
var T: TColor;
|
||||
P: PRGBTriple;
|
||||
begin
|
||||
T := Color2RGB(C);
|
||||
p := @T;
|
||||
if D > 0 then begin
|
||||
if p.rgbtBlue < 255 - D then p.rgbtBlue := p.rgbtBlue + D else p.rgbtBlue := 255;
|
||||
if p.rgbtRed < 255 - D then p.rgbtRed := p.rgbtRed + D else p.rgbtRed := 255;
|
||||
if p.rgbtGreen < 255 - D then p.rgbtGreen := p.rgbtGreen + D else p.rgbtGreen := 255;
|
||||
end else begin
|
||||
if p.rgbtBlue > D then p.rgbtBlue := p.rgbtBlue - D else p.rgbtBlue := 000;
|
||||
if p.rgbtRed > D then p.rgbtRed := p.rgbtRed - D else p.rgbtRed := 000;
|
||||
if p.rgbtGreen > D then p.rgbtGreen := p.rgbtGreen - D else p.rgbtGreen := 000;
|
||||
end;
|
||||
Result := T;
|
||||
end;
|
||||
|
||||
begin
|
||||
InstBlockList := nil;
|
||||
InstBlockCount := 0;
|
||||
InstFreeList := nil;
|
||||
end.
|
||||
2299
Addons/RAS.pas
Normal file
2299
Addons/RAS.pas
Normal file
File diff suppressed because it is too large
Load Diff
58
Addons/Serv.pas
Normal file
58
Addons/Serv.pas
Normal file
@@ -0,0 +1,58 @@
|
||||
unit serv;
|
||||
|
||||
interface
|
||||
|
||||
procedure FreeList(var p : pchar; s : word);
|
||||
function NewEList(var p : pointer; s : word; c : boolean) : pointer;
|
||||
|
||||
implementation
|
||||
|
||||
procedure FreeList;
|
||||
var r,
|
||||
d : pchar;
|
||||
begin
|
||||
while p <> nil do begin
|
||||
r := p;
|
||||
d := p + s - 4;
|
||||
move(d^, p, 4);
|
||||
freeMem(r, s);
|
||||
end;
|
||||
end;
|
||||
|
||||
function NextList(p : pchar; s : word) : pointer;
|
||||
var r,
|
||||
d : pchar;
|
||||
begin
|
||||
d := p + s - 4;
|
||||
move(d^, r, 4);
|
||||
NextList := r;
|
||||
end;
|
||||
|
||||
function NewEList;
|
||||
var r,
|
||||
d : pchar;
|
||||
n : pchar;
|
||||
begin
|
||||
if p = Nil then begin
|
||||
getmem(p, s);
|
||||
NewEList := p;
|
||||
r := p;
|
||||
FillChar(r^, s, #0);
|
||||
end else begin
|
||||
n := p;
|
||||
while NextList(n, s) <> nil do begin
|
||||
n := NextList(n, s);
|
||||
end;
|
||||
getmem(r, s);
|
||||
FillChar(r^, s, #0);
|
||||
d := n + s - 4;
|
||||
move(r, d^, 4);
|
||||
if c then begin
|
||||
d := r + s - 8;
|
||||
move(n, d^, 4);
|
||||
end;
|
||||
NewEList := r;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
537
Addons/ToGrush.pas
Normal file
537
Addons/ToGrush.pas
Normal file
@@ -0,0 +1,537 @@
|
||||
unit ToGRush;
|
||||
|
||||
interface
|
||||
|
||||
//{$DEFINE TOGRUSH_AUTO_DISIMAGES} // add this symbol to provide 256 gray images
|
||||
// based on original ones for Disabled state
|
||||
// of toolbar buttons
|
||||
//{$DEFINE TOGRUSH_AUTO_DIS_EQ} // RGB channels of the same level while TOGRUSH_AUTO_DISIMAGES
|
||||
//{$DEFINE TOGRUSH_DROPBTN2} // Drop button will be placed right to the button
|
||||
// having property DropDown, not in the button
|
||||
//{$DEFINE TOGRUSH_NO_AUTO_SIZE_BTNS} // not use AutoSize for buttons
|
||||
// (sensible only in a case, when only images are in the toolbar)
|
||||
|
||||
uses Windows, KOL, KOLGRushControls;
|
||||
|
||||
function NewButton( AParent: PControl; const Caption: KOLString ): PControl;
|
||||
|
||||
function NewCheckbox( AParent: PControl; const Caption: KOLString ): PControl;
|
||||
function NewRadiobox( AParent: PControl; const Caption: KOLString ): PControl;
|
||||
|
||||
function NewPanel( AParent: PControl; EdgeStyle: TEdgeStyle ): PControl;
|
||||
|
||||
function NewSplitter( AParent: PControl; MinSizePrev, MinSizeNext: Integer ): PControl;
|
||||
function NewSplitterEx( AParent: PControl; MinSizePrev, MinSizeNext: Integer;
|
||||
EdgeStyle: TEdgeStyle ): PControl;
|
||||
|
||||
|
||||
function NewToolbar( AParent: PControl; Align: TControlAlign; Options: TToolbarOptions;
|
||||
Bitmap: HBitmap; const Buttons: array of PChar;
|
||||
const BtnImgIdxArray: array of Integer ) : PControl;
|
||||
|
||||
function ToolbarButtonRect( Toolbar: PControl; BtnID: Integer ): TRect;
|
||||
procedure ToolbarSetTooltips( Toolbar: PControl; BtnID1st: Integer; const Tooltips: array of PKOLChar );
|
||||
function ToolbarButtonEnabled( Toolbar: PControl; BtnID: Integer ): Boolean;
|
||||
procedure EnableToolbarButton( Toolbar: PControl; BtnID: Integer; Enable: Boolean );
|
||||
function ToolbarButtonVisible( Toolbar: PControl; BtnID: Integer ): Boolean;
|
||||
procedure ShowHideToolbarButton( Toolbar: PControl; BtnID: Integer; Show: Boolean );
|
||||
|
||||
function NewProgressbar( AParent: PControl ): PControl;
|
||||
function NewProgressbarEx( AParent: PControl; Options: TProgressbarOptions ): PControl;
|
||||
|
||||
implementation
|
||||
|
||||
const
|
||||
IS_DRDWN = 16;
|
||||
type
|
||||
PControl_ = ^TControl_;
|
||||
TControl_ = object( TControl )
|
||||
end;
|
||||
|
||||
////////////////////////////////////////////////////////////////////////////////
|
||||
// BUTTON, CHECK, RADIO CHECK
|
||||
////////////////////////////////////////////////////////////////////////////////
|
||||
function NewButton( AParent: PControl; const Caption: KOLString ): PControl;
|
||||
begin
|
||||
Result := Pointer( NewGRushButton( AParent, Caption ).SetSize( 64, 22 ) );
|
||||
PControl_( Result ).fIsButton := TRUE;
|
||||
end;
|
||||
|
||||
function NewCheckbox( AParent: PControl; const Caption: KOLString ): PControl;
|
||||
begin
|
||||
Result := Pointer( NewGRushCheckBox( AParent, Caption ).SetSize( 64, 22 ) );
|
||||
end;
|
||||
|
||||
function NewRadiobox( AParent: PControl; const Caption: KOLString ): PControl;
|
||||
begin
|
||||
Result := Pointer( NewGRushRadioBox( AParent, Caption ).SetSize( 64, 22 ) );
|
||||
end;
|
||||
|
||||
////////////////////////////////////////////////////////////////////////////////
|
||||
// PANEL
|
||||
////////////////////////////////////////////////////////////////////////////////
|
||||
function NewPanel( AParent: PControl; EdgeStyle: TEdgeStyle ): PControl;
|
||||
begin
|
||||
if EdgeStyle = esTransparent then
|
||||
begin
|
||||
Result := KOL.NewPanel( AParent, esNone ).SetSize( 64, 64 );
|
||||
Result.Transparent := TRUE;
|
||||
end
|
||||
else
|
||||
Result := Pointer( NewGRushPanel( AParent ) );
|
||||
end;
|
||||
|
||||
////////////////////////////////////////////////////////////////////////////////
|
||||
// SPLITTER
|
||||
////////////////////////////////////////////////////////////////////////////////
|
||||
function NewSplitter( AParent: PControl; MinSizePrev, MinSizeNext: Integer ): PControl;
|
||||
begin
|
||||
Result := Pointer( NewGRushSplitter( AParent, MinSizePrev, MinSizeNext ) );
|
||||
Result.Transparent := TRUE;
|
||||
end;
|
||||
|
||||
function NewSplitterEx( AParent: PControl; MinSizePrev, MinSizeNext: Integer;
|
||||
EdgeStyle: TEdgeStyle ): PControl;
|
||||
begin
|
||||
Result := Pointer( NewGRushSplitter( AParent, MinSizePrev, MinSizeNext ) );
|
||||
Result.Transparent := TRUE;
|
||||
end;
|
||||
|
||||
////////////////////////////////////////////////////////////////////////////////
|
||||
// TOOL BAR
|
||||
////////////////////////////////////////////////////////////////////////////////
|
||||
type
|
||||
TTBButtonEvent = packed Record
|
||||
BtnID: DWORD;
|
||||
Event: TOnToolbarButtonClick;
|
||||
end;
|
||||
PTBButtonEvent = ^TTBButtonEvent;
|
||||
procedure ToGR_ClickToolbarBtn( Dummy, Sender: PControl );
|
||||
var D: DWORD;
|
||||
Idx: Integer;
|
||||
IsCheck, Checked: Boolean;
|
||||
Toolbar: PControl_;
|
||||
EventRec: PTBButtonEvent;
|
||||
begin
|
||||
D := GetProp( Sender.Handle, 'GRBTN' );
|
||||
Idx := LoWord( D );
|
||||
IsCheck := HiWord( D ) and 2 <> 0;
|
||||
Checked := HiWord( D ) and 4 <> 0;
|
||||
if IsCheck then
|
||||
begin
|
||||
Checked := not Checked;
|
||||
D := D xor $40000;
|
||||
SetProp( Sender.Handle, 'GRBTN', D );
|
||||
PGrushControl( Sender ).Checked := Checked;
|
||||
end;
|
||||
Toolbar := Pointer( Sender.Parent );
|
||||
if Assigned( Toolbar.fTBEvents ) and
|
||||
(Toolbar.fTBevents.Count > Idx) then
|
||||
begin
|
||||
EventRec := Toolbar.fTBevents.Items[ Idx ];
|
||||
if Assigned( EventRec.Event ) then
|
||||
EventRec.Event( Toolbar, EventRec.BtnID );
|
||||
end
|
||||
else
|
||||
if Assigned( Toolbar.fOnClick ) then
|
||||
begin
|
||||
Toolbar.fOnClick( Toolbar );
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure ToGR_ClickToolbarBtnDD( Dummy, Sender: PControl );
|
||||
var D: DWORD;
|
||||
Idx: Integer;
|
||||
Toolbar: PControl_;
|
||||
EventRec: PTBButtonEvent;
|
||||
begin
|
||||
D := GetProp( Sender.Handle, 'GRBTN' );
|
||||
Idx := LoWord( D );
|
||||
Toolbar := Pointer( Sender.Parent );
|
||||
{$IFDEF TOGRUSH_DROPBTN2}
|
||||
{$ELSE}
|
||||
Toolbar := Pointer( Toolbar.Parent );
|
||||
{$ENDIF}
|
||||
Toolbar.fCurItem := Idx;
|
||||
Toolbar.fCurIndex := Idx;
|
||||
Toolbar.fDropped := TRUE;
|
||||
if Assigned( Toolbar.fTBevents ) and
|
||||
(Toolbar.fTBevents.Count > Idx) then
|
||||
begin
|
||||
EventRec := Toolbar.fTBevents.Items[ Idx ];
|
||||
Toolbar.fCurItem := EventRec.BtnID;
|
||||
end;
|
||||
if Assigned( Toolbar.OnTBDropDown ) then
|
||||
begin
|
||||
Toolbar.OnTBDropDown( Toolbar );
|
||||
end
|
||||
else
|
||||
if Assigned( Toolbar.fOnClick ) then
|
||||
begin
|
||||
Toolbar.fOnClick( Toolbar );
|
||||
end;
|
||||
Toolbar.fDropped := FALSE;
|
||||
end;
|
||||
|
||||
procedure Provide_DIS_images( var B: PBitmap );
|
||||
var B2: PBitmap;
|
||||
y, y_to, x, c: Integer;
|
||||
Src, Dst: PRGBQuad;
|
||||
first_pixel: Boolean;
|
||||
Transp: DWORD;
|
||||
begin
|
||||
if (B =nil) or B.Empty then Exit;
|
||||
B2 := NewDIBBitmap( B.Width, B.Height * 2, pf32bit );
|
||||
TRY
|
||||
B.Draw( B2.Canvas.Handle, 0, 0 );
|
||||
y_to := B.Height;
|
||||
first_pixel := TRUE;
|
||||
Transp := 0;
|
||||
for y := 0 to B.Height-1 do
|
||||
begin
|
||||
Src := B2.ScanLine[ y ];
|
||||
Dst := B2.ScanLine[ y_to ];
|
||||
for x := 0 to B2.Width-1 do
|
||||
begin
|
||||
if first_pixel then
|
||||
Transp := PDWORD( Src )^ and $FFFFFF;
|
||||
first_pixel := FALSE;
|
||||
if PDWORD( Src )^ and $FFFFFF = Transp then
|
||||
PDWORD( Dst )^ := Transp
|
||||
else
|
||||
begin
|
||||
{$IFDEF TOGRUSH_AUTO_DIS_BAL}
|
||||
c := (Src.rgbRed * 64 + Src.rgbGreen * 128 + Src.rgbBlue * (128 + 64))
|
||||
div 256;
|
||||
{$ELSE}
|
||||
c := (Src.rgbRed * 64 + Src.rgbGreen * 64 + Src.rgbBlue * 64)
|
||||
div 100;
|
||||
{$ENDIF}
|
||||
if c > 255 then c := 255;
|
||||
Dst.rgbBlue := c;
|
||||
Dst.rgbGreen := c;
|
||||
Dst.rgbRed := c;
|
||||
end;
|
||||
inc( Src );
|
||||
inc( Dst );
|
||||
end;
|
||||
inc( y_to );
|
||||
end;
|
||||
FINALLY
|
||||
B.Assign( B2 );
|
||||
B2.Free;
|
||||
END;
|
||||
end;
|
||||
|
||||
var DrDownBmp: PBitmap;
|
||||
function NewToolbar( AParent: PControl; Align: TControlAlign; Options: TToolbarOptions;
|
||||
Bitmap: HBitmap; const Buttons: array of PChar;
|
||||
const BtnImgIdxArray: array of Integer ) : PControl;
|
||||
var i, BtnID: Integer;
|
||||
B, B2: PGRushControl;
|
||||
C: String;
|
||||
IsSep: Boolean;
|
||||
IsDropDown: Boolean;
|
||||
IsCheck, Checked, IsRadio: Boolean;
|
||||
Idx: Integer;
|
||||
D: DWORD;
|
||||
imgW, imgH, W, H: Integer;
|
||||
Bmp: PBitmap;
|
||||
DD_dst: PByte;
|
||||
y: Integer;
|
||||
ES: TEdgeStyle;
|
||||
const DD_img: array[ 0..6 ] of Byte = ( $0, $F8, $F8, $70, $70, $20, $20 );
|
||||
begin
|
||||
if Align = caNone then Align := caTop;
|
||||
H := 0;
|
||||
imgW := 0;
|
||||
imgH := 0;
|
||||
Bmp := nil;
|
||||
if Bitmap <> 0 then
|
||||
begin
|
||||
Bmp := NewBitmap( 0, 0 );
|
||||
Bmp.Handle := Bitmap;
|
||||
imgH := Bmp.Height;
|
||||
imgW := imgH;
|
||||
H := Bmp.Height + 12;
|
||||
//Bmp.PixelFormat := pf32bit;
|
||||
//Bmp.SaveToFile( GetStartDir + 'test_toolbar1.bmp' );
|
||||
{$IFDEF TOGRUSH_AUTO_DISIMAGES}
|
||||
Provide_DIS_images( Bmp );
|
||||
{$ENDIF}
|
||||
end;
|
||||
ES := esNone;
|
||||
if [tboTransparent, tboFlat] * Options <> [] then
|
||||
ES := esTransparent;
|
||||
Result := Pointer( NewPanel( AParent, ES ).SetSize( 0, H ).SetAlign(Align) );
|
||||
//if Bmp <> nil then Result.Add2AutoFree( Bmp );
|
||||
Idx := -1;
|
||||
for i := 0 to High( Buttons ) do
|
||||
begin
|
||||
C := Buttons[ i ];
|
||||
IsSep := C = '-';
|
||||
IsDropDown := FALSE;
|
||||
IsCheck := FALSE;
|
||||
Checked := FALSE;
|
||||
BtnID := i; //ToolbarsIDcmd; inc( ToolbarsIDcmd );
|
||||
if IsSep then C := ''
|
||||
else
|
||||
begin
|
||||
Inc( Idx );
|
||||
IsDropDown := (C <> '') and (C[ 1 ] = '^');
|
||||
if IsDropDown then Delete( C, 1, 1 );
|
||||
IsCheck := (C <> '') and (C[ 1 ] in [ '+', '-' ]);
|
||||
if IsCheck then
|
||||
begin
|
||||
Checked := C[ 1 ] = '+';
|
||||
Delete( C, 1, 1 );
|
||||
IsRadio := (C <> '') and (C[ 1 ] = '!');
|
||||
if IsRadio then Delete( C, 1, 1 );
|
||||
end;
|
||||
end;
|
||||
if Trim( C ) = '' then C := '';
|
||||
if IsSep then
|
||||
NewPanel( Result, esTransparent ).SetSize( 6, 0 ).SetAlign( caLeft )
|
||||
else
|
||||
begin
|
||||
if C = '' then
|
||||
begin
|
||||
W := 32;
|
||||
if H <> 0 then W := H;
|
||||
end
|
||||
else
|
||||
begin
|
||||
W := 64;
|
||||
end;
|
||||
B := Pointer( NewButton( Result, C ).SetSize( W, 0 ).SetAlign( caLeft ) );
|
||||
{$IFDEF USE_NAMES}
|
||||
//B.Name := 'TB' + Int2Str( Idx+1 );
|
||||
{$ENDIF USE_NAMES}
|
||||
B.Tabstop := FALSE;
|
||||
B.LikeSpeedButton;
|
||||
B.Transparent := TRUE;
|
||||
if IsSep then B.Enabled := FALSE;
|
||||
if B.GetWindowHandle <> 0 then
|
||||
begin
|
||||
D := i or Integer( IsSep ) shl 16
|
||||
or Integer( IsCheck ) shl 17
|
||||
or Integer( Checked ) shl 18
|
||||
or Integer( IsDropDown ) shl 19
|
||||
;
|
||||
SetProp( B.Handle, 'GRBTN', D );
|
||||
end;
|
||||
SetProp( B.Handle, 'BTNID', BtnID );
|
||||
B.OnClick := TOnEvent( MakeMethod( nil, @ ToGR_ClickToolbarBtn ) );
|
||||
if Bmp <> nil then
|
||||
begin
|
||||
B.All_GlyphItemX := idx;
|
||||
B.All_GlyphItemY := 0;
|
||||
B.All_GlyphBitmap := Bmp;
|
||||
B.All_GlyphWidth := ImgW;
|
||||
B.All_GlyphHeight := ImgH;
|
||||
//B.All_GlyphAttached := TRUE;
|
||||
{$IFDEF TOGRUSH_AUTO_DISIMAGES}
|
||||
B.Dis_GlyphItemX := idx;
|
||||
B.Dis_GlyphItemY := 1;
|
||||
B.All_GlyphBitmap := Bmp;
|
||||
B.All_GlyphWidth := ImgW;
|
||||
B.All_GlyphHeight := ImgH;
|
||||
{$ENDIF}
|
||||
if not IsDropDown and (C = '') then
|
||||
B.All_GlyphHAlign := haCenter;
|
||||
end;
|
||||
{$IFNDEF TOGRUSH_NO_AUTO_SIZE_BTNS}
|
||||
B.fCommandActions.aAutoSzX := 10 + ImgW;
|
||||
if ImgW > 0 then inc( B.fCommandActions.aAutoSzX, 5 );
|
||||
if IsDropDown then inc( B.fCommandActions.aAutoSzX, 10 );
|
||||
B.AutoSize( TRUE );
|
||||
{$ENDIF}
|
||||
if IsDropDown then
|
||||
begin
|
||||
{$IFDEF TOGRUSH_DROPBTN2}
|
||||
B2 := Pointer( NewButton( Result, C ).SetSize( 5 + 8, 0 ).SetAlign( caLeft ) );
|
||||
{$ELSE}
|
||||
//B.AutoSize( FALSE );
|
||||
//B.Width := W + 13;
|
||||
B.All_TextHAlign := haLeft;
|
||||
B.Border := 2;
|
||||
B2 := Pointer( NewButton( B, C ).SetSize( 5 + 8, 0 ).SetAlign( caRight ) );
|
||||
{$ENDIF}
|
||||
{$IFDEF USE_NAMES}
|
||||
//B2.Name := 'TB_dd' + Int2Str( Idx+1 );
|
||||
{$ENDIF USE_NAMES}
|
||||
B2.Tabstop := FALSE;
|
||||
B2.LikeSpeedButton;
|
||||
B2.Transparent := TRUE;
|
||||
PGrushControl( B2 ).All_BorderWidth := 0;
|
||||
PGrushControl( B2 ).Over_BorderWidth := 1;
|
||||
if B2.GetWindowHandle <> 0 then
|
||||
begin
|
||||
D := i or Integer( IsSep ) shl 16
|
||||
or Integer( IsCheck ) shl 17
|
||||
or Integer( Checked ) shl 18
|
||||
or Integer( IsDropDown ) shl 19
|
||||
or IS_DRDWN shl 16;
|
||||
SetProp( B2.Handle, 'GRBTN', D );
|
||||
end;
|
||||
B2.OnClick := TOnEvent( MakeMethod( nil, @ ToGR_ClickToolbarBtnDD ) );
|
||||
if DrDownBmp = nil then
|
||||
begin
|
||||
DrDownBmp := NewDIBBitmap( 5, High( DD_img )+1, pf1bit );
|
||||
DrDownBmp.DIBPalEntries[ 0 ] := $686868;
|
||||
DrDownBmp.DIBPalEntries[ 1 ] := $FFFFFF;
|
||||
for y := 0 to High( DD_img ) do
|
||||
begin
|
||||
DD_dst := DrDownBmp.ScanLine[ y ];
|
||||
DD_dst^ := not DD_img[ y ];
|
||||
end;
|
||||
//B2.All_GlyphItemX := 0;
|
||||
//B.All_GlyphItemY := 0;
|
||||
B2.All_GlyphBitmap := DrDownBmp;
|
||||
DrDownBmp.RefDec;
|
||||
end
|
||||
else
|
||||
begin
|
||||
B2.All_GlyphBitmap := DrDownBmp;
|
||||
end;
|
||||
B2.All_GlyphWidth := 5;
|
||||
B2.All_GlyphHeight := High( DD_img )+1;
|
||||
B2.All_GlyphHAlign := haCenter;
|
||||
B2.All_GlyphVAlign := vaBottom;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
if Bmp <> nil then
|
||||
begin
|
||||
Bmp.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
function ToolbarButtonRect( Toolbar: PControl; BtnID: Integer ): TRect;
|
||||
var i: Integer;
|
||||
B: PControl;
|
||||
begin
|
||||
for i := 0 to Toolbar.ChildCount-1 do
|
||||
begin
|
||||
B := Toolbar.Children[ i ];
|
||||
if (B.GetWindowHandle <> 0) and
|
||||
(Integer( GetProp( B.Handle, 'BTNID' ) ) = BtnID) then
|
||||
begin
|
||||
Result := B.BoundsRect;
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
Result := MakeRect( 0, 0, 0, 0 );
|
||||
end;
|
||||
|
||||
procedure ToolbarSetTooltips( Toolbar: PControl; BtnID1st: Integer; const Tooltips: array of PKOLChar );
|
||||
{$IFDEF USE_MHTOOLTIP}
|
||||
var i, j: Integer;
|
||||
B: PControl;
|
||||
found: Boolean;
|
||||
{$ENDIF}
|
||||
begin
|
||||
Toolbar.TBSetTooltips( BtnID1st, Tooltips );
|
||||
{$IFDEF USE_MHTOOLTIP}
|
||||
found := FALSE;
|
||||
j := 0;
|
||||
if BtnID1st < 0 then BtnID1st := 0;
|
||||
for i := 0 to Toolbar.ChildCount-1 do
|
||||
begin
|
||||
if j > High( Tooltips ) then break;
|
||||
B := Toolbar.Children[ i ];
|
||||
//if not B.IsButton then continue;
|
||||
if HiWord( GetProp( B.Handle, 'GRBTN' ) ) and IS_DRDWN <> 0 then
|
||||
continue;
|
||||
if found or (Integer( GetProp( B.Handle, 'BTNID' ) ) = BtnID1st) then
|
||||
begin
|
||||
found := TRUE;
|
||||
if Trim( Tooltips[ j ] ) <> '' then
|
||||
NewHint( B ).Text := Tooltips[ j ];
|
||||
inc( BtnID1st );
|
||||
inc( j );
|
||||
end;
|
||||
end;
|
||||
{$ENDIF USE_MHTOOLTIP}
|
||||
end;
|
||||
|
||||
function ToolbarButtonEnabled( Toolbar: PControl; BtnID: Integer ): Boolean;
|
||||
var i: Integer;
|
||||
B: PControl;
|
||||
begin
|
||||
for i := 0 to Toolbar.ChildCount-1 do
|
||||
begin
|
||||
B := Toolbar.Children[ i ];
|
||||
if (B.GetWindowHandle <> 0) and
|
||||
(Integer( GetProp( B.Handle, 'BTNID' ) ) = BtnID) then
|
||||
begin
|
||||
Result := B.Enabled;
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
Result := FALSE;
|
||||
end;
|
||||
|
||||
procedure EnableToolbarButton( Toolbar: PControl; BtnID: Integer; Enable: Boolean );
|
||||
var i: Integer;
|
||||
B: PControl;
|
||||
begin
|
||||
for i := 0 to Toolbar.ChildCount-1 do
|
||||
begin
|
||||
B := Toolbar.Children[ i ];
|
||||
if (B.GetWindowHandle <> 0) and
|
||||
(Integer( GetProp( B.Handle, 'BTNID' ) ) = BtnID) then
|
||||
begin
|
||||
B.Enabled := Enable;
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function ToolbarButtonVisible( Toolbar: PControl; BtnID: Integer ): Boolean;
|
||||
var i: Integer;
|
||||
B: PControl;
|
||||
begin
|
||||
for i := 0 to Toolbar.ChildCount-1 do
|
||||
begin
|
||||
B := Toolbar.Children[ i ];
|
||||
if (B.GetWindowHandle <> 0) and
|
||||
(Integer( GetProp( B.Handle, 'BTNID' ) ) = BtnID) then
|
||||
begin
|
||||
Result := B.Visible;
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
Result := FALSE;
|
||||
end;
|
||||
|
||||
procedure ShowHideToolbarButton( Toolbar: PControl; BtnID: Integer; Show: Boolean );
|
||||
var i: Integer;
|
||||
B: PControl;
|
||||
begin
|
||||
for i := 0 to Toolbar.ChildCount-1 do
|
||||
begin
|
||||
B := Toolbar.Children[ i ];
|
||||
if (B.GetWindowHandle <> 0) and
|
||||
(Integer( GetProp( B.Handle, 'BTNID' ) ) = BtnID) then
|
||||
begin
|
||||
B.Visible := Show;
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
////////////////////////////////////////////////////////////////////////////////
|
||||
// PROGRESS BAR
|
||||
////////////////////////////////////////////////////////////////////////////////
|
||||
function NewProgressbar( AParent: PControl ): PControl;
|
||||
begin
|
||||
Result := Pointer( NewGRushProgressBar( AParent ).SetSize( 300, 20 ) );
|
||||
end;
|
||||
|
||||
function NewProgressbarEx( AParent: PControl; Options: TProgressbarOptions ): PControl;
|
||||
begin
|
||||
Result := NewProgressbar( AParent );
|
||||
end;
|
||||
|
||||
end.
|
||||
130
Addons/UDig.pas
Normal file
130
Addons/UDig.pas
Normal file
@@ -0,0 +1,130 @@
|
||||
unit UDig;
|
||||
|
||||
interface
|
||||
|
||||
function stri (n,n1:integer;zero,trim:boolean):string;
|
||||
function strL (n: longint; n1 :integer):string;
|
||||
|
||||
{function strr(n:real;n1,n2:word):string;
|
||||
function strH (w : longint; c : word) : string;}
|
||||
function strhl(w : longint; c : word) : string;
|
||||
function hexi(s:string):word;
|
||||
function hexl(s:string):longint;
|
||||
function inti(s:string):word;
|
||||
{function intl(s:string):longint; }
|
||||
|
||||
implementation
|
||||
|
||||
uses UWrd, UStr;
|
||||
|
||||
function atrim(s : string) : string;
|
||||
var t : string;
|
||||
begin
|
||||
t := s;
|
||||
while (t[1] = ' ') and (length(t) > 0) do t := copy(t, 2, 255);
|
||||
while (t[length(t)] = ' ') and (length(t) > 0) do t := copy(t, 1, length(t) - 1);
|
||||
atrim := t;
|
||||
end;
|
||||
|
||||
{
|
||||
function strh;
|
||||
const a:array[0..15] of cHar =
|
||||
('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F');
|
||||
var r:string;
|
||||
begin
|
||||
if c>0 then r:=strh(w div 16,c-1)+a[w mod 16]
|
||||
else r:='';
|
||||
strH := r;
|
||||
end;
|
||||
}
|
||||
function strhl;
|
||||
const a:array[0..15] of cHar =
|
||||
('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F');
|
||||
var r:string;
|
||||
begin
|
||||
if c > 0 then
|
||||
if w mod 16 >= 0 tHen r := strhl(w sHr 4, c - 1) + a[ w mod 16] else
|
||||
r := strHl(w sHr 4, c - 1) + a[16 + w mod 16]
|
||||
else r := '';
|
||||
strHl := r;
|
||||
end;
|
||||
|
||||
function hexi;
|
||||
const a : string[15] ='123456789ABCDEF';
|
||||
var i : integer;
|
||||
h :word;
|
||||
begin
|
||||
h:=0;
|
||||
for i:=1 to length(s) do begin
|
||||
if S[i]<>' ' then begin
|
||||
h:=h shl 4;
|
||||
h:=h+pos(UpCase(S[i]),a);
|
||||
end;
|
||||
end;
|
||||
hexi:=h;
|
||||
end;
|
||||
|
||||
function hexl;
|
||||
const a : string[15] ='123456789ABCDEF';
|
||||
var i : integer;
|
||||
h :longint;
|
||||
begin
|
||||
h:=0;
|
||||
for i:=1 to length(s) do begin
|
||||
if S[i]<>' ' then begin
|
||||
h:=h shl 4;
|
||||
h:=h+pos(UpCase(S[i]),a);
|
||||
end;
|
||||
end;
|
||||
hexl:=h;
|
||||
end;
|
||||
|
||||
function inti;
|
||||
var
|
||||
rc : integer;
|
||||
ww : longint;
|
||||
begin
|
||||
val(s, ww, rc);
|
||||
inti := ww;
|
||||
end;
|
||||
{
|
||||
function intl;
|
||||
var
|
||||
rc : integer;
|
||||
ww : integer;
|
||||
begin
|
||||
val(s, ww, rc);
|
||||
intl := ww;
|
||||
end;
|
||||
}
|
||||
|
||||
function stri;
|
||||
var s : string;
|
||||
i : integer;
|
||||
begin
|
||||
str(n: n1, s);
|
||||
if zero THen begin
|
||||
for i := 1 to lengtH(s) do
|
||||
if s[i] = ' ' THen s[i] := '0';
|
||||
end;
|
||||
if trim then s := atrim(s);
|
||||
stri := s;
|
||||
end;
|
||||
|
||||
function strl;
|
||||
var s:string;
|
||||
begin
|
||||
str(n:n1,s);
|
||||
strl:=s;
|
||||
end;
|
||||
|
||||
{
|
||||
function strr;
|
||||
var s:string;
|
||||
begin
|
||||
str(n:n1:n2,s);
|
||||
strr:=s;
|
||||
end;
|
||||
}
|
||||
|
||||
end.
|
||||
99
Addons/UFor.pas
Normal file
99
Addons/UFor.pas
Normal file
@@ -0,0 +1,99 @@
|
||||
unit UFor;
|
||||
|
||||
interface
|
||||
|
||||
function points(d : boolean; t : string; m : integer): string;
|
||||
function toreal(r : string): real;
|
||||
function rtostr(r : real): string;
|
||||
function plslop(o, c: string; back, buys: boolean): string;
|
||||
function plslom(o, c: string; back, buys: boolean; size, amnt, intr: string): string;
|
||||
function chkprc(o, c, q, b: string): boolean;
|
||||
|
||||
implementation
|
||||
uses SysUtils;
|
||||
|
||||
function points;
|
||||
var s : string;
|
||||
p,
|
||||
i,
|
||||
e : integer;
|
||||
begin
|
||||
s := t;
|
||||
if pos('.', s) = 0 then s := s + '.';
|
||||
while length(s) < 6 do s := s + '0';
|
||||
p := pos('.', s);
|
||||
s := copy(s, 1, p - 1) + copy(s, p + 1, 6 - p);
|
||||
val(s, i, e);
|
||||
if d then inc(i, m) else dec(i, m);
|
||||
s := inttostr(i);
|
||||
while length(s) < 5 do s := '0' + s;
|
||||
s := copy(s, 1, p - 1) + '.' + copy(s, p, 6 - p);
|
||||
points := s;
|
||||
end;
|
||||
|
||||
function toreal(r: string): real;
|
||||
var f : real;
|
||||
i : integer;
|
||||
s : string;
|
||||
begin
|
||||
S := R;
|
||||
val(trim(S), F, I);
|
||||
if (i > 0) and (I < length(S)) then begin
|
||||
if S[I] = '.' then S[I] := ',' else
|
||||
if S[I] = ',' then S[i] := '.';
|
||||
val(trim(S), F, I);
|
||||
end;
|
||||
result := F;
|
||||
end;
|
||||
|
||||
function rtostr;
|
||||
var s : string;
|
||||
begin
|
||||
str(r:5:2, s);
|
||||
rtostr := s;
|
||||
end;
|
||||
|
||||
function plslop;
|
||||
var op,
|
||||
cl : real;
|
||||
j : integer;
|
||||
begin
|
||||
op := toreal(o);
|
||||
cl := toreal(c);
|
||||
repeat
|
||||
op := op * 10;
|
||||
cl := cl * 10;
|
||||
until op > 3000;
|
||||
j := round(cl - op);
|
||||
if back xor buys then j := -j;
|
||||
plslop := inttostr(j);
|
||||
end;
|
||||
|
||||
function plslom;
|
||||
var op, cl: real;
|
||||
dd: real;
|
||||
begin
|
||||
plslom := '0';
|
||||
op := toreal(o);
|
||||
cl := toreal(c);
|
||||
if (op = 0) or (cl = 0) then exit;
|
||||
if back then dd := cl - op
|
||||
else dd := 1/op - 1/cl;
|
||||
dd := dd * toreal(size);
|
||||
if back xor buys then dd := -dd;
|
||||
dd := dd * strtoint(amnt) - toreal(intr);
|
||||
plslom := rtostr(dd);
|
||||
end;
|
||||
|
||||
function chkprc;
|
||||
var op, cl: real;
|
||||
bk, sb: boolean;
|
||||
begin
|
||||
op := toreal(o);
|
||||
cl := toreal(c);
|
||||
bk := (q = 'EUR') or (q = 'GBP');
|
||||
sb := (b = 'Buy');
|
||||
chkprc := (op >= cl) xor (bk xor sb);
|
||||
end;
|
||||
|
||||
end.
|
||||
301
Addons/USrv.pas
Normal file
301
Addons/USrv.pas
Normal file
@@ -0,0 +1,301 @@
|
||||
Unit USrv;
|
||||
|
||||
interface
|
||||
uses Windows, Classes, Graphics, Controls, Messages, Dialogs,
|
||||
SysUtils;
|
||||
|
||||
const WM_GETIMAGE = WM_USER + $0429;
|
||||
|
||||
function BitmapToRegion(Bitmap: TBitmap): HRGN;
|
||||
function CopyToBitmap(Control: TControl; Bitmap: TBitmap; Anyway: boolean): boolean;
|
||||
procedure CopyParentImage(Control: TControl; Dest: TCanvas);
|
||||
procedure RestoreImage(DestDC: HDC; SrcBitmap: TBitmap; r: TRect;
|
||||
dwROP: dword); overload;
|
||||
procedure RestoreImage(DestDC: HDC; SrcBitmap: TBitmap; l, t, w, h: integer;
|
||||
dwROP: dword); overload;
|
||||
procedure AjustBitmap(const M: TBitmap; S, C: TColor);
|
||||
procedure FadeBitmap(const M: TBitmap; C: TColor; D: byte);
|
||||
function IncColor(C: TColor; D: integer): TColor;
|
||||
|
||||
implementation
|
||||
|
||||
function BitmapToRegion(Bitmap: TBitmap): HRGN;
|
||||
var
|
||||
X, Y: Integer;
|
||||
XStart: Integer;
|
||||
TransC: TColor;
|
||||
R: HRGN;
|
||||
begin
|
||||
Result := 0;
|
||||
with Bitmap do begin
|
||||
TransC := Canvas.Pixels[0, 0];
|
||||
for Y := 0 to Height - 1 do begin
|
||||
X := 0;
|
||||
while X < Width do begin
|
||||
while (X < Width) and (Canvas.Pixels[X, Y] = TransC) do Inc(X);
|
||||
if X >= Width then Break;
|
||||
XStart := X;
|
||||
while (X < Width) and (Canvas.Pixels[X, Y] <> TransC) do Inc(X);
|
||||
R := CreateRectRgn(XStart, Y, X, Y + 1);
|
||||
if Result = 0 then Result := R
|
||||
else begin
|
||||
CombineRgn(Result, Result, R, RGN_OR);
|
||||
DeleteObject(R);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function CopyToBitmap;
|
||||
var x, y: integer;
|
||||
begin
|
||||
Result := False;
|
||||
if Control = nil then exit;
|
||||
x := BitMap.Width - 2;
|
||||
y := BitMap.Height - 2;
|
||||
if (Anyway) or
|
||||
(x + 2 <> Control.Width) or
|
||||
(y + 2 <> Control.Height) or
|
||||
(BitMap.Canvas.Pixels[x, y] = $FFFFFF) or
|
||||
(BitMap.Canvas.Pixels[x, y] = $000000) then begin
|
||||
BitMap.Width := Control.Width;
|
||||
BitMap.Height := Control.Height;
|
||||
CopyParentImage(Control, BitMap.Canvas);
|
||||
Result := True;
|
||||
end;
|
||||
end;
|
||||
|
||||
type
|
||||
TParentControl = class(TWinControl);
|
||||
|
||||
procedure CopyParentImage(Control: TControl; Dest: TCanvas);
|
||||
var
|
||||
I, Count, X, Y, SaveIndex: Integer;
|
||||
DC: HDC;
|
||||
R, SelfR, CtlR: TRect;
|
||||
begin
|
||||
if (Control = nil) or (Control.Parent = nil) then Exit;
|
||||
Count := Control.Parent.ControlCount;
|
||||
DC := Dest.Handle;
|
||||
with Control.Parent do ControlState := ControlState + [csPaintCopy];
|
||||
try
|
||||
with Control do begin
|
||||
SelfR := Bounds(Left, Top, Width, Height);
|
||||
X := -Left; Y := -Top;
|
||||
end;
|
||||
{ Copy parent control image }
|
||||
SaveIndex := SaveDC(DC);
|
||||
try
|
||||
if TParentControl(Control.Parent).Perform(
|
||||
WM_GETIMAGE, DC, integer(@SelfR)) <> $29041961 then begin
|
||||
SetViewportOrgEx(DC, X, Y, nil);
|
||||
IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth,
|
||||
Control.Parent.ClientHeight);
|
||||
with TParentControl(Control.Parent) do begin
|
||||
Perform(WM_ERASEBKGND, DC, 0);
|
||||
PaintWindow(DC);
|
||||
end;
|
||||
end;
|
||||
finally
|
||||
RestoreDC(DC, SaveIndex);
|
||||
end;
|
||||
{ Copy images of graphic controls }
|
||||
for I := 0 to Count - 1 do begin
|
||||
if Control.Parent.Controls[I] = Control then continue
|
||||
else if (Control.Parent.Controls[I] <> nil) and
|
||||
(Control.Parent.Controls[I] is TGraphicControl) then
|
||||
begin
|
||||
with TGraphicControl(Control.Parent.Controls[I]) do begin
|
||||
CtlR := Bounds(Left, Top, Width, Height);
|
||||
if Bool(IntersectRect(R, SelfR, CtlR)) and Visible then begin
|
||||
ControlState := ControlState + [csPaintCopy];
|
||||
SaveIndex := SaveDC(DC);
|
||||
try
|
||||
if Perform(
|
||||
WM_GETIMAGE, DC, integer(@SelfR)) <> $29041961 then begin
|
||||
{ SaveIndex := SaveDC(DC);}
|
||||
SetViewportOrgEx(DC, Left + X, Top + Y, nil);
|
||||
IntersectClipRect(DC, 0, 0, Width, Height);
|
||||
Perform(WM_PAINT, DC, 0);
|
||||
end;
|
||||
finally
|
||||
RestoreDC(DC, SaveIndex);
|
||||
ControlState := ControlState - [csPaintCopy];
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
finally
|
||||
with Control.Parent do ControlState := ControlState - [csPaintCopy];
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure RestoreImage(DestDC: HDC; SrcBitmap: TBitmap; r: TRect;
|
||||
dwROP: dword); overload;
|
||||
begin
|
||||
RestoreImage(DestDC, SrcBitmap, r.Left, r.Top,
|
||||
r.Right - r.Left, r.Bottom - r.Top, dwROP);
|
||||
end;
|
||||
|
||||
procedure RestoreImage(DestDC: HDC; SrcBitmap: TBitmap; l, t, w, h: integer;
|
||||
dwROP: dword); overload;
|
||||
var x, y: integer;
|
||||
begin
|
||||
x := l + w div 2;
|
||||
y := t + h div 2;
|
||||
if (SrcBitmap.Canvas.Pixels[x, y] <> $FFFFFF) and
|
||||
(SrcBitMap.Canvas.Pixels[x, y] <> $000000) then begin
|
||||
x := l;
|
||||
y := t;
|
||||
if y + h > SrcBitMap.Height then begin
|
||||
y := SrcBitMap.Height - h;
|
||||
end;
|
||||
bitblt(DestDC, l, t, w, h,
|
||||
SrcBitMap.Canvas.Handle, x, y, dwROP);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure SplitColor(C: TColor; var r, g, b: integer);
|
||||
begin
|
||||
b := (c and $FF0000) shr 16;
|
||||
g := (c and $00FF00) shr 08;
|
||||
r := (c and $0000FF) shr 00;
|
||||
end;
|
||||
|
||||
procedure AjustBitmap;
|
||||
var i, j: integer;
|
||||
t: TBitmap;
|
||||
r,
|
||||
g,
|
||||
b,
|
||||
r2,
|
||||
g2,
|
||||
b2: integer;
|
||||
p: PRGBTriple;
|
||||
|
||||
function CalcColor(c1, c2, c3: integer): integer;
|
||||
begin
|
||||
if c1 = c3 then begin
|
||||
Result := c2;
|
||||
exit;
|
||||
end;
|
||||
|
||||
if c1 = 0 then begin
|
||||
Result := 0;
|
||||
exit;
|
||||
end;
|
||||
|
||||
{ Result := 255 * c1 div c3 - c1 * (255 - c1) * (255 - c2) div c3 div (255 - c3);
|
||||
exit;}
|
||||
|
||||
Result := c1 * c2 div c3;
|
||||
if c2 = 0 then Result := c1 * 150 div 255;
|
||||
if Result > 255 then Result := 255;
|
||||
if Result < 50 then Result := Result + 50;
|
||||
{ exit;
|
||||
a := trunc(x1 * 3);
|
||||
a := c1 * (255 - c1) * c2 * (255 - c2) div c3 div (255 - c3);
|
||||
a := 255 * 255 - 4 * a;
|
||||
try
|
||||
x1 := Trunc((255 - sqrt(a)) / 2);
|
||||
x2 := Trunc((255 + sqrt(a)) / 2);
|
||||
if x1 > x2 then Result := Trunc(x1)
|
||||
else Result := Trunc(x2);
|
||||
except
|
||||
Result := 0;
|
||||
end;}
|
||||
end;
|
||||
|
||||
begin
|
||||
if s = c then exit;
|
||||
if m.Width = 0 then exit;
|
||||
if m.Height = 0 then exit;
|
||||
t := TBitmap.Create;
|
||||
m.PixelFormat := pf24bit;
|
||||
t.Assign(m);
|
||||
SplitColor(ColorToRGB(s), r, g, b);
|
||||
if r = 0 then r := 1;
|
||||
if g = 0 then g := 1;
|
||||
if b = 0 then b := 1;
|
||||
SplitColor(ColorToRGB(c), r2, g2, b2);
|
||||
for j := 0 to t.Height - 1 do begin
|
||||
p := t.scanline[j];
|
||||
for i := 0 to t.Width - 1 do begin
|
||||
p.rgbtRed := CalcColor(p.rgbtRed, r2, r);
|
||||
p.rgbtGreen := CalcColor(p.rgbtGreen, g2, g);
|
||||
p.rgbtBlue := CalcColor(p.rgbtBlue, b2, b);
|
||||
inc(p);
|
||||
end;
|
||||
end;
|
||||
m.Assign(t);
|
||||
t.Free;
|
||||
end;
|
||||
|
||||
procedure FadeBitmap;
|
||||
var i, j: integer;
|
||||
t: TBitmap;
|
||||
r,
|
||||
g,
|
||||
b: integer;
|
||||
p: PRGBTriple;
|
||||
|
||||
function CalcColor(o: byte; c: byte; b: byte): byte;
|
||||
var d: byte;
|
||||
begin
|
||||
Result := c;
|
||||
if o > c then begin
|
||||
d := $FF - c;
|
||||
if d > b then d := b;
|
||||
Result := c + c * d div 255;
|
||||
end else
|
||||
if o < c then begin
|
||||
d := c;
|
||||
if d > b then d := b;
|
||||
Result := c - c * d div 255;
|
||||
end;
|
||||
end;
|
||||
|
||||
begin
|
||||
if m.Width = 0 then exit;
|
||||
if m.Height = 0 then exit;
|
||||
t := TBitmap.Create;
|
||||
m.PixelFormat := pf24bit;
|
||||
t.Assign(m);
|
||||
SplitColor(ColorToRGB(c), r, g, b);
|
||||
if r = 0 then r := 1;
|
||||
if g = 0 then g := 1;
|
||||
if b = 0 then b := 1;
|
||||
for j := 0 to t.Height - 1 do begin
|
||||
p := t.scanline[j];
|
||||
for i := 0 to t.Width - 1 do begin
|
||||
p.rgbtRed := CalcColor(p.rgbtRed, r, d);
|
||||
p.rgbtGreen := CalcColor(p.rgbtGreen, g, d);
|
||||
p.rgbtBlue := CalcColor(p.rgbtBlue, b, d);
|
||||
inc(p);
|
||||
end;
|
||||
end;
|
||||
m.Assign(t);
|
||||
t.Free;
|
||||
end;
|
||||
|
||||
function IncColor;
|
||||
var T: TColor;
|
||||
P: PRGBTriple;
|
||||
begin
|
||||
T := ColorToRGB(C);
|
||||
p := @T;
|
||||
if D > 0 then begin
|
||||
if p.rgbtBlue < 255 - D then p.rgbtBlue := p.rgbtBlue + D else p.rgbtBlue := 255;
|
||||
if p.rgbtRed < 255 - D then p.rgbtRed := p.rgbtRed + D else p.rgbtRed := 255;
|
||||
if p.rgbtGreen < 255 - D then p.rgbtGreen := p.rgbtGreen + D else p.rgbtGreen := 255;
|
||||
end else begin
|
||||
if p.rgbtBlue > D then p.rgbtBlue := p.rgbtBlue - D else p.rgbtBlue := 000;
|
||||
if p.rgbtRed > D then p.rgbtRed := p.rgbtRed - D else p.rgbtRed := 000;
|
||||
if p.rgbtGreen > D then p.rgbtGreen := p.rgbtGreen - D else p.rgbtGreen := 000;
|
||||
end;
|
||||
Result := T;
|
||||
end;
|
||||
|
||||
end.
|
||||
258
Addons/UStr.pas
Normal file
258
Addons/UStr.pas
Normal file
@@ -0,0 +1,258 @@
|
||||
unit UStr;
|
||||
|
||||
interface
|
||||
|
||||
function space ( n:integer):string ;
|
||||
function replicate(ch:char; n:integer):string ;
|
||||
function trim (str:string;c:boolean=false):string ;
|
||||
function alike (a,b:string;var d, p: integer): boolean;
|
||||
function center (str:string;n:integer):string ;
|
||||
function UpSt ( s:string ):string;
|
||||
function LoSt ( s:string ):string;
|
||||
function lpad ( s:string;n:integer;c:char):string;
|
||||
function rpad ( s:string;n:integer;c:char):string;
|
||||
function addbackslash(p : string) : string;
|
||||
function match (sm : string; var st: string) : boolean;
|
||||
function lines (p, l, s : longint) : string;
|
||||
function LoCase (c : char) : char;
|
||||
function JustPathName(PathName : string) : string;
|
||||
function JustFileName(PathName : string) : string;
|
||||
function JustName (PathName : string) : string;
|
||||
function CRC16 (s : string) : system.word;
|
||||
|
||||
implementation
|
||||
|
||||
function space;
|
||||
var i : integer;
|
||||
tempstr : string;
|
||||
begin
|
||||
tempstr:='';
|
||||
for i:=1 to n do tempstr:=tempstr+' ';
|
||||
space:=tempstr;
|
||||
end;
|
||||
|
||||
function replicate;
|
||||
var i : integer;
|
||||
tempstr : string;
|
||||
begin
|
||||
tempstr:='';
|
||||
for i:=1 to n do tempstr:=tempstr+ch;
|
||||
replicate:=tempstr;
|
||||
end;
|
||||
|
||||
function trim;
|
||||
var i,j : integer;
|
||||
s : string;
|
||||
begin
|
||||
trim := '';
|
||||
s := str;
|
||||
if length(str) > 1 then begin
|
||||
i := length(str);
|
||||
j := 1;
|
||||
while (j <= i) and (str[j] = ' ') do inc(j);
|
||||
if j > i then begin
|
||||
result := '';
|
||||
exit;
|
||||
end;
|
||||
while (str[i] = ' ') do dec(i);
|
||||
s := copy(str, j, i - j + 1);
|
||||
end;
|
||||
if c and (length(s) > 3) then begin
|
||||
repeat
|
||||
i := pos(' ', s);
|
||||
if i > 0 then begin
|
||||
s := copy(s, 1, i - 1) + copy(s, i + 1, length(s) - i);
|
||||
end;
|
||||
until i = 0;
|
||||
end;
|
||||
if c then result := LoSt(s)
|
||||
else result := s;
|
||||
end;
|
||||
|
||||
function alike;
|
||||
var e, f: integer;
|
||||
begin
|
||||
result := false;
|
||||
p := 0;
|
||||
e := length(a);
|
||||
f := length(b);
|
||||
if e + f = 0 then begin
|
||||
result := true;
|
||||
d := 100;
|
||||
exit;
|
||||
end;
|
||||
if (e = 0) or (f = 0) then begin
|
||||
d := 0;
|
||||
exit;
|
||||
end;
|
||||
while (p < e) and (p < f) do begin
|
||||
inc(p);
|
||||
if a[p] <> b[p] then begin
|
||||
dec(p);
|
||||
break;
|
||||
end;
|
||||
end;
|
||||
d := 200 * p div (e + f);
|
||||
if p * 2 > (e + f) div 2 then begin
|
||||
result := true;
|
||||
end;
|
||||
end;
|
||||
|
||||
function center;
|
||||
var tempstr : string;
|
||||
j : integer;
|
||||
begin
|
||||
j := n - length(trim(str));
|
||||
if j > 0 then tempstr := space(j - j div 2) + trim(str) + space(j div 2)
|
||||
else tempstr := trim(str);
|
||||
center := tempstr;
|
||||
end;
|
||||
|
||||
function UpSt;
|
||||
var t : string;
|
||||
i : integer;
|
||||
begin
|
||||
t := s;
|
||||
for i := 1 to length(s) do t[i] := UpCase(s[i]);
|
||||
UpSt := t;
|
||||
end;
|
||||
|
||||
function LoSt;
|
||||
var t : string;
|
||||
i : integer;
|
||||
begin
|
||||
t := s;
|
||||
for i := 1 to length(s) do t[i] := LoCase(s[i]);
|
||||
LoSt := t;
|
||||
end;
|
||||
|
||||
function lpad;
|
||||
begin
|
||||
lpad := replicate(c, n - length(s)) + s;
|
||||
end;
|
||||
|
||||
function rpad;
|
||||
begin
|
||||
rpad := s + replicate(c, n - length(s));
|
||||
end;
|
||||
|
||||
function addbackslash;
|
||||
begin
|
||||
if length(p) > 0 then
|
||||
if p[length(p)] = '\' then addbackslash := p
|
||||
else addbackslash := p + '\'
|
||||
else addbackslash := p;
|
||||
end;
|
||||
|
||||
function match(sm : string; var st: string) : boolean;
|
||||
var p : integer;
|
||||
_sm,
|
||||
_st : string;
|
||||
begin
|
||||
match := false;
|
||||
if (length(sm) > 0) and (length(st) > 0) then begin
|
||||
_sm := UpSt(sm);
|
||||
_st := UpSt(st);
|
||||
while pos(_sm, _st) > 0 do begin
|
||||
match := true;
|
||||
p := pos(_sm, _st);
|
||||
_st := copy(_st, 1, p - 1) + copy(_st, p + length(_sm), 250);
|
||||
st := copy( st, 1, p - 1) + copy( st, p + length( sm), 250);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function lines;
|
||||
var o : string;
|
||||
i : longint;
|
||||
n : longint;
|
||||
begin
|
||||
if l > 0 then begin
|
||||
i := p * s div l;
|
||||
n := p * s * 2 div l;
|
||||
o := replicate('�', i);
|
||||
if n > i * 2 then o := o + '�';
|
||||
lines := o + space(s - length(o));
|
||||
end else lines := '';
|
||||
end;
|
||||
|
||||
function LoCase;
|
||||
var t : char;
|
||||
begin
|
||||
if (c >= 'A') and (c <= 'Z') then t := chr(ord(c) + 32)
|
||||
else t := c;
|
||||
LoCase := t;
|
||||
end;
|
||||
|
||||
function JustPathname(PathName : string) : string;
|
||||
{-Return just the drive:directory portion of a pathname}
|
||||
var
|
||||
I : Word;
|
||||
begin
|
||||
I := Succ(Word(Length(PathName)));
|
||||
repeat
|
||||
Dec(I);
|
||||
until (PathName[I] in ['\',':',#0]) or (I = 1);
|
||||
|
||||
if I = 1 then
|
||||
{Had no drive or directory name}
|
||||
JustPathname := ''
|
||||
else if I = 1 then
|
||||
{Either the root directory of default drive or invalid pathname}
|
||||
JustPathname := PathName[1]
|
||||
else if (PathName[I] = '\') then begin
|
||||
if PathName[Pred(I)] = ':' then
|
||||
{Root directory of a drive, leave trailing backslash}
|
||||
JustPathname := Copy(PathName, 1, I)
|
||||
else
|
||||
{Subdirectory, remove the trailing backslash}
|
||||
JustPathname := Copy(PathName, 1, Pred(I));
|
||||
end else
|
||||
{Either the default directory of a drive or invalid pathname}
|
||||
JustPathname := Copy(PathName, 1, I);
|
||||
end;
|
||||
|
||||
function JustFilename(PathName : string) : string;
|
||||
{-Return just the filename of a pathname}
|
||||
var
|
||||
I : Word;
|
||||
begin
|
||||
I := Succ(Word(Length(PathName)));
|
||||
repeat
|
||||
Dec(I);
|
||||
until (I = 0) or (PathName[I] in ['\', ':', #0]);
|
||||
JustFilename := Copy(PathName, Succ(I), 64);
|
||||
end;
|
||||
|
||||
function JustName(PathName : string) : string;
|
||||
{-Return just the name (no extension, no path) of a pathname}
|
||||
var
|
||||
DotPos : Byte;
|
||||
begin
|
||||
PathName := JustFileName(PathName);
|
||||
DotPos := Pos('.', PathName);
|
||||
if DotPos > 0 then
|
||||
PathName := Copy(PathName, 1, DotPos-1);
|
||||
JustName := PathName;
|
||||
end;
|
||||
|
||||
|
||||
function CRC16(s : string) : system.word; { By Kevin Cooney }
|
||||
var
|
||||
crc : longint;
|
||||
t,r : byte;
|
||||
begin
|
||||
crc := 0;
|
||||
for t := 1 to length(s) do
|
||||
begin
|
||||
crc := (crc xor (ord(s[t]) shl 8));
|
||||
for r := 1 to 8 do
|
||||
if (crc and $8000)>0 then
|
||||
crc := ((crc shl 1) xor $1021)
|
||||
else
|
||||
crc := (crc shl 1);
|
||||
end;
|
||||
CRC16 := (crc and $FFFF);
|
||||
end;
|
||||
|
||||
end.
|
||||
101
Addons/UWrd.pas
Normal file
101
Addons/UWrd.pas
Normal file
@@ -0,0 +1,101 @@
|
||||
unit UWrd;
|
||||
|
||||
interface
|
||||
|
||||
function words (str:string;d:char ):integer;
|
||||
function wordn (str:string;d:char;n:integer):string ;
|
||||
function wordd (str:string;d:char;n:integer):string ;
|
||||
function wordp (str:string;d:char;n:integer):integer;
|
||||
function wordi ( wrd,str:string;d:cHar):boolean;
|
||||
function wordf (str:string;d:char;n:integer):string ;
|
||||
|
||||
implementation
|
||||
|
||||
function words;
|
||||
var tempstr : string;
|
||||
ins : boolean;
|
||||
i,j : integer;
|
||||
begin
|
||||
tempstr := d + str + d;
|
||||
ins := false;
|
||||
j := 0;
|
||||
for i := 1 to length(tempstr) do begin
|
||||
if ins then
|
||||
if tempstr[i] =d then ins:=false
|
||||
else begin end
|
||||
else
|
||||
if tempstr[i]<>d then begin
|
||||
inc(j);ins:=true;
|
||||
end;
|
||||
end;
|
||||
words:=j;
|
||||
end;
|
||||
|
||||
function wordn;
|
||||
var i,j:integer;
|
||||
tempstr:string;
|
||||
begin
|
||||
i:=words(str, d);
|
||||
if i<n then begin
|
||||
wordn:='';
|
||||
exit;
|
||||
end;
|
||||
i:=1;
|
||||
while words(copy(str,1,i), d)<n do inc(i);
|
||||
j:=i;
|
||||
tempstr:=str+d;
|
||||
while tempstr[j]<>d do inc(j);
|
||||
wordn:=copy(str,i,j-i);
|
||||
end;
|
||||
|
||||
function wordd;
|
||||
var i,j:integer;
|
||||
sss:string;
|
||||
tempstr:string;
|
||||
begin
|
||||
i:=words(str, d);
|
||||
if i<n then begin
|
||||
wordd:=str;
|
||||
exit;
|
||||
end;
|
||||
i:=1;
|
||||
while words(copy(str,1,i), d)<n do inc(i);
|
||||
j:=i;
|
||||
tempstr:=str+d;
|
||||
while tempstr[j]<>d do inc(j);
|
||||
sss :=copy(str,1,i-1);
|
||||
wordd:=sss+copy(str,j+1,length(tempstr)-j);
|
||||
end;
|
||||
|
||||
function wordp;
|
||||
var i:integer;
|
||||
begin
|
||||
i:=words(str, d);
|
||||
if i < n then begin
|
||||
wordp := 0;
|
||||
exit;
|
||||
end;
|
||||
i:=1;
|
||||
while words(copy(str,1,i), d)<n do inc(i);
|
||||
wordp := i;
|
||||
end;
|
||||
|
||||
function wordi;
|
||||
var i : integer;
|
||||
begin
|
||||
wordi := true;
|
||||
for i := 1 to words(str, d) do
|
||||
if wrd = wordn(str, d, i) tHen exit;
|
||||
wordi := false;
|
||||
end;
|
||||
|
||||
function wordf;
|
||||
var i: integer;
|
||||
begin
|
||||
i := wordp(str, d, n);
|
||||
wordf := '';
|
||||
if (i > 0) and (i < length(str)) then
|
||||
wordf := copy(str, i, length(str) - i + 1);
|
||||
end;
|
||||
|
||||
end.
|
||||
520
Addons/XPMenus.pas
Normal file
520
Addons/XPMenus.pas
Normal file
@@ -0,0 +1,520 @@
|
||||
{***********************************************************************}
|
||||
{ ��������� KOL XPMenu }
|
||||
{ ��������: }
|
||||
{ * ��������� �� ���� ��������� ���� � ����� OfficeXP. }
|
||||
{ }
|
||||
{ ������ : 1.09 �� 22.10.2005 }
|
||||
{ ����� : ������ ��������� }
|
||||
{ E-mail : alex@diploms.com }
|
||||
{ �������� �� ������ ������ RyMenu ������� ��������� (skitl@mail.ru). }
|
||||
{***********************************************************************}
|
||||
{$DEFINE USE_AUTOFREE4CONTROLS}
|
||||
|
||||
unit XPMenus;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Windows, Types, Messages, KOL;
|
||||
|
||||
type
|
||||
PXPControl=^TXPControl;
|
||||
TXPControl=object(TControl)
|
||||
end;
|
||||
|
||||
PXPMenu = ^TXPMenu;
|
||||
TXPMenu = object(TMenu)
|
||||
private
|
||||
FFont: PGraphicTool;
|
||||
FGutterColor: TColor;
|
||||
FBackColor: TColor;
|
||||
FSelectedColor: TColor;
|
||||
FSelLightColor: TColor;
|
||||
FCheckColor: TColor;
|
||||
FMinWidth: Integer;
|
||||
FMinHeight: Integer;
|
||||
FIsPopup : boolean;
|
||||
FBmpCheck: PBitmap;
|
||||
|
||||
procedure SetFont(Value: PGraphicTool);
|
||||
procedure SetSelectedColor(const Value: TColor);
|
||||
procedure InternalInitItems(Item: PMenu);
|
||||
function TextExtent(const Text: string): TSize;
|
||||
procedure InitCheckBmp;
|
||||
protected
|
||||
public
|
||||
// destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
|
||||
procedure DrawXPstyle;
|
||||
function MeasureItem(Sender: PObj; Idx: Integer): Integer;
|
||||
function DrawItem(Sender: PObj; DC: HDC; const Rect: TRect;
|
||||
ItemIdx: Integer; DrawAction: TDrawAction; ItemState: TDrawState): Boolean;
|
||||
|
||||
public
|
||||
property GutterColor: TColor read FGutterColor write FGutterColor;
|
||||
property BackColor: TColor read FBackColor write FBackColor;
|
||||
property SelectedColor: TColor read FSelectedColor write SetSelectedColor;
|
||||
property CheckColor: TColor read FCheckColor write FCheckColor;
|
||||
property Font: PGraphicTool read FFont write SetFont; {������ �������� ���� � ����}
|
||||
property ItemHeight: Integer read FMinHeight write FMinHeight;
|
||||
property ItemWidth: Integer read FMinWidth write FMinWidth;
|
||||
end;
|
||||
TKOLXPMainMenu= PXPMenu;
|
||||
TKOLXPPopupMenu= PXPMenu;
|
||||
|
||||
{procedure XPDrawItem(Sender: PObj; DC: HDC; ARect: TRect;
|
||||
ItemState: TDrawState; TopLevel, IsLine: Boolean;
|
||||
Bitmap:HBitmap;BitmapSize: tagBitmap; AFont: PGraphicTool;
|
||||
const Caption: String; GutterWidth: Integer;
|
||||
SelectedColor, GutterColor, MenuColor, SelLightColor, CheckColor: TColor);
|
||||
}
|
||||
function NewXPMenu( AParent : PControl; MaxCmdReserve: DWORD; const Template : array of PKOLChar;
|
||||
aOnMenuItem: TOnMenuItem; isPopup:boolean ): PXPMenu;
|
||||
|
||||
implementation
|
||||
|
||||
type
|
||||
TRGB = packed record
|
||||
R, G, B: Byte;
|
||||
end;
|
||||
|
||||
AGRBQuad = array [0..0] of RGBQuad;
|
||||
PAGRBQuad = ^AGRBQuad;
|
||||
|
||||
PPoints = ^TPoints;
|
||||
TPoints = array[0..0] of TPoint;
|
||||
|
||||
//������������ ����� �� ��������� �����
|
||||
function GetRGB(const Color: TColor): TRGB;
|
||||
var
|
||||
iColor: TColor;
|
||||
begin
|
||||
iColor := Color2RGB(Color);
|
||||
Result.R := GetRValue(iColor);
|
||||
Result.G := GetGValue(iColor);
|
||||
Result.B := GetBValue(iColor);
|
||||
end;
|
||||
|
||||
//�������� ������� ����
|
||||
function GetLightColor(Color: TColor; Light: Byte) : TColor;
|
||||
var
|
||||
fFrom: TRGB;
|
||||
begin
|
||||
FFrom := GetRGB(Color);
|
||||
|
||||
Result := RGB(
|
||||
Round(FFrom.R + (255 - FFrom.R) * (Light / 100)),
|
||||
Round(FFrom.G + (255 - FFrom.G) * (Light / 100)),
|
||||
Round(FFrom.B + (255 - FFrom.B) * (Light / 100))
|
||||
);
|
||||
end;
|
||||
|
||||
function GetShadeColor(Color: TColor; Shade: Byte) : TColor;
|
||||
var
|
||||
fFrom: TRGB;
|
||||
begin
|
||||
FFrom := GetRGB(Color);
|
||||
|
||||
Result := RGB(
|
||||
Max(0, FFrom.R - Shade),
|
||||
Max(0, FFrom.G - Shade),
|
||||
Max(0, FFrom.B - Shade)
|
||||
);
|
||||
end;
|
||||
|
||||
function BtnHighlight : TColor;
|
||||
begin
|
||||
Result := GetLightColor(clBtnFace, 50)
|
||||
end;
|
||||
|
||||
function NewXPMenu( AParent : PControl; MaxCmdReserve: DWORD; const Template : array of PKOLChar;
|
||||
aOnMenuItem: TOnMenuItem; isPopup:boolean): PXPMenu;
|
||||
var M: PXPMenu;
|
||||
{$IFDEF INITIALFORMSIZE_FIXMENU}
|
||||
R: TRect;
|
||||
{$ENDIF}
|
||||
|
||||
begin
|
||||
New( Result, Create );
|
||||
{+}{++}(*Result := PXPMenu.Create;*){--}
|
||||
Result.FVisible := TRUE;
|
||||
Result.FPopupFlags := TPM_LEFTALIGN or TPM_LEFTBUTTON;
|
||||
Result.FMenuItems := NewList;
|
||||
Result.FOnMenuItem := aOnMenuItem;
|
||||
if (High(Template)>=0) and (Template[0] <> nil) then
|
||||
begin
|
||||
if (AParent <> nil) and (PXPControl( AParent).fMenuObj = nil) and not PXPControl( AParent).fIsControl then
|
||||
Result.FHandle := CreateMenu
|
||||
else
|
||||
Result.FHandle := CreatePopupMenu;
|
||||
Result.FillMenuItems( Result.FHandle, 0, Template );
|
||||
end;
|
||||
if Assigned( AParent ) then
|
||||
begin
|
||||
Result.FControl :=PControl( AParent);
|
||||
if Assigned(PXPControl( AParent).fMenuObj) then
|
||||
begin
|
||||
// add popup menu to the end of menu chain
|
||||
M := PXPMenu( PXPControl( AParent).fMenuObj );
|
||||
while Assigned(M.fNextMenu) do
|
||||
M := PXPMenu(M.fNextMenu);
|
||||
M.fNextMenu := Result;
|
||||
end
|
||||
else
|
||||
begin
|
||||
if not PXPControl( AParent).fIsControl then
|
||||
begin
|
||||
{$IFDEF INITIALFORMSIZE_FIXMENU}
|
||||
R := AParent.ClientRect;
|
||||
{$ENDIF}
|
||||
AParent.Menu := Result.FHandle;
|
||||
{$IFDEF INITIALFORMSIZE_FIXMENU}
|
||||
AParent.SetClientSize( R.Right, R.Bottom );
|
||||
{$ENDIF}
|
||||
end;
|
||||
PXPControl( AParent).fMenuObj := Result;
|
||||
AParent.AttachProc(WndProcMenu );
|
||||
{$IFDEF USE_AUTOFREE4CONTROLS} //dufa
|
||||
AParent.Add2AutoFree( Result );
|
||||
{$ENDIF}
|
||||
end;
|
||||
end;
|
||||
|
||||
Result.FGutterColor := clBtnFace; //����� �������
|
||||
Result.FBackColor := GetLightColor(clBtnFace, 85);
|
||||
Result.FSelectedColor := GetLightColor(clHighlight, 65); //���������� ����� ����
|
||||
Result.FSelLightColor := GetLightColor(clHighlight, 75);
|
||||
Result.FCheckColor :=clBlack;
|
||||
Result.FMinWidth := 0;
|
||||
Result.FMinHeight:=0;
|
||||
Result.FIsPopup:=isPopup;
|
||||
Result.FFont := NewFont;
|
||||
Result.Add2AutoFree(Result.FFont);
|
||||
end;
|
||||
|
||||
procedure TXPMenu.InitCheckBmp;
|
||||
const ChkBMP: array[0..11] of word=(0,0,0,8,24,568,880,992,448,128,0,0);
|
||||
|
||||
var
|
||||
i,j: Byte;
|
||||
row: PAGRBQuad;
|
||||
x:word;
|
||||
|
||||
begin
|
||||
FBmpCheck := NewDIBBitmap(12,12,pf32bit);
|
||||
Add2AutoFree(FBmpCheck);
|
||||
with FBmpCheck^ do
|
||||
begin
|
||||
if FCheckColor=clWhite then Canvas.Brush.Color := clBlack else Canvas.Brush.Color := clWhite;
|
||||
Canvas.FillRect(Rect(0, 0, Width, Height));
|
||||
for j:=0 to Height-1 do begin
|
||||
row:=ScanLine[j]; x:=ChkBMP[j];
|
||||
for i:=0 to Width-1 do begin
|
||||
if (x and 2048)=2048 then row[i]:=Color2RGBQuad(FCheckColor);
|
||||
x:=x shl 1;
|
||||
end;
|
||||
end;
|
||||
end
|
||||
end;
|
||||
|
||||
function TXPMenu.TextExtent(const Text: string): TSize;
|
||||
var
|
||||
DC: HDC;
|
||||
begin
|
||||
DC := CreateCompatibleDC( 0 );
|
||||
SelectObject(DC,FFont.Handle);
|
||||
GetTextExtentPoint32( DC, PKOLChar(Text), Length(Text), Result);
|
||||
DeleteDC(DC);
|
||||
end;
|
||||
|
||||
{destructor TXPMenu.Destroy;
|
||||
begin
|
||||
FFont.Free;
|
||||
if Assigned(FBmpCheck) then
|
||||
Free_And_Nil(FBmpCheck);
|
||||
inherited;
|
||||
end;}
|
||||
|
||||
procedure TXPMenu.InternalInitItems(Item : PMenu);
|
||||
//����� �� ���� �������, ��� ������ ���������� � ���������
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
with Item^ do begin
|
||||
OnMeasureItem := MeasureItem;
|
||||
OnDrawItem := DrawItem;
|
||||
OwnerDraw :=true;
|
||||
for I := 0 to Count - 1 do
|
||||
if Items[I].Count > 0 then InternalInitItems(Items[I]);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TXPMenu.DrawXPstyle;
|
||||
var i:integer;
|
||||
begin
|
||||
for i:=0 to Count -1 do
|
||||
InternalInitItems(Items[i]);
|
||||
end;
|
||||
|
||||
//���������� ���������-c
|
||||
function TXPMenu.DrawItem(Sender: PObj; DC: HDC;
|
||||
const Rect: TRect; ItemIdx: Integer; DrawAction: TDrawAction;
|
||||
ItemState: TDrawState): Boolean;
|
||||
|
||||
var BitmapSize:tagBITMAP;
|
||||
aBrush, aPen, aFont: PGraphicTool;
|
||||
i:byte;
|
||||
BMP,maskBMP{, grayBMP}:PBitmap;
|
||||
{ oldBrush:HBrush;
|
||||
oldPen:HPen;
|
||||
oldFont:HFont;}
|
||||
GutterWidth:Integer;
|
||||
TopLevel:boolean;
|
||||
ARect:TRect;
|
||||
|
||||
function GetGutterWidth(IsLine: Boolean): Integer;
|
||||
begin
|
||||
|
||||
with PMenu(Sender)^ do
|
||||
begin
|
||||
if Pointer(Bitmap)<>nil then
|
||||
begin
|
||||
Result := Max(BitmapSize.bmWidth + 4,
|
||||
Rect.Bottom - Rect.Top); //������ ����� �� �������� + �������� + ���� �����
|
||||
if IsLine then
|
||||
Result := Max(Result, TextExtent('W').cy + 4);
|
||||
end else
|
||||
if IsLine then
|
||||
Result := TextExtent('W').cy + 4
|
||||
else
|
||||
Result := Rect.Bottom - Rect.Top; {������ = ������ + 2 + 2 �����}
|
||||
end;
|
||||
Result := Max(Result, ItemHeight) + 1;
|
||||
end;
|
||||
|
||||
procedure RGB2GrayScale(grayBMP:PBitmap);
|
||||
var i,j:word;
|
||||
fFrom: TRGB;
|
||||
c:byte;
|
||||
|
||||
begin
|
||||
with grayBMP^ do
|
||||
for i:=0 to Width-1 do
|
||||
for j:=0 to Height-1 do begin
|
||||
FFrom := GetRGB(Pixels[i,j]);
|
||||
with FFrom do c:=round(0.30*R+0.59*G+0.11*B);
|
||||
Pixels[i,j]:=RGB(c,c,c) ;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure MyPolyline(DC: HDC;const Points: array of TPoint);
|
||||
begin
|
||||
Polyline(DC, PPoints(@Points)^, High(Points) + 1);
|
||||
end;
|
||||
|
||||
|
||||
const
|
||||
//��������� �����
|
||||
_Flags: LongInt = DT_NOCLIP or DT_VCENTER or DT_END_ELLIPSIS or DT_SINGLELINE;
|
||||
_FlagsTopLevel: array[Boolean] of Longint = (DT_LEFT, DT_CENTER);
|
||||
_FlagsShortCut: Longint = (DT_RIGHT);
|
||||
|
||||
begin
|
||||
with PMenu(Sender)^ do begin
|
||||
if Pointer(Bitmap)<>nil then
|
||||
GetObject(Bitmap , sizeof(tagBITMAP), @BitmapSize);
|
||||
GutterWidth:=GetGutterWidth(IsSeparator);
|
||||
TopLevel:=(TopParent.IndexOf( Parent )=-1) and not FIsPopup;
|
||||
aBrush:=NewBrush;
|
||||
aPen:=NewPen;
|
||||
aFont:=NewFont;
|
||||
|
||||
aPen.Color := GetShadeColor(clHighlight, 50);
|
||||
// oldPen:=SelectObject(DC,aPen.Handle);
|
||||
// oldBrush:=SelectObject(DC,aBrush.Handle);
|
||||
if (odsSelected in ItemState) then //���� ����� ���� �������
|
||||
begin
|
||||
if TopLevel then //���� ��� ������� ��������� ����
|
||||
begin
|
||||
aBrush.Color := BtnHighLight;
|
||||
SelectObject(DC,aBrush.Handle);
|
||||
FillRect(DC,Rect,aBrush.Handle);
|
||||
aPen.Color := GetShadeColor(clBtnShadow, 50);
|
||||
SelectObject(DC,aPen.Handle);
|
||||
MyPolyline(DC,[
|
||||
Point(Rect.Left, Rect.Bottom-1),
|
||||
Point(Rect.Left, Rect.Top),
|
||||
Point(Rect.Right-1, Rect.Top),
|
||||
Point(Rect.Right-1, Rect.Bottom)
|
||||
]);
|
||||
end else
|
||||
if not (odsDisabled in ItemState) then
|
||||
begin
|
||||
aBrush.Color := FSelectedColor;
|
||||
SelectObject(DC,aBrush.Handle);
|
||||
Rectangle(DC,Rect.Left, Rect.Top, Rect.Right, Rect.Bottom);
|
||||
end
|
||||
end else
|
||||
if TopLevel then //���� ��� ������� ��������� ����
|
||||
begin
|
||||
if (odsHotList in ItemState) then //���� ���� ��� ������� ����
|
||||
begin
|
||||
aPen.Color := GetShadeColor(clHighlight, 50);
|
||||
SelectObject(DC,aPen.Handle);
|
||||
aBrush.Color := FSelectedColor;
|
||||
SelectObject(DC,aBrush.Handle);
|
||||
Rectangle(DC,Rect.Left, Rect.Top, Rect.Right, Rect.Bottom);
|
||||
end else
|
||||
begin
|
||||
aBrush.Color := clBtnFace;
|
||||
FillRect(DC,Rect,aBrush.Handle);
|
||||
end
|
||||
end else
|
||||
begin //����� �� �������������� ����� ����
|
||||
aBrush.Color := FGutterColor; //�������
|
||||
FillRect(DC,Types.Rect(Rect.Left, Rect.Top, Rect.Left + GutterWidth, Rect.Bottom),aBrush.Handle );
|
||||
aBrush.Color := FBackColor;
|
||||
FillRect(DC,Types.Rect(Rect.Left + GutterWidth, Rect.Top, Rect.Right, Rect.Bottom),aBrush.Handle);
|
||||
end;
|
||||
|
||||
if odsChecked in ItemState then
|
||||
begin // ������������ �������� ����� ����
|
||||
aPen.Color := GetShadeColor(clHighlight, 50);
|
||||
SelectObject(DC,aPen.Handle);
|
||||
if (odsSelected in ItemState) then aBrush.Color := GetShadeColor(FSelLightColor, 40)
|
||||
else aBrush.Color := FSelLightColor;
|
||||
SelectObject(DC,aBrush.Handle);
|
||||
Rectangle(DC,(Rect.Left + 1), (Rect.Top + 1),
|
||||
(Rect.Left - 1 + GutterWidth - 1), (Rect.Bottom - 1) );
|
||||
end;
|
||||
|
||||
if (Pointer(Bitmap)<>nil) and (not TopLevel) then begin
|
||||
BMP:=NewBitmap(BitmapSize.bmWidth ,BitmapSize.bmHeight);
|
||||
BMP.Handle:=CopyImage(Bitmap,IMAGE_BITMAP ,0,0,0);
|
||||
maskBMP:=NewBitmap(BitmapSize.bmWidth ,BitmapSize.bmHeight);
|
||||
maskBMP.Handle:=CopyImage(Bitmap,IMAGE_BITMAP ,0,0,0);
|
||||
maskBMP.Convert2Mask(BMP.Pixels[0,0]);
|
||||
if not (odsDisabled in ItemState) then begin //������ ������� ��������
|
||||
if (odsSelected in ItemState) then begin
|
||||
{grayBMP:=NewBitmap(BitmapSize.bmWidth ,BitmapSize.bmHeight);
|
||||
grayBMP.Handle:=CopyImage(Bitmap,IMAGE_BITMAP ,0,0,0);
|
||||
RGB2GrayScale(grayBMP);
|
||||
grayBMP.DrawMasked(DC ,(ARect.Left + GutterWidth - 1 - BitmapSize.bmWidth ) shr 1+2,
|
||||
(ARect.Top + ARect.Bottom - BitmapSize.bmHeight ) shr 1+2, maskBMP.Handle);
|
||||
grayBMP.Free; }
|
||||
end;
|
||||
end else begin //������ �������� ��������
|
||||
RGB2GrayScale(BMP);
|
||||
end;
|
||||
BMP.DrawMasked(DC ,(Rect.Left + GutterWidth - 1 - BitmapSize.bmWidth ) shr 1,
|
||||
(Rect.Top + Rect.Bottom - BitmapSize.bmHeight ) shr 1, maskBMP.Handle);
|
||||
maskBMP.Free; BMP.Free;
|
||||
end else
|
||||
if odsChecked in ItemState then begin
|
||||
if not Assigned(FBmpCheck) then InitCheckBmp;
|
||||
FBmpCheck.DrawTransparent(DC,(Rect.Left + GutterWidth - 1 - FBmpCheck.Width) shr 1,
|
||||
(Rect.Top + Rect.Bottom - FBmpCheck.Height) shr 1,FBmpCheck.Pixels[0,0]);
|
||||
end;
|
||||
ARect:=Rect;
|
||||
if not TopLevel then
|
||||
Inc(ARect.Left, GutterWidth + 5); //������ ��� ������
|
||||
|
||||
aFont.Assign(Font);
|
||||
with aFont^ do
|
||||
begin
|
||||
if (odsDefault in ItemState) then FontStyle := [fsBold];
|
||||
if (odsDisabled in ItemState) then Color := clGray;
|
||||
end;
|
||||
// oldFont:=SelectObject(DC,aFont.Handle);
|
||||
|
||||
if IsSeparator then //���� �����������
|
||||
begin
|
||||
aPen.Color := clBtnShadow;
|
||||
SelectObject(DC,aPen.Handle);
|
||||
MyPolyline(DC,[
|
||||
Point(Rect.Left, ARect.Top + (ARect.Bottom - ARect.Top) shr 1),
|
||||
Point(Rect.Right, ARect.Top + (ARect.Bottom - ARect.Top) shr 1)]);
|
||||
end else
|
||||
begin //����� ����
|
||||
i:=1; while (i<=Length(Caption)) and (Caption[i]<>#9) do inc(i);
|
||||
{ i:=Pos(#9, Caption);
|
||||
if i=0 then i:=Length(Caption)+1;
|
||||
} SetBkMode(DC, TRANSPARENT);
|
||||
SetTextColor(DC, aFont.Color );
|
||||
DrawText(DC, PKOLChar(copy(Caption,1,i-1)),i-1 ,ARect,
|
||||
_Flags or _FlagsTopLevel[TopLevel]);
|
||||
if i<Length(Caption) then //������������
|
||||
begin
|
||||
Dec(ARect.Right, 5);
|
||||
DrawText(DC, PKOLChar(copy(Caption,i+1,Length(Caption)-i)),Length(Caption)-i,
|
||||
ARect, _Flags or _FlagsShortCut);
|
||||
end
|
||||
end;
|
||||
//DeleteObject(SelectObject(DC, oldFont));
|
||||
//DeleteObject(SelectObject(DC, oldBrush));
|
||||
//DeleteObject(SelectObject(DC, oldPen));
|
||||
aFont.Free;
|
||||
aBrush.Free;
|
||||
aPen.Free;
|
||||
end;
|
||||
Result:=true;
|
||||
end;
|
||||
|
||||
//������� ����
|
||||
function TXPMenu.MeasureItem(Sender: PObj; Idx: Integer): Integer;
|
||||
VAR Bound:integer;
|
||||
bb:packed record
|
||||
Height:word;
|
||||
Width:word;
|
||||
end absolute Bound;
|
||||
BitmapSize:tagBitmap;
|
||||
|
||||
begin
|
||||
with PMenu(Sender)^ do
|
||||
if (TopParent.IndexOf( Parent )=-1) and not FIsPopup then
|
||||
begin
|
||||
bb.Width := TextExtent(Caption).cX;
|
||||
bb.Height := TextExtent(Caption).cY;
|
||||
end else begin
|
||||
|
||||
if Pointer(Bitmap)<>nil then
|
||||
begin
|
||||
GetObject(Bitmap , sizeof(tagBITMAP), @BitmapSize);
|
||||
if IsSeparator then
|
||||
if Max(ItemHeight, BitmapSize.bmHeight ) > 20 then //��� ������� 20 ����� ������� ���������
|
||||
bb.Height := 11 else bb.Height := 5
|
||||
else
|
||||
begin
|
||||
bb.Height := Max(ItemHeight,
|
||||
Max(TextExtent('W').cy , BitmapSize.bmHeight ) + 4);
|
||||
|
||||
bb.Width := BitmapSize.bmWidth ;
|
||||
if bb.Width < bb.Height then bb.Width := bb.Height else bb.Width := bb.Width + 5;
|
||||
bb.Width := Max(ItemWidth,
|
||||
bb.Width + TextExtent(Caption).cx + 15);
|
||||
end
|
||||
end else
|
||||
begin
|
||||
bb.Height := Max(TextExtent('W').cY + 4, ItemHeight);
|
||||
bb.Width := Max(ItemWidth, bb.Height + TextExtent(Caption).cx + 15);
|
||||
|
||||
if IsSeparator then
|
||||
if bb.Height > 20 then //��� ������� 20 ����� ������� ���������
|
||||
bb.Height := 11 else bb.Height := 5;
|
||||
end
|
||||
|
||||
end;
|
||||
Result:=Bound;
|
||||
end;
|
||||
|
||||
procedure TXPMenu.SetFont(Value: PGraphicTool);
|
||||
begin
|
||||
FFont.Assign(Value);
|
||||
end;
|
||||
|
||||
procedure TXPMenu.SetSelectedColor(const Value: TColor);
|
||||
begin
|
||||
FSelectedColor := Value;
|
||||
FSelLightColor := GetLightColor(Value, 75);
|
||||
end;
|
||||
|
||||
end.
|
||||
182
Addons/mckSocket.pas
Normal file
182
Addons/mckSocket.pas
Normal file
@@ -0,0 +1,182 @@
|
||||
unit mckSocket;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Windows, Classes, Messages, Winsock, Forms, SysUtils,
|
||||
KOLSocket, mirror;
|
||||
|
||||
type
|
||||
|
||||
TSocketMessageEvent = procedure (SocketMessage: TWMSocket) of object;
|
||||
|
||||
TKOLSocket = class(TKOLObj)
|
||||
private
|
||||
fIPAddress: string;
|
||||
fPortNumber: word;
|
||||
FOnError: TSocketMessageEvent;
|
||||
FOnAccept: TSocketMessageEvent;
|
||||
FOnClose: TSocketMessageEvent;
|
||||
FOnConnect: TSocketMessageEvent;
|
||||
FOnRead: TSocketMessageEvent;
|
||||
FOnWrite: TSocketMessageEvent;
|
||||
FOnListen: TSocketMessageEvent;
|
||||
FOnOOB: TSocketMessageEvent;
|
||||
protected
|
||||
function AdditionalUnits: string; override;
|
||||
procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override;
|
||||
procedure SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); override;
|
||||
procedure AssignEvents( SL: TStringList; const AName: String ); override;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
|
||||
function GetPortNumber: LongInt;
|
||||
function GetIPAddress: String;
|
||||
|
||||
procedure SetPortNumber(NewPortNumber: LongInt);
|
||||
procedure SetIPAddress(NewIPAddress: String);
|
||||
|
||||
procedure SetOnAccept(Value: TSocketMessageEvent);
|
||||
procedure SetOnClose(Value: TSocketMessageEvent);
|
||||
procedure SetOnConnect(Value: TSocketMessageEvent);
|
||||
procedure SetOnError(Value: TSocketMessageEvent);
|
||||
procedure SetOnListen(Value: TSocketMessageEvent);
|
||||
procedure SetOnOOB(Value: TSocketMessageEvent);
|
||||
procedure SetOnRead(Value: TSocketMessageEvent);
|
||||
procedure SetOnWrite(Value: TSocketMessageEvent);
|
||||
|
||||
published
|
||||
property IPAddress: String read GetIPAddress write SetIPAddress;
|
||||
property PortNumber: LongInt read GetPortNumber write SetPortNumber;
|
||||
property OnError: TSocketMessageEvent read FOnError write SetOnError;
|
||||
property OnAccept: TSocketMessageEvent read FOnAccept write SetOnAccept;
|
||||
property OnClose: TSocketMessageEvent read FOnClose write SetOnClose;
|
||||
property OnConnect: TSocketMessageEvent read FOnConnect write SetOnConnect;
|
||||
property OnRead: TSocketMessageEvent read FOnRead write SetOnRead;
|
||||
property OnWrite: TSocketMessageEvent read FOnWrite write SetOnWrite;
|
||||
property OnOOB: TSocketMessageEvent read FOnOOB write SetOnOOB;
|
||||
property OnListen: TSocketMessageEvent read FOnListen write SetOnListen;
|
||||
end;
|
||||
|
||||
procedure Register;
|
||||
|
||||
implementation
|
||||
|
||||
{$R *.dcr}
|
||||
|
||||
constructor TKOLSocket.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
InstanceCount := InstanceCount + 1;
|
||||
end; // constructor TKOLSocket.Create
|
||||
|
||||
destructor TKOLSocket.Destroy;
|
||||
begin
|
||||
inherited Destroy;
|
||||
end; // destructor TKOLSocket.Destroy;
|
||||
|
||||
function TKOLSocket.GetIPAddress: String;
|
||||
begin
|
||||
Result := fIPAddress;
|
||||
end; // function TKOLSocket.GetIPAddress: String
|
||||
|
||||
function TKOLSocket.GetPortNumber: LongInt;
|
||||
begin
|
||||
Result := fPortNumber;
|
||||
end; // function TKOLSocket.GetPortNumber: Word
|
||||
|
||||
procedure TKOLSocket.SetIPAddress(NewIPAddress: String);
|
||||
begin
|
||||
fIPAddress := NewIPAddress;
|
||||
Change;
|
||||
end; // procedure TKOLSocket.SetIPAddress(NewIPAddress: String)
|
||||
|
||||
procedure TKOLSocket.SetPortNumber(NewPortNumber: LongInt);
|
||||
begin
|
||||
fPortNumber := NewPortNumber;
|
||||
Change;
|
||||
end; // procedure TKOLSocket.SetPortNumber(NewPortNumber: Word)
|
||||
|
||||
procedure TKOLSocket.SetOnAccept;
|
||||
begin
|
||||
fOnAccept := Value;
|
||||
Change;
|
||||
end;
|
||||
|
||||
procedure TKOLSocket.SetOnClose;
|
||||
begin
|
||||
fOnClose := Value;
|
||||
Change;
|
||||
end;
|
||||
|
||||
procedure TKOLSocket.SetOnConnect;
|
||||
begin
|
||||
fOnConnect := Value;
|
||||
Change;
|
||||
end;
|
||||
|
||||
procedure TKOLSocket.SetOnError;
|
||||
begin
|
||||
fOnError := Value;
|
||||
Change;
|
||||
end;
|
||||
|
||||
procedure TKOLSocket.SetOnListen;
|
||||
begin
|
||||
fOnListen := Value;
|
||||
Change;
|
||||
end;
|
||||
|
||||
procedure TKOLSocket.SetOnOOB;
|
||||
begin
|
||||
fOnOOB := Value;
|
||||
Change;
|
||||
end;
|
||||
|
||||
procedure TKOLSocket.SetOnRead;
|
||||
begin
|
||||
fOnRead := Value;
|
||||
Change;
|
||||
end;
|
||||
|
||||
procedure TKOLSocket.SetOnWrite;
|
||||
begin
|
||||
fOnWrite := Value;
|
||||
Change;
|
||||
end;
|
||||
|
||||
function TKOLSocket.AdditionalUnits;
|
||||
begin
|
||||
result := ', KOLSocket';
|
||||
end;
|
||||
|
||||
procedure TKOLSocket.SetupFirst(SL: TStringList; const AName,
|
||||
AParent, Prefix: String);
|
||||
begin
|
||||
SL.Add( Prefix + AName + ' := NewAsyncSocket;' );
|
||||
SL.Add( Prefix + AName + '.PortNumber := ' + inttostr(fPortNumber) + ';');
|
||||
SL.Add( Prefix + AName + '.IPAddress := ''' + fIPAddress + ''';');
|
||||
end;
|
||||
|
||||
procedure TKOLSocket.SetupLast(SL: TStringList; const AName,
|
||||
AParent, Prefix: String);
|
||||
begin
|
||||
//
|
||||
end;
|
||||
|
||||
procedure TKOLSocket.AssignEvents(SL: TStringList; const AName: String);
|
||||
begin
|
||||
inherited;
|
||||
DoAssignEvents( SL, AName,
|
||||
[ 'OnConnect', 'OnAccept', 'OnListen', 'OnRead', 'OnWrite', 'OnOOB', 'OnClose', 'OnError' ],
|
||||
[ @OnConnect , @OnAccept , @OnListen , @OnRead , @OnWrite , @OnOOB , @OnClose , @OnError ]);
|
||||
end;
|
||||
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('KOLAddons', [TKOLSocket]);
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
BIN
Addons/mckTCPSocket.dcr
Normal file
BIN
Addons/mckTCPSocket.dcr
Normal file
Binary file not shown.
289
Addons/mckTCPSocket.pas
Normal file
289
Addons/mckTCPSocket.pas
Normal file
@@ -0,0 +1,289 @@
|
||||
unit mckTCPSocket;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Windows, Classes, Messages, Winsock, Forms, SysUtils, kolTCPSocket, mirror;
|
||||
|
||||
type
|
||||
TKOLTCPClient = class(TKOLObj)
|
||||
private
|
||||
FPort: smallint;
|
||||
FHost: string;
|
||||
FOnConnect: TOnTCPConnect;
|
||||
FOnDisconnect: TOnTCPDisconnect;
|
||||
FOnError: TOnTCPError;
|
||||
FOnReceive: TOnTCPReceive;
|
||||
// FOnResolve: TOnTCPResolve;
|
||||
FOnManualReceive: TOnTCPManualReceive;
|
||||
FOnStreamReceive: TOnTCPStreamReceive;
|
||||
FOnStreamSend: TOnTCPStreamSend;
|
||||
procedure SetHost(const Value: string);
|
||||
procedure SetOnConnect(const Value: TOnTCPConnect);
|
||||
procedure SetOnDisconnect(const Value: TOnTCPDisconnect);
|
||||
procedure SetOnError(const Value: TOnTCPError);
|
||||
procedure SetOnReceive(const Value: TOnTCPReceive);
|
||||
// procedure SetOnResolve(const Value: TOnTCPResolve);
|
||||
procedure SetPort(const Value: smallint);
|
||||
procedure SetOnManualReceive(const Value: TOnTCPManualReceive);
|
||||
procedure SetOnStreamReceive(const Value: TOnTCPStreamReceive);
|
||||
procedure SetOnStreamSend(const Value: TOnTCPStreamSend);
|
||||
protected
|
||||
function AdditionalUnits: string; override;
|
||||
procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override;
|
||||
procedure SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); override;
|
||||
procedure AssignEvents( SL: TStringList; const AName: String ); override;
|
||||
public
|
||||
published
|
||||
property Host:string read FHost write SetHost;
|
||||
property Port:smallint read FPort write SetPort;
|
||||
property OnDisconnect:TOnTCPDisconnect read FOnDisconnect write SetOnDisconnect;
|
||||
property OnError:TOnTCPError read FOnError write SetOnError;
|
||||
property OnReceive:TOnTCPReceive read FOnReceive write SetOnReceive;
|
||||
property OnManualReceive:TOnTCPManualReceive read FOnManualReceive write SetOnManualReceive;
|
||||
property OnStreamSend:TOnTCPStreamSend read FOnStreamSend write SetOnStreamSend;
|
||||
property OnStreamReceive:TOnTCPStreamReceive read FOnStreamReceive write SetOnStreamReceive;
|
||||
property OnConnect:TOnTCPConnect read FOnConnect write SetOnConnect;
|
||||
end;
|
||||
|
||||
TKOLTCPServer = class(TKOLObj)
|
||||
private
|
||||
FPort: smallint;
|
||||
FOnClientError: TOnTCPError;
|
||||
FOnAccept: TOnTCPAccept;
|
||||
FOnError: TOnTCPError;
|
||||
FOnConnect: TOnTCPConnect;
|
||||
FOnClientReceive: TOnTCPReceive;
|
||||
FOnClientConnect: TOnTCPClientConnect;
|
||||
FOnClientDisconnect: TOnTCPDisconnect;
|
||||
FOnClientManualReceive: TOnTCPManualReceive;
|
||||
FOnClientStreamReceive: TOnTCPStreamReceive;
|
||||
FOnClientStreamSend: TOnTCPStreamSend;
|
||||
procedure SetOnAccept(const Value: TOnTCPAccept);
|
||||
procedure SetOnError(const Value: TOnTCPError);
|
||||
procedure SetPort(const Value: smallint);
|
||||
procedure SetOnConnect(const Value: TOnTCPConnect);
|
||||
procedure SetOnClientError(const Value: TOnTCPError);
|
||||
procedure SetOnClientReceive(const Value: TOnTCPReceive);
|
||||
procedure SetOnClientConnect(const Value: TOnTCPClientConnect);
|
||||
procedure SetOnClientDisconnect(const Value: TOnTCPDisconnect);
|
||||
procedure SetOnClientManualReceive(const Value: TOnTCPManualReceive);
|
||||
procedure SetOnClientStreamReceive(const Value: TOnTCPStreamReceive);
|
||||
procedure SetOnClientStreamSend(const Value: TOnTCPStreamSend);
|
||||
protected
|
||||
function AdditionalUnits: string; override;
|
||||
procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override;
|
||||
procedure SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); override;
|
||||
procedure AssignEvents( SL: TStringList; const AName: String ); override;
|
||||
public
|
||||
published
|
||||
property Port:smallint read FPort write SetPort;
|
||||
property OnAccept:TOnTCPAccept read FOnAccept write SetOnAccept;
|
||||
property OnError:TOnTCPError read FOnError write SetOnError;
|
||||
property OnConnect:TOnTCPConnect read FOnConnect write SetOnConnect;
|
||||
property OnClientError:TOnTCPError read FOnClientError write SetOnClientError;
|
||||
property OnClientReceive:TOnTCPReceive read FOnClientReceive write SetOnClientReceive;
|
||||
property OnClientManualReceive:TOnTCPManualReceive read FOnClientManualReceive write SetOnClientManualReceive;
|
||||
property OnClientConnect:TOnTCPClientConnect read FOnClientConnect write SetOnClientConnect;
|
||||
property OnClientDisconnect:TOnTCPDisconnect read FOnClientDisconnect write SetOnClientDisconnect;
|
||||
property OnClientStreamSend:TOnTCPStreamSend read FOnClientStreamSend write SetOnClientStreamSend;
|
||||
property OnClientStreamReceive:TOnTCPStreamReceive read FOnClientStreamReceive write SetOnClientStreamReceive;
|
||||
end;
|
||||
|
||||
procedure Register;
|
||||
|
||||
implementation
|
||||
|
||||
{$R *.dcr}
|
||||
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('KOLAddons', [TKOLTCPClient,TKOLTCPServer]);
|
||||
end;
|
||||
|
||||
{ TKOLTCPClient }
|
||||
|
||||
function TKOLTCPClient.AdditionalUnits;
|
||||
begin
|
||||
result:=', kolTCPSocket';
|
||||
end;
|
||||
|
||||
procedure TKOLTCPClient.SetupFirst(SL: TStringList; const AName, AParent, Prefix: String);
|
||||
begin
|
||||
sl.add(prefix+aname+':=newtcpclient;');
|
||||
sl.add(prefix+aname+'.port:='+inttostr(fport)+';');
|
||||
sl.add(prefix+aname+'.host:='#39+fhost+#39';');
|
||||
end;
|
||||
|
||||
procedure TKOLTCPClient.SetupLast(SL: TStringList; const AName, AParent, Prefix: String);
|
||||
begin
|
||||
//
|
||||
end;
|
||||
|
||||
procedure TKOLTCPClient.AssignEvents(SL: TStringList; const AName: String);
|
||||
begin
|
||||
inherited;
|
||||
doassignevents(sl,aname,
|
||||
['OnConnect','OnDisconnect','OnError','OnReceive','OnManualReceive',
|
||||
'OnStreamSend','OnStreamReceive'],
|
||||
[@OnConnect,@OnDisconnect,@OnError,@OnReceive,@OnManualReceive,
|
||||
@OnStreamSend,@OnStreamReceive]);
|
||||
end;
|
||||
|
||||
procedure TKOLTCPClient.SetHost(const Value: string);
|
||||
begin
|
||||
FHost := Value;
|
||||
change;
|
||||
end;
|
||||
|
||||
procedure TKOLTCPClient.SetOnConnect(const Value: TOnTCPConnect);
|
||||
begin
|
||||
FOnConnect := Value;
|
||||
change;
|
||||
end;
|
||||
|
||||
procedure TKOLTCPClient.SetOnDisconnect(const Value: TOnTCPDisconnect);
|
||||
begin
|
||||
FOnDisconnect := Value;
|
||||
change;
|
||||
end;
|
||||
|
||||
procedure TKOLTCPClient.SetOnError(const Value: TOnTCPError);
|
||||
begin
|
||||
FOnError := Value;
|
||||
change;
|
||||
end;
|
||||
|
||||
procedure TKOLTCPClient.SetOnReceive(const Value: TOnTCPReceive);
|
||||
begin
|
||||
FOnReceive := Value;
|
||||
change;
|
||||
end;
|
||||
|
||||
{procedure TKOLTCPClient.SetOnResolve(const Value: TOnTCPResolve);
|
||||
begin
|
||||
FOnResolve := Value;
|
||||
change;
|
||||
end;
|
||||
}
|
||||
procedure TKOLTCPClient.SetPort(const Value: smallint);
|
||||
begin
|
||||
FPort := Value;
|
||||
change;
|
||||
end;
|
||||
|
||||
procedure TKOLTCPClient.SetOnManualReceive( const Value: TOnTCPManualReceive);
|
||||
begin
|
||||
FOnManualReceive := Value;
|
||||
change;
|
||||
end;
|
||||
|
||||
procedure TKOLTCPClient.SetOnStreamReceive(const Value: TOnTCPStreamReceive);
|
||||
begin
|
||||
FOnStreamReceive := Value;
|
||||
change;
|
||||
end;
|
||||
|
||||
procedure TKOLTCPClient.SetOnStreamSend(const Value: TOnTCPStreamSend);
|
||||
begin
|
||||
FOnStreamSend := Value;
|
||||
change;
|
||||
end;
|
||||
|
||||
{ TKOLTCPServer }
|
||||
|
||||
function TKOLTCPServer.AdditionalUnits: string;
|
||||
begin
|
||||
result:=', kolTCPSocket';
|
||||
end;
|
||||
|
||||
procedure TKOLTCPServer.AssignEvents(SL: TStringList;
|
||||
const AName: String);
|
||||
begin
|
||||
inherited;
|
||||
doassignevents(sl,aname,
|
||||
['OnConnect','OnAccept','OnError','OnClientError','OnClientConnect','OnClientDisconnect','OnClientReceive',
|
||||
'OnClientManualReceive','OnClientStreamSend','OnClientStreamReceive'],
|
||||
[@OnConnect,@OnAccept,@OnError,@OnClientError,@OnClientConnect,@OnClientDisconnect,@OnClientReceive,
|
||||
@OnClientManualReceive,@OnClientStreamSend,@OnClientStreamReceive]);
|
||||
end;
|
||||
|
||||
procedure TKOLTCPServer.SetOnConnect(const Value: TOnTCPConnect);
|
||||
begin
|
||||
FOnConnect := Value;
|
||||
change;
|
||||
end;
|
||||
|
||||
procedure TKOLTCPServer.SetOnAccept(const Value: TOnTCPAccept);
|
||||
begin
|
||||
FOnAccept := Value;
|
||||
change;
|
||||
end;
|
||||
|
||||
procedure TKOLTCPServer.SetOnClientConnect( const Value: TOnTCPClientConnect);
|
||||
begin
|
||||
FOnClientConnect := Value;
|
||||
change;
|
||||
end;
|
||||
|
||||
procedure TKOLTCPServer.SetOnClientDisconnect( const Value: TOnTCPDisconnect);
|
||||
begin
|
||||
FOnClientDisconnect := Value;
|
||||
change;
|
||||
end;
|
||||
|
||||
procedure TKOLTCPServer.SetOnClientError(const Value: TOnTCPError);
|
||||
begin
|
||||
FOnClientError := Value;
|
||||
change;
|
||||
end;
|
||||
|
||||
procedure TKOLTCPServer.SetOnClientManualReceive( const Value: TOnTCPManualReceive);
|
||||
begin
|
||||
FOnClientManualReceive := Value;
|
||||
change;
|
||||
end;
|
||||
|
||||
procedure TKOLTCPServer.SetOnClientReceive(const Value: TOnTCPReceive);
|
||||
begin
|
||||
FOnClientReceive := Value;
|
||||
change;
|
||||
end;
|
||||
|
||||
procedure TKOLTCPServer.SetOnClientStreamReceive( const Value: TOnTCPStreamReceive);
|
||||
begin
|
||||
FOnClientStreamReceive := Value;
|
||||
change;
|
||||
end;
|
||||
|
||||
procedure TKOLTCPServer.SetOnClientStreamSend( const Value: TOnTCPStreamSend);
|
||||
begin
|
||||
FOnClientStreamSend := Value;
|
||||
change;
|
||||
end;
|
||||
|
||||
procedure TKOLTCPServer.SetOnError(const Value: TOnTCPError);
|
||||
begin
|
||||
FOnError := Value;
|
||||
change;
|
||||
end;
|
||||
|
||||
procedure TKOLTCPServer.SetPort(const Value: smallint);
|
||||
begin
|
||||
FPort := Value;
|
||||
change;
|
||||
end;
|
||||
|
||||
procedure TKOLTCPServer.SetupFirst(SL: TStringList; const AName, AParent, Prefix: String);
|
||||
begin
|
||||
sl.add(prefix+aname+':=newtcpserver;');
|
||||
sl.add(prefix+aname+'.port:='+inttostr(fport)+';');
|
||||
end;
|
||||
|
||||
procedure TKOLTCPServer.SetupLast(SL: TStringList; const AName, AParent, Prefix: String);
|
||||
begin
|
||||
//
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
BIN
Addons/mckWebBrowser.dcr
Normal file
BIN
Addons/mckWebBrowser.dcr
Normal file
Binary file not shown.
BIN
Addons/mckXPMenus.dcr
Normal file
BIN
Addons/mckXPMenus.dcr
Normal file
Binary file not shown.
390
Addons/mckXPMenus.pas
Normal file
390
Addons/mckXPMenus.pas
Normal file
@@ -0,0 +1,390 @@
|
||||
unit mckXPMenus;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Windows, mirror, Messages, Graphics, Classes, Math, SysUtils;
|
||||
|
||||
type
|
||||
TKOLXPMainMenu = class(TKOLMainMenu)
|
||||
private
|
||||
{ Private declarations }
|
||||
FBackColor: TColor;
|
||||
FGutterColor: TColor;
|
||||
FSelectedColor: TColor;
|
||||
FCheckColor: TColor;
|
||||
FFont:TKOLFont;
|
||||
FItemHeight: integer;
|
||||
FItemWidth: integer;
|
||||
procedure SetBackColor(const Value:TColor);
|
||||
procedure SetGutterColor(const Value:TColor);
|
||||
procedure SetSelectedColor(const Value:TColor);
|
||||
procedure SetCheckColor(const Value:TColor);
|
||||
procedure SetFont(const Value:TKOLFont);
|
||||
procedure SetItemHeight(const Value:integer);
|
||||
procedure SetItemWidth(const Value:integer);
|
||||
protected
|
||||
{ Protected declarations }
|
||||
function AdditionalUnits: string; override;
|
||||
|
||||
public
|
||||
{ Public declarations }
|
||||
constructor Create(AOwner:TComponent);override;
|
||||
destructor Destroy;override;
|
||||
procedure SetupFirst(SL: TStringList; const AName,AParent, Prefix: String); override;
|
||||
procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: String); override;
|
||||
function TypeName: String; override;
|
||||
published
|
||||
{ Published declarations }
|
||||
property BackColor: TColor read FBackColor write SetBackColor;
|
||||
property GutterColor: TColor read FGutterColor write SetGutterColor;
|
||||
property SelectedColor: TColor read FSelectedColor write SetSelectedColor;
|
||||
property Font: TKOLFont read FFont write SetFont;
|
||||
property ItemHeight: integer read FItemHeight write SetItemHeight;
|
||||
property ItemWidth: integer read FItemWidth write SetItemWidth;
|
||||
property CheckColor: TColor read FCheckColor write SetCheckColor;
|
||||
end;
|
||||
|
||||
TKOLXPPopupMenu = class(TKOLPopupMenu)
|
||||
private
|
||||
{ Private declarations }
|
||||
FBackColor: TColor;
|
||||
FGutterColor: TColor;
|
||||
FSelectedColor: TColor;
|
||||
FCheckColor: TColor;
|
||||
FFont:TKOLFont;
|
||||
FItemHeight: integer;
|
||||
FItemWidth: integer;
|
||||
procedure SetBackColor(const Value:TColor);
|
||||
procedure SetGutterColor(const Value:TColor);
|
||||
procedure SetSelectedColor(const Value:TColor);
|
||||
procedure SetCheckColor(const Value:TColor);
|
||||
procedure SetFont(const Value:TKOLFont);
|
||||
procedure SetItemHeight(const Value:integer);
|
||||
procedure SetItemWidth(const Value:integer);
|
||||
protected
|
||||
{ Protected declarations }
|
||||
function AdditionalUnits: string; override;
|
||||
|
||||
public
|
||||
{ Public declarations }
|
||||
constructor Create(AOwner:TComponent);override;
|
||||
destructor Destroy;override;
|
||||
function TypeName: String; override;
|
||||
procedure SetupFirst(SL: TStringList; const AName,AParent, Prefix: String); override;
|
||||
procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: String); override;
|
||||
published
|
||||
{ Published declarations }
|
||||
property BackColor: TColor read FBackColor write SetBackColor;
|
||||
property GutterColor: TColor read FGutterColor write SetGutterColor;
|
||||
property SelectedColor: TColor read FSelectedColor write SetSelectedColor;
|
||||
property Font: TKOLFont read FFont write SetFont;
|
||||
property ItemHeight: integer read FItemHeight write SetItemHeight;
|
||||
property ItemWidth: integer read FItemWidth write SetItemWidth;
|
||||
property CheckColor: TColor read FCheckColor write SetCheckColor;
|
||||
end;
|
||||
|
||||
|
||||
procedure Register;
|
||||
|
||||
implementation
|
||||
|
||||
type
|
||||
TRGB = packed record
|
||||
R, G, B: Byte;
|
||||
end;
|
||||
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('KOLAddons', [TKOLXPMainMenu]);
|
||||
RegisterComponents('KOLAddons', [TKOLXPPopupMenu]);
|
||||
end;
|
||||
|
||||
function GetRGB(const Color: TColor): TRGB;
|
||||
var
|
||||
iColor: TColor;
|
||||
begin
|
||||
iColor := ColorToRGB(Color);
|
||||
Result.R := GetRValue(iColor);
|
||||
Result.G := GetGValue(iColor);
|
||||
Result.B := GetBValue(iColor);
|
||||
end;
|
||||
|
||||
|
||||
function GetLightColor(Color: TColor; Light: Byte) : TColor;
|
||||
var
|
||||
fFrom: TRGB;
|
||||
begin
|
||||
FFrom := GetRGB(Color);
|
||||
|
||||
Result := RGB(
|
||||
Round(FFrom.R + (255 - FFrom.R) * (Light / 100)),
|
||||
Round(FFrom.G + (255 - FFrom.G) * (Light / 100)),
|
||||
Round(FFrom.B + (255 - FFrom.B) * (Light / 100))
|
||||
);
|
||||
end;
|
||||
|
||||
// XP Main Menu
|
||||
|
||||
constructor TKOLXPMainMenu.Create(AOwner:TComponent);
|
||||
begin
|
||||
FGutterColor := clBtnFace;
|
||||
FBackColor := GetLightColor(clBtnFace, 85);
|
||||
FSelectedColor := GetLightColor(clHighlight, 65);
|
||||
fFont := TKOLFont.Create(Self);
|
||||
FCheckColor:= clBlack;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
destructor TKOLXPMainMenu.Destroy;
|
||||
begin
|
||||
fFont.Free ;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
|
||||
function TKOLXPMainMenu.AdditionalUnits;
|
||||
begin
|
||||
Result := ', XPMenus';
|
||||
end;
|
||||
|
||||
function TKOLXPMainMenu.TypeName;
|
||||
begin
|
||||
Result := 'XPMenu';
|
||||
end;
|
||||
|
||||
procedure TKOLXPMainMenu.SetupFirst(SL: TStringList; const AName,AParent, Prefix: String);
|
||||
var i:integer;
|
||||
MI: TKOLMenuItem;
|
||||
s:string;
|
||||
begin
|
||||
if Count = 0 then Exit;
|
||||
SL.Add( Prefix + AName + ' := NewXPMenu( ' + AParent + ', 0, [ ' );
|
||||
|
||||
for I := 0 to Count - 1 do
|
||||
begin
|
||||
MI := Items[ I ];
|
||||
MI.SetupTemplate( SL, I = 0 );
|
||||
end;
|
||||
|
||||
S := ''''' ], ' + OnMenuItemMethodName(False) + ', false );';
|
||||
if Count <> 0 then
|
||||
S := ', ' + S;
|
||||
if Length( S ) + Length( SL[ SL.Count - 1 ] ) > 64 then
|
||||
SL.Add( Prefix + ' ' + S )
|
||||
else
|
||||
SL[ SL.Count - 1 ] := SL[ SL.Count - 1 ] + S;
|
||||
if Name <> '' then
|
||||
begin
|
||||
SL.Add( ' {$IFDEF USE_NAMES}' );
|
||||
SL.Add( Prefix + AName + '.Name := ''' + Name + ''';' );
|
||||
SL.Add( ' {$ENDIF}' );
|
||||
end;
|
||||
for I := 0 to Count - 1 do
|
||||
begin
|
||||
MI := Items[ I ];
|
||||
MI.SetupAttributes( SL, AName );
|
||||
end;
|
||||
GenerateTag( SL, AName, Prefix );
|
||||
end;
|
||||
|
||||
procedure TKOLXPMainMenu.SetupLast(SL: TStringList; const AName, AParent, Prefix: String);
|
||||
begin
|
||||
inherited;
|
||||
if fBackColor<>GetLightColor(clBtnFace, 85) then SL.Add(Prefix + AName +'.BackColor :='+ Color2Str(fBackColor)+';');
|
||||
if fGutterColor<>clBtnFace then SL.Add(Prefix + AName +'.GutterColor :='+ Color2Str(fGutterColor)+';');
|
||||
if fSelectedColor<>GetLightColor(clHighlight, 65) then SL.Add(Prefix + AName +'.SelectedColor :='+ Color2Str(fSelectedColor)+';');
|
||||
if fCheckColor<>clBlack then SL.Add(Prefix + AName +'.CheckColor :='+ Color2Str(fCheckColor)+';');
|
||||
fFont.GenerateCode(SL,AName,nil);
|
||||
if fItemHeight<>0 then SL.Add(Prefix + AName +'.ItemHeight :='+ inttoStr(fItemHeight)+';');
|
||||
if fItemWidth<>0 then SL.Add(Prefix + AName +'.ItemWidth :='+ inttoStr(fItemWidth)+';');
|
||||
SL.Add(Prefix + AName +'.DrawXPStyle;');
|
||||
end;
|
||||
|
||||
procedure TKOLXPMainMenu.SetBackColor(const Value:TColor);
|
||||
begin
|
||||
if FBackColor=Value then begin
|
||||
FBackColor:=Value;
|
||||
Change;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TKOLXPMainMenu.SetGutterColor(const Value:TColor);
|
||||
begin
|
||||
if FGutterColor=Value then begin
|
||||
FGutterColor:=Value;
|
||||
Change;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TKOLXPMainMenu.SetSelectedColor(const Value:TColor);
|
||||
begin
|
||||
if FSelectedColor<>Value then begin
|
||||
FSelectedColor:=Value;
|
||||
Change;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TKOLXPMainMenu.SetCheckColor(const Value:TColor);
|
||||
begin
|
||||
if FCheckColor<>Value then begin
|
||||
FCheckColor:=Value;
|
||||
Change;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TKOLXPMainMenu.SetFont(const Value:TKOLFont);
|
||||
begin
|
||||
FFont:=Value;
|
||||
Change;
|
||||
end;
|
||||
|
||||
procedure TKOLXPMainMenu.SetItemHeight(const Value:integer);
|
||||
begin
|
||||
if FItemHeight<>Value then begin
|
||||
FItemHeight:= Value;
|
||||
Change;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TKOLXPMainMenu.SetItemWidth(const Value:integer);
|
||||
begin
|
||||
if FItemWidth<>Value then begin
|
||||
FItemWidth:= Value;
|
||||
Change;
|
||||
end;
|
||||
end;
|
||||
|
||||
// XP Popup Menu
|
||||
|
||||
constructor TKOLXPPopupMenu.Create(AOwner:TComponent);
|
||||
begin
|
||||
FGutterColor := clBtnFace;
|
||||
FBackColor := GetLightColor(clBtnFace, 85);
|
||||
FSelectedColor := GetLightColor(clHighlight, 65);
|
||||
fFont := TKOLFont.Create(Self);
|
||||
FCheckColor:= clBlack;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
destructor TKOLXPPopupMenu.Destroy;
|
||||
begin
|
||||
fFont.Free ;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
function TKOLXPPopupMenu.AdditionalUnits;
|
||||
begin
|
||||
Result := ', XPMenus';
|
||||
end;
|
||||
|
||||
function TKOLXPPopupMenu.TypeName;
|
||||
begin
|
||||
Result := 'XPMenu';
|
||||
end;
|
||||
|
||||
procedure TKOLXPPopupMenu.SetupFirst(SL: TStringList; const AName,AParent, Prefix: String);
|
||||
var i:integer;
|
||||
MI: TKOLMenuItem;
|
||||
s:string;
|
||||
begin
|
||||
if Count = 0 then Exit;
|
||||
SL.Add( Prefix + AName + ' := NewXPMenu( ' + AParent + ', 0, [ ' );
|
||||
|
||||
for I := 0 to Count - 1 do
|
||||
begin
|
||||
MI := Items[ I ];
|
||||
MI.SetupTemplate( SL, I = 0 );
|
||||
end;
|
||||
|
||||
S := ''''' ], ' + OnMenuItemMethodName(False) + ', true );';
|
||||
if Count <> 0 then
|
||||
S := ', ' + S;
|
||||
if Length( S ) + Length( SL[ SL.Count - 1 ] ) > 64 then
|
||||
SL.Add( Prefix + ' ' + S )
|
||||
else
|
||||
SL[ SL.Count - 1 ] := SL[ SL.Count - 1 ] + S;
|
||||
if Name <> '' then
|
||||
begin
|
||||
SL.Add( ' {$IFDEF USE_NAMES}' );
|
||||
SL.Add( Prefix + AName + '.Name := ''' + Name + ''';' );
|
||||
SL.Add( ' {$ENDIF}' );
|
||||
end;
|
||||
for I := 0 to Count - 1 do
|
||||
begin
|
||||
MI := Items[ I ];
|
||||
MI.SetupAttributes( SL, AName );
|
||||
end;
|
||||
GenerateTag( SL, AName, Prefix );
|
||||
end;
|
||||
|
||||
procedure TKOLXPPopupMenu.SetupLast(SL: TStringList; const AName, AParent, Prefix: String);
|
||||
begin
|
||||
inherited;
|
||||
if fBackColor<>GetLightColor(clBtnFace, 85) then SL.Add(Prefix + AName +'.BackColor :='+ Color2Str(fBackColor)+';');
|
||||
if fGutterColor<>clBtnFace then SL.Add(Prefix + AName +'.GutterColor :='+ Color2Str(fGutterColor)+';');
|
||||
if fSelectedColor<>GetLightColor(clHighlight, 65) then SL.Add(Prefix + AName +'.SelectedColor :='+ Color2Str(fSelectedColor)+';');
|
||||
if fCheckColor<>clBlack then SL.Add(Prefix + AName +'.CheckColor :='+ Color2Str(fCheckColor)+';');
|
||||
fFont.GenerateCode(SL,AName,nil);
|
||||
if fItemHeight<>0 then SL.Add(Prefix + AName +'.ItemHeight :='+ inttoStr(fItemHeight)+';');
|
||||
if fItemWidth<>0 then SL.Add(Prefix + AName +'.ItemWidth :='+ inttoStr(fItemWidth)+';');
|
||||
SL.Add(Prefix + AName +'.DrawXPStyle;');
|
||||
end;
|
||||
|
||||
procedure TKOLXPPopupMenu.SetBackColor(const Value:TColor);
|
||||
begin
|
||||
if FBackColor<>Value then begin
|
||||
FBackColor:=Value;
|
||||
Change;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TKOLXPPopupMenu.SetGutterColor(const Value:TColor);
|
||||
begin
|
||||
if FGutterColor<>Value then begin
|
||||
FGutterColor:=Value;
|
||||
Change;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TKOLXPPopupMenu.SetSelectedColor(const Value:TColor);
|
||||
begin
|
||||
if FSelectedColor<>Value then begin
|
||||
FSelectedColor:=Value;
|
||||
Change;
|
||||
end
|
||||
end;
|
||||
|
||||
procedure TKOLXPPopupMenu.SetCheckColor(const Value:TColor);
|
||||
begin
|
||||
if FCheckColor<>Value then begin
|
||||
FCheckColor:=Value;
|
||||
Change;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TKOLXPPopupMenu.SetFont(const Value:TKOLFont);
|
||||
begin
|
||||
FFont:=Value;
|
||||
Change;
|
||||
end;
|
||||
|
||||
procedure TKOLXPPopupMenu.SetItemHeight(const Value:integer);
|
||||
begin
|
||||
if FItemHeight<>Value then begin
|
||||
FItemHeight:=Value;
|
||||
Change;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TKOLXPPopupMenu.SetItemWidth(const Value:integer);
|
||||
begin
|
||||
if FItemWidth<>Value then begin
|
||||
FItemWidth:= Value;
|
||||
Change;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
|
||||
end.
|
||||
255
Addons/reader.pas
Normal file
255
Addons/reader.pas
Normal file
@@ -0,0 +1,255 @@
|
||||
unit reader;
|
||||
|
||||
interface
|
||||
|
||||
function compare(_ts, _ms : string) : boolean;
|
||||
procedure setvar ( vn, vv : string);
|
||||
function getvar ( vn : string) : string;
|
||||
function parstr : string;
|
||||
procedure setglo ( vn, vv : string);
|
||||
function getglo ( vn : string) : string;
|
||||
function parse ( vn : string; al : boolean) : string;
|
||||
procedure freeglob;
|
||||
|
||||
implementation
|
||||
|
||||
uses UStr, Serv, UWrd;
|
||||
|
||||
type
|
||||
trec = record
|
||||
name : string[12];
|
||||
valu : string[255];
|
||||
next : pointer;
|
||||
end;
|
||||
|
||||
var
|
||||
fvar,
|
||||
fglo : pointer;
|
||||
vrec,
|
||||
vglo,
|
||||
rrec : ^trec;
|
||||
v,
|
||||
z : string;
|
||||
|
||||
function compare;
|
||||
label fail, succ;
|
||||
var i,
|
||||
j,
|
||||
n : integer;
|
||||
ts,
|
||||
ms : string;
|
||||
|
||||
procedure freelist;
|
||||
begin
|
||||
vrec := fvar;
|
||||
while vrec <> nil do begin
|
||||
rrec := vrec;
|
||||
vrec := vrec^.next;
|
||||
freemem(rrec, sizeof(trec));
|
||||
end;
|
||||
fvar := nil;
|
||||
end;
|
||||
|
||||
begin
|
||||
ts := _ts;
|
||||
ms := _ms;
|
||||
i := 1;
|
||||
j := 1;
|
||||
compare := true;
|
||||
freelist;
|
||||
repeat
|
||||
if (i > length(ts)) and (j > length(ms)) then goto succ;
|
||||
if (i > length(ts)) or (j > length(ms)) then goto fail;
|
||||
if ts[i] = ms[j] then begin
|
||||
inc(i);
|
||||
inc(j);
|
||||
if j > length(ms) then goto succ;
|
||||
end else
|
||||
if ts[i] = '?' then begin
|
||||
inc(i);
|
||||
inc(j);
|
||||
end else
|
||||
if ts[i] = '*' then begin
|
||||
inc(i);
|
||||
if i > length(ts) then goto succ;
|
||||
z := copy(ts, i, 255);
|
||||
if pos('*', z) > 0 then z := copy(z, 1, pos('*', z) - 1);
|
||||
if pos('?', z) > 0 then z := copy(z, 1, pos('?', z) - 1);
|
||||
if pos('%', z) > 0 then z := copy(z, 1, pos('%', z) - 1);
|
||||
while (j <= length(ms)) and (copy(ms, j, length(z)) <> z) do begin
|
||||
while (j < length(ms)) and (ms[j] <> ts[i]) do inc(j);
|
||||
if j > length(ms) then goto fail;
|
||||
if copy(ms, j, length(z)) <> z then inc(j);
|
||||
end;
|
||||
end else
|
||||
if ts[i] = '%' then begin
|
||||
inc(i);
|
||||
n := i;
|
||||
while (i <= length(ts)) and (ts[i] <> '%') do inc(i);
|
||||
if i > length(ts) then goto fail;
|
||||
v := copy(ts, n, i - n);
|
||||
v := upst(v);
|
||||
inc(i);
|
||||
n := j;
|
||||
if i <= length(ts) then begin
|
||||
while (j <= length(ms)) and (ms[j] <> ts[i]) do inc(j);
|
||||
if j > length(ms) then goto fail;
|
||||
end else begin
|
||||
j := length(ms) + 1;
|
||||
end;
|
||||
z := copy(ms, n, j - n);
|
||||
if fvar = nil then begin
|
||||
getmem(fvar, sizeof(trec));
|
||||
vrec := fvar;
|
||||
end else begin
|
||||
getmem(vrec^.next, sizeof(trec));
|
||||
vrec := vrec^.next;
|
||||
end;
|
||||
fillchar(vrec^, sizeof(trec), #0);
|
||||
vrec^.name := v;
|
||||
vrec^.valu := z;
|
||||
if fglo = nil then begin
|
||||
getmem(fglo, sizeof(trec));
|
||||
vglo := fglo;
|
||||
rrec := fglo;
|
||||
fillchar(vglo^, sizeof(trec), #0);
|
||||
end else begin
|
||||
rrec := fglo;
|
||||
while (rrec <> nil) and (rrec^.name <> v) do begin
|
||||
vglo := rrec;
|
||||
rrec := rrec^.next;
|
||||
end;
|
||||
if rrec = nil then begin
|
||||
getmem(vglo^.next, sizeof(trec));
|
||||
vglo := vglo^.next;
|
||||
rrec := vglo;
|
||||
fillchar(vglo^, sizeof(trec), #0);
|
||||
end;
|
||||
end;
|
||||
rrec^.name := v;
|
||||
rrec^.valu := z;
|
||||
end else begin
|
||||
if (i > 1) and (j > i) then
|
||||
if compare(ts, copy(ms, j, length(ms) - j + 1)) then goto succ
|
||||
else goto fail
|
||||
else goto fail;
|
||||
end;
|
||||
until false;
|
||||
fail:
|
||||
compare := false;
|
||||
freelist;
|
||||
exit;
|
||||
succ:
|
||||
exit;
|
||||
end;
|
||||
|
||||
procedure setvar;
|
||||
begin
|
||||
vglo := fvar;
|
||||
while vglo <> Nil do begin
|
||||
if vglo^.name = UpSt(vn) then break;
|
||||
vglo := vglo^.next;
|
||||
end;
|
||||
if vglo = Nil then vglo := NewEList(fvar, sizeof(trec), false);
|
||||
vglo^.name := UpSt(vn);
|
||||
vglo^.valu := vv;
|
||||
end;
|
||||
|
||||
function getvar;
|
||||
var
|
||||
tv : string;
|
||||
begin
|
||||
getvar := '';
|
||||
vrec := fvar;
|
||||
tv := vn;
|
||||
tv := upst(tv);
|
||||
while vrec <> nil do begin
|
||||
if vrec^.name = tv then begin
|
||||
getvar := vrec^.valu;
|
||||
exit;
|
||||
end;
|
||||
vrec := vrec^.next;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure setglo;
|
||||
begin
|
||||
vglo := fglo;
|
||||
while vglo <> Nil do begin
|
||||
if vglo^.name = UpSt(vn) then break;
|
||||
vglo := vglo^.next;
|
||||
end;
|
||||
if vglo = Nil then vglo := NewEList(fglo, sizeof(trec), false);
|
||||
vglo^.name := UpSt(vn);
|
||||
vglo^.valu := vv;
|
||||
end;
|
||||
|
||||
function getglo;
|
||||
var
|
||||
tv : string;
|
||||
begin
|
||||
getglo := '';
|
||||
vglo := fglo;
|
||||
tv := vn;
|
||||
tv := upst(tv);
|
||||
while vglo <> nil do begin
|
||||
if vglo^.name = tv then begin
|
||||
getglo := vglo^.valu;
|
||||
exit;
|
||||
end;
|
||||
vglo := vglo^.next;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure freeglob;
|
||||
begin
|
||||
vglo := fglo;
|
||||
while vglo <> nil do begin
|
||||
rrec := vglo;
|
||||
vglo := vglo^.next;
|
||||
freemem(rrec, sizeof(trec));
|
||||
end;
|
||||
fglo := nil;
|
||||
end;
|
||||
|
||||
function parstr;
|
||||
var
|
||||
tv : string;
|
||||
begin
|
||||
tv := '';
|
||||
vrec := fvar;
|
||||
while vrec <> nil do begin
|
||||
tv := tv + ' ' + vrec^.valu;
|
||||
vrec := vrec^.next;
|
||||
end;
|
||||
parstr := tv;
|
||||
end;
|
||||
|
||||
function parse;
|
||||
var i,
|
||||
p : integer;
|
||||
s : string;
|
||||
rs : string;
|
||||
begin
|
||||
s := '';
|
||||
i := 0;
|
||||
repeat
|
||||
inc(i);
|
||||
rs := wordn(vn, '%', i + 1);
|
||||
rs := getglo(rs);
|
||||
s := s + wordn(vn, '%', i);
|
||||
p := wordp(vn, '%', i + 1);
|
||||
if p > 0 then begin
|
||||
if al then s := copy(s, 1, p - 2);
|
||||
if al then s := s + space(p - 2 - length(s));
|
||||
end;
|
||||
s := s + rs;
|
||||
if rs <> '' then inc(i);
|
||||
until i > words(vn, '%');
|
||||
parse := s;
|
||||
end;
|
||||
|
||||
begin
|
||||
fvar := nil;
|
||||
fglo := nil;
|
||||
end.
|
||||
202
Addons/richprint.pas
Normal file
202
Addons/richprint.pas
Normal file
@@ -0,0 +1,202 @@
|
||||
unit RichPrint;
|
||||
{* By Savva. A unit to print rich edit control content. }
|
||||
|
||||
interface
|
||||
|
||||
uses Windows, KOL, {$IFNDEF NOT_USE_PRINTER_OBJ}
|
||||
{$IFDEF USE_MHPRINTER} KOLMHPrinters {$ELSE} KOLPrinters {$ENDIF}
|
||||
,{$ENDIF}
|
||||
RichEdit, CommDlg;
|
||||
|
||||
procedure FilePrint(ACaption : string;fRichEdit : PControl);
|
||||
{* ������ ��� ������������� ������� Printer }
|
||||
|
||||
{$IFNDEF NOT_USE_PRINTER_OBJ}
|
||||
procedure PrintRichEdit(CONST fRichEdit : PControl;const Caption: string);
|
||||
{* ������ c �������������� ������� Printer }
|
||||
{$ENDIF}
|
||||
|
||||
implementation
|
||||
|
||||
//*****************************************************
|
||||
// ������ ��� ������������� ������� Printer
|
||||
// -----------------------------------------------------
|
||||
// ������� FilePrint
|
||||
// -----------------------------------------------------
|
||||
procedure FilePrint(ACaption : string;fRichEdit : PControl);
|
||||
var
|
||||
fr : FORMATRANGE;
|
||||
docInfo : TDOCINFO;
|
||||
lLastChar, lTextSize :integer ;
|
||||
pd : TPRINTDLG ;
|
||||
nRc : integer ;
|
||||
hPrintDC : HDC ;
|
||||
|
||||
szErr : string;
|
||||
dwErr :DWORD ;
|
||||
//TextLenEx: TGetTextLengthEx;
|
||||
|
||||
begin
|
||||
// �������������� ���� ��������� PRITDLG
|
||||
|
||||
ZeroMemory(@pd, sizeof(pd));
|
||||
pd.lStructSize := sizeof(TPRINTDLG);
|
||||
pd.hwndOwner := fRichEdit.Handle;
|
||||
pd.hInstance := HInstance;
|
||||
pd.Flags := PD_RETURNDC or PD_NOPAGENUMS or PD_NOSELECTION or PD_PRINTSETUP or
|
||||
PD_ALLPAGES;
|
||||
pd.nFromPage := $ffff;
|
||||
pd.nToPage := $ffff;
|
||||
pd.nMinPage := 0;
|
||||
pd.nMaxPage := $ffff;
|
||||
pd.nCopies := 1;
|
||||
|
||||
|
||||
// ������� �� ����� ���������� ������, ���������������
|
||||
// ��� ������ ���������
|
||||
if PrintDlg(pd) then begin
|
||||
// if(TRUE) then begin
|
||||
hPrintDC := pd.hDC;
|
||||
|
||||
// �������������� ���� ��������� FORMATRANGE
|
||||
ZeroMemory(@fr, sizeof(fr));
|
||||
|
||||
// ����� �������� � �������������� ���������
|
||||
// ��������, ����������� �� ������� PrintDlg
|
||||
fr.hdc := hPrintDC;
|
||||
fr.hdcTarget:=fr.hdc;
|
||||
|
||||
// �������� ���� ��������
|
||||
fr.chrg.cpMin := 0;
|
||||
fr.chrg.cpMax := -1;
|
||||
|
||||
// ������������� ������� �������� � TWIPS-��
|
||||
fr.rcPage.top := 0;
|
||||
fr.rcPage.left := 0;
|
||||
fr.rcPage.right :=
|
||||
MulDiv(GetDeviceCaps(hPrintDC, PHYSICALWIDTH),
|
||||
1440, GetDeviceCaps(hPrintDC, LOGPIXELSX));
|
||||
|
||||
fr.rcPage.bottom := MulDiv(GetDeviceCaps(hPrintDC,
|
||||
PHYSICALHEIGHT),1440,
|
||||
GetDeviceCaps(hPrintDC, LOGPIXELSY));
|
||||
fr.rc := fr.rcPage;
|
||||
|
||||
// ��������� ����
|
||||
if (fr.rcPage.right > 2*3*1440/4+1440) then begin
|
||||
fr.rc.left := 3*1440 div 4;
|
||||
fr.rc.right :=fr.rc.right - (fr.rc.left);
|
||||
end;
|
||||
if(fr.rcPage.bottom > 3*1440) then begin
|
||||
fr.rc.top := 1440;
|
||||
fr.rc.bottom:=fr.rc.bottom - (fr.rc.top);
|
||||
end;
|
||||
|
||||
// ��������� ���� ��������� DOCINFO
|
||||
ZeroMemory(@docInfo, sizeof(DOCINFO));
|
||||
docInfo.cbSize := sizeof(DOCINFO);
|
||||
docInfo.lpszOutput := nil;
|
||||
docInfo.lpszDocName := PChar(ACaption);
|
||||
|
||||
|
||||
// �������� ������ ���������
|
||||
nRc := StartDoc(hPrintDC, docInfo);
|
||||
|
||||
// ���� ��������� ������, �������� � ������� �� �����
|
||||
// ��� ������
|
||||
if (nRc < 0) then begin
|
||||
dwErr := GetLastError();
|
||||
|
||||
szErr:=format( 'Print Error %ld \r\n %s', [dwErr,SysErrorMessage(dwErr)]);
|
||||
|
||||
MessageBox(0, PChar(szErr),
|
||||
'Error printing', MB_OK or MB_ICONEXCLAMATION);
|
||||
|
||||
DeleteDC(hPrintDC);
|
||||
exit;
|
||||
end;
|
||||
|
||||
// �������� ������ ��������
|
||||
StartPage(hPrintDC);
|
||||
|
||||
lLastChar := 0;
|
||||
|
||||
// ���������� ����� ������
|
||||
lTextSize := fRichEdit.RE_TextSizePrecise;
|
||||
// ���� �� ���� ��������� ���������
|
||||
while (lLastChar < lTextSize) do begin
|
||||
// ����������� ������ ��� �������� � �������� ��
|
||||
lLastChar := SendMessage(fRichEdit.Handle, EM_FORMATRANGE, DWORD(TRUE),
|
||||
LPARAM( @fr));
|
||||
|
||||
if(lLastChar < lTextSize) then begin
|
||||
// ��������� ������ ��������� ��������
|
||||
EndPage(hPrintDC);
|
||||
|
||||
// �������� ����� ��������
|
||||
StartPage(hPrintDC);
|
||||
fr.chrg.cpMin := lLastChar;
|
||||
fr.chrg.cpMax := -1;
|
||||
end;
|
||||
end;
|
||||
|
||||
// ������� ����������, ������� �������� �
|
||||
// ������ ���������� Rich Edit
|
||||
SendMessage(fRichEdit.Handle, EM_FORMATRANGE, DWORD(TRUE), LPARAM(nil));
|
||||
|
||||
// ��������� ������ ��������
|
||||
EndPage(hPrintDC);
|
||||
|
||||
// ��������� ������ ���������
|
||||
EndDoc(hPrintDC);
|
||||
|
||||
// ������� �������� ��������
|
||||
DeleteDC(hPrintDC);
|
||||
end;
|
||||
end;
|
||||
|
||||
{$IFNDEF NOT_USE_PRINTER_OBJ}
|
||||
//*****************************************************
|
||||
// ������ c �������������� ������� Printer
|
||||
procedure PrintRichEdit(CONST fRichEdit : PControl;const Caption: string);
|
||||
var
|
||||
Range: TFormatRange;
|
||||
LastChar, MaxLen, LogX, LogY, OldMap: Integer;
|
||||
SaveRect: TRect;
|
||||
begin
|
||||
FillChar(Range, SizeOf(TFormatRange), 0);
|
||||
Printer.Title := Caption;
|
||||
Printer.BeginDoc;
|
||||
Range.hdc := Printer.Handle;
|
||||
Range.hdcTarget := Range.hdc;
|
||||
LogX := GetDeviceCaps(Printer.Handle, LOGPIXELSX);
|
||||
LogY := GetDeviceCaps(Printer.Handle, LOGPIXELSY);
|
||||
|
||||
Range.rc.right := Printer.PageWidth * 1440 div LogX;
|
||||
Range.rc.bottom := Printer.PageHeight * 1440 div LogY;
|
||||
Range.rcPage := Range.rc;
|
||||
SaveRect := Range.rc;
|
||||
LastChar := 0;
|
||||
// MaxLen := fRichEdit.Perform(WM_GETTEXTLENGTH, 0, 0);
|
||||
MaxLen := fRichEdit.RE_TextSizePrecise;
|
||||
Range.chrg.cpMax := -1;
|
||||
// ensure printer DC is in text map mode
|
||||
OldMap := SetMapMode(range.hdc, MM_TEXT);
|
||||
fRichEdit.Perform(EM_FORMATRANGE, 0, 0); // flush buffer
|
||||
try
|
||||
repeat
|
||||
Range.rc := SaveRect;
|
||||
Range.chrg.cpMin := LastChar;
|
||||
LastChar := fRichEdit.Perform(EM_FORMATRANGE, 1, Longint(@Range));
|
||||
if (LastChar < MaxLen) and (LastChar <> -1) then Printer.NewPage;
|
||||
until (LastChar >= MaxLen) or (LastChar = -1);
|
||||
Printer.EndDoc;
|
||||
finally
|
||||
fRichEdit.Perform(EM_FORMATRANGE, 0, 0); // flush buffer
|
||||
SetMapMode(Range.hdc, OldMap); // restore previous map mode
|
||||
end;
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
|
||||
end.
|
||||
138
Addons/tinyJPGGIFBMP.pas
Normal file
138
Addons/tinyJPGGIFBMP.pas
Normal file
@@ -0,0 +1,138 @@
|
||||
unit tinyJPGGIFBMP;
|
||||
|
||||
// file: tinyJPGGIFBMP.pas
|
||||
// file version: 0.35
|
||||
// last modified: 05.01.06
|
||||
// package: GRushControls
|
||||
// author: Karpinskyj Alexandr aka homm
|
||||
// mailto: homm86@mail.ru
|
||||
// My humble Web-Page: http://www.homm86.narod.ru
|
||||
|
||||
|
||||
interface
|
||||
|
||||
uses Windows, Kol, ActiveX;
|
||||
|
||||
type TBitmapmod = object( TBitMap )end;
|
||||
|
||||
procedure tinyLoadJPGGIFBMPFile(var TargetBitmap: PBitMap; FileName: String);
|
||||
procedure tinyLoadJPGGIFBMPMemory(var TargetBitmap: PBitMap; Ptr: HGlobal; Size: DWORD);
|
||||
procedure tinyLoadJPGGIFBMPResource(var TargetBitmap: PBitMap; Inst : HInst; ResName : PChar; ResType : PChar);
|
||||
|
||||
implementation
|
||||
|
||||
const IID_IPicture:TGUID='{7BF80980-BF32-101A-8BBB-00AA00300CAB}';
|
||||
|
||||
function SHCreateStreamOnFileA(FileName: PChar; grfMode: DWORD;var stream: IStream):HResult;
|
||||
external 'shlwapi.dll' name 'SHCreateStreamOnFileA';
|
||||
|
||||
procedure OleFree( Picta: IPicture );
|
||||
{begin
|
||||
if Picta <> nil then
|
||||
Picta._Release;}
|
||||
asm
|
||||
push eax
|
||||
mov eax, esp
|
||||
call System.@IntFClear
|
||||
pop eax
|
||||
end;
|
||||
|
||||
procedure tinyLoadJPGGIFBMPFile(var TargetBitmap: PBitMap; FileName: String);
|
||||
var Stream: IStream;
|
||||
Picta: IPicture;
|
||||
hh: THandle;
|
||||
asm
|
||||
//[ebx] = PBitmap;
|
||||
//edi = FileName;
|
||||
push ebx
|
||||
push edi
|
||||
mov ebx, eax
|
||||
mov edi, edx
|
||||
//BitMap := nil;
|
||||
xor eax, eax
|
||||
mov [ebx], eax
|
||||
//SHCreateStreamOnFileA(PChar(FileName), 0, Stream);
|
||||
lea eax, [Stream]
|
||||
push eax
|
||||
push $00
|
||||
push edi //FileName
|
||||
call SHCreateStreamOnFileA
|
||||
//if Stream=nil then exit;
|
||||
cmp Dword ptr [Stream], $00
|
||||
jz @@EXIT
|
||||
//OleLoadPicture(Stream, FileSize(FileName), false, IID_IPicture, Picta);
|
||||
lea eax, [Picta]
|
||||
push eax
|
||||
push offset IID_IPicture
|
||||
push $00
|
||||
mov eax, edi //FileName
|
||||
call KOL.FileSize
|
||||
push eax
|
||||
mov eax, [Stream]
|
||||
push eax
|
||||
call ActiveX.OleLoadPicture
|
||||
//if Picta = nil then exit;
|
||||
cmp Dword ptr [Picta], $00
|
||||
jz @@EXIT
|
||||
//Picta.get_Handle(hh);
|
||||
lea eax, [hh]
|
||||
push eax
|
||||
mov edx, [Picta]
|
||||
push edx
|
||||
mov eax, [edx]
|
||||
call dword ptr [eax+$0c]
|
||||
//BitMap := NewBitMap(0, 0);
|
||||
xor eax, eax
|
||||
xor edx, edx
|
||||
call NewBitmap
|
||||
mov [ebx], eax
|
||||
//BitMap.Handle := hh;
|
||||
mov edx, [hh]
|
||||
call TBitMapMod.SetHandle
|
||||
//BitMap.Add2AutoFreeEx(TObjectMethod(MakeMethod(Pointer(Picta), @OleFree)));
|
||||
mov eax, [Picta]
|
||||
push eax
|
||||
push offset OleFree
|
||||
mov eax, [ebx]
|
||||
call TObj.Add2AutoFreeEx
|
||||
|
||||
@@EXIT:
|
||||
lea eax, [Stream]
|
||||
call System.@IntFClear
|
||||
|
||||
pop edi
|
||||
pop ebx
|
||||
end;
|
||||
|
||||
procedure tinyLoadJPGGIFBMPMemory(var TargetBitmap: PBitMap; Ptr: HGlobal; Size: DWORD);
|
||||
var Stream: IStream;
|
||||
Picta: IPicture;
|
||||
hh: THandle;
|
||||
begin
|
||||
TargetBitmap := nil;
|
||||
if CreateStreamOnHGlobal(ptr, TRUE, Stream) <> S_OK then
|
||||
exit;
|
||||
if OleLoadPicture(Stream, Size, false, IID_IPicture, Picta) <> S_OK then
|
||||
exit;
|
||||
Picta.get_Handle(hh);
|
||||
Picta._AddRef;
|
||||
TargetBitmap := NewBitmap(0, 0);
|
||||
TargetBitmap.Handle := hh;
|
||||
TargetBitmap.Add2AutoFreeEx(TObjectMethod(MakeMethod(Pointer(Picta), @OleFree)));
|
||||
end;
|
||||
|
||||
procedure tinyLoadJPGGIFBMPResource(var TargetBitmap: PBitMap; Inst : HInst; ResName : PChar; ResType : PChar);
|
||||
var G: Pointer;
|
||||
Sz: DWORD;
|
||||
Ptr: Pointer;
|
||||
Resource: HRSRC;
|
||||
begin
|
||||
Resource := FindResource(Inst, ResName, ResType);
|
||||
Sz := SizeofResource(Inst, Resource);
|
||||
DWORD(G) := LoadResource(hinstance, Resource);
|
||||
DWORD(Ptr) := LocalAlloc(GMEM_FIXED, Sz);
|
||||
move(g^, Ptr^, Sz);
|
||||
tinyLoadJPGGIFBMPMemory(TargetBitmap, DWORD(Ptr), Sz);
|
||||
end;
|
||||
|
||||
end.
|
||||
1347
Addons/tinyPNG.pas
Normal file
1347
Addons/tinyPNG.pas
Normal file
File diff suppressed because it is too large
Load Diff
Reference in New Issue
Block a user