pascal/kolmck
1
0
Fork 0
Code Issues Releases Activity

git-svn-id: https://svn.code.sf.net/p/kolmck/code@9 91bb2d04-0c0c-4d2d-88a5-bbb6f4c1fa07

Browse Source
This commit is contained in:
dkolmck
2009-08-06 14:32:07 +00:00
parent a2d3cece16
commit c41d6e135c
59 changed files with 75348 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

36
Addons/Errors.pas Normal file
View File

@ -0,0 +1,36 @@
unit Errors;
interface
var
ErrorMsg: array[1..21] of string = (
{01} 'Cannot load image. Invalid or unexpected %s image format.',
{02} 'Invalid color format in %s file.',
{03} 'Stream read error in %s file.',
{04} 'Cannot load image. Unsupported %s image format.',
{05} 'Cannot load image. %s not supported for %s files.',
{06} 'Cannot load image. CRC error found in %s file.',
{07} 'Cannot load image. Compression error found in %s file.',
{08} 'Cannot load image. Extra compressed data found in %s file.',
{09} 'Cannot load image. Palette in %s file is invalid.',
{10} 'Cannot load PNG image. Unexpected but critical chunk detected.',
// features (usually used together with unsupported feature string)
{11} 'The compression scheme is',
{12} 'Image formats other than RGB and RGBA are',
{13} 'File versions other than 3 or 4 are',
// color manager error messages
{14} 'Conversion between indexed and non-indexed pixel formats is not supported.',
{15} 'Color conversion failed. Could not find a proper method.',
{16} 'Color depth is invalid. Bits per sample must be 1,2,4,8 or 16.',
{17} 'Sample count per pixel does not correspond to the given color scheme.',
{18} 'Subsampling value is invalid. Allowed are 1,2 and 4.',
{19} 'Vertical subsampling value must be <= horizontal subsampling value.',
// compression errors
{20} 'LZ77 decompression error.',
// miscellaneous
{21} 'Warning');
implementation
end.

126
Addons/GRushControls#README#RUS#.txt Normal file
View File

@ -0,0 +1,126 @@
-----------------------------
������� �� 14 ������� 2006 �.
GRushControls v0.35
[+] �������� ������ �������� ���������� USE_MEMSAVEMODE (������� �� ���������). ����� ���-�� �� ��� �������� � ����� ������ ����������������� ��������� ����� Paterns ��� ��������� ��� ������� ����, � ������� ����� ��� ��� �� ����� �����. � ������� �������� ����� ������ ��������� ���������� ������������ ������ (� ����� ������ ����).
[*] ��������� BitmapAntialias4X ���������� � MMX �� �������� (������� �� �������� �����), ��� ������ �� ������ ��������� ����� ������������������ ��� ������� ��������� XXX_BorderRoundWidth/Height. �� �������� ����� ����� - GDI, ������� ��������� ������� BitmapAntialias2X (� ��� ����� � � MMX) � �� ��������� ������ ������������ ��� (���� ������� �� �������� ����� ������ �������� ���������� USE_2XAA_INSTEAD_OF_4XAA).
[-] ��������� ��������� ������ ��-�� ���������� ������ RemoveProp.
[-] ��������� �������������� ����� ���������.
MCK:
[*] ���������� �������� � ���������� ����������. � ��������� ShadowOffset, ��� ��� ���� ����� ������� ������� �� ������� - �������� � ShadowOffset ����������� �������� 255.
[-] ��������� �������������� ����� ���������.
[+] ���� ��� ���� ���� ��� GRush ����� ������ ������ ������, ������� "�����������" � �� ����������� ���������� � ���������� ����� ������, �� ��� ������� ������ ������� �������� ���� ������: ��� ���� MCK ������ ��������� ����������� Design-time ���������. ��� ��������� - ��� ������!
-----------------------------
������� �� 6 ������� 2006 �.
GRushControls v0.34
[+] �������� ����� ��������� TKOLGRushImageCollection. � ���� ��� "���������" � KOLGRushControls.pas, � ������ �� ��� �������� �����������. � ����� � ����:
[!] ������� � ���� ������ ������ ���������� tinyPictures ������ � ����� GRushControls � �������� ��� ������������ ������.
[-] ��� ��� "��������� ������������� ������, ���� ��������� All_GlyphBitmap := nil". � ���������� ������ �������� :)
[*] ������� ������� ������ *.dfm ������, ���������� GRush ��������.
tinyJPGGIFBMP.pas:
[+] ��������� ���������
procedure tinyLoadJPGGIFBMPResource(var TargetBitmap: PBitMap; Inst : HInst; ResName : PChar; ResType : PChar);
tinyPNG.pas:
[+] ��������� �������
function tinyLoadPNGResource(var TargetBitmap: PBitMap; Inst : HInst; ResName : PChar; ResType : PChar): DWORD;
���� ��� ���� ���� TKOLGRushImageCollection, � ��� �� �����������. ��������� ��� ����� ���������� ���� ����� ���� ��� PBitmap. � ���� ������ � ������� ���������� tinyPictures ������������ ������� �� ��������, ������������ ��� All_GlyphBitmap ��� ���������, ����� ���� �� ������������ ������������. �.�. �� ������ �� ���������� GRushImageCollection1 � ������ �����, ������ � runtime � ����� ������� �������� (� ��������� ����, � �� ������������ :) ). �������� �������� - ImageType. �� ��������� ��� ����� None. ���� ��� ��������, �������� ������ �������� �����. ��� �������� ������������ ����� ��� ��� ����������� ������������� � ��������� � ImageType, � ���������� ����� ����� ��������� ��������� � �� (�����, � �� ��������). ��� ������������ ����� ����� ������ ������� ImageType = None. ���������� ����� ��������� �������� � *.dfm �����, � ������� ������������� �� ���������.
������ ������� ������ ����� �������� imagecollection, ����������� ��� � ������������ TKOLGRushImageCollection. �������� ���������� All_GlyphWidth � All_GlyphHeight ������ ������������ �� ��������� �����: ���� TKOLGRushControl.GRushStyle.GlyphWidth �� ����� ����, �� ������������� ��� ��������, ���� ��� ����� ����, �� �� ����� ���� �������� TKOLGRushImageCollestion.ImageWidth, �� ������������� ��� ��������. ���� �� ��� �������� ����� ����, �� ������ �� ������������ � ������������� All_GlyphWidth ���������� ������ All_GlyphBitmap.Width. ��� �������� Height ��� ����������.
-----------------------------
������� �� 31 ������ 2006 �.
GRushControls v0.33
[-] "���������" ������-������ ��������� ��-�� ������-������������� �������.
[*] ���������� �������� ������ ������� XXX_GlyphItemX, XXX_GlyphItemY, All_GlyphWidth, All_GlyphHeight.
[*] ��� ��������� ���������� � ������ ������ ������������ ���� �������� ��������� GRush (TControlType --> TGRushControlType). � �������� ��� ��������� ����, �� ���� � ����������� ��� �������� ��� RecalcRects (TRects --> TGrushRects). ��� �������� ��������������� �� ���� ����������� ������� ��� OnRecalcRects.
[*] ����������� ����������� ���� ������� ��������� � 32 (�� ����� ��� � ���� ����� ���� ��������).
[+] ��������� ��������:
All_Spacing : DWORD = ��������� ����� ������� � �������� (���� ��� ������������ �� ��������)
All_SplitterDotsCount : DWORD = ���������� ����� ����� �� Splitter. ������� ����� �� ������ �������� ��� ���� ������ ���������.
[-] ��������� ������ ������ � GDI �������� ��� ����������� ��������.
[*] ��������� ������������� ������, ���� ��������� All_GlyphBitmap := nil.
MCK:
[-] ������ ������ � ��������� ������� ��������� ����-���� ��� Collapse.
[*] ���������� ��������� ����-���� All_ColorCheck � All_UpdateSpeed ��� CheckBox ��� Collapse.
[+] ��������� ��������� ���� ��� �������� All_SplitterDotsCount (��� Splitter ��������������)
-----------------------------
������� �� 6 ������ 2006 �.
GRushControls v0.32
[+] ��������� ��������� �������� �������� ���������� ��� ��������� ���� ��������� ��������. ������ ������ �� ���������� ���������� �������� �������� ������ ��� ����� �������� (� ������) �� ���������� ������� �� �����������. �� ��������� ������� ������ MOSTCOMPATIBILITY, ������������� ���������� ��� ���������. ���� ������ ��������� �����-���� ������, ����� ������� ��������� MOSTCOMPATIBILITY.
[+] ��������� P-���� (���� ����) ��� ������� Collapse ���������� � ������ ������. ��� ������������� ���� ����������� ����� �������� ", KOLGRushControls" � ����� "CollapseUses.inc" � "GR0O_ = object( TGRushControl ) end;" � "CollapseObjects.inc" (������ ����� ����� � ����� �� ����������� �������� - ��������� ����� �� �������, � ��� Fake'� ��� �������).
[+] ������� ��������� � ����������� � xhelpgen �������. � ������ ������ ������ ���� ����������, ��� �������� ����� �� ��������� ����. (������ ����� �������� ������� �������� ����� � ini ����� ��������� SpecialChar== ������ ���������).
[+] ������ �������� XXX_GlyphItemX, XXX_GlyphItemY, All_GlyphWidth, All_GlyphHeight �������� ���, ��� � ���������. ��� ��������� ������ �� ��� ����:
�� ��������� �������� All_GlyphWidth/All_GlyphHeight (��� ���������� All_GlyphBitmap �������) ��������������� ������� All_GlyphBitmap.Width/All_GlyphBitmap.Height ��������������. �� ��� �� ���� � ����! �������� All_GlyphWidth/All_GlyphHeight ���� ��� ������������ ������������ �������. �� All_GlyphBitmap ��� �� ���������� �� ���� �����������, � ������� ������ ������� � ������ �������� ��������� All_GlyphWidth/All_GlyphHeight. � ��� ������� ��������� ���������� ���������� ��� ��� �������� - XXX_GlyphItemX, XXX_GlyphItemY. ��� ��� ��� � ������� � ���, ����� ������� �� ���� ������� �������. ��� �������� ��������� ��� ������: ����� ������ � ����� �������� 32*32 ���� (�.�. ��� ������ ����� ������ 96*32). ��������� ��� � �������� All_GlyphBitmap (��� ���� All_GlyphWidth=96 All_GlyphHeight=32), ������ All_GlyphWidth:=32, ������ Down_GlyphItemX:=1 Over_GlyphItemX:=2. �������� ������ ��� � �����88 (��� ����� ��������!). ��� ��� ����� ��� ����� ����� ���������� ����: ������ �������� ������ � �������� ��� ����� ����������! ��������� ��� � ����������� All_GlyphBitmap �� ������� ��� ���� �����������. ��� ���� ������ �� �����������, � ��� ������������� ������� ���������. ����� �����, �������� Free ��� ����� ������� (��� ������ �� �������� � ��� �����������, �� ��������� ���������� ��� ����� ����������� ���������� ������������� ��� �������� �������������!). �������� ������ ��������� ���������� GlyphItemX/GlyphItemY ��� ����������� ������� ������! ��� ���������� write-only ���������� All_GlyphItemX/All_GlyphItemY.
-----------------------------
������� �� 11 ������� 2005 �.
GRushControls v0.30.1
[*] ���������� ������ ��������� GDI �������� � Windows 98.
-----------------------------
������� �� 25 ������ 2005 �.
GRushControls v0.30
[*] ����� ��� �� �������� ���� � KOL � �������� DrawTransparent � � ����� ������������ ��������� TransparentBlt ���, ��� ��� ��������.
[*] �������-�� �������� ����� ������� �� ����� ����� ��� �����������. ������ ������������ CustomObj ����� CustomData
[*] ��� ��������� Caption ������ �� ����� �������� SetAllNeedUpdate, ������ �� ���������� �������������
[*] �������������� ������������, ������� ����� ���
[*] ������ ������������ OnPaint ������ ��������� WM_PAINT. ��� ����� ��������� ������� ����, ���� � ������� ��� ������������ OnPaint. ���� ���, �� ������� ���� ����� ��������� ��������� GRUSH_OLD_PAINT
-----------------------------
������� �� 13 ������ 2005 �.
GRushControls v0.29
news v0.29 �� 13.11.05
[*] ���������� �������, ������� ��� ��������� � ������������.
[-] ������ �������� �������� Vertical � ProgressBar. ��� �������� �������� ProgressVertical.
[+] ������� OnProgressChange;
[+] ������� OnProgressChange, OnRecalcRects ����� ������ � ������� ������.
-----------------------------
������� �� 06 ������ 2005 �.
GRushControls v0.28
[+] � MCK ����� �������� ����������� ��� ����������� ����������������. ���� ��� ��� �������� �������� � ������� OnRecalcRects.
[-] ������� �� ������ ������ � PAS_VERSION. ���������� ��� � KOL(v2.20), ��� � ����� (� ����� ������� �������� ���� ����� ��������).
[*] ������� GetCPUType ���������� � KOLGRushControls.pas � ������������� � CPUisMMX. ��������� �������� ������.
[-] ���� MaxProgress � ProgressBar ����� ����, �������. ����������.
[+] ������������ �������� ��� Progress ��������� �� ������� ��������.
[*] ��������� gsXXX ��� �������� All_UpdateSpeed �������� �� usXXX
[*] NewGRushPanel ����� �� ��������� ������ �������� (Caption). ������ ��� ���� �������� ��� � ������� ������.
-----------------------------
������� �� 29 ������� 2005 �.
GRushControls v0.27
[-] ����������� ���� �� ������� �� 800 ����.
[+] ����� ������� OnRecalcRects ���������� ������ ��� ����� GRush'� ���� �������� �������.
[*] ����� �� RadioBox ����� ��� ������ �����, ������������ ��� � CheckBox.
[*] � ������� 98 ���� �� ���������� ����� �������. ���-�� � ���� ������, �� �� ���� ���������. :(
[*] CommandActions �������� ��� ����������� AutoSize ��� CheckBox � RadioBox.
[*] � MCK ���� �������, ��� ������� ��, ��� MTsv DN ��������� ������ ProgressBar.
-----------------------------
������� �� 23 ������� 2005 �.
GRushControls v0.26
[+] �������� ��������� GRush Progress Bar.
[+] ��������� ��������������� �������� � PGRushControl:
All_DrawProgress : Boolean = ��������� �������.
All_DrawProgressRect : Boolean = ��������� ����� ��� ProgressBar
All_ProgressVertical : Boolean = ������������ ��� ��������������.
[*] ����������� �������: DeactivateSublings, DoPop, DoPush, DoEnter, DoExit, � ����� ������� �� ��������� WM_TIMER, WM_PAINT, BM_SETCHECK, BM_GETCHECK � �.�.
[*] ���� BorderWidth = 0 �� �� ��� ����� ���. ����������.
[*] ShadowOffset ��� ����, ���� �������. ����� ��������� ������������� ��������.
-----------------------------
������� �� 22 ������� 2005 �.
GRushControls v0.25
[+] ������ �����.

122
Addons/HeapMM.pas Normal file
View File

@ -0,0 +1,122 @@
{
Alternative memory manager. To use it, just place a reference to this
unit *FIRST* in the uses clause of your project (dpr-file). It is a good idea
to use this memory manager with system dcu replacement by Vladimir Kladov.
Heap API used, which is fast and very effective (allocated block granularity
is 16 bytes). One additional benefit is that some proofing tools (MemProof)
do not detect API failures, which those can find when standard Delphi memory
manager used.
=====================================================================
Copyright (C) by Vladimir Kladov, 2001
---------------------------------------------------------------------
http://xcl.cjb.net
mailto: bonanzas@xcl.cjb.net
}
unit HeapMM;
interface
uses windows;
const
HEAP_NO_SERIALIZE = $00001;
HEAP_GROWABLE = $00002;
HEAP_GENERATE_EXCEPTIONS = $00004;
HEAP_ZERO_MEMORY = $00008;
HEAP_REALLOC_IN_PLACE_ONLY = $00010;
HEAP_TAIL_CHECKING_ENABLED = $00020;
HEAP_FREE_CHECKING_ENABLED = $00040;
HEAP_DISABLE_COALESCE_ON_FREE = $00080;
HEAP_CREATE_ALIGN_16 = $10000;
HEAP_CREATE_ENABLE_TRACING = $20000;
HEAP_MAXIMUM_TAG = $00FFF;
HEAP_PSEUDO_TAG_FLAG = $08000;
HEAP_TAG_SHIFT = 16 ;
{$DEFINE USE_PROCESS_HEAP}
var
HeapHandle: THandle;
{* Global handle to the heap. Do not change it! }
HeapFlags: DWORD = 0;
{* Possible flags are:
HEAP_GENERATE_EXCEPTIONS - system will raise an exception to indicate a
function failure, such as an out-of-memory
condition, instead of returning NULL.
HEAP_NO_SERIALIZE - mutual exclusion will not be used while the HeapAlloc
function is accessing the heap. Be careful!
Not recommended for multi-thread applications.
But faster.
HEAP_ZERO_MEMORY - obviously. (Slower!)
}
{ Note from MSDN:
The granularity of heap allocations in Win32 is 16 bytes. So if you
request a global memory allocation of 1 byte, the heap returns a pointer
to a chunk of memory, guaranteeing that the 1 byte is available. Chances
are, 16 bytes will actually be available because the heap cannot allocate
less than 16 bytes at a time.
}
implementation
function HeapGetMem(size: Integer): Pointer;
// Allocate memory block.
begin
Result := HeapAlloc( HeapHandle, HeapFlags, size );
end;
function HeapFreeMem(p: Pointer): Integer;
// Deallocate memory block.
begin
Result := Integer( not HeapFree( HeapHandle, HeapFlags and HEAP_NO_SERIALIZE,
p ) );
end;
function HeapReallocMem(p: Pointer; size: Integer): Pointer;
// Resize memory block.
begin
Result := HeapRealloc( HeapHandle, HeapFlags and (HEAP_NO_SERIALIZE and
HEAP_GENERATE_EXCEPTIONS and HEAP_ZERO_MEMORY),
// (Prevent using flag HEAP_REALLOC_IN_PLACE_ONLY here - to allow
// system to move the block if necessary).
p, size );
end;
{function HeapMemoryManagerSet: Boolean;
begin
Result := TRUE;
end;}
const
HeapMemoryManager: TMemoryManager = (
GetMem: HeapGetMem;
FreeMem: HeapFreeMem;
ReallocMem: HeapReallocMem);
var OldMM: TMemoryManager;
//OldIsMMset: function : Boolean;
initialization
{$IFDEF USE_PROCESS_HEAP}
HeapHandle := GetProcessHeap;
{$ELSE}
HeapHandle := HeapCreate( 0, 0, 0 );
{$ENDIF}
GetMemoryManager( OldMM );
//OldIsMMset := IsMemoryManagerSet;
//IsMemoryManagerSet := HeapMemoryManagerSet;
SetMemoryManager( HeapMemoryManager );
finalization
SetMemoryManager( OldMM );
//IsMemoryManagerSet := OldIsMMset;
{$IFNDEF USE_PROCESS_HEAP}
HeapDestroy( HeapHandle );
{$ENDIF}
end.

1885
Addons/JpegObj.pas Normal file
View File

File diff suppressed because it is too large Load Diff

7883
Addons/KOLBlockCipher.pas Normal file
View File

File diff suppressed because it is too large Load Diff

1768
Addons/KOLCCtrls.pas Normal file
View File

File diff suppressed because it is too large Load Diff

955
Addons/KOLEcmListEdit.pas Normal file
View File

@ -0,0 +1,955 @@
unit KOLEcmListEdit;
{$DEFINE rbutton_sel}
{* TKOLEcmListEdit - ���������� ������������ ListView ������������ ��������������
|=================================================================================
| Version 1.17
|Copyright (C) by ECM, 2004..2006 <ecm@ua.fm>
|This unit conains objects TEcmListEdit.
|<pre>
�������: ListEdit "������" ����������� � lvsDetail(lvsDetailNoHeader) � �� DBLCLICK ����
�� Enter ��� �� "��������������" ������� � ����������
(���� ���������� StartEdit)����������� � �����
"��������������" - ������ �� ������� ������ ListEdit �������������
"���������� ��������" (��-��������� EditBox)
� ���� ������ ����� ���������� ����� ����� ����� �������� �����
��� � StringGrid-�. ����� �� ������ �������������� - Esc, StopEdit
��� ����� ������
��� ������� �� KOLmdvXLGrid - �� "�� ����" ����������� ����� ( ~3.9 ��)
��������(����): KOLListEdit - ��������� ������� - thanks! (��� ��������� ������
����������� ���������)
����� �� ��������� � ���������� (KOLListEdit):
- ������� ��� ����� ��������� � StringGrid �� ���� ��������� � �����������
��������� ����� � ����� ������� ������������ ��������� ������ ������ (��. OnColAdjust);
- �������������� ��������� ListView � ������ �������������� (��� �� ���������
��� � �� �����������)+ ����������� ����� �������� �� ����������� ��������� �����-������;
- �������������� �������: OnGetEditText,OnPutEditText,OnStopEdit,OnEditChar,
OnColAdjust,OnCreateEdit
����������� ��������� ��������� ����������� ��������� � �������� ����� ����������������
|</pre>
}
// Version 1.17 (29.06.2006)
// ��������� ��� ��������� Align ��� Inplace Editor - ������� Matveev Dmitry
// ��������� ������� OnDrawCell (by Matveev Dmitry)
// ��������� ���� ������ ������ ������ ��� lvoRowSelect = True
// ���������� ������ �������� � ����� �������������� �� ������� Ctrl - ������� Matveev Dmitry
// Version 1.16 (27.02.2006)
// ��������� ����������� � ���� ������-��������� ������ �����
// Version 1.15 (3.1.2006)
// ��������� ���� �� $DEFINE USE_PROP ������ � ����������� � KOL.PAS(����� ������ ��� �������!)
// Version 1.14 (19.10.2005)
// ���: Dcr-���� ������������ � ������ �� ���� ���������� �� pas-������� �
// dpk-�����
// Version 1.13 (2.10.2005)
// ��������� �������� AutoHide � TOnCreateEdit
// AutoHide = True (default) - ������������� ��������� Inplace Editor
// ��� ������ ������� ������ �����. False - ��������� ��� ��������
// Version 1.12 (14.07.2005)
// ��������� ������� WndProcListViewWOResizeFlicks
// Version 1.11 (24.01.2005)
// ������ ������ ��������� ��� ������ SetCurLVPos
// thanx Sphinxx for bugreport
// Version 1.10 (18.01.2005)
// ��� ������ DrawText �������� ������� DT_NOPREFIX
// Version 1.09 (24.12.2004)
// [+] ��������� ������� UpdateRow
// Version 1.08 (17.11.2004)
// [-] ���������� ��������� ����� ���� ��� ����������� ���������. (���-��
// ���� � ������� ��� ListView - � ��������� Color = clWindow � �������
// ����� �������� �� ���������� ������ )
// Version 1.07 (25.10.2004)
// [+] ��������� ��������� ������� ����� (��������� ����� LVDrawItem - ������
// ��������������� - ���� ���� ����� �������������� ������������ ������)
// [-] ���������� ������ �������� ��������� - ����� ����� ������� ������ ���
// ������ ���������� � ����������� ����� ������
// [-] ��������� ����� InternalStopEdit (by Dmitry Matveev)
// [*] ��������� ������ ��������� (� �������� ��������� ������� ���������
// ������ �������)
// Version 1.06 (4.10.2004)
// [*] ��������� ������ � ������� KOL 1.96 - ������ NO_ITEMHEIGHT �� �����
// Version 1.05 (28.09.2004)
// [+] ������� � OnCreateEdit �������� ReadOnly. ��� ��������� ��� � True
// �������� �� ��������� (by Matveev Dmitry)
// [+] DEFINE NO_ITEMHEIGHT - ��� ���������� ���� ������������� ������ �����
// (���������� ������������� ����� � � ������� ���� ������������ ������
// KOL 1.95+ - � ��� ���������� ������� �������� � ListView)
// ���� KOL+MCK �� 1.95 �� ������ 1.95+ ������������ �������� � ����������
// ������ ����� ��� ListView ����� ����� http://kolibdb.100free.com/kolmck195Plus.zip
// Version 1.04 (16.09.2004)
// [+] ������� ����������� ��������� lvsDetailNoHeader (by Matveev Dmitry)
// Version 1.03 (15.09.2004)
// [-] ����� "����������" ������� ��������� �� ��������� ��� ��������� ScrollBar-��
// [*] ����� ����� �������� ������ ��� ������ �� ������ ������ ������ (by Matveev Dmitry)
// Version 1.02 (14.09.2004)
// [*] ������������� ��������� - ������ ������ �������
// [+] ���������� ��������� ��� ����� ������
// [*] ������������� ������������ � ������ ����������� ��������� ������
// (�� ������� ���� ��� taLeft) ����������� Indent � OnColAdjust ��� �������������
// [+] ������� ������� OnCreateEdit - ������ ����� ����������� ������ ������ "�����������"
// EditBox-� - ������ �������� (���� �������� �� CheckBox � ComboBox)
// ������ ������������� � ����� ... ����������������� ���� - ����� ����
// ��������... :(
// Version 1.01 (10.09.2004)
// [+] ������ ����� ��������� OwnerDraw - ���������� ����� ������ ����� VCL-StringGrid
// (� ������ FixedCols = 0 ; Options= [..,goEditing,goDrawFocusSelect,..])
// � ���� ������ ����� ������ ������������� �������������� ColOptions.Indent - InPlaceEditor
// ��-��������� ����� �������� ����� �� ���� ����� ��� � ������ � ListView
// (�� ������� ���� ��� �������� taLeft.
// [+] ������� ����������� ������������� ������ �����(������ ��� �������� OwnerDraw)
// ��������������� � �������������� ��������� NewEcmListEdit, � MCK - ItemHeight
// [+] StartEdit ������ ���������� ��� � ��� WM_CHAR (����� Enter) �� ListView-� /by SeM/
// [*] ����� ������ �����������
// Version 1.00 (6.09.2004)
// ������ ����������
//
{$I KOLDEF.INC}
//{$DEFINE _LE_DEBUG_}
interface
uses
Windows, Messages, KOL;
type
PEditorOptions = ^TEditorOptions;
TEditorOptions = packed record
Indent: TRect;
TextAlign: TTextAlign;
Options: TEditOptions;
end;
TOnEditText = procedure(Sender: PControl; ACol, ARow: Integer; var Value: string) of object;
TOnEditChar = procedure(Sender: PControl; ACol, ARow: Integer; var Key: KOLChar; Shift: DWORD) of object;
TOnEndEdit = procedure(Sender: PControl; ACol, ARow: Integer; CellChanged: Boolean) of object;
TOnCreateEdit = procedure(Sender: PControl; ACol: Integer; var Editor: PControl; var ReadOnly: Boolean; var AutoHide: Boolean) of object;
TOnColAdjust = procedure(Sender: PControl; ACol: Integer; var ColOption: TEditorOptions) of object;
TOnDrawCell = function(Sender: PObj; DC: HDC; const Rect: TRect; ACol, ARow: Integer; DrawAction: TDrawAction; ItemState: TDrawState): Boolean of object;
PEcmListEdit = ^TEcmListEdit;
TEcmListEdit = object(TObj)
{* TEcmListEdit ��������� ��� ���������������� KOLEcmListEdit.
|<p>
KOLEcmListEdit ��������� ��� ������ NewEcmListEdit, ������� ������������
TEcmListEdit � �������� KOLEcmListEdit.CustomObj � ���������� ����� ����������
�������. ������� ��� ������� � TEcmListEdit � ���������� ������������ �����
�����������:
! PEcmListEdit(KOLEcmListEdit1.CustomObj)
� MCK ��� ������������ �������������.
|</p>
}
private
fOnCreateEd: TOnCreateEdit;
FOnDrawCell: TOnDrawCell;
procedure EditOnKeyDown(Sender: PControl; var Key: Longint; Shift: DWORD);
procedure EditOnChar(Sender: PControl; var Key: KOLChar; Shift: DWORD);
procedure SetCurIdx(const Value: Integer);
protected
fOwner: PControl;
fColOptions: PList;
fCurIdx: Integer;
fCurLine: Integer;
fScroll: Integer;
fOnPutText: TOnEditText;
fOnGetText: TOnEditText;
fOnEndEdit: TOnEndEdit;
FOnColAdjust: TOnColAdjust;
fStarted: Boolean;
fOnEditChar: TOnEditChar;
fShift: Integer;
fEmbedEd: Boolean;
fAutoHide: Boolean;
function NewInPlaceEd(Options: TEditOptions; Align: TTextAlign): PControl;
procedure DestroyInPlaceEditor;
procedure SetEditPos;
procedure LoadEditValues;
function GetLVItemAtPos(Pt: TSmallPoint; var SubItem: Integer): Integer;
procedure DoColAdjust(ColCount: Integer);
procedure InternalStopEdit(const Store: Boolean);
procedure HideInplaceEd(ActivateOwner: Boolean);
function LVDrawItem(Sender: PObj; DC: HDC; const Rect: TRect; ItemIdx: Integer; DrawAction: TDrawAction; ItemState: TDrawState): Boolean;
procedure ComboBox_CloseUp(Sender: PObj);
public
fInPlaceEd: PControl;
bComboEditor: Boolean;
ComboOptions: TComboOptions;
ComboText: string;
destructor Destroy; virtual; // Do not call this destructor. Use Free method instead.
procedure SetCurLVPos(ALine, AIdx: Integer);
procedure StartEdit;
{*
|<p>
��������� ������ � ��������� �������������� Editing=True. ����������
�������� ���������� �� ������� (LVCurItem) ������ ������.
���� � ������ ��� ��������� ������ (LVCurItem=-1), �������������
���������� ������(0) ������ ������ ListView.
���������� ������������� ��� DblClick-� ������ ��� �� ������� Enter.
����� ������� ����������:
! PEcmListEdit(KOLEcmListEdit1.CustomObj).StartEdit
|</p>
}
procedure StopEdit(Store: Boolean);
{*
|<p>
������� ������ �� ��������� �������������� Editing=False.
�������� Store ���������� ����� �� ����������� ������ ��
����������� ��������� � ListView.
���������� ������������� ��� ������� ������� Esc (Store=False),
����� ������ (� ������ OwnerDraw!)
����� ������� ����������:
! PEcmListEdit(KOLEcmListEdit1.CustomObj).StopEdit(True)
|</p>
}
procedure SelectCell(ACol, ARow: Integer);
{* ������������ ������� ������ }
procedure UpdateRow(ARow: Integer);
{* ����������� (Invalidate) ��������� ������ }
property Editing: Boolean read fStarted;
{* True - ���������� �������� �������. }
property OnGetEditText: TOnEditText read fOnGetText write fOnGetText;
{* ���������� ��� �������� ������ �� ���������� ��������. (��������
��� ������ �������). }
property OnPutEditText: TOnEditText read fOnPutText write fOnPutText;
{* ���������� ��� �������� ������ �� ����������� ���������. (��������
��� ������ �������). }
property OnStopEdit: TOnEndEdit read fOnEndEdit write fOnEndEdit;
{* ���������� ��� ����� ������ �������������� � ��� ���������� StopEdit. }
property OnEditChar: TOnEditChar read fOnEditChar write fOnEditChar;
{* ���������� ��� ��������� ���������� ���������� ������� WM_CHAR. �����
�������������� ��� ��������� �����}
//---------------------------------------------------------------------------
property OnColAdjust: TOnColAdjust read FOnColAdjust write fOnColAdjust;
{*
|<p>
���������� ��� �������� ����������� ���������. (�������� ��� �������
�������). ������������ ��� ������� ��������� ���������.
|</p>
}
property CurIdx: Integer read fCurIdx write SetCurIdx;
{*
|<p>
������������� ����� �� ��������� �������.
|</p>
}
property OnCreateEdit: TOnCreateEdit read fOnCreateEd write fOnCreateEd;
{* ���������� ��� �������� ��������� ������. ����� �������������� ���
���������� ����������� EditBox-� ������� ������������. }
property OnDrawCell: TOnDrawCell read FOnDrawCell write FOnDrawCell;
{*
|<p>
��������� ����������� ����������� ��������� ����� (�� � ������ ��������������)
���������� �������� ��� ������ ������. ���� ���������� ���������� False - ������
�������� ����������.
|</p>
}
end;
// mck class
TKOLEcmListEdit = PControl;
function NewEcmListEdit(AParent: PControl; Style: TListViewStyle; Options: TListViewOptions; ImageListSmall, ImageListNormal, ImageListState: PImageList): PControl;
function WndProcEcmListEdit(Sender: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
function WndProcListViewWOResizeFlicks(Sender: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
implementation
const
LEN_COL_ADJUST = WM_USER + 223;
{$IFDEF _LE_DEBUG_}
procedure AddLog(Addr: Pointer; const S: string);
var
TS: TSystemTime;
SS: String;
begin
GetSystemTime(TS);
SS := Format(' %2d:%.2d:%.2d:%.3d | %.8x ', [TS.wHour, TS.wMinute, TS.wSecond, TS.wMilliseconds, Integer(Addr)]);
LogFileOutput('.\LE_Log.txt', SS + S);
end;
{$ENDIF}
function WndProcEcmListEdit(Sender: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
var
R: TRect;
NMhdr: PNMHdr;
NewLine: Integer;
NewCurIdx: Integer;
begin
Result := False;
with PEcmListEdit(Sender.CustomObj)^ do begin
case Msg.message of
LVM_INSERTCOLUMNA, LVM_INSERTCOLUMNW, LVM_DELETECOLUMN:
PostMessage(Msg.hwnd, LEN_COL_ADJUST, 0, 0);
LEN_COL_ADJUST:
DoColAdjust(Sender.LVColCount);
WM_LBUTTONDOWN{$IFDEF rbutton_sel}, WM_RBUTTONDOWN{$ENDIF}:
begin
NewLine := GetLVItemAtPos(TSmallPoint(Msg.lParam), NewCurIdx);
SetCurLVPos(NewLine, NewCurIdx);
Sender.Focused := True;
Result := True;
end;
WM_LBUTTONDBLCLK{$IFDEF rbutton_sel}, WM_RBUTTONDBLCLK{$ENDIF}:
begin
NewLine := GetLVItemAtPos(TSmallPoint(Msg.lParam), NewCurIdx);
SetCurLVPos(NewLine, NewCurIdx);
if (NewLine <> -1) and (NewCurIdx <> -1) then StartEdit;
Sender.Tabstop := False;
Result := True;
end;
WM_KEYDOWN:
begin
if (Msg.WParam = VK_RETURN) then
StartEdit
else begin
case Msg.WParam of
VK_LEFT, VK_RIGHT:
begin
SetCurLVPos(Sender.LVCurItem, fCurIdx + Msg.wParam - 38);
Result := True;
end;
end;
SetEditPos;
end;
//fInPlaceEd.Click; //.DroppedDown := True;
end;
// by SeM
WM_CHAR:
if (GetKeyState(VK_CONTROL) >= 0) then begin // ! by Matveev Dmitry
case Msg.wParam of
VK_ESCAPE, VK_RETURN, VK_TAB:
;
else begin
StartEdit;
Sender.Tabstop := False;
if Assigned(fInPlaceEd) then
PostMessage(fInPlaceEd.Handle, Msg.message, Msg.wParam, Msg.lParam);
Result := True;
end;
end;
end;
WM_NCPAINT, WM_PAINT:
begin
{$IFDEF _LE_DEBUG_}
AddLog(Sender, 'ListEdit:WM_PAINT');
{$ENDIF}
SetEditPos();
end;
// WM_ERASEBKGND: begin
// Result := True;
// end;
// �����-�� ���� � ����������� ����� � ������ lvoGridLines ��� �������������
// ���� XP - ��� ��������� ScrollBar(������ �������� "�����","����") ����������
// ������ ���������� ����� - � ���������� �������� ������ ���������� ��������������
// ���� "������" ��������� ������ ���������� ��������
// ���� ��� ����� ��� ��������� - �������� ��� ...
WM_VSCROLL:
begin
if (Msg.wParam = SB_ENDSCROLL) then begin
InvalidateRect(fOwner.Handle, nil, True);
UpdateWindow(fOwner.Handle);
end;
end;
WM_NOTIFY:
begin
NMHdr := Pointer(Msg.lParam);
case NMHdr.code of
NM_KILLFOCUS:
begin
{$IFDEF _LE_DEBUG_}
AddLog(Sender, 'ListEdit:NM_KILLFOCUS');
{$ENDIF}
R := fOwner.ClientRect;
InvalidateRect(fOwner.Handle, @R, False); //UpdateRow(fCurLine);
end;
NM_SETFOCUS:
begin
{$IFDEF _LE_DEBUG_}
AddLog(Sender, 'ListEdit:NM_SETFOCUS');
{$ENDIF}
//SetCurLVPos(fOwner.LVCurItem,fCurIdx);
end;
LVN_ITEMCHANGED:
begin
{$IFDEF _LE_DEBUG_}
AddLog(Sender, 'ListEdit:LVN_ITEMCHANGED');
{$ENDIF}
if (fCurLine <> fOwner.LVCurItem) then SetCurLVPos(fOwner.LVCurItem, fCurIdx);
end;
end;
end;
end;
end;
end;
//by Matveev Dmitry
function WndProcInPlaceEd(Sender: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
var
pLE: PEcmListEdit;
begin
Result := False;
case Msg.message of
WM_KEYDOWN:
begin
if Msg.wParam = VK_ESCAPE then
PEcmListEdit(Sender.Parent.CustomObj).StopEdit(False);
end;
WM_KILLFOCUS:
begin
pLE := PEcmListEdit(Sender.Parent.CustomObj);
if not Assigned(pLE) then Exit;
with pLE^ do if (fEmbedEd and fAutoHide) then begin
InternalStopEdit(True);
HideInPlaceEd(True);
end;
end;
// D[u]fa
WM_CHAR:
if (Msg.wParam = VK_RETURN) then begin
Msg.message := WM_KILLFOCUS;
WndProcInPlaceEd(Sender, Msg, Rslt);
Result := True;
end;
end;
end;
// ��������� � ������� ������� ���������� �� ������� "��������" ��� ���������
// ��������. ����� �������������� ��� ������������ KOLListView.
// ��� ���������� ����� �������� ListView-� (ListEdit-�) ���������� ������������
// ������ ������� ������� ListViewXXX.AttachProc(@WndProcListViewWOResizeFlicks);
function WndProcListViewWOResizeFlicks(Sender: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
var
rUnder: TRect;
rRight: TRect;
rClient: TRect;
begin
Result := False;
if (Msg.message = WM_ERASEBKGND) then begin
rClient := Sender.ClientRect;
if (Sender.LVCount > 0) then begin
rUnder := Sender.LVSubItemRect(Sender.LVCount - 1, 0);
rUnder.Top := rUnder.Bottom;
rUnder.Bottom := rClient.Bottom;
rRight.Left := rUnder.Right;
rRight.Right := rClient.Right;
rRight.Top := rClient.Top;
rRight.Bottom := rClient.Bottom;
FillRect(Msg.wParam, rRight, Sender.Canvas.Brush.Handle);
end else
rUnder := rClient;
FillRect(Msg.wParam, rUnder, Sender.Canvas.Brush.Handle);
Result := True;
end;
end;
// PEcmListEdit
function NewEcmListEdit;
var
pLD: PEcmListEdit;
mOpt: TListViewOptions;
begin
mOpt := Options + [lvoHideSel, lvoOwnerDrawFixed];
if ((Style <> lvsDetail) and (Style <> lvsDetailNoHeader)) then Style := lvsDetail;
Result := NewListView(AParent, Style, mOpt, ImageListSmall, ImageListNormal, ImageListState);
New(pLD, Create);
pLD.fOwner := Result;
pLD.fEmbedEd := False;
pLD.fColOptions := NewList;
pLD.fCurLine := -1;
Result.CustomObj := pLD;
Result.OnDrawItem := pLD.LVDrawItem;
Result.AttachProc(WndProcEcmListEdit);
Result.AttachProc(WndProcListViewWOResizeFlicks); //beta, �� �� ���� �����
end;
destructor TEcmListEdit.Destroy;
begin
InternalStopEdit(False);
fColOptions.Release;
inherited;
end;
procedure TEcmListEdit.ComboBox_CloseUp(Sender: PObj);
begin
StopEdit(True);
end;
procedure TEcmListEdit.EditOnKeyDown(Sender: PControl; var Key: Longint; Shift: DWORD);
begin
if (fScroll <> 0) then
PostMessage(fOwner.Handle, LVM_SCROLL, fScroll, 0);
case key of
// VK_RETURN:
// StoreEditValues;
// VK_ESCAPE: StopEdit(False);
VK_UP, VK_DOWN:
begin
SetCurLVPos(fCurLine + (Key - 39), fCurIdx);
Key := 0;
end;
VK_LEFT:
if (Sender.SelStart = 0) and (Sender.SelLength = 0) and (fCurIdx > 0) then begin
SetCurLVPos(fCurLine, fCurIdx - 1);
Key := 0;
end;
VK_RIGHT:
if (Sender.SelStart = Length(Sender.Text)) and (fCurIdx < fOwner.LVColCount - 1) then begin
SetCurLVPos(fCurLine, fCurIdx + 1);
Key := 0;
end;
end;
end;
procedure TEcmListEdit.DestroyInPlaceEditor;
begin
{$IFDEF _LE_DEBUG_}
AddLog(Self.fOwner, 'DestroyInPlaceEditor');
{$ENDIF}
if fEmbedEd and Assigned(fInPlaceEd) then
fInPlaceEd.Free;
fInPlaceEd := nil;
end;
procedure TEcmListEdit.SetEditPos;
var
R, Re: TRect;
cw: Integer;
pEO: PEditorOptions;
Header: THandle;
HeaderHeight: Integer;
begin
{$IFDEF _LE_DEBUG_}
AddLog(Self.fOwner, 'SetEditPos');
{$ENDIF}
with fOwner^ do begin
R := LVSubItemRect(LVCurItem, fCurIdx);
cw := LVColWidth[fCurIdx];
R.Right := R.Left + cw;
if Assigned(fInPlaceEd) then begin
Header := Perform(LVM_GETHEADER, 0, 0);
GetWindowRect(Header, Re);
HeaderHeight := Re.Bottom - Re.Top;
if R.Top >= HeaderHeight then begin
if fEmbedEd and (fInPlaceEd.Perform(EM_GETRECT, 0, Integer(@Re)) > 0) then begin
if (R.Bottom - R.Top) > (Re.Bottom - Re.Top) then begin
cw := ((R.Bottom - R.Top) - (Re.Bottom - Re.Top)) div 2;
Inc(R.Top, cw);
Dec(R.Bottom, cw);
end;
Inc(R.Left, fShift - Re.Left);
Dec(R.Right, fShift - Re.Left);
end;
pEO := fColOptions.Items[fCurIdx];
with pEO.Indent do begin
Inc(R.Left, Left);
Dec(R.Right, Right);
Inc(R.Top, Top);
Dec(R.Bottom, Bottom);
//
if fEmbedEd then
Dec(R.Left, 2);
end;
end else
FillChar(R, SizeOf(R), 0);
fInPlaceEd.BoundsRect := R;
end;
if (R.Left <= 0) then
fScroll := R.Left
else if (R.Right > fOwner.Width - 24) then
fScroll := R.Right - (fOwner.Width - 24)
else
fScroll := 0;
end;
end;
procedure TEcmListEdit.LoadEditValues;
var
S: string;
begin
{$IFDEF _LE_DEBUG_}
AddLog(Self.fOwner, 'LoadEditValues');
{$ENDIF}
with fOwner^ do begin
S := fOwner.LVItems[LVCurItem, fCurIdx];
if Assigned(fOnGetText) then
fOnGetText(fOwner, fCurIdx, LVCurItem, S);
if bComboEditor then begin
fInPlaceEd.CurIndex := fInPlaceEd.IndexOf(S);
bComboEditor := False; //
//fInPlaceEd.DroppedDown := True;
end else begin //if fEmbedEd then begin
if (fInPlaceEd.SubClassName = 'obj_COMBOBOX') then
fInPlaceEd.CurIndex := fInPlaceEd.IndexOf(S)
else begin // 'obj_EDIT'
fInPlaceEd.Text := S;
fInPlaceEd.SelectAll;
end;
end;
end;
end;
procedure TEcmListEdit.StartEdit;
var
pEO: PEditorOptions;
begin
{$IFDEF _LE_DEBUG_}
AddLog(Self.fOwner, 'StartEdit');
{$ENDIF}
if (fOwner.LVColCount = 0) or (fOwner.LVCount = 0) or fStarted or (fCurIdx = -1) then Exit;
fCurLine := fOwner.LVCurItem;
if (fCurLine = -1) then begin
fCurLine := 0;
fOwner.LVCurItem := 0;
end;
//CreateInPlaceEditor(fOwner.LVColCount);
if not fStarted then begin
DestroyInPlaceEditor;
if (fOwner.LVColCount > 0) then begin
pEO := fColOptions.Items[fCurIdx];
fInPlaceEd := NewInPlaceEd(pEO.Options, pEO.TextAlign);
end;
end;
if Assigned(fInPlaceEd) then begin
fStarted := True;
SetEditPos;
LoadEditValues;
fOwner.Tabstop := False;
fInPlaceEd.Visible := True;
fInPlaceEd.Focused := True;
UpdateRow(fCurLine);
end;
end;
procedure TEcmListEdit.StopEdit(Store: Boolean);
begin
{$IFDEF _LE_DEBUG_}
AddLog(Self.fOwner, 'StopEdit: ' + Int2Str(Integer(Store)));
{$ENDIF}
InternalStopEdit(Store);
HideInPlaceEd(True);
end;
function TEcmListEdit.GetLVItemAtPos(Pt: TSmallPoint; var SubItem: Integer): Integer;
var
HTI: TLVHitTestInfo;
begin
{$IFDEF _LE_DEBUG_}
AddLog(Self.fOwner, 'GetLVItemAtPos: ' + Int2Str(SubItem));
{$ENDIF}
HTI.pt.x := Pt.X;
HTI.pt.y := Pt.Y;
fOwner.Perform(LVM_SUBITEMHITTEST, 0, Integer(@HTI));
Result := HTI.iItem;
SubItem := HTI.iSubItem;
end;
procedure TEcmListEdit.EditOnChar(Sender: PControl; var Key: KOLChar; Shift: DWORD);
begin
case Key of
#13:
begin
StopEdit(True);
Key := #0
end;
end;
if Assigned(fOnEditChar) then begin
case Key of
#08: // BackSpace! - ������ ������������
else
fOnEditChar(fInPlaceEd, fCurIdx, fOwner.LVCurItem, Key, Shift);
end;
end;
end;
function TEcmListEdit.NewInPlaceEd(Options: TEditOptions; Align: TTextAlign): PControl;
var
RO: Boolean;
AH: Boolean;
begin
Result := nil;
RO := False;
AH := True;
if Assigned(fOnCreateEd) then
fOnCreateEd(fOwner, fCurIdx, Result, RO, AH);
if not RO then begin
fEmbedEd := not Assigned(Result);
if fEmbedEd then begin
if bComboEditor then begin
Result := NewCombobox(fOwner, ComboOptions);
Result.OnCloseUp := ComboBox_CloseUp;
repeat
Result.Add(Parse(ComboText, ';'));
until (Length(ComboText) = 0);
end else
Result := NewEditBox(fOwner, Options);
Result.Font.Assign(fOwner.Font);
Result.Color := fOwner.LVTextBkColor;
Result.ExStyle := Result.ExStyle and not (WS_EX_DLGMODALFRAME or WS_EX_WINDOWEDGE or WS_EX_CLIENTEDGE);
Result.OnKeyDown := EditOnKeyDown;
Result.AttachProc(WndProcInPlaceEd); //by Matveev Dmitry
end else begin
Result.Parent := fOwner;
//Result.Focused := True;
Result.Visible := True;
end;
//Result.Tabstop := True;
fAutoHide := AH;
Result.OnChar := EditOnChar;
Result.TabOrder := fOwner.TabOrder;
Result.TextAlign := Align;
end;
end;
function TEcmListEdit.LVDrawItem(Sender: PObj; DC: HDC; const Rect: TRect; ItemIdx: Integer; DrawAction: TDrawAction; ItemState: TDrawState): Boolean;
var
fBr: HBRUSH;
cBr: TColor;
i: Integer;
S: String;
P: TPoint;
R: TRect;
dt: DWORD;
pEO: PEditorOptions;
begin
with fOwner^ do begin
fShift := 0;
for i := 0 to LVColCount - 1 do begin
R := LVSubItemRect(ItemIdx, i);
P := LVItemPos[i];
if (i = 0) then begin
R.Right := R.Left + LVColWidth[0];
fShift := P.X - R.Left + 2;
end;
if (Perform(LVM_GETEXTENDEDLISTVIEWSTYLE, 0, 0) and LVS_EX_GRIDLINES) <> 0 then begin
Inc(R.Left);
Dec(R.Bottom);
end;
if Assigned(FOnDrawCell) then
if FOnDrawCell(Sender, DC, R, i, ItemIdx, DrawAction, ItemState) then Continue; //by Matveev Dmitry
if fOwner.Enabled then
cBr := fOwner.LVTextBkColor
else
cBr := clBtnFace;
if (ItemIdx = fCurLine) then begin
if (fOwner.Focused or (Assigned(fInPlaceEd) and fInPlaceEd.Visible)) and Enabled then begin
if (i = fCurIdx) then begin
if fStarted then
cBr := fOwner.LVTextBkColor
else
cBr := clHighlight;
SetTextColor(DC, Color2RGB(clHighlightText));
end else begin
if (Perform(LVM_GETEXTENDEDLISTVIEWSTYLE, 0, 0) and LVS_EX_FULLROWSELECT) <> 0 then
cBr := $F3E6CD;
SetTextColor(DC, Color2RGB(fOwner.Font.Color));
end
end else begin
SetTextColor(DC, Color2RGB(fOwner.Font.Color));
if Enabled then begin
if (i = fCurIdx) then begin
if fStarted then
cBr := fOwner.LVTextBkColor
else
cBr := clInactiveBorder;
end else begin
cBr := $F0F0F0;
end
end;
end;
end else
SetTextColor(DC, Color2RGB(fOwner.Font.Color));
fBr := CreateSolidBrush(Color2RGB(cBr));
FillRect(DC, R, fBr);
DeleteObject(fBr);
if not ((ItemIdx = LVCurItem) and (fStarted) and (i = fCurIdx)) then begin
S := fOwner.LVItems[ItemIdx, i];
dt := DT_END_ELLIPSIS or DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX;
if (fColOptions.Count <> LVColCount) then
DoColAdjust(LVColCount);
pEO := fColOptions.Items[i];
case pEO.TextAlign of
taRight:
dt := dt or DT_RIGHT;
taCenter:
dt := dt or DT_CENTER;
end;
Dec(R.Right, fShift);
Inc(R.Left, fShift);
DrawText(DC, @S[1], Length(S), R, dt);
end;
end;
end;
Result := True;
end;
procedure TEcmListEdit.DoColAdjust(ColCount: Integer);
var
i: Integer;
pEO: PEditorOptions;
begin
if (ColCount <> fColOptions.Count) then begin
for i := fColOptions.Count - 1 downto 0 do // downto - for what?
FreeMem(fColOptions.Items[i]);
fColOptions.Clear;
for i := 0 to ColCount - 1 do begin
New(pEO);
ZeroMemory(pEO, SizeOf(TEditorOptions));
pEO.TextAlign := fOwner.LVColAlign[i];
if Assigned(fOnColAdjust) then
fOnColAdjust(fOwner, i, pEO^);
fColOptions.Add(pEO);
end;
end;
end;
procedure TEcmListEdit.SetCurLVPos(ALine, AIdx: Integer);
var
NewIdx: Integer;
begin
// NewIdx := AIdx;
with fOwner^ do begin
// if (ALine = LVCurItem) and (AIdx = fCurIdx) then Exit;
{$IFDEF _LE_DEBUG_}
AddLog(Self.fOwner, 'SetCurLVPos: ' + Int2Str(ALine) + ',' + Int2Str(AIdx));
{$ENDIF}
if (AIdx >= 0) and (AIdx < LVColCount) and (ALine >= 0) and (ALine < LVCount) then
NewIdx := AIdx
else
NewIdx := fCurIdx;
InternalStopEdit(True);
fCurIdx := NewIdx;
if (ALine >= 0) and (ALine < LVCount) then begin
if ALine <> LVCurItem then begin
NewIdx := LVCurItem;
LVCurItem := ALine;
UpdateRow(NewIdx);
end;
fCurLine := LVCurItem;
end;
HideInPlaceEd(True);
SetEditPos;
if (fScroll <> 0) then
PostMessage(Handle, LVM_SCROLL, fScroll, 0);
if (ALine <> -1) then
PostMessage(Handle, LVM_ENSUREVISIBLE, fCurLine, 0);
UpdateRow(fCurLine);
end;
end;
procedure TEcmListEdit.InternalStopEdit(const Store: Boolean);
var
s: String;
fCellChanged: Boolean;
begin
if fStarted then begin
{$IFDEF _LE_DEBUG_}
AddLog(Self.fOwner, 'InternalStopEdit: ' + Int2Str(Integer(Store)));
{$ENDIF}
fCellChanged := False;
if Store then begin
with fOwner^ do begin
if (fOwner.LVItems[LVCurItem, fCurIdx] <> fInPlaceEd.Text) then begin
S := fInPlaceEd.Text;
if Assigned(fOnPutText) then
fOnPutText(fOwner, fCurIdx, LVCurItem, S);
if (S <> fOwner.LVItems[LVCurItem, fCurIdx]) then begin
fCellChanged := True;
fOwner.LVItems[LVCurItem, fCurIdx] := S;
end;
fInPlaceEd.Text := S;
end;
end;
end;
fStarted := False;
if Assigned(fOnEndEdit) then
fOnEndEdit(fOwner, fCurIdx, fOwner.LVCurItem, fCellChanged);
end;
end;
procedure TEcmListEdit.HideInplaceEd(ActivateOwner: Boolean);
begin
{$IFDEF _LE_DEBUG_}
AddLog(Self.fOwner, 'HideInplaceEd: ' + Int2Str(Integer(ActivateOwner)));
{$ENDIF}
if Assigned(fInPlaceEd) then begin
// fInPlaceEd.Tabstop := False;
fOwner.TabOrder := fInPlaceEd.TabOrder;
{if ActivateOwner then }fOwner.Focused := True;
fOwner.Tabstop := True;
fInPlaceEd.Visible := False;
UpdateRow(fCurLine);
//fOwner.Invalidate;
end;
//if fInPlaceEd <> nil then DestroyInPlaceEditor();
end;
procedure TEcmListEdit.SetCurIdx(const Value: Integer);
begin
fOwner.Focused := True;
SetCurLVPos(fOwner.LVCurItem, Value);
end;
procedure TEcmListEdit.SelectCell(ACol, ARow: Integer);
begin
{$IFDEF _LE_DEBUG_}
AddLog(Self.fOwner, 'SelectCell: ' + Int2Str(ACol) + ',' + Int2Str(ARow));
{$ENDIF}
fOwner.Focused := True;
SetCurLVPos(ARow, ACol);
end;
procedure TEcmListEdit.UpdateRow(ARow: Integer);
var
R: TRect;
begin
{$IFDEF _LE_DEBUG_}
AddLog(Self.fOwner, 'UpdateRow": ' + Int2Str(ARow));
{$ENDIF}
R := fOwner.LVSubItemRect(ARow, 0);
InvalidateRect(fOwner.Handle, @R, False);
end;
end.

2209
Addons/KOLEdb.pas Normal file
View File

File diff suppressed because it is too large Load Diff

424
Addons/KOLFontEditor.pas Normal file
View File

@ -0,0 +1,424 @@
unit KOLFontEditor;
{
==================================================================
TKOLFont Property Editor
for MCK
-----------------------------------------------
Version: 1.0
Date: 16-sep-2003
Author: (C) Alexander Pravdin (aka SPeller)
e-mail: speller@mail.primorye.ru
www: http://kol.mastak.ru
http://bonanzas.rinet.ru
Thanks to:
Dmitry Zharov (aka Gandalf):
Start point of this component (MHFontDialog).
Delphi 5 and Delphi 7 support.
Tested Delphi versions: 5, 6, 7.
==================================================================}
interface
{$I KOLDEF.INC}
uses KOL, Windows, Messages, Graphics, Forms, CommDlg, Mirror,
{$IFDEF _D6orHigher}
DesignEditors, DesignIntf;
{$ELSE}
DsgnIntf;
{$ENDIF}
type
TKOLFontProperty = class(TClassProperty)
private
DlgWnd,
hWndOwner,
LabelWnd,
PickWnd,
FontLWnd,
EditWnd,
CBWnd: HWND;
ColorDlg: PColorDialog;
Top, Left, Height, Width,
OldPickWndProc,
OldEditWndProc: Integer;
Colors: PList;
Font: TFont;
Color: Integer;
function DlgExecute: Boolean;
public
function GetAttributes: TPropertyAttributes; override;
procedure Edit; override;
end;
procedure Register;
implementation
const
ID_DLGOBJ = 'ID_DLGOBJ'#0;
DLG_LBLID = 11200;
DLG_PICKID = 11201;
DLG_EDITID = 11202;
DLG_COLORCB = 1139;
DLG_EFFECTSGROUP = 1072;
CN_APPLYCOLOR = 501;
function PickWndProc(Wnd: HWND; Msg: Cardinal; wParam, lParam: Integer): Integer; stdcall;
var
_Self : TKOLFontProperty;
R : TRect;
hBr, DC : THandle;
begin
_Self := TKOLFontProperty(GetProp(Wnd, ID_DLGOBJ));
with _Self do
begin
case Msg of
WM_PAINT:
begin
GetClientRect(Wnd, R);
CallWindowProc(Pointer(OldPickWndProc), Wnd, Msg, wParam, lParam);
hBr := CreateSolidBrush(Color);
DC := GetDC(Wnd);
FillRect(DC, R, hBr);
ReleaseDC(Wnd, DC);
DeleteObject(hBr);
Result := 0;
Exit;
end;
end; // case
Result := CallWindowProc(Pointer(OldPickWndProc), Wnd, Msg, wParam, lParam);
end; // with
end;
function EditWndProc(Wnd: HWND; Msg: Cardinal; wParam, lParam: Integer): Integer; stdcall;
var
_Self : TKOLFontProperty;
begin
_Self := TKOLFontProperty(GetProp(Wnd, ID_DLGOBJ));
with _Self do
begin
Result := CallWindowProc(Pointer(OldEditWndProc), Wnd, Msg, wParam, lParam);
end; // with
end;
function FontDialogHook(Wnd: HWnd; Msg: UINT; WParam: WPARAM; LParam: LPARAM): UINT; stdcall;
var
_Self : TKOLFontProperty;
R, R2, SR : TRect;
I, tmID, CBCurSel, CBCount: Integer;
PCF : PChooseFontA;
tmWnd, ChildWnd, hFont: THandle;
st : string;
FR : Boolean;
begin
Result := 0;
_Self := TKOLFontProperty(GetProp(Wnd, ID_DLGOBJ));
if (_Self = nil) and (Msg = WM_INITDIALOG) then
begin
PCF := Pointer(lParam);
SetProp(Wnd, ID_DLGOBJ, Cardinal(PCF.lCustData));
_Self := TKOLFontProperty(GetProp(Wnd, ID_DLGOBJ));
end;
with _Self do
begin
case Msg of
WM_INITDIALOG:
begin
DlgWnd := Wnd;
GetWindowRect(Wnd, R);
SR := MakeRect(0, 0, GetSystemMetrics(SM_CXSCREEN), GetSystemMetrics(SM_CYSCREEN));
Width := R.Right - R.Left;
Height := R.Bottom - R.Top + 0;
Left := (SR.Left + SR.Right - Width) div 2;
Top := (SR.Top + SR.Bottom - Height) div 2;
SetWindowPos(Wnd, 0, Left, Top, Width, Height, SWP_NOZORDER);
ChildWnd := 0;
repeat
ChildWnd := FindWindowEx(Wnd, ChildWnd, 'COMBOBOX', nil);
tmID := GetWindowLong(ChildWnd, GWL_ID);
until (tmID = DLG_COLORCB) or (ChildWnd = 0);
if ChildWnd <> 0 then
begin
CBWnd := ChildWnd;
GetWindowRect(CBWnd, R);
R.Right := R.Right + 5;
SetWindowPos(CBWnd, 0, 0, 0, R.Right - R.Left, R.Bottom - R.Top, SWP_NOZORDER or SWP_NOMOVE);
end else
Exit;
ChildWnd := 0;
repeat
ChildWnd := FindWindowEx(Wnd, ChildWnd, 'BUTTON', nil);
tmID := GetWindowLong(ChildWnd, GWL_ID);
until (tmID = DLG_EFFECTSGROUP) or (ChildWnd = 0);
if ChildWnd <> 0 then
begin
tmWnd := ChildWnd;
GetWindowRect(tmWnd, R);
ScreenToClient(Wnd, R.TopLeft);
ScreenToClient(Wnd, R.BottomRight);
R.Bottom := R.Bottom + 20;
SetWindowPos(tmWnd, HWND_BOTTOM, R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top, 0);
end else
Exit;
ChildWnd := 0;
repeat
ChildWnd := FindWindowEx(Wnd, ChildWnd, 'STATIC', nil);
tmID := GetWindowLong(ChildWnd, GWL_ID);
until (tmID = 1093) or (ChildWnd = 0);
if ChildWnd <> 0 then
begin
FontLWnd := ChildWnd;
GetWindowRect(FontLWnd, R2);
R2 := MakeRect(7, 172, 219, 20);
R2.Top := R2.Top + 25;
R2.Bottom := R2.Bottom + 20;
SetWindowPos(FontLWnd, 0, R2.Left, R2.Top, R2.Right - R2.Left, R2.Bottom - R2.Top, SWP_NOZORDER);
end;
LabelWnd := CreateWindow('STATIC', 'Exactly:',
SS_LEFT or WS_VISIBLE or WS_CHILD,
R.Left + 10, R.Bottom - 26, 40, 15,
Wnd, 0, hInstance, nil);
SetWindowLong(LabelWnd, GWL_ID, DLG_LBLID);
SetProp(LabelWnd, ID_DLGOBJ, Cardinal(_Self));
hFont := SendMessage(Wnd, WM_GETFONT, 0, 0);
SendMessage(LabelWnd, WM_SETFONT, hFont, 0);
if WinVer >= wvXP then
begin
I := 0;
tmID := WS_BORDER;
end else
begin
I := WS_EX_CLIENTEDGE;
tmID := 0;
end;
PickWnd := CreateWindowEx(I,
'STATIC', nil,
WS_VISIBLE or WS_CHILD or SS_NOTIFY or tmID,
R.Left + 116, R.Bottom - 30, 21, 21,
Wnd, 0, hInstance, nil);
SetProp(PickWnd, ID_DLGOBJ, Cardinal(_Self));
SetWindowLong(PickWnd, GWL_ID, DLG_PICKID);
OldPickWndProc := SetWindowLong(PickWnd, GWL_WNDPROC, Integer(@PickWndProc));
EditWnd := CreateWindowEx(WS_EX_CLIENTEDGE,
'EDIT', nil,
WS_VISIBLE or WS_CHILD or ES_UPPERCASE or ES_AUTOHSCROLL,
R.Left + 60, R.Bottom - 30, 55, 21,
Wnd, 0, hInstance, nil);
SetWindowLong(EditWnd, GWL_ID, DLG_EDITID);
SetProp(EditWnd, ID_DLGOBJ, Cardinal(_Self));
SendMessage(EditWnd, WM_SETFONT, hFont, 0);
SendMessage(EditWnd, EM_SETLIMITTEXT, 6, 0);
OldEditWndProc := SetWindowLong(EditWnd, GWL_WNDPROC, Integer(@EditWndProc));
ColorDlg.OwnerWindow := Wnd;
CBCount := SendMessage(CBWnd, CB_GETCOUNT, 0, 0);
for I := 0 to CBCount - 1 do
begin
Colors.Add(Pointer(SendMessage(CBWnd, CB_GETITEMDATA, I, 0)));
end;
CBCurSel := Colors.IndexOf(Pointer(Color));
if CBCurSel < 0 then
begin
SendMessage(CBWnd, CB_ADDSTRING, 0, Integer(PChar('$' + Int2Hex(Color, 6))));
Colors.Add(Pointer(Color));
CBCurSel := Colors.Count - 1;
SendMessage(CBWnd, CB_SETITEMDATA, CBCurSel, Color);
end;
SendMessage(CBWnd, CB_SETCURSEL, CBCurSel, 0);
TSmallPoint(I).x := DLG_COLORCB;
TSmallPoint(I).y := CBN_SELCHANGE;
SendMessage(Wnd, WM_COMMAND, I, CBWnd);
end;
WM_COMMAND:
begin
case TSmallPoint(wParam).X of
DLG_PICKID:
begin
case TSmallPoint(wParam).Y of
STN_CLICKED:
begin
if GetWindowLong(PickWnd, GWL_USERDATA) = CN_APPLYCOLOR then
FR := True
else
begin
ColorDlg.Color := Color;
FR := ColorDlg.Execute;
if FR then Color := ColorDlg.Color;
end;
if FR then
begin
//-----
CBCurSel := Colors.IndexOf(Pointer(Color));
if CBCurSel < 0 then
begin
SendMessage(CBWnd, CB_ADDSTRING, 0, Integer(PChar('$' + Int2Hex(Color, 6))));
Colors.Add(Pointer(Color));
CBCurSel := Colors.Count - 1;
SendMessage(CBWnd, CB_SETITEMDATA, CBCurSel, Color);
end;
SendMessage(CBWnd, CB_SETCURSEL, CBCurSel, 0);
TSmallPoint(I).Y := CBN_SELCHANGE;
TSmallPoint(I).X := DLG_COLORCB;
SendMessage(Wnd, WM_COMMAND, I, CBWnd);
//-----
end;
end; // STN_CLICKED
end; // case
end; // DLG_PICKID
DLG_COLORCB:
begin
if TSmallPoint(wParam).Y = CBN_SELCHANGE then
begin
CBCurSel := SendMessage(CBWnd, CB_GETCURSEL, 0, 0);
if CBCurSel >= 0 then
begin
Color := SendMessage(CBWnd, CB_GETITEMDATA, CBCurSel, 0);
SetWindowText(EditWnd, PChar(Int2Hex(Color, 6)));
SendMessage(PickWnd, WM_PAINT, 0, 0);
end;
end;
end; // DLG_COLORCB
DLG_EDITID:
begin
case TSmallPoint(wParam).Y of
EN_CHANGE:
begin
SetLength(st, 20);
GetWindowText(EditWnd, @st[1], 18);
Color := Hex2Int(st);
SendMessage(PickWnd, WM_PAINT, 0, 0);
end;
end;
end; // DLG_EDITID
end; // case TSmallPoint( wParam ).X
end; // WM_COMMAND
end; // case
end; // with
end;
function TKOLFontProperty.DlgExecute: Boolean;
var
TMPCF : tagChooseFont;
TMPLogFont : tagLogFontA;
begin
FillChar(TMPCF, SizeOf(TMPCF), 0);
GetObject(Font.Handle, SizeOf(tagLOGFONT), @TMPLogFont);
TMPCF.lStructSize := Sizeof(TMPCF);
TMPCF.hWndOwner := hWndOwner;
TMPCF.Flags := CF_EFFECTS or CF_BOTH or CF_ENABLEHOOK or CF_INITTOLOGFONTSTRUCT;
TMPCF.lpfnHook := FontDialogHook;
TMPCF.lpLogFont := @TMPLogFont;
TMPCF.rgbColors := Color2RGB(Font.Color);
TMPCF.lCustData := Integer(Self);
Color := TMPCF.rgbColors;
Result := ChooseFont(TMPCF);
if Result then
begin
DeleteObject(Font.Handle);
Font.Handle := CreateFontIndirect(TMPLogFont);
Font.Color := Color;
end;
end;
function TKOLFontProperty.GetAttributes: TPropertyAttributes;
begin
Result := inherited GetAttributes + [paDialog, paReadOnly];
end;
procedure TKOLFontProperty.Edit;
const
Pitch2API : array[TFontPitch] of Byte = (DEFAULT_PITCH, VARIABLE_PITCH, FIXED_PITCH);
var
LF : tagLOGFONT;
F : TKOLFont;
FS1 : TFontStyles;
begin
//----------------
hWndOwner := Application.Handle;
Font := TFont.Create;
Colors := NewList;
ColorDlg := NewColorDialog(ccoFullOpen);
//-----------------
F := TKOLFont(GetOrdValue);
FillChar(LF, SizeOf(tagLOGFONT), 0);
LF.lfHeight := F.FontHeight;
LF.lfWidth := F.FontWidth;
LF.lfOrientation := F.FontOrientation;
if fsBold in F.FontStyle then LF.lfWeight := 700;
LF.lfItalic := Byte(fsItalic in F.FontStyle);
LF.lfUnderline := Byte(fsUnderline in F.FontStyle);
LF.lfStrikeOut := Byte(fsStrikeOut in F.FontStyle);
LF.lfCharSet := F.FontCharset;
LF.lfPitchAndFamily := Pitch2API[F.FontPitch];
Move(F.FontName[1], LF.lfFaceName, Length(F.FontName));
Font.Color := F.Color;
Font.Handle := CreateFontIndirect(LF);
if DlgExecute then
begin
FillChar(LF, SizeOf(tagLOGFONT), 0);
GetObject(Font.Handle, SizeOf(tagLOGFONT), @LF);
F.FontHeight := LF.lfHeight;
F.FontWidth := LF.lfWidth;
F.FontOrientation := LF.lfOrientation;
FS1 := [];
if Boolean(LF.lfItalic) then Include(FS1, fsItalic);
if Boolean(LF.lfUnderline) then Include(FS1, fsUnderline);
if Boolean(LF.lfStrikeOut) then Include(FS1, fsStrikeout);
if LF.lfWeight > FW_NORMAL then Include(FS1, fsBold);
F.FontStyle := FS1;
F.FontCharset := LF.lfCharSet;
case LF.lfPitchAndFamily of
DEFAULT_PITCH: F.FontPitch := fpDefault;
FIXED_PITCH: F.FontPitch := fpFixed;
VARIABLE_PITCH: F.FontPitch := fpVariable;
end;
F.FontName := LF.lfFaceName;
F.Color := Font.Color;
SetOrdValue(Integer(F));
end;
//-----------------
ColorDlg.Free;
Colors.Free;
Font.Free;
//-----------------
end;
procedure Register;
begin
RegisterPropertyEditor(TypeInfo(TKOLFont), nil, '', TKOLFontProperty);
end;
end.

3307
Addons/KOLGRushControls.pas Normal file
View File

File diff suppressed because it is too large Load Diff

2848
Addons/KOLGif.pas Normal file
View File

File diff suppressed because it is too large Load Diff

4111
Addons/KOLGraphicColor.pas Normal file
View File

File diff suppressed because it is too large Load Diff

1648
Addons/KOLGraphicCompression.pas Normal file
View File

File diff suppressed because it is too large Load Diff

6073
Addons/KOLGraphicEx.pas Normal file
View File

File diff suppressed because it is too large Load Diff

1138
Addons/KOLHTTPDownload.pas Normal file
View File

File diff suppressed because it is too large Load Diff

5175
Addons/KOLHashs.PAS Normal file
View File

File diff suppressed because it is too large Load Diff

209
Addons/KOLHttp.pas Normal file
View File

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

939
Addons/KOLMHToolTip.pas Normal file
View File

@ -0,0 +1,939 @@
//{$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}
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}
{$IFDEF pre_interface}
PMHHint = ^TMHHint;
TKOLMHHint = PMHHint;
{$ENDIF pre_interface}
{$IFDEF interface}
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;
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}
{$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;
// a: integer;
const
CS_DROPSHADOW = $00020000;
begin
DoInitCommonControls(ICC_BAR_CLASSES);
New(Result, Create);
Result.fHandle := CreateWindowEx(0, TOOLTIPS_CLASS, '', 0, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, AParent.Handle, 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, 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;
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; // Spec
//rect := Parent.ClientRect; // Spec
rect := MakeRect( 0, 0, 2048, 1600 );
// ��� ������ �� ������, � ������������ ������������� �� ������� ��������,
// ������� ����� ���������� � �������� ������
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;
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;
Manager.Free;
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}

1780
Addons/KOLMath.pas Normal file
View File

File diff suppressed because it is too large Load Diff

409
Addons/KOLPageSetupDialog.pas Normal file
View File

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

364
Addons/KOLPcx.pas Normal file
View File

@ -0,0 +1,364 @@
unit KOLPcx;
{* PCX - PC Paintbrush format (ZSoft) support for KOL.
(C) by Kladov Vladimir 30-Sep-2002
( bonanzas@xcl.cjb.net, http://xcl.cjb.net )
v1.0 - reading PCX only (it is converted to DIB bitmap when loaded)
}
interface
{$RANGECHECKS OFF}
uses
Windows, KOL;
type
TRGBPixel = packed record
R, G, B: Byte;
end;
PPCXHeader = ^TPCXHeader;
TPCXHeader = packed record
Manufacturer : Byte; //���������� ���� 10 = ZSoft .PCX
Version : Byte; //0 = ������ 2.5
//2 = ������ 2.8 � ����������� � �������
//3 = ������ 2.8 ��� ���������� � �������
//5 = ������ 3.0
Encoding : Byte; //1 = .PCX ����������� �������� �������
BitsPerPixel : Byte; //����� ��� �� ������ � ����
Xmin : Word; //������� ����������� (Xmin, Ymin) - (Xmax, Ymax) � �������� ������������
Ymin : Word;
Xmax : Word;
Ymax : Word;
Hres : Word; //�������������� ���������� ���������� ����������
Vres : Word; //������������ ���������� ���������� ����������
ColorMap : array[ 0..15 ] of TRGBPixel;
Reserved : Byte;
NPlanes : Byte; //����� �������� �����
BytesPerLine : Word; //����� ���� �� ������ � �������� ����
//(��� PCX-������ ������ ������ ���� ������)
PaletteInfo : Byte; //��� ���������������� �������:
//1 = �������/�����-�����,
//2 = �������� ������
Filler : array[ 0..58 ] of Byte; // ����
end;
PPCX = ^TPCX;
TPCX = object( TObj )
{* PCX implementation object}
protected
//FError: TPCXError;
FBitmap: PBitmap;
protected
{Returns image width and height}
function GetWidth: Integer;
function GetHeight: Integer;
{Returns if the image is empty}
function GetEmpty: Boolean;
public
procedure Clear;
{Draws the image into a canvas}
procedure Draw(DC: HDC; X, Y: Integer);
procedure StretchDraw( DC: HDC; const Rect: TRect );
{Width and height properties}
property Width: Integer read GetWidth;
property Height: Integer read GetHeight;
{Property to return if the image is empty or not}
property Empty: Boolean read GetEmpty;
{Object being created and destroyed}
destructor Destroy; virtual;
function LoadFromFile(const Filename: String): Boolean;
//procedure SaveToFile(const Filename: String);
function LoadFromStream(Stream: PStream): Boolean;
//procedure SaveToStream(Stream: PStream);
{Loading the image from resources}
function LoadFromResourceName(Instance: HInst; const Name: String): Boolean;
function LoadFromResourceID(Instance: HInst; ResID: Integer): Boolean;
{}
property Bitmap: PBitmap read FBitmap;
end;
function NewPCX: PPCX;
implementation
function NewPCX: PPCX;
begin
new( Result, Create );
end;
{ TPCX }
procedure TPCX.Clear;
begin
Free_And_Nil( FBitmap );
end;
destructor TPCX.Destroy;
begin
FBitmap.Free;
inherited;
end;
procedure TPCX.Draw(DC: HDC; X, Y: Integer);
begin
if Empty then Exit;
FBitmap.Draw( DC, X, Y );
end;
function TPCX.GetEmpty: Boolean;
begin
Result := (FBitmap=nil) or FBitmap.Empty;
end;
function TPCX.GetHeight: Integer;
begin
if Empty then
Result := 0
else
Result := FBitmap.Height;
end;
function TPCX.GetWidth: Integer;
begin
if Empty then
Result := 0
else
Result := FBitmap.Width;
end;
function TPCX.LoadFromFile(const Filename: String): Boolean;
var Strm: PStream;
begin
Strm := NewReadFileStream( Filename );
Result := LoadFromStream( Strm );
Strm.Free;
end;
function TPCX.LoadFromResourceID(Instance: HInst; ResID: Integer): Boolean;
var Strm: PStream;
begin
Strm := NewMemoryStream;
Resource2Stream( Strm, Instance, PChar( ResID ), RT_RCDATA );
Strm.Position := 0;
Result := LoadFromStream( Strm );
Strm.Free;
end;
function TPCX.LoadFromResourceName(Instance: HInst; const Name: String): Boolean;
var Strm: PStream;
begin
Strm := NewMemoryStream;
Resource2Stream( Strm, Instance, PChar( Name ), RT_RCDATA );
Strm.Position := 0;
Result := LoadFromStream( Strm );
Strm.Free;
end;
function TPCX.LoadFromStream(Stream: PStream): Boolean;
type
TRGBPixelExt = packed record
Pixel: TRGBPixel;
Dummy: Byte;
end;
var
StartPos: DWORD;
procedure Decode;
var Header: TPCXHeader;
Format: TPixelFormat;
Buffer, Dest, Src, SrcBuf: PByte;
W, H, ImgSize, I, BitIdx, X, SrcSize: Integer;
B, B1, B2, B3, B4: Byte;
RGBPixelExt: TRGBPixelExt;
begin
Result := FALSE;
Clear;
if Stream.Read( Header, Sizeof( Header ) ) < Sizeof( Header ) then Exit;
if Header.Manufacturer <> 10 then Exit;
if (Header.BitsPerPixel = 1) and (Header.NPlanes = 1) then
Format := pf1bit
else
if (Header.BitsPerPixel = 1) and (Header.NPlanes = 4) or
(Header.BitsPerPixel = 4) and (Header.NPlanes = 1) then
Format := pf4bit
else
if (Header.BitsPerPixel = 8) and (Header.NPlanes = 1) then
Format := pf8bit
else
if (Header.BitsPerPixel = 8) and (Header.NPlanes = 3) then
Format := pf24bit
else
Exit;
W := Header.Xmax - Header.Xmin + 1;
H := Header.Ymax - Header.Ymin + 1;
ImgSize := Header.NPlanes * Header.BytesPerLine * H;
GetMem( Buffer, ImgSize );
if Buffer = nil then Exit;
//-------------------- ������������� ----------------------
SrcSize := Stream.Size - Stream.Position;
if SrcSize > ImgSize * 2 then
SrcSize := ImgSize * 2;
GetMem( SrcBuf, SrcSize );
SrcSize := Stream.Read( SrcBuf^, SrcSize );
Src := SrcBuf;
Dest := Buffer;
while (DWORD( Dest ) < DWORD( Buffer ) + DWORD( ImgSize ) ) and
(DWORD( Src ) < DWORD( SrcBuf ) + DWORD( SrcSize ) ) do
begin
//Stream.Read( B, 1 );
B := Src^; Inc( Src );
if B >= $C0 then
begin
I := B and $3F;
//Stream.Read( B, 1 );
B := Src^; Inc( Src );
for I := I-1 downto 0 do
begin
Dest^ := B; Inc( Dest );
end;
end
else
begin
Dest^ := B; Inc( Dest );
end;
end;
//Stream.Position := StartPos + Sizeof( Header ) + DWORD( Src ) - DWORD( SrcBuf );
FreeMem( SrcBuf );
FBitmap := NewDIBBitmap( W, H, Format );
//-------------------- ������������ ����������� ------------------------
if (Format = pf4bit) and (Header.NPlanes = 4) then
begin
for I := 0 to H-1 do
begin
Dest := FBitmap.ScanLine[ I ];
BitIdx := 8;
B1 := 0; B2 := 0; B3 := 0; B4 := 0;
Src := Pointer( Integer( Buffer ) + Header.BytesPerLine * 4 * I );
for X := 0 to W div 2 - 1 do
begin
if BitIdx >= 8 then
begin
BitIdx := 0;
B1 := Src^;
B2 := PByte( Integer( Src ) + Header.BytesPerLine )^;
B3 := PByte( Integer( Src ) + Header.BytesPerLine * 2 )^;
B4 := PByte( Integer( Src ) + Header.BytesPerLine * 3 )^;
Inc( Src );
end;
B := ((B1 and $80) shr 3) or ((B2 and $80) shr 2) or ((B3 and $80) shr 1) or (B4 and $80)
or ((B1 and $40) shr 6) or ((B2 and $40) shr 5) or ((B3 and $40) shr 4) or ((B4 and $40) shr 3);
B1 := B1 shl 2;
B2 := B2 shl 2;
B3 := B3 shl 2;
B4 := B4 shl 2;
Dest^ := B;
Inc( Dest );
Inc( BitIdx, 2 );
end;
end; // ����� �������� 16-�������� ����������� �� �����
end
else
if Format = pf24bit then
begin
for I := 0 to H-1 do
begin
Dest := FBitmap.ScanLine[ I ];
Src := PByte( Integer( Buffer ) + Header.BytesPerLine * 3 * I );
for X := 0 to W-1 do
begin
B1 := Src^;
B2 := PByte( Integer( Src ) + Header.BytesPerLine )^;
B3 := PByte( Integer( Src ) + Header.BytesPerLine*2 )^;
Dest^ := B3; Inc( Dest );
Dest^ := B2; Inc( Dest );
Dest^ := B1; Inc( Dest );
Inc( Src );
end;
end; // ����� �������� ������������, 256-�������� �����������
end
else
//if (Format in [pf8bit,pf1bit]) or ((Format = pf4bit) and (Header.NPlanes = 1)) then
begin
Src := Buffer;
for I := 0 to H-1 do
begin
Dest := FBitmap.ScanLine[ I ];
Move( Src^, Dest^, Header.BytesPerLine );
if Format = pf4bit then
begin
for X := 0 to W div 2 - 1 do
begin
B := Dest^;
B := ((B and $11) shl 2) or ((B and $44) shr 2) or
(B and $AA);
Dest^ := B;
Inc( Dest );
end;
end;
Inc( Src, Header.BytesPerLine );
end; // ����� �������� ������������, 256-�������� ����������� ��� 16-�������� � ����� ����
end;
//----------- �������� ������� ------------------
if Format = pf8bit then
begin
B := 0;
if Stream.Size > 768 then
begin
Stream.Position := Stream.Size - 769;
Stream.Read( B, 1 );
end;
if (Header.Version in [2,5]) and (B in [10,12]) then
begin // ���� ���� �������, ���������
RGBPixelExt.Dummy := 0;
GetMem( SrcBuf, 768 );
Stream.Read( SrcBuf^, 768 );
Src := SrcBuf;
for I := 0 to 255 do
begin
RGBPixelExt.Pixel.B := Src^; Inc( Src );
RGBPixelExt.Pixel.G := Src^; Inc( Src );
RGBPixelExt.Pixel.R := Src^; Inc( Src );
if B = 10 then
begin
RGBPixelExt.Pixel.R := RGBPixelExt.Pixel.R shl 2;
RGBPixelExt.Pixel.G := RGBPixelExt.Pixel.G shl 2;
RGBPixelExt.Pixel.B := RGBPixelExt.Pixel.B shl 2;
end;
FBitmap.DIBPalEntries[ I ] := Integer( RGBPixelExt );
end;
FreeMem( SrcBuf );
end;
end
else
if Format in [pf1bit, pf4bit] then
begin // �������� ������� ��� 16-������� ��� ����������� �����������
RGBPixelExt.Dummy := 0;
for I := 0 to FBitmap.DIBPalEntryCount-1 do
begin
RGBPixelExt.Pixel := Header.ColorMap[ I ];
B := RGBPixelExt.Pixel.R;
RGBPixelExt.Pixel.R := RGBPixelExt.Pixel.B;
RGBPixelExt.Pixel.B := B;
FBitmap.DIBPalEntries[ I ] := Integer( RGBPixelExt );
end;
end;
FreeMem( Buffer );
Result := TRUE;
end;
begin
StartPos:= Stream.Position;
Decode;
If Result = False Then Stream.Position:= StartPos;
end;
procedure TPCX.StretchDraw(DC: HDC; const Rect: TRect);
begin
If Empty = False Then FBitmap.StretchDraw( DC, Rect );
end;
end.

30
Addons/KOLPrintCommon.pas Normal file
View File

@ -0,0 +1,30 @@
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 Normal file
View File

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

663
Addons/KOLPrinters.pas Normal file
View File

@ -0,0 +1,663 @@
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 Normal file
View File

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

1541
Addons/KOLQProgBar.pas Normal file
View File

File diff suppressed because it is too large Load Diff

410
Addons/KOLRarBar.pas Normal file
View File

@ -0,0 +1,410 @@
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 Normal file
View File

@ -0,0 +1,377 @@
//////////////////////////////////////////////////////////////////////
// //
// 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 Normal file
View File

@ -0,0 +1,386 @@
{$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 Normal file
View File

Binary file not shown.

1277
Addons/KOLReport.pas Normal file
View File

File diff suppressed because it is too large Load Diff

845
Addons/KOLSocket.pas Normal file
View File

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

1292
Addons/KOLmdvDBF.pas Normal file
View File

File diff suppressed because it is too large Load Diff

53
Addons/KOLmhxp.pas Normal file
View File

@ -0,0 +1,53 @@
unit KOLMHXP;
// MHXP ��������� (MHXP Component)
// ����� (Author): ����� ������� (Zharov Dmitry) aka �������� (Gandalf)
// ���� �������� (Create date): 14-���(nov)-2001
// ���� ��������� (Last correction Date): 21-���(apr)-2003
// ������ (Version): 1.17
// EMail: Gandalf@kol.mastak.ru
// WWW: http://kol.mastak.ru
// ������������� (Thanks):
// Alexander Pravdin
// ����� � (New in):
// V1.17
// [+] ������� �������� (External manifest) [KOLnMCK]
//
// V1.16
// [+] ��������� D7 (D7 Support) [KOLnMCK]
//
// V1.15
// [+] ��������� D6 (D6 Support) <Thanks to Alexander Pravdin> [KOLnMCK]
//
// V1.14
// [!.] ������� ��������� (Small Fixing) [MCK]
//
// V1.13
// [+] Tag [MCK]
// [*] Code MCK Optim-z [MCK]
//
// V1.12
// [*] Hide Tag as unused [MCK]
// [*] Del Unused modules [MCK]
//
// V1.11
// [*] Needn't to create and free KOLObj [MCK]
// [*] Nearly clear KOL-file [KOL]
//
// V1.1
// [!] Resource Compile [MCK]
//
// ������ ��� (To-Do list):
// 1. �������������� (Optimize)
// 2. ���������� (Clear Stuff)
// 3. XP ������ ���� ���� �� ������ (XP in Project must be ONE)
interface
type
TKOLMHXP = Pointer;
implementation
end.

264
Addons/ListEdit.pas Normal file
View File

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

2570
Addons/MCKGRushButtonEditor.pas Normal file
View File

File diff suppressed because it is too large Load Diff

2620
Addons/MCKGRushCheckBoxEditor.pas Normal file
View File

File diff suppressed because it is too large Load Diff

3110
Addons/MCKGRushControls.pas Normal file
View File

File diff suppressed because it is too large Load Diff

BIN
Addons/MCKGRushControls.res Normal file
View File

Binary file not shown.

338
Addons/MCKGRushImageCollectionEditor.pas Normal file
View File

@ -0,0 +1,338 @@
unit MCKGRushImageCollectionEditor;
// file: MCKGRushImageCollectionEditor.pas
// file version: 0.35
// last modified: 06.02.06
// package: GRushControls
// author: Karpinskyj Alexandr aka homm
// mailto: homm86@mail.ru
// My humble Web-Page: http://www.homm86.narod.ru
interface
{$I KOLDEF.INC}
uses Windows,
Messages,
ShellAPI,
KOL,
KOLGRushControls,
tinyJPGGIFBMP,
tinyPNG,
mirror,
Classes,
Controls,
mckObjs,
Graphics,
mckCtrls,
MCKGRushControls,
Forms,
{$IFDEF _D6orHigher}
DesignEditors,
DesignIntf;
{$ELSE}
DsgnIntf;
{$ENDIF}
type
TKOLGRushImageCollectionEditor = class( TComponentEditor )
private
protected
public
procedure Edit; override;
procedure ExecuteVerb(Index: Integer); override;
function GetVerb(Index: Integer): string; override;
function GetVerbCount: Integer; override;
end;
ImageCollectionData= record
fImageType: TKOLGRushImageCollectionImageType;
fItemWidth: DWORD;
fItemHeight: DWORD;
fDataStream: TMemoryStream;
end;
PImageCollectionEditor = ^TImageCollectionEditor;
TImageCollectionEditor = object (TObj)
Form: KOL.PControl;
ScrollBox: PControl;
ImageShow: PControl;
ButtonOK: PGRushControl;
ButtonCancel: PGRushControl;
ButtonOpen_Close: PGRushControl;
ButtonSave: PGRushControl;
OSD: KOL.POpenSaveDialog;
Collection: ImageCollectionData;
Comp: TKOLGRushImageCollection;
Bitmap: KOL.PBitmap;
///////////////////
ActiveWindow: HWnd;
WindowList: Pointer;
procedure OKClick(Self_: KOL.PObj);
procedure CancelClick(Self_: KOL.PObj);
procedure CloseClick(Self_: KOL.PObj);
procedure OpenClick(Self_: KOL.PObj);
procedure SaveClick(Self_: KOL.PObj);
procedure CalcRects (Sender: PGRushControl; var Rects: TGRushRects);
procedure DoClose ( Sender: PObj; var Accept: Boolean );
procedure ImageShowPaint ( Sender: PControl; DC: HDC );
procedure SetControls;
end;
procedure Register;
var
ImageCollectionEditor: PImageCollectionEditor;
procedure NewImageCollectionEditor( var Result: PImageCollectionEditor; Component: TKOLGRushImageCollection );
implementation
procedure Register;
begin
RegisterComponentEditor( TKOLGRushImageCollection, TKOLGRushImageCollectionEditor );
end;
procedure NewImageCollectionEditor( var Result: PImageCollectionEditor; Component: TKOLGRushImageCollection );
begin
New(Result, Create);
with Result^ do begin
Form := NewForm(nil, Component.Name + ': Edit').SetClientSize(440, 256).CenterOnParent;
KOL.Applet := Form;
Form.ExStyle := Form.ExStyle or WS_EX_DLGMODALFRAME or WS_EX_WINDOWEDGE;
Form.Style := Form.Style and not (WS_MINIMIZEBOX or WS_MAXIMIZEBOX);
Form.CanResize := FALSE;
Form.OnClose := DoClose;
Form.Add2AutoFree(Result);
ScrollBox := NewScrollBoxEx(Form, esLowered).SetPosition(8, 8).SetSize(320, 240).SetBorder(0);
ImageShow := NewPanel(ScrollBox, esNone);
ImageShow.OnPaint := ImageShowPaint;
ButtonOpen_Close := PGRushControl(NewGRushButton(Result.Form, '').SetSize(96, 24).SetPosition(336, 8));
ButtonOpen_Close.OnRecalcRects := CalcRects;
ButtonSave := PGRushControl(NewGRushButton(Result.Form, 'Save as').SetSize(96, 24).SetPosition(336, 40));
ButtonSave.OnClick := Result.SaveClick;
ButtonSave.OnRecalcRects := CalcRects;
ButtonOK := PGRushControl(NewGRushButton(Result.Form, 'OK').SetSize(96, 24).SetPosition(336, 192));
ButtonOK.OnClick := Result.OKClick;
ButtonOK.OnRecalcRects := CalcRects;
ButtonOK.Focused := TRUE;
ButtonCancel := PGRushControl(NewGRushButton(Result.Form, 'Cancel').SetSize(96, 24).SetPosition(336, 224));
ButtonCancel.OnClick := Result.CancelClick;
ButtonCancel.OnRecalcRects := CalcRects;
OSD := NewOpenSaveDialog('chose file to open', ProjectSourcePath
, [OSFileMustExist, OSHideReadonly, OSPathMustExist, OSOverwritePrompt] );
OSD.Filter := 'Jpeg files|*.jpg;*.jpeg|Png files|*.png|Gif files|*.gif|Bmp files|*.bmp|'
+ 'All suported files|*.jpg;*.jpeg;*.png;*.gif;*.bmp|All files|*.*|';
OSD.FilterIndex := 5;
OSD.WndOwner := Form.Handle;
Comp := Component;
Collection.fImageType := Component.ImageType;
if assigned(Component.DataStream) then begin
Collection.fDataStream := TMemoryStream.Create;
Collection.fDataStream.LoadFromStream(Component.DataStream);
end;
Bitmap := Component.LoadBitmap;
SetControls;
end;
end;
procedure TKOLGRushImageCollectionEditor.Edit;
begin
if Component = nil then Exit;
if not(Component is TKOLGRushImageCollection) then Exit;
ImageCollectionEditor := nil;
AppletTerminated := FALSE;
try
NewImageCollectionEditor(ImageCollectionEditor, Component as TKOLGRushImageCollection);
ImageCollectionEditor.ActiveWindow := GetActiveWindow;
ImageCollectionEditor.WindowList := DisableTaskWindows(0);
KOL.Run(KOL.Applet);
finally
end;
(Component as TKOLGRushImageCollection).Change;
end;
procedure TKOLGRushImageCollectionEditor.ExecuteVerb(Index: Integer);
begin
if Index = 0 then
Edit;
end;
function TKOLGRushImageCollectionEditor.GetVerb(Index: Integer): string;
begin
if Index = 0 then
Result := 'Edit component';
end;
function TKOLGRushImageCollectionEditor.GetVerbCount: Integer;
begin
Result := 1;
end;
procedure TImageCollectionEditor.SetControls;
begin
if Bitmap = nil then begin
try
Collection.fDataStream.Free;
finally
Collection.fDataStream := nil;
end;
Collection.fImageType := None;
ButtonOpen_Close.Caption := 'Open';
ButtonOpen_Close.OnClick := OpenClick;
ButtonSave.Enabled := FALSE;
ImageShow.Visible := FALSE;
end else begin
ButtonOpen_Close.Caption := 'Free';
ButtonOpen_Close.OnClick := CloseClick;
ButtonSave.Enabled := TRUE;
ImageShow.SetSize(Bitmap.Width, Bitmap.Height);
ImageShow.Visible := TRUE;
end;
end;
procedure TImageCollectionEditor.OKClick(Self_: KOL.PObj);
begin
try
Comp.DataStream.Free;
finally
Comp.DataStream := nil;
end;
TKOLGRushImageCollectionImageType((@Comp.ImageType)^) := Collection.fImageType;
if Comp.ImageType <> None then begin
Comp.DataStream := TMemoryStream.Create;
Comp.DataStream.LoadFromStream(Collection.fDataStream);
Comp.DataStream.Position := 0;
end;
Form.Close;
end;
procedure TImageCollectionEditor.CancelClick(Self_: KOL.PObj);
begin
Form.Close;
end;
procedure TImageCollectionEditor.OpenClick(Self_: KOL.PObj);
var KOLStream: KOL.PStream;
begin
OSD.OpenDialog := TRUE;
if OSD.Execute then begin
Collection.fDataStream := TMemoryStream.Create;
Collection.fDataStream.LoadFromFile(OSD.FileName);
KOLStream := NewExMemoryStream(Collection.fDataStream.Memory, Collection.fDataStream.Size);
try
tinyLoadPNG(Bitmap, KOLStream);
except
ShowMessage('��������� ������ �� ����� ������� ������������ ���� ��� *.png'
+ '. ��������� �������� �� ���� ������ (homm86@mail.ru) � ����������'
+ ' ���������� ���� ���� ��� ������ ����� ���������.');
try
Bitmap.Free;
finally
Bitmap := nil;
end;
end;
KOLStream.Free;
if Bitmap <> nil then begin
Collection.fImageType := PNG;
end else begin // maybe JPG?
tinyLoadJPGGIFBMPStream(Bitmap, Collection.fDataStream);
if Bitmap <> nil then begin
Collection.fImageType := BMP_GIF_JPG;
end else begin // not suported
Collection.fImageType := None;
ShowMessage ('This file type not suported.');
try
Collection.fDataStream.Free;
finally
Collection.fDataStream := nil;
end;
try
Bitmap.Free;
finally
Bitmap := nil;
end;
end;
end;
SetControls;
end;
end;
procedure TImageCollectionEditor.CloseClick(Self_: KOL.PObj);
begin
ImageShow.Visible := FALSE;
ButtonOpen_Close.OnClick := OpenClick;
ButtonOpen_Close.Caption := 'Open';
ButtonSave.Enabled := FALSE;
Collection.fImageType := None;
try
Collection.fDataStream.Free;
finally
Collection.fDataStream := nil;
end;
try
Bitmap.Free;
finally
Bitmap := nil;
end;
end;
procedure TImageCollectionEditor.SaveClick(Self_: KOL.PObj);
begin
try
OSD.OpenDialog := FALSE;
if OSD.Execute then begin
Collection.fDataStream.SaveToFile(OSD.FileName);
end;
except
ShowMessage('�� ������� ��������� �������.');
end;
end;
procedure TImageCollectionEditor.DoClose ( Sender: PObj; var Accept: Boolean );
begin
Accept := TRUE;
try
Collection.fDataStream.Free;
finally
Collection.fDataStream := nil;
end;
try
Bitmap.Free;
finally
Bitmap := nil;
end;
EnableTaskWindows(WindowList);
SetActiveWindow(ActiveWindow);
TerminateExecution(KOL.Applet);
end;
procedure TImageCollectionEditor.CalcRects (Sender: PGRushControl; var Rects: TGRushRects);
begin
InflateRect(Rects.AlphaRect, -4, -3);
end;
procedure TImageCollectionEditor.ImageShowPaint ( Sender: PControl; DC: HDC );
begin
if Bitmap <> nil then begin
BitBlt(DC, 0, 0, Bitmap.Width, Bitmap.Height, Bitmap.Canvas.Handle, 0, 0, SRCCOPY);
end;
end;
end.

2147
Addons/MCKGRushPanelEditor.pas Normal file
View File

File diff suppressed because it is too large Load Diff

2290
Addons/MCKGRushProgressBarEditor.pas Normal file
View File

File diff suppressed because it is too large Load Diff

2620
Addons/MCKGRushRadioBoxEditor.pas Normal file
View File

File diff suppressed because it is too large Load Diff

2605
Addons/MCKGRushSplitterEditor.pas Normal file
View File

File diff suppressed because it is too large Load Diff

1197
Addons/err.pas Normal file
View File

File diff suppressed because it is too large Load Diff

972
Addons/kolTCPSocket.pas Normal file
View File

@ -0,0 +1,972 @@
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
ioctlsocket(fhandle,FIONREAD,result);
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/mckBlockCipher.dcr Normal file
View File

Binary file not shown.

1092
Addons/mckBlockCipher.pas Normal file
View File

File diff suppressed because it is too large Load Diff

BIN
Addons/mckCCtrls.dcr Normal file
View File

Binary file not shown.

895
Addons/mckCCtrls.pas Normal file
View File

@ -0,0 +1,895 @@
unit mckCCtrls;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ComCtrls, ExtCtrls, mirror, mckCtrls, KOLCCtrls;
{$I KOLDEF.INC}
type
TKOLTrackBar = class(TKOLControl)
private
FOptions: TTrackbarOptions;
FPosition: Integer;
FRangeMin: Integer;
FSelStart: Integer;
FThumbLen: Integer;
FRangeMax: Integer;
FLineSize: Integer;
FPageSize: Integer;
FSelEnd: Integer;
FOnScroll: TOnScroll;
procedure SetOptions(const Value: TTrackbarOptions);
procedure SetPosition(const Value: Integer);
procedure SetLineSize(const Value: Integer);
procedure SetPageSize(const Value: Integer);
procedure SetRangeMax(const Value: Integer);
procedure SetRangeMin(const Value: Integer);
procedure SetSelEnd(const Value: Integer);
procedure SetSelStart(const Value: Integer);
procedure SetThumbLen(const Value: Integer);
procedure SetOnScroll(const Value: TOnScroll);
protected
function AdditionalUnits: string; override;
function TabStopByDefault: Boolean; override;
procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override;
function SetupParams(const AName, AParent: string): string; override;
procedure SetupConstruct(SL: TStringList; const AName, AParent, Prefix: string); override;
public
constructor Create(AOwner: TComponent); override;
published
property Options: TTrackbarOptions read FOptions write SetOptions;
property Position: Integer read FPosition write SetPosition;
property RangeMin: Integer read FRangeMin write SetRangeMin;
property RangeMax: Integer read FRangeMax write SetRangeMax;
property PageSize: Integer read FPageSize write SetPageSize;
property LineSize: Integer read FLineSize write SetLineSize;
property ThumbLen: Integer read FThumbLen write SetThumbLen;
property SelStart: Integer read FSelStart write SetSelStart;
property SelEnd: Integer read FSelEnd write SetSelEnd;
property OnScroll: TOnScroll read FOnScroll write SetOnScroll;
property TabStop;
property TabOrder;
end;
{ SPC CONTROLS }
TSPCDirectoryEditBox = class(TKOLControl)
private
{ Private declarations }
fPath: string;
fCaptionEmpty: string;
fTitle: string;
fNotAvailable: Boolean;
procedure SetTitle(Value: string);
procedure SetCaptionEmpty(Value: string);
procedure SetPath(Value: string);
protected
{ Protected declarations }
function AdditionalUnits: string; override;
procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override;
public
{ Public declarations }
constructor Create(Owner: TComponent); override;
published
{ Published declarations }
property Path: string read fPath write SetPath;
property Title: string read fTitle write SetTitle;
property Font;
property CaptionEmpty: string read fCaptionEmpty write SetCaptionEmpty;
property OnChange;
property OnShow: Boolean read FNotAvailable;
property OnScroll: Boolean read FNotAvailable;
property OnResize: Boolean read FNotAvailable;
property OnPaint: Boolean read FNotAvailable;
property OnMove: Boolean read FNotAvailable;
property OnMouseWheel: Boolean read FNotAvailable;
property OnMouseUp: Boolean read FNotAvailable;
property OnMouseMove: Boolean read FNotAvailable;
property OnMouseLeave: Boolean read FNotAvailable;
property OnMouseEnter: Boolean read FNotAvailable;
property OnMouseDown: Boolean read FNotAvailable;
property OnMouseDblClk: Boolean read FNotAvailable;
property OnMessage: Boolean read FNotAvailable;
property OnHide: Boolean read FNotAvailable;
property OnEraseBkgnd: Boolean read FNotAvailable;
property OnDropFiles: Boolean read FNotAvailable;
property OnDestroy: Boolean read FNotAvailable;
property OnClick: Boolean read FNotAvailable;
end;
TSortBy = (sbName, sbExtention);
TSPCFileListBox = class(TKOLListBox)
private
{ Private declarations }
fIntegralHeight: Boolean;
fDoCase: TCase;
fPath: string;
fFilters: string;
FNotAvailable: Boolean;
fExecuteOnDblClk: Boolean;
fSortBy: TSortBy;
procedure SetPath(Value: string);
procedure SetFilters(Value: string);
procedure SetIntegralHeight(Value: Boolean);
procedure SetCase(Value: TCase);
procedure SetExecuteOnDblClk(Value: Boolean);
procedure SetSortBy(Value: TSortBy);
protected
{ Protected declarations }
function AdditionalUnits: string; override;
procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override;
public
{ Public declarations }
constructor Create(Owner: TComponent); override;
published
{ Published declarations }
property SortBy: TSortBy read fSortBy write SetSortBy;
property Path: string read fPath write SetPath;
property ExecuteOnDblClk: Boolean read fExecuteOnDblClk write SetExecuteOnDblClk;
property Filters: string read fFilters write SetFilters;
property DoCase: TCase read fDoCase write SetCase;
property IntegralHeight: Boolean read fIntegralHeight write SetIntegralHeight;
property OnChange: Boolean read FNotAvailable;
property OnShow: Boolean read FNotAvailable;
property OnResize: Boolean read FNotAvailable;
property OnPaint: Boolean read FNotAvailable;
property OnMove: Boolean read FNotAvailable;
property OnMouseWheel: Boolean read FNotAvailable;
property OnMouseUp: Boolean read FNotAvailable;
property OnMouseMove: Boolean read FNotAvailable;
property OnMouseLeave: Boolean read FNotAvailable;
property OnMouseEnter: Boolean read FNotAvailable;
property OnMouseDown: Boolean read FNotAvailable;
// property OnMOuseDblClk: Boolean read FNotAvailable;
property OnMessage: Boolean read FNotAvailable;
property OnMeasureItem: Boolean read FNotAvailable;
property OnLeave: Boolean read FNotAvailable;
property OnKeyUp: Boolean read FNotAvailable;
property OnKeyDown: Boolean read FNotAvailable;
property OnHide: Boolean read FNotAvailable;
property OnEnter: Boolean read FNotAvailable;
property OnDropFiles: Boolean read FNotAvailable;
property OnDropDown: Boolean read FNotAvailable;
property OnDrawItem: Boolean read FNotAvailable;
property OnDestroy: Boolean read FNotAvailable;
property OnEraseBkgnd: Boolean read FNotAvailable;
property OnCloseUp: Boolean read FNotAvailable;
property OnClick: Boolean read FNotAvailable;
property OnChar: Boolean read FNotAvailable;
property OnScroll: Boolean read FNotAvailable;
// property Items: Boolean read FNotAvailable;
end;
TSPCDirectoryListBox = class(TKOLListView)
private
{ Private declarations }
fIntegralHeight: Boolean;
fDoIndent: Boolean;
fPath: string;
FNotAvailable: Boolean;
fFileListBox: TSPCFileListBox;
procedure SetPath(Value: string);
procedure SetIndent(Value: Boolean);
procedure SetIntegralHeight(Value: Boolean);
procedure SetFileListBox(Value: TSPCFileListBox);
protected
{ Protected declarations }
function AdditionalUnits: string; override;
procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override;
procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override;
public
{ Public declarations }
constructor Create(Owner: TComponent); override;
published
{ Published declarations }
property FileListBox: TSPCFileListBox read fFileListBox write SetFileListBox;
property Items: Boolean read FNotAvailable;
property ImageListState: Boolean read FNotAvailable;
property ImageListSmall: Boolean read FNotAvailable;
property ImageListNormal: Boolean read FNotAvailable;
property Path: string read fPath write SetPath;
property IntegralHeight: Boolean read fIntegralHeight write SetIntegralHeight;
property DoIndent: Boolean read fDoIndent write SetIndent;
// property OnChange: Boolean read FNotAvailable;
property OnShow: Boolean read FNotAvailable;
property OnResize: Boolean read FNotAvailable;
property OnPaint: Boolean read FNotAvailable;
property OnMove: Boolean read FNotAvailable;
property OnMouseWheel: Boolean read FNotAvailable;
property OnMouseUp: Boolean read FNotAvailable;
property OnMouseMove: Boolean read FNotAvailable;
property OnMouseLeave: Boolean read FNotAvailable;
property OnMouseEnter: Boolean read FNotAvailable;
property OnMouseDown: Boolean read FNotAvailable;
property OnMessage: Boolean read FNotAvailable;
property OnMeasureItem: Boolean read FNotAvailable;
property OnLeave: Boolean read FNotAvailable;
property OnKeyUp: Boolean read FNotAvailable;
property OnKeyDown: Boolean read FNotAvailable;
property OnHide: Boolean read FNotAvailable;
property OnEnter: Boolean read FNotAvailable;
property OnDropFiles: Boolean read FNotAvailable;
property OnDropDown: Boolean read FNotAvailable;
property OnDrawItem: Boolean read FNotAvailable;
property OnDestroy: Boolean read FNotAvailable;
property OnEraseBkgnd: Boolean read FNotAvailable;
property OnCloseUp: Boolean read FNotAvailable;
property OnClick: Boolean read FNotAvailable;
property OnChar: Boolean read FNotAvailable;
property OnScroll: Boolean read FNotAvailable;
property OnLVStateChange: Boolean read FNotAvailable;
property OnLVData: Boolean read FNotAvailable;
property OnLVDelete: Boolean read FNotAvailable;
property OnEndEditLVItem: Boolean read FNotAvailable;
property OnDeleteLVItem: Boolean read FNotAvailable;
property OnDeleteAllLVItems: Boolean read FNotAvailable;
property OnCompareLVItems: Boolean read FNotAvailable;
property OnColumnClick: Boolean read FNotAvailable;
end;
TSPCDriveComboBox = class(TKOLComboBox)
private
{ Private declarations }
fDrive: char;
FNotAvailable: Boolean;
fDirectoryListBox: TSPCDirectoryListBox;
procedure SetDrive(Value: char);
procedure SetDirectoryListBox(Value: TSPCDirectoryListBox);
protected
{ Protected declarations }
function AdditionalUnits: string; override;
procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override;
procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override;
public
{ Public declarations }
constructor Create(Owner: TComponent); override;
published
{ Published declarations }
property DirectoryListBox: TSPCDirectoryListBox read fDirectoryListBox write SetDirectoryListBox;
property Drive: char read fDrive write SetDrive;
property OnSelChange: Boolean read FNotAvailable;
property OnShow: Boolean read FNotAvailable;
property OnResize: Boolean read FNotAvailable;
property OnPaint: Boolean read FNotAvailable;
property OnMove: Boolean read FNotAvailable;
property OnMouseWheel: Boolean read FNotAvailable;
property OnMouseUp: Boolean read FNotAvailable;
property OnMouseMove: Boolean read FNotAvailable;
property OnMouseLeave: Boolean read FNotAvailable;
property OnMouseEnter: Boolean read FNotAvailable;
property OnMouseDown: Boolean read FNotAvailable;
property OnMOuseDblClk: Boolean read FNotAvailable;
property OnMessage: Boolean read FNotAvailable;
property OnMeasureItem: Boolean read FNotAvailable;
property OnLeave: Boolean read FNotAvailable;
property OnKeyUp: Boolean read FNotAvailable;
property OnKeyDown: Boolean read FNotAvailable;
property OnHide: Boolean read FNotAvailable;
property OnEnter: Boolean read FNotAvailable;
property OnDropFiles: Boolean read FNotAvailable;
property OnDropDown: Boolean read FNotAvailable;
property OnDrawItem: Boolean read FNotAvailable;
property OnDestroy: Boolean read FNotAvailable;
property OnEraseBkgnd: Boolean read FNotAvailable;
property OnCloseUp: Boolean read FNotAvailable;
property OnClick: Boolean read FNotAvailable;
property OnChar: Boolean read FNotAvailable;
property Items: Boolean read FNotAvailable;
end;
TSPCFilterComboBox = class(TKOLComboBox)
private
{ Private declarations }
fLines: TStrings;
FNotAvailable: Boolean;
fFileListBox: TSPCFileListBox;
// procedure SetText(Value: TStrings);
// function GetText: TStrings;
procedure SetFileListBox(Value: TSPCFileListBox);
protected
{ Protected declarations }
function AdditionalUnits: string; override;
procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override;
procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override;
public
{ Public declarations }
constructor Create(Owner: TComponent); override;
published
{ Published declarations }
property FileListBox: TSPCFileListBox read fFileListBox write SetFileListBox;
// property Items: Boolean read FNotAvailable;
// property Filters: TStrings read GetText write SetText;
property OnSelChange: Boolean read FNotAvailable;
property OnShow: Boolean read FNotAvailable;
property OnResize: Boolean read FNotAvailable;
property OnPaint: Boolean read FNotAvailable;
property OnMove: Boolean read FNotAvailable;
property OnMouseWheel: Boolean read FNotAvailable;
property OnMouseUp: Boolean read FNotAvailable;
property OnMouseMove: Boolean read FNotAvailable;
property OnMouseLeave: Boolean read FNotAvailable;
property OnMouseEnter: Boolean read FNotAvailable;
property OnMouseDown: Boolean read FNotAvailable;
property OnMOuseDblClk: Boolean read FNotAvailable;
property OnMessage: Boolean read FNotAvailable;
property OnMeasureItem: Boolean read FNotAvailable;
property OnLeave: Boolean read FNotAvailable;
property OnKeyUp: Boolean read FNotAvailable;
property OnKeyDown: Boolean read FNotAvailable;
property OnHide: Boolean read FNotAvailable;
property OnEnter: Boolean read FNotAvailable;
property OnDropFiles: Boolean read FNotAvailable;
property OnDropDown: Boolean read FNotAvailable;
property OnDrawItem: Boolean read FNotAvailable;
property OnDestroy: Boolean read FNotAvailable;
property OnEraseBkgnd: Boolean read FNotAvailable;
property OnCloseUp: Boolean read FNotAvailable;
property OnClick: Boolean read FNotAvailable;
property OnChar: Boolean read FNotAvailable;
end;
TSPCStatusBar = class(TKOLControl)
private
{ Private declarations }
FNotAvailable: Boolean;
fSimpleStatusText: string;
fSizeGrip: Boolean;
procedure SetSimpleStatusText(Value: string);
procedure SetSizeGrip(Value: Boolean);
protected
{ Protected declarations }
function AdditionalUnits: string; override;
procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override;
public
{ Public declarations }
constructor Create(Owner: TComponent); override;
published
{ Published declarations }
property SizeGrip: Boolean read fSizeGrip write SetSizeGrip;
property OnShow: Boolean read FNotAvailable;
property SimpleStatusText: string read fSimpleStatusText write SetSimpleStatusText;
property Caption: Boolean read FNotAvailable;
property OnPaint: Boolean read FNotAvailable;
property OnMove: Boolean read FNotAvailable;
property OnMouseWheel: Boolean read FNotAvailable;
property OnMouseUp: Boolean read FNotAvailable;
property OnMouseMove: Boolean read FNotAvailable;
property OnMouseLeave: Boolean read FNotAvailable;
property OnMouseEnter: Boolean read FNotAvailable;
property OnMouseDown: Boolean read FNotAvailable;
property OnMOuseDblClk: Boolean read FNotAvailable;
property OnMessage: Boolean read FNotAvailable;
property OnMeasureItem: Boolean read FNotAvailable;
property OnLeave: Boolean read FNotAvailable;
property OnKeyUp: Boolean read FNotAvailable;
property OnKeyDown: Boolean read FNotAvailable;
property OnHide: Boolean read FNotAvailable;
property OnEnter: Boolean read FNotAvailable;
property OnDropFiles: Boolean read FNotAvailable;
property OnDropDown: Boolean read FNotAvailable;
property OnDrawItem: Boolean read FNotAvailable;
property OnDestroy: Boolean read FNotAvailable;
property OnEraseBkgnd: Boolean read FNotAvailable;
property OnCloseUp: Boolean read FNotAvailable;
property OnClick: Boolean read FNotAvailable;
property OnChar: Boolean read FNotAvailable;
property Items: Boolean read FNotAvailable;
end;
procedure Register;
(*)
{$R mckCCtrls.dcr}
(*)
implementation
procedure Register;
begin
RegisterComponents('KOLAddons', [TKOLTrackBar, TSPCDirectoryEditBox,
TSPCDirectoryListBox, TSPCDriveComboBox, TSPCFileListBox, TSPCFilterComboBox,
TSPCStatusBar]);
end;
{ TKOLTrackBar }
function TKOLTrackBar.AdditionalUnits: string;
begin
Result := ', KOLCCtrls';
end;
constructor TKOLTrackBar.Create(AOwner: TComponent);
begin
inherited;
Width := 200;
DefaultWidth := Width;
Height := 40;
DefaultHeight := Height;
end;
procedure TKOLTrackBar.SetLineSize(const Value: Integer);
begin
FLineSize := Value;
Change;
end;
procedure TKOLTrackBar.SetOnScroll(const Value: TOnScroll);
begin
FOnScroll := Value;
Change;
end;
procedure TKOLTrackBar.SetOptions(const Value: TTrackbarOptions);
begin
FOptions := Value;
Change;
end;
procedure TKOLTrackBar.SetPageSize(const Value: Integer);
begin
FPageSize := Value;
Change;
end;
procedure TKOLTrackBar.SetPosition(const Value: Integer);
begin
FPosition := Value;
Change;
end;
procedure TKOLTrackBar.SetRangeMax(const Value: Integer);
begin
FRangeMax := Value;
Change;
end;
procedure TKOLTrackBar.SetRangeMin(const Value: Integer);
begin
FRangeMin := Value;
Change;
end;
procedure TKOLTrackBar.SetSelEnd(const Value: Integer);
begin
FSelEnd := Value;
Change;
end;
procedure TKOLTrackBar.SetSelStart(const Value: Integer);
begin
FSelStart := Value;
Change;
end;
procedure TKOLTrackBar.SetThumbLen(const Value: Integer);
begin
FThumbLen := Value;
Change;
end;
procedure TKOLTrackBar.SetupConstruct(SL: TStringList; const AName,
AParent, Prefix: string);
var
S : string;
begin
S := GenerateTransparentInits;
SL.Add(Prefix + AName + ' := PTrackbar( New' + TypeName + '( '
+ SetupParams(AName, AParent) + ' )' + S + ');');
end;
procedure TKOLTrackBar.SetupFirst(SL: TStringList; const AName, AParent,
Prefix: string);
begin
inherited;
if RangeMin <> 0 then
SL.Add(Prefix + AName + '.RangeMin := ' + IntToStr(RangeMin) + ';');
if RangeMax <> 0 then
SL.Add(Prefix + AName + '.RangeMax := ' + IntToStr(RangeMax) + ';');
if PageSize <> 0 then
SL.Add(Prefix + AName + '.PageSize := ' + IntToStr(PageSize) + ';');
if LineSize <> 0 then
SL.Add(Prefix + AName + '.LineSize := ' + IntToStr(LineSize) + ';');
if Position <> 0 then
SL.Add(Prefix + AName + '.Position := ' + IntToStr(Position) + ';');
if ThumbLen <> 0 then
SL.Add(Prefix + AName + '.ThumbLen := ' + IntToStr(ThumbLen) + ';');
if SelStart <> 0 then
SL.Add(Prefix + AName + '.SelStart := ' + IntToStr(SelStart) + ';');
if SelEnd <> 0 then
SL.Add(Prefix + AName + '.SelEnd := ' + IntToStr(SelEnd) + ';');
end;
function TKOLTrackBar.SetupParams(const AName, AParent: string): string;
var
S : string;
begin
S := '';
if trbAutoTicks in Options then S := 'trbAutoTicks,';
if trbEnableSelRange in Options then S := S + 'trbEnableSelRange,';
if trbFixedLength in Options then S := S + 'trbFixedLength,';
if trbNoThumb in Options then S := S + 'trbNoThumb,';
if trbNoTicks in Options then S := S + 'trbNoTicks,';
if trbTooltips in Options then S := S + 'trbTooltips,';
if trbTopLeftMarks in Options then S := S + 'trbTopLeftMarks,';
if trbVertical in Options then S := S + 'trbVertical,';
if trbNoBorder in Options then S := S + 'trbNoBorder,';
S := Copy(S, 1, Length(S) - 1);
Result := AParent + ', [' + S + '], ';
if TMethod(OnScroll).Code <> nil then
Result := Result + 'Result.' + ParentForm.MethodName(TMethod(OnScroll).Code)
else
Result := Result + 'nil';
end;
function TKOLTrackBar.TabStopByDefault: Boolean;
begin
Result := TRUE;
end;
{ TSPCDirectoryEditBox }
constructor TSPCDirectoryEditBox.Create;
var
TS : string;
begin
inherited;
Width := 145;
Height := 21;
Title := 'Select folder:';
GetDir(0, TS);
Path := TS;
Font.FontHeight := -11;
Color := $FFFFFF;
end;
function TSPCDirectoryEditBox.AdditionalUnits;
begin
Result := ', KOLCCtrls';
end;
procedure TSPCDirectoryEditBox.SetPath(Value: string);
begin
if DirectoryExists(Value) then fPath := Value else fPath := '';
Change;
end;
procedure TSPCDirectoryEditBox.SetCaptionEmpty(Value: string);
begin
fCaptionEmpty := Value;
Change;
end;
procedure TSPCDirectoryEditBox.SetTitle(Value: string);
begin
fTitle := Value;
Change;
end;
procedure TSPCDirectoryEditBox.SetupFirst;
begin
inherited;
SL.Add(Prefix + AName + '.Color:=' + IntToStr(Color) + ';');
SL.Add(Prefix + AName + '.Title:=''' + Title + ''';');
SL.Add(Prefix + AName + '.CaptionEmpty:=''' + CaptionEmpty + ''';');
SL.Add(Prefix + AName + '.Initialize;');
SL.Add(Prefix + AName + '.Path:=''' + Path + ''';');
SL.Add(Prefix + AName + '.Top:=' + IntToStr(Top) + ';');
SL.Add(Prefix + AName + '.Left:=' + IntToStr(Left) + ';');
SL.Add(Prefix + AName + '.Width:=' + IntToStr(Width) + ';');
SL.Add(Prefix + AName + '.Height:=' + IntToStr(Height) + ';');
end;
{ TSPCDirectoryListBox }
procedure TSPCDirectoryListBox.SetIndent(Value: Boolean);
begin
fDoIndent := Value;
Change;
end;
constructor TSPCDirectoryListBox.Create;
var
TS : string;
begin
inherited;
Width := 145;
Height := 105;
DoIndent := True;
GetDir(0, TS);
Path := TS;
end;
function TSPCDirectoryListBox.AdditionalUnits;
begin
Result := ', KOLCCtrls';
end;
function Boolean2Str(b: Boolean): string;
begin
if b then
Result := 'True'
else
Result := 'False';
end;
procedure TSPCDirectoryListBox.SetupFirst;
//var St: string;
begin
inherited;
SL.Add(Prefix + AName + '.Top:=' + IntToStr(Top) + ';');
SL.Add(Prefix + AName + '.Left:=' + IntToStr(Left) + ';');
SL.Add(Prefix + AName + '.Width:=' + IntToStr(Width) + ';');
SL.Add(Prefix + AName + '.Height:=' + IntToStr(Height) + ';');
SL.Add(Prefix + AName + '.DoIndent:=' + Boolean2Str(DoIndent) + ';');
SL.Add(Prefix + AName + '.IntegralHeight:=' + Boolean2Str(IntegralHeight) + ';');
SL.Add(Prefix + AName + '.Path:=''' + Path + ''';');
end;
procedure TSPCDirectoryListBox.SetupLast(SL: TStringList; const AName, AParent, Prefix: string);
begin
if Assigned(fFileListBox) then if Length(fFileListBox.Name) > 0 then SL.Add(Prefix + AName + '.FileListBox:=Result.' + fFileListBox.Name + ';');
end;
procedure TSPCDirectoryListBox.SetFileListBox(Value: TSPCFileListBox);
begin
fFileListBox := Value;
Change;
end;
procedure TSPCDirectoryListBox.SetIntegralHeight(Value: Boolean);
begin
fIntegralHeight := Value;
Change;
end;
procedure TSPCDirectoryListBox.SetPath(Value: string);
var
fT : string;
begin
fT := Value;
if Value[Length(Value)] = '\' then fT := Value else
if Length(Value) = 1 then fT := Value + ':\' else fT := Value + '\';
if DirectoryExists(fT) then fPath := fT else fPath := '';
Change;
end;
{ TSPCDriveComboBox }
constructor TSPCDriveComboBox.Create;
var
TS : string;
begin
inherited;
Width := 145;
Height := 22;
Color := clWhite;
GetDir(0, TS);
Drive := TS[1];
end;
function TSPCDriveComboBox.AdditionalUnits;
begin
Result := ', KOLCCtrls';
end;
procedure TSPCDriveComboBox.SetupFirst;
begin
inherited;
SL.Add(Prefix + AName + '.Top:=' + IntToStr(Top) + ';');
SL.Add(Prefix + AName + '.Left:=' + IntToStr(Left) + ';');
SL.Add(Prefix + AName + '.Width:=' + IntToStr(Width) + ';');
SL.Add(Prefix + AName + '.Height:=' + IntToStr(Height) + ';');
SL.Add(Prefix + AName + '.Color:=' + IntToStr(Color) + ';');
SL.Add(Prefix + AName + '.Drive:=''' + Drive + ''';');
end;
procedure TSPCDriveComboBox.SetupLast(SL: TStringList; const AName, AParent, Prefix: string);
begin
if Assigned(fDirectoryListBox) then if Length(fDirectoryListBox.Name) > 0 then SL.Add(Prefix + AName + '.DirectoryListBox:=Result.' + fDirectoryListBox.Name + ';');
end;
procedure TSPCDriveComboBox.SetDirectoryListBox(Value: TSPCDirectoryListBox);
begin
fDirectoryListBox := Value;
Change;
end;
procedure TSPCDriveComboBox.SetDrive;
var
fC : Char;
begin
fC := Value;
if DirectoryExists(fC + ':') then
fDrive := Value;
Change;
end;
{ TSPCFileListBox }
constructor TSPCFileListBox.Create;
var
TS : string;
begin
inherited;
Width := 145;
Height := 105;
Filters := '*.*';
DoCase := ctLower;
GetDir(0, TS);
Path := TS;
Font.FontHeight := -11;
end;
function TSPCFileListBox.AdditionalUnits;
begin
Result := ', KOLCCtrls';
end;
procedure TSPCFileListBox.SetupFirst;
var
St : string;
begin
inherited;
case DoCase of
ctDefault: St := 'ctDefault';
ctLower: St := 'ctLower';
ctUpper: St := 'ctUpper';
end;
SL.Add(Prefix + AName + '.DoCase:=' + St + ';');
SL.Add(Prefix + AName + '.IntegralHeight:=' + Boolean2Str(IntegralHeight) + ';');
SL.Add(Prefix + AName + '.Filters:=''' + Filters + ''';');
SL.Add(Prefix + AName + '.Color:=' + IntToStr(Color) + ';');
SL.Add(Prefix + AName + '.Top:=' + IntToStr(Top) + ';');
SL.Add(Prefix + AName + '.Left:=' + IntToStr(Left) + ';');
SL.Add(Prefix + AName + '.Width:=' + IntToStr(Width) + ';');
SL.Add(Prefix + AName + '.Height:=' + IntToStr(Height) + ';');
SL.Add(Prefix + AName + '.Path:=''' + Path + ''';');
SL.Add(Prefix + AName + '.ExecuteOnDblClk:=' + Boolean2Str(ExecuteOnDblClk) + ';');
case fSortBy of
sbName: SL.Add(Prefix + AName + '._SortBy:=sbName;');
sbExtention: SL.Add(Prefix + AName + '._SortBy:=sbExtention;');
end;
end;
procedure TSPCFileListBox.SetCase(Value: TCase);
begin
fDoCase := Value;
Change;
end;
procedure TSPCFileListBox.SetIntegralHeight(Value: Boolean);
begin
fIntegralHeight := Value;
Change;
end;
procedure TSPCFileListBox.SetFilters(Value: string);
begin
fFilters := Value;
Change;
end;
procedure TSPCFileListBox.SetPath(Value: string);
begin
if DirectoryExists(Value) then
begin
if Value[Length(Value)] = '\' then fPath := Value else fPath := Value + '\';
end else fPath := '';
Change;
end;
procedure TSPCFileListBox.SetExecuteOnDblClk(Value: Boolean);
begin
fExecuteOnDblClk := Value;
Change;
end;
procedure TSPCFileListBox.SetSortBy(Value: TSortBy);
begin
fSortBy := Value;
Change;
end;
{ TSPCFilterComboBox }
constructor TSPCFilterComboBox.Create;
//var
// TS: string;
begin
inherited;
Width := 145;
Height := 22;
Color := clWhite;
fLines := TStringList.Create;
Font.FontHeight := -11;
end;
function TSPCFilterComboBox.AdditionalUnits;
begin
Result := ', KOLCCtrls';
end;
procedure TSPCFilterComboBox.SetFileListBox(Value: TSPCFileListBox);
begin
fFileListBox := Value;
Change;
end;
{procedure TSPCFilterComboBox.SetText;
begin
fLines.Text:=Value.Text;
Change;
end;
function TSPCFilterComboBox.GetText: TStrings;
begin
Result:=fLines;
end;}
procedure TSPCFilterComboBox.SetupFirst;
//var
// i: Integer;
begin
inherited;
if (Length(FLines.Text) > 0) then
AddLongTextField(SL, Prefix, AName + '.Text:=', FLines.Text, ';');
SL.Add(Prefix + AName + '.Color:=' + IntToStr(Color) + ';');
// SL.Add( Prefix + AName + '.BuildList;');
SL.Add(Prefix + AName + '.Top:=' + IntToStr(Top) + ';');
SL.Add(Prefix + AName + '.Left:=' + IntToStr(Left) + ';');
SL.Add(Prefix + AName + '.Width:=' + IntToStr(Width) + ';');
SL.Add(Prefix + AName + '.Height:=' + IntToStr(Height) + ';');
end;
procedure TSPCFilterComboBox.SetupLast(SL: TStringList; const AName, AParent, Prefix: string);
begin
if Assigned(fFileListBox) then if Length(fFileListBox.Name) > 0 then SL.Add(Prefix + AName + '.FileListBox:=Result.' + fFileListBox.Name + ';');
end;
{ TSPCStatusBar }
constructor TSPCStatusBar.Create;
//var
// TS: string;
begin
inherited;
Width := 145;
Height := 19;
Align := TKOLAlign(caBottom);
end;
function TSPCStatusBar.AdditionalUnits;
begin
Result := ', KOLCCtrls';
end;
procedure TSPCStatusBar.SetupFirst;
//var
// St: string;
begin
inherited;
SL.Add(Prefix + AName + '.Top:=' + IntToStr(Top) + ';');
SL.Add(Prefix + AName + '.Left:=' + IntToStr(Left) + ';');
SL.Add(Prefix + AName + '.Width:=' + IntToStr(Width) + ';');
SL.Add(Prefix + AName + '.Height:=' + IntToStr(Height) + ';');
SL.Add(Prefix + AName + '.SimpleStatusText:=''' + SimpleStatusText + ''';');
SL.Add(Prefix + AName + '.SizeGrip:=' + Boolean2Str(SizeGrip) + ';');
end;
procedure TSPCStatusBar.SetSimpleStatusText(Value: string);
begin
fSimpleStatusText := Value;
Change;
end;
procedure TSPCStatusBar.SetSizeGrip(Value: Boolean);
begin
fSizeGrip := Value;
Change;
end;
end.

BIN
Addons/mckCProgBar.dcr Normal file
View File

Binary file not shown.

306
Addons/mckCProgBar.pas Normal file
View File

@ -0,0 +1,306 @@
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 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;
function AdditionalUnits: string; override;
procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override;
public
{ Public declarations }
constructor Create(Owner: TComponent); 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/mckEcmListEdit.dcr Normal file
View File

Binary file not shown.

233
Addons/mckEcmListEdit.pas Normal file
View File

@ -0,0 +1,233 @@
unit mckEcmListEdit;
interface
{$I KOLDEF.INC}
uses
Windows, KOL, Classes, Messages, Forms, SysUtils, mirror,
mckCtrls, Graphics, KOLEcmListEdit,
//////////////////////////////////////////////////
{$IFDEF _D6orHigher} //
DesignIntf, DesignEditors, DesignConst, //
Variants, //
{$ELSE} //
//////////////////////////////////////////////////
DsgnIntf,
//////////////////////////////////////////////////////////
{$ENDIF} //
mckLVColumnsEditor;
type
// TOnEditText = procedure (Sender: PControl; ACol, ARow: Integer; var Value: String) of object;
TKOLEcmListEdit = class(TKOLListView)
private
fDrawForbidden: TOnDrawItem;
fListData: boolean;
fOnGetText: TOnEditText;
fOnPutText: TOnEditText;
fOnEndEdit: TOnEndEdit;
fOnColAdjust: TOnColAdjust;
fOnEditChar: TOnEditChar;
fOnCreateEdit: TOnCreateEdit;
fLimStyle: TKOLListViewStyle;
fOnDrawCell: TOnDrawCell;
procedure SetOnGetText(const Value: TOnEditText);
procedure SetOnPutText(const Value: TOnEditText);
procedure SetOnEndEdit(const Value: TOnEndEdit);
procedure SetOnColAdjust(const Value: TOnColAdjust);
procedure SetOnEditChar(const Value: TOnEditChar);
procedure SetOnCreateEdit(const Value: TOnCreateEdit);
procedure SetLimStyle(const Value: TKOLListViewStyle);
procedure SetOnDrawCell(const Value: TOnDrawCell);
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 SetupParams( const AName, AParent: String ): String; override;
function GetCaption: string;
function GetStyle: TKOLListViewStyle;
function GetOptions: TKOLListViewOptions;
procedure SetOptions(v: TKOLListViewOptions);
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 fLimStyle write SetLimStyle;
property Options: TKOLListViewOptions read GetOptions write SetOptions;
property OnGetEditText: TOnEditText read fOnGetText write SetOnGetText;
property OnPutEditText: TOnEditText read fOnPutText write SetOnPutText;
property OnStopEdit: TOnEndEdit read fOnEndEdit write SetOnEndEdit;
property OnColAdjust: TOnColAdjust read fOnColAdjust write SetOnColAdjust;
property OnEditChar: TOnEditChar read fOnEditChar write SetOnEditChar;
property OnCreateEdit: TOnCreateEdit read fOnCreateEdit write SetOnCreateEdit;
property OnDrawCell: TOnDrawCell read FOnDrawCell write SetOnDrawCell;
// Hide in Object Inspector property OnDrawItem (made read only)
property OnDrawItem: TOnDrawItem read fDrawForbidden;
end;
procedure Register;
implementation
//{$R EcmListEdit.dcr}
constructor TKOLEcmListEdit.Create;
begin
inherited;
inherited Style := lvsDetail;
inherited Options := [{lvoRowSelect,}lvoHideSel,lvoGridLines,lvoOwnerDrawFixed];
// Font.FontCharset := 204;
end;
function TKOLEcmListEdit.AdditionalUnits;
begin
Result := ', KOLEcmListEdit';
end;
procedure TKOLEcmListEdit.SetupFirst;
begin
// if @fOnGetText <> nil then
// SL.Add( ' PEcmListEdit(' + AName + '.CustomObj).OnGetEditText := Result.' +
inherited;
end;
procedure TKOLEcmListEdit.SetupLast;
begin
inherited AssignEvents(SL, AName);
if @fOnGetText <> nil then
SL.Add( ' PEcmListEdit(' + AName + '.CustomObj).OnGetEditText := Result.' +
ParentForm.MethodName( @OnGetEditText ) + ';' );
if @fOnPutText <> nil then
SL.Add( ' PEcmListEdit(' + AName + '.CustomObj).OnPutEditText := Result.' +
ParentForm.MethodName( @OnPutEditText ) + ';' );
if @fOnEndEdit <> nil then
SL.Add( ' PEcmListEdit(' + AName + '.CustomObj).OnStopEdit := Result.' +
ParentForm.MethodName( @OnStopEdit ) + ';' );
if @fOnColAdjust <> nil then
SL.Add( ' PEcmListEdit(' + AName + '.CustomObj).OnColAdjust := Result.' +
ParentForm.MethodName( @OnColAdjust ) + ';' );
if @fOnEditChar <> nil then
SL.Add( ' PEcmListEdit(' + AName + '.CustomObj).OnEditChar := Result.' +
ParentForm.MethodName( @OnEditChar ) + ';' );
if @fOnCreateEdit <> nil then
SL.Add( ' PEcmListEdit(' + AName + '.CustomObj).OnCreateEdit := Result.' +
ParentForm.MethodName( @OnCreateEdit ) + ';' );
if @fOnDrawCell <> nil then
SL.Add( ' PEcmListEdit(' + AName + '.CustomObj).OnDrawCell := Result.' +
ParentForm.MethodName( @OnDrawCell ) + ';' );
end;
procedure TKOLEcmListEdit.AssignEvents;
begin
inherited;
end;
function TKOLEcmListEdit.GetCaption;
begin
Result := inherited Caption;
end;
function TKOLEcmListEdit.GetStyle;
begin
// Result := lvsDetail;
Result := fLimStyle;
end;
function TKOLEcmListEdit.GetOptions;
begin
Result := inherited Options;
end;
procedure TKOLEcmListEdit.SetOptions;
begin
inherited Options := v + [{lvoRowSelect,}lvoHideSel,lvoOwnerDrawFixed];
end;
procedure Register;
begin
RegisterComponents('KOLAddons', [TKOLEcmListEdit]);
RegisterComponentEditor( TKOLEcmListEdit, TKOLLVColumnsEditor );
end;
procedure TKOLEcmListEdit.UpdateColumns;
begin
Change;
end;
procedure TKOLEcmListEdit.SetOnGetText(const Value: TOnEditText);
begin
if @fOnGetText <> @Value then begin
fOnGetText := Value;
Change();
end;
end;
procedure TKOLEcmListEdit.SetOnPutText(const Value: TOnEditText);
begin
if @fOnPutText <> @Value then begin
fOnPutText := Value;
Change();
end;
end;
procedure TKOLEcmListEdit.SetOnEndEdit(const Value: TOnEndEdit);
begin
if @fOnEndEdit <> @Value then begin
fOnEndEdit := Value;
Change();
end;
end;
procedure TKOLEcmListEdit.SetOnColAdjust(const Value: TOnColAdjust);
begin
if @fOnColAdjust <> @Value then begin
fOnColAdjust := Value;
Change;
end;
end;
procedure TKOLEcmListEdit.SetOnEditChar(const Value: TOnEditChar);
begin
if @fOnEditChar <> @Value then begin
fOnEditChar := Value;
Change();
end;
end;
procedure TKOLEcmListEdit.SetOnDrawCell(const Value: TOnDrawCell);
begin
if @FOnDrawCell <> @Value then begin
FOnDrawCell:= Value;
Change();
end;
end;
function TKOLEcmListEdit.SetupParams(const AName, AParent: String): String;
begin
Result := inherited SetupParams(AName,AParent)
end;
procedure TKOLEcmListEdit.SetOnCreateEdit(const Value: TOnCreateEdit);
begin
if @fOnCreateEdit <> @Value then begin
fOnCreateEdit := Value;
Change();
end;
end;
procedure TKOLEcmListEdit.SetLimStyle(const Value: TKOLListViewStyle);
begin
if (Value <> fLimStyle) and ((Value = lvsDetail) or (Value = lvsDetailNoHeader)) then begin
fLimStyle := Value;
inherited Style := fLimStyle;
end;
end;
end.

BIN
Addons/mckHTTP.dcr Normal file
View File

Binary file not shown.

154
Addons/mckHTTP.pas Normal file
View File

@ -0,0 +1,154 @@
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 Normal file
View File

Binary file not shown.

BIN
Addons/mckHashs.dcr Normal file
View File

Binary file not shown.

920
Addons/mckHashs.pas Normal file
View File

@ -0,0 +1,920 @@
unit mckHashs;
interface
uses
Windows, Messages, Classes, Controls, mirror, mckCtrls, KOL, Graphics;
type
TKOLHAVAL = class(TKOLObj)
private
// fOnMyEvent: TOnMyEvent;
// procedure SetOnMyEvent(Value: TOnMyEvent);
protected
function AdditionalUnits: string; override;
procedure AssignEvents(SL: TStringList; const AName: string); override;
procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override;
procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override;
public
constructor Create(Owner: TComponent); override;
function TypeName: string; override;
published
// property OnMyEvent: TOnMyEvent read fOnMyEvent write SetOnMyEvent;
end;
TKOLMD4 = class(TKOLObj)
private
// fOnMyEvent: TOnMyEvent;
// procedure SetOnMyEvent(Value: TOnMyEvent);
protected
function AdditionalUnits: string; override;
procedure AssignEvents(SL: TStringList; const AName: string); override;
procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override;
procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override;
public
constructor Create(Owner: TComponent); override;
function TypeName: string; override;
published
// property OnMyEvent: TOnMyEvent read fOnMyEvent write SetOnMyEvent;
end;
TKOLMD5 = class(TKOLObj)
private
// fOnMyEvent: TOnMyEvent;
// procedure SetOnMyEvent(Value: TOnMyEvent);
protected
function AdditionalUnits: string; override;
procedure AssignEvents(SL: TStringList; const AName: string); override;
procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override;
procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override;
public
constructor Create(Owner: TComponent); override;
function TypeName: string; override;
published
// property OnMyEvent: TOnMyEvent read fOnMyEvent write SetOnMyEvent;
end;
TKOLRMD128 = class(TKOLObj)
private
// fOnMyEvent: TOnMyEvent;
// procedure SetOnMyEvent(Value: TOnMyEvent);
protected
function AdditionalUnits: string; override;
procedure AssignEvents(SL: TStringList; const AName: string); override;
procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override;
procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override;
public
constructor Create(Owner: TComponent); override;
function TypeName: string; override;
published
// property OnMyEvent: TOnMyEvent read fOnMyEvent write SetOnMyEvent;
end;
TKOLRMD160 = class(TKOLObj)
private
// fOnMyEvent: TOnMyEvent;
// procedure SetOnMyEvent(Value: TOnMyEvent);
protected
function AdditionalUnits: string; override;
procedure AssignEvents(SL: TStringList; const AName: string); override;
procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override;
procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override;
public
constructor Create(Owner: TComponent); override;
function TypeName: string; override;
published
// property OnMyEvent: TOnMyEvent read fOnMyEvent write SetOnMyEvent;
end;
TKOLSHA1 = class(TKOLObj)
private
// fOnMyEvent: TOnMyEvent;
// procedure SetOnMyEvent(Value: TOnMyEvent);
protected
function AdditionalUnits: string; override;
procedure AssignEvents(SL: TStringList; const AName: string); override;
procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override;
procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override;
public
constructor Create(Owner: TComponent); override;
function TypeName: string; override;
published
// property OnMyEvent: TOnMyEvent read fOnMyEvent write SetOnMyEvent;
end;
TKOLSHA256 = class(TKOLObj)
private
// fOnMyEvent: TOnMyEvent;
// procedure SetOnMyEvent(Value: TOnMyEvent);
protected
function AdditionalUnits: string; override;
procedure AssignEvents(SL: TStringList; const AName: string); override;
procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override;
procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override;
public
constructor Create(Owner: TComponent); override;
function TypeName: string; override;
published
// property OnMyEvent: TOnMyEvent read fOnMyEvent write SetOnMyEvent;
end;
TKOLSHA384 = class(TKOLObj)
private
// fOnMyEvent: TOnMyEvent;
// procedure SetOnMyEvent(Value: TOnMyEvent);
protected
function AdditionalUnits: string; override;
procedure AssignEvents(SL: TStringList; const AName: string); override;
procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override;
procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override;
public
constructor Create(Owner: TComponent); override;
function TypeName: string; override;
published
// property OnMyEvent: TOnMyEvent read fOnMyEvent write SetOnMyEvent;
end;
TKOLSHA512 = class(TKOLObj)
private
// fOnMyEvent: TOnMyEvent;
// procedure SetOnMyEvent(Value: TOnMyEvent);
protected
function AdditionalUnits: string; override;
procedure AssignEvents(SL: TStringList; const AName: string); override;
procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override;
procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override;
public
constructor Create(Owner: TComponent); override;
function TypeName: string; override;
published
// property OnMyEvent: TOnMyEvent read fOnMyEvent write SetOnMyEvent;
end;
TKOLTIGER = class(TKOLObj)
private
// fOnMyEvent: TOnMyEvent;
// procedure SetOnMyEvent(Value: TOnMyEvent);
protected
function AdditionalUnits: string; override;
procedure AssignEvents(SL: TStringList; const AName: string); override;
procedure SetupFirst(SL: TStringList; const AName, AParent, Prefix: string); override;
procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: string); override;
public
constructor Create(Owner: TComponent); override;
function TypeName: string; override;
published
// property OnMyEvent: TOnMyEvent read fOnMyEvent write SetOnMyEvent;
end;
procedure Register;
{$R *.dcr}
implementation
procedure Register;
begin
RegisterComponents('KOL HASHES', [TKOLHAVAL, TKOLMD4, TKOLMD5, TKOLRMD128,
TKOLRMD160, TKOLSHA1, TKOLSHA256, TKOLSHA384, TKOLSHA512, TKOLTIGER]);
end;
{ ���������� ������ }
function TKOLHAVAL.AdditionalUnits;
begin
Result := ', KOLHashs';
end;
function TKOLHAVAL.TypeName: string;
begin
Result := 'TKOLHAVAL';
end;
////////////////////////////////////////////////////////////////////////////////
{--------------------------}
{ ����������� ������������ }
{--------------------------}
procedure TKOLHAVAL.AssignEvents;
begin
inherited;
// DoAssignEvents(SL, AName, ['OnMyEvent'], [@OnMyEvent]);
// DoAssignEvents(SL, AName, ['OnEvent1', 'OnEvent2'], [@OnEvent1, @OnEvent2]);
end;
{--------------------------}
{ ���������� � unitX_X.inc }
{--------------------------}
procedure TKOLHAVAL.SetupFirst;
//const
// spc = ', ';
// Boolean2Str: array [Boolean] of String = ('FALSE', 'TRUE');
begin
SL.Add(Prefix + AName + ' := NewHAVAL;');
// Boolean2Str[TRUE]
// Color2Str(myColor)
// SL.Add(Prefix + AName + '.myStr := ''' + myStr + ''';');
end;
{--------------------------}
{ ���������� � unitX_X.inc }
{--------------------------}
procedure TKOLHAVAL.SetupLast;
begin
// SL.Add(Prefix + AName + '.myInt := ' + Int2Str(myInt) + ';');
end;
////////////////////////////////////////////////////////////////////////////////
{-------------}
{ ����������� }
{-------------}
constructor TKOLHAVAL.Create;
begin
inherited;
// fmyInt := 10;
end;
{ procedure TKOLHAVAL.SetOnMyEvent;
begin
fOnMyEvent := Value;
Change;
end; }
{ ���������� ������ }
function TKOLMD4.AdditionalUnits;
begin
Result := ', KOLHashs';
end;
function TKOLMD4.TypeName: string;
begin
Result := 'TKOLMD4';
end;
////////////////////////////////////////////////////////////////////////////////
{--------------------------}
{ ����������� ������������ }
{--------------------------}
procedure TKOLMD4.AssignEvents;
begin
inherited;
// DoAssignEvents(SL, AName, ['OnMyEvent'], [@OnMyEvent]);
// DoAssignEvents(SL, AName, ['OnEvent1', 'OnEvent2'], [@OnEvent1, @OnEvent2]);
end;
{--------------------------}
{ ���������� � unitX_X.inc }
{--------------------------}
procedure TKOLMD4.SetupFirst;
//const
// spc = ', ';
// Boolean2Str: array [Boolean] of String = ('FALSE', 'TRUE');
begin
SL.Add(Prefix + AName + ' := NewMD4;');
// Boolean2Str[TRUE]
// Color2Str(myColor)
// SL.Add(Prefix + AName + '.myStr := ''' + myStr + ''';');
end;
{--------------------------}
{ ���������� � unitX_X.inc }
{--------------------------}
procedure TKOLMD4.SetupLast;
begin
// SL.Add(Prefix + AName + '.myInt := ' + Int2Str(myInt) + ';');
end;
////////////////////////////////////////////////////////////////////////////////
{-------------}
{ ����������� }
{-------------}
constructor TKOLMD4.Create;
begin
inherited;
// fmyInt := 10;
end;
{ procedure TKOLMD4.SetOnMyEvent;
begin
fOnMyEvent := Value;
Change;
end; }
{ ���������� ������ }
function TKOLMD5.AdditionalUnits;
begin
Result := ', KOLHashs';
end;
function TKOLMD5.TypeName: string;
begin
Result := 'TKOLMD5';
end;
////////////////////////////////////////////////////////////////////////////////
{--------------------------}
{ ����������� ������������ }
{--------------------------}
procedure TKOLMD5.AssignEvents;
begin
inherited;
// DoAssignEvents(SL, AName, ['OnMyEvent'], [@OnMyEvent]);
// DoAssignEvents(SL, AName, ['OnEvent1', 'OnEvent2'], [@OnEvent1, @OnEvent2]);
end;
{--------------------------}
{ ���������� � unitX_X.inc }
{--------------------------}
procedure TKOLMD5.SetupFirst;
//const
// spc = ', ';
// Boolean2Str: array [Boolean] of String = ('FALSE', 'TRUE');
begin
SL.Add(Prefix + AName + ' := NewMD5;');
// Boolean2Str[TRUE]
// Color2Str(myColor)
// SL.Add(Prefix + AName + '.myStr := ''' + myStr + ''';');
end;
{--------------------------}
{ ���������� � unitX_X.inc }
{--------------------------}
procedure TKOLMD5.SetupLast;
begin
// SL.Add(Prefix + AName + '.myInt := ' + Int2Str(myInt) + ';');
end;
////////////////////////////////////////////////////////////////////////////////
{-------------}
{ ����������� }
{-------------}
constructor TKOLMD5.Create;
begin
inherited;
// fmyInt := 10;
end;
{ procedure TKOLMD5.SetOnMyEvent;
begin
fOnMyEvent := Value;
Change;
end; }
{ ���������� ������ }
function TKOLRMD128.AdditionalUnits;
begin
Result := ', KOLHashs';
end;
function TKOLRMD128.TypeName: string;
begin
Result := 'TKOLRMD128';
end;
////////////////////////////////////////////////////////////////////////////////
{--------------------------}
{ ����������� ������������ }
{--------------------------}
procedure TKOLRMD128.AssignEvents;
begin
inherited;
// DoAssignEvents(SL, AName, ['OnMyEvent'], [@OnMyEvent]);
// DoAssignEvents(SL, AName, ['OnEvent1', 'OnEvent2'], [@OnEvent1, @OnEvent2]);
end;
{--------------------------}
{ ���������� � unitX_X.inc }
{--------------------------}
procedure TKOLRMD128.SetupFirst;
//const
// spc = ', ';
// Boolean2Str: array [Boolean] of String = ('FALSE', 'TRUE');
begin
SL.Add(Prefix + AName + ' := NewRMD128;');
// Boolean2Str[TRUE]
// Color2Str(myColor)
// SL.Add(Prefix + AName + '.myStr := ''' + myStr + ''';');
end;
{--------------------------}
{ ���������� � unitX_X.inc }
{--------------------------}
procedure TKOLRMD128.SetupLast;
begin
// SL.Add(Prefix + AName + '.myInt := ' + Int2Str(myInt) + ';');
end;
////////////////////////////////////////////////////////////////////////////////
{-------------}
{ ����������� }
{-------------}
constructor TKOLRMD128.Create;
begin
inherited;
// fmyInt := 10;
end;
{ procedure TKOLRMD128.SetOnMyEvent;
begin
fOnMyEvent := Value;
Change;
end; }
{ ���������� ������ }
function TKOLRMD160.AdditionalUnits;
begin
Result := ', KOLHashs';
end;
function TKOLRMD160.TypeName: string;
begin
Result := 'TKOLRMD160';
end;
////////////////////////////////////////////////////////////////////////////////
{--------------------------}
{ ����������� ������������ }
{--------------------------}
procedure TKOLRMD160.AssignEvents;
begin
inherited;
// DoAssignEvents(SL, AName, ['OnMyEvent'], [@OnMyEvent]);
// DoAssignEvents(SL, AName, ['OnEvent1', 'OnEvent2'], [@OnEvent1, @OnEvent2]);
end;
{--------------------------}
{ ���������� � unitX_X.inc }
{--------------------------}
procedure TKOLRMD160.SetupFirst;
//const
// spc = ', ';
// Boolean2Str: array [Boolean] of String = ('FALSE', 'TRUE');
begin
SL.Add(Prefix + AName + ' := NewRMD160;');
// Boolean2Str[TRUE]
// Color2Str(myColor)
// SL.Add(Prefix + AName + '.myStr := ''' + myStr + ''';');
end;
{--------------------------}
{ ���������� � unitX_X.inc }
{--------------------------}
procedure TKOLRMD160.SetupLast;
begin
// SL.Add(Prefix + AName + '.myInt := ' + Int2Str(myInt) + ';');
end;
////////////////////////////////////////////////////////////////////////////////
{-------------}
{ ����������� }
{-------------}
constructor TKOLRMD160.Create;
begin
inherited;
// fmyInt := 10;
end;
{ procedure TKOLRMD160.SetOnMyEvent;
begin
fOnMyEvent := Value;
Change;
end; }
{ ���������� ������ }
function TKOLSHA1.AdditionalUnits;
begin
Result := ', KOLHashs';
end;
function TKOLSHA1.TypeName: string;
begin
Result := 'TKOLSHA1';
end;
////////////////////////////////////////////////////////////////////////////////
{--------------------------}
{ ����������� ������������ }
{--------------------------}
procedure TKOLSHA1.AssignEvents;
begin
inherited;
// DoAssignEvents(SL, AName, ['OnMyEvent'], [@OnMyEvent]);
// DoAssignEvents(SL, AName, ['OnEvent1', 'OnEvent2'], [@OnEvent1, @OnEvent2]);
end;
{--------------------------}
{ ���������� � unitX_X.inc }
{--------------------------}
procedure TKOLSHA1.SetupFirst;
//const
// spc = ', ';
// Boolean2Str: array [Boolean] of String = ('FALSE', 'TRUE');
begin
SL.Add(Prefix + AName + ' := NewSHA1;');
// Boolean2Str[TRUE]
// Color2Str(myColor)
// SL.Add(Prefix + AName + '.myStr := ''' + myStr + ''';');
end;
{--------------------------}
{ ���������� � unitX_X.inc }
{--------------------------}
procedure TKOLSHA1.SetupLast;
begin
// SL.Add(Prefix + AName + '.myInt := ' + Int2Str(myInt) + ';');
end;
////////////////////////////////////////////////////////////////////////////////
{-------------}
{ ����������� }
{-------------}
constructor TKOLSHA1.Create;
begin
inherited;
// fmyInt := 10;
end;
{ procedure TKOLSHA1.SetOnMyEvent;
begin
fOnMyEvent := Value;
Change;
end; }
{ ���������� ������ }
function TKOLSHA256.AdditionalUnits;
begin
Result := ', KOLHashs';
end;
function TKOLSHA256.TypeName: string;
begin
Result := 'TKOLSHA256';
end;
////////////////////////////////////////////////////////////////////////////////
{--------------------------}
{ ����������� ������������ }
{--------------------------}
procedure TKOLSHA256.AssignEvents;
begin
inherited;
// DoAssignEvents(SL, AName, ['OnMyEvent'], [@OnMyEvent]);
// DoAssignEvents(SL, AName, ['OnEvent1', 'OnEvent2'], [@OnEvent1, @OnEvent2]);
end;
{--------------------------}
{ ���������� � unitX_X.inc }
{--------------------------}
procedure TKOLSHA256.SetupFirst;
//const
// spc = ', ';
// Boolean2Str: array [Boolean] of String = ('FALSE', 'TRUE');
begin
SL.Add(Prefix + AName + ' := NewSHA256;');
// Boolean2Str[TRUE]
// Color2Str(myColor)
// SL.Add(Prefix + AName + '.myStr := ''' + myStr + ''';');
end;
{--------------------------}
{ ���������� � unitX_X.inc }
{--------------------------}
procedure TKOLSHA256.SetupLast;
begin
// SL.Add(Prefix + AName + '.myInt := ' + Int2Str(myInt) + ';');
end;
////////////////////////////////////////////////////////////////////////////////
{-------------}
{ ����������� }
{-------------}
constructor TKOLSHA256.Create;
begin
inherited;
// fmyInt := 10;
end;
{ procedure TKOLSHA256.SetOnMyEvent;
begin
fOnMyEvent := Value;
Change;
end; }
{ ���������� ������ }
function TKOLSHA384.AdditionalUnits;
begin
Result := ', KOLHashs';
end;
function TKOLSHA384.TypeName: string;
begin
Result := 'TKOLSHA384';
end;
////////////////////////////////////////////////////////////////////////////////
{--------------------------}
{ ����������� ������������ }
{--------------------------}
procedure TKOLSHA384.AssignEvents;
begin
inherited;
// DoAssignEvents(SL, AName, ['OnMyEvent'], [@OnMyEvent]);
// DoAssignEvents(SL, AName, ['OnEvent1', 'OnEvent2'], [@OnEvent1, @OnEvent2]);
end;
{--------------------------}
{ ���������� � unitX_X.inc }
{--------------------------}
procedure TKOLSHA384.SetupFirst;
begin
SL.Add(Prefix + AName + ' := NewSHA384;');
// Boolean2Str[TRUE]
// Color2Str(myColor)
// SL.Add(Prefix + AName + '.myStr := ''' + myStr + ''';');
end;
{--------------------------}
{ ���������� � unitX_X.inc }
{--------------------------}
procedure TKOLSHA384.SetupLast;
begin
// SL.Add(Prefix + AName + '.myInt := ' + Int2Str(myInt) + ';');
end;
////////////////////////////////////////////////////////////////////////////////
{-------------}
{ ����������� }
{-------------}
constructor TKOLSHA384.Create;
begin
inherited;
// fmyInt := 10;
end;
{ procedure TKOLSHA384.SetOnMyEvent;
begin
fOnMyEvent := Value;
Change;
end; }
{ ���������� ������ }
function TKOLSHA512.AdditionalUnits;
begin
Result := ', KOLHashs';
end;
function TKOLSHA512.TypeName: string;
begin
Result := 'TKOLSHA512';
end;
////////////////////////////////////////////////////////////////////////////////
{--------------------------}
{ ����������� ������������ }
{--------------------------}
procedure TKOLSHA512.AssignEvents;
begin
inherited;
// DoAssignEvents(SL, AName, ['OnMyEvent'], [@OnMyEvent]);
// DoAssignEvents(SL, AName, ['OnEvent1', 'OnEvent2'], [@OnEvent1, @OnEvent2]);
end;
{--------------------------}
{ ���������� � unitX_X.inc }
{--------------------------}
procedure TKOLSHA512.SetupFirst;
//const
// spc = ', ';
// Boolean2Str: array [Boolean] of String = ('FALSE', 'TRUE');
begin
SL.Add(Prefix + AName + ' := NewSHA512;');
// Boolean2Str[TRUE]
// Color2Str(myColor)
// SL.Add(Prefix + AName + '.myStr := ''' + myStr + ''';');
end;
{--------------------------}
{ ���������� � unitX_X.inc }
{--------------------------}
procedure TKOLSHA512.SetupLast;
begin
// SL.Add(Prefix + AName + '.myInt := ' + Int2Str(myInt) + ';');
end;
////////////////////////////////////////////////////////////////////////////////
{-------------}
{ ����������� }
{-------------}
constructor TKOLSHA512.Create;
begin
inherited;
// fmyInt := 10;
end;
{ procedure TKOLSHA512.SetOnMyEvent;
begin
fOnMyEvent := Value;
Change;
end; }
{ ���������� ������ }
function TKOLTIGER.AdditionalUnits;
begin
Result := ', KOLHashs';
end;
function TKOLTIGER.TypeName: string;
begin
Result := 'TKOLTIGER';
end;
////////////////////////////////////////////////////////////////////////////////
{--------------------------}
{ ����������� ������������ }
{--------------------------}
procedure TKOLTIGER.AssignEvents;
begin
inherited;
// DoAssignEvents(SL, AName, ['OnMyEvent'], [@OnMyEvent]);
// DoAssignEvents(SL, AName, ['OnEvent1', 'OnEvent2'], [@OnEvent1, @OnEvent2]);
end;
{--------------------------}
{ ���������� � unitX_X.inc }
{--------------------------}
procedure TKOLTIGER.SetupFirst;
//const
// spc = ', ';
// Boolean2Str: array [Boolean] of String = ('FALSE', 'TRUE');
begin
SL.Add(Prefix + AName + ' := NewTIGER;');
// Boolean2Str[TRUE]
// Color2Str(myColor)
// SL.Add(Prefix + AName + '.myStr := ''' + myStr + ''';');
end;
{--------------------------}
{ ���������� � unitX_X.inc }
{--------------------------}
procedure TKOLTIGER.SetupLast;
begin
// SL.Add(Prefix + AName + '.myInt := ' + Int2Str(myInt) + ';');
end;
////////////////////////////////////////////////////////////////////////////////
{-------------}
{ ����������� }
{-------------}
constructor TKOLTIGER.Create;
begin
inherited;
// fmyInt := 10;
end;
{ procedure TKOLTIGER.SetOnMyEvent;
begin
fOnMyEvent := Value;
Change;
end; }
end.