pascal/kolmck
1
0
Fork 0
Code Issues Releases Activity

- del old modules

Browse Source 
* fix some warnings in D2009+ versions

git-svn-id: https://svn.code.sf.net/p/kolmck/code@145 91bb2d04-0c0c-4d2d-88a5-bbb6f4c1fa07
This commit is contained in:
dkolmck
2014-12-04 10:46:29 +00:00
parent 7e8e9d66ff
commit 0e80f52e2f
48 changed files with 4 additions and 14833 deletions
Download Patch File Download Diff File Expand all files Collapse all files

26
Addons/KOLAddons2006.dpk
View File

@ -1,11 +1,7 @@
package KOLAddons2006;
{$R *.res}
{$R 'MCKMonthCalendar.res'}
{$R 'mckCCtrls.dcr'}
{$R 'mckHTTPDownload.dcr'}
{$R 'mckQProgBar.dcr'}
{$R 'MCKMHIPEdit.dcr'}
{$ALIGN 8}
{$ASSERTIONS ON}
{$BOOLEVAL OFF}
@ -49,36 +45,16 @@ contains
KOLFontEditor in 'KOLFontEditor.pas',
KOLmhxp in 'KOLmhxp.pas',
MCKMHXP in 'MCKMHXP.pas',
mckTCPSocket in 'mckTCPSocket.pas',
mckListEdit in 'mckListEdit.pas',
kolTCPSocket in 'kolTCPSocket.pas',
mckCProgBar in 'mckCProgBar.pas',
mckRarInfoBar in 'mckRarInfoBar.pas',
mckRarProgBar in 'mckRarProgBar.pas',
mckEcmListEdit in 'mckEcmListEdit.pas',
KOLEcmListEdit in 'KOLEcmListEdit.pas',
mckBlockCipher in 'mckBlockCipher.pas',
KOLBlockCipher in 'KOLBlockCipher.pas',
MCKPrintDialogs in 'MCKPrintDialogs.pas',
MCKPageSetup in 'MCKPageSetup.pas',
KOLReport in 'KOLReport.pas',
MCKReport in 'MCKReport.pas',
KOLHTTPDownload in 'KOLHTTPDownload.pas',
mckHTTPDownload in 'mckHTTPDownload.pas',
KOLPageSetupDialog in 'KOLPageSetupDialog.pas',
KOLPrintCommon in 'KOLPrintCommon.pas',
KOLPrintDialogs in 'KOLPrintDialogs.pas',
KOLPrinters in 'KOLPrinters.pas',
mckXPMenus in 'mckXPMenus.pas',
XPMenus in 'XPMenus.pas',
tinyPNG in 'tinyPNG.pas',
tinyJPGGIFBMP in 'tinyJPGGIFBMP.pas',
mckWebBrowser in 'mckWebBrowser.pas',
mckDHTML in 'mckDHTML.pas',
KolZLibBzip in 'KolZLibBzip.pas',
KOLMHIPEdit in 'KOLMHIPEdit.pas',
MCKMHIPEdit in 'MCKMHIPEdit.pas',
MCKMonthCalendar in 'MCKMonthCalendar.pas',
KOLMonthCalendar in 'KOLMonthCalendar.pas';
KolZLibBzip in 'KolZLibBzip.pas';
end.

2
Addons/KOLCCtrls.pas
View File

@ -403,7 +403,7 @@ type
fDescription: string;
fFilter: string;
public
published
//published
property Full: string read fFull write fFull;
property Description: string read fDescription write fDescription;
property Filter: string read fFilter write fFilter;

1138
Addons/KOLHTTPDownload.pas
View File

File diff suppressed because it is too large Load Diff

209
Addons/KOLHttp.pas
View File

@ -1,209 +0,0 @@
unit KOLHttp;
interface
uses
Windows, KOL, KOLSocket;
type
TKOLhttp =^TKOLhttpControl;
PKOLhttpControl =^TKOLhttpControl;
TKOLhttpControl = object(TObj)
private
fAdr: string;
fUrl: string;
fRef: string;
fUsr: string;
fPas: string;
fMth: string;
fPAd: string;
fPPr: integer;
fCod: integer;
Body: boolean;
fHdr: PStrList;
fCnt: PStrList;
fSoc: PAsyncSocket;
fPort: integer;
fOnClos: TOnEvent;
procedure OnDumm(Sender: TWMSocket);
procedure OnConn(Sender: TWMSocket);
procedure OnRead(Sender: TWMSocket);
procedure OnClos(Sender: TWMSocket);
procedure Prepare;
protected
procedure ParseUrl;
public
procedure Get; overload;
procedure Get(_Url: string); overload;
property Url: string read fUrl write fUrl;
property HostPort: integer read fPort write fPort;
property HostAddr: string read fAdr write fAdr;
property UserName: string read fUsr write fUsr;
property Password: string read fPas write fPas;
property Responce: integer read fCod write fCod;
property Header: PStrList read fHdr;
property Content: PStrList read fCnt;
property ProxyAddr: string read fPAd write fPAd;
property ProxyPort: integer read fPPr write fPPr;
property OnClose: TOnEvent read fOnClos write fOnClos;
end;
function NewKOLhttpControl: PKOLhttpControl;
implementation
uses UStr, UWrd;
const
bin2b64:string='ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
function NewKOLhttpControl: PKOLhttpControl;
begin
New(Result, create);
Result.fPort := 80;
Result.fAdr := '';
Result.fUsr := '';
Result.fPas := '';
Result.fMth := 'GET';
Result.fHdr := NewStrList;
Result.fCnt := NewStrList;
end;
function encode_line(const buf: string):string;
var
offset: shortint;
pos1,pos2: byte;
i: byte;
out: string;
begin
setlength(out, length(buf) * 4 div 3 + 4);
fillchar(out[1], length(buf) * 4 div 3 + 2, #0);
offset:=2;
pos1:=0;
pos2:=1;
out[pos2]:=#0;
while pos1 < length(buf) do begin
if offset > 0 then begin
out[pos2]:=char(ord(out[pos2]) or ((ord(buf[pos1 + 1]) and ($3f shl offset)) shr offset));
offset:=offset-6;
inc(pos2);
out[pos2]:=#0;
end
else if offset < 0 then begin
offset:=abs(offset);
out[pos2]:=char(ord(out[pos2]) or ((ord(buf[pos1 + 1]) and ($3f shr offset)) shl offset));
offset:=8-offset;
inc(pos1);
end
else begin
out[pos2]:=char(ord(out[pos2]) or ((ord(buf[pos1 + 1]) and $3f)));
inc(pos2);
inc(pos1);
out[pos2]:=#0;
offset:=2;
end;
end;
if offset=2 then dec(pos2);
for i:=1 to pos2 do
out[i]:=bin2b64[ord(out[i])+1];
while (pos2 and 3)<>0 do begin
inc(pos2);
out[pos2] := '=';
end;
encode_line := copy(out, 1, pos2);
end;
procedure TKOLhttpControl.OnDumm;
begin
end;
procedure TKOLhttpControl.OnConn;
begin
fHdr.Clear;
fCnt.Clear;
fSoc.SendString(fMth + ' ' + fRef + ' HTTP/1.1'#13#10);
fSoc.SendString('User-Agent: KOL-HTTP'#13#10);
fSoc.SendString('Host: ' + fAdr + #13#10);
if fUsr <> '' then begin
fSoc.SendString('Authorization: Basic ' + encode_line(fUsr + ':' + fPas) + #13#10);
end;
fSoc.SendString(#13#10);
end;
procedure TKOLhttpControl.OnRead;
var s: string;
begin
while fSoc.Count > 0 do begin
s := Wordn(fSoc.ReadLine(#10), #13, 1);
if pos('<', s) = 1 then Body := True;
if Body then fCnt.Add(s)
else fHdr.Add(s);
if pos('HTTP/1.', s) = 1 then fCod := str2int(wordn(s, ' ', 2));
end;
if Assigned(fOnClos) then fOnClos(@self);
end;
procedure TKOLhttpControl.OnClos;
begin
if Assigned(fOnClos) then fOnClos(@self);
end;
procedure TKOLhttpControl.ParseUrl;
var s,
r: string;
begin
s := Url;
if pos('HTTP://', UpSt(s)) = 1 then begin
s := copy(s, 8, length(s) - 7);
end;
r := wordn(s, '@', 1);
if r <> s then begin
fUsr := wordn(r, ':', 1);
fPas := wordn(r, ':', 2);
s := wordn(s, '@', 2);
end;
r := wordn(s, ':', 2);
if r <> '' then begin
fPort := str2int(r);
s := wordn(s, ':', 1);
end;
r := wordn(s, '/', 1);
fAdr := r;
if fAdr = '' then fAdr := s;
fRef := copy(s, length(fAdr) + 1, length(s) - length(fAdr));
if fRef = '' then fRef := '/';
end;
procedure TKOLhttpControl.Prepare;
begin
Body := False;
fSoc := NewAsyncSocket;
ParseUrl;
fSoc.PortNumber := fPort;
fSoc.IPAddress := fAdr;
if fPAd <> '' then begin
fSoc.IPAddress := fPAd;
fSoc.PortNumber := fPPr;
fRef := 'http://' + fAdr + fRef;
end;
fSoc.OnConnect := OnConn;
fSoc.OnRead := OnRead;
fSoc.OnError := OnDumm;
fSoc.OnClose := OnClos;
end;
procedure TKOLhttpControl.Get;
begin
Prepare;
fMth := 'GET';
fSoc.DoConnect;
end;
procedure TKOLhttpControl.Get(_Url: string);
begin
Url := _Url;
Get;
end;
end.

937
Addons/KOLMHToolTip.pas
View File

@ -1,937 +0,0 @@
//{$DEFINE DEBUG}
{$IFDEF DEBUG}
{$DEFINE interface}
{$DEFINE implementation}
{$DEFINE initialization}
{$DEFINE finalization}
{$ENDIF}
{$IFDEF Frame}
unit KOLMHToolTip;
// 8-jan-2003
// MHDateTimePicker ��������� (MHDateTimePicker Component)
// ����� (Author): ����� ������� (Zharov Dmitry) aka �������� (Gandalf)
// ���� �������� (Create date): 1-���(aug)-2002
// ���� ��������� (Last correction Date): 13-���(sep)-2002
// ������ (Version): 0.91
// EMail: Gandalf@kol.mastak.ru
// ������������� (Thanks):
// Alexander Pravdin
// ����� � (New in):
// V0.91
// [+] ��������� D6 (D6 Support) <Thanks to Alexander Pravdin> [KOLnMCK]
//
// V0.9
// [+++] ����� ����� (Very much) [KOLnMCK]
// [N] KOLnMCK>=1.42
//
// ������ ��� (To-Do list):
// 1. ��������� (Asm)
// 2. �������������� (Optimize)
// 3. ��������� ������ (Styles)
// 4. ��������� (Draw)
// 5. ���������� (Clear Stuff)
// 6. ������� (Events)
// 7. ��� API (All API's)
interface
uses Windows, KOL, Messages;
type
{$ENDIF Frame}
{$IFDEF interface_part}
TFE = (eTextColor, eBkColor, eAPDelay, eRDelay, eIDelay);
TFI = record
FE: set of TFE;
Colors: array[0..1] of TColor;
Delays: array[0..3] of Integer;
end;
PMHToolTipManager = ^TMHToolTipManager;
TKOLMHToolTipManager = PMHToolTipManager;
PMHToolTip = ^TMHToolTip;
TKOLMHToolTip = PMHToolTip;
{$ENDIF interface_part}
{$IFDEF pre_interface}
PMHHint = ^TMHHint;
TKOLMHHint = PMHHint;
{$ENDIF pre_interface}
{$IFDEF interface_part}
TMHToolTipManager = object(TObj)
protected
destructor Destroy; virtual;
public
TTT: array of PMHToolTip;
function AddTip: Integer;
function FindNeed(FI: TFI): PMHToolTip;
function CreateNeed(FI: TFI): PMHToolTip;
end;
//P_MHHint = ^TMHHint;
TMHHint = object(TObj)
private
function GetManager:PMHToolTipManager;
// Spec
procedure ProcBegin(var TI: TToolInfo);
procedure ProcEnd(var TI: TToolInfo);
procedure ReConnect(FI: TFI);
procedure MoveTool(T1: PMHToolTip);
procedure CreateToolTip;
function GetFI: TFI;
// Group
function GetDelay(const Index: Integer): Integer;
procedure SetDelay(const Index: Integer; const Value: Integer);
function GetColor(const Index: Integer): TColor;
procedure SetColor(const Index: Integer; const Value: TColor);
// Local
procedure SetText(Value: KOLString);
function GetText: KOLString;
public
ToolTip: PMHToolTip;
HasTool: Boolean;
Parent: PControl;
destructor Destroy; virtual;
procedure Pop;
procedure Popup;
property AutoPopDelay: Integer index 2 read GetDelay write SetDelay;
property InitialDelay: Integer index 3 read GetDelay write SetDelay;
property ReshowDelay: Integer index 1 read GetDelay write SetDelay;
property TextColor: TColor index 1 read GetColor write SetColor;
property BkColor: TColor index 0 read GetColor write SetColor;
property Text: KOLString read GetText write SetText;
end;
TMHToolTip = object(TObj)
private
fHandle: THandle;
Count: Integer;
function GetDelay(const Index: Integer): Integer;
procedure SetDelay(const Index: Integer; const Value: Integer);
function GetColor(const Index: Integer): TColor;
procedure SetColor(const Index: Integer; const Value: TColor);
function GetMaxWidth: Integer;
procedure SetMaxWidth(const Value: Integer);
function GetMargin: TRect;
procedure SetMargin(const Value: TRect);
function GetActivate: Boolean;
procedure SetActivate(const Value: Boolean);
// function GetText: string;
// procedure SetText(const Value: string);
// function GetToolCount: Integer;
// function GetTool(Index: Integer): TToolInfo;
protected
public
destructor Destroy; virtual;
procedure Pop;
procedure Popup;
procedure Update;
// function GetInfo: TToolInfo; // Hide in Info
// procedure SetInfo(Value: TToolInfo);
// handle:Thandle;
// procedure SetC(C: PControl);
// procedure SetI(C: PControl; S: string);
// procedure Add(Value: TToolInfo);
// procedure Delete(Value: TToolInfo);
// function Connect(Value: PControl): Integer;
// property OnCloseUp: TOnEvent read GetOnDropDown write SetOnDropDown;
property AutoPopDelay: Integer index 2 read GetDelay write SetDelay;
property InitialDelay: Integer index 3 read GetDelay write SetDelay;
property ReshowDelay: Integer index 1 read GetDelay write SetDelay;
property TextColor: TColor index 1 read GetColor write SetColor;
property BkColor: TColor index 0 read GetColor write SetColor;
property MaxWidth: Integer read GetMaxWidth write SetMaxWidth;
property Margin: TRect read GetMargin write SetMargin;
property Activate: Boolean read GetActivate write SetActivate;
property Handle: THandle read fHandle;
// property Text: string read GetText write SetText;
// property ToolCount: Integer read GetToolCount;
// property Tools[Index: Integer]: TToolInfo read GetTool;
end;
const
Dummy = 0;
function NewHint(A: PControl): PMHHint;
function NewManager: PMHToolTipManager;
function NewMHToolTip(AParent: PControl): PMHToolTip;
var
Manager: PMHToolTipManager;
{$ENDIF interface_part}
{$IFDEF Frame}
implementation
{$ENDIF Frame}
{$IFDEF implementation}
const
Dummy1 = 1;
TTDT_AUTOMATIC = 0;
TTDT_RESHOW = 1;
TTDT_AUTOPOP = 2;
TTDT_INITIAL = 3;
//function WndProcMHDateTimePicker(Sender: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
{begin
Result := False;}
//end;
function NewMHToolTip(AParent: PControl): PMHToolTip;
//var
// Data: PDateTimePickerData;
// T: TWndClassEx;
//var a: integer;
const
CS_DROPSHADOW = $00020000;
begin
DoInitCommonControls(ICC_BAR_CLASSES);
New(Result, Create);
Result.fHandle := CreateWindowEx(WS_EX_TOPMOST, TOOLTIPS_CLASS, '', 0, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, AParent.GetWindowHandle, 0, HInstance, nil);
// SetClassLong(Result.handle,GCL_STYLE,CS_DROPSHADOW);
// Result := PMHToolTip(_NewControl(AParent, TOOLTIPS_CLASS, 0, False, 0)); //PMHToolTip(_NewCommonControl(AParent,TOOLTIPS_CLASS, 0{TTS_ALWAYSTIP}{WS_CHILD or WS_VISIBLE},False,0));
// Result.Style:=0;
// Result.ExStyle:=0;
// GetMem(Data,Sizeof(Data^));
// FillChar(Data^,Sizeof(Data^),0);
// a:=SetClassLong(Result.Handle,GCL_STYLE,CS_DROPSHADOW);
// ShowMessage(Int2Str(a));
// Result.CustomData:=Data;
{ T.cbSize:=SizeOf(T);
GetClassInfoEx(hInstance,TOOLTIPS_CLASS,T);
T.style:=T.style or CS_DROPSHADOW;
T.hInstance:=hInstance;
T.lpszClassName:='ZharovHint';
a:=RegisterClassEx(T);
ShowMessage(Int2Str(a)); }
// Result.handle := CreateWindowEx(0, {'ZharovHint'} TOOLTIPS_CLASS, '', 0 {orCS_DROPSHADOW or WS_POPUP or WS_BORDER or CS_SAVEBITS or WS_CHILD or WS_CLIPSIBLINGS}, CW_USEDEFAULT, CW_USEDEFAULT,
// CW_USEDEFAULT, CW_USEDEFAULT, AParent.Handle, 0, HInstance, nil);
// Data.ttt:=CreateWindowEx (CS_IMEWS_EX_TOOLWINDOW or WS_EX_CONTROLPARENT{ or CS_SAVEBITS or WS_POPUP or WS_BORDER}{65536},{'ZharovHint'}TOOLTIPS_CLASS,'',{WS_CHILD or}{ WS_VISIBLE}{100663296}{WS_EX_TOOLWINDOW}CS_DROPSHADOW or WS_POPUP or WS_BORDER or CS_SAVEBITS or WS_CHILD or WS_CLIPSIBLINGS,CW_USEDEFAULT,CW_USEDEFAULT,
// CW_USEDEFAULT,CW_USEDEFAULT,AParent.Handle,0,HInstance,NIL);
// SetClassLong(Data.ttt,GCL_STYLE,CS_DROPSHADOW);
// SendMessage (Data.ttt,TTM_SETDELAYTIME,TTDT_INITIAL,5);
// SendMessage (Data.ttt,TTM_SETDELAYTIME,TTDT_RESHOW,20);
// SendMessage (Result.handle,TTM_SETDELAYTIME,TTDT_AUTOPOP,2000);
// Result.CreateWindow;
// Result.Parent := AParent;
// Result.Perform(TTM_SETTIPTEXTCOLOR,clRed,0);
// SendMessage (Result.handle,TTM_SETTIPTEXTCOLOR,clBlue,0);
// SendMessage (Result.handle,TTM_SETTIPTEXTCOLOR,clRed,0);
// Result.Color:=clRed;
// Result.Font.Color:=clRed;
// Data.FCalColors:=NewMonthCalColors(Result);
// Data.FOnDropDown:=nil;
// Result.AttachProc(WndProcMHDateTimePicker);
// Result.AttachProc(WndProcMHDateTimePicker);
end;
{procedure TMHToolTip.SetC(C: PControl);
var
TI: TToolInfo;
R: Trect;
// Data:PDateTimePickerData;
begin
R := C.ClientRect;
// Control:= C.Handle;
with TI do
begin
cbSize := SizeOf(TI);
uFlags := TTF_SUBCLASS; // or TTF_IDISHWND;
hWnd := C.GetWindowHandle; //Control;
uId := 0;
rect.Left := R.Left;
rect.Top := R.Top;
rect.Right := R.Right;
rect.Bottom := R.Bottom;
hInst := 0;
lpszText := Pchar('I am ' + C.Caption);
end;
PostMessage(handle, TTM_ADDTOOL, 0, DWORD(@TI));
// Perform(TTM_ADDTOOL, 0, DWord(@TI));
end; }
function TMHToolTip.GetDelay(const Index: Integer): Integer;
begin
Result := SendMessage(fHandle, TTM_GETDELAYTIME, Index, 0);
end;
procedure TMHToolTip.SetDelay(const Index, Value: Integer);
begin
SendMessage(handle, TTM_SETDELAYTIME, Index, MAKELONG(Value, 0));
end;
function TMHToolTip.GetColor(const Index: Integer): TColor;
begin
Result := SendMessage(handle, TTM_GETTIPBKCOLOR + Index, 0, 0);
end;
procedure TMHToolTip.SetColor(const Index: Integer; const Value: TColor);
begin
SendMessage(handle, TTM_SETTIPBKCOLOR + Index, Value, 0);
end;
function TMHToolTip.GetMaxWidth: Integer;
begin
Result := SendMessage(fHandle, TTM_GETMAXTIPWIDTH, 0, 0);
end;
procedure TMHToolTip.SetMaxWidth(const Value: Integer);
begin
SendMessage(fHandle, TTM_SETMAXTIPWIDTH, 0, Value);
end;
{procedure TMHToolTip.SetI(C: PControl; S: string);
var
TI: TToolInfo;
R: Trect;
// Data:PDateTimePickerData;
begin
R := C.ClientRect;
// Control:= C.Handle;
with TI do
begin
cbSize := SizeOf(TI);
uFlags := TTF_SUBCLASS;
hWnd := C.GetWindowHandle; //Control;
uId := 0;
rect.Left := R.Left;
rect.Top := R.Top;
rect.Right := R.Right;
rect.Bottom := R.Bottom;
hInst := 0;
lpszText := PChar(S);
end;
// PostMessage (handle,TTM_ADDTOOL,0,DWORD (@TI));
// Perform(TTM_SETTOOLINFO, 0, DWord(@TI));
end; }
function TMHToolTip.GetMargin: TRect;
begin
SendMessage(fHandle, TTM_GETMARGIN, 0, DWord(@Result));
end;
procedure TMHToolTip.SetMargin(const Value: TRect);
begin
SendMessage(fHandle, TTM_SETMARGIN, 0, DWord(@Value));
end;
function TMHToolTip.GetActivate: Boolean;
begin
// ??????
Result := False;
end;
procedure TMHToolTip.SetActivate(const Value: Boolean);
begin
SendMessage(fHandle, TTM_ACTIVATE, DWord(Value), 0);
end;
procedure TMHToolTip.Pop;
begin
SendMessage(fHandle, TTM_POP, 0, 0);
end;
procedure TMHToolTip.Popup;
begin
SendMessage(fHandle, $0422 {TTM_POPUP}, 0, 0);
end;
{function TMHToolTip.GetText: string;
begin
end;
procedure TMHToolTip.SetText(const Value: string);
var
TI: TToolInfo;
begin
TI := GetInfo;
TI.lpszText := PChar(Value);
SetInfo(TI);
end; }
{function TMHToolTip.GetInfo: TToolInfo;
begin
with Result do
begin
// ????
FillChar(Result, SizeOf(Result), 0);
cbSize := SizeOf(Result);
// hWnd := Parent.GetWindowHandle;
uId := 0;
end;
// Perform(TTM_GETTOOLINFO, 0, DWord(@Result));
end;
procedure TMHToolTip.SetInfo(Value: TToolInfo);
begin
// Perform(TTM_SETTOOLINFO, 0, DWord(@Value));
end;}
{function TMHToolTip.GetToolCount: Integer;
begin
// Result := Perform(TTM_GETTOOLCOUNT, 0, 0);
end;
function TMHToolTip.GetTool(Index: Integer): TToolInfo;
begin
FillChar(Result, SizeOf(Result), 0); // ????
Result.cbSize := SizeOf(Result);
// Perform(TTM_ENUMTOOLS, Index, DWord(@Result));
end; }
{procedure TMHToolTip.Add(Value: TToolInfo);
begin
// Perform(TTM_ADDTOOL, 0, DWord(@Value));
end;}
{procedure TMHToolTip.Delete(Value: TToolInfo);
begin
// Perform(TTM_DELTOOL, 0, DWord(@Value));
end;}
procedure TMHToolTip.Update;
begin
inherited; // ???
SendMessage(fHandle, TTM_UPDATE, 0, 0);
end;
function NewHint(A: PControl): PMHHint;
begin
New(Result, Create);
with Result^ do
begin
Parent := A;
ToolTip := nil; // ???
HasTool := False; // ???
end;
A.Add2AutoFree(Result);
end;
function NewManager: PMHToolTipManager;
begin
New(Result, Create);
end;
{ TMHHint }
function TMHHint.GetDelay(const Index: Integer): Integer;
begin
// CreateToolTip;
Result := 0;
if Assigned(ToolTip) then
Result := ToolTip.GetDelay(Index);
end;
function TMHHint.GetFI: TFI;
begin
/// !!! DANGER-WITH !!!
with Result, ToolTip^ do
begin
FE := FE + [eTextColor];
Colors[1] := TextColor;
FE := FE + [eBkColor];
Colors[0] := BkColor;
FE := FE + [eAPDelay];
Delays[TTDT_AUTOPOP] := AutoPopDelay;
FE := FE + [eRDelay];
Delays[TTDT_RESHOW] := ReshowDelay;
FE := FE + [eIDelay];
Delays[TTDT_INITIAL] := InitialDelay;
end;
end;
procedure TMHHint.ReConnect(FI: TFI);
var
TMP: PMHToolTip;
begin
with GetManager^ do
begin
TMP := FindNeed(FI);
if not Assigned(TMP) then
TMP := CreateNeed(FI);
if Assigned(ToolTip) and HasTool then
MoveTool(TMP);
ToolTip := TMP;
end;
end;
procedure TMHHint.MoveTool(T1: PMHToolTip);
var
TI: TToolInfo;
TextL: array[0..255] of KOLChar;
begin
if T1 = ToolTip then
Exit;
with TI do
begin
cbSize := SizeOf(TI);
hWnd := Parent.GetWindowHandle;
uId := Parent.GetWindowHandle;
lpszText := @TextL[0];
end;
SendMessage(ToolTip.handle, TTM_GETTOOLINFO, 0, DWord(@TI));
SendMessage(ToolTip.handle, TTM_DELTOOL, 0, DWORD(@TI));
ToolTip.Count := ToolTip.Count - 1;
SendMessage(T1.handle, TTM_ADDTOOL, 0, DWORD(@TI));
T1.Count := T1.Count - 1;
HasTool := True;
end;
procedure TMHHint.SetColor(const Index: Integer; const Value: TColor);
var
FI: TFI;
begin
if Assigned(ToolTip) then
begin
if ToolTip.Count + Byte(not HasTool) = 1 then
begin
ToolTip.SetColor(Index, Value);
Exit;
end;
FI := GetFI;
end;
case Index of
0: FI.FE := FI.FE + [eBkColor];
1: FI.FE := FI.FE + [eTextColor];
end;
FI.Colors[Index] := Value;
ReConnect(FI);
end;
function TMHHint.GetColor(const Index: Integer): TColor;
begin
Result := 0;
if Assigned(ToolTip) then
Result := ToolTip.GetColor(Index);
end;
procedure TMHHint.SetDelay(const Index, Value: Integer);
var
FI: TFI;
begin
if Assigned(ToolTip) then
begin
if ToolTip.Count + Byte(not HasTool) = 1 then
begin
ToolTip.SetDelay(Index, Value);
Exit;
end;
FI := GetFI;
end;
case Index of
TTDT_AUTOPOP: FI.FE := FI.FE + [eAPDelay]; // Spec
TTDT_INITIAL: FI.FE := FI.FE + [eIDelay]; // Spec
TTDT_RESHOW: FI.FE := FI.FE + [eRDelay]; // Spec
end; //case
FI.Delays[Index] := Value; //Spec
ReConnect(FI);
end;
procedure TMHHint.SetText(Value: KOLString);
var
TI: TToolInfo;
begin
ProcBegin(TI);
with TI do
begin
uFlags := TTF_SUBCLASS or TTF_IDISHWND; // Spec
lpszText := PKOLChar(Value); // Spec
end;
procEnd(TI);
if HasTool then
begin
TI.lpszText := PKOLChar(Value);
SendMessage(ToolTip.handle, TTM_SETTOOLINFO, 0, DWord(@TI));
end;
end;
(*
procedure TMHHint.SetText(Value: string);
var
TI: TToolInfo;
R: Trect;
TextLine: array[0..255] of Char;
begin
if not Assigned(ToolTip) then
begin
if Length(Manager.TTT) = 0 then
Manager.AddTip;
ToolTip := Manager.TTT[0];
end;
with TI do
begin
cbSize := SizeOf(TI);
hWnd := Parent.GetWindowHandle;
uId := Parent.GetWindowHandle;
hInst := 0;
end;
if not HasTool {TTool = -1} then
begin
R := Parent.ClientRect;
// Control:= C.Handle;
with TI do
begin
// cbSize := SizeOf(TI);
uFlags := TTF_SUBCLASS;
// hWnd := Parent.GetWindowHandle; //Control;
// uId := Parent.GetWindowHandle;
rect.Left := R.Left;
rect.Top := R.Top;
rect.Right := R.Right;
rect.Bottom := R.Bottom;
// hInst := 0;
lpszText := PChar(Value);
end;
SendMessage({Manager.TTT[TTip]} ToolTip.handle, TTM_ADDTOOL, 0, DWORD(@TI));
HasTool := True;
// TTool := 0;
ToolTip {Manager.TTT[TTip]}.Count := ToolTip {Manager.TTT[TTip]}.Count + 1;
end
else
begin
with TI do
begin
// ????
// FillChar(TI, SizeOf(TI), 0);
// cbSize := SizeOf(TI);
// hWnd := Parent.GetWindowHandle;
// uId := Parent.GetWindowHandle;
lpszText := @TextLine; //PChar(S);
end;
SendMessage(ToolTip {Manager.TTT[TTip]}.handle, TTM_GETTOOLINFO, 0, DWord(@TI));
TI.lpszText := PChar(Value);
// Perform(TTM_GETTOOLINFO, 0, DWord(@Result));
SendMessage(ToolTip {Manager.TTT[TTip]}.handle, TTM_SETTOOLINFO, 0, DWord(@TI));
end;
// Manager.TTT[TTip].Tool[TTool].SSSetText(Value);
end;
*)
{ TMHToolTipManager }
{function TMHToolTipManager.AddColor(C: TColor): Integer;
begin
SetLength(TTT, Length(TTT) + 1);
TTT[Length(TTT) - 1] := NewMHToolTip(Applet);
TTT[Length(TTT) - 1].SetColor(1, C);
Result := Length(TTT) - 1;
end; }
function TMHToolTipManager.AddTip: Integer;
begin
SetLength(TTT, Length(TTT) + 1);
TTT[Length(TTT) - 1] := NewMHToolTip(Applet);
Result := Length(TTT) - 1;
end;
{function TMHToolTip.Connect(Value: PControl): Integer;
var
TI: TToolInfo;
R: Trect;
// Data:PDateTimePickerData;
begin
R := Value.ClientRect;
// Control:= C.Handle;
with TI do
begin
cbSize := SizeOf(TI);
uFlags := TTF_SUBCLASS;
hWnd := Value.GetWindowHandle; //Control;
uId := Value.GetWindowHandle;
rect.Left := R.Left;
rect.Top := R.Top;
rect.Right := R.Right;
rect.Bottom := R.Bottom;
hInst := 0;
lpszText := PChar('Super');
end;
PostMessage(handle, TTM_ADDTOOL, 0, DWORD(@TI));
// Perform(TTM_ADDTOOL, 0, DWord(@TI));
end;}
{function TMHToolTipManager.FindTip(N: Integer): Integer;
begin
Result := -1;
end;}
function TMHToolTipManager.FindNeed(FI: TFI): PMHToolTip;
var
i: Integer;
begin
Result := nil;
for i := 0 to length(TTT) - 1 do
begin
if ((eTextColor in FI.FE) and (not (FI.Colors[1] = TTT[i].TextColor))) or
((eBkColor in FI.FE) and (not (FI.Colors[0] = TTT[i].BkColor))) or
((eAPDelay in FI.FE) and (not (FI.Delays[TTDT_AUTOPOP] = TTT[i].AutoPopDelay))) or
((eIDelay in FI.FE) and (not (FI.Delays[TTDT_INITIAL] = TTT[i].InitialDelay))) or
((eRDelay in FI.FE) and (not (FI.Delays[TTDT_RESHOW] = TTT[i].ReshowDelay))) then
Continue;
Result := TTT[i];
Break;
end;
end;
function TMHToolTipManager.CreateNeed(FI: TFI): PMHToolTip;
begin
Setlength(TTT, length(TTT) + 1);
TTT[length(TTT) - 1] := NewMHToolTip(Applet);
with TTT[length(TTT) - 1]^ do
begin
if (eTextColor in FI.FE) then
TextColor := FI.Colors[1];
if (eBkColor in FI.FE) then
BkColor := FI.Colors[0];
if (eAPDelay in FI.FE) then
AutoPopDelay := FI.Delays[TTDT_AUTOPOP];
if (eIDelay in FI.FE) then
InitialDelay := FI.Delays[TTDT_INITIAL];
if (eRDelay in FI.FE) then
ReshowDelay := FI.Delays[TTDT_RESHOW];
end;
Result := TTT[length(TTT) - 1];
end;
procedure TMHHint.ProcBegin(var TI: TToolInfo);
begin
CreateToolTip;
with TI do
begin
cbSize := SizeOf(TI);
hWnd := Parent.GetWindowHandle;
uId := Parent.GetWindowHandle;
hInst := 0;
end;
end;
procedure TMHHint.ProcEnd(var TI: TToolInfo);
var
TextLine: array[0..255] of KOLChar;
begin
if not HasTool then
begin
SendMessage(ToolTip.handle, TTM_ADDTOOL, 0, DWORD(@TI));
HasTool := True;
ToolTip.Count := ToolTip.Count + 1;
end
else
begin
with TI do
begin
lpszText := @TextLine[0];
end;
SendMessage(ToolTip.handle, TTM_SETTOOLINFO, 0, DWord(@TI));
end;
end;
destructor TMHToolTipManager.Destroy;
var
i: Integer;
begin
for i := 0 to Length(TTT) - 1 do
TTT[i].Free;
SetLength(TTT, 0);
inherited;
end;
procedure TMHHint.Pop;
begin
if Assigned(ToolTip) and (HasTool) then
begin // ^^^^^^^^^^^^ ???
// CreateToolTip;
ToolTip.Pop;
end;
end;
procedure TMHHint.Popup;
begin
if Assigned(ToolTip) and (HasTool) then
begin // ^^^^^^^^^^^^ ???
// CreateToolTip;
ToolTip.Popup;
end;
end;
destructor TMHHint.Destroy;
var
TI: TToolInfo;
i: integer;
begin
with TI do
begin
cbSize := SizeOf(TI);
hWnd := Parent.GetWindowHandle;
uId := Parent.GetWindowHandle;
end;
SendMessage(ToolTip.handle, TTM_DELTOOL, 0, DWORD(@TI));
ToolTip.Count := ToolTip.Count - 1;
if ToolTip.Count <= 0 then begin
i:=Length(Manager.TTT);
if i > 1 then begin
Manager.TTT[i - 1].Free;
SetLength(Manager.TTT, i - 1);
end
else
Free_And_Nil(Manager);
end;
inherited;
end;
destructor TMHToolTip.Destroy;
begin
inherited;
end;
procedure TMHHint.CreateToolTip;
begin
if not Assigned(ToolTip) then
begin
if Length(GetManager.TTT) = 0 then
GetManager.AddTip;
ToolTip := GetManager.TTT[0];
end;
end;
function TMHHint.GetText: KOLString;
var
TI: TToolInfo;
TextL: array[0..255] of KOLChar;
begin
if Assigned(ToolTip) and (HasTool) then
begin
// !!!
with TI do
begin
// ????
// FillChar(TI, SizeOf(TI), 0);
cbSize := SizeOf(TI);
hWnd := Parent.GetWindowHandle;
uId := Parent.GetWindowHandle;
lpszText := @TextL[0];
end;
SendMessage(ToolTip.handle, TTM_GETTOOLINFO, 0, DWord(@TI));
Result := TextL; //TI.lpszText;// := PChar(Value);
end;
end;
function TMHHint.GetManager: PMHToolTipManager;
begin
if Manager=nil then
Manager:=NewManager;
Result:=Manager;
end;
{$ENDIF implementation}
{$IFDEF Frame}
initialization
{$ENDIF Frame}
{$IFDEF initialization}
Manager := NewManager;
{$ENDIF initialization}
{$IFDEF Frame}
finalization
{$ENDIF Frame}
{$IFDEF finalization}
// Manager.Free;
{$ENDIF finalization}
{$IFDEF Frame}
end.
{$ENDIF Frame}
{$IFDEF function}
function GetHint: PMHHint;
{$ENDIF function}
{$IFDEF public}
property Hint: PMHHint read GetHint;
{$ENDIF public}
{$IFDEF code}
function TControl.GetHint: PMHHint;
begin
if fHint = nil then
fHint := NewHint(@Self);
Result := fHint;
end;
{$ENDIF code}
{$IFDEF MHdestroy}
fHint.Free;
{$ENDIF MHdestroy}
{$IFDEF var}
fHint: PMHHint;
{$ENDIF var}

409
Addons/KOLPageSetupDialog.pas
View File

@ -1,409 +0,0 @@
unit KOLPageSetupDialog;
{* Page setup dialog.
|<br>
Ver 1.4
|<br>
Now the information about selected printer can be transferred to TKOLPrinter.
If DC is needed directly use new psdReturnDC option.
|<br>
Note :page setup dialog replace print dialog marked as obsolete by Microsoft.
|<br> Bad news is that this dialog do not return printer DC. In TKOLPageSetupDialog
DC is constructed from returned values, but margins should be processed by application.
(or assigned to TKOLPrinter ;-) 17-09-2002 B.Brandys)
|<br>
Note:
|<br>
- when custom page is selected ,DC is empty (bug?)
|<br>
- application must process margins (but it is simple as AssignMargins to TKOlPrinter ;-)
}
interface
uses Windows, Messages, KOL, KOLPrintCommon;
const
DN_DEFAULTPRN = $0001; {default printer }
HELPMSGSTRING = 'commdlg_help';
//******************************************************************************
// PageSetupDlg options
//******************************************************************************
PSD_DEFAULTMINMARGINS = $00000000;
PSD_INWININIINTLMEASURE = $00000000;
PSD_MINMARGINS = $00000001;
PSD_MARGINS = $00000002;
PSD_INTHOUSANDTHSOFINCHES = $00000004;
PSD_INHUNDREDTHSOFMILLIMETERS = $00000008;
PSD_DISABLEMARGINS = $00000010;
PSD_DISABLEPRINTER = $00000020;
PSD_NOWARNING = $00000080;
PSD_DISABLEORIENTATION = $00000100;
PSD_RETURNDEFAULT = $00000400;
PSD_DISABLEPAPER = $00000200;
PSD_SHOWHELP = $00000800;
PSD_ENABLEPAGESETUPHOOK = $00002000;
PSD_ENABLEPAGESETUPTEMPLATE = $00008000;
PSD_ENABLEPAGESETUPTEMPLATEHANDLE = $00020000;
PSD_ENABLEPAGEPAINTHOOK = $00040000;
PSD_DISABLEPAGEPAINTING = $00080000;
PSD_NONETWORKBUTTON = $00200000;
//******************************************************************************
// Error constants
//******************************************************************************
CDERR_DIALOGFAILURE = $FFFF;
CDERR_GENERALCODES = $0000;
CDERR_STRUCTSIZE = $0001;
CDERR_INITIALIZATION = $0002;
CDERR_NOTEMPLATE = $0003;
CDERR_NOHINSTANCE = $0004;
CDERR_LOADSTRFAILURE = $0005;
CDERR_FINDRESFAILURE = $0006;
CDERR_LOADRESFAILURE = $0007;
CDERR_LOCKRESFAILURE = $0008;
CDERR_MEMALLOCFAILURE = $0009;
CDERR_MEMLOCKFAILURE = $000A;
CDERR_NOHOOK = $000B;
CDERR_REGISTERMSGFAIL = $000C;
PDERR_PRINTERCODES = $1000;
PDERR_SETUPFAILURE = $1001;
PDERR_PARSEFAILURE = $1002;
PDERR_RETDEFFAILURE = $1003;
PDERR_LOADDRVFAILURE = $1004;
PDERR_GETDEVMODEFAIL = $1005;
PDERR_INITFAILURE = $1006;
PDERR_NODEVICES = $1007;
PDERR_NODEFAULTPRN = $1008;
PDERR_DNDMMISMATCH = $1009;
PDERR_CREATEICFAILURE = $100A;
PDERR_PRINTERNOTFOUND = $100B;
PDERR_DEFAULTDIFFERENT = $100C;
type
{ Structure for PageSetupDlg function }
PtagPSD = ^tagPSD;
tagPSD = packed record
{* Structure for PageSetupDlg function }
lStructSize: DWORD;
hwndOwner: HWND;
hDevMode: HGLOBAL;
hDevNames: HGLOBAL;
Flags: DWORD;
ptPaperSize: TPoint;
rtMinMargin: TRect;
rtMargin: TRect;
hInstance: HINST;
lCustData: LPARAM;
lpfnPageSetupHook: function(Wnd: HWND; Message: UINT; wParam: WPARAM; lParam: LPARAM): UINT stdcall;
lpfnPagePaintHook: function(Wnd: HWND; Message: UINT; wParam: WPARAM; lParam: LPARAM): UINT stdcall;
lpPageSetupTemplateName: PAnsiChar;
hPageSetupTemplate: HGLOBAL;
end;
function PageSetupDlg(var PgSetupDialog: tagPSD): BOOL; stdcall;external 'comdlg32.dll'
name {$IFDEF UNICODE_CTRLS} 'PageSetupDlgW' {$ELSE} 'PageSetupDlgA' {$ENDIF};
function CommDlgExtendedError():DWORD;stdcall; external 'comdlg32.dll'
name 'CommDlgExtendedError';
//////////////////////////////////////////////////////
// //
// Page setup dialog. //
// //
//////////////////////////////////////////////////////
type
TPageSetupOption = (psdMargins,psdOrientation,psdSamplePage,psdPaperControl,psdPrinterControl,
psdHundredthsOfMillimeters,psdThousandthsOfInches,psdUseMargins,psdUseMinMargins,psdWarning,psdHelp,psdReturnDC);
TPageSetupOptions = Set of TPageSetupOption;
{* Options:
|<br>
|<ul><li><b>psdMargins</b> : allow user to select margins </li>
|<li><b>psdOrientation</b> : allow user to select page orientation</li>
|<li><b>psdSamplePage</b> : draw contents of the sample page</li>
|<li><b>psdPaperControl</b> : allow paper size control </li>
|<li><b>psdPrinterControl</b> : allow user to select printer </li>
|<li><b>psdHundredthsOfMillimeters</b> : set scale to hundredths of millimeters for margins and paper size,on return indicate selected scale</li>
|<li><b>psdThousandthsOfInches</b> : set scale to thousandths of inches for margins and paper size,on return indicate selected scale</li>
|<li><b>psdUseMargins,psdUseMinMargins</b> : use suggested margins </li>
|<li><b>psdWarning</b> : generate warning when there is no default printer </li>
|<li><b>psdHelp</b> : add help button to dialog, application must process HELPMSGSTRING message</li>
|<li><b>psdReturnDC</b> : returns DC of selected printer if required </li>
|</ul>
}
PPageSetupDlg = ^TPageSetupDlg;
TKOLPageSetupDialog = PPageSetupDlg;
TPageSetupDlg = object(TObj)
{*}
private
{ Private declarations }
fhDC : HDC;
fAdvanced : WORD;
ftagPSD : tagPSD;
fOptions : TPageSetupOptions;
fDevNames : PDevNames;
PrinterInfo : TPrinterInfo;
protected
function GetError : Integer;
{*}
{ Protected declarations }
public
{ Public declarations }
destructor Destroy; virtual;
property Error : Integer read GetError;
{* Returns extended error (which is not the same as error returned from GetLastError)
|<br>
Note : if You want error descriptions each error is defined in this file source
}
function GetPaperSize : TPoint;
{*}
procedure SetMinMargins(Left,Top,Right,Bottom: Integer);
{*}
function GetMinMargins : TRect;
{*}
procedure SetMargins(Left,Top,Right,Bottom : Integer);
{*}
function GetMargins : TRect;
{*}
property Options : TPageSetupOptions read fOptions write fOptions;
{* Set of dialog options}
property DC : hDC read fhDC;
{*}
function Execute : Boolean;
{*}
function Info : PPrinterInfo;
{* Return info about selected printer.Can be used by TKOLPrinter}
{These below are usefull in Advanced mode }
property tagPSD : tagPSD read ftagPSD write ftagPSD;
{* For low-level access}
property Advanced : WORD read fAdvanced write fAdvanced;
{* 0 := default
|<br>
1 := You must assign properties to tagPSD.Flags by yourself
|<br>
2 := You can create DEVNAMES and DEVMODE structures and assign to object tagPSD
(but also You must free previous tagPSD.hDevMode and tagPSD.hDevNames)
}
procedure FillOptions(DlgOptions : TPageSetupOptions);
{* }
procedure Prepare;
{* Destroy of previous allocated DEVMODE , DEVNAMES and DC. Is always invoked on destroy and in Execute method (when Advanced :=0 of course).}
end;
function NewPageSetupDialog(AOwner : PControl; Options : TPageSetupOptions) : PPageSetupDlg;
{* Global function for page setup dialog}
implementation
//////////////////////////////////////////////////////
// //
// Page setup dialog (implementation) //
// //
//////////////////////////////////////////////////////
function NewPageSetupDialog(AOwner : PControl; Options : TPageSetupOptions) : PPageSetupDlg;
begin
New(Result,Create);
FillChar(Result.ftagPSD,sizeof(tagPSD),0);
Result.ftagPSD.hWndOwner := AOwner.GetWindowHandle;
Result.ftagPSD.hInstance := hInstance;
Result.fOptions := Options;
Result.fAdvanced :=0;
Result.fhDC := 0;
end;
destructor TPageSetupDlg.Destroy;
begin
Prepare;
inherited;
end;
procedure TPageSetupDlg.Prepare;
begin
if ftagPSD.hDevMode <> 0 then
begin
GlobalUnlock(ftagPSD.hDevMode);
GlobalFree(ftagPSD.hDevMode);
ftagPSD.hDevMode :=0;
end;
if ftagPSD.hDevNames <> 0 then
begin
GlobalUnlock(ftagPSD.hDevNames);
GlobalFree(ftagPSD.hDevNames);
ftagPSD.hDevNames :=0;
end;
if fhDC <> 0 then
begin
DeleteDC(fhDC);
fhDC :=0;
end;
end;
procedure TPageSetupDlg.FillOptions(DlgOptions : TPageSetupOptions);
begin
ftagPSD.Flags := PSD_DEFAULTMINMARGINS;
{ Disable some parts of PageSetup window }
if not (psdMargins in DlgOptions) then Inc(ftagPSD.Flags, PSD_DISABLEMARGINS);
if not (psdOrientation in DlgOptions) then Inc(ftagPSD.Flags, PSD_DISABLEORIENTATION);
if not (psdSamplePage in DlgOptions) then Inc(ftagPSD.Flags, PSD_DISABLEPAGEPAINTING);
if not (psdPaperControl in DlgOptions) then Inc(ftagPSD.Flags,PSD_DISABLEPAPER);
if not (psdPrinterControl in DlgOptions) then inc(ftagPSD.Flags,PSD_DISABLEPRINTER);
{ Process HELPMSGSTRING message. Note : AOwner control must register and
process this message.}
if psdHelp in DlgOptions then Inc(ftagPSD.Flags, PSD_SHOWHELP);
{ Disable warning if there is no default printer }
if not (psdWarning in DlgOptions) then Inc(ftagPSD.Flags, PSD_NOWARNING);
if psdHundredthsOfMillimeters in DlgOptions then Inc(ftagPSD.Flags,PSD_INHUNDREDTHSOFMILLIMETERS);
if psdThousandthsOfInches in DlgOptions then Inc(ftagPSD.Flags,PSD_INTHOUSANDTHSOFINCHES);
if psdUseMargins in Dlgoptions then Inc(ftagPSD.Flags,PSD_MARGINS);
if psdUseMinMargins in DlgOptions then Inc(ftagPSD.Flags,PSD_MINMARGINS);
end;
function TPageSetupDlg.GetError : Integer;
begin
Result := CommDlgExtendedError();
end;
function TPageSetupDlg.Execute : Boolean;
var
ExitCode : Boolean;
Device,Driver,Output : PChar;
fDevMode : PDevMode;
begin
case fAdvanced of
0 : //Not in advanced mode
begin
Prepare;
FillOptions(fOptions);
end;
1:Prepare; //Advanced mode . User must assign properties and/or hook procedures
end; //If Advanced > 1 then You are expert ! (better use pure API ;-))
ftagPSD.lStructSize := sizeof(tagPSD);
ExitCode := PageSetupDlg(ftagPSD);
if (ftagPSD.Flags and PSD_INHUNDREDTHSOFMILLIMETERS) <> 0 then
fOptions := fOptions + [psdHundredthsOfMillimeters]
else
fOptions := fOptions - [psdHundredthsOfMillimeters];
if (ftagPSD.Flags and PSD_INTHOUSANDTHSOFINCHES) <> 0 then
fOptions := fOptions + [psdThousandthsOfInches]
else
fOptions := fOptions - [psdThousandthsOfInches];
fDevNames := PDevNames(GlobalLock(ftagPSD.hDevNames));
fDevMode := PDevMode(GlobalLock(ftagPSD.hDevMode));
if fDevNames <> nil then //support situation when user pressed cancel button
begin
Driver := PChar(fDevNames) + fDevNames^.wDriverOffset;
Device := PChar(fDevNames) + fDevNames^.wDeviceOffset;
Output := PChar(fDevNames) + fDevNames^.wOutputOffset;
if psdReturnDC in fOptions then fhDC := CreateDC(Driver,Device,Output,fDevMode);
end;
Result := ExitCode;
end;
function TPageSetupDlg.Info : PPrinterInfo;
begin
try
FillChar(PrinterInfo,sizeof(PrinterInfo),0);
with PrinterInfo do
begin
if fDevNames <> nil then
begin
ADriver := PChar(fDevNames) + fDevNames^.wDriverOffset;
ADevice := PChar(fDevNames) + fDevNames^.wDeviceOffset;
APort := PChar(fDevNames) + fDevNames^.wOutputOffset;
end;
ADevMode := ftagPSD.hDevMode;
end;
finally // support fDevNames=0 (user pressed Cancel)
Result := @PrinterInfo;
end;
end;
function TPageSetupDlg.GetPaperSize : TPoint;
begin
Result := ftagPSD.ptPaperSize;
end;
procedure TPageSetupDlg.SetMinMargins(Left,Top,Right,Bottom: Integer);
begin
ftagPSD.rtMinMargin.Left := Left;
ftagPSD.rtMinMargin.Top := Top;
ftagPSD.rtMinMargin.Right := Right;
ftagPSD.rtMinMargin.Bottom := Bottom;
end;
function TPageSetupDlg.GetMinMargins : TRect;
begin
Result := ftagPSD.rtMinMargin;
end;
procedure TPageSetupDlg.SetMargins(Left,Top,Right,Bottom : Integer);
begin
ftagPSD.rtMargin.Left := Left;
ftagPSD.rtMargin.Top := Top;
ftagPSD.rtMargin.Right := Right;
ftagPSD.rtMargin.Bottom := Bottom;
end;
function TPageSetupDlg.GetMargins : TRect;
begin
Result := ftagPSD.rtMargin;
end;
begin
end.

30
Addons/KOLPrintCommon.pas
View File

@ -1,30 +0,0 @@
unit KOLPrintCommon;
{*}
interface
uses Windows;
type
PDevNames = ^tagDEVNAMES;
tagDEVNAMES = packed record
wDriverOffset: Word;
wDeviceOffset: Word;
wOutputOffset: Word;
wDefault: Word;
end;
PPrinterInfo = ^TPrinterInfo;
TPrinterInfo = packed record
{* Used for transferring information between Print/Page dialogs and TKOLPrinter.This way TKOLPrinter and Print/Page dialogs could be used separately}
ADevice : PChar;
ADriver : PChar;
APort : PChar;
ADevMode : THandle;
end;
implementation
end.

373
Addons/KOLPrintDialogs.pas
View File

@ -1,373 +0,0 @@
unit KOLPrintDialogs;
{* Print and printer setup dialogs, implemented in KOL object.
|<br>
Ver 1.4
|<br>
Now the information about selected printer can be transferred to TKOLPrinter.
If DC is needed directly use new pdReturnDC option.}
interface
uses Windows, Messages, KOL, KOLPrintCommon;
const
DN_DEFAULTPRN = $0001; {default printer }
HELPMSGSTRING = 'commdlg_help';
//******************************************************************************
// PrintDlg options
//******************************************************************************
PD_ALLPAGES = $00000000;
PD_SELECTION = $00000001;
PD_PAGENUMS = $00000002;
PD_NOSELECTION = $00000004;
PD_NOPAGENUMS = $00000008;
PD_COLLATE = $00000010;
PD_PRINTTOFILE = $00000020;
PD_PRINTSETUP = $00000040;
PD_NOWARNING = $00000080;
PD_RETURNDC = $00000100;
PD_RETURNIC = $00000200;
PD_RETURNDEFAULT = $00000400;
PD_SHOWHELP = $00000800;
PD_ENABLEPRINTHOOK = $00001000;
PD_ENABLESETUPHOOK = $00002000;
PD_ENABLEPRINTTEMPLATE = $00004000;
PD_ENABLESETUPTEMPLATE = $00008000;
PD_ENABLEPRINTTEMPLATEHANDLE = $00010000;
PD_ENABLESETUPTEMPLATEHANDLE = $00020000;
PD_USEDEVMODECOPIES = $00040000;
PD_USEDEVMODECOPIESANDCOLLATE = $00040000;
PD_DISABLEPRINTTOFILE = $00080000;
PD_HIDEPRINTTOFILE = $00100000;
PD_NONETWORKBUTTON = $00200000;
//******************************************************************************
// Error constants
//******************************************************************************
CDERR_DIALOGFAILURE = $FFFF;
CDERR_GENERALCODES = $0000;
CDERR_STRUCTSIZE = $0001;
CDERR_INITIALIZATION = $0002;
CDERR_NOTEMPLATE = $0003;
CDERR_NOHINSTANCE = $0004;
CDERR_LOADSTRFAILURE = $0005;
CDERR_FINDRESFAILURE = $0006;
CDERR_LOADRESFAILURE = $0007;
CDERR_LOCKRESFAILURE = $0008;
CDERR_MEMALLOCFAILURE = $0009;
CDERR_MEMLOCKFAILURE = $000A;
CDERR_NOHOOK = $000B;
CDERR_REGISTERMSGFAIL = $000C;
PDERR_PRINTERCODES = $1000;
PDERR_SETUPFAILURE = $1001;
PDERR_PARSEFAILURE = $1002;
PDERR_RETDEFFAILURE = $1003;
PDERR_LOADDRVFAILURE = $1004;
PDERR_GETDEVMODEFAIL = $1005;
PDERR_INITFAILURE = $1006;
PDERR_NODEVICES = $1007;
PDERR_NODEFAULTPRN = $1008;
PDERR_DNDMMISMATCH = $1009;
PDERR_CREATEICFAILURE = $100A;
PDERR_PRINTERNOTFOUND = $100B;
PDERR_DEFAULTDIFFERENT = $100C;
type
PDevNames = ^tagDEVNAMES;
tagDEVNAMES = packed record
{*}
wDriverOffset: Word;
wDeviceOffset: Word;
wOutputOffset: Word;
wDefault: Word;
end;
{ Structure for PrintDlg function }
PtagPD = ^tagPD;
tagPD = packed record
{*}
lStructSize: DWORD;
hWndOwner: HWND;
hDevMode: HGLOBAL;
hDevNames: HGLOBAL;
hDC: HDC;
Flags: DWORD;
nFromPage: Word;
nToPage: Word;
nMinPage: Word;
nMaxPage: Word;
nCopies: Word;
hInstance: HINST;
lCustData: LPARAM;
lpfnPrintHook: function(Wnd: HWND; Message: UINT; wParam: WPARAM; lParam: LPARAM): UINT stdcall;
lpfnSetupHook: function(Wnd: HWND; Message: UINT; wParam: WPARAM; lParam: LPARAM): UINT stdcall;
lpPrintTemplateName: PAnsiChar;
lpSetupTemplateName: PAnsiChar;
hPrintTemplate: HGLOBAL;
hSetupTemplate: HGLOBAL;
end;
function PrintDlg(var PrintDlg: tagPD): BOOL; stdcall;external 'comdlg32.dll' name 'PrintDlgA';
function CommDlgExtendedError():DWORD;stdcall; external 'comdlg32.dll' name 'CommDlgExtendedError';
type
//////////////////////////////////////////////////////
// //
// Print dialog and printer setup dialog. //
// //
//////////////////////////////////////////////////////
TPrintDlgOption = (pdPrinterSetup,pdCollate,pdPrintToFile,pdPageNums,pdSelection,
pdWarning,pdDeviceDepend,pdHelp,pdReturnDC);
{* Options:
|<br>
|<ul>
|<li><b>pdPrinterSetup</b> : printer setup dialog </li>
|<li><b>pdCollate</b> : places checkmark in Collate check box.When Execute returns this flag
indicates that the user selected the Collate option but printer does not support it
|</li>
|<li><b>pdPrintToFile</b> : causes "Print to File" check box to be visible.When Execute returns this flag
indicates that this check box was selected and must be processed
|</li>
|<li><b>pdPageNums</b> : allow to select pages in dialog </li>
|<li><b>pdSelection</b> : set Selection field visible in dialog </li>
|<li><b>pdWarning</b> : when set, and there's no default printer in system, warning is generated (like in VCL TPrintDialog) </li>
|<li><b>pdDeviceDepend</b> : disables fields : Copies,Collate if this functions aren't supported by printer driver </li>
|<li><b>pdHelp</b> : Help button is visible (owner receive HELPMSGSTRING registered message)</li>
|<li><b>pdReturnDC</b> : returns DC of selected printer </li>
|</ul>
}
TPrintDlgOptions = Set of TPrintDlgOption;
{*}
PPrintDlg =^TPrintDlg;
TKOLPrintDialog = PPrintDlg;
TPrintDlg = object(TObj)
{*}
private
{ Private declarations }
fDevNames : PDevNames;
fAdvanced : WORD;
ftagPD : tagPD;
fOptions : TPrintDlgOptions;
PrinterInfo : TPrinterInfo;
protected
function GetError : Integer;
{ Protected declarations }
public
{ Public declarations }
destructor Destroy; virtual;
property Error : Integer read GetError;
{* Extended error}
property FromPage : WORD read ftagPD.nFromPage write ftagPD.nFromPage;
{* Starting page }
property ToPage : WORD read ftagPD.nToPage write ftagPD.nToPage;
{* Ending page}
property MinPage : WORD read ftagPD.nMinPage write ftagPD.nMinPage;
{* Minimal page number which is allowed to select}
property MaxPage : WORD read ftagPD.nMaxPage write ftagPD.nMaxPage;
{* Maximal page number which is allowed to select}
property Copies : WORD read ftagPD.nCopies write ftagPD.nCopies;
{* Number of copies}
property Options : TPrintDlgOptions read fOptions write fOptions;
{* Set of options}
property DC : hDC read ftagPD.hDC;
{* DC of selected printer}
function Execute : Boolean;
{* Main method}
function Info : PPrinterInfo;
{*}
{These below are usefull in Advanced mode }
property tagPD : tagPD read ftagPD write ftagPD;
{* For low-level access}
property Advanced : WORD read fAdvanced write fAdvanced;
{* 1 := You must assign properties to tagPD by yourself
|<br>
2 := Even more control...
}
procedure FillOptions(DlgOptions : TPrintDlgOptions);
{* Fill options}
procedure Prepare;
{* Destroy of prevoius context (DEVMODE,DEVNAMES,DC) .Usefull when Advanced > 0}
end;
function NewPrintDialog(AOwner : PControl; Options : TPrintDlgOptions) : PPrintDlg;
{* Global creating function}
implementation
///////////////////////////////////////////////////////////////
// //
// Print dialog and printer setup dialog (implementation) //
// //
///////////////////////////////////////////////////////////////
function NewPrintDialog(AOwner : PControl; Options : TPrintDlgOptions) : PPrintDlg;
begin
New(Result,Create);
FillChar(Result.ftagPD,sizeof(tagPD),0);
Result.ftagPD.hWndOwner := AOwner.GetWindowHandle;
Result.ftagPD.hInstance := hInstance;
Result.fOptions := Options;
Result.fAdvanced := 0;
end;
destructor TPrintDlg.Destroy;
begin
Prepare;
inherited;
end;
procedure TPrintDlg.Prepare;
begin
if ftagPD.hDevMode <> 0 then
begin
GlobalFree(ftagPD.hDevMode);
ftagPD.hDevMode :=0;
end;
if ftagPD.hDevNames <> 0 then
begin
GlobalUnlock(ftagPD.hDevNames);
GlobalFree(ftagPD.hDevNames);
ftagPD.hDevNames :=0;
end;
if ftagPD.hDC <> 0 then
begin
DeleteDC(ftagPD.hDC);
ftagPD.hDC :=0;
end;
end;
procedure TPrintDlg.FillOptions(DlgOptions : TPrintDlgOptions);
begin
ftagPD.Flags := PD_ALLPAGES;
{ Return HDC if required}
if pdReturnDC in DlgOptions then Inc(ftagPD.Flags,PD_RETURNDC);
{ Show printer setup dialog }
if pdPrinterSetup in DlgOptions then Inc(ftagPD.Flags,PD_PRINTSETUP);
{ Process HELPMSGSTRING message. Note : AOwner control must register and
process this message.}
if pdHelp in DlgOptions then Inc(ftagPD.Flags, PD_SHOWHELP);
{ This flag indicates on return that printer driver does not support collation.
You must eigther provide collation or set pdDeviceDepend (and user won't see
collate checkbox if is not supported) }
if pdCollate in DlgOptions then Inc(ftagPD.Flags,PD_COLLATE);
{ Disable some parts of PrintDlg window }
if not (pdPrintToFile in DlgOptions) then Inc(ftagPD.Flags, PD_HIDEPRINTTOFILE);
if not (pdPageNums in DlgOptions) then Inc(ftagPD.Flags, PD_NOPAGENUMS);
if not (pdSelection in DlgOptions) then Inc(ftagPD.Flags, PD_NOSELECTION);
{ Disable warning if there is no default printer }
if not (pdWarning in DlgOptions) then Inc(ftagPD.Flags, PD_NOWARNING);
if pdDeviceDepend in DlgOptions then Inc(ftagPD.Flags,PD_USEDEVMODECOPIESANDCOLLATE);
end;
function TPrintDlg.GetError : Integer;
begin
Result := CommDlgExtendedError();
end;
function TPrintDlg.Execute : Boolean;
var
ExitCode : Boolean;
begin
case fAdvanced of
0 : //Not in advanced mode
begin
Prepare;
FillOptions(fOptions);
end;
1:Prepare; //Advanced mode . User must assign properties and/or hook procedures
end;
ftagPD.lStructSize := sizeof(tagPD);
ExitCode := PrintDlg(ftagPD);
fDevNames := PDevNames(GlobalLock(ftagPD.hDevNames));
if (ftagPD.Flags and PD_PRINTTOFILE) <> 0 then fOptions := fOptions + [pdPrintToFile]
else
fOptions := fOptions - [pdPrintToFile];
if (ftagPD.Flags and PD_COLLATE) <> 0 then fOptions := fOptions + [pdCollate]
else
fOptions := fOptions - [pdCollate];
Result := ExitCode;
end;
function TPrintDlg.Info : PPrinterInfo;
begin
try
FillChar(PrinterInfo,sizeof(PrinterInfo),0);
with PrinterInfo do
begin
ADriver := PChar(fDevNames) + fDevNames^.wDriverOffset;
ADevice := PChar(fDevNames) + fDevNames^.wDeviceOffset;
APort := PChar(fDevNames) + fDevNames^.wOutputOffset;
ADevMode := ftagPD.hDevMode ;
end;
finally //support situation when fDevNames=0 (user pressed Cancel)
Result := @PrinterInfo;
end;
end;
begin
end.

626
Addons/KOLPrinters.pas
View File

@ -1,626 +0,0 @@
unit KOLPrinters;
{* Replaces VCL TPrinter functionality.
|<br>
Author : Bogus�aw Brandys, <brandysb@poczta.onet.pl>
|<br>
|<H3>Version 1.4 </H3>
|<br>
|<i>History :</i>
|<br>
|<b> 17-09-2002 </b> [+] Added property Assigned which should always be checked before first access
to TKOLPrinter. If is FALSE then there is no printer in system. (Warning: if You
assign incorrect info to Assign procedure this could lead Your application to
crash rather then return Assigned = FALSE)
|<br>
[+] Changed Write to WriteLn and improved.Now always print a line of text with
carrage return #10#13 even there is no one at the end of text.Also should not break
word on bottom-right corner of page and working good when text does not fit on page
(NextPage invoked)
|<br>
|<br>
|<b> 15-09-2002 </b> [-] Fix access violation when there is no printer in system (caused
by DefPrinter function and Assign procedure).
|<br>
|<b><i>Example:</i></b>
! with Printer^ do
! begin
! Assign(nil); //default printer (actually not needed as default printer is assigned on start)
! if not Assigned then begin
! MsgBox('There is no default printer in system!',mb_iconexclamation);
! Exit;
! end;
! Title := 'Printing test...';
! Canvas.Font.Assign(Memo1.Font);
! BeginDoc;
! for i:=0 to Memo1.Count-1 do WriteLn(Memo1.Items[i]); //or just WriteLn(Memo1.Text);
! EndDoc;
! end;
|<br>
|</i>One more note:</i>
|<br> use psdWarning and pdWarning in PageSetup/Print dialogs to let
user know that there is no printer in system (or no default).
When these options are not used PrintDialog appear empty but PageSetup dialog never
appears.
|<br>
Notes:
|<br>
When output is redirected to a file and You want to know his name , check Output property
but always after sucessful Execute and before EndDoc (becouse EndDoc clears Output property)
Margins are supported but experimental (if You have time and paper please examine
if it working and let me know ;-) - especially if units for margins are properly computed.
Beside let me know what is still missing...
|<br>
Still missing (I suppose):
|<br>
- printing text as continuation of current printed line (in the middle of the line)
(this was a nightmare for me , if You know how to do it contact me)
|<br>
- printing of selected pages only (must compute pages count)
|<br>
- collate and printing more than one page when printer do not support multiple pages and collation
(well, should not be very difficult, maybe just check if this is supported and if no just print many times
the same)
|<br>
- Printers property (list of printers in system),PrinterIndex and Fonts property
|<br>
- print preview
|<br>
- more tests}
interface
uses Windows, Messages, KOL, KOLPrintCommon;
type
TPrinterState = (psNeedHandle, psHandle, psOtherHandle);
TPrinterOrientation = (poPortrait, poLandscape);
{* Paper orientation}
TMarginOption = (mgInches, mgMillimeters);
{* Margin option}
PPrinter = ^TPrinter;
TKOLPrinter = PPrinter;
TPrinter = object(TObj)
{*}
private
{ Private declarations }
fDevice, fDriver, fPort: string;
fDevMode: THandle;
fDeviceMode: PDeviceMode;
fCanvas: PCanvas; // KOL canvas
fTitle: string;
fState: TPrinterState; // DC is allocated or need new DC becouse params were changed
fAborted: Boolean;
fPrinting: Boolean;
fPageNumber: Integer;
fOutput: string;
PrinterInfo: TPrinterInfo;
fRec: TRect;
fMargins: TRect; //Margins (in pixels)
fAssigned: Boolean; //if TRUE ,there is a printer with correctly assigned information
protected
function GetHandle: HDC;
procedure SetHandle(Value: HDC);
function GetCanvas: PCanvas;
function GetCopies: Integer;
procedure SetCopies(const Value: Integer);
function GetOrientation: TPrinterOrientation;
procedure SetOrientation(const Value: TPrinterOrientation);
function GetPageHeight: Integer;
function GetPageWidth: Integer;
function Scale: Integer;
procedure Prepare;
procedure DefPrinter;
public
{ Public declarations }
destructor Destroy; virtual;
procedure Abort;
{* Abort print process}
procedure BeginDoc;
{* Begin print process}
procedure EndDoc;
{* End print process end send it to print spooler}
procedure NewPage;
{* Request new page}
procedure Assign(Source: PPrinterInfo);
{* Assign information about selected printer for example from Print/Page dialogs}
procedure AssignMargins(cMargins: TRect; Option: TMarginOption);
{* Assign information about paper margins for example from TKOLPageSetupDialog
(in thousands of inches scale)}
procedure WriteLn(const Text: string);
{* Print tekst with TKOLPrinter selected font.Note: can be invoked more than once, but currently
only for text ended with #10#13 (other is not properly wraped around right page corner ;-( )}
procedure RE_Print(RichEdit: PControl);
{* Print content of TKOLRichEdit (if Rich is not TKOLRichEdit nothing happens)
with full formating of course :-)}
property Assigned: Boolean read fAssigned;
{* If TRUE, there is a default or assigned previoulsy printer (by Assign).Always check
this property to avoid access violation when there is no printer in system}
property Title: string read fTitle write fTitle;
{* Title of print process in print manager window}
function Info: PPrinterInfo;
{* Returns info of selected print}
property Output: string read fOutput write fOutput;
{* Let print to the file.Assign file path to this property.}
property Handle: HDC read GetHandle write SetHandle;
{*}
property Canvas: PCanvas read GetCanvas;
{*}
property Copies: Integer read GetCopies write SetCopies;
{* Number of copies}
property Orientation: TPrinterOrientation read GetOrientation write SetOrientation;
{* Page orientation}
property Margins: TRect read fMargins write fMargins;
{* Page margins (in pixels)}
property PageHeight: Integer read GetPageHeight;
{* Page height in logical pixels}
property PageWidth: Integer read GetPageWidth;
{* Page width in logical pixels}
property PageNumber: Integer read fPageNumber;
{* Currently printed page number}
property Printing: Boolean read fPrinting;
{* Indicate printing process}
property Aborted: Boolean read fAborted;
{* Indicate abort of printing process}
end;
function Printer: PPrinter;
{* Returns pointer to global TKOLPrinter object}
procedure RecreatePrinter;
{* Recreates global Printer pbject }
function NewPrinter(PrinterInfo: PPrinterInfo): PPrinter;
{* Global function for creating TKOLPrinter instance.Usually not needed, becouse
inluding KOLPrinters causes creating of global TKOLPrinter instance.}
implementation
uses
RichEdit;
type
PtagPD = ^tagPD;
tagPD = packed record
lStructSize: DWORD;
hWndOwner: HWND;
hDevMode: HGLOBAL;
hDevNames: HGLOBAL;
hDC: HDC;
Flags: DWORD;
nFromPage: Word;
nToPage: Word;
nMinPage: Word;
nMaxPage: Word;
nCopies: Word;
hInstance: HINST;
lCustData: LPARAM;
lpfnPrintHook: function(Wnd: HWND; Message: UINT; wParam: WPARAM; lParam: LPARAM): UINT stdcall;
lpfnSetupHook: function(Wnd: HWND; Message: UINT; wParam: WPARAM; lParam: LPARAM): UINT stdcall;
lpPrintTemplateName: PAnsiChar;
lpSetupTemplateName: PAnsiChar;
hPrintTemplate: HGLOBAL;
hSetupTemplate: HGLOBAL;
end;
const
PD_RETURNDC = $00000100;
PD_RETURNDEFAULT = $00000400;
var
FPrinter : PPrinter = nil;
function PrintDlg(var PrintDlg: tagPD): BOOL; stdcall; external 'comdlg32.dll' name 'PrintDlgA';
function AbortProc(Handle: HDC; Error: Integer): Bool; stdcall;
begin
Result := not fPrinter.Aborted;
end;
function NewPrinter(PrinterInfo: PPrinterInfo): PPrinter;
begin
New(Result, Create);
Result.fTitle := '';
Result.fOutput := '';
Result.fAborted := False;
Result.fPrinting := False;
Result.fPageNumber := 0;
Result.fCanvas := nil;
Result.fMargins.Top := 10;
Result.fMargins.Left := 10;
Result.fMargins.Bottom := 10;
Result.fMargins.Right := 10;
FillChar(Result.fRec, sizeof(Result.fRec), 0);
if PrinterInfo = nil then
Result.DefPrinter
else
Result.Assign(PrinterInfo);
end;
function Printer: PPrinter;
begin
if FPrinter = nil then
FPrinter := NewPrinter(nil);
Result := FPrinter;
end;
procedure RecreatePrinter;
begin
Free_And_Nil(FPrinter);
FPrinter := NewPrinter(nil);
end;
destructor TPrinter.Destroy;
begin
Prepare;
fTitle := '';
fDevice := '';
fDriver := '';
fPort := '';
fOutput := '';
inherited; {+++}
FPrinter := nil;
end;
procedure TPrinter.Prepare;
begin
{ Free previously used resources }
if (fState <> psOtherHandle) and (fCanvas <> nil) then begin
fCanvas.Free;
fCanvas := nil; {+++}
end;
if fDevMode <> 0 then begin
GlobalUnlock(fDevMode);
GlobalFree(fDevMode);
end;
end;
function TPrinter.Scale: Integer;
var
DC : HDC;
ScreenH, PrinterH : Integer;
begin
DC := GetDC(0);
ScreenH := GetDeviceCaps(DC, LOGPIXELSY);
PrinterH := GetDeviceCaps(fCanvas.Handle, LOGPIXELSY);
ReleaseDC(0, DC);
Result := PrinterH div ScreenH;
end;
procedure TPrinter.WriteLn(const Text: string);
var
OldFontSize, PageH, Size, Len: Integer;
pC : PChar;
Rect : TRect;
Metrics : TTextMetric;
NewText : string;
procedure ComputeRect;
{ Start from new line.Rect is the rest of page from current new line to the bottom. First probe
how many characters do not fit on this rect.}
begin
Len := 1;
while Windows.DrawText(fCanvas.Handle, pC, Len, Rect, DT_CALCRECT + DT_WORDBREAK + DT_NOCLIP + DT_NOPREFIX + DT_EXPANDTABS) < PageH do begin
Rect.Right := fRec.Right; //must be, becouse DrawText shorten right corner
Len := Len + 100;
if Len > Size then begin
Len := Size;
Break;
end;
end;
{ Next : Count backwards to find exact characters which fit on required page rect.}
while Windows.DrawText(fCanvas.Handle, pC, Len, Rect, DT_CALCRECT + DT_WORDBREAK + DT_NOCLIP + DT_NOPREFIX + DT_EXPANDTABS) > PageH do
Len := Len - 1;
{ Find position of last space or line end (#13#10) to not break word
(if possible) on bottom-right corner of the page.Do it only for multipage text (Len<>Size) }
{
if (Len <> Size) and (Len > 0) then begin
Test := Len;
while ((NewText[Test] <> #32) and (NewText[Test]<> #10)) and (Test > 0) do Test := Test -1 ;
if Test > 0 then Len := Test;
end;
}
{ Finally draw it!}
Windows.DrawText(fCanvas.Handle, pC, Len, Rect, DT_WORDBREAK + DT_NOCLIP + DT_NOPREFIX + DT_EXPANDTABS);
end;
begin
if Length(Text) <= 0 then Exit;
if Text[Length(Text)] <> #10 then NewText := Text + #13#10
else
NewText := Text;
pC := PChar(NewText);
Size := Length(NewText);
SetMapMode(fCanvas.Handle, MM_TEXT);
OldFontSize := fCanvas.Font.FontHeight;
fCanvas.Font.FontHeight := fCanvas.Font.FontHeight * Scale;
SelectObject(fCanvas.Handle, fCanvas.Font.Handle);
PageH := GetPageHeight - fMargins.Bottom;
GetTextMetrics(fCanvas.Handle, Metrics);
while Size > 0 do begin
Rect := fRec;
ComputeRect;
Inc(pC, Len + 1);
Dec(Size, Len + 1);
if (Size > 0) and (fRec.Left <= fMargins.Left) then NewPage;
end;
if (Rect.Bottom > PageH) then begin
NewPage;
Rect.Bottom := 0;
end;
fRec.Top := Rect.Bottom - Metrics.tmHeight;
fRec.Left := fMargins.Left;
fRec.Bottom := PageH;
fCanvas.Font.FontHeight := OldFontSize;
NewText := '';
end;
procedure TPrinter.DefPrinter;
var
ftagPD : tagPD;
DevNames : PDevNames;
begin
fAssigned := false;
fState := psHandle;
Prepare;
{ Get DC of default printer }
FillChar(ftagPD, sizeof(tagPD), 0);
ftagPD.Flags := PD_RETURNDC + PD_RETURNDEFAULT;
ftagPD.lStructSize := sizeof(ftagPD);
if not PrintDlg(ftagPD) then Exit;
fAssigned := true;
DevNames := PDevNames(GlobalLock(ftagPD.hDevNames));
fDevMode := ftagPD.hDevMode;
fDeviceMode := PDevMode(GlobalLock(fDevMode));
try
fDriver := string(PChar(DevNames) + DevNames^.wDriverOffset);
fDevice := string(PChar(DevNames) + DevNames^.wDeviceOffset);
fPort := string(PChar(DevNames) + DevNames^.wOutputOffset);
finally
GlobalUnlock(ftagPD.hDevNames);
GlobalFree(ftagPD.hDevNames);
end;
fCanvas := NewCanvas(ftagPD.hDC);
end;
procedure TPrinter.Assign(Source: PPrinterInfo);
var
Size : Integer;
DevMode : PDevMode;
fhDC : HDC;
begin
fAssigned := false;
if (Source = nil) or
(Source^.ADriver = nil) and
(Source^.ADevice = nil) and
(Source^.APort = nil) and
(Source^.ADevMode = 0) then DefPrinter
else begin
Prepare;
fDriver := string(Source^.ADriver);
fDevice := string(Source^.ADevice);
fPort := string(Source^.APort);
DevMode := PDevMode(GlobalLock(Source^.ADevMode));
try
Size := sizeof(DevMode^);
fDevMode := GlobalAlloc(GHND, Size);
fDeviceMode := PDevMode(GlobalLock(fDevMode));
CopyMemory(fDeviceMode, DevMode, Size);
fhDC := CreateDC(PChar(fDriver), PChar(fDevice), PChar(fPort), fDeviceMode);
finally
GlobalUnlock(Source^.ADevMode);
end;
fCanvas := NewCanvas(fhDC);
fAssigned := true;
end;
end;
procedure TPrinter.AssignMargins(cMargins: TRect; Option: TMarginOption);
var
PH, PW : Integer;
begin
PH := GetDeviceCaps(fCanvas.Handle, LOGPIXELSY);
PW := GetDeviceCaps(fCanvas.Handle, LOGPIXELSX);
case Option of
mgInches: begin
fMargins.Top := round((cMargins.Top * PH) / 1000);
fMargins.Left := round((cMargins.Left * PW) / 1000);
fMargins.Bottom := round((cMargins.Bottom * PH) / 1000);
fMargins.Right := round((cMargins.Right * PW) / 1000);
end;
mgMillimeters: begin
fMargins.Top := round((cMargins.Top * PH) / 2540);
fMargins.Left := round((cMargins.Left * PW) / 2540);
fMargins.Bottom := round((cMargins.Bottom * PH) / 2540);
fMargins.Right := round((cMargins.Right * PW) / 2540);
end;
end;
end;
procedure TPrinter.Abort;
begin
AbortDoc(fCanvas.Handle);
fAborted := True;
EndDoc;
end;
procedure TPrinter.BeginDoc;
var
doc : DOCINFOA;
begin
fRec.Top := fMargins.Top;
fRec.Left := fMargins.Left;
fRec.Right := GetPageWidth - fMargins.Right;
fRec.Bottom := GetPageHeight - fMargins.Bottom;
fAborted := False;
fPageNumber := 1;
fPrinting := True;
FillChar(doc, sizeof(DOCINFOA), 0);
doc.lpszDocName := PChar(fTitle);
if (fOutput <> '') then doc.lpszOutput := PChar(fOutput);
doc.cbSize := sizeof(doc);
SetAbortProc(fCanvas.Handle, AbortProc);
StartDoc(fCanvas.Handle, doc);
StartPage(fCanvas.Handle);
end;
procedure TPrinter.EndDoc;
begin
EndPage(fCanvas.Handle);
if not fAborted then Windows.EndDoc(fCanvas.Handle);
fAborted := False;
fPageNumber := 0;
fOutPut := '';
fPrinting := False;
end;
function TPrinter.GetHandle: HDC;
var
fhDC : HDC;
begin
if (fState = psNeedHandle) and (fCanvas <> nil) then begin
fCanvas.Free;
fhDC := CreateDC(PChar(fDriver), PChar(fDevice), PChar(fPort), fDeviceMode);
fCanvas := NewCanvas(fhDC);
fState := psHandle;
end;
Result := fCanvas.Handle;
end;
procedure TPrinter.SetHandle(Value: HDC);
begin
if Value <> fCanvas.Handle then begin
if fCanvas <> nil then fCanvas.Free;
fCanvas := NewCanvas(Value);
fState := psOtherHandle;
end;
end;
function TPrinter.GetCanvas: PCanvas;
begin
GetHandle;
Result := fCanvas;
end;
function TPrinter.Info: PPrinterInfo;
begin
with PrinterInfo do begin
ADevice := PChar(fDevice);
ADriver := PChar(fDriver);
APort := PChar(fPort);
ADevMode := fDevMode;
end;
Result := @PrinterInfo;
end;
function TPrinter.GetCopies: Integer;
begin
Result := fDeviceMode^.dmCopies;
end;
procedure TPrinter.SetCopies(const Value: Integer);
begin
fDeviceMode^.dmCopies := Value;
end;
function TPrinter.GetOrientation: TPrinterOrientation;
begin
if System.Assigned(fDeviceMode) and (fDeviceMode^.dmOrientation = DMORIENT_PORTRAIT) then
Result := poPortrait
else
Result := poLandscape;
end;
procedure TPrinter.SetOrientation(const Value: TPrinterOrientation);
const
Orientations : array[TPrinterOrientation] of Integer = (DMORIENT_PORTRAIT, DMORIENT_LANDSCAPE);
begin
fDeviceMode^.dmOrientation := Orientations[Value];
end;
function TPrinter.GetPageHeight: Integer;
begin
if fCanvas <> nil then
Result := GetDeviceCaps(fCanvas.Handle, VERTRES)
else Result := 0;
end;
function TPrinter.GetPageWidth: Integer;
begin
if fCanvas <> nil then
Result := GetDeviceCaps(fCanvas.Handle, HORZRES)
else Result := 0;
end;
procedure TPrinter.NewPage;
begin
fRec.Top := fMargins.Top;
fRec.Left := fMargins.Left;
fRec.Right := GetPageWidth - fMargins.Right;
fRec.Bottom := GetPageHeight - fMargins.Bottom;
EndPage(fCanvas.Handle);
StartPage(fCanvas.Handle);
SelectObject(fCanvas.Handle, fCanvas.Font.Handle);
Inc(fPageNumber);
end;
procedure TPrinter.RE_Print(RichEdit: PControl);
var
Range : TFormatRange;
LastChar, MaxLen, LogX, LogY, OldMap: Integer;
SaveRect : TRect;
TextLenEx : TGetTextLengthEx;
begin
if IndexOfStr(RichEdit.SubClassName, 'obj_RichEdit') = -1 then Exit;
FillChar(Range, SizeOf(TFormatRange), 0);
with Range do begin
BeginDoc;
hdc := GetHandle;
hdcTarget := hdc;
LogX := GetDeviceCaps(Handle, LOGPIXELSX);
LogY := GetDeviceCaps(Handle, LOGPIXELSY);
rc.Top := fMargins.Top * 1440 div LogY;
rc.Left := fMargins.Left * 1440 div LogX;
rc.Right := (GetPageWidth - fMargins.Right) * 1440 div LogX;
rc.Bottom := (GetPageHeight - fMargins.Bottom) * 1440 div LogY;
rcPage := rc;
SaveRect := rc;
LastChar := 0;
// if RichEdit.Version >= 2 then begin
with TextLenEx do begin
flags := GTL_DEFAULT;
codepage := CP_ACP;
end;
MaxLen := RichEdit.Perform(EM_GETTEXTLENGTHEX, WParam(@TextLenEx), 0);
// end
// else
// MaxLen := Length(RichEdit.RE_Text[ reRTF, True ]);
chrg.cpMax := -1;
OldMap := SetMapMode(hdc, MM_TEXT);
SendMessage(RichEdit.Handle, EM_FORMATRANGE, 0, 0); { flush buffer }
try
repeat
rc := SaveRect;
chrg.cpMin := LastChar;
LastChar := SendMessage(RichEdit.Handle, EM_FORMATRANGE, 1, Longint(@Range));
if (LastChar < MaxLen) and (LastChar <> -1) then NewPage;
until (LastChar >= MaxLen) or (LastChar = -1);
EndDoc;
finally
SendMessage(RichEdit.Handle, EM_FORMATRANGE, 0, 0); { flush buffer }
SetMapMode(hdc, OldMap); { restore previous map mode }
end;
end;
end;
initialization
//FPrinter := NewPrinter(nil);
finalization
Free_And_Nil(FPrinter);
end.

359
Addons/KOLProgBar.pas
View File

@ -1,359 +0,0 @@
unit KOLProgBar;
interface
uses
Windows, Messages, KOL;
type
TBevel = (bvUp, bvDown, bvNone);
PColorProgBar =^TColorProgBar;
TColorProgressBar = PColorProgBar;
TColorProgBar = object(TObj)
private
{ Private declarations }
fControl : PControl;
fPosition: integer;
fOldPosit: integer;
fBColor,
fFColor : TColor;
fFirst : boolean;
fBorder : integer;
fParentCl: boolean;
fBevel : TBevel;
fMin,
fMax : integer;
fStr : string;
fFont : PGraphicTool;
fCanvas : PCanvas;
OldWind,
NewWind : longint;
procedure SetFColor(C: TColor);
procedure SetBColor(C: TColor);
procedure SetPos(P: integer);
procedure SetBorder(B: integer);
procedure SetParentCl(B: boolean);
procedure SetBevel(B: TBevel);
procedure SetMin(M: integer);
procedure SetMax(M: integer);
protected
{ Protected declarations }
procedure NewWndProc(var Msg: TMessage);
procedure Paint;
{ procedure WMPaint(var Msg: TMessage); message WM_PAINT;
procedure WMSize (var Msg: TMessage); message WM_SIZE;
procedure WMActiv(var Msg: TMessage); message WM_SHOWWINDOW;
procedure CMParCl(var Msg: TMessage); message CM_PARENTCOLORCHANGED;}
public
destructor Destroy; virtual;
function SetPosition(X, Y: integer): PColorProgBar; overload;
function SetSize(X, Y: integer): PColorProgBar; overload;
function SetAlign(A: TControlAlign): PColorProgBar; overload;
function GetFont: PGraphicTool;
{ Public declarations }
{ constructor Create(Owner: TControl); override;}
property Font: PGraphicTool read GetFont;
property FColor: TColor read fFColor write SetFColor;
property BColor: TColor read fBColor write SetBColor;
property Border: integer read fBorder write SetBorder;
property Position: integer read fPosition write SetPos;
property Max: integer read fMax write SetMax;
property Min: integer read fMin write SetMin;
property ParentColor: boolean read fParentCl write SetParentCl;
property Bevel: TBevel read fBevel write SetBevel;
end;
function NewTColorProgressBar(AOwner: PControl): PColorProgBar;
implementation
uses objects;
function NewTColorProgressBar;
var p: PColorProgBar;
c: PControl;
begin
{ New(Result, Create);}
c := pointer(_NewControl( AOwner, 'STATIC', WS_VISIBLE or WS_CHILD or
SS_LEFTNOWORDWRAP or SS_NOPREFIX or SS_NOTIFY,
False, nil ));
c.CreateWindow;
New(p, create);
AOwner.Add2AutoFree(p);
p.fControl := c;
p.fFont := NewFont;
p.fCanvas := NewCanvas(GetDC(c.Handle));
p.fMin := 0;
p.fMax := 100;
p.fFColor := clRed;
p.fBColor := clBtnFace;
p.fBorder := 4;
p.fBevel := bvDown;
p.fFirst := True;
p.fPosition := 50;
p.fFont.FontStyle := [fsBold];
Result := p;
p.OldWind := GetWindowLong(c.Handle, GWL_WNDPROC);
p.NewWind := LongInt(MakeObjectInstance(p.NewWndProc));
SetWindowLong(c.Handle, GWL_WNDPROC, p.NewWind);
end;
destructor TColorProgBar.Destroy;
begin
SetWindowLong(fControl.Handle, GWL_WNDPROC, OldWind);
FreeObjectInstance(Pointer(NewWind));
fCanvas.Free;
fFont.Free;
inherited;
end;
function TColorProgBar.SetPosition(X, Y: integer): PColorProgBar;
begin
fControl.Left := X;
fControl.Top := Y;
Result := @self;
end;
function TColorProgBar.SetSize(X, Y: integer): PColorProgBar;
begin
fControl.Width := X;
fControl.Height := Y;
Result := @self;
end;
function TColorProgBar.SetAlign(A: TControlAlign): PColorProgBar;
begin
fControl.Align := A;
Result := @self;
end;
function TColorProgBar.GetFont;
begin
Result := fFont;
end;
procedure TColorProgBar.NewWndProc;
begin
Msg.Result := CallWindowProc(Pointer(OldWind), fControl.Handle, Msg.Msg, Msg.wParam, Msg.lParam);
case Msg.Msg of
WM_PAINT: Paint;
WM_SIZE: begin
fFirst := True;
Paint;
end;
WM_ACTIVATE:
begin
fFirst := True;
Paint;
end;
{CM_PARENTCOLORCHANGED:
begin
if fParentCl then begin
if Msg.wParam <> 0 then
BColor := TColor(Msg.lParam) else
BColor := (Parent as TForm).Color;
FColor := (Parent as TForm).Font.Color;
end;
end;}
end;
end;
procedure TColorProgBar.SetFColor;
begin
fFColor := C;
fFirst := True;
Paint;
end;
procedure TColorProgBar.SetBColor;
begin
fBColor := C;
fFirst := True;
Paint;
end;
procedure TColorProgBar.SetPos;
begin
fPosition := P;
Paint;
end;
procedure TColorProgBar.SetBorder;
begin
fBorder := B;
fFirst := True;
Paint;
end;
procedure TColorProgBar.SetParentCl;
begin
fParentCl := B;
if B then begin
{ Perform(CM_PARENTCOLORCHANGED, 0, 0);}
Paint;
end;
end;
procedure TColorProgBar.SetBevel;
begin
fBevel := B;
fFirst := True;
Paint;
end;
procedure TColorProgBar.SetMin;
begin
fMin := M;
fFirst := True;
if fMax = fMin then fMax := fMin + 1;
Paint;
end;
procedure TColorProgBar.SetMax;
begin
fMax := M;
fFirst := True;
if fMin = fMax then fMin := fMax - 1;
Paint;
end;
procedure Frame3D(Canvas: PCanvas; var Rect: TRect; TopColor, BottomColor: TColor;
Width: Integer);
procedure DoRect;
var
TopRight, BottomLeft: TPoint;
begin
with Canvas^, Rect do
begin
TopRight.X := Right;
TopRight.Y := Top;
BottomLeft.X := Left;
BottomLeft.Y := Bottom;
Pen.Color := TopColor;
PolyLine([BottomLeft, TopLeft, TopRight]);
Pen.Color := BottomColor;
Dec(BottomLeft.X);
PolyLine([TopRight, BottomRight, BottomLeft]);
end;
end;
begin
Dec(Rect.Bottom); Dec(Rect.Right);
while Width > 0 do
begin
Dec(Width);
DoRect;
InflateRect(Rect, -1, -1);
end;
Inc(Rect.Bottom); Inc(Rect.Right);
end;
function ColorToRGB(Color: TColor): Longint;
begin
if Color < 0 then
Result := GetSysColor(Color and $000000FF) else
Result := Color;
end;
procedure TColorProgBar.Paint;
var Rct: TRect;
Trc: TRect;
Twk: TRect;
Str: string;
Rht: integer;
Len: integer;
Rgn: HRgn;
Stw: integer;
begin
GetClientRect(fControl.Handle, Rct);
Trc := Rct;
if (fPosition <= fOldPosit) or fFirst then begin
case fBevel of
bvUp: begin
Frame3D(fCanvas, Rct, clWhite, clBlack, 1);
end;
bvDown: begin
Frame3D(fCanvas, Rct, clBlack, clWhite, 1);
end;
end;
fFirst := False;
fCanvas.brush.Color := fBColor;
fCanvas.FillRect(Rct);
end;
Rct := Trc;
InflateRect(Rct, -fBorder, -fBorder);
Rct.Right := Rct.Left + (Rct.Right - Rct.Left) * fPosition div (Max - Min);
Str := ' ' + int2str(fPosition * 100 div (fMax - fMin)) + '% ';
SelectObject(fCanvas.Handle, fFont.Handle);
Stw := fCanvas.TextWidth(Str);
Trc.Left := (fControl.width - Stw) div 2;
Trc.Right := (fControl.width + Stw) div 2 + 1;
Twk := Rct;
fCanvas.brush.Color := fFColor;
if (Rct.Right <= Trc.Left) then begin
fCanvas.FillRect(Rct);
end else begin
Twk.Right := Trc.Left;
fCanvas.FillRect(Twk);
end;
Rht := Rct.Right;
Len := Length(Str);
Rct.Left := (fControl.width - Stw) div 2;
Rct.Right := (fControl.width + Stw) div 2 + 1;
if fStr <> Str then begin
if (Rct.Right > Rht) or (fCanvas.TextHeight(Str) > (Rct.Bottom - Rct.Top)) then begin
Rgn := CreateRectRgn(Rht, Rct.Top, Rct.Right, Rct.Bottom);
SelectClipRgn(fCanvas.Handle, Rgn);
SelectObject(fCanvas.Handle, fFont.Handle);
SetBkColor(fCanvas.Handle, ColorToRGB(fBColor));
SetTextColor(fCanvas.Handle, ColorToRGB(fFColor));
DrawText(fCanvas.Handle, @Str[1], Len, Rct, DT_TOP or DT_NOCLIP);
SelectClipRgn(fCanvas.Handle, 0);
DeleteObject(Rgn);
end;
end;
if Rht < Rct.Right then begin
Rct.Right := Rht;
end;
Dec(Rct.Left);
Inc(Rct.Right);
if (Rct.Right > Rct.Left) then begin
SelectObject(fCanvas.Handle, fFont.Handle);
SetBkColor(fCanvas.Handle, ColorToRGB(fFColor));
SetTextColor(fCanvas.Handle, ColorToRGB(fBColor));
DrawText(fCanvas.Handle, @Str[1], Len, Rct, DT_TOP);
if Rct.Right < Trc.Right then begin
Twk := Rct;
Twk.Top := Twk.Top + fCanvas.TextHeight(Str);
fCanvas.brush.Color := fFColor;
fCanvas.Fillrect(Twk);
end;
end;
if (Rct.Right >= Trc.Right) then begin
Rct.Left := Trc.Right - 2;
Rct.Right := Rht;
SetBkColor(fCanvas.Handle, ColorToRGB(fFColor));
fCanvas.FillRect(Rct);
end;
fStr := Str;
fOldPosit := fPosition;
end;
end.

1543
Addons/KOLQProgBar.pas
View File

File diff suppressed because it is too large Load Diff

410
Addons/KOLRarBar.pas
View File

@ -1,410 +0,0 @@
unit KOLRarBar;
interface
uses Windows, Messages, Kol, Objects;
type
PRarBar = ^TRarBar;
TRarInfoBar = PRarBar;
TRarBar = object(TObj)
private
{ Private declarations }
FControl: PControl;
FPosition: integer;
FShowPerc: boolean;
FFont: PGraphicTool;
FLineColor,FTopColor,FSideColor1,FSideColor2,FEmptyColor1,FEmptyColor2,
FEmptyFrameColor1,FEmptyFrameColor2,FBottomFrameColor,FBottomColor,
FFilledFrameColor,FFilledColor,FFilledSideColor1,FFilledSideColor2: TColor;
TopX,TopY,Size: integer;
FMin,FMax: integer;
OldWind,NewWind: integer;
procedure SetPos(P: integer);
procedure SetMin(M: integer);
procedure SetMax(M: integer);
procedure SetFont(F: PGraphicTool);
procedure SetLineColor(C: TColor);
procedure SetTopColor(C: TColor);
procedure SetSideColor1(C: TColor);
procedure SetSideColor2(C: TColor);
procedure SetEmptyColor1(C: TColor);
procedure SetEmptyColor2(C: TColor);
procedure SetEmptyFrameColor1(C: TColor);
procedure SetEmptyFrameColor2(C: TColor);
procedure SetBottomFrameColor(C: TColor);
procedure SetBottomColor(C: TColor);
procedure SetFilledFrameColor(C: TColor);
procedure SetFilledColor(C: TColor);
procedure SetFilledSideColor1(C: TColor);
procedure SetFilledSideColor2(C: TColor);
procedure SetShowPerc(V: boolean);
protected
{ Protected declarations }
procedure NewWndProc(var Msg: TMessage);
procedure Paint;
public
destructor Destroy; virtual;
function SetPosition(X,Y: integer): PRarBar; overload;
function SetSize(X,Y: integer): PRarBar; overload;
function SetAlign(A: TControlAlign): PRarBar; overload;
{ Public declarations }
property Position: integer read FPosition write SetPos;
property Max: integer read FMax write SetMax;
property Min: integer read FMin write SetMin;
property ShowPercent: boolean read FShowPerc write SetShowPerc;
property Font: PGraphicTool read FFont write SetFont;
property LineColor: TColor read FLineColor write SetLineColor;
property TopColor: TColor read FTopColor write SetTopColor;
property SideColor1: TColor read FSideColor1 write SetSideColor1;
property SideColor2: TColor read FSideColor2 write SetSideColor2;
property EmptyColor1: TColor read FEmptyColor1 write SetEmptyColor1;
property EmptyColor2: TColor read FEmptyColor2 write SetEmptyColor2;
property EmptyFrameColor1: TColor read FEmptyFrameColor1 write SetEmptyFrameColor1;
property EmptyFrameColor2: TColor read FEmptyFrameColor2 write SetEmptyFrameColor2;
property BottomFrameColor: TColor read FBottomFrameColor write SetBottomFrameColor;
property BottomColor: TColor read FBottomColor write SetBottomColor;
property FilledFrameColor: TColor read FFilledFrameColor write SetFilledFrameColor;
property FilledColor: TColor read FFilledColor write SetFilledColor;
property FilledSideColor1: TColor read FFilledSideColor1 write SetFilledSideColor1;
property FilledSideColor2: TColor read FFilledSideColor2 write SetFilledSideColor2;
end;
function NewTRarInfoBar(AOwner: PControl): PRarBar;
implementation
function NewTRarInfoBar;
var P: PRarBar;
C: PControl;
begin
C:=pointer(_NewControl(AOwner,'STATIC',WS_VISIBLE or WS_CHILD or SS_LEFTNOWORDWRAP or SS_NOPREFIX or SS_NOTIFY,False,nil));
C.CreateWindow;
New(P,Create);
AOwner.Add2AutoFree(P);
AOwner.Add2AutoFree(C);
P.FControl:=C;
P.FFont:=NewFont;
P.FFont.Color:=clPurple;
P.FFont.FontHeight:=-11;
P.FFont.FontName:=C.Font.FontName;
P.FFont.FontStyle:=[fsBold];
P.FLineColor:=$FFE0E0;
P.FTopColor:=$FF8080;
P.FSideColor1:=$E06868;
P.FSideColor2:=$FF8080;
P.FEmptyFrameColor1:=$A06868;
P.FEmptyFrameColor2:=$BF8080;
P.FEmptyColor1:=$C06868;
P.FEmptyColor2:=$DF8080;
P.FBottomFrameColor:=$64408C;
P.FBottomColor:=$7A408C;
P.FFilledFrameColor:=$8060A0;
P.FFilledSideColor1:=$823C96;
P.FFilledSideColor2:=$8848C0;
P.FFilledColor:=$A060A0;
P.FShowPerc:=True;
P.FMin:=0;
P.FMax:=100;
P.FPosition:=0;
C.SetSize(70,180);
Result:=P;
P.OldWind:=GetWindowLong(C.Handle,GWL_WNDPROC);
P.NewWind:=integer(MakeObjectInstance(P.NewWndProc));
SetWindowLong(C.Handle,GWL_WNDPROC,P.NewWind);
end;
destructor TRarBar.Destroy;
begin
SetWindowLong(FControl.Handle,GWL_WNDPROC,OldWind);
FreeObjectInstance(Pointer(NewWind));
inherited;
end;
function TRarBar.SetPosition(X,Y: integer): PRarBar;
begin
FControl.Left:=X;
FControl.Top:=Y;
Result:=@Self;
end;
function TRarBar.SetSize(X,Y: integer): PRarBar;
begin
FControl.Width:=X;
FControl.Height:=Y;
Result:=@Self;
end;
function TRarBar.SetAlign(A: TControlAlign): PRarBar;
begin
FControl.Align:=A;
Result:=@Self;
end;
procedure TRarBar.NewWndProc;
begin
Msg.Result:=CallWindowProc(Pointer(OldWind),FControl.Handle,Msg.Msg,Msg.wParam,Msg.lParam);
case Msg.Msg of
WM_PAINT : Paint;
WM_SIZE : Paint;
WM_ACTIVATE: Paint;
end;
end;
procedure TRarBar.SetFont(F: PGraphicTool);
begin
FFont.Assign(F);
Paint;
end;
procedure TRarBar.SetMin;
begin
if M>FMax then M:=FMax;
FMin:=M;
Paint;
end;
procedure TRarBar.SetMax;
begin
if M<FMin then M:=FMin;
FMax:=M;
Paint;
end;
procedure TRarBar.SetPos;
begin
if P>FMax then P:=FMax;
FPosition:=P;
Paint;
end;
procedure TRarBar.SetLineColor;
begin
FLineColor:=C;
Paint;
end;
procedure TRarBar.SetTopColor;
begin
FTopColor:=C;
Paint;
end;
procedure TRarBar.SetSideColor1;
begin
FSideColor1:=C;
Paint;
end;
procedure TRarBar.SetSideColor2;
begin
FSideColor2:=C;
Paint;
end;
procedure TRarBar.SetEmptyColor1;
begin
FEmptyColor1:=C;
Paint;
end;
procedure TRarBar.SetEmptyColor2;
begin
FEmptyColor2:=C;
Paint;
end;
procedure TRarBar.SetEmptyFrameColor1;
begin
FEmptyFrameColor1:=C;
Paint;
end;
procedure TRarBar.SetEmptyFrameColor2;
begin
FEmptyFrameColor2:=C;
Paint;
end;
procedure TRarBar.SetBottomFrameColor;
begin
FBottomFrameColor:=C;
Paint;
end;
procedure TRarBar.SetBottomColor;
begin
FBottomColor:=C;
Paint;
end;
procedure TRarBar.SetFilledFrameColor;
begin
FFilledFrameColor:=C;
Paint;
end;
procedure TRarBar.SetFilledColor;
begin
FFilledColor:=C;
Paint;
end;
procedure TRarBar.SetFilledSideColor1;
begin
FFilledSideColor1:=C;
Paint;
end;
procedure TRarBar.SetFilledSideColor2;
begin
FFilledSideColor2:=C;
Paint;
end;
procedure TRarBar.SetShowPerc;
begin
FShowPerc:=V;
Paint;
end;
procedure TRarBar.Paint;
procedure DrawFrame(C: PCanvas);
var PP: TPoint;
begin
C.Pen.Color:=FLineColor;
C.Pen.PenWidth:=1;
C.Pen.PenStyle:=psSolid;
C.Pen.PenMode:=pmCopy;
C.MoveTo(TopX,TopY+5);
GetCurrentPositionEx(C.Handle,@PP);
C.LineTo(PP.X+15,PP.Y-5);
GetCurrentPositionEx(C.Handle,@PP);
C.LineTo(PP.X+15,PP.Y+5);
GetCurrentPositionEx(C.Handle,@PP);
C.LineTo(PP.X-15,PP.Y+5);
GetCurrentPositionEx(C.Handle,@PP);
C.LineTo(PP.X-15,PP.Y-5);
GetCurrentPositionEx(C.Handle,@PP);
C.LineTo(PP.X,PP.Y+(Size-10));
GetCurrentPositionEx(C.Handle,@PP);
C.LineTo(PP.X+15,PP.Y+5);
GetCurrentPositionEx(C.Handle,@PP);
C.LineTo(PP.X,PP.Y-(Size-10));
GetCurrentPositionEx(C.Handle,@PP);
C.MoveTo(PP.X,PP.Y+(Size-10));
GetCurrentPositionEx(C.Handle,@PP);
C.LineTo(PP.X+15,PP.Y-5);
GetCurrentPositionEx(C.Handle,@PP);
C.LineTo(PP.X,PP.Y-(Size-10));
end;
var Points: array[1..4] of TPoint;
Prog,Perc: integer;
R: real;
S: string;
PP: TPoint;
begin
TopX:=0;
TopY:=5;
Size:=FControl.Height-TopY-5;
if (Size=0) or ((FMax-FMin)=0) then
begin
Perc:=0;
Prog:=0;
end
else
begin
R:=(FPosition-FMin)/((FMax-FMin)/(Size-10));
Prog:=Round(R);
Perc:=Round(R/((Size-10)/100));
end;
if Prog<0 then Prog:=0 else
if Prog>Size-10 then Prog:=Size-10;
FControl.Canvas.Brush.Color:=FControl.Color;
FControl.Canvas.FillRect(FControl.Canvas.ClipRect);
DrawFrame(FControl.Canvas);
FControl.Canvas.Brush.Color:=FTopColor;
FControl.Canvas.FloodFill(TopX+7,TopY+5,FControl.Canvas.Pixels[TopX+(15 div 2),TopY+5],fsSurface);
FControl.Canvas.Brush.Color:=FSideColor1;
FControl.Canvas.FloodFill(TopX+1,TopY+6,FControl.Canvas.Pixels[TopX+1,TopY+6],fsSurface);
FControl.Canvas.Brush.Color:=FSideColor2;
FControl.Canvas.FloodFill(TopX+29,TopY+6,FControl.Canvas.Pixels[TopX+29,TopY+6],fsSurface);
if Prog>0 then
begin
FControl.Canvas.MoveTo(TopX,TopY+Size-5);
GetCurrentPositionEx(FControl.Canvas.Handle,@PP);
FControl.Canvas.Pen.Color:=FBottomFrameColor;
FControl.Canvas.LineTo(PP.X+15,PP.Y-5);
GetCurrentPositionEx(FControl.Canvas.Handle,@PP);
FControl.Canvas.LineTo(PP.X+15,PP.Y+5);
GetCurrentPositionEx(FControl.Canvas.Handle,@PP);
FControl.Canvas.Brush.Color:=FBottomColor;
FControl.Canvas.FloodFill(TopX+7,TopY+Size-5,FSideColor1,fsSurface);
FControl.Canvas.FloodFill(TopX+22,TopY+Size-5,FSideColor2,fsSurface);
FControl.Canvas.Brush.Color:=FFilledColor;
FControl.Canvas.Pen.Color:=FFilledFrameColor;
Points[1]:=MakePoint(TopX+15,TopY+Size-Prog);
Points[2]:=MakePoint(TopX,TopY+Size-Prog-5);
Points[3]:=MakePoint(TopX+15,TopY+Size-Prog-10);
Points[4]:=MakePoint(TopX+30,TopY+Size-Prog-5);
FControl.Canvas.Polygon(Points);
FControl.Canvas.Brush.Color:=FFilledSideColor1;
FControl.Canvas.FloodFill(TopX+1,TopY+Size-5-(Prog div 2),FSideColor1,fsSurface);
FControl.Canvas.Brush.Color:=FFilledSideColor2;
FControl.Canvas.FloodFill(TopX+29,TopY+Size-5-(Prog div 2),FSideColor2,fsSurface);
DrawFrame(FControl.Canvas);
end
else
begin
{EMPTY}
FControl.Canvas.MoveTo(TopX,TopY+Size-5);
GetCurrentPositionEx(FControl.Canvas.Handle,@PP);
FControl.Canvas.Pen.Color:=FEmptyFrameColor1;
FControl.Canvas.LineTo(PP.X+15,PP.Y-5);
GetCurrentPositionEx(FControl.Canvas.Handle,@PP);
FControl.Canvas.Pen.Color:=FEmptyFrameColor2;
FControl.Canvas.LineTo(PP.X+15,PP.Y+5);
GetCurrentPositionEx(FControl.Canvas.Handle,@PP);
DrawFrame(FControl.Canvas);
FControl.Canvas.Brush.Color:=FEmptyColor1;
FControl.Canvas.FloodFill(TopX+7,TopY+Size-5,FSideColor1,fsSurface);
FControl.Canvas.Brush.Color:=FEmptyColor2;
FControl.Canvas.FloodFill(TopX+22,TopY+Size-5,FSideColor2,fsSurface);
end;
if FShowPerc then
begin
FControl.Canvas.Brush.Color:=FControl.Color;
FControl.Canvas.Font.Assign(FFont);
S:=Int2Str(Perc)+' %';
FControl.Canvas.TextOut(TopX+33,TopY+Size-Prog-FControl.Canvas.TextHeight(S),S);
end;
end;
end.

377
Addons/KOLRarProgBar.pas
View File

@ -1,377 +0,0 @@
//////////////////////////////////////////////////////////////////////
// //
// TRarProgressBar version 1.0 //
// Description: TRarProgressBar is a component which //
// displays dual progress bar like a WinRAR //
// Author: Dimaxx //
// //
//////////////////////////////////////////////////////////////////////
unit KOLRarProgBar;
interface
uses Windows, Messages, Kol, Objects;
type
PRarProgBar =^TRarProgBar;
TRarProgressBar = PRarProgBar;
TRarProgBar = object(TObj)
private
{ Private declarations }
FControl: PControl;
FPosition1: integer;
FPosition2: integer;
FPercent1,FPercent2: integer;
FDouble: boolean;
B: PBitmap;
FLightColor1,FDarkColor,FLightColor2,FFrameColor1,FFrameColor2,
FFillColor1,FFillColor2,FBackFrameColor1,FBackFrameColor2,
FBackFillColor,FShadowColor: TColor;
TopX,TopY,SizeX,SizeY: integer;
FMin,FMax: integer;
OldWind,NewWind: integer;
procedure SetPos1(P: integer);
procedure SetPos2(P: integer);
procedure SetMin(M: integer);
procedure SetMax(M: integer);
procedure SetDouble(D: boolean);
procedure SetLightColor1(C: TColor);
procedure SetLightColor2(C: TColor);
procedure SetDarkColor(C: TColor);
procedure SetFrameColor1(C: TColor);
procedure SetFrameColor2(C: TColor);
procedure SetFillColor1(C: TColor);
procedure SetFillColor2(C: TColor);
procedure SetBackFrameColor1(C: TColor);
procedure SetBackFrameColor2(C: TColor);
procedure SetBackFillColor(C: TColor);
procedure SetShadowColor(C: TColor);
protected
{ Protected declarations }
procedure NewWndProc(var Msg: TMessage);
procedure Paint;
public
destructor Destroy; virtual;
function SetPosition(X,Y: integer): PRarProgBar; overload;
function SetSize(X,Y: integer): PRarProgBar; overload;
function SetAlign(A: TControlAlign): PRarProgBar; overload;
{ Public declarations }
property Position1: integer read FPosition1 write SetPos1;
property Position2: integer read FPosition2 write SetPos2;
property Percent1: integer read FPercent1;
property Percent2: integer read FPercent2;
property Max: integer read FMax write SetMax;
property Min: integer read FMin write SetMin;
property Double: boolean read FDouble write SetDouble;
property LightColor1: TColor read FLightColor1 write SetLightColor1;
property LightColor2: TColor read FLightColor2 write SetLightColor2;
property DarkColor: TColor read FDarkColor write SetDarkColor;
property FrameColor1: TColor read FFrameColor1 write SetFrameColor1;
property FrameColor2: TColor read FFrameColor2 write SetFrameColor2;
property FillColor1: TColor read FFillColor1 write SetFillColor1;
property FillColor2: TColor read FFillColor2 write SetFillColor2;
property BackFrameColor1: TColor read FBackFrameColor1 write SetBackFrameColor1;
property BackFrameColor2: TColor read FBackFrameColor2 write SetBackFrameColor2;
property BackFillColor: TColor read FBackFillColor write SetBackFillColor;
property ShadowColor: TColor read FShadowColor write SetShadowColor;
procedure Add1(D: integer);
procedure Add2(D: integer);
end;
function NewTRarProgressBar(AOwner: PControl): PRarProgBar;
implementation
function Bounds(ALeft,ATop,AWidth,AHeight: integer): TRect;
begin
with Result do
begin
Left:=ALeft;
Top:=ATop;
Right:=ALeft+AWidth;
Bottom:=ATop+AHeight;
end;
end;
function NewTRarProgressBar;
var P: PRarProgBar;
C: PControl;
begin
C:=pointer(_NewControl(AOwner,'STATIC',WS_VISIBLE or WS_CHILD or SS_LEFTNOWORDWRAP or SS_NOPREFIX or SS_NOTIFY,False,nil));
C.CreateWindow;
New(P,Create);
AOwner.Add2AutoFree(P);
AOwner.Add2AutoFree(C);
P.FControl:=C;
P.FMin:=0;
P.FMax:=100;
P.FPosition1:=0;
P.FPosition2:=0;
P.FDouble:=False;
P.FPercent1:=0;
P.FPercent2:=0;
P.FLightColor1:=clWhite;
P.FDarkColor:=$606060;
P.FLightColor2:=$C0FFFF;
P.FFrameColor1:=$EEE8E8;
P.FFrameColor2:=$B4D4E4;
P.FFillColor1:=$DCD6D6;
P.FFillColor2:=$A0C0D0;
P.FBackFrameColor1:=$9494B4;
P.FBackFrameColor2:=$80809E;
P.FBackFillColor:=$6E6E94;
P.FShadowColor:=$464040;
C.SetSize(204,18);
P.B:=NewBitmap(C.Width,C.Height);
Result:=P;
P.OldWind:=GetWindowLong(C.Handle,GWL_WNDPROC);
P.NewWind:=integer(MakeObjectInstance(P.NewWndProc));
SetWindowLong(C.Handle,GWL_WNDPROC,P.NewWind);
end;
destructor TRarProgBar.Destroy;
begin
SetWindowLong(FControl.Handle,GWL_WNDPROC,OldWind);
FreeObjectInstance(Pointer(NewWind));
B.Free;
inherited;
end;
function TRarProgBar.SetPosition(X,Y: integer): PRarProgBar;
begin
FControl.Left:=X;
FControl.Top:=Y;
Result:=@Self;
end;
function TRarProgBar.SetSize(X,Y: integer): PRarProgBar;
begin
FControl.Width:=X;
FControl.Height:=Y;
B.Width:=X;
B.Height:=Y;
Result:=@Self;
end;
function TRarProgBar.SetAlign(A: TControlAlign): PRarProgBar;
begin
FControl.Align:=A;
Result:=@Self;
end;
procedure TRarProgBar.NewWndProc;
begin
Msg.Result:=CallWindowProc(Pointer(OldWind),FControl.Handle,Msg.Msg,Msg.wParam,Msg.lParam);
case Msg.Msg of
WM_PAINT : Paint;
WM_SIZE : Paint;
WM_ACTIVATE: Paint;
end;
end;
procedure TRarProgBar.SetMin;
begin
if M>FMax then M:=FMax;
FMin:=M;
Paint;
end;
procedure TRarProgBar.SetMax;
begin
if M<FMin then M:=FMin;
FMax:=M;
Paint;
end;
procedure TRarProgBar.SetPos1;
begin
if FDouble then if P<FPosition2 then P:=FPosition2;
if P>FMax then P:=FMax;
FPosition1:=P;
Paint;
end;
procedure TRarProgBar.SetPos2;
begin
if FDouble then if P>FPosition1 then P:=FPosition1;
FPosition2:=P;
Paint;
end;
procedure TRarProgBar.SetDouble;
begin
FDouble:=D;
Paint;
end;
procedure TRarProgBar.SetLightColor1;
begin
FLightColor1:=C;
Paint;
end;
procedure TRarProgBar.SetLightColor2;
begin
FLightColor2:=C;
Paint;
end;
procedure TRarProgBar.SetDarkColor;
begin
FDarkColor:=C;
Paint;
end;
procedure TRarProgBar.SetFrameColor1;
begin
FFrameColor1:=C;
Paint;
end;
procedure TRarProgBar.SetFrameColor2;
begin
FFrameColor2:=C;
Paint;
end;
procedure TRarProgBar.SetFillColor1;
begin
FFillColor1:=C;
Paint;
end;
procedure TRarProgBar.SetFillColor2;
begin
FFillColor2:=C;
Paint;
end;
procedure TRarProgBar.SetBackFrameColor1;
begin
FBackFrameColor1:=C;
Paint;
end;
procedure TRarProgBar.SetBackFrameColor2;
begin
FBackFrameColor2:=C;
Paint;
end;
procedure TRarProgBar.SetBackFillColor;
begin
FBackFillColor:=C;
Paint;
end;
procedure TRarProgBar.SetShadowColor;
begin
FShadowColor:=C;
Paint;
end;
procedure TRarProgBar.Paint;
var R: real;
Prog: cardinal;
begin
TopX:=2;
TopY:=2;
SizeX:=FControl.Width-TopX-2;
SizeY:=FControl.Height-TopY-4;
if (SizeX=0) or (SizeY=0) or (FMax-FMin=0) then Exit;
///////////////////////////////////////////////////////////////////////////////
// ������ ������
///////////////////////////////////////////////////////////////////////////////
B.Canvas.Brush.BrushStyle:=bsSolid;
B.Canvas.Brush.Color:=FControl.Color;
B.Canvas.FillRect(Bounds(0,0,B.Width,B.Height));
B.Canvas.Brush.Color:=FShadowColor;
B.Canvas.FillRect(Bounds(TopX+1,TopY+2,SizeX,SizeY));
B.Canvas.Brush.Color:=FBackFillColor;
B.Canvas.FillRect(Bounds(TopX,TopY,SizeX,SizeY+1));
B.Canvas.Brush.Color:=FDarkColor;
B.Canvas.FrameRect(Bounds(TopX,TopY,SizeX,SizeY+1));
B.Canvas.Brush.Color:=FBackFrameColor1;
B.Canvas.FrameRect(Bounds(TopX,TopY,SizeX,SizeY));
B.Canvas.Brush.Color:=FBackFrameColor2;
B.Canvas.FrameRect(Bounds(TopX+1,TopY+1,SizeX-2,SizeY-2));
///////////////////////////////////////////////////////////////////////////////
// ������ ������ ���������
///////////////////////////////////////////////////////////////////////////////
R:=(FPosition1-FMin)/((FMax-FMin)/SizeX);
Prog:=Round(R);
FPercent1:=Byte(Round(R/(SizeX/100)));
if Prog<>0 then
begin
B.Canvas.Brush.Color:=FLightColor1;
B.Canvas.FillRect(Bounds(TopX,TopY,TopX+Prog-2,TopY+SizeY-2));
if Prog>1 then
begin
B.Canvas.Brush.Color:=FFillColor1;
B.Canvas.FillRect(Bounds(TopX+1,TopY+1,TopX+Prog-3,TopY+SizeY-3));
B.Canvas.Brush.Color:=FFrameColor1;
B.Canvas.FrameRect(Bounds(TopX+1,TopY+1,TopX+Prog-3,TopY+SizeY-3));
end;
B.Canvas.Brush.Color:=FDarkColor;
B.Canvas.FillRect(Bounds(TopX+Prog,TopY,1,TopY+SizeY-1));
if Prog<SizeX-1 then
begin
B.Canvas.Brush.Color:=FBackFillColor;
B.Canvas.FillRect(Bounds(TopX+Prog+1,TopY,SizeX-Prog-1,SizeY));
B.Canvas.Brush.Color:=FBackFrameColor1;
B.Canvas.FrameRect(Bounds(TopX+Prog+1,TopY,SizeX-Prog-1,SizeY));
B.Canvas.Brush.Color:=FBackFrameColor2;
B.Canvas.FrameRect(Bounds(TopX+Prog+1,TopY+1,SizeX-Prog-2,SizeY-2));
end;
end;
///////////////////////////////////////////////////////////////////////////////
// ������ ������ ���������
///////////////////////////////////////////////////////////////////////////////
if FDouble then
begin
R:=(FPosition2-FMin)/((FMax-FMin)/SizeX);
Prog:=Round(R);
FPercent2:=Byte(Round(R/(SizeX/100)));
if Prog<>0 then
begin
B.Canvas.Brush.Color:=FLightColor2;
B.Canvas.FillRect(Bounds(TopX,TopY,TopX+Prog-2,TopY+SizeY-2));
if Prog>1 then
begin
B.Canvas.Brush.Color:=FFillColor2;
B.Canvas.FillRect(Bounds(TopX+1,TopY+1,TopX+Prog-3,TopY+SizeY-3));
B.Canvas.Brush.Color:=FFrameColor2;
B.Canvas.FrameRect(Bounds(TopX+1,TopY+1,TopX+Prog-3,TopY+SizeY-3));
end;
end;
end;
FControl.Canvas.CopyRect(Bounds(0,0,FControl.Width,FControl.Height),B.Canvas,Bounds(0,0,B.Width,B.Height));
end;
procedure TRarProgBar.Add1;
begin
Inc(FPosition1,D);
Paint;
end;
procedure TRarProgBar.Add2;
begin
Inc(FPosition2,D);
Paint;
end;
end.

386
Addons/KOLRas.pas
View File

@ -1,386 +0,0 @@
{$A+}
unit KOLRas;
interface
uses
Windows, KOL, RAS;
type
PRASObj =^TRASObj;
TKOLRAS = PRASObj;
TOnErrorEvent = procedure (Sender: PRASObj; Error: Integer) of object;
TOnConnectingEvent = procedure (Sender: PRASObj; Msg: Integer; State: Integer; Error: Longint) of object;
TRASObj = object(TObj)
private
FOnConnecting: TOnConnectingEvent; // event for asynchronous dialing
FOnError: TOnErrorEvent; // error event
FRASHandle: THRasConn; // connection handle
FRASName: string; // name of the RAS service
fState: TRASConnState;
fError: longint;
fTimer: PTimer;
connecting: boolean;
function GetConnected: Boolean;
function GetParams(Server: string; var DialParams: TRasDialParams): Boolean;
function GetPassword: string;
procedure GetRASHandle;
function GetUsername: string;
procedure SetRASName( Value: string );
function GetStatusString: string;
function GetErrorString: string;
procedure OnTimer(Sender: PObj);
public
destructor Destroy; virtual; // and destroy it
procedure Connect; // make a connection
procedure DisConnect(force: boolean); // close the connection
property Connected: Boolean read GetConnected; // is service connected?
property Status: TRASConnState read fState; // current RAS state
property Error: longint read fError; // last RAS error
property RASHandle: THRASConn read fRASHandle;
property StatusString: string read GetStatusString;
property ErrorString: string read GetErrorString;
property Password: string read GetPassword; // get the password
property RASName: string read FRASName write SetRASName; // name of RAS service
property Username: string read GetUsername; // username
property OnConnecting: TOnConnectingEvent read FOnConnecting write FOnConnecting; // asynch dialing event
property OnError: TOnErrorEvent read FOnError write FOnError; // error event
end;
function GetStatString(s: longint): string;
function GetErrString(e: longint): string;
function NewRASObj: PRASObj;
function GetRASConnected(Handles: PList): PStrList; // get all existing connections
function GetRASNames: PStrList; // get all possible connections
function IsRASConnected( const r: string ): Boolean; // test if a connection is available
procedure HangUp( const RASName: string );
implementation
var RASSave: PRASObj;
CBkSave: TOnConnectingEvent;
procedure RASCallback(Msg: Integer; State: TRasConnState; Error: Longint); stdcall;
begin
if assigned(RASSave) then begin
RASSAve.fState := State;
RASSave.fError := Error;
if Assigned(CBkSave) then begin
CBkSave( RASSave, Msg, State, Error );
end;
if (Assigned(RASSave.FOnError)) and (Error<>0) then begin
RASSave.FOnError( RASSave, Error );
end;
if State = $2000 then begin
RASSave.fTimer.Enabled := True;
RASSave.connecting := false;
end;
end;
end;
function NewRASObj;
begin
New(Result, create); // create the component first
Result.FRASHandle := 0; // internal RAS handle
Result.FRASName := ''; // no default RAS name
Result.fTimer := NewTimer(1000); // watchdog timer
Result.fTimer.Enabled := True;
Result.fTimer.Enabled := False;
Result.fTimer.OnTimer := Result.OnTimer;
RASSave := Nil;
CBkSave := Nil;
end;
destructor TRASObj.Destroy;
begin
DisConnect(True);
RASSave := Nil;
CBkSave := Nil;
fTimer.Free;
inherited Destroy; // next destroy the object
end;
procedure TRASObj.Connect;
var DialParams: TRasDialParams; // local dial parameters
begin
if not Connected then begin // only if the service is not connected
if GetParams( FRASName, DialParams ) then begin // get actual dial parameters
connecting := true;
RASSave := @self; // save the object itself
CbkSave := FOnConnecting;
RasDial(nil, nil, DialParams, 0, @RASCallback, FRASHandle ); // call with a callback function
end;
end;
end;
procedure TRASObj.DisConnect;
var s: TRasConnStatus;
begin
if Connected or force then begin // only if a connection is available
if FRASHandle<>0 then begin // only if a vaild handle is available
RasHangup( FRASHandle ); // hangup the RAS service
s.dwSize := sizeof(s);
repeat
sleep(0);
until RasGetConnectStatus( FRASHandle, s ) = ERROR_INVALID_HANDLE;
FRASHandle := 0;
end;
end;
end;
function TRASObj.GetConnected: Boolean;
begin
Result := IsRASConnected( FRASName ); // test if a service with this name is established
if (Result) and (FRASHandle=0) then begin // if no handle is available
GetRASHandle; // try to read the handle
end;
end;
function TRASObj.GetParams(Server: string; var DialParams: TRasDialParams): Boolean;
var DialPassword: LongBool;
RASResult: LongInt;
begin
Result := true; // result is first vaild
FillChar( DialParams, SizeOf(TRasDialParams), 0); // clear the result record
DialParams.dwSize := Sizeof(TRasDialParams); // set the result array size
StrPCopy(DialParams.szEntryName, Server); // set the ras service name
DialPassword := true; // get the dial password
RASResult := RasGetEntryDialParams(nil, DialParams, DialPassword); // read the ras parameters
if (RASResult<>0) then begin // if the API call was not successful
Result := false; // result is not vaild
if (Assigned(FOnError)) then begin // if an error event is assigned
FOnError( @self, RASResult ); // call the error event
end;
end;
end;
function TRASObj.GetPassword: string;
var DialParams: TRasDialParams; // dial parameters for this service
begin
if GetParams( FRASName, DialParams ) then begin // if read of dial parameters was successful
Result := DialParams.szPassword; // copy the password string
end else begin // if read was not successful
Result := ''; // return an empty string
end;
end;
procedure TRASObj.GetRASHandle;
const cMaxRas = 100; // maximum number of ras services
var BufferSize: LongInt; // used for size of result buffer
RASBuffer: array[1..cMaxRas] of TRasConn; // the API result buffer itself
RASCount: LongInt; // number of found ras services
i: Integer; // loop counter
begin
FRASHandle := 0; // first no handle is available
FillChar( RASBuffer, SizeOf(RASBuffer), 0 ); // clear the API Buffer
RASBuffer[1].dwSize := SizeOf(TRasConn); // set the API buffer size for a single record
BufferSize := SizeOf(TRasConn) * cMaxRas; // calc complete buffer size
if RasEnumConnections(@RASBuffer[1], BufferSize, RASCount) = 0 then begin
for i := 1 to RASCount do begin // for all found ras services
if RASBuffer[i].szEntryName = RASName then begin // if the actual name is available
FRASHandle := RASBuffer[i].hrasconn; // save the found ras handle
end;
end;
end;
end;
function TRASObj.GetUsername: string;
var DialParams: TRasDialParams; // dial parameters for this service
begin
if GetParams( FRASName, DialParams ) then begin // if read of dial parameters was successful
Result := DialParams.szUserName; // copy the user name string
end else begin // if read was not successful
Result := ''; // return an empty string
end;
end;
function TRASObj.GetStatusString;
begin
result := GetStatString(fState);
end;
function GetStatString;
begin
result := 'unexpected status: ' + int2str(s);
case s of
0: result := '';
1: result := 'port is opened';
2: result := 'call in progress';
3: result := 'device is connected';
4: result := 'all devices is connected';
5: result := 'authentication';
6: result := 'authnotify';
7: result := 'authretry';
8: result := 'authcallback';
9: result := 'authchangepassword';
10: result := 'authproject';
11: result := 'linkspeed';
12: result := 'authack';
13: result := 'reauthenticate';
14: result := 'authenticated';
15: result := 'prepareforcallback';
16: result := 'waitformodemreset';
17: result := 'waitforcallback';
18: result := 'projected';
19: result := 'startauthentication';
20: result := 'callbackcomplete';
21: result := 'logonnetwork';
$1000: result := 'interactive';
$1001: result := 'retryauthentication';
$1002: result := 'callbacksetbycaller';
$1003: result := 'password is expired';
$2000: result := 'connected';
$2001: result := 'disconnected';
end;
end;
function TRASObj.GetErrorString;
begin
result := GetErrString(fError);
end;
function GetErrString(e: longint): string;
begin
result := 'unexpected error: ' + int2str(e);
case e of
000: result := '';
600: result := 'operation is pending';
601: result := 'invalid port handle';
608: result := 'device does not exist';
615: result := 'port not found';
619: result := 'connection is terminated';
628: result := 'port was disconnected';
629: result := 'disconnected by remote';
630: result := 'hardware failure';
631: result := 'user disconnect';
633: result := 'port is in use';
638: result := 'PPP no address assigned';
651: result := 'device error';
676: result := 'line is busy';
678: result := 'no answer';
680: result := 'no dialtone';
691: result := 'authentication failure';
718: result := 'PPP timeout';
720: result := 'PPP no CP configured';
721: result := 'PPP no responce';
732: result := 'PPP is not converging';
734: result := 'PPP LCP terminated';
735: result := 'PPP adress rejected';
738: result := 'no PPP address assigned';
742: result := 'no remote encription';
743: result := 'remote requires encription';
752: result := 'script syntax error';
777: result := 'no answer timeout';
797: result := 'modem is not found';
end;
end;
procedure TRASObj.SetRASName( Value: string );
var DialParams: TRasDialParams; // dial parameters for this service
begin
if GetParams( Value, DialParams ) then begin
FRASName := Value;
GetRASHandle; // try to read an existing handle
end;
end;
function GetRASConnected;
const cMaxRas = 100; // maximum number of ras services
var BufferSize: LongInt; // used for size of result buffer
RASBuffer: array[1..cMaxRas] of TRasConn; // the API result buffer itself
RASCount: LongInt; // number of found ras services
i: Integer; // loop counter
begin
FillChar( RASBuffer, SizeOf(RASBuffer), 0 ); // clear the API Buffer
RASBuffer[1].dwSize := SizeOf(TRasConn); // set the API buffer size for a single record
BufferSize := SizeOf(TRasConn) * cMaxRas; // calc complete buffer size
Result := NewStrList;
if RasEnumConnections(@RASBuffer[1], BufferSize, RASCount) = 0 then begin
for i := 1 to RASCount do begin // for all found ras services
Result.Add( RASBuffer[i].szEntryName ); // copy the name of the ras service
if Handles <> nil then Handles.Add(pointer(RASBuffer[i].hrasconn));
end;
end;
if assigned(RASSave) then begin
if RASSAve.FRASHandle <> 0 then begin
if RASSave.connecting then begin
i := Result.IndexOf(RASSave.FRASName);
if i = -1 then begin
i := Result.Add(RASSave.FRASName);
if Handles <> nil then Handles.Add(pointer(RASSave.FRASHandle));
end;
if Handles <> nil then Handles.Items[i] := pointer(RASSave.FRASHandle);
end;
end;
end;
end;
function GetRASNames;
const cMaxRas = 100; // maximum number of ras services
var BufferSize: LongInt; // used for size of result buffer
RASBuffer: array[1..cMaxRas] of TRasEntryName; // the API result buffer itself
RASCount: LongInt; // number of found ras services
i: Integer; // loop counter
begin
Result := Nil;
FillChar( RASBuffer, SizeOf(RASBuffer), 0 ); // clear the API Buffer
RASBuffer[1].dwSize := SizeOf(TRasEntryname); // set the API buffer size for a single record
BufferSize := SizeOf(TRasEntryName) * cMaxRas;// calc complete buffer size
if RasEnumEntries(nil, nil, @RASBuffer[1], BufferSize, RASCount) = 0 then begin
Result := NewStrList;
for i := 1 to RASCount do begin // for all found ras services
Result.Add( RASBuffer[i].szEntryName ); // copy the name of the ras service
end;
end;
end;
function IsRASConnected( const r: string ): Boolean;
var n: PStrList; // result object for connected services
i: Integer; // loop counter
p: PList;
begin
Result := false; // first the result is false
p := NewList;
n := GetRasConnected(p); // create the object for connected services
for i := 0 to n.Count - 1 do begin // for all connected services
if r = n.Items[i] then begin // if the ras name was found
Result := true; // the result is true now
Break; // break the loop, one is found
end;
end;
n.Free; // destroy the object for connected services
p.Free;
end;
procedure HangUP;
var e: PStrList;
h: PList;
i: integer;
begin
h := NewList;
e := GetRASConnected(h);
i := e.IndexOf(RASName);
if i > -1 then begin
RASHangUp(integer(h.Items[i]));
end;
e.Free;
h.Free;
end;
procedure TRASObj.OnTimer;
begin
if not connected then begin
fTimer.Enabled := False;
Disconnect(True);
if assigned(fOnConnecting) then begin
fState := $2001;
fError := 619;
fOnConnecting(@self, 0, $2001, 619);
end;
end;
end;
end.

BIN
Addons/KOLReport.dcr
View File

Binary file not shown.

1276
Addons/KOLReport.pas
View File

File diff suppressed because it is too large Load Diff

845
Addons/KOLSocket.pas
View File

@ -1,845 +0,0 @@
unit KOLSocket;
interface
uses
KOL, Windows, Messages, Winsock;
const
WM_SOCKET = WM_USER + $7000;
WM_SOCKETERROR = WM_USER + $7001;
WM_SOCKETCLOSE = WM_USER + $7002;
WM_SOCKETREAD = WM_USER + $7003;
WM_SOCKETCONNECT = WM_USER + $7004;
WM_SOCKETACCEPT = WM_USER + $7005;
WM_SOCKETWRITE = WM_USER + $7006;
WM_SOCKETOOB = WM_USER + $7007;
WM_SOCKETLISTEN = WM_USER + $7008;
WM_SOCKETLOOKUP = WM_USER + $7009;
EVENTS_DOLISTEN = FD_CLOSE OR FD_ACCEPT;
EVENTS_DOCONNECT = FD_CONNECT OR FD_CLOSE OR FD_READ;
EVENTS_SETSOCKETHANDLE = FD_READ OR FD_CLOSE OR FD_CONNECT;
MaxWord = 65535;
MinWord = 0;
c_FIRST = 1;
INVALID_SOCKET = winsock.INVALID_SOCKET;
type
TWndMethod = procedure(var Message: TMessage) of object;
PhWnd =^ThWnd;
ThWnd = object( TObj )
protected
m_hWnd: hWnd;
destructor Destroy; virtual;
public
property Handle: hWnd read m_hWnd;
end;
PAsyncSocket =^TAsyncSocket;
TKOLSocket = PAsyncSocket;
TWMSocket = record
Msg: Word;
case Integer of
0: (
SocketWParam: Word;
SocketDataSize: LongInt;
SocketNumber: Longint;
SocketAddress: PAsyncSocket);
1: (
WParamLo: Byte;
WParamHi: Byte;
SocketEvent: Word;
SocketError: Word;
ResultLo: Word;
ResultHi: Word);
2: (
WParam: Word;
TaskHandle: Word;
WordHolder: Word;
pHostStruct: Pointer);
end;
TBArray = array[0..65534] of byte;
TBufRecord = record
i: integer;
p:^TBArray;
end;
TSocketMessageEvent = procedure (SocketMessage: TWMSocket) of object;
TAsyncSocket = object( TObj )
m_SockAddr: TSockAddr;
m_Handle: TSocket;
m_hWnd: PhWnd;
fConnected: boolean;
fDNSResult: string;
fDNSHandle: integer;
FDnsBuffer: array [0..MAXGETHOSTSTRUCT] of char;
FList: PList;
FOnError: TSocketMessageEvent;
FOnLookup: TSocketMessageEvent;
FOnAccept: TSocketMessageEvent;
FOnClose: TSocketMessageEvent;
FOnConnect: TSocketMessageEvent;
FOnRead: TSocketMessageEvent;
FOnWrite: TSocketMessageEvent;
FOnListen: TSocketMessageEvent;
FOnOOB: TSocketMessageEvent;
protected
destructor Destroy; virtual;
private
function GetCount: LongInt;
function GetPortNumber: LongInt;
function GetIPAddress: String;
function ErrorTest(Evaluation: LongInt): LongInt;
procedure AllocateSocket;
procedure KillWinsockBug;
procedure SetPortNumber(NewPortNumber: LongInt);
procedure SetIPAddress(NewIPAddress: String);
procedure SetSocketHandle(NewSocketHandle: TSocket);
function GetConnected: boolean;
// Message Handlers
procedure HWndProcedure(var Message: TMessage);
procedure Message_Error(var Message: TWMSocket);
procedure Message_Lookup(var Message: TWMSocket);
procedure Message_Close(var Message: TWMSocket);
procedure Message_Accept(var Message: TWMSocket);
procedure Message_Read(var Message: TWMSocket);
procedure Message_Connect(var Message: TWMSocket);
procedure Message_Write(var Message: TWMSocket);
procedure Message_OOB(var Message: TWMSocket);
procedure Message_Listen(var Message: TWMSocket);
procedure DoReceive(Buffer: Pointer; var ReceiveLen: LongInt);
procedure DoFinal(Abort: boolean);
public
procedure ProcessMessages;
function DoGetHostByAddr(IPAddr: PChar): String;
function DoGetHostByName(Name: PChar): String;
procedure DoLookup(host: string);
procedure DoClose;
procedure DoSend(Buffer: Pointer; var SendLen: LongInt);
procedure DoListen;
procedure DoConnect;
procedure DoAccept(var AcceptSocket: PAsyncSocket);
procedure SendString(fString: String);
function ReadData(b: pointer; c: integer): integer;
function ReadLine(c: char): string; overload;
function ReadLine(c: char; t: integer): string; overload;
function ErrToStr(Err: LongInt): String;
function LocalIP: String;
function LocalPort: integer;
property SocketHandle: TSocket read m_Handle write SetSocketHandle;
property IPAddress: String read GetIPAddress write SetIPAddress;
property PortNumber: LongInt read GetPortNumber write SetPortNumber;
property Count: LongInt read GetCount;
property Connected: boolean read GetConnected;
property DNSResult: string read fDNSResult write fDNSResult;
property OnError: TSocketMessageEvent read FOnError write FOnError;
property OnLookup: TSocketMessageEvent read FOnLookup write FOnLookup;
property OnAccept: TSocketMessageEvent read FOnAccept write FOnAccept;
property OnClose: TSocketMessageEvent read FOnClose write FOnClose;
property OnConnect: TSocketMessageEvent read FOnConnect write FOnConnect;
property OnRead: TSocketMessageEvent read FOnRead write FOnRead;
property OnWrite: TSocketMessageEvent read FOnWrite write FOnWrite;
property OnOOB: TSocketMessageEvent read FOnOOB write FOnOOB;
property OnListen: TSocketMessageEvent read FOnListen write FOnListen;
end;
function NewThWnd(WndMethod: TWndMethod): PhWnd;
function NewAsyncSocket: PAsyncSocket;
var
InstanceCount: LongInt = 0;
implementation
uses objects;
function NewThWnd;
begin
New(Result, Create);
Result.m_hWnd := AllocateHWnd(WndMethod);
end; // constructor ThWnd.Create(WndMethod: TWndMethod)
destructor ThWnd.Destroy;
begin
DeallocateHWnd(m_hWnd);
inherited;
end;
function NewAsyncSocket;
var
TempWSAData: TWSAData;
begin
InstanceCount := InstanceCount + 1;
New(Result, Create);
if (InstanceCount = c_FIRST) then
Result.ErrorTest(WSAStartup($101, TempWSAData));
Result.KillWinsockBug;
Result.m_Handle := INVALID_SOCKET;
Result.m_SockAddr.sin_family := AF_INET;
Result.m_SockAddr.sin_addr.s_addr := INet_Addr('0.0.0.0');
Result.PortNumber := 0;
Result.FList := NewList;
Result.m_hWnd := NewThWnd(Result.HWndProcedure);
end; // constructor TAsyncSocket.Create
function TAsyncSocket.GetCount;
var i: integer;
t:^TBufRecord;
begin
result := 0;
for i := 0 to FList.Count - 1 do begin
t := FList.Items[i];
result := result + t^.i;
end;
end;
function TAsyncSocket.ReadData;
var n,
r: integer;
t:^TBufRecord;
u:^TBufRecord;
a:^TBArray;
begin
if FList.count = 0 then begin
result := 0;
exit;
end;
n := 0;
a := b;
while (n < c) and (n < count) do begin
r := c - n;
t := FList.Items[0];
if r > t^.i then r := t^.i;
move(t^.p^, a^[n], r);
n := n + r;
if r = t^.i then begin
FreeMem(t^.p, t^.i);
FreeMem(t, SizeOf(TBufRecord));
FList.Delete(0);
end else begin
GetMem(u, SizeOf(TBufRecord));
u^.i := t^.i - r;
GetMem(u^.p, u^.i);
move(t^.p^[r], u^.p^, u^.i);
FreeMem(t^.p, t^.i);
FreeMem(t, SizeOf(TBufRecord));
FList.Items[0] := u;
end;
end;
result := n;
end;
function TAsyncSocket.ReadLine(c: char): string;
var i,
n,
j: integer;
t:^TBufRecord;
s: string;
begin
result := '';
n := 0;
if count = 0 then exit;
for i := 0 to FList.Count - 1 do begin
t := FList.Items[i];
for j := 0 to t^.i - 1 do begin
inc(n);
if chr(t^.p^[j]) = c then begin
if n > 1 then begin
setlength(s, n - 1);
ReadData(@s[1], n - 1);
ReadData(@n , 1);
result := s;
end else begin
ReadData(@n , 1);
result := '';
end;
exit;
end;
end;
end;
end;
function TAsyncSocket.ReadLine(c: char; t: integer): string;
var tt: longint;
Msg: tagMSG;
begin
result := '';
tt := gettickcount;
while (result = '') and (longint(gettickcount) < tt + t * 1000) do begin
if PeekMessage(Msg, m_hWnd.m_hWnd, 0, 0, PM_REMOVE) then begin
DispatchMessage(Msg);
end;
result := ReadLine(c);
if m_Handle = INVALID_SOCKET then exit;
end;
end;
function TAsyncSocket.GetIPAddress: String;
begin
Result := INet_NToA(m_SockAddr.sin_addr);
end; // function TAsyncSocket.GetIPAddress: String
function TAsyncSocket.GetPortNumber: LongInt;
begin
Result := NToHS(m_SockAddr.sin_port);
end; // function TAsyncSocket.GetPortNumber: Word
procedure TAsyncSocket.AllocateSocket;
begin
if (m_Handle = INVALID_SOCKET) then
begin
m_Handle := ErrorTest(socket(AF_INET, SOCK_STREAM, 0));
end; // if (m_Handle = INVALID_SOCKET) then
end; // procedure TAsyncSocket.AllocateSocket
procedure TAsyncSocket.SetSocketHandle(NewSocketHandle: TSocket);
begin
DoFinal(True);
m_Handle := NewSocketHandle;
ErrorTest(WSAAsyncSelect(m_Handle, m_hWnd.Handle, WM_SOCKET, EVENTS_SETSOCKETHANDLE));
end; // procedure TAsyncSocket.SetSocketHandle(NewSocketHandle: TSocket)
function TAsyncSocket.GetConnected;
begin
result := fConnected;
end;
function TAsyncSocket.ErrorTest(Evaluation: LongInt): LongInt;
var
TempMessage: TWMSocket;
begin
if ((Evaluation = SOCKET_ERROR) OR (Evaluation = INVALID_SOCKET)) then
begin
TempMessage.Msg := WM_SOCKETERROR;
TempMessage.SocketError := WSAGetLastError;
TempMessage.SocketNumber := m_Handle;
TempMessage.SocketAddress := @self;
Message_Error(TempMessage);
Result := Evaluation;
end // if ((Evaluation = SOCKET_ERROR) OR (Evaluation = INVALID_SOCKET)) then
else
Result := Evaluation;
end; // function ErrorTest(Evaluation: LongInt): LongInt;
procedure TAsyncSocket.KillWinsockBug;
var
Addr: Integer;
begin
Addr := 0;
// For an unknown reason, if a call is made to GetHostByName and it should
// fail, the following call to GetHostByAddr will not fail, but return '>'
// in the place of the host name. This clears the problem up.
GetHostByName('');
GetHostByAddr(@Addr, SizeOf(Integer), PF_INET);
GetHostByName('');
end;
procedure TAsyncSocket.SetIPAddress(NewIPAddress: String);
var
pTempHostEnt: PHostEnt;
begin
m_SockAddr.sin_addr.s_addr := INet_Addr(PChar(NewIPAddress));
if (m_SockAddr.sin_addr.s_addr = u_long(INADDR_NONE)) then
begin
pTempHostEnt := GetHostByName(PChar(NewIPAddress));
if (pTempHostEnt <> Nil) then
m_SockAddr.sin_addr.s_addr := PInAddr(pTempHostEnt^.h_addr_list^)^.s_addr;
end;
end; // procedure TAsyncSocket.SetIPAddress(NewIPAddress: String)
procedure TAsyncSocket.SetPortNumber(NewPortNumber: LongInt);
begin
if ((NewPortNumber > 0) AND (NewPortNumber <= MaxWord)) then
m_SockAddr.sin_port := HToNS(NewPortNumber);
end; // procedure TAsyncSocket.SetPortNumber(NewPortNumber: Word)
procedure TAsyncSocket.DoReceive(Buffer: Pointer; var ReceiveLen: LongInt);
begin
ReceiveLen := recv(m_Handle, Buffer^, ReceiveLen, 0);
ErrorTest(ReceiveLen);
end; // TAsyncSocket.DoReceive(Buffer: Pointer; BufferLen: LongInt)
procedure TAsyncSocket.DoSend(Buffer: Pointer; var SendLen: LongInt);
begin
SendLen := send(m_Handle, Buffer^, SendLen, 0);
ErrorTest(SendLen);
end; // procedure TAsyncSocket.DoSend(Buffer: Pointer; BufferLen: LongInt)
procedure TAsyncSocket.DoLookup;
var
IPAddr : TInAddr;
begin
if Host = '' then begin
Exit;
end;
{ Cancel any pending lookup }
if FDnsHandle <> 0 then
WSACancelAsyncRequest(FDnsHandle);
FDnsResult := '';
IPAddr.S_addr := Inet_addr(PChar(Host));
if IPAddr.S_addr <> u_long(INADDR_NONE) then begin
FDnsResult := inet_ntoa(IPAddr);
{ TriggerDnsLookupDone(0);}
Exit;
end;
FDnsHandle := WSAAsyncGetHostByName(m_hWnd.Handle,
WM_SOCKETLOOKUP,
@Host[1],
@FDnsBuffer,
SizeOf(FDnsBuffer));
if FDnsHandle = 0 then begin
ErrorTest(WSAGetLastError);
Exit;
end;
end;
procedure TAsyncSocket.DoClose;
begin
DoFinal(True);
end;
procedure TAsyncSocket.DoFinal;
var
TempMessage: TWMSocket;
begin
if (m_Handle <> INVALID_SOCKET) then begin
if not Abort then begin
ProcessMessages;
end;
TempMessage.Msg := WM_SOCKETCLOSE;
TempMessage.SocketNumber := m_Handle;
TempMessage.SocketAddress := @self;
Message_Close(TempMessage);
ErrorTest(closesocket(m_Handle));
m_Handle := INVALID_SOCKET;
end;
end;
procedure TAsyncSocket.DoAccept(var AcceptSocket: PAsyncSocket);
var
TempSize: Integer;
TempSock: TSocket;
TempAddr: TSockAddrIn;
begin
TempSize := SizeOf(TSockAddr);
TempSock := accept(m_Handle, @TempAddr, @TempSize);
AcceptSocket.m_SockAddr := TempAddr;
if (ErrorTest(TempSock) <> INVALID_SOCKET) then
AcceptSocket.SocketHandle := TempSock;
end; // procedure TAsyncSocket.DoAccept(var AcceptSocket: TAsyncSocket)
procedure TAsyncSocket.DoListen;
var
TempMessage: TWMSocket;
begin
DoClose;
AllocateSocket;
if
(ErrorTest(WSAAsyncSelect(m_Handle, m_hWnd.Handle, WM_SOCKET, EVENTS_DOLISTEN))
<> SOCKET_ERROR) AND
(ErrorTest(bind(m_Handle, m_SockAddr, SizeOf(TSockAddr))) <> SOCKET_ERROR) AND
(ErrorTest(listen(m_Handle, 5)) <> SOCKET_ERROR) then
begin
TempMessage.Msg := WM_SOCKETLISTEN;
TempMessage.SocketNumber := m_Handle;
TempMessage.SocketAddress := @self;
Message_Listen(TempMessage);
end
else
DoClose;
end; // procedure TAsyncSocket.DoListen
procedure TAsyncSocket.DoConnect;
var
TempResult: LongInt;
begin
DoClose;
AllocateSocket;
ErrorTest(WSAAsyncSelect(m_Handle, m_hWnd.Handle, WM_SOCKET, EVENTS_DOCONNECT));
TempResult := connect(m_Handle, m_SockAddr, SizeOf(TSockAddr));
if ((TempResult = SOCKET_ERROR) AND (WSAGetLastError <> WSAEWOULDBLOCK)) then
ErrorTest(SOCKET_ERROR);
end; // procedure TAsyncSocket.DoConnect
procedure TAsyncSocket.SendString;
var
L: LongInt;
begin
L := Length(fString);
DoSend(PChar(fString), L);
end;
function TAsyncSocket.DoGetHostByName(Name: PChar): String;
var
pTempHostEnt: PHostEnt;
begin
pTempHostEnt := GetHostByName(Name);
if (pTempHostEnt <> Nil) then
Result := inet_ntoa(pInAddr(pTempHostEnt^.h_addr_list^)^)
else
Result := '';
end;
procedure TAsyncSocket.ProcessMessages;
var Msg: TMsg;
begin
while PeekMessage(Msg, m_hWnd.m_hWnd, WM_SOCKET, WM_SOCKETLOOKUP, PM_REMOVE) do begin
DispatchMessage(Msg);
end;
end;
function TAsyncSocket.DoGetHostByAddr(IPAddr: PChar): String;
var
pTempHostEnt: PHostEnt;
TempAddr: LongInt;
begin
TempAddr := INet_Addr(IPAddr);
pTempHostEnt := GetHostByAddr(@TempAddr, SizeOf(TempAddr), PF_INET);
if (pTempHostEnt <> Nil) then
Result := pTempHostEnt^.h_name
else
Result := '';
end;
procedure TAsyncSocket.HWndProcedure(var Message: TMessage);
var
TempMessage: TWMSocket;
begin
case Message.Msg of
WM_SOCKETLOOKUP:
begin
TempMessage.Msg := WM_SOCKETLOOKUP;
TempMessage.SocketNumber := m_Handle;
TempMessage.SocketAddress := @self;
Message_Lookup(TempMessage);
end;
WM_SOCKET:
begin
if (Message.LParamHi > WSABASEERR) then
begin
WSASetLastError(Message.LParamHi);
ErrorTest(SOCKET_ERROR);
end // if (Message.LParamHi > WSABASEERR) then
else
begin
case Message.LParamLo of
FD_READ:
begin
TempMessage.SocketDataSize := 0;
ErrorTest(IOCtlSocket(m_Handle, FIONREAD, TempMessage.SocketDataSize));
TempMessage.Msg := WM_SOCKETREAD;
TempMessage.SocketNumber := m_Handle;
TempMessage.SocketAddress := @self;
Message_Read(TempMessage);
end; // FD_READ
FD_CLOSE:
begin
DoFinal(False);
end; // FD_CLOSE
FD_CONNECT:
begin
TempMessage.Msg := WM_SOCKETCONNECT;
TempMessage.SocketNumber := m_Handle;
TempMessage.SocketAddress := @self;
Message_Connect(TempMessage);
end; // FD_CONNECT
FD_ACCEPT:
begin
TempMessage.Msg := WM_SOCKETACCEPT;
TempMessage.SocketNumber := m_Handle;
TempMessage.SocketAddress := @self;
Message_Accept(TempMessage);
end; // FD_ACCEPT
FD_WRITE:
begin
TempMessage.Msg := WM_SOCKETWRITE;
TempMessage.SocketNumber := m_Handle;
TempMessage.SocketAddress := @self;
Message_Write(TempMessage);
end; // FD_WRITE
FD_OOB:
begin
TempMessage.Msg := WM_SOCKETOOB;
TempMessage.SocketNumber := m_Handle;
TempMessage.SocketAddress := @self;
Message_OOB(TempMessage);
end; // FD_OOB
end; // case Message.LParamLo of
end // else (if (Message.LParamHi > WSABASEERR) then)
end; // WM_SOCKET:
else
Message.Result := DefWindowProc(m_hWnd.m_hWnd, Message.Msg, Message.WParam, Message.LParam);
end; // case Message.Msg of
end; // procedure TAsyncSocket.HWndProcedure(var Message: TMessage)
procedure TAsyncSocket.Message_Error(var Message: TWMSocket);
begin
if Assigned(FOnError) then FOnError(Message)
else
MessageBox(HWND_DESKTOP, PChar(ErrToStr(Message.SocketError) + ' on socket ' +
Int2Str(Message.SocketNumber)), 'Message_Error', MB_OK);
end; // procedure TAsyncSocket.Message_Error(var Message: TWMSocket)
procedure TAsyncSocket.Message_Lookup(var Message: TWMSocket);
var p: PHostEnt;
begin
p := @fDNSBuffer;
fDNSResult := p.h_name;
if Assigned(FOnLookup) then FOnLookup(Message)
else
MessageBox(HWND_DESKTOP, PChar('WM_SOCKETLOOKUP on socket ' + Int2Str(Message.SocketNumber)),
'Message_Lookup', MB_OK);
end; // procedure TAsyncSocket.Message_LookUp(var Message: TWMSocket)
procedure TAsyncSocket.Message_Close(var Message: TWMSocket);
begin
fConnected := False;
if Assigned(FOnClose) then FOnClose(Message)
else
MessageBox(HWND_DESKTOP, PChar('WM_SOCKETCLOSE on socket ' + Int2Str(Message.SocketNumber)),
'Message_Close', MB_OK);
end; // procedure TAsyncSocket.Message_Close(var Message: TWMSocket)
procedure TAsyncSocket.Message_Accept(var Message: TWMSocket);
begin
fConnected := True;
if Assigned(FOnAccept) then FOnAccept(Message)
else
MessageBox(HWND_DESKTOP, PChar('WM_SOCKETACCEPT on socket ' + Int2Str(Message.SocketNumber)),
'Message_Accept', MB_OK);
end; // procedure TAsyncSocket.Message_Accept(var Message: TWMSocket)
procedure TAsyncSocket.Message_Read(var Message: TWMSocket);
var t:^TBufRecord;
begin
if Message.SocketDataSize > 0 then begin
fConnected := True;
GetMem(t, sizeof(TBufRecord));
t^.i := Message.SocketDataSize;
GetMem(t^.p, t^.i);
DoReceive(t^.p, t^.i);
FList.Add(t);
end;
if Assigned(FOnRead) then FOnRead(Message)
else
MessageBox(HWND_DESKTOP, PChar('WM_SOCKETREAD on socket ' + Int2Str(Message.SocketNumber)),
'Message_Read', MB_OK);
end; // procedure TAsyncSocket.Message_Read(var Message: TWMSocket)
procedure TAsyncSocket.Message_Connect(var Message: TWMSocket);
begin
fConnected := True;
if Assigned(FOnConnect) then FOnConnect(Message)
else
MessageBox(HWND_DESKTOP, PChar('WM_SOCKETCONNECT on socket ' + Int2Str(Message.SocketNumber)),
'Message_Connect', MB_OK);
end; // procedure TAsyncSocket.Message_Connect(var Message: TWMSocket)
procedure TAsyncSocket.Message_Write(var Message: TWMSocket);
begin
fConnected := True;
if Assigned(FOnWrite) then FOnWrite(Message)
else
MessageBox(HWND_DESKTOP, PChar('WM_SOCKETWRITE on socket ' + Int2Str(Message.SocketNumber)),
'Message_Write', MB_OK);
end; // procedure TAsyncSocket.Message_Write(var Message: TWMSocket)
procedure TAsyncSocket.Message_OOB(var Message: TWMSocket);
begin
if Assigned(FOnOOB) then FOnOOB(Message)
else
MessageBox(HWND_DESKTOP, PChar('WM_SOCKETOOB on socket ' + Int2Str(Message.SocketNumber)),
'Message_OOB', MB_OK);
end; // procedure TAsyncSocket.Message_OOB(var Message: TWMSocket)
procedure TAsyncSocket.Message_Listen(var Message: TWMSocket);
begin
if Assigned(FOnListen) then FOnListen(Message)
else
MessageBox(HWND_DESKTOP, PChar('WM_SOCKETLISTEN on socket ' + Int2Str(Message.SocketNumber)),
'Message_Listen', MB_OK);
end; // procedure TAsyncSocket.Message_Listen(var Message: TWMSocket)
destructor TAsyncSocket.Destroy;
var t:^TBufRecord;
i: integer;
begin
DoClose;
if (InstanceCount = c_FIRST) then
ErrorTest(WSACleanup);
m_hWnd.Free;
for i := 0 to FList.Count - 1 do begin
t := FList.Items[i];
FreeMem(t^.p, t^.i);
FreeMem(t, SizeOf(TBufRecord));
end;
FList.Free;
InstanceCount := InstanceCount - 1;
inherited;
end;
function TAsyncSocket.ErrToStr(Err: LongInt): String;
begin
case Err of
WSAEINTR:
Result := 'WSAEINTR';
WSAEBADF:
Result := 'WSAEBADF';
WSAEACCES:
Result := 'WSAEACCES';
WSAEFAULT:
Result := 'WSAEFAULT';
WSAEINVAL:
Result := 'WSAEINVAL';
WSAEMFILE:
Result := 'WSAEMFILE';
WSAEWOULDBLOCK:
Result := 'WSAEWOULDBLOCK';
WSAEINPROGRESS:
Result := 'WSAEINPROGRESS';
WSAEALREADY:
Result := 'WSAEALREADY';
WSAENOTSOCK:
Result := 'WSAENOTSOCK';
WSAEDESTADDRREQ:
Result := 'WSAEDESTADDRREQ';
WSAEMSGSIZE:
Result := 'WSAEMSGSIZE';
WSAEPROTOTYPE:
Result := 'WSAEPROTOTYPE';
WSAENOPROTOOPT:
Result := 'WSAENOPROTOOPT';
WSAEPROTONOSUPPORT:
Result := 'WSAEPROTONOSUPPORT';
WSAESOCKTNOSUPPORT:
Result := 'WSAESOCKTNOSUPPORT';
WSAEOPNOTSUPP:
Result := 'WSAEOPNOTSUPP';
WSAEPFNOSUPPORT:
Result := 'WSAEPFNOSUPPORT';
WSAEAFNOSUPPORT:
Result := 'WSAEAFNOSUPPORT';
WSAEADDRINUSE:
Result := 'WSAEADDRINUSE';
WSAEADDRNOTAVAIL:
Result := 'WSAEADDRNOTAVAIL';
WSAENETDOWN:
Result := 'WSAENETDOWN';
WSAENETUNREACH:
Result := 'WSAENETUNREACH';
WSAENETRESET:
Result := 'WSAENETRESET';
WSAECONNABORTED:
Result := 'WSAECONNABORTED';
WSAECONNRESET:
Result := 'WSAECONNRESET';
WSAENOBUFS:
Result := 'WSAENOBUFS';
WSAEISCONN:
Result := 'WSAEISCONN';
WSAENOTCONN:
Result := 'WSAENOTCONN';
WSAESHUTDOWN:
Result := 'WSAESHUTDOWN';
WSAETOOMANYREFS:
Result := 'WSAETOOMANYREFS';
WSAETIMEDOUT:
Result := 'WSAETIMEDOUT';
WSAECONNREFUSED:
Result := 'WSAECONNREFUSED';
WSAELOOP:
Result := 'WSAELOOP';
WSAENAMETOOLONG:
Result := 'WSAENAMETOOLONG';
WSAEHOSTDOWN:
Result := 'WSAEHOSTDOWN';
WSAEHOSTUNREACH:
Result := 'WSAEHOSTUNREACH';
WSAENOTEMPTY:
Result := 'WSAENOTEMPTY';
WSAEPROCLIM:
Result := 'WSAEPROCLIM';
WSAEUSERS:
Result := 'WSAEUSERS';
WSAEDQUOT:
Result := 'WSAEDQUOT';
WSAESTALE:
Result := 'WSAESTALE';
WSAEREMOTE:
Result := 'WSAEREMOTE';
WSASYSNOTREADY:
Result := 'WSASYSNOTREADY';
WSAVERNOTSUPPORTED:
Result := 'WSAVERNOTSUPPORTED';
WSANOTINITIALISED:
Result := 'WSANOTINITIALISED';
WSAHOST_NOT_FOUND:
Result := 'WSAHOST_NOT_FOUND';
WSATRY_AGAIN:
Result := 'WSATRY_AGAIN';
WSANO_RECOVERY:
Result := 'WSANO_RECOVERY';
WSANO_DATA:
Result := 'WSANO_DATA';
else Result := 'UNDEFINED WINSOCK ERROR';
end; // case Err of
end; // function TAsyncSocket.ErrToStr(Err: LongInt): String
function TAsyncSocket.LocalIP;
var Name: TSockAddrIn;
len: integer;
begin
GetSockName(m_Handle, Name, len);
Result := int2str(ord(Name.sin_addr.S_un_b.s_b1)) + '.' +
int2str(ord(Name.sin_addr.S_un_b.s_b2)) + '.' +
int2str(ord(Name.sin_addr.S_un_b.s_b3)) + '.' +
int2str(ord(Name.sin_addr.S_un_b.s_b4));
end;
function TAsyncSocket.LocalPort;
var Name: TSockAddrIn;
len: integer;
err: integer;
Tmp: TWMSocket;
begin
Result := 0;
err := GetSockName(m_Handle, Name, len);
if err = 0 then begin
Result := NToHS(Name.sin_port);
end else begin
Tmp.Msg := WM_SOCKETERROR;
Tmp.SocketError := WSAGetLastError;
Tmp.SocketNumber := m_Handle;
Tmp.SocketAddress := @self;
Message_Error(Tmp);
end;
end;
end.

4
Addons/KOLZLibBzip.pas
View File

@ -145,7 +145,7 @@ function gZipCompressStream(inStream, outStream: PStream; level: TZCompressionLe
function gZipDecompressStreamHeader(inStream: PStream; var gzHdr: TgzipHeader): Integer;
function gZipDecompressStreamBody(inStream, outStream: PStream; const aCheckCRC: Boolean = True): Integer;
function gZipDecompressStream(inStream, outStream: PStream; var gzHdr: TgzipHeader): Integer;
function gZipDecompressString(const S: String; const useheaders: Boolean = True; const aCheckCRC: Boolean = True): String;
function gZipDecompressString(const S: AnsiString; const useheaders: Boolean = True; const aCheckCRC: Boolean = True): AnsiString;
{*******************************************************}
{ }
@ -1643,7 +1643,7 @@ begin
Result := gZipDecompressStreamBody(inStream, outStream);
end;
function gZipDecompressString(const S: String; const useheaders: Boolean = True; const aCheckCRC: Boolean = True): String;
function gZipDecompressString(const S: AnsiString; const useheaders: Boolean = True; const aCheckCRC: Boolean = True): AnsiString;
var
Rslt: Integer;
gzHdr: TgzipHeader;

264
Addons/ListEdit.pas
View File

@ -1,264 +0,0 @@
unit ListEdit;
interface
uses KOL, Windows, Messages, objects;
const
WM_JUSTFREE = WM_USER + 51;
WM_EDITFREE = WM_USER + 52;
WM_DBLCLICK = WM_USER + 53;
WM_ROWCHANG = WM_USER + 54;
type
PListEdit =^TListEdit;
TKOLListEdit = PControl;
TListEdit = object(Tobj)
EList: PList;
Enter: boolean;
LView: PControl;
TabSave: boolean;
TabStrt: boolean;
OldWind: longint;
NewWind: longint;
CurEdit: integer;
destructor destroy; virtual;
procedure SetEvents(LV: PControl);
procedure NewWndProc(var Msg: TMessage);
procedure LVPaint;
procedure LVDblClk;
procedure LVChange(Store: boolean);
procedure PostFree(var Key: integer);
procedure EDChar(Sender: PControl; var Key: integer; Sh: Cardinal);
procedure EDPres(Sender: PControl; var Key: integer; Sh: Cardinal);
procedure EDentr(Sender: PObj);
end;
function NewListEdit(AParent: PControl; Style: TListViewStyle; Options: TListViewOptions;
ImageListSmall, ImageListNormal, ImageListState: PImageList): PControl;
implementation
function NewListEdit;
var p: PListEdit;
begin
Result := NewListView(AParent, Style, Options, ImageListSmall, ImageListNormal, ImageListState);
Result.CreateWindow;
New(p, create);
AParent.Add2AutoFree(p);
p.LView := Result;
p.SetEvents(PControl(Result));
end;
destructor TListEdit.destroy;
begin
LVChange(False);
EList.Free;
SetWindowLong(LView.Handle, GWL_WNDPROC, OldWind);
FreeObjectInstance(Pointer(NewWind));
inherited;
end;
procedure TListEdit.SetEvents;
begin
EList := NewList;
Enter := False;
TabStrt := False;
OldWind := GetWindowLong(LV.Handle, GWL_WNDPROC);
NewWind := LongInt(MakeObjectInstance(NewWndProc));
SetWindowLong(LV.Handle, GWL_WNDPROC, NewWind);
end;
procedure TListEdit.NewWndProc;
var e: boolean;
begin
e := EList.Count > 0;
case Msg.Msg of
WM_LBUTTONDOWN:
begin
LVChange(True);
CurEdit := 0;
if e then PostMessage(LView.Handle, WM_DBLCLICK, 0, 0);
end;
WM_LBUTTONDBLCLK:
begin
LVDblClk;
end;
WM_KEYDOWN:
begin
if Msg.WParam = 13 then begin
LVDblClk;
end else
{ if Msg.WParam = 27 then begin
LVChange(False);
end else begin
LVChange(True);
if e then PostMessage(LView.Handle, WM_DBLCLICK, 0, 0);
end;}
end;
WM_NCPAINT:
begin
LVPaint;
end;
WM_JUSTFREE:
begin
LVChange(Msg.WParam <> 27);
end;
WM_EDITFREE:
begin
LVChange(Msg.WParam <> 27);
if e then PostMessage(LView.Handle, WM_DBLCLICK, 0, 0);
end;
WM_DBLCLICK:
begin
LVDblClk;
end;
WM_PAINT:
begin
LVPaint;
end;
end;
Msg.Result := CallWindowProc(Pointer(OldWind), LView.Handle, Msg.Msg, Msg.wParam, Msg.lParam);
end;
procedure TListEdit.LVPaint;
var i: integer;
r: TRect;
l: integer;
e: PControl;
p: TPoint;
begin
with LView^ do begin
SendMessage(Handle, WM_SETFONT, Font.Handle, 0);
l := 0;
p := LVItemPos[0];
for i := 0 to EList.Count - 1 do begin
r := LVItemRect(LVCurItem, lvipBounds);
r.Left := l + p.X;
r.Right := l + LVColWidth[i] + p.X;
Dec(r.Top);
Inc(r.Bottom);
e := EList.Items[i];
e.BoundsRect := r;
l := l + LVColWidth[i];
end;
end;
end;
procedure TListEdit.LVDblClk;
var i: integer;
e: PControl;
r: TRect;
l: integer;
a: PControl;
p: TPoint;
o: TPoint;
begin
with LView^ do begin
if EList.Count <> 0 then LVChange(True);
if enter then exit;
enter := true;
l := 0;
a := nil;
GetCursorPos(p);
p := Screen2Client(p);
o := LVItemPos[0];
for i := 0 to LVColCount - 1 do begin
r := LVItemRect(LVCurItem, lvipBounds);
r.Left := l + o.X;
r.Right := l + LVColWidth[i] + o.X;
l := l + LVColWidth[i];
Dec(r.Top);
Inc(r.Bottom);
e := NewEditBox(LView, []);
EList.Add(e);
e.BoundsRect := r;
e.DoubleBuffered := True;
e.Tabstop := True;
e.Font.FontHeight := LView.Font.FontHeight;
e.Font.FontCharset := 204;
e.Text := LVItems[LVCurItem, i];
e.OnKeyDown := EDChar;
e.OnKeyUp := EDPres;
e.OnEnter := EDEntr;
e.Show;
if a = nil then a := e;
if (CurEdit <> 0) then
if (EList.Count = CurEdit) then a := e else else
if (r.Left <= p.x) and (r.Right >= p.x) then
a := e;
end;
if a <> nil then a.Focused := True;
TabSave := TabStop;
TabStop := False;
TabStrt := True;
enter := false;
end;
end;
procedure TListEdit.LVChange;
var e: PControl;
i: integer;
g: boolean;
begin
with LView^ do begin
if enter then exit;
enter := true;
g := False;
for i := 0 to EList.Count - 1 do begin
e := EList.Items[i];
if Store then begin
g := g or (LVItems[LVCurItem, i] <> e.Text);
LVItems[LVCurItem, i] := e.Text;
end;
if e.Focused then CurEdit := i + 1;
e.Free;
end;
EList.Clear;
enter := false;
if TabStrt then TabStop := TabSave;
if g then
SendMessage(Parent.Handle, WM_ROWCHANG, LVCurItem, 0);
end;
end;
procedure TListEdit.PostFree;
begin
with LView^ do begin
if Key = 27 then
PostMessage(Handle, WM_JUSTFREE, key, 0);
if Key = 13 then
PostMessage(Handle, WM_EDITFREE, key, 0);
if ((key = 40) and (LView.LVCurItem < LView.LVCount - 1)) or
((key = 38) and (LView.LVCurItem > 0)) then begin
PostMessage(Handle, WM_EDITFREE, key, 0);
PostMessage(Handle, wm_keydown, Key, 0);
PostMessage(Handle, wm_keyup, Key, 0);
end;
end;
end;
procedure TListEdit.EDChar;
begin
case key of
13,
27,
38,
40: PostFree(key);
end;
end;
procedure TListEdit.EDPres;
begin
case key of
38,
40: key := 0;
end;
end;
procedure TListEdit.EDentr;
begin
PControl(Sender).SelectAll;
end;
end.

104
Addons/MCKPageSetup.pas
View File

@ -1,104 +0,0 @@
unit mckPageSetup;
interface
uses
KOL,KOLPageSetupDialog,Windows, Classes,Graphics,
mirror,mckObjs ;
type
TKOLPageSetupDialog = class(TKOLObj)
private
fOptions : TPageSetupOptions;
fAlwaysReset : Boolean;
protected
function AdditionalUnits: string; override;
procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override;
procedure SetOptions(const Value : TPageSetupOptions);
procedure SetAlwaysReset(const Value : Boolean);
public
constructor Create( AOwner: TComponent ); override;
destructor Destroy;override;
published
property Options : TPageSetupOptions read fOptions write SetOptions;
property AlwaysReset : Boolean read fAlwaysReset write SetAlwaysReset;
end;
procedure Register;
implementation
{$R *.dcr}
constructor TKOLPageSetupDialog.Create( AOwner: TComponent );
begin
inherited Create(Aowner);
fAlwaysReset := false;
fOptions := [psdMargins,psdOrientation,psdSamplePage,psdPaperControl,psdPrinterControl];
end;
destructor TKOLPageSetupDialog.Destroy;
begin
inherited Destroy;
end;
procedure TKOLPageSetupDialog.SetAlwaysReset(const Value: Boolean);
begin
fAlwaysReset := Value;
Change;
end;
procedure TKOLPageSetupDialog.SetOptions(const Value : TPageSetupOptions);
begin
fOptions := Value;
Change;
end;
function TKOLPageSetupDialog.AdditionalUnits;
begin
Result := ', KOLPageSetupDialog';
end;
procedure TKOLPageSetupDialog.SetupFirst(SL: TStringList; const AName,
AParent, Prefix: String);
var
s : String;
begin
if (psdMargins in fOptions) then s := s + ',psdMargins';
if (psdOrientation in fOptions) then s := s + ',psdOrientation';
if (psdSamplePage in fOptions) then s := s + ',psdSamplePage';
if (psdPaperControl in fOptions) then s := s + ',psdPaperControl';
if (psdPrinterControl in fOptions) then s := s + ',psdPrinterControl';
if (psdHundredthsOfMillimeters in fOptions) then s := s + ',psdHundredthsOfMillimeters';
if (psdThousandthsOfInches in fOptions) then s := s + ',psdThousandthsOfInches';
if (psdUseMargins in fOptions) then s := s + ',psdUseMargins';
if (psdUseMinMargins in fOptions) then s := s + ',psdUseMinMargins';
if (psdWarning in fOptions) then s := s + ',psdWarning';
if (psdHelp in fOptions) then s := s + ',psdHelp';
if (psdReturnDC in fOptions) then s:= s + ',psdReturnDC';
if s <> '' then
if s[1] = ',' then s[1] := Chr(32);
SL.Add(Prefix + AName + ' := NewPageSetupDialog(' + AParent + ',[' + s + ']);');
if fAlwaysReset then SL.Add(Prefix + AName + '.AlwaysReset := True;');
end;
procedure Register;
begin
RegisterComponents('KOLAddons', [TKOLPageSetupDialog]);
end;
end.

144
Addons/MCKPrintDialogs.pas
View File

@ -1,144 +0,0 @@
unit mckPrintDialogs;
interface
uses
KOL,KOLPrintDialogs,Windows, Classes,Graphics,
mirror,mckObjs ;
type
TKOLPrintDialog = class(TKOLObj)
private
ftagPD : tagPD;
fOptions : TPrintDlgOptions;
fAlwaysReset : Boolean;
protected
function AdditionalUnits: string; override;
procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override;
procedure SetOptions(const Value : TPrintDlgOptions);
procedure SetFromPage(const Value : WORD);
procedure SetToPage(const Value : WORD);
procedure SetMinPage(const Value : WORD);
procedure SetMaxPage(const Value : WORD);
procedure SetCopies(const Value : WORD);
procedure SetAlwaysReset(const Value : Boolean);
public
constructor Create( AOwner: TComponent ); override;
published
property FromPage : WORD read ftagPD.nFromPage write SetFromPage;
property ToPage : WORD read ftagPD.nToPage write SetToPage;
property MinPage : WORD read ftagPD.nMinPage write SetMinPage;
property MaxPage : WORD read ftagPD.nMaxPage write SetMaxPage;
property Copies : WORD read ftagPD.nCopies write SetCopies;
property Options : TPrintDlgOptions read fOptions write SetOptions;
property AlwaysReset : Boolean read fAlwaysReset write SetAlwaysReset;
end;
procedure Register;
implementation
{$R *.dcr}
constructor TKOLPrintDialog.Create( AOwner: TComponent );
begin
inherited Create(Aowner);
fAlwaysReset := false;
FromPage := 1;
ToPage := 1;
MinPage := 1;
MaxPage := 1;
Copies := 1;
end;
procedure TKOLPrintDialog.SetAlwaysReset(const Value : Boolean);
begin
fAlwaysReset := Value;
Change;
end;
procedure TKOLPrintDialog.SetOptions(const Value : TPrintDlgOptions);
begin
fOptions := Value;
Change;
end;
procedure TKOLPrintDialog.SetFromPage(const Value : WORD);
begin
ftagPD.nFromPage := Value;
Change;
end;
procedure TKOLPrintDialog.SetToPage(const Value : WORD);
begin
ftagPD.nToPage := Value;
Change;
end;
procedure TKOLPrintDialog.SetMinPage(const Value : WORD);
begin
ftagPD.nMinPage := Value;
Change;
end;
procedure TKOLPrintDialog.SetMaxPage(const Value : WORD);
begin
ftagPD.nMaxPage := Value;
Change;
end;
procedure TKOLPrintDialog.SetCopies(const Value : WORD);
begin
ftagPD.nCopies := Value;
Change;
end;
function TKOLPrintDialog.AdditionalUnits;
begin
Result := ', KOLPrintDialogs';
end;
procedure TKOLPrintDialog.SetupFirst(SL: TStringList; const AName,
AParent, Prefix: String);
var
s : String;
begin
if (pdPrinterSetup in fOptions) then s := s + ',pdPrinterSetup';
if (pdCollate in fOptions) then s := s + ',pdCollate';
if (pdPrintToFile in fOptions) then s := s + ',pdPrintToFile';
if (pdPageNums in fOptions) then s := s + ',pdPageNums';
if (pdSelection in fOptions) then s := s + ',pdSelection';
if (pdWarning in fOptions) then s := s + ',pdWarning';
if (pdDeviceDepend in fOptions) then s := s + ',pdDeviceDepend';
if (pdHelp in fOptions) then s := s + ',pdHelp';
if (pdReturnDC in fOptions) then s:= s + ',pdReturnDC';
if s <> '' then
if s[1] = ',' then s[1] := Chr(32);
SL.Add( Prefix + AName + ' := NewPrintDialog(' + AParent + ',[' + s + ']);');
if fAlwaysReset then SL.Add(Prefix + AName + '.AlwaysReset := true;');
SL.Add(Prefix + AName + '.FromPage :=' + Int2Str(Integer(ftagPD.nFromPage)) + ';');
SL.Add(Prefix + AName + '.ToPage :=' + Int2Str(Integer(ftagPD.nToPage)) + ';');
SL.Add(Prefix + AName + '.MinPage :=' + Int2Str(Integer(ftagPD.nMinPage)) + ';');
SL.Add(Prefix + AName + '.MaxPage :=' + Int2Str(Integer(ftagPD.nMaxPage)) + ';');
SL.Add(Prefix + AName + '.Copies :=' + Int2Str(Integer(ftagPD.nCopies)) + ';');
end;
procedure Register;
begin
RegisterComponents('KOLAddons', [TKOLPrintDialog]);
end;
end.

314
Addons/MCKReport.pas
View File

@ -1,314 +0,0 @@
unit MCKReport;
interface
uses KOL, Windows, Messages, Dialogs, Forms, Classes, Controls, Graphics, SysUtils,
mirror, mckCtrls, KOLReport;
type
TKOLReport = class( TKOLObj )
private
FOnNewBand: TOnEvent;
FOnPrint: TOnEvent;
FOnNewPage: TOnEvent;
FDoubleBufferedPreview: Boolean;
FDocumentName: String;
procedure SetOnNewBand(const Value: TOnEvent);
procedure SetOnNewPage(const Value: TOnEvent);
procedure SetOnPrint(const Value: TOnEvent);
procedure SetDoubleBufferedPreview(const Value: Boolean);
procedure SetDocumentName(const Value: String);
protected
function AdditionalUnits: String; override;
procedure AssignEvents( SL: TStringList; const AName: String ); override;
procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override;
published
property OnPrint: TOnEvent read FOnPrint write SetOnPrint;
property OnNewPage: TOnEvent read FOnNewPage write SetOnNewPage;
property OnNewBand: TOnEvent read FOnNewBand write SetOnNewBand;
property DoubleBufferedPreview: Boolean read FDoubleBufferedPreview write SetDoubleBufferedPreview;
property DocumentName: String read FDocumentName write SetDocumentName;
end;
TKOLBand = class( TKOLPanel )
private
FFrames: TFrames;
procedure SetFrames(const Value: TFrames);
protected
function SetupParams( const AName, AParent: String ): String; override;
function AdditionalUnits: String; override;
procedure Set_VA(const Value: TVerticalAlign); override;
public
constructor Create( AOwner: TComponent ); override;
function NoDrawFrame: Boolean; override;
procedure Paint; override;
published
property Frames: TFrames read FFrames write SetFrames;
end;
TKOLReportLabel = class( TKOLLabel )
private
FFrames: TFrames;
procedure SetFrames(const Value: TFrames);
protected
function AdditionalUnits: String; override;
public
constructor Create( AOwner: TComponent ); override;
function TypeName: String; override;
function NoDrawFrame: Boolean; override;
function AdjustVerticalAlign( Value: TVerticalAlign ): TVerticalAlign; override;
function SetupParams( const AName, AParent: String ): String; override;
procedure Paint; override;
function BorderNeeded: Boolean; override;
published
property Frames: TFrames read FFrames write SetFrames;
property Border;
end;
procedure Register;
{$R KOLReport.dcr}
implementation
procedure Register;
begin
RegisterComponents( 'KOLAddons', [ TKOLReport, TKOLBand, TKOLReportLabel ] );
end;
function CalcFrames( const Frames: TFrames ): String;
begin
Result := '';
if frLeft in Frames then
Result := 'frLeft,';
if frTop in Frames then
Result := Result + 'frTop,';
if frRight in Frames then
Result := Result + 'frRight,';
if frBottom in Frames then
Result := Result + 'frBottom,';
if Result <> '' then
Delete( Result, Length( Result ), 1 );
Result := '[' + Result + ']';
end;
type
TFakeControl = class( TControl )
public
property Color;
end;
{ TKOLReport }
function TKOLReport.AdditionalUnits: String;
begin
Result := inherited AdditionalUnits + ', KOLReport';
end;
procedure TKOLReport.AssignEvents(SL: TStringList; const AName: String);
begin
inherited;
DoAssignEvents( SL, AName, [ 'OnPrint', 'OnNewPage', 'OnNewBand' ],
[ @ OnPrint, @ OnNewPage, @ OnNewBand ] );
end;
procedure TKOLReport.SetDocumentName(const Value: String);
begin
FDocumentName := Value;
Change;
end;
procedure TKOLReport.SetDoubleBufferedPreview(const Value: Boolean);
begin
FDoubleBufferedPreview := Value;
Change;
end;
procedure TKOLReport.SetOnNewBand(const Value: TOnEvent);
begin
FOnNewBand := Value;
Change;
end;
procedure TKOLReport.SetOnNewPage(const Value: TOnEvent);
begin
FOnNewPage := Value;
Change;
end;
procedure TKOLReport.SetOnPrint(const Value: TOnEvent);
begin
FOnPrint := Value;
Change;
end;
procedure TKOLReport.SetupFirst(SL: TStringList; const AName, AParent,
Prefix: String);
begin
inherited;
if DoubleBufferedPreview then
SL.Add( Prefix + AName + '.DoubleBufferedPreview := TRUE;' );
if Trim( DocumentName ) <> '' then
SL.Add( Prefix + AName + '.DocumentName := ' + String2PascalStrExpr( DocumentName ) + ';' );
end;
{ TKOLBand }
function TKOLBand.AdditionalUnits: String;
begin
Result := inherited AdditionalUnits + ', KOLReport';
end;
constructor TKOLBand.Create(AOwner: TComponent);
begin
inherited;
EdgeStyle := esNone;
if (AOwner <> nil) and (AOwner is TControl) and
(TFakeControl(AOwner).Color = clWhite) then
else
begin
ParentColor := FALSE;
Color := clWhite;
end;
if (AOwner <> nil) and (AOwner is TControl) and
(TFakeControl(AOwner).Font.Color = clBlack) and
(TFakeControl(AOwner).Font.Name = 'Arial') then
else
begin
ParentFont := FALSE;
Font.Color := clBlack;
Font.FontName := 'Arial';
end;
Width := 400;
Height := 40;
Border := 1;
end;
function TKOLBand.NoDrawFrame: Boolean;
begin
Result := TRUE;
end;
procedure TKOLBand.Paint;
var W, H, B: Integer;
begin
inherited;
Canvas.Brush.Color := Font.Color;
W := ClientWidth;
H := ClientHeight;
B := Border;
if frLeft in Frames then
Canvas.FillRect( Rect( 0, 0, B, H ) );
if frTop in Frames then
Canvas.FillRect( Rect( 0, 0, W, B ) );
if frRight in Frames then
Canvas.FillRect( Rect( W - B, 0, W, H ) );
if frBottom in Frames then
Canvas.FillRect( Rect( 0, H - B, W, H ) );
end;
procedure TKOLBand.SetFrames(const Value: TFrames);
begin
FFrames := Value;
Change;
Invalidate;
end;
function TKOLBand.SetupParams(const AName, AParent: String): String;
begin
Result := AParent + ', ' + CalcFrames( Frames );
end;
procedure TKOLBand.Set_VA(const Value: TVerticalAlign);
begin
fVerticalAlign := Value;
Change;
Invalidate;
end;
{ TKOLReportLabel }
function TKOLReportLabel.AdditionalUnits: String;
begin
Result := inherited AdditionalUnits + ', KOLReport';
end;
function TKOLReportLabel.AdjustVerticalAlign(
Value: TVerticalAlign): TVerticalAlign;
begin
Result := Value;
end;
function TKOLReportLabel.BorderNeeded: Boolean;
begin
Result := TRUE;
end;
constructor TKOLReportLabel.Create(AOwner: TComponent);
begin
inherited;
if (AOwner <> nil) and (AOwner is TControl) and
(TFakeControl(AOwner).Color = clWhite) then
else
begin
ParentColor := FALSE;
Color := clWhite;
end;
if (AOwner <> nil) and (AOwner is TControl) and
(TFakeControl(AOwner).Font.Color = clBlack) and
(TFakeControl(AOwner).Font.Name = 'Arial') then
else
begin
ParentFont := FALSE;
Font.Color := clBlack;
Font.FontName := 'Arial';
end;
Border := 1;
DefaultAutoSize := TRUE;
AutoSize := TRUE;
end;
function TKOLReportLabel.NoDrawFrame: Boolean;
begin
Result := TRUE;
end;
procedure TKOLReportLabel.Paint;
var W, H, B: Integer;
begin
inherited;
Canvas.Brush.Color := Font.Color;
W := ClientWidth;
H := ClientHeight;
B := Border;
if frLeft in Frames then
Canvas.FillRect( Rect( 0, 0, B, H ) );
if frTop in Frames then
Canvas.FillRect( Rect( 0, 0, W, B ) );
if frRight in Frames then
Canvas.FillRect( Rect( W - B, 0, W, H ) );
if frBottom in Frames then
Canvas.FillRect( Rect( 0, H - B, W, H ) );
end;
procedure TKOLReportLabel.SetFrames(const Value: TFrames);
begin
FFrames := Value;
Change;
Invalidate;
end;
function TKOLReportLabel.SetupParams(const AName, AParent: String): String;
begin
Result := inherited SetupParams( AName, AParent ) + ', ' + CalcFrames( Frames );
end;
function TKOLReportLabel.TypeName: String;
begin
if WordWrap then
Result := 'WordWrapReportLabel'
else
Result := 'ReportLabel';
end;
end.

974
Addons/kolTCPSocket.pas
View File

@ -1,974 +0,0 @@
unit kolTCPSocket;
////////////////////////////////////////////////////////////////////
//
// TTTTTTTTTT CCCCCCCC PPPPPPPPP
// T TTTT T CCCC CCCC PPPP PPPP
// TTTT CCCC PPPP PPPP
// TTTT CCCC PPPP PPPP
// TTTT CCCC PPPPPPPPP
// TTTT CCCC CCCC PPPP
// TTTT CCCCCCCC PPPP
//
// S O C K E T
//
// TCPServer, TCPClient implementation for Key Objects Library
//
// (c) 2002 by Vorobets Roman
// Roman.Vorobets@p25.f8.n454.z2.fidonet.org
//
////////////////////////////////////////////////////////////////////
interface
uses
kol,windows,winsock,messages;
const
WM_SOCKET=WM_USER+1;
WM_SOCKETDESTROY=WM_USER+2;
type
twndmethod=procedure(var message:tmessage) of object;
PTCPBase=^TTCPBase;
PTCPServer=^TTCPServer;
PTCPClient=^TTCPClient;
PTCPServerClient=^TTCPServerClient;
TKOLTCPClient=PTCPClient;
TKOLTCPServer=PTCPServer;
TOnTCPClientEvent = procedure(Sender: PTCPClient) of object;
TOnTCPStreamSend = TOnTCPClientEvent;
TOnTCPStreamReceive = TOnTCPClientEvent;
TOnTCPConnect = TOnTCPClientEvent;
TOnTCPManualReceive = TOnTCPClientEvent;
TOnTCPDisconnect = TOnTCPClientEvent;
TOnTCPReceive = procedure(Sender: PTCPClient; var Buf: array of byte; const Count: Integer) of object;
TOnTCPResolve = procedure(Sender: PTCPClient; const IP: String) of object;
TOnTCPAccept = function(Sender: PTCPServer; const IP: String;
const Port: SmallInt):boolean of object;
TOnTCPClientConnect = procedure(Sender: PTCPServerClient) of object;
TOnTCPError = procedure(Sender: PObj; const Error:integer) of object;
TTCPBase=object(TObj)
private
FWnd:HWnd;
FConnecting: Boolean;
function GetWnd: HWnd;
procedure Method(var message:tmessage);virtual;
procedure DoClose;
private
FPort: SmallInt;
FOnConnect: TOnTCPConnect;
FOnDisconnect: TOnTCPDisconnect;
FOnError: TOnTCPError;
FHandle: TSocket;
FConnected: Boolean;
FSection: TRTLCriticalSection;
property Wnd:HWnd read GetWnd;
function GetPort: SmallInt;
procedure SetPort(const Value: SmallInt);
procedure SetOnConnect(const Value: TOnTCPConnect);
procedure SetOnDisconnect(const Value: TOnTCPDisconnect);
procedure SetOnError(const Value: TOnTCPError);
procedure SetHandle(const Value: TSocket);
function ErrorTest(const e: integer): boolean;
protected
procedure Creating;virtual;
destructor Destroy;virtual;
public
property Connected:Boolean read FConnected;
property Online:Boolean read FConnected;
property Connecting:Boolean read FConnecting;
property Handle:TSocket read FHandle write SetHandle;
property Port:SmallInt read GetPort{FPort} write SetPort;
property OnError:TOnTCPError read FOnError write SetOnError;
property OnConnect:TOnTCPConnect read FOnConnect write SetOnConnect;
property OnDisconnect:TOnTCPDisconnect read FOnDisconnect write SetOnDisconnect;
procedure Lock;
procedure Unlock;
procedure Disconnect;virtual;
end;
TTCPServer=object(TTCPBase)
private
FConnections: PList;
FOnAccept: TOnTCPAccept;
FOnClientConnect: TOnTCPClientConnect;
FOnClientDisconnect: TOnTCPDisconnect;
FOnClientError: TOnTCPError;
FOnClientReceive: TOnTCPReceive;
FOnClientManualReceive: TOnTCPManualReceive;
FOnClientStreamReceive: TOnTCPStreamReceive;
FOnClientStreamSend: TOnTCPStreamSend;
procedure SetOnAccept(const Value: TOnTCPAccept);
procedure SetOnClientConnect(const Value: TOnTCPClientConnect);
procedure SetOnClientDisconnect(const Value: TOnTCPDisconnect);
procedure SetOnClientError(const Value: TOnTCPError);
procedure SetOnClientReceive(const Value: TOnTCPReceive);
function GetConnection(Index: Integer): PTCPServerClient;
function GetCount: Integer;
procedure Method(var message: tmessage); virtual;
procedure SetOnClientManualReceive(const Value: TOnTCPManualReceive);
procedure SetOnClientStreamReceive(const Value: TOnTCPStreamReceive);
procedure SetOnClientStreamSend(const Value: TOnTCPStreamSend);
protected
procedure Creating;virtual;
destructor Destroy;virtual;
public
property OnAccept:TOnTCPAccept read FOnAccept write SetOnAccept;
property OnClientError:TOnTCPError read FOnClientError write SetOnClientError;
property OnClientConnect:TOnTCPClientConnect read FOnClientConnect write SetOnClientConnect;
property OnClientDisconnect:TOnTCPDisconnect read FOnClientDisconnect write SetOnClientDisconnect;
property OnClientReceive:TOnTCPReceive read FOnClientReceive write SetOnClientReceive;
property OnClientManualReceive:TOnTCPManualReceive read FOnClientManualReceive write SetOnClientManualReceive;
property OnClientStreamSend:TOnTCPStreamSend read FOnClientStreamSend write SetOnClientStreamSend;
property OnClientStreamReceive:TOnTCPStreamReceive read FOnClientStreamReceive write SetOnClientStreamReceive;
property Count:Integer read GetCount;
property Connection[Index: Integer]: PTCPServerClient read GetConnection;
procedure Listen;
procedure Disconnect;virtual;
end;
TTCPClient=object(TTCPBase)
private
FHost: String;
FBuffer: array[0..4095] of byte;
FOnResolve: TOnTCPResolve;
FOnReceive: TOnTCPReceive;
FOnStreamSend: TOnTCPStreamSend;
FSendStream: PStream;
FSendAutoFree: Boolean;
FReceiveStream: PStream;
FReceiveAutoFree: Boolean;
FReceiveAutoFreeSize: Integer;
FReceiveStartPos: Integer;
FOnManualReceive: TOnTCPManualReceive;
FOnStreamReceive: TOnTCPStreamReceive;
FIndex: Integer;
procedure SetHost(const Value: String);
procedure SetOnResolve(const Value: TOnTCPResolve);
procedure SetOnReceive(const Value: TOnTCPReceive);
procedure SetOnStreamSend(const Value: TOnTCPStreamSend);
procedure Method(var message:tmessage);virtual;
function SendStreamPiece: Boolean;
procedure SetOnManualReceive(const Value: TOnTCPManualReceive);
procedure SetOnStreamReceive(const Value: TOnTCPStreamReceive);
procedure SetIndex(const Value: Integer);virtual;
protected
destructor Destroy;virtual;
public
property OnReceive:TOnTCPReceive read FOnReceive write SetOnReceive;
property OnManualReceive:TOnTCPManualReceive read FOnManualReceive write SetOnManualReceive;
property OnResolve:TOnTCPResolve read FOnResolve write SetOnResolve;
property OnStreamSend:TOnTCPStreamSend read FOnStreamSend write SetOnStreamSend;
property OnStreamReceive:TOnTCPStreamReceive read FOnStreamReceive write SetOnStreamReceive;
property Host:String read FHost write SetHost;
property Index:Integer read FIndex write SetIndex;
function StreamSending:Boolean;
function StreamReceiving:Boolean;
procedure Connect;virtual;
function Send(var Buf; const Count: Integer): Integer;
procedure SendString(S: String);
function SendStream(Stream: PStream; const AutoFree: Boolean): Boolean;
procedure SetReceiveStream(Stream: PStream; const AutoFree: Boolean=false;
const AutoFreeSize: Integer=0);
function ReceiveLength: Integer;
function ReceiveBuf(var Buf; Count: Integer): Integer;
end;
TTCPServerClient=object(TTCPClient)
private
FIP: String;
FServer: PTCPServer;
procedure SetIndex(const Value: Integer);virtual;
public
property IP: String read FIP;
procedure Connect;virtual;
procedure Disconnect;virtual;
end;
function NewTCPServer: PTCPServer;
function NewTCPClient: PTCPClient;
function Err2Str(const id: integer): string;
function TCPGetHostByName(name: pchar): string;
procedure Startup;
procedure Cleanup;
implementation
type
pobjectinstance=^tobjectinstance;
tobjectinstance=packed record
code:byte;
offset:integer;
case integer of
0:(next:pobjectinstance);
1:(method:twndmethod);
end;
pinstanceblock=^tinstanceblock;
tinstanceblock=packed record
next:pinstanceblock;
code:array[1..2] of byte;
wndprocptr:pointer;
instances: array[0..$ff] of tobjectinstance;
end;
var
instblocklist:pinstanceblock;
instfreelist:pobjectinstance;
wsadata:twsadata;
function NewTCPServerClient(Server: PTCPServer): PTCPServerClient;forward;
function stdwndproc(window:hwnd;message:dword;wparam:WPARAM;
lparam:LPARAM):LRESULT;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;
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,$E9);
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;
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;
end;
procedure FreeObjectInstance(ObjectInstance: Pointer);
begin
if objectinstance<>nil then
begin
pobjectinstance(objectinstance)^.next:=instfreelist;
instfreelist:=objectinstance;
end;
end;
var
utilclass:twndclass=(lpfnwndproc:@defwindowproc;lpszclassname:'TCPSocket');
function AllocateHWnd(Method: TWndMethod): HWND;
var
tempclass:twndclass;
classregistered:boolean;
begin
utilclass.hinstance:=hinstance;
classregistered:=getclassinfo(hinstance,utilclass.lpszclassname,tempclass);
if not classregistered or (tempclass.lpfnwndproc<>@defwindowproc) then
begin
if classregistered then unregisterclass(utilclass.lpszclassname,hinstance);
registerclass(utilclass);
end;
result:=createwindowex(WS_EX_TOOLWINDOW,utilclass.lpszclassname,nil,
WS_POPUP,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 Startup;
begin
if bool(wsastartup($101,wsadata)) then showmessage('WSAStartup error.');
end;
procedure Cleanup;
begin
if bool(wsacleanup) then showmessage('WSACleanup error');
end;
{ TTCPBase }
procedure TTCPBase.Creating;
begin
startup;
initializecriticalsection(fsection);
fhandle:=SOCKET_ERROR;
end;
destructor TTCPBase.Destroy;
begin
if fwnd<>0 then deallocatehwnd(fwnd);
doclose;
disconnect;
deletecriticalsection(fsection);
cleanup;
end;
procedure TTCPBase.Disconnect;
begin
if fhandle<>SOCKET_ERROR then
begin
doclose;
if fconnected then
begin
fconnected:=false;
if assigned(ondisconnect) then ondisconnect(@self);
end;
fconnecting:=false;
end;
end;
procedure TTCPBase.DoClose;
begin
if fhandle<>SOCKET_ERROR then
begin
errortest(closesocket(fhandle));
fhandle:=SOCKET_ERROR;
end;
end;
function TTCPBase.ErrorTest(const e: integer): boolean;
var
wsae: Integer;
begin
{ msgok(int2str(e));
msgok(int2str(SOCKET_ERROR));
msgok(int2str(INVALID_SOCKET)); }
result:= (e = SOCKET_ERROR) or (e = INVALID_SOCKET);
if result then begin
wsae:=wsagetlasterror;
if wsae<>WSAEWOULDBLOCK then
begin
if assigned(onerror) then onerror(@self,wsae) else
showmessage('Socket error '+err2str(wsae)+' on socket '+int2str(fhandle));
end else result:=false;
end;
end;
function TTCPBase.GetWnd: HWnd;
begin
if fwnd=0 then fwnd:=allocatehwnd(method);
result:=fwnd;
end;
procedure TTCPBase.Lock;
begin
entercriticalsection(fsection);
end;
procedure TTCPBase.Method(var message: tmessage);
begin
if message.msg<>WM_SOCKET then exit;
if message.lparamhi>WSABASEERR then
begin
wsasetlasterror(message.lparamhi);
errortest(SOCKET_ERROR);
if fconnecting then doclose;
fconnecting:=false;
end;
case message.lparamlo of
FD_CLOSE:begin
fconnected:=false;
fconnecting:=false;
if assigned(ondisconnect) then ondisconnect(@self);
if fhandle<>SOCKET_ERROR then doclose;
end;
end;
end;
procedure TTCPBase.SetHandle(const Value: TSocket);
begin
FHandle := Value;
end;
procedure TTCPBase.SetOnDisconnect(const Value: TOnTCPDisconnect);
begin
FOnDisconnect := Value;
end;
procedure TTCPBase.SetOnError(const Value: TOnTCPError);
begin
FOnError := Value;
end;
procedure TTCPBase.SetPort(const Value: SmallInt);
begin
FPort := Value;
end;
function TTCPBase.GetPort: SmallInt;
var buf: sockaddr_in; bufSz: Integer;
begin
if FConnected then
begin
bufSz := SizeOf(buf);
ZeroMemory( @buf, bufSz );
getsockname(fhandle, buf, bufSz);
FPort := htons(buf.sin_port);
end;
Result := FPort;
end;
function NewTCPServer: PTCPServer;
begin
new(result,create);
result.creating;
end;
function NewTCPClient: PTCPClient;
begin
new(result,create);
result.creating;
end;
function NewTCPServerClient(Server: PTCPServer): PTCPServerClient;
begin
new(result,create);
result.creating;
result.fserver:=server;
end;
procedure TTCPBase.Unlock;
begin
leavecriticalsection(fsection);
end;
{ TTCPClient }
procedure TTCPClient.Connect;
var
adr: TSockAddr;
begin
disconnect;
fhandle:= socket(AF_INET, SOCK_STREAM, IPPROTO_TCP);
if not errortest(fhandle) then begin
WSAAsyncSelect(fhandle, wnd, WM_SOCKET, FD_READ or FD_WRITE or FD_CONNECT or FD_CLOSE);
with adr do begin
sin_family:= AF_INET;
sin_port:= htons(port);
//Integer(sin_addr):= inet_addr(PChar(host));
sin_addr.S_addr:= inet_addr(PChar(host));
if Integer(sin_addr) = SOCKET_ERROR then begin
sin_addr.S_addr:= PInAddr(gethostbyname(PChar(Host)).h_addr_list^)^.S_addr;
end;
//msgok('bly' + int2str(sin_addr.S_addr));
{if Integer(sin_addr) = SOCKET_ERROR then begin
// must be WSAAsyncGetHostByName
ph:= winsock.gethostbyname(pchar(host));
if ph=nil then showmessage('gethostbyname() error');
move(ph.h_addr^^,sin_addr,ph.h_length);
if assigned(onresolve) then onresolve(@self,inet_ntoa(adr.sin_addr));
end;}
end;
fconnecting:= not errortest(Integer(adr.sin_addr)) and not errortest(WinSock.connect(fhandle, adr, SizeOf(adr)));
if not fconnecting then doclose;
end;
end;
destructor TTCPClient.Destroy;
begin
if fsendautofree and (fsendstream<>nil) then fsendstream.free;
fsendstream:=nil;
inherited;
end;
function TTCPClient.StreamReceiving: Boolean;
begin
Result:= Assigned(FReceiveStream);
end;
function TTCPClient.StreamSending: Boolean;
begin
Result:= Bool(fsendstream);
end;
procedure TTCPClient.Method(var message: tmessage);
var
sz:integer;
begin
inherited;
if (message.msg<>WM_SOCKET) then exit;
if message.lparamhi>WSABASEERR then
begin
if message.lparamlo=FD_CLOSE then
begin
if streamsending then
begin
if fsendautofree then fsendstream.free;
if assigned(onstreamsend) then onstreamsend(@self);
end;
if streamreceiving then
begin
if freceiveautofree then freceivestream.free;
if assigned(onstreamreceive) then onstreamreceive(@self);
end;
end;
end else
case message.lparamlo of
FD_CONNECT:begin
fconnected:=true;
fconnecting:=false;
if assigned(onconnect) then onconnect(@self);
end;
FD_READ:if (freceivestream=nil) and assigned(onmanualreceive) then onmanualreceive(@self) else
begin
lock;
// repeat
ioctlsocket(fhandle,FIONREAD,sz);
if sz>0 then
begin
if sz>sizeof(fbuffer) then sz:=sizeof(fbuffer);
sz:=receivebuf(fbuffer,sz);
errortest(sz);
if freceivestream<>nil then
begin
freceivestream.write(fbuffer,sz);
if assigned(onstreamreceive) then onstreamreceive(@self);
end else if assigned(onreceive) then onreceive(@self,fbuffer,sz);
end;
// until (sz<=0) or //not fmaxsendstreamspeed or
// ((freceivestream<>nil) and freceiveautofree and
// (freceivestream.size>=freceiveautofreesize));
unlock;
if (freceivestream<>nil) and freceiveautofree and
(integer(freceivestream.position)+freceivestartpos>=freceiveautofreesize) then
begin
freceivestream.free;
freceivestream:=nil;
if assigned(onstreamreceive) then onstreamreceive(@self);
end;
end;
FD_WRITE:if streamsending then sendstreampiece;// else if assigned(onwrite) then onwrite(@self);
end;
end;
function TTCPClient.ReceiveBuf(var Buf; Count: Integer): Integer;
begin
result:=0;
if not fconnected or (fhandle=SOCKET_ERROR) or (count<=0) then exit;
lock;
result:=recv(fhandle,buf,count,0);
errortest(result);
unlock;
end;
function TTCPClient.ReceiveLength: Integer;
begin
if fhandle<>SOCKET_ERROR then
ioctlsocket(fhandle,FIONREAD,result)
else result:=0;
end;
function TTCPClient.Send(var Buf; const Count: Integer): Integer;
begin
result:=winsock.send(fhandle,buf,count,0);
end;
function TTCPClient.SendStream(Stream: PStream; const AutoFree: Boolean): Boolean;
begin
result:=false;
if fsendstream=nil then
begin
fsendstream:=stream;
fsendautofree:=autofree;
result:=sendstreampiece;
end;
end;
function TTCPClient.SendStreamPiece: Boolean;
var
buf:array[0..4095] of byte;
startpos,amountinbuf,amountsent:integer;
begin
result:=false;
if not fconnected or (fhandle=SOCKET_ERROR) or (fsendstream=nil) then exit;
lock;
repeat
startpos:=fsendstream.position;
amountinbuf:=fsendstream.read(buf,sizeof(buf));
if amountinbuf>0 then
begin
amountsent:=send(buf,amountinbuf);
if amountsent=SOCKET_ERROR then
begin
if errortest(SOCKET_ERROR) then
begin
fsendstream:=nil;
break;
end else
begin
fsendstream.position:=startpos;
break;
end;
end else
if amountinbuf>amountsent then fsendstream.position:=startpos+amountsent else
if fsendstream.position=fsendstream.size then
begin
if fsendautofree then fsendstream.free;
fsendstream:=nil;
break;
end;
end else
begin
fsendstream:=nil;
break;
end;
until false;
result:=true;
unlock;
if assigned(onstreamsend) then onstreamsend(@self);
end;
procedure TTCPClient.SendString(S: String);
begin
send(s[1], length(s));
end;
procedure TTCPClient.SetHost(const Value: String);
begin
FHost := Value;
end;
procedure TTCPClient.SetIndex(const Value: Integer);
begin
FIndex := Value;
end;
procedure TTCPBase.SetOnConnect(const Value: TOnTCPConnect);
begin
FOnConnect := Value;
end;
procedure TTCPClient.SetOnManualReceive(const Value: TOnTCPManualReceive);
begin
FOnManualReceive := Value;
end;
procedure TTCPClient.SetOnReceive(const Value: TOnTCPReceive);
begin
FOnReceive := Value;
end;
procedure TTCPClient.SetOnResolve(const Value: TOnTCPResolve);
begin
FOnResolve := Value;
end;
procedure TTCPClient.SetOnStreamReceive(const Value: TOnTCPStreamReceive);
begin
FOnStreamReceive := Value;
end;
procedure TTCPClient.SetOnStreamSend(const Value: TOnTCPStreamSend);
begin
FOnStreamSend := Value;
end;
procedure TTCPClient.SetReceiveStream(Stream: PStream; const AutoFree: Boolean = False; const AutoFreeSize: Integer=0);
begin
if Autofree and (AutoFreeSize = 0) then Exit;
if Assigned(FReceiveStream) then FReceiveStream.free;
FReceiveAutoFree:= AutoFree;
FReceiveAutoFreeSize:= AutoFreeSize;
FReceiveStartpos:= Stream.Position;
FReceiveStream:= Stream;
end;
{ TTCPServer }
procedure TTCPServer.Creating;
begin
inherited;
fconnections:=newlist;
end;
destructor TTCPServer.Destroy;
var
i:integer;
begin
for i:=0 to pred(count) do connection[i].free;
fconnections.free;
fconnections:=nil;
inherited;
end;
procedure TTCPServer.Disconnect;
begin
if fconnections=nil then exit;
lock;
while count>0 do connection[0].disconnect;
unlock;
inherited;
end;
function TTCPServer.GetConnection(Index: Integer): PTCPServerClient;
begin
result:=ptcpserverclient(fconnections.items[index]);
end;
function TTCPServer.GetCount: Integer;
begin
result:=fconnections.count;
end;
procedure TTCPServer.Listen;
var
adr:tsockaddr;
begin
if fhandle<>SOCKET_ERROR then exit;
fhandle:=socket(AF_INET,SOCK_STREAM,IPPROTO_TCP);
if not errortest(fhandle) then
begin
with adr do
begin
sin_family:=AF_INET;
sin_port:=htons(port);
integer(sin_addr):=INADDR_ANY;
end;
if errortest(bind(fhandle,adr,sizeof(adr))) then doclose else
begin
wsaasyncselect(fhandle,wnd,WM_SOCKET,FD_ACCEPT or FD_CLOSE or FD_CONNECT);
if errortest(winsock.listen(fhandle,64)) then
doclose
else
begin
FConnected := True;
if assigned(onconnect) then onconnect(@self);
end;
end;
end;
end;
procedure TTCPServer.Method(var message: tmessage);
var
adr:tsockaddr;
sz:integer;
sock:TSocket;
sclient:ptcpserverclient;
begin
inherited;
case message.msg of
WM_SOCKET:
if message.lparamhi<=WSABASEERR then
case message.lparamlo of
FD_ACCEPT:begin
sz:=sizeof(adr);
sock:=accept(fhandle,@adr,@sz);
if not errortest(sock) then
begin
if not assigned(onaccept) or onaccept(@self,inet_ntoa(adr.sin_addr),htons(adr.sin_port)) then
begin
sclient:=newtcpserverclient(@self);
with sclient^ do
begin
wsaasyncselect(sock,wnd,WM_SOCKET,FD_READ or FD_WRITE or FD_CLOSE);
fhost:=inet_ntoa(adr.sin_addr);
fport:=htons(adr.sin_port);
fip:=fhost;
fhandle:=sock;
fconnected:=true;
fconnecting:=false;
findex:=fconnections.count;
onerror:=onclienterror;
ondisconnect:=onclientdisconnect;
onreceive:=onclientreceive;
onmanualreceive:=onclientmanualreceive;
onstreamsend:=onclientstreamsend;
onstreamreceive:=onclientstreamreceive;
end;
fconnections.add(sclient);
if assigned(onclientconnect) then onclientconnect(sclient);
end else closesocket(sock);
end;
end;
end;
WM_SOCKETDESTROY:ptcpserverclient(message.wparam).free;
end;
end;
procedure TTCPServer.SetOnAccept(const Value: TOnTCPAccept);
begin
FOnAccept := Value;
end;
procedure TTCPServer.SetOnClientConnect(const Value: TOnTCPClientConnect);
begin
FOnClientConnect := Value;
end;
procedure TTCPServer.SetOnClientDisconnect(const Value: TOnTCPDisconnect);
begin
FOnClientDisconnect := Value;
end;
procedure TTCPServer.SetOnClientError(const Value: TOnTCPError);
begin
FOnClientError := Value;
end;
procedure TTCPServer.SetOnClientManualReceive( const Value: TOnTCPManualReceive);
begin
FOnClientManualReceive := Value;
end;
procedure TTCPServer.SetOnClientReceive(const Value: TOnTCPReceive);
begin
FOnClientReceive := Value;
end;
function Err2Str(const id: integer): string;
begin
case id of
WSAEINTR:result:='WSAEINTR';
WSAEBADF:result:='WSAEBADF';
WSAEACCES:result:='WSAEACCES';
WSAEFAULT:result:='WSAEFAULT';
WSAEINVAL:result:='WSAEINVAL';
WSAEMFILE:result:='WSAEMFILE';
WSAEWOULDBLOCK:result:='WSAEWOULDBLOCK';
WSAEINPROGRESS:result:='WSAEINPROGRESS';
WSAEALREADY:result:='WSAEALREADY';
WSAENOTSOCK:result:='WSAENOTSOCK';
WSAEDESTADDRREQ:result:='WSAEDESTADDRREQ';
WSAEMSGSIZE:result:='WSAEMSGSIZE';
WSAEPROTOTYPE:result:='WSAEPROTOTYPE';
WSAENOPROTOOPT:result:='WSAENOPROTOOPT';
WSAEPROTONOSUPPORT:result:='WSAEPROTONOSUPPORT';
WSAESOCKTNOSUPPORT:result:='WSAESOCKTNOSUPPORT';
WSAEOPNOTSUPP:result:='WSAEOPNOTSUPP';
WSAEPFNOSUPPORT:result:='WSAEPFNOSUPPORT';
WSAEAFNOSUPPORT:result:='WSAEAFNOSUPPORT';
WSAEADDRINUSE:result:='WSAEADDRINUSE';
WSAEADDRNOTAVAIL:result:='WSAEADDRNOTAVAIL';
WSAENETDOWN:result:='WSAENETDOWN';
WSAENETUNREACH:result:='WSAENETUNREACH';
WSAENETRESET:result:='WSAENETRESET';
WSAECONNABORTED:result:='WSAECONNABORTED';
WSAECONNRESET:result:='WSAECONNRESET';
WSAENOBUFS:result:='WSAENOBUFS';
WSAEISCONN:result:='WSAEISCONN';
WSAENOTCONN:result:='WSAENOTCONN';
WSAESHUTDOWN:result:='WSAESHUTDOWN';
WSAETOOMANYREFS:result:='WSAETOOMANYREFS';
WSAETIMEDOUT:result:='WSAETIMEDOUT';
WSAECONNREFUSED:result:='WSAECONNREFUSED';
WSAELOOP:result:='WSAELOOP';
WSAENAMETOOLONG:result:='WSAENAMETOOLONG';
WSAEHOSTDOWN:result:='WSAEHOSTDOWN';
WSAEHOSTUNREACH:result:='WSAEHOSTUNREACH';
WSAENOTEMPTY:result:='WSAENOTEMPTY';
WSAEPROCLIM:result:='WSAEPROCLIM';
WSAEUSERS:result:='WSAEUSERS';
WSAEDQUOT:result:='WSAEDQUOT';
WSAESTALE:result:='WSAESTALE';
WSAEREMOTE:result:='WSAEREMOTE';
WSASYSNOTREADY:result:='WSASYSNOTREADY';
WSAVERNOTSUPPORTED:result:='WSAVERNOTSUPPORTED';
WSANOTINITIALISED:result:='WSANOTINITIALISED';
WSAHOST_NOT_FOUND:result:='WSAHOST_NOT_FOUND';
WSATRY_AGAIN:result:='WSATRY_AGAIN';
WSANO_RECOVERY:result:='WSANO_RECOVERY';
WSANO_DATA:result:='WSANO_DATA';
else result:='WSAEUNKNOWN';
end;
end;
procedure TTCPServer.SetOnClientStreamReceive( const Value: TOnTCPStreamReceive);
begin
FOnClientStreamReceive := Value;
end;
procedure TTCPServer.SetOnClientStreamSend(const Value: TOnTCPStreamSend);
begin
FOnClientStreamSend := Value;
end;
{ TTCPServerClient }
procedure TTCPServerClient.Connect;
begin
showmessage('Can''t connect ServerClient');
end;
procedure TTCPServerClient.Disconnect;
var
i,j:integer;
srv:ptcpserver;
begin
if fserver<>nil then
begin
srv:=fserver;
fserver:=nil;
srv.lock;
i:=srv.fconnections.indexof(@self);
for j:=pred(srv.fconnections.count) downto succ(i) do dec(srv.connection[j].findex);
srv.fconnections.delete(i);
srv.unlock;
postmessage(srv.wnd,WM_SOCKETDESTROY,integer(@self),0);
end;
inherited;
end;
function TCPGetHostByName(name: pchar): string;
var
host:phostent;
adr:in_addr;
begin
host:=gethostbyname(name);
move(host.h_addr^^,adr,host.h_length);
result:=inet_ntoa(adr);
end;
procedure TTCPServerClient.SetIndex(const Value: Integer);
begin
showmessage('Can''t set index of ServerClient');
end;
initialization
instblocklist:=nil;
instfreelist:=nil;
end.

BIN
Addons/mckCProgBar.dcr
View File

Binary file not shown.

306
Addons/mckCProgBar.pas
View File

@ -1,306 +0,0 @@
unit mckCProgBar;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ComCtrls, ExtCtrls, mirror;
type
TBevel = (bvUp, bvDown, bvNone);
TColorProgressBar = class(TKOLControl)
private
{ Private declarations }
fPosition: integer;
fOldPosit: integer;
fBColor,
fFColor : TColor;
fFirst : boolean;
fBorder : integer;
fParentCl: boolean;
// fBrush : boolean;
fBevel : TBevel;
fMin,
fMax : integer;
fStr : string;
procedure SetFColor(C: TColor);
procedure SetBColor(C: TColor);
procedure SetPosition(P: integer);
procedure SetBorder(B: integer);
procedure SetParentCl(B: boolean);
procedure SetBevel(B: TBevel);
procedure SetMin(M: integer);
procedure SetMax(M: integer);
protected
{ Protected declarations }
procedure WMPaint(var Msg: TMessage); message WM_PAINT;
procedure WMSize (var Msg: TMessage); message WM_SIZE;
procedure WMActiv(var Msg: TMessage); message WM_SHOWWINDOW;
procedure CMParCl(var Msg: TMessage); message CM_PARENTCOLORCHANGED;
function AdditionalUnits: string; override;
procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override;
public
{ Public declarations }
constructor Create(Owner: TComponent); override;
procedure Paint; override;
published
{ Published declarations }
property FColor: TColor read fFColor write SetFColor;
property BColor: TColor read fBColor write SetBColor;
property Border: integer read fBorder write SetBorder;
property Position: integer read fPosition write SetPosition;
property Max: integer read fMax write SetMax;
property Min: integer read fMin write SetMin;
property ParentColor: boolean read fParentCl write SetParentCl;
property Bevel: TBevel read fBevel write SetBevel;
{ property Font;}
end;
procedure Register;
implementation
{$R *.dcr}
procedure Register;
begin
RegisterComponents('KOLAddons', [TColorProgressBar]);
end;
constructor TColorProgressBar.Create;
begin
inherited;
fBColor := ClBtnFace;
fFColor := ClRed;
Width := 100;
Height := 30;
fFirst := True;
fBorder := 4;
fPosition := 50;
fMin := 0;
fMax := 100;
Font.FontHeight := -17;
Font.FontStyle := [fsBold];
end;
procedure TColorProgressBar.WMPaint;
begin
inherited;
Paint;
end;
procedure TColorProgressBar.WMSize;
begin
inherited;
fFirst := True;
Paint;
end;
procedure TColorProgressBar.WMActiv;
begin
inherited;
fFirst := True;
Paint;
end;
procedure TColorProgressBar.CMParCl;
begin
inherited;
if fParentCl then begin
if Msg.wParam <> 0 then
BColor := TColor(Msg.lParam) else
BColor := (Parent as TForm).Color;
FColor := (Parent as TForm).Font.Color;
end;
end;
function TColorProgressBar.AdditionalUnits;
begin
Result := ', KOLProgBar';
end;
procedure TColorProgressBar.SetupFirst;
var St: string;
begin
inherited;
if fPosition <> 50 then begin
SL.Add( Prefix + AName + '.Position := ' + inttostr(fPosition) + ';');
end;
if fBorder <> 4 then begin
SL.Add( Prefix + AName + '.Border := ' + inttostr(fBorder) + ';');
end;
if fMin <> 0 then begin
SL.Add( Prefix + AName + '.Min := ' + inttostr(fMin) + ';');
end;
if fMax <> 100 then begin
SL.Add( Prefix + AName + '.Max := ' + inttostr(fMax) + ';');
end;
if fFColor <> clRed then begin
SL.Add( Prefix + AName + '.FColor := ' + color2str(fFColor) + ';');
end;
if fBColor <> clRed then begin
SL.Add( Prefix + AName + '.BColor := ' + color2str(fBColor) + ';');
end;
if fBevel <> bvDown then begin
if fBevel = bvUp then St := 'bvUp' else St := 'bvNone';
SL.Add( Prefix + AName + '.Bevel := ' + St + ';');
end;
end;
procedure TColorProgressBar.SetFColor;
begin
fFColor := C;
fFirst := True;
Paint;
end;
procedure TColorProgressBar.SetBColor;
begin
fBColor := C;
fFirst := True;
Paint;
end;
procedure TColorProgressBar.SetPosition;
begin
fPosition := P;
Paint;
end;
procedure TColorProgressBar.SetBorder;
begin
fBorder := B;
fFirst := True;
Paint;
end;
procedure TColorProgressBar.SetParentCl;
begin
fParentCl := B;
if B then begin
Perform(CM_PARENTCOLORCHANGED, 0, 0);
Paint;
end;
end;
procedure TColorProgressBar.SetBevel;
begin
fBevel := B;
fFirst := True;
Paint;
end;
procedure TColorProgressBar.SetMin;
begin
fMin := M;
fFirst := True;
if fMax = fMin then fMax := fMin + 1;
Paint;
end;
procedure TColorProgressBar.SetMax;
begin
fMax := M;
fFirst := True;
if fMin = fMax then fMin := fMax - 1;
Paint;
end;
procedure TColorProgressBar.Paint;
var Rct: TRect;
Trc: TRect;
Twk: TRect;
Str: string;
Rht: integer;
Len: integer;
Rgn: HRgn;
begin
Rct := GetClientRect;
Trc := Rct;
if (fPosition <= fOldPosit) or fFirst or
(csDesigning in ComponentState) then begin
case fBevel of
bvUp: begin
Frame3D(Canvas, Rct, clWhite, clBlack, 1);
end;
bvDown: begin
Frame3D(Canvas, Rct, clBlack, clWhite, 1);
end;
end;
fFirst := False;
Canvas.brush.Color := fBColor;
Canvas.FillRect(Rct);
end;
Rct := Trc;
InflateRect(Rct, -fBorder, -fBorder);
Rct.Right := Rct.Left + (Rct.Right - Rct.Left) * fPosition div (Max - Min);
Str := ' ' + inttostr(fPosition * 100 div (fMax - fMin)) + '% ';
Trc.Left := (width - Canvas.TextWidth(Str)) div 2;
Trc.Right := (width + Canvas.TextWidth(Str)) div 2 + 1;
if (Rct.Right <= Trc.Left) then begin
Canvas.brush.Color := fFColor;
Canvas.FillRect(Rct);
end else begin
Canvas.brush.Color := fFColor;
Twk := Rct;
Twk.Right := Trc.Left;
Canvas.FillRect(Twk);
end;
Rht := Rct.Right;
Canvas.Font.Name := Font.FontName;
Canvas.Font.Height := Font.FontHeight;
Canvas.Font.Color := Font.Color;
Canvas.Font.Style := Font.FontStyle;
Len := Length(Str);
Rct.Left := (width - Canvas.TextWidth(Str)) div 2;
Rct.Right := (width + Canvas.TextWidth(Str)) div 2 + 1;
if (fStr <> Str) or ffirst or (csDesigning in ComponentState) then begin
if (Rct.Right > Rht) or (Canvas.TextHeight(Str) > (Rct.Bottom - Rct.Top)) then begin
Rgn := CreateRectRgn({Left +} Rht, {Top +} Rct.Top, {Left +} Rct.Right, {Top +} Rct.Bottom);
SelectClipRgn(Canvas.Handle, Rgn);
Canvas.brush.Color := fBColor;
SetTextColor(Canvas.Handle, ColorToRGB(fFColor));
DrawText(Canvas.Handle, @Str[1], Len, Rct, DT_TOP {or DT_NOCLIP});
SelectClipRgn(Canvas.Handle, 0);
DeleteObject(Rgn);
end;
end;
if Rht < Rct.Right then begin
Rct.Right := Rht;
end;
Dec(Rct.Left);
Inc(Rct.Right);
if (Rct.Right > Rct.Left) then begin
Canvas.brush.Color := fFColor;
SetTextColor(Canvas.Handle, ColorToRGB(fBColor));
DrawText(Canvas.Handle, @Str[1], Len, Rct, DT_TOP);
if Rct.Right < Trc.Right then begin
Twk := Rct;
Twk.Top := Twk.Top + Canvas.TextHeight(Str);
Canvas.Fillrect(Twk);
end;
end;
if (Rct.Right >= Trc.Right) then begin
Canvas.brush.Color := fFColor;
Rct.Left := Trc.Right - 1;
Rct.Right := Rht;
Canvas.FillRect(Rct);
end;
fStr := Str;
fOldPosit := fPosition;
end;
end.

BIN
Addons/mckHTTP.dcr
View File

Binary file not shown.

154
Addons/mckHTTP.pas
View File

@ -1,154 +0,0 @@
unit mckHTTP;
interface
uses
Windows, Classes, Messages, Forms, SysUtils,
KOLRAS, mirror, KOL, KOLHTTP;
type
PKOLHttp =^TKOLHttp;
TKOLHttp = class(TKOLObj)
private
fUserName: string;
fUserPass: string;
fHostAddr: string;
fHostPort: string;
fProxyAdr: string;
fProxyPrt: string;
fOnHttpClo: TOnEvent;
public
constructor Create(Owner: TComponent); override;
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;
procedure SetUserName(Value: string);
procedure SetUserPass(Value: string);
procedure SetHostAddr(Value: string);
procedure SetHostPort(Value: string);
procedure SetProxyAdr(Value: string);
procedure SetProxyPrt(Value: string);
procedure SetOnHttpClo(Value: TOnEvent);
published
property UserName : string read fUserName write SetUserName;
property Password : string read fUserPass write SetUserPass;
property Url : string read fHostAddr write SetHostAddr;
property Port : string read fHostPort write SetHostPort;
property ProxyAddr: string read fProxyAdr write SetProxyAdr;
property ProxyPort: string read fProxyPrt write SetProxyPrt;
property OnClose : TOnEvent read fOnHttpClo write SetOnHttpClo;
end;
procedure Register;
implementation
{$R *.dcr}
constructor TKOLHttp.create;
begin
inherited create(Owner);
fHostPort := '80';
end;
procedure TKOLHttp.SetUserName;
begin
fUserName := Value;
Change;
end;
procedure TKOLHttp.SetUserPass;
begin
fUserPass := Value;
Change;
end;
procedure TKOLHttp.SetHostAddr;
begin
fHostAddr := Value;
Change;
end;
procedure TKOLHttp.SetHostPort;
begin
fHostPort := Value;
Change;
end;
procedure TKOLHttp.SetProxyAdr;
begin
fProxyAdr := Value;
Change;
end;
procedure TKOLHttp.SetProxyPrt;
begin
fProxyPrt := Value;
Change;
end;
procedure TKOLHttp.SetOnHttpClo;
begin
fOnHttpClo := Value;
Change;
end;
function TKOLHttp.AdditionalUnits;
begin
Result := ', KOLHttp';
end;
procedure TKOLHttp.SetupFirst(SL: TStringList; const AName,
AParent, Prefix: String);
begin
SL.Add( Prefix + AName + ' := NewKOLHttpControl;' );
if fUserName <> '' then
SL.Add( Prefix + AName + '.UserName := ''' + fUserName + ''';');
if fUserPass <> '' then
SL.Add( Prefix + AName + '.Password := ''' + fUserPass + ''';');
if fHostAddr <> '' then
SL.Add( Prefix + AName + '.Url := ''' + fHostAddr + ''';');
if fHostPort <> '80' then
SL.Add( Prefix + AName + '.HostPort := ' + fHostPort + ';');
if fProxyAdr <> '' then
SL.Add( Prefix + AName + '.ProxyAddr := ''' + fProxyAdr + ''';');
if fProxyPrt <> '' then
SL.Add( Prefix + AName + '.ProxyPort := ' + fProxyPrt + ';');
end;
procedure TKOLHttp.SetupLast(SL: TStringList; const AName,
AParent, Prefix: String);
begin
//
end;
procedure TKOLHttp.AssignEvents(SL: TStringList; const AName: String);
begin
inherited;
DoAssignEvents( SL, AName,
[ 'OnClose' ],
[ @OnClose ]);
end;
procedure Register;
begin
RegisterComponents('KOLAddons', [TKOLHttp]);
end;
end.

BIN
Addons/mckHTTPDownload.dcr
View File

Binary file not shown.

216
Addons/mckHTTPDownload.pas
View File

@ -1,216 +0,0 @@
{$IFDEF FPC}
{$mode delphi}
{$ENDIF}
unit mckHTTPDownload;
{
("`-''-/").___..--''"`-._
`6_ 6 ) `-. ( ).`-.__.`)
(_Y_.)' ._ ) `._ `. ``-..-'
_..`--'_..-_/ /--'_.' ,'
(il).-'' (li).' ((!.-'
Download with HTTP-protocol (MCK Classes)
Copyright � 2007-2008 Denis Fateyev (Danger)
Website: <http://fateyev.com>
E-Mail: <denis@fateyev.com>
}
interface
// ----------------------------------------------------------
uses
Windows, Classes, Messages, Forms, SysUtils, mirror,
KOL, KOLHTTPDownload {$IFDEF FPC}, LResources {$ENDIF};
// ----------------------------------------------------------
type
PKOLHttpDownload =^TKOLHttpDownload;
TKOLHttpDownload = class( TKOLObj )
private
fUserName: string;
fUserPass: string;
fProxyAddr: string;
fProxyPort: Integer;
fPreconfProxy: Boolean;
fOnError: THTTPErrorEvent;
fOnDownload: THTTPDownloadEvent;
fOnProgress: THTTPProgressEvent;
fOnHeaderReceived: THTTPHdrRecvEvent;
public
constructor Create( Owner: TComponent ); override;
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;
procedure SetUserName( Value: string );
procedure SetUserPass( Value: string );
procedure SetProxyAddr( Value: string );
procedure SetProxyPort( Value: Integer );
procedure SetPreconfProxy( Value: Boolean );
procedure SetOnDownload( Value: THTTPDownloadEvent );
procedure SetOnError( Value: THTTPErrorEvent );
procedure SetOnProgress( Value: THTTPProgressEvent );
procedure SetOnHeaderReceived( Value: THTTPHdrRecvEvent );
published
property authUserName : string read fUserName write SetUserName;
property authPassword : string read fUserPass write SetUserPass;
property ProxyServer : string read fProxyAddr write SetProxyAddr;
property ProxyPort : Integer read fProxyPort write SetProxyPort;
property PreconfigProxy: Boolean read fPreconfProxy write SetPreconfProxy;
property OnDownload : THTTPDownloadEvent read fOnDownload write SetOnDownload;
property OnProgress : THTTPProgressEvent read fOnProgress write SetOnProgress;
property OnHeaderReceived : THTTPHdrRecvEvent read fOnHeaderReceived write SetOnHeaderReceived;
property OnError : THTTPErrorEvent read fOnError write SetOnError;
end;
// ----------------------------------------------------------
procedure Register;
implementation
// ----------------------------------------------------------
procedure Register;
begin
RegisterComponents('KOLAddons', [TKOLHttpDownload]);
end;
// ----------------------------------------------------------
{ TKOLHttpDownload }
constructor TKOLHttpDownload.Create;
begin
inherited Create( Owner );
fPreconfProxy:= false;
end;
// ----------------------------------------------------------
procedure TKOLHttpDownload.SetUserName;
begin
fUserName:= Value;
Change;
end;
// ----------------------------------------------------------
procedure TKOLHttpDownload.SetUserPass;
begin
fUserPass:= Value;
Change;
end;
// ----------------------------------------------------------
procedure TKOLHttpDownload.SetProxyAddr;
begin
fProxyAddr:= Value;
Change;
end;
// ----------------------------------------------------------
procedure TKOLHttpDownload.SetProxyPort;
begin
if fProxyAddr = '' then fProxyPort:= 0
else fProxyPort := Value;
Change;
end;
// ----------------------------------------------------------
procedure TKOLHttpDownload.SetPreconfProxy;
begin
fPreconfProxy:= Value;
Change;
end;
// ----------------------------------------------------------
procedure TKOLHttpDownload.SetOnDownload;
begin
fOnDownload:= Value;
Change;
end;
// ----------------------------------------------------------
procedure TKOLHttpDownload.SetOnError;
begin
fOnError:= Value;
Change;
end;
// ----------------------------------------------------------
procedure TKOLHttpDownload.SetOnProgress;
begin
fOnProgress:= Value;
Change;
end;
// ----------------------------------------------------------
procedure TKOLHttpDownload.SetOnHeaderReceived;
begin
fOnHeaderReceived := Value;
Change;
end;
// ----------------------------------------------------------
function TKOLHttpDownload.AdditionalUnits;
begin
Result := ', KOLHTTPDownload';
end;
// ----------------------------------------------------------
procedure TKOLHttpDownload.SetupFirst(SL: TStringList; const AName,
AParent, Prefix: String);
begin
SL.Add( Prefix + AName + ' := NewHTTPDownload;' );
if ( fPreconfProxy ) then
SL.Add( Prefix + AName + '.UsePreconfigProxy:= true; ')
else
begin
if ( fProxyAddr <> '' ) then
begin
SL.Add( Prefix + AName + '.ProxyServer := ''' + fProxyAddr + ''';');
if ( fProxyPort <> 0 ) then
SL.Add( Prefix + AName + '.ProxyPort := ' + IntToStr( fProxyPort ) + ';');
end;
end;
if ( fUserName <> '' ) or ( fUserPass <> '' ) then
SL.Add( Prefix + AName + '.SetAuthInfo( ''' + fUserName + ''', ''' + fUserPass +''' );');
end;
// ----------------------------------------------------------
procedure TKOLHttpDownload.SetupLast(SL: TStringList; const AName,
AParent, Prefix: String);
begin
//
end;
// ----------------------------------------------------------
procedure TKOLHttpDownload.AssignEvents(SL: TStringList; const AName: String);
begin
inherited;
DoAssignEvents( SL, AName, [ 'OnDownload' ], [ @OnDownload ]);
DoAssignEvents( SL, AName, [ 'OnProgress' ], [ @OnProgress ]);
DoAssignEvents( SL, AName, [ 'OnHeaderReceived' ], [ @OnHeaderReceived ]);
DoAssignEvents( SL, AName, [ 'OnError' ], [ @OnError ]);
end;
// ----------------------------------------------------------
{$IFDEF FPC}
initialization
{$I mckHTTPDownload.lrs}
{$ENDIF}
// ----------------------------------------------------------
end.

BIN
Addons/mckKOLTable.dcr
View File

Binary file not shown.

526
Addons/mckKOLTable.pas
View File

@ -1,526 +0,0 @@
unit mckKOLTable;
interface
uses
Windows, Classes, Messages, Forms, SysUtils,
mirror, mckCtrls, Graphics, KOLEdb, ADOdb,
ADOConEd, mckListEdit, DB, KOL,
ExptIntf, ToolIntf, EditIntf, // DsgnIntf
//////////////////////////////////////////////////
{$IFDEF VER140} //
DesignIntf, DesignEditors, DesignConst, //
Variants //
{$ELSE} //
DsgnIntf //
{$ENDIF} //
//////////////////////////////////////////////////
{$IFNDEF VER90}{$IFNDEF VER100}, ToolsAPI{$ENDIF}{$ENDIF},
TypInfo, Consts;
type
PKOLDataSource =^TKOLDataSource;
TKOLDataSource = class(TKOLObj)
private
fConnection: WideString;
AQ: TADOQuery;
protected
function AdditionalUnits: string; override;
function TypeName: string; override;
function CompareFirst( c, n: string): boolean; override;
procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override;
function GetConnection: WideString;
procedure SetConnection(Value: WideString);
public
constructor Create(AOwner: TComponent); override;
published
property Connection: WideString read GetConnection write SetConnection;
end;
TKOLSession = class(TKOLObj)
private
fDataSource: TKOLDataSource;
protected
function AdditionalUnits: string; override;
function TypeName: string; override;
function CompareFirst( c, n: string): boolean; override;
procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override;
procedure SetDataSource(DS: TKOLDataSource);
published
property DataSource: TKOLDataSource read fDataSource write SetDataSource;
end;
TKOLQuery = class(TKOLObj)
private
fSession: TKOLSession;
fTableName: WideString;
fText: string;
protected
function AdditionalUnits: string; override;
function TypeName: string; override;
function CompareFirst( c, n: string): boolean; override;
procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override;
procedure SetSession(SS: TKOLSession);
procedure SetText (Tt: string);
function GetTableName: WideString;
procedure SetTableName(Value: WideString);
published
property Session: TKOLSession read fSession write SetSession;
property SQL: string read fText write SetText;
property TableName: WideString read GetTableName write SetTableName;
end;
TTableStringProperty = class(TStringProperty)
public
function GetAttributes: TPropertyAttributes; override;
procedure Edit; override;
end;
TTableNameProperty = class(TStringProperty)
private
FConnection: TADOConnection;
public
function AutoFill: Boolean; override;
function GetAttributes: TPropertyAttributes; override;
function GetConnection(Opened: Boolean): TADOConnection;
procedure GetValueList(List: TStrings);
procedure GetValues(Proc: TGetStrProc); override;
end;
TKOLListData = class(TKOLListEdit)
private
fAutoOpen: boolean;
fOnRowChanged: TOnEvent;
fQuery: TKOLQuery;
fColCount: integer;
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;
procedure SetAutoOpen(Value: boolean);
function GetColCount: integer;
procedure SetColCount(Value: integer);
procedure SetQuery(Value: TKOLQuery);
procedure SetOnRowChanged(Value: TOnEvent);
procedure DoRequest(Full: boolean);
procedure Loaded; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure UpdateColumns; override;
published
property AutoOpen: boolean read fAutoOpen write SetAutoOpen;
property ColCount read GetColCount write SetColCount;
property Query: TKOLQuery read fQuery write SetQuery;
property OnRowChanged: TOnEvent read fOnRowChanged write SetOnRowChanged;
end;
procedure Register;
implementation
uses Ustr;
{$R *.dcr}
function TTableStringProperty.GetAttributes: TPropertyAttributes;
begin
Result := [paDialog];
end;
procedure TTableStringProperty.Edit;
begin
if EditConnectionString((GetComponent(0) as TKOLDataSource).AQ) then begin
Modified;
end;
end;
constructor TKOLDataSource.Create;
begin
inherited;
AQ := TADOQuery.Create(self);
end;
function TKOLDataSource.AdditionalUnits;
begin
Result := ', OLETable, KOLEdb';
end;
function TKOLDataSource.TypeName;
begin
Result := 'TKOLDataSource';
end;
function TKOLDataSource.CompareFirst;
begin
Result := False;
if c = '' then Result := True;
end;
procedure TKOLDataSource.SetupFirst;
var s: string;
c: string;
t: string;
begin
SL.Add( Prefix + AName + ' := NewDataSource(');
c := '''' + fConnection + ''');';
repeat
t := Prefix + copy(c, 1, 77 - length(Prefix));
delete(c, 1, 77 - length(Prefix));
if c <> '' then begin
t := t + ''' +';
c := '''' + c;
end;
SL.Add(t);
until length(c) = 0;
end;
function TKOLDataSource.GetConnection;
begin
fConnection := AQ.ConnectionString;
Result := fConnection;
end;
procedure TKOLDataSource.SetConnection;
begin
fConnection := Value;
AQ.ConnectionString := Value;
Change;
end;
function TKOLSession.AdditionalUnits;
begin
Result := ', OLETable, KOLEdb';
end;
function TKOLSession.TypeName;
begin
Result := 'TKOLSession';
end;
function TKOLSession.CompareFirst;
begin
Result := False;
if c = '' then Result := True;
if c = 'TKOLDataSource' then Result := True;
end;
procedure TKOLSession.SetupFirst;
begin
SL.Add( Prefix + AName + ' := NewSession( Result.' + fDataSource.Name + ' );' );
end;
procedure TKOLSession.SetDataSource;
begin
fDataSource := DS;
Change;
end;
function TKOLQuery.AdditionalUnits;
begin
Result := ', OLETable, KOLEdb';
end;
function TKOLQuery.TypeName;
begin
Result := 'TKOLQuery';
end;
function TKOLQuery.CompareFirst;
begin
Result := False;
if c = '' then Result := True;
if c = 'TKOLDataSource' then Result := True;
if c = 'TKOLSession' then Result := True;
end;
procedure TKOLQuery.SetupFirst;
begin
SL.Add( Prefix + AName + ' := NewQuery( Result.' + fSession.Name + ' );' );
if fText <> '' then begin
SL.Add( Prefix + AName + '.Text := ''' + fText + ''';');
end else
if fTableName <> '' then begin
SL.Add( Prefix + AName + '.Text := ''Select * from ' + fTableName + ''';');
end;
end;
procedure TKOLQuery.SetSession;
begin
fSession := SS;
Change;
end;
procedure TKOLQuery.SetText;
begin
fText := Tt;
Change;
end;
function TTableNameProperty.GetAttributes: TPropertyAttributes;
begin
Result := [paValueList, paSortList, paMultiSelect];
end;
function TTableNameProperty.GetConnection(Opened: Boolean): TADOConnection;
var
Component: TComponent;
Connection: string;
begin
Result := FConnection;
Component := (GetComponent(0) as TKOLQuery).Session.DataSource;
Connection := TypInfo.GetStrProp(Component,
TypInfo.GetPropInfo(Component.ClassInfo, 'Connection'));
if Connection = '' then Exit;
FConnection := TADOConnection.Create(nil);
FConnection.ConnectionString := Connection;
FConnection.LoginPrompt := False;
Result := FConnection;
Result.Open;
end;
procedure TTableNameProperty.GetValueList(List: TStrings);
var
Connection: TADOConnection;
begin
Connection := GetConnection(True);
if Assigned(Connection) then
try
Connection.GetTableNames(List);
finally
FConnection.Free;
FConnection := nil;
end;
end;
procedure TTableNameProperty.GetValues;
var l: TStringList;
i: integer;
begin
l := TStringList.Create;
GetValueList(l);
for i := 0 to l.Count - 1 do
Proc(l[i]);
l.Free;
end;
function TTableNameProperty.AutoFill: Boolean;
var
Connection: TADOConnection;
begin
Connection := GetConnection(False);
Result := Assigned(Connection) and Connection.Connected;
end;
constructor TKOLListData.Create;
begin
inherited;
IsListData := True;
end;
destructor TKOLListData.Destroy;
begin
inherited;
end;
function TKOLListData.AdditionalUnits;
begin
Result := ', OLETable, KOLEdb';
end;
procedure TKOLListData.SetupFirst;
begin
inherited;
DoRequest(True);
if fQuery <> nil then begin
if not fQuery.fSession.fDataSource.AQ.Active then fAutoOpen := False;
SL.Add( Prefix + AName + '.Query := Result.' + fQuery.Name + ';');
end;
end;
procedure TKOLListData.SetupLast;
begin
inherited;
if fQuery <> nil then begin
if fAutoOpen then
SL.Add( Prefix + AName + '.Open;' );
end;
end;
procedure TKOLListData.AssignEvents;
begin
inherited;
DoAssignEvents( SL, AName,
[ 'OnRowChanged'],
[ @OnRowChanged ]);
end;
procedure TKOLListData.SetAutoOpen;
begin
fAutoOpen := Value;
Change;
end;
function TKOLListData.GetColCount;
begin
Result := fColCount;
end;
procedure TKOLListData.SetColCount;
var i: integer;
n: integer;
a: TADOQuery;
t: TListEditColumnsItem;
e: boolean;
begin
if Value > 0 then begin
fColCount := Value;
end;
while Columns.Count > fColCount do begin
Columns.Delete(Columns.Count - 1);
end;
DoRequest(True);
a := nil;
if fQuery <> nil then begin
if fQuery.fSession <> nil then begin
if fQuery.fSession.fDataSource <> nil then begin
a := fQuery.fSession.fDataSource.AQ;
end;
end;
end;
if a <> nil then begin
for i := 0 to a.FieldCount - 1 do begin
e := True;
for n := 0 to Columns.Count - 1 do begin
t := Columns.Items[n];
if t.FieldName = a.Fields[i].FieldName then begin
e := False;
break;
end;
end;
if e and (Columns.Count < fColCount) then begin
t := TListEditColumnsItem(Columns.Add);
t.Caption := a.Fields[i].FieldName;
t.FieldName := a.Fields[i].FieldName;
case a.Fields[i].DataType of
ftString,
ftWideString: t.Alignment := taLeftJustify;
else
t.Alignment := taRightJustify;
end;
t.Width := Canvas.TextWidth(Replicate('Q', a.Fields[i].DisplayWidth));
end;
end;
UpDateColumns;
end;
end;
procedure TKOLListData.SetOnRowChanged;
begin
fOnRowChanged := Value;
Change;
end;
procedure TKOLListData.DoRequest;
begin
if fQuery <> nil then begin
if fQuery.fText <> '' then begin
fQuery.fSession.fDataSource.AQ.SQL.Clear;
{ fQuery.fSession.fDataSource.AQ.SQL.Add(fQuery.fText);}
fQuery.fSession.fDataSource.AQ.SQL.Add('Select * from ' + fQuery.fTableName);
try
fQuery.fSession.fDataSource.AQ.Open;
except
on E: Exception do MsgOK(E.Message);
end;
end else
if fQuery.fTableName <> '' then begin
fQuery.fSession.fDataSource.AQ.SQL.Clear;
fQuery.fSession.fDataSource.AQ.SQL.Add('Select * from ' + fQuery.fTableName);
try
fQuery.fSession.fDataSource.AQ.Open;
except
on E: Exception do MsgOK(E.Message);
end;
end;
end;
end;
procedure TKOLListData.Loaded;
var i: integer;
n: integer;
a: TADOQuery;
t: TListEditColumnsItem;
e: boolean;
begin
inherited;
DoRequest(True);
a := nil;
if fQuery <> nil then begin
if fQuery.fSession <> nil then begin
if fQuery.fSession.fDataSource <> nil then begin
a := fQuery.fSession.fDataSource.AQ;
end;
end;
end;
if a <> nil then begin
Columns.FieldNames.Clear;
for i := 0 to a.FieldCount - 1 do begin
Columns.FieldNames.Add(a.Fields[i].FieldName);
end;
end;
end;
procedure TKOLListData.UpdateColumns;
var s: string;
i: integer;
f: string;
begin
s := '';
for i := 0 to Columns.Count - 1 do begin
if Columns.Items[i].FieldName <> '' then begin
s := s + '[' + Columns.Items[i].FieldName + ']' + ',';
end;
end;
s := copy(s, 1, length(s) - 1);
if fQuery = nil then begin
MsgOK('Query is not defined !');
exit;
end;
i := pos('FROM', UpSt(fQuery.fText));
if i > 0 then f := copy(fQuery.fText, i + 5, length(fQuery.fText) - i - 4)
else f := fQuery.TableName;
if trim(s) = '' then s := '*';
if trim(f) = '' then f := fQuery.TableName;
fQuery.fText := 'Select ' + s + ' from ' + f;
Change;
end;
function TKOLQuery.GetTableName;
begin
Result := fTableName;
end;
procedure TKOLQuery.SetTableName;
begin
fTableName := Value;
Change;
end;
procedure TKOLListData.SetQuery;
begin
fQuery := Value;
Change;
end;
procedure Register;
begin
RegisterComponents ('KOLData', [TKOLDataSource, TKOLSession, TKOLQuery, TKOLListData]);
RegisterPropertyEditor (TypeInfo(WideString), TKOLDataSource, 'Connection', TTableStringProperty);
RegisterPropertyEditor (TypeInfo(WideString), TKOLQuery, 'TableName', TTableNameProperty);
end;
end.

BIN
Addons/mckListEdit.dcr
View File

Binary file not shown.

226
Addons/mckListEdit.pas
View File

@ -1,226 +0,0 @@
unit mckListEdit;
interface
uses
Windows, Classes, Messages, Forms, SysUtils,
mckCtrls, Graphics;
type
TListEditColumns = class;
TKOLListEdit = class(TKOLListView)
private
fColumns: TListEditColumns;
fColCount: integer;
fListData: boolean;
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;
function GetCaption: string;
function GetStyle: TKOLListViewStyle;
function GetOptions: TKOLListViewOptions;
procedure SetOptions(v: TKOLListViewOptions);
function GetColumns: TListEditColumns; virtual;
procedure SetColumns(v: TListEditColumns);
function GetColCount: integer;
procedure SetColCount(v: integer);
public
constructor Create(Owner: TComponent); override;
property IsListData: boolean read fListData write fListData;
procedure UpdateColumns; virtual;
published
property Caption: string Read GetCaption;
property Style: TKOLListViewStyle Read GetStyle;
property Options: TKOLListViewOptions read GetOptions write SetOptions;
property Columns: TListEditColumns read fColumns write SetColumns;
property ColCount: integer read GetColCount write SetColCount;
end;
TListEditColumnsItem = class(TCollectionItem)
private
fCaption: string;
fAlign: TAlignment;
fWidth: integer;
fFieldName: string;
protected
procedure SetAlignment(a: TAlignment);
procedure SetCaption(c: string);
procedure SetWidth(w: integer);
published
property Alignment: TAlignment read fAlign write fAlign;
property Caption: string read fCaption write fCaption;
property Width: integer read fWidth write fWidth;
property FieldName: string read fFieldName write fFieldName;
end;
TListEditColumns = class(TCollection)
private
FOwner: TKOLListEdit;
function GetItem(Index: Integer): TListEditColumnsItem;
procedure SetItem(Index: Integer; Value: TListEditColumnsItem);
protected
function GetOwner: TPersistent; override;
public
FieldNames: TStringList;
constructor Create(AOwner: TKOLListEdit);
destructor Destroy; override;
function Owner: TKOLListEdit;
property Items[Index: Integer]: TListEditColumnsItem read GetItem write SetItem; default;
end;
procedure Register;
implementation
{$R *.dcr}
constructor TKOLListEdit.Create;
begin
inherited;
inherited Style := lvsDetail;
inherited Options := [lvoRowSelect];
Font.FontCharset := 204;
fColumns := TListEditColumns.Create(self);
end;
procedure TKOLListEdit.UpdateColumns;
begin
Change;
end;
function TKOLListEdit.AdditionalUnits;
begin
Result := ', ListEdit';
end;
procedure TKOLListEdit.SetupFirst;
var i: integer;
s: string;
begin
inherited;
for i := 0 to fColumns.Count - 1 do begin
case fColumns.Items[i].Alignment of
taLeftJustify: s := 'taLeft';
taCenter: s := 'taCenter';
taRightJustify: s := 'taRight';
end;
SL.Add( Prefix + AName + '.LVColAdd(''' + fColumns.Items[i].Caption + ''',' + s + ' , ' + intTostr(fColumns.Items[i].Width) + ');' );
end;
end;
procedure TKOLListEdit.SetupLast;
begin
inherited AssignEvents(SL, AName);
end;
procedure TKOLListEdit.AssignEvents;
begin
inherited;
end;
function TKOLListEdit.GetCaption;
begin
Result := inherited Caption;
end;
function TKOLListEdit.GetStyle;
begin
Result := lvsDetail;
end;
function TKOLListEdit.GetOptions;
begin
Result := inherited Options;
end;
procedure TKOLListEdit.SetOptions;
begin
inherited Options := v + [lvoRowSelect];
end;
function TKOLListEdit.GetColumns;
begin
Result := fColumns;
end;
procedure TKOLListEdit.SetColumns;
begin
fColumns.Assign(v);
Change;
end;
function TKOLListEdit.GetColCount;
begin
Result := fColumns.Count;
end;
procedure TKOLListEdit.SetColCount;
begin
fColCount := v;
if fColCount < 0 then fColCount := 0;
while fColCount > fColumns.Count do fColumns.Add;
while fColCount < fColumns.Count do fColumns[fColumns.Count - 1].Free;
Change;
end;
procedure TListEditColumnsItem.SetAlignment;
begin
fAlign := A;
TListEditColumns(GetOwner).FOwner.Change;
end;
procedure TListEditColumnsItem.SetCaption;
begin
fCaption := C;
end;
procedure TListEditColumnsItem.SetWidth;
begin
fWidth := W;
end;
constructor TListEditColumns.Create;
begin
inherited create(TListEditColumnsItem);
fOwner := AOwner;
FieldNames := TStringList.Create;
end;
destructor TListEditColumns.Destroy;
begin
FieldNames.Free;
inherited;
end;
function TListEditColumns.GetItem;
begin
result := TListEditColumnsItem(inherited GetItem(Index));
end;
procedure TListEditColumns.SetItem;
begin
inherited SetItem(Index, Value);
FOwner.Change;
end;
function TListEditColumns.GetOwner;
begin
result := FOwner;
end;
function TListEditColumns.Owner;
begin
result := FOwner;
end;
procedure Register;
begin
RegisterComponents('KOLAddons', [TKOLListEdit]);
end;
end.

BIN
Addons/mckPageSetup.dcr
View File

Binary file not shown.

BIN
Addons/mckPrintDialogs.dcr
View File

Binary file not shown.

BIN
Addons/mckQProgBar.dcr
View File

Binary file not shown.

1152
Addons/mckQProgBar.pas
View File

File diff suppressed because it is too large Load Diff

BIN
Addons/mckRAS.dcr
View File

Binary file not shown.

94
Addons/mckRAS.pas
View File

@ -1,94 +0,0 @@
unit mckRAS;
interface
uses
Windows, Classes, Messages, Forms, SysUtils,
KOLRAS, mirror;
type
TKOLRAS = class(TKOLObj)
private
fRASName: string;
FOnConnecting: TOnConnectingEvent;
FOnError: TOnErrorEvent;
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;
procedure SetRASName(Value: string);
procedure SetOnConnecting(Value: TOnConnectingEvent);
procedure SetOnError(Value: TOnErrorEvent);
published
property RASName: string read FRASName write SetRASName;
property OnConnecting: TOnConnectingEvent read FOnConnecting write SetOnConnecting;
property OnError: TOnErrorEvent read FOnError write SetOnError;
end;
procedure Register;
implementation
{$R *.dcr}
procedure TKOLRAS.SetRASName(Value: String);
begin
fRASName := Value;
Change;
end;
procedure TKOLRAS.SetOnConnecting;
begin
fOnConnecting := Value;
Change;
end;
procedure TKOLRAS.SetOnError;
begin
fOnError := Value;
Change;
end;
function TKOLRAS.AdditionalUnits;
begin
Result := ', KOLRAS';
end;
procedure TKOLRAS.SetupFirst(SL: TStringList; const AName,
AParent, Prefix: String);
begin
SL.Add( Prefix + AName + ' := NewRASObj;' );
if fRASName <> '' then
SL.Add( Prefix + AName + '.RASName := ''' + fRASName + ''';');
end;
procedure TKOLRAS.SetupLast(SL: TStringList; const AName,
AParent, Prefix: String);
begin
//
end;
procedure TKOLRAS.AssignEvents(SL: TStringList; const AName: String);
begin
inherited;
DoAssignEvents( SL, AName,
[ 'OnConnecting', 'OnError' ],
[ @OnConnecting , @OnError ]);
end;
procedure Register;
begin
RegisterComponents('KOLAddons', [TKOLRAS]);
end;
end.

BIN
Addons/mckRarInfoBar.dcr
View File

Binary file not shown.

372
Addons/mckRarInfoBar.pas
View File

@ -1,372 +0,0 @@
unit mckRarInfoBar;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
ComCtrls, ExtCtrls, Mirror;
const
Boolean2Str: array [Boolean] of string = ('False','True');
type
TRarInfoBar = class(TKOLControl)
private
{ Private declarations }
FPosition: integer;
FMin,FMax: integer;
FShowPerc: boolean;
FLineColor,FTopColor,FSideColor1,FSideColor2,FEmptyColor1,FEmptyColor2,
FEmptyFrameColor1,FEmptyFrameColor2,FBottomFrameColor,FBottomColor,
FFilledFrameColor,FFilledColor,FFilledSideColor1,FFilledSideColor2: TColor;
TopX,TopY,Size: integer;
procedure SetPos(P: integer);
procedure SetMin(M: integer);
procedure SetMax(M: integer);
procedure SetShowPerc(V: boolean);
procedure SetLineColor(C: TColor);
procedure SetTopColor(C: TColor);
procedure SetSideColor1(C: TColor);
procedure SetSideColor2(C: TColor);
procedure SetEmptyColor1(C: TColor);
procedure SetEmptyColor2(C: TColor);
procedure SetEmptyFrameColor1(C: TColor);
procedure SetEmptyFrameColor2(C: TColor);
procedure SetBottomFrameColor(C: TColor);
procedure SetBottomColor(C: TColor);
procedure SetFilledFrameColor(C: TColor);
procedure SetFilledColor(C: TColor);
procedure SetFilledSideColor1(C: TColor);
procedure SetFilledSideColor2(C: TColor);
protected
{ Protected declarations }
procedure WMPaint(var Msg: TMessage); message WM_PAINT;
procedure WMSize(var Msg: TMessage); message WM_SIZE;
procedure WMActiv(var Msg: TMessage); message WM_SHOWWINDOW;
function AdditionalUnits: string; override;
procedure SetupFirst(SL: TStringList; const AName,AParent,Prefix: string); override;
public
{ Public declarations }
constructor Create(Owner: TComponent); override;
procedure Paint; override;
published
{ Published declarations }
property Position: integer read FPosition write SetPos;
property Max: integer read FMax write SetMax;
property Min: integer read FMin write SetMin;
property ShowPercent: boolean read FShowPerc write SetShowPerc;
property LineColor: TColor read FLineColor write SetLineColor;
property TopColor: TColor read FTopColor write SetTopColor;
property SideColor1: TColor read FSideColor1 write SetSideColor1;
property SideColor2: TColor read FSideColor2 write SetSideColor2;
property EmptyColor1: TColor read FEmptyColor1 write SetEmptyColor1;
property EmptyColor2: TColor read FEmptyColor2 write SetEmptyColor2;
property EmptyFrameColor1: TColor read FEmptyFrameColor1 write SetEmptyFrameColor1;
property EmptyFrameColor2: TColor read FEmptyFrameColor2 write SetEmptyFrameColor2;
property BottomFrameColor: TColor read FBottomFrameColor write SetBottomFrameColor;
property BottomColor: TColor read FBottomColor write SetBottomColor;
property FilledFrameColor: TColor read FFilledFrameColor write SetFilledFrameColor;
property FilledColor: TColor read FFilledColor write SetFilledColor;
property FilledSideColor1: TColor read FFilledSideColor1 write SetFilledSideColor1;
property FilledSideColor2: TColor read FFilledSideColor2 write SetFilledSideColor2;
end;
procedure Register;
implementation
{$R mckRarInfoBar.dcr}
procedure Register;
begin
RegisterComponents('KOLAddons', [TRarInfoBar]);
end;
constructor TRarInfoBar.Create;
begin
inherited;
Width:=70;
Height:=180;
FMin:=0;
FMax:=100;
FPosition:=0;
FLineColor:=$FFE0E0;
FTopColor:=$FF8080;
FSideColor1:=$E06868;
FSideColor2:=$FF8080;
FEmptyFrameColor1:=$A06868;
FEmptyFrameColor2:=$BF8080;
FEmptyColor1:=$C06868;
FEmptyColor2:=$DF8080;
FBottomFrameColor:=$64408C;
FBottomColor:=$7A408C;
FFilledFrameColor:=$8060A0;
FFilledSideColor1:=$823C96;
FFilledSideColor2:=$8848C0;
FFilledColor:=$A060A0;
FShowPerc:=True;
Font.FontStyle:=[fsBold];
Font.Color:=clPurple;
end;
procedure TRarInfoBar.WMPaint;
begin
inherited;
Paint;
end;
procedure TRarInfoBar.WMSize;
begin
inherited;
Paint;
end;
procedure TRarInfoBar.WMActiv;
begin
inherited;
Paint;
end;
function TRarInfoBar.AdditionalUnits;
begin
Result:=', KOLRarBar';
end;
procedure TRarInfoBar.SetupFirst;
begin
inherited;
SL.Add(Prefix+AName+'.Position := '+IntToStr(FPosition)+';');
SL.Add(Prefix+AName+'.Min := '+IntToStr(FMin)+';');
SL.Add(Prefix+AName+'.Max := '+IntToStr(FMax)+';');
SL.Add(Prefix+AName+'.ShowPercent := '+Boolean2Str[FShowPerc]+';');
SL.Add(Prefix+AName+'.LineColor := '+Color2Str(FLineColor)+';');
SL.Add(Prefix+AName+'.TopColor := '+Color2Str(FTopColor)+';');
SL.Add(Prefix+AName+'.SideColor1 := '+Color2Str(FSideColor1)+';');
SL.Add(Prefix+AName+'.SideColor2 := '+Color2Str(FSideColor2)+';');
SL.Add(Prefix+AName+'.EmptyFrameColor1 := '+Color2Str(FEmptyFrameColor1)+';');
SL.Add(Prefix+AName+'.EmptyFrameColor2 := '+Color2Str(FEmptyFrameColor2)+';');
SL.Add(Prefix+AName+'.EmptyColor1 := '+Color2Str(FEmptyColor1)+';');
SL.Add(Prefix+AName+'.EmptyColor2 := '+Color2Str(FEmptyColor2)+';');
SL.Add(Prefix+AName+'.BottomFrameColor := '+Color2Str(FBottomFrameColor)+';');
SL.Add(Prefix+AName+'.BottomColor := '+Color2Str(FBottomColor)+';');
SL.Add(Prefix+AName+'.FilledFrameColor := '+Color2Str(FFilledFrameColor)+';');
SL.Add(Prefix+AName+'.FilledSideColor1 := '+Color2Str(FFilledSideColor1)+';');
SL.Add(Prefix+AName+'.FilledSideColor2 := '+Color2Str(FFilledSideColor2)+';');
SL.Add(Prefix+AName+'.FilledColor := '+Color2Str(FFilledColor)+';');
end;
procedure TRarInfoBar.SetPos;
begin
if P>FMax then P:=FMax;
FPosition:=P;
Paint;
end;
procedure TRarInfoBar.SetMin;
begin
if M>FMax then M:=FMax;
FMin:=M;
Paint;
end;
procedure TRarInfoBar.SetMax;
begin
if M<FMin then M:=FMin;
FMax:=M;
Paint;
end;
procedure TRarInfoBar.SetLineColor;
begin
FLineColor:=C;
Paint;
end;
procedure TRarInfoBar.SetTopColor;
begin
FTopColor:=C;
Paint;
end;
procedure TRarInfoBar.SetSideColor1;
begin
FSideColor1:=C;
Paint;
end;
procedure TRarInfoBar.SetSideColor2;
begin
FSideColor2:=C;
Paint;
end;
procedure TRarInfoBar.SetEmptyColor1;
begin
FEmptyColor1:=C;
Paint;
end;
procedure TRarInfoBar.SetEmptyColor2;
begin
FEmptyColor2:=C;
Paint;
end;
procedure TRarInfoBar.SetEmptyFrameColor1;
begin
FEmptyFrameColor1:=C;
Paint;
end;
procedure TRarInfoBar.SetEmptyFrameColor2;
begin
FEmptyFrameColor2:=C;
Paint;
end;
procedure TRarInfoBar.SetBottomFrameColor;
begin
FBottomFrameColor:=C;
Paint;
end;
procedure TRarInfoBar.SetBottomColor;
begin
FBottomColor:=C;
Paint;
end;
procedure TRarInfoBar.SetFilledFrameColor;
begin
FFilledFrameColor:=C;
Paint;
end;
procedure TRarInfoBar.SetFilledColor;
begin
FFilledColor:=C;
Paint;
end;
procedure TRarInfoBar.SetFilledSideColor1;
begin
FFilledSideColor1:=C;
Paint;
end;
procedure TRarInfoBar.SetFilledSideColor2;
begin
FFilledSideColor2:=C;
Paint;
end;
procedure TRarInfoBar.SetShowPerc;
begin
FShowPerc:=V;
Paint;
end;
procedure TRarInfoBar.Paint;
procedure DrawFrame(C: TCanvas);
begin
C.Pen.Color:=FLineColor;
C.Pen.Width:=1;
C.Pen.Style:=psSolid;
C.Pen.Mode:=pmCopy;
C.MoveTo(TopX,TopY+5);
C.LineTo(C.PenPos.X+15,C.PenPos.Y-5);
C.LineTo(C.PenPos.X+15,C.PenPos.Y+5);
C.LineTo(C.PenPos.X-15,C.PenPos.Y+5);
C.LineTo(C.PenPos.X-15,C.PenPos.Y-5);
C.LineTo(C.PenPos.X,C.PenPos.Y+(Size-10));
C.LineTo(C.PenPos.X+15,C.PenPos.Y+5);
C.LineTo(C.PenPos.X,C.PenPos.Y-(Size-10));
C.MoveTo(C.PenPos.X,C.PenPos.Y+(Size-10));
C.LineTo(C.PenPos.X+15,C.PenPos.Y-5);
C.LineTo(C.PenPos.X,C.PenPos.Y-(Size-10));
end;
var Points: array[1..4] of TPoint;
Prog,Perc: integer;
R: real;
S: string;
begin
TopX:=0;
TopY:=5;
Size:=Height-TopY-5;
if (Size=0) or ((FMax-FMin)=0) then
begin
Perc:=0;
Prog:=0;
end
else
begin
R:=(FPosition-FMin)/((FMax-FMin)/(Size-10));
Prog:=Round(R);
Perc:=Round(R/((Size-10)/100));
end;
if Prog<0 then Prog:=0 else
if Prog>Size-10 then Prog:=Size-10;
Canvas.Brush.Color:=Color;
Canvas.FillRect(Canvas.ClipRect);
DrawFrame(Canvas);
Canvas.Brush.Color:=FTopColor;
Canvas.FloodFill(TopX+7,TopY+5,Canvas.Pixels[TopX+(15 div 2),TopY+5],fsSurface);
Canvas.Brush.Color:=FSideColor1;
Canvas.FloodFill(TopX+1,TopY+6,Canvas.Pixels[TopX+1,TopY+6],fsSurface);
Canvas.Brush.Color:=FSideColor2;
Canvas.FloodFill(TopX+29,TopY+6,Canvas.Pixels[TopX+29,TopY+6],fsSurface);
if Prog>0 then
begin
Canvas.MoveTo(TopX,TopY+Size-5);
Canvas.Pen.Color:=FBottomFrameColor;
Canvas.LineTo(Canvas.PenPos.X+15,Canvas.PenPos.Y-5);
Canvas.LineTo(Canvas.PenPos.X+15,Canvas.PenPos.Y+5);
Canvas.Brush.Color:=FBottomColor;
Canvas.FloodFill(TopX+7,TopY+Size-5,FSideColor1,fsSurface);
Canvas.FloodFill(TopX+22,TopY+Size-5,FSideColor2,fsSurface);
Canvas.Brush.Color:=FFilledColor;
Canvas.Pen.Color:=FFilledFrameColor;
Points[1]:=Point(TopX+15,TopY+Size-Prog);
Points[2]:=Point(TopX,TopY+Size-Prog-5);
Points[3]:=Point(TopX+15,TopY+Size-Prog-10);
Points[4]:=Point(TopX+30,TopY+Size-Prog-5);
Canvas.Polygon(Points);
Canvas.Brush.Color:=FFilledSideColor1;
Canvas.FloodFill(TopX+1,TopY+Size-5-(Prog div 2),FSideColor1,fsSurface);
Canvas.Brush.Color:=FFilledSideColor2;
Canvas.FloodFill(TopX+29,TopY+Size-5-(Prog div 2),FSideColor2,fsSurface);
DrawFrame(Canvas);
end
else
begin
{EMPTY}
Canvas.MoveTo(TopX,TopY+Size-5);
Canvas.Pen.Color:=FEmptyFrameColor1;
Canvas.LineTo(Canvas.PenPos.X+15,Canvas.PenPos.Y-5);
Canvas.Pen.Color:=FEmptyFrameColor2;
Canvas.LineTo(Canvas.PenPos.X+15,Canvas.PenPos.Y+5);
DrawFrame(Canvas);
Canvas.Brush.Color:=FEmptyColor1;
Canvas.FloodFill(TopX+7,TopY+Size-5,FSideColor1,fsSurface);
Canvas.Brush.Color:=FEmptyColor2;
Canvas.FloodFill(TopX+22,TopY+Size-5,FSideColor2,fsSurface);
end;
if FShowPerc then
begin
Canvas.Font.Name:=Font.FontName;
Canvas.Font.Height:=Font.FontHeight;
Canvas.Font.Color:=Font.Color;
Canvas.Font.Style:=Font.FontStyle;
Canvas.Brush.Color:=Color;
S:=IntToStr(Perc)+' %';
Canvas.TextOut(TopX+33,TopY+Size-Prog-Canvas.TextHeight(S),S);
end;
end;
end.

BIN
Addons/mckRarProgBar.dcr
View File

Binary file not shown.

368
Addons/mckRarProgBar.pas
View File

@ -1,368 +0,0 @@
//////////////////////////////////////////////////////////////////////
// //
// TRarProgressBar version 1.0 //
// Description: TRarProgressBar is a component which //
// displays dual progress bar like a WinRAR //
// Author: Dimaxx //
// //
//////////////////////////////////////////////////////////////////////
unit mckRarProgBar;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
ComCtrls, ExtCtrls, Mirror;
const
Boolean2Str: array [Boolean] of string = ('False','True');
type
TRarProgressBar = class(TKOLControl)
private
{ Private declarations }
FPosition1: integer;
FPosition2: integer;
FMin,FMax: integer;
FPercent1,FPercent2: integer;
FDouble: boolean;
FLightColor1,FDarkColor,FLightColor2,FFrameColor1,FFrameColor2,
FFillColor1,FFillColor2,FBackFrameColor1,FBackFrameColor2,
FBackFillColor,FShadowColor: TColor;
TopX,TopY,SizeX,SizeY: integer;
procedure SetPos1(P: integer);
procedure SetPos2(P: integer);
procedure SetMin(M: integer);
procedure SetMax(M: integer);
procedure SetDouble(D: boolean);
procedure SetLightColor1(C: TColor);
procedure SetLightColor2(C: TColor);
procedure SetDarkColor(C: TColor);
procedure SetFrameColor1(C: TColor);
procedure SetFrameColor2(C: TColor);
procedure SetFillColor1(C: TColor);
procedure SetFillColor2(C: TColor);
procedure SetBackFrameColor1(C: TColor);
procedure SetBackFrameColor2(C: TColor);
procedure SetBackFillColor(C: TColor);
procedure SetShadowColor(C: TColor);
protected
{ Protected declarations }
procedure WMPaint(var Msg: TMessage); message WM_PAINT;
procedure WMSize(var Msg: TMessage); message WM_SIZE;
procedure WMActiv(var Msg: TMessage); message WM_SHOWWINDOW;
procedure SetupFirst(SL: TStringList; const AName,AParent,Prefix: string); override;
function AdditionalUnits: string; override;
public
{ Public declarations }
constructor Create(Owner: TComponent); override;
procedure Paint; override;
published
{ Published declarations }
property Position1: integer read FPosition1 write SetPos1;
property Position2: integer read FPosition2 write SetPos2;
property Percent1: integer read FPercent1;
property Percent2: integer read FPercent2;
property Max: integer read FMax write SetMax;
property Min: integer read FMin write SetMin;
property Double: boolean read FDouble write SetDouble;
property LightColor1: TColor read FLightColor1 write SetLightColor1;
property LightColor2: TColor read FLightColor2 write SetLightColor2;
property DarkColor: TColor read FDarkColor write SetDarkColor;
property FrameColor1: TColor read FFrameColor1 write SetFrameColor1;
property FrameColor2: TColor read FFrameColor2 write SetFrameColor2;
property FillColor1: TColor read FFillColor1 write SetFillColor1;
property FillColor2: TColor read FFillColor2 write SetFillColor2;
property BackFrameColor1: TColor read FBackFrameColor1 write SetBackFrameColor1;
property BackFrameColor2: TColor read FBackFrameColor2 write SetBackFrameColor2;
property BackFillColor: TColor read FBackFillColor write SetBackFillColor;
property ShadowColor: TColor read FShadowColor write SetShadowColor;
procedure Add1(D: integer);
procedure Add2(D: integer);
end;
procedure Register;
implementation
{$R mckRarProgBar.dcr}
procedure Register;
begin
RegisterComponents('KOLAddons', [TRarProgressBar]);
end;
constructor TRarProgressBar.Create;
begin
inherited;
Width:=204;
Height:=18;
FMin:=0;
FMax:=100;
FPosition1:=0;
FPosition2:=0;
FDouble:=False;
FPercent1:=0;
FPercent2:=0;
FLightColor1:=clWhite;
FDarkColor:=$606060;
FLightColor2:=$C0FFFF;
FFrameColor1:=$EEE8E8;
FFrameColor2:=$B4D4E4;
FFillColor1:=$DCD6D6;
FFillColor2:=$A0C0D0;
FBackFrameColor1:=$9494B4;
FBackFrameColor2:=$80809E;
FBackFillColor:=$6E6E94;
FShadowColor:=$464040;
end;
procedure TRarProgressBar.WMPaint;
begin
inherited;
Paint;
end;
procedure TRarProgressBar.WMSize;
begin
inherited;
Paint;
end;
procedure TRarProgressBar.WMActiv;
begin
inherited;
Paint;
end;
function TRarProgressBar.AdditionalUnits;
begin
Result:=', KOLRarProgBar';
end;
procedure TRarProgressBar.SetupFirst;
begin
inherited;
SL.Add(Prefix+AName+'.Position1 := '+IntToStr(FPosition1)+';');
SL.Add(Prefix+AName+'.Position2 := '+IntToStr(FPosition2)+';');
SL.Add(Prefix+AName+'.Min := '+IntToStr(FMin)+';');
SL.Add(Prefix+AName+'.Max := '+IntToStr(FMax)+';');
SL.Add(Prefix+AName+'.Double := '+Boolean2Str[FDouble]+';');
SL.Add(Prefix+AName+'.LightColor1 := '+Color2Str(FLightColor1)+';');
SL.Add(Prefix+AName+'.LightColor2 := '+Color2Str(FLightColor2)+';');
SL.Add(Prefix+AName+'.DarkColor := '+Color2Str(FDarkColor)+';');
SL.Add(Prefix+AName+'.FrameColor1 := '+Color2Str(FFrameColor1)+';');
SL.Add(Prefix+AName+'.FrameColor2 := '+Color2Str(FFrameColor2)+';');
SL.Add(Prefix+AName+'.FillColor1 := '+Color2Str(FFillColor1)+';');
SL.Add(Prefix+AName+'.FillColor2 := '+Color2Str(FFillColor2)+';');
SL.Add(Prefix+AName+'.BackFrameColor1 := '+Color2Str(FBackFrameColor1)+';');
SL.Add(Prefix+AName+'.BackFrameColor2 := '+Color2Str(FBackFrameColor2)+';');
SL.Add(Prefix+AName+'.BackFillColor := '+Color2Str(FBackFillColor)+';');
SL.Add(Prefix+AName+'.ShadowColor := '+Color2Str(FShadowColor)+';');
end;
procedure TRarProgressBar.SetPos1;
begin
if FDouble then if P<FPosition2 then P:=FPosition2;
if P>FMax then P:=FMax;
FPosition1:=P;
Paint;
end;
procedure TRarProgressBar.SetPos2;
begin
if FDouble then if P>FPosition1 then P:=FPosition1;
FPosition2:=P;
Paint;
end;
procedure TRarProgressBar.SetMin;
begin
if M>FMax then M:=FMax;
FMin:=M;
Paint;
end;
procedure TRarProgressBar.SetMax;
begin
if M<FMin then M:=FMin;
FMax:=M;
Paint;
end;
procedure TRarProgressBar.SetDouble;
begin
FDouble:=D;
Paint;
end;
procedure TRarProgressBar.SetLightColor1;
begin
FLightColor1:=C;
Paint;
end;
procedure TRarProgressBar.SetLightColor2;
begin
FLightColor2:=C;
Paint;
end;
procedure TRarProgressBar.SetDarkColor;
begin
FDarkColor:=C;
Paint;
end;
procedure TRarProgressBar.SetFrameColor1;
begin
FFrameColor1:=C;
Paint;
end;
procedure TRarProgressBar.SetFrameColor2;
begin
FFrameColor2:=C;
Paint;
end;
procedure TRarProgressBar.SetFillColor1;
begin
FFillColor1:=C;
Paint;
end;
procedure TRarProgressBar.SetFillColor2;
begin
FFillColor2:=C;
Paint;
end;
procedure TRarProgressBar.SetBackFrameColor1;
begin
FBackFrameColor1:=C;
Paint;
end;
procedure TRarProgressBar.SetBackFrameColor2;
begin
FBackFrameColor2:=C;
Paint;
end;
procedure TRarProgressBar.SetBackFillColor;
begin
FBackFillColor:=C;
Paint;
end;
procedure TRarProgressBar.SetShadowColor;
begin
FShadowColor:=C;
Paint;
end;
procedure TRarProgressBar.Paint;
var R: real;
Prog: Integer;
begin
TopX:=2;
TopY:=2;
SizeX:=Width-TopX-2;
SizeY:=Height-TopY-4;
if (SizeX=0) or (SizeY=0) or (FMax-FMin=0) then Exit;
///////////////////////////////////////////////////////////////////////////////
// Drawing base
///////////////////////////////////////////////////////////////////////////////
Canvas.Brush.Style:=bsSolid;
Canvas.Brush.Color:=Color;
Canvas.FillRect(Bounds(0,0,Width,Height));
Canvas.Brush.Color:=FShadowColor;
Canvas.FillRect(Bounds(TopX+1,TopY+2,SizeX,SizeY));
Canvas.Brush.Color:=FBackFillColor;
Canvas.FillRect(Bounds(TopX,TopY,SizeX,SizeY+1));
Canvas.Brush.Color:=FDarkColor;
Canvas.FrameRect(Bounds(TopX,TopY,SizeX,SizeY+1));
Canvas.Brush.Color:=FBackFrameColor1;
Canvas.FrameRect(Bounds(TopX,TopY,SizeX,SizeY));
Canvas.Brush.Color:=FBackFrameColor2;
Canvas.FrameRect(Bounds(TopX+1,TopY+1,SizeX-2,SizeY-2));
///////////////////////////////////////////////////////////////////////////////
// Drawing first bar
///////////////////////////////////////////////////////////////////////////////
R:=(FPosition1-FMin)/((FMax-FMin)/SizeX);
Prog:=Round(R);
FPercent1:=Byte(Round(R/(SizeX/100)));
if Prog<>0 then
begin
Canvas.Brush.Color:=FLightColor1;
Canvas.FillRect(Bounds(TopX,TopY,TopX+Prog-2,TopY+SizeY-2));
if Prog>1 then
begin
Canvas.Brush.Color:=FFillColor1;
Canvas.FillRect(Bounds(TopX+1,TopY+1,TopX+Prog-3,TopY+SizeY-3));
Canvas.Brush.Color:=FFrameColor1;
Canvas.FrameRect(Bounds(TopX+1,TopY+1,TopX+Prog-3,TopY+SizeY-3));
end;
Canvas.Brush.Color:=FDarkColor;
Canvas.FillRect(Bounds(TopX+Prog,TopY,1,TopY+SizeY-1));
if Prog<SizeX-1 then
begin
Canvas.Brush.Color:=FBackFillColor;
Canvas.FillRect(Bounds(TopX+Prog+1,TopY,SizeX-Prog-1,SizeY));
Canvas.Brush.Color:=FBackFrameColor1;
Canvas.FrameRect(Bounds(TopX+Prog+1,TopY,SizeX-Prog-1,SizeY));
Canvas.Brush.Color:=FBackFrameColor2;
Canvas.FrameRect(Bounds(TopX+Prog+1,TopY+1,SizeX-Prog-2,SizeY-2));
end;
end;
///////////////////////////////////////////////////////////////////////////////
// Drawing second bar
///////////////////////////////////////////////////////////////////////////////
if FDouble then
begin
R:=(FPosition2-FMin)/((FMax-FMin)/SizeX);
Prog:=Round(R);
FPercent2:=Byte(Round(R/(SizeX/100)));
if Prog<>0 then
begin
Canvas.Brush.Color:=FLightColor2;
Canvas.FillRect(Bounds(TopX,TopY,TopX+Prog-2,TopY+SizeY-2));
if Prog>1 then
begin
Canvas.Brush.Color:=FFillColor2;
Canvas.FillRect(Bounds(TopX+1,TopY+1,TopX+Prog-3,TopY+SizeY-3));
Canvas.Brush.Color:=FFrameColor2;
Canvas.FrameRect(Bounds(TopX+1,TopY+1,TopX+Prog-3,TopY+SizeY-3));
end;
end;
end;
end;
procedure TRarProgressBar.Add1;
begin
Inc(FPosition1,D);
Paint;
end;
procedure TRarProgressBar.Add2;
begin
Inc(FPosition2,D);
Paint;
end;
end.

BIN
Addons/mckSocket.dcr
View File

Binary file not shown.

182
Addons/mckSocket.pas
View File

@ -1,182 +0,0 @@
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
View File

Binary file not shown.

289
Addons/mckTCPSocket.pas
View File

@ -1,289 +0,0 @@
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.

202
Addons/richprint.pas
View File

@ -1,202 +0,0 @@
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.