From 0e80f52e2f4f018c79f16a94678148e6fac8b835 Mon Sep 17 00:00:00 2001 From: dkolmck Date: Thu, 4 Dec 2014 10:46:29 +0000 Subject: [PATCH] - del old modules * fix some warnings in D2009+ versions git-svn-id: https://svn.code.sf.net/p/kolmck/code@145 91bb2d04-0c0c-4d2d-88a5-bbb6f4c1fa07 --- Addons/KOLAddons2006.dpk | 26 +- Addons/KOLCCtrls.pas | 2 +- Addons/KOLHTTPDownload.pas | 1138 ------------------------ Addons/KOLHttp.pas | 209 ----- Addons/KOLMHToolTip.pas | 937 -------------------- Addons/KOLPageSetupDialog.pas | 409 --------- Addons/KOLPrintCommon.pas | 30 - Addons/KOLPrintDialogs.pas | 373 -------- Addons/KOLPrinters.pas | 626 ------------- Addons/KOLProgBar.pas | 359 -------- Addons/KOLQProgBar.pas | 1543 --------------------------------- Addons/KOLRarBar.pas | 410 --------- Addons/KOLRarProgBar.pas | 377 -------- Addons/KOLRas.pas | 386 --------- Addons/KOLReport.dcr | Bin 1368 -> 0 bytes Addons/KOLReport.pas | 1276 --------------------------- Addons/KOLSocket.pas | 845 ------------------ Addons/KOLZLibBzip.pas | 4 +- Addons/ListEdit.pas | 264 ------ Addons/MCKPageSetup.pas | 104 --- Addons/MCKPrintDialogs.pas | 144 --- Addons/MCKReport.pas | 314 ------- Addons/kolTCPSocket.pas | 974 --------------------- Addons/mckCProgBar.dcr | Bin 2184 -> 0 bytes Addons/mckCProgBar.pas | 306 ------- Addons/mckHTTP.dcr | Bin 696 -> 0 bytes Addons/mckHTTP.pas | 154 ---- Addons/mckHTTPDownload.dcr | Bin 1736 -> 0 bytes Addons/mckHTTPDownload.pas | 216 ----- Addons/mckKOLTable.dcr | Bin 8600 -> 0 bytes Addons/mckKOLTable.pas | 526 ----------- Addons/mckListEdit.dcr | Bin 480 -> 0 bytes Addons/mckListEdit.pas | 226 ----- Addons/mckPageSetup.dcr | Bin 492 -> 0 bytes Addons/mckPrintDialogs.dcr | Bin 484 -> 0 bytes Addons/mckQProgBar.dcr | Bin 488 -> 0 bytes Addons/mckQProgBar.pas | 1152 ------------------------ Addons/mckRAS.dcr | Bin 468 -> 0 bytes Addons/mckRAS.pas | 94 -- Addons/mckRarInfoBar.dcr | Bin 1724 -> 0 bytes Addons/mckRarInfoBar.pas | 372 -------- Addons/mckRarProgBar.dcr | Bin 484 -> 0 bytes Addons/mckRarProgBar.pas | 368 -------- Addons/mckSocket.dcr | Bin 476 -> 0 bytes Addons/mckSocket.pas | 182 ---- Addons/mckTCPSocket.dcr | Bin 928 -> 0 bytes Addons/mckTCPSocket.pas | 289 ------ Addons/richprint.pas | 202 ----- 48 files changed, 4 insertions(+), 14833 deletions(-) delete mode 100644 Addons/KOLHTTPDownload.pas delete mode 100644 Addons/KOLHttp.pas delete mode 100644 Addons/KOLMHToolTip.pas delete mode 100644 Addons/KOLPageSetupDialog.pas delete mode 100644 Addons/KOLPrintCommon.pas delete mode 100644 Addons/KOLPrintDialogs.pas delete mode 100644 Addons/KOLPrinters.pas delete mode 100644 Addons/KOLProgBar.pas delete mode 100644 Addons/KOLQProgBar.pas delete mode 100644 Addons/KOLRarBar.pas delete mode 100644 Addons/KOLRarProgBar.pas delete mode 100644 Addons/KOLRas.pas delete mode 100644 Addons/KOLReport.dcr delete mode 100644 Addons/KOLReport.pas delete mode 100644 Addons/KOLSocket.pas delete mode 100644 Addons/ListEdit.pas delete mode 100644 Addons/MCKPageSetup.pas delete mode 100644 Addons/MCKPrintDialogs.pas delete mode 100644 Addons/MCKReport.pas delete mode 100644 Addons/kolTCPSocket.pas delete mode 100644 Addons/mckCProgBar.dcr delete mode 100644 Addons/mckCProgBar.pas delete mode 100644 Addons/mckHTTP.dcr delete mode 100644 Addons/mckHTTP.pas delete mode 100644 Addons/mckHTTPDownload.dcr delete mode 100644 Addons/mckHTTPDownload.pas delete mode 100644 Addons/mckKOLTable.dcr delete mode 100644 Addons/mckKOLTable.pas delete mode 100644 Addons/mckListEdit.dcr delete mode 100644 Addons/mckListEdit.pas delete mode 100644 Addons/mckPageSetup.dcr delete mode 100644 Addons/mckPrintDialogs.dcr delete mode 100644 Addons/mckQProgBar.dcr delete mode 100644 Addons/mckQProgBar.pas delete mode 100644 Addons/mckRAS.dcr delete mode 100644 Addons/mckRAS.pas delete mode 100644 Addons/mckRarInfoBar.dcr delete mode 100644 Addons/mckRarInfoBar.pas delete mode 100644 Addons/mckRarProgBar.dcr delete mode 100644 Addons/mckRarProgBar.pas delete mode 100644 Addons/mckSocket.dcr delete mode 100644 Addons/mckSocket.pas delete mode 100644 Addons/mckTCPSocket.dcr delete mode 100644 Addons/mckTCPSocket.pas delete mode 100644 Addons/richprint.pas diff --git a/Addons/KOLAddons2006.dpk b/Addons/KOLAddons2006.dpk index 2ecda40..0974945 100644 --- a/Addons/KOLAddons2006.dpk +++ b/Addons/KOLAddons2006.dpk @@ -1,11 +1,7 @@ package KOLAddons2006; {$R *.res} -{$R 'MCKMonthCalendar.res'} {$R 'mckCCtrls.dcr'} -{$R 'mckHTTPDownload.dcr'} -{$R 'mckQProgBar.dcr'} -{$R 'MCKMHIPEdit.dcr'} {$ALIGN 8} {$ASSERTIONS ON} {$BOOLEVAL OFF} @@ -49,36 +45,16 @@ contains KOLFontEditor in 'KOLFontEditor.pas', KOLmhxp in 'KOLmhxp.pas', MCKMHXP in 'MCKMHXP.pas', - mckTCPSocket in 'mckTCPSocket.pas', - mckListEdit in 'mckListEdit.pas', - kolTCPSocket in 'kolTCPSocket.pas', - mckCProgBar in 'mckCProgBar.pas', - mckRarInfoBar in 'mckRarInfoBar.pas', - mckRarProgBar in 'mckRarProgBar.pas', mckEcmListEdit in 'mckEcmListEdit.pas', KOLEcmListEdit in 'KOLEcmListEdit.pas', mckBlockCipher in 'mckBlockCipher.pas', KOLBlockCipher in 'KOLBlockCipher.pas', - MCKPrintDialogs in 'MCKPrintDialogs.pas', - MCKPageSetup in 'MCKPageSetup.pas', - KOLReport in 'KOLReport.pas', - MCKReport in 'MCKReport.pas', - KOLHTTPDownload in 'KOLHTTPDownload.pas', - mckHTTPDownload in 'mckHTTPDownload.pas', - KOLPageSetupDialog in 'KOLPageSetupDialog.pas', - KOLPrintCommon in 'KOLPrintCommon.pas', - KOLPrintDialogs in 'KOLPrintDialogs.pas', - KOLPrinters in 'KOLPrinters.pas', mckXPMenus in 'mckXPMenus.pas', XPMenus in 'XPMenus.pas', tinyPNG in 'tinyPNG.pas', tinyJPGGIFBMP in 'tinyJPGGIFBMP.pas', mckWebBrowser in 'mckWebBrowser.pas', mckDHTML in 'mckDHTML.pas', - KolZLibBzip in 'KolZLibBzip.pas', - KOLMHIPEdit in 'KOLMHIPEdit.pas', - MCKMHIPEdit in 'MCKMHIPEdit.pas', - MCKMonthCalendar in 'MCKMonthCalendar.pas', - KOLMonthCalendar in 'KOLMonthCalendar.pas'; + KolZLibBzip in 'KolZLibBzip.pas'; end. diff --git a/Addons/KOLCCtrls.pas b/Addons/KOLCCtrls.pas index 8d5b8c5..0a3bd14 100644 --- a/Addons/KOLCCtrls.pas +++ b/Addons/KOLCCtrls.pas @@ -403,7 +403,7 @@ type fDescription: string; fFilter: string; public - published + //published property Full: string read fFull write fFull; property Description: string read fDescription write fDescription; property Filter: string read fFilter write fFilter; diff --git a/Addons/KOLHTTPDownload.pas b/Addons/KOLHTTPDownload.pas deleted file mode 100644 index dae4a7f..0000000 --- a/Addons/KOLHTTPDownload.pas +++ /dev/null @@ -1,1138 +0,0 @@ -{$IFDEF FPC} - {$mode delphi} -{$ENDIF} -unit KOLHTTPDownload; -{ - - ("`-''-/").___..--''"`-._ - `6_ 6 ) `-. ( ).`-.__.`) - (_Y_.)' ._ ) `._ `. ``-..-' - _..`--'_..-_/ /--'_.' ,' -(il).-'' (li).' ((!.-' - - Download with HTTP-protocol - - Copyright © 2007-2008 Denis Fateyev (Danger) - Website: - E-Mail: - - 'ParseURL' and 'Posn' functions are copyright (C) 1997-2001 by Francois Piette - "Permission is granted to anyone to use this software for any purpose, including - commercial applications, and to alter it and redistribute it freely." } - - {* TKOLHTTPDownload is the non-visual component that provides a downloading resources with HTTP-protocol. Now uses WinInet routines. - |
-  |Copyright (C) 2007-2008 Denis Fateyev (Danger) (denis@fateyev.com).
-  |
- |TKOLHTTPDownload coming under the form of a KOL library unit, it can be simply used - by creating object at runtime, setting the necessary properties: - !uses Windows, Messages, KOL, ..., KOLHTTPDownload; - ! //... - !var DL : PHTTPDownload; - ! //... - !DL := NewHTTPDownload; - !DL.OnDownload:= MyDownload_Proc; - !DL.GetResource( 'http://example.com/foo/bar.zip' ); - !DL. ... - !DL.Free; - |

Certainly you can use the 'MCK mirror' provided with component to manage control properties at design time. } - -interface - -// This conditional define allows some manupulations with HTTP-headers, -// you can disable it (if you really don't need it) by commenting the following line. -{$DEFINE USE_CUSTOMHEADERS} - -//----------------------------------------------------- -uses - Windows, WinInet, KOL; - -//----------------------------------------------------- -const - iDefProxyPort = 3128; - iTimeOutValue = 200; // 0.2 sec - iDataBufSize = 4096; // 4 KByte buffer - strUserAgent = 'Dangers HTTPClient/2.1'; - strConnectType = 'Connection: close'; - strProxyConnectType = 'Proxy-Connection: close'; - -//----------------------------------------------------- - { THTTPHeader } - -type - PHTTPHeader = ^THTTPHeader; - THTTPHeader = record - {* |

Most important values that can be extracted from http-servers response - |(see ParseHeaders procedure - |below for more details).

} - HTTPVersion: KOLstring; - StatusCode: Integer; - ReasonPhrase: KOLstring; - ServerDate: KOLstring; - ServerStr: KOLstring; - LastModified: KOLstring; - Location: KOLstring; - SetCookie: KOLstring; - Expires: KOLstring; - ContentLength: Integer; - TransferEncoding: KOLstring; - ContentType: KOLstring; - end; - -//----------------------------------------------------- - { THTTPDownload } - - PHTTPDownload = ^THTTPDownload; - PDownloadWorker = ^TDownloadWorker; - TKOLHTTPDownload = PHTTPDownload; - THTTPHdrRecvEvent = procedure( Sender: PHTTPDownload; HeaderList: PStrList ) of object; - {* |Event to be called when http-headers received from http-server. } - - THTTPProgressEvent = procedure( Sender: PHTTPDownload; - BytesRecv: Integer; BytesAll: Integer ) of object; - {* |Event to be called when download progress is changed. } - - THTTPErrorEvent = procedure( Sender: PHTTPDownload; Error: Word ) of object; - {* |Event to be called when error occured while download process. } - - THTTPDownloadEvent = procedure( Sender: PHTTPDownload; Data: PStream ) of object; - {* |Event to be called when resource download completed. } - - THTTPDownload = object( TObj ) - {* |This object implements all functionality of component.
- |Use NewHTTPDownload constuction function for creation of object instance. Here is the prototype: - ! function NewHTTPDownload: PHTTPDownload; } - private - fWorker: PDownloadWorker; - fHeaderList: PStrList; - {$IFDEF USE_CUSTOMHEADERS} - fCHeaderList: PStrList; - {$ENDIF} - fDataStream: PStream; - fResource: string; - fBusy: Boolean; - fPort: Word; - fHostName: string; - fPath: string; - fUserName: string; - fPassword: string; - fProxySrv: string; - fProxyPort: Word; - fPreConfigProxy: Boolean; - - fOnError: THTTPErrorEvent; - fOnHeaderReceived: THTTPHdrRecvEvent; - fOnProgress: THTTPProgressEvent; - fOnDownload: THTTPDownloadEvent; - - public - function CheckConnection( AResourceName: string ): Boolean; - {* Simple check if a connection to host that provides specified resource can be established, - and requested resource can be retrieved. By example: - ! CheckConnection( 'http://www.example.com/foo/bar.zip' ); - Note that this function may give the wrong results if destination host doesn't accept 'ping' requests. - |Return value: True if a connection is made successfully, or False otherwise. } - - function GetResource( AResourceName: string ): Boolean; - {* |Initiate download process for the specified resource.
- |The parameter AResourceName must contains full path of the requested resource - in such syntax: - ! protocol://[user[:password]@]server[:port]/path - |If parameter port not specified, then standard http-port (80) will be used in request. - Authorization parameters can be omitted too, if isn't needed. - In simple case can be used, by example: - ! GetResource( 'http://www.example.com/foo/bar.zip' ); - |Return value: the function returns False if resource request has invalid syntax, - |otherwise True returned. } - - procedure SetProxySettings( AProxyServer: string; iProxyPort: Integer = iDefProxyPort ); - {* |Proxy settings for the resource request.
- |iProxyPort parameter can be omitted then standard proxy port (3128) will be used. } - - procedure SetAuthInfo( AUserName: string; APassword: string ); - {* Authorization parameters for the resource request. } - - function ParseHeaders( var Header: PHTTPHeader ): Boolean; - {* Extract http-headers information and put into the specified HTTPHeader. By example: - !var - ! DL: PHTTPDownload; - ! Header: PHTTPHeader; - !// ... - !procedure TForm1.DLHeaderReceived( Sender: PHTTPDownload; HeaderList: PStrList ); - !begin - ! New( Header ); - ! DL.ParseHeaders( Header ); - ! // ... do something with Header ... - ! MsgOk( Header.ReasonPhrase ); - ! // ... - ! Dispose( Header ); - !end; - |Return value: False if http-headers doesn't exists (nothing to analyze). } - - {$IFDEF USE_CUSTOMHEADERS} - procedure AddCustomHeader( AHeader: string ); - {* |Add custom line to requests http-header. By example: - !var - ! DL: PHTTPDownload; - !// ... - !procedure TForm1.Button1Click( Sender: PObj ); - !begin - ! DL.AddCustomHeader( 'Cookie: PHPSESSID=abcdef' ); - ! DL.GetResource( 'http://www.example.com/foo/bar.zip' ); - !end; - Once assigned these headers will be added automatically to each request sent to http-server - (while the current THTTPDownload object is in use). Custom headers are not assigned by default. - |To clear user defined http-headers list, call ClearCustomHeaders procedure. - |Note that 'Connection: close' or 'Proxy-Connection: close' (depends on connection type) - |will be included in the request headers anyway.
- |You must add USE_CUSTOMHEADERS conditional symbol into the project options list. } - - procedure SetCustomHeaders( AHeaderList: PStrList ); - {* |Assign the custom http-headers list from another one. By example: - !var - ! DL: PHTTPDownload; - ! CList: PStrList; - !// ... - !procedure TForm1.Button1Click( Sender: PObj ); - !begin - ! CList:= NewStrList; - ! CList.Add( 'Cookie: PHPSESSID=abcdef' ); - ! DL.SetCustomHeaders( CList ); - ! DL.GetResource( 'http://www.example.com/foo/bar.zip' ); - ! CList.Free; - !end; - |You must add USE_CUSTOMHEADERS conditional symbol into the project options list. } - - procedure ClearCustomHeaders; - {* |Clear user defined http-headers list (restore to defaults). - |You must add USE_CUSTOMHEADERS conditional symbol into the project options list. } - {$ENDIF} - - procedure CancelDownload; - {* |Drop current download process immediately. } - - property Resource: string read fResource; - {* |Currently requested resource. By default: None. } - - property ProxyServer: string read fProxySrv write fProxySrv; - {* |IP-address or hostname of http-proxy server. By default: None. } - - property ProxyPort: Word read fProxyPort write fProxyPort; - {* |TCP Port of http-proxy server. By default: 3128. } - - property UserName: string read fUserName write fUserName; - {* |HTTP Autorization parameters: username. By default: None. } - - property Password: string read fPassword write fPassword; - {* |HTTP Autorization parameters: password. By default: None. } - - property UsePreconfigProxy: Boolean read fPreConfigProxy write fPreConfigProxy; - {*|Parameter that allows to use connection settings stored in Internet Explorer. - Retrieves the proxy or direct configuration from the Windows registry. - |By default: False. } - - property HeaderList: PStrList read fHeaderList; - {*|Retrieves all received http-headers in raw format (as is). - Most important parameters can be retrieved with ParseHeaders procedure. } - - {$IFDEF USE_CUSTOMHEADERS} - property CustomHeaderList: PStrList read fCHeaderList; - {*|Retrieves custom http-header list assigned by user. - See SetCustomHeaders procedure for more details. } - {$ENDIF} - - property ReceivedData: PStream read fDataStream; - {*|Retrieves downloaded resource if present. } - - property Busy: Boolean read fBusy; - {*| If True, the object is busy and resource download is in progress at the moment. - If you wish, you can terminate download process at any moment with CancelDownload procedure. } - - property OnError: THTTPErrorEvent read fOnError write fOnError; - {* |Event to be called when error occured while download process. } - - property OnHeaderReceived: THTTPHdrRecvEvent read fOnHeaderReceived write fOnHeaderReceived; - {* |Event to be called when http-headers received from http-server. } - - property OnProgress: THTTPProgressEvent read fOnProgress write fOnProgress; - {* |Event to be called when download progress is changed. - Note that there's no way to automatically determine the whole size of requested resource - |if 'Content-Length' field is missing in the http-header (i.e. if Transfer-Encoding - |header field (rfc-2068 section 14.40) is present and indicates that the "chunked" transfer - |coding has been applied). Therefore, if 'Content-Length' is present, BytesAll - |parameter indicates the requested resource size, otherwise it's equal to '-1'. } - - property OnDownload: THTTPDownloadEvent read fOnDownload write fOnDownload; - {* |Event to be called when resource download completed. } - - destructor Destroy; virtual; - end; - -//----------------------------------------------------- - { TDownloadWorker } - - TDownloadWorker = object (TObj ) - private - // Contains parent object's pointer (or NIL if download terminated) - fOwner: PHTTPDownload; - fWThread: PThread; - fDLThread: PThread; - fCritSection: TRTLCriticalSection; - fDataBuf: PChar; - fPort: Word; - fHostName: string; - fPath: string; - fUserName: string; - fPassword: string; - fProxySrv: string; - fProxyPort: Word; - fPreConfigProxy: Boolean; - iContentLen: Integer; - iReadCount: Integer; - - function On_DownloadExecute( Sender: PThread ): Integer; - function On_WatchExecute( Sender: PThread ): Integer; - procedure On_UpdateProgress; - - public - procedure StartDownload; - function StopDownload: Integer; - destructor Destroy; virtual; - end; - -//----------------------------------------------------- -function NewHTTPDownload: PHTTPDownload; -function NewDownloadWorker( AOwner: PHTTPDownload ): PDownloadWorker; -//----------------------------------------------------- - -implementation - -//----------------------------------------------------- -function NewHTTPDownload: PHTTPDownload; -begin - New( Result, Create ); - with ( Result^ ) do - begin - fBusy:= false; - fPreConfigProxy:= false; - fProxyPort:= iDefProxyPort; - end; -end; - -//----------------------------------------------------- -function NewDownloadWorker( AOwner: PHTTPDownload ): PDownloadWorker; -begin - New( Result, Create ); - with ( Result^ ) do - begin - fOwner:= AOwner; - InitializeCriticalSection( fCritSection ); - end; -end; - -//----------------------------------------------------- -function StrPas(const Str: PChar): string; -begin - Result:= Str; -end; - -//----------------------------------------------------- -{ Find the count'th occurence of the s string in the t string. } -{ If count < 0 then look from the back } -function Posn(const s , t : String; Count : Integer) : Integer; -var - i, h, Last : Integer; - u : String; -begin - u := t; - if Count > 0 then - begin - Result := Length(t); - for i := 1 to Count do - begin - h := Pos(s, u); - if h > 0 then - u := Copy(u, h + 1, Length(u)) - else - begin - u := ''; - Inc(Result); - end; - end; - Result := Result - Length(u); - end - else if Count < 0 then - begin - Last := 0; - for i := Length(t) downto 1 do - begin - u := Copy(t, i, Length(t)); - h := Pos(s, u); - if (h <> 0) and ((h + i) <> Last) then - begin - Last := h + i - 1; - Inc(count); - if Count = 0 then - break; - end; - end; - if Count = 0 then - Result := Last - else - Result := 0; - end - else - Result := 0; -end; - -//----------------------------------------------------- -{ Syntax of an URL: protocol://[user[:password]@]server[:port]/path } -procedure ParseURL(const url : String; var Proto, User, Pass, Host, Port, Path : String); -var - p, q : Integer; - s : String; - CurPath : String; -begin - CurPath := Path; - proto := ''; - User := ''; - Pass := ''; - Host := ''; - Port := ''; - Path := ''; - - if Length(url) < 1 then Exit; - - { Handle path beginning with "./" or "../". } - { This code handle only simple cases ! } - { Handle path relative to current document directory } - if (Copy(url, 1, 2) = './') then - begin - p := Posn('/', CurPath, -1); - if p > Length(CurPath) then - p := 0; - if p = 0 then - CurPath := '/' - else - CurPath := Copy(CurPath, 1, p); - Path := CurPath + Copy(url, 3, Length(url)); - Exit; - end - { Handle path relative to current document parent directory } - else if (Copy(url, 1, 3) = '../') then - begin - p := Posn('/', CurPath, -1); - if p > Length(CurPath) then - p := 0; - if p = 0 then - CurPath := '/' - else - CurPath := Copy(CurPath, 1, p); - - s := Copy(url, 4, Length(url)); - { We could have several levels } - while TRUE do - begin - CurPath := Copy(CurPath, 1, p-1); - p := Posn('/', CurPath, -1); - if p > Length(CurPath) then - p := 0; - if p = 0 then - CurPath := '/' - else - CurPath := Copy(CurPath, 1, p); - if (Copy(s, 1, 3) <> '../') then - break; - s := Copy(s, 4, Length(s)); - end; - - Path := CurPath + Copy(s, 1, Length(s)); - Exit; - end; - - p := pos('://',url); - if p = 0 then - begin - if (url[1] = '/') then - begin - { Relative path without protocol specified } - proto := 'http'; - p := 1; - if (Length(url) > 1) and (url[2] <> '/') then - begin - { Relative path } - Path := Copy(url, 1, Length(url)); - Exit; - end; - end - else if lowercase(Copy(url, 1, 5)) = 'http:' then - begin - proto := 'http'; - p := 6; - if (Length(url) > 6) and (url[7] <> '/') then - begin - { Relative path } - Path := Copy(url, 6, Length(url)); - Exit; - end; - end - else if lowercase(Copy(url, 1, 7)) = 'mailto:' then - begin - proto := 'mailto'; - p := pos(':', url); - end; - end - else - begin - proto := Copy(url, 1, p - 1); - inc(p, 2); - end; - s := Copy(url, p + 1, Length(url)); - - p := pos('/', s); - q := pos('?', s); - if (q > 0) and ((q < p) or (p = 0)) then - p := q; - if p = 0 then - p := Length(s) + 1; - Path := Copy(s, p, Length(s)); - s := Copy(s, 1, p-1); - - p := Posn(':', s, -1); - if p > Length(s) then - p := 0; - q := Posn('@', s, -1); - if q > Length(s) then - q := 0; - if (p = 0) and (q = 0) then - begin { no user, password or port } - Host := s; - Exit; - end - else if q < p then - begin { a port given } - Port := Copy(s, p + 1, Length(s)); - Host := Copy(s, q + 1, p - q - 1); - if q = 0 then - Exit; { no user, password } - s := Copy(s, 1, q - 1); - end - else - begin - Host := Copy(s, q + 1, Length(s)); - s := Copy(s, 1, q - 1); - end; - p := pos(':', s); - if p = 0 then - User := s - else - begin - User := Copy(s, 1, p - 1); - Pass := Copy(s, p + 1, Length(s)); - end; -end; - -//---------------- { THTTPDownload } ------------------------------- - -function THTTPDownload.ParseHeaders( var Header: PHTTPHeader ): Boolean; -var - i: Integer; S: KOLstring; -begin - Result:= false; - - if ( not Assigned( fHeaderList ) ) then Exit; - // HTTP/1.1 200 OK - Header.ReasonPhrase:= fHeaderList.Items[0]; - Header.HTTPVersion:= Parse( Header.ReasonPhrase, ' ' ); - Header.StatusCode:= Str2Int( Parse(Header.ReasonPhrase, ' ') ); - // avoid curious things if value isn't present in the list - Header.ContentLength:= -1; - // begin from second list item - for i:= 2 to fHeaderList.Count do - begin - S:= fHeaderList.Items[i-1]; - // Date: Wed, 09 May 2007 14:31:23 GMT - if ( Pos('Date: ', S) > 0 ) then - begin - Parse(S, ' '); Header.ServerDate:= S; - Continue; - end; - // Server: Apache x.x.x (Unix) - if ( Pos('Server: ', S) > 0 ) then - begin - Parse(S, ' '); Header.ServerStr:= S; - Continue; - end; - // Last-Modified: Wed, 09 May 2007 14:31:23 GMT - if ( Pos('Last-Modified: ', S) > 0 ) then - begin - Parse(S, ' '); Header.LastModified:= S; - Continue; - end; - // Set-Cookie: PHPSESSID=xxxxxxxxx - if ( Pos('Set-Cookie: ', S) > 0 ) then - begin - Parse(S, ' '); Header.SetCookie:= S; - Continue; - end; - // Expires: Wed, 10 May 2007 14:31:23 GMT - if ( Pos('Expires: ', S) > 0 ) then - begin - Parse(S, ' '); Header.Expires:= S; - Continue; - end; - // Location: foobar.html - if ( Pos('Location: ', S) > 0 ) then - begin - Parse(S, ' '); Header.Location:= S; - Continue; - end; - // Content-Length: 12345 - if ( Pos('Content-Length: ', S) > 0 ) then - begin - Parse(S, ' '); Header.ContentLength:= Str2Int( S ); - Continue; - end; - // Transfer-Encoding: chunked - if ( Pos('Transfer-Encoding: ', S) > 0 ) then - begin - Parse(S, ' '); Header.TransferEncoding:= S; - Continue; - end; - // Content-Type: application/zip - if ( Pos('Content-Type: ', S) > 0 ) then - begin - Parse(S, ' '); Header.ContentType:= S; - Continue; - end; - end; - - Result:= true; -end; - -//----------------------------------------------------- -procedure THTTPDownload.SetProxySettings( AProxyServer: string; iProxyPort: Integer = iDefProxyPort ); -begin - fProxySrv:= AProxyServer; - fProxyPort:= iProxyPort; -end; - -//----------------------------------------------------- -procedure THTTPDownload.SetAuthInfo( AUserName: string; APassword: string ); -begin - fUserName:= AUserName; - fPassword:= APassword; -end; - -//----------------------------------------------------- -{$IFDEF USE_CUSTOMHEADERS} -procedure THTTPDownload.AddCustomHeader( AHeader: string ); -begin - if ( Length( AHeader ) > 0 ) then - begin - if ( not Assigned( fCHeaderList ) ) then - begin - fCHeaderList:= NewStrList; - fCHeaderList.Add2AutoFree( @Self ); - end; // 'if ( not Assigned( fCHeaderList )' - fCHeaderList.Add( AHeader ); - end; -end; - -//----------------------------------------------------- -procedure THTTPDownload.ClearCustomHeaders; -begin - if Assigned( fCHeaderList ) then fCHeaderList.Clear; -end; - -//----------------------------------------------------- -procedure THTTPDownload.SetCustomHeaders( AHeaderList: PStrList ); -begin - if Assigned( AHeaderList ) then - begin - if ( not Assigned( fCHeaderList ) ) then - begin - fCHeaderList:= NewStrList; - fCHeaderList.Add2AutoFree( @Self ); - end; // 'if ( not Assigned( fCHeaderList )' - fCHeaderList.Assign( AHeaderList ); - end; -end; -{$ENDIF} - -//----------------------------------------------------- -function THTTPDownload.CheckConnection( AResourceName: string ): Boolean; -begin - Result:= false; - - // I'm wondering why FLAG_ICC_FORCE_CONNECTION declaration is missing in WinInet.pas - if ( InternetCheckConnection( PChar( AResourceName ), $00000001 {FLAG_ICC_FORCE_CONNECTION}, 0 ) ) then - Result:= true - else - if Assigned( fOnError ) then fOnError( @Self, GetLastError ); -end; - -//----------------------------------------------------- -function THTTPDownload.GetResource( AResourceName: string ): Boolean; -var - strPort, strProto: string; -begin - Result:= false; - CancelDownload; - - if ( not fBusy ) then - begin - fResource:= AResourceName; - // checking request data - ParseURL( fResource, strProto, fUserName, fPassword, fHostName, strPort, fPath ); - if ( strProto = '' ) then strProto:= 'http'; - if ( ( fHostName = '' ) or ( fPath = '' ) or ( strProto <> 'http' ) ) then - begin - if Assigned( fOnError ) then fOnError( @Self, ERROR_INTERNET_INVALID_URL ); - Exit; - end; - if ( strPort = '' ) then fPort:= INTERNET_DEFAULT_HTTP_PORT - else fPort:= Str2Int( strPort ); - - if Assigned( fOnHeaderReceived ) then - if ( not Assigned( fHeaderList ) ) then - begin - fHeaderList:= NewStrList; - fHeaderList.Add2AutoFree( @Self ); - end; - - if Assigned( fOnDownload ) then - begin - if ( not Assigned( fDataStream ) ) then - begin - fDataStream:= NewMemoryStream; - fDataStream.Add2AutoFree( @Self ); - end - else fDataStream.Size:= 0; - end; - - fBusy:= true; - fWorker:= NewDownloadWorker( @Self ); - fWorker.StartDownload; - Result:= true; - end; - -end; - -//----------------------------------------------------- -procedure THTTPDownload.CancelDownload; -begin - if ( fBusy ) then - fWorker.StopDownload; -end; - -//----------------------------------------------------- -destructor THTTPDownload.Destroy; -begin - CancelDownload; - fResource:= ''; - fHostName:= ''; - fPath:= ''; - fProxySrv:= ''; - fUserName:= ''; - fPassword:= ''; - inherited; -end; - -//---------------- { TDownloadWorker } ------------------------------- - -procedure TDownloadWorker.StartDownload; -begin - fWThread:= NewThread; - fWThread.OnExecute:= On_WatchExecute; - fWThread.Add2AutoFree( @Self ); - fWThread.Resume; -end; - -//----------------------------------------------------- -function TDownloadWorker.On_WatchExecute( Sender: PThread ): Integer; -begin - Result:= 0; // stub - - // create download working thread - fDLThread:= NewThreadEx( On_DownloadExecute ); - // wait for download thread finished (any way) - fDLThread.WaitFor; - // destroy worker object - Free; -end; - -//----------------------------------------------------- -function TDownloadWorker.StopDownload: Integer; -var - lpOwner: PHTTPDownload; -begin - Result:= 0; // stub - - lpOwner:= nil; // avoid compiler warning - EnterCriticalSection( fCritSection ); - try - if Assigned( fOwner ) then - begin - lpOwner:= PHTTPDownload( fOwner ); - fOwner:= nil; - end; - finally - LeaveCriticalSection( fCritSection ); - end; - - // trying to terminate thread gracefully - if ( not fDLThread.Terminated ) then fDLThread.WaitForTime( iTimeOutValue ); - // terminate thread forcefully - if ( not fDLThread.Terminated ) then fDLThread.Terminate; - - if Assigned( lpOwner ) then - begin - // don't keep partially downloaded file - if Assigned( lpOwner.fDataStream ) then - lpOwner.fDataStream.Size:= 0; - lpOwner.fBusy:= false; - end; - -end; - -//----------------------------------------------------- -procedure TDownloadWorker.On_UpdateProgress; -begin - if Assigned( fOwner ) then - fOwner.OnProgress( fOwner, iReadCount, iContentLen ); -end; - -//----------------------------------------------------- -function TDownloadWorker.On_DownloadExecute( Sender: PThread ): Integer; -var - hSession, hConnect, hRequest: HINTERNET; - iBufSize, lpdwIndex, iNumRead: Cardinal; - Buf: PChar; i, iErrorCode: Integer; - - procedure CloseHandles; - begin - InternetCloseHandle( hRequest ); - InternetCloseHandle( hConnect ); - InternetCloseHandle( hSession ); - end; - -begin - Result:= 0; // stub - - EnterCriticalSection( fCritSection ); - try - if Assigned( fOwner ) then - begin - fHostName:= fOwner.fHostName; - fPath:= fOwner.fPath; - fPort:= fOwner.fPort; - fUserName:= fOwner.fUserName; - fPassword:= fOwner.fPassword; - fPreConfigProxy:= fOwner.fPreConfigProxy; - if ( not fPreConfigProxy ) then - begin - fProxySrv:= fOwner.fProxySrv; - fProxyPort:= fOwner.fProxyPort; - end; - end // 'if Assigned( fOwner ) then' - else Exit; - finally - LeaveCriticalSection( fCritSection ); - end; - - // initializing Wininet, settings some connection parameters - if ( fPreConfigProxy ) then - hSession:= InternetOpen( strUserAgent, INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0 ) - else - begin - if ( fProxySrv <> '' ) then - hSession:= InternetOpen( strUserAgent, INTERNET_OPEN_TYPE_PROXY, - PChar( 'http=' + fProxySrv + ':' + Int2Str( fProxyPort) ), nil, 0 ) - else - hSession:= InternetOpen( strUserAgent, INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0 ); - end; - if ( hSession = nil ) then - begin - with ( fOwner^ ) do - if Assigned( fOnError ) then fOnError( fOwner, GetLastError ); - Exit; - end; - - // checking if thread must be terminated - EnterCriticalSection( fCritSection ); - try - if ( not Assigned( fOwner ) ) then Exit; - finally - LeaveCriticalSection( fCritSection ); - end; - - // connecting to http-server - hConnect:= InternetConnect( hSession, PChar( fHostName ), fPort, - PChar( fUserName ), PChar( fPassword ), INTERNET_SERVICE_HTTP, 0, 0 ); - if ( hConnect = nil ) then - begin - with ( fOwner^ ) do - if Assigned( fOnError ) then fOnError( fOwner, GetLastError ); - CloseHandles; - Exit; - end; - - // checking if thread must be terminated - EnterCriticalSection( fCritSection ); - try - if ( not Assigned( fOwner ) ) then - begin - CloseHandles; - Exit; - end; - finally - LeaveCriticalSection( fCritSection ); - end; - - // prepare resource request to http-server - // we're prefer HTTP/1.0 version but this parameter can be ignored by Wininet - // see KB258425 (http://support.microsoft.com/kb/258425) for more details. - hRequest:= HttpOpenRequest( hConnect, nil, PChar( fPath ), nil, - nil, nil, INTERNET_FLAG_NO_UI + INTERNET_FLAG_PRAGMA_NOCACHE, 0); - if ( hRequest = nil ) then - begin - with ( fOwner^ ) do - if Assigned( fOnError ) then fOnError( fOwner, GetLastError ); - CloseHandles; - Exit; - end; - // adding custom http headers to request - {$IFDEF USE_CUSTOMHEADERS} - with ( fOwner^ ) do - if Assigned( fCHeaderList ) then - with ( fCHeaderList^ ) do - if ( Count > 0 ) then - for i:= 1 to Count do - HttpAddRequestHeaders( hRequest, PChar( Items[i-1] ), Length( Items[i-1] ), HTTP_ADDREQ_FLAG_ADD ); - {$ENDIF} - // setting http headers 'connection type' field (don't allow persistent connection) - if ( fPreConfigProxy or ( fProxySrv <> '' ) ) then - HttpAddRequestHeaders( hRequest, strProxyConnectType, Length( strProxyConnectType ), HTTP_ADDREQ_FLAG_ADD ) - else - HttpAddRequestHeaders( hRequest, strConnectType, Length( strConnectType ), HTTP_ADDREQ_FLAG_ADD ); - - // checking if thread must be terminated - EnterCriticalSection( fCritSection ); - try - if ( not Assigned( fOwner ) ) then - begin - CloseHandles; - Exit; - end; - finally - LeaveCriticalSection( fCritSection ); - end; - - // send http request to server - if ( not HttpSendRequest( hRequest, nil, 0, nil, 0 ) ) then - begin - with ( fOwner^ ) do - if Assigned( fOnError ) then fOnError( fOwner, GetLastError ); - CloseHandles; - Exit; - end; - - // checking if thread must be terminated - EnterCriticalSection( fCritSection ); - try - if ( not Assigned( fOwner ) ) then - begin - CloseHandles; - Exit; - end; - finally - LeaveCriticalSection( fCritSection ); - end; - - // receiving headers (if event assigned) - if Assigned( fOwner.fOnHeaderReceived ) then - begin - lpdwIndex:= 0; Buf:= nil; - HttpQueryInfo( hRequest, HTTP_QUERY_RAW_HEADERS_CRLF, Buf, iBufSize, lpdwIndex ); - // NB: it's ok when 'unsufficient buffer' message received now - iErrorCode:= GetLastError; - - if ( iErrorCode = ERROR_INSUFFICIENT_BUFFER ) then - begin - GetMem( Buf, iBufSize ); - lpdwIndex:= 0; - try - if ( HttpQueryInfo( hRequest, HTTP_QUERY_RAW_HEADERS_CRLF, Buf, iBufSize, lpdwIndex ) ) then - with ( fOwner^ ) do - begin - fHeaderList.SetText( Buf, false ); - with ( fHeaderList^ ) do - if ( Items[Count-1] = '' ) then Delete( Count-1 ); - fOnHeaderReceived( fOwner, fHeaderList ); - end // 'if ( HttpQueryInfo( hRequest, HTTP_QUERY_RAW_HEADERS_CRLF, Buf, iBufSize, iReserved ) )' - else - with ( fOwner^ ) do - if Assigned( fOnError ) then fOnError( fOwner, GetLastError ); - - finally - FreeMem( Buf ); - end; - end // 'if ( iErrorCode = ERROR_INSUFFICIENT_BUFFER )' - else - with ( fOwner^ ) do - if Assigned( fOnError ) then fOnError( fOwner, iErrorCode ); - - // checking if thread must be terminated - EnterCriticalSection( fCritSection ); - try - if ( not Assigned( fOwner ) ) then - begin - CloseHandles; - Exit; - end; - finally - LeaveCriticalSection( fCritSection ); - end; - - end; // 'if Assigned( fOnHeaderReceived )' - - // checking if thread must be terminated - EnterCriticalSection( fCritSection ); - try - if ( not Assigned( fOwner ) ) then - begin - CloseHandles; - Exit; - end; - finally - LeaveCriticalSection( fCritSection ); - end; - - // getting http status code - iBufSize:= 16; - iErrorCode:= 0; - lpdwIndex:= 0; - GetMem( Buf, iBufSize ); - try - if ( HttpQueryInfo( hRequest, HTTP_QUERY_STATUS_CODE, Buf, iBufSize, lpdwIndex ) ) then - iErrorCode:= Str2Int( StrPas( Buf ) ) - else - with ( fOwner^ ) do - if Assigned( fOnError ) then fOnError( fOwner, GetLastError ); - finally - FreeMem( Buf ); - end; - - // checking if thread must be terminated - EnterCriticalSection( fCritSection ); - try - if ( not Assigned( fOwner ) ) then - begin - CloseHandles; - Exit; - end; - finally - LeaveCriticalSection( fCritSection ); - end; - - // checking if resource is available - if ( ( Assigned( fOwner.fOnDownload ) and ( iErrorCode = HTTP_STATUS_OK {HTTP/1.1 200 OK} ) ) ) then - begin - iBufSize:= 16; - lpdwIndex:= 0; - iContentLen:= 0; - GetMem( Buf, iBufSize ); - try - if ( HttpQueryInfo( hRequest, HTTP_QUERY_CONTENT_LENGTH, Buf, iBufSize, lpdwIndex ) ) then - // getting http content length - iContentLen:= Str2Int( StrPas( Buf ) ); - // set iContentLen value to '-1' if not present or invalid - if ( iContentLen <= 0 ) then iContentLen:= -1; - - iReadCount:= 0; - GetMem( fDataBuf, iDataBufSize ); - try - // downloading resource - with ( fOwner^ ) do - while ( InternetReadFile( hRequest, fDataBuf, iDataBufSize, iNumRead ) ) do - if ( iNumRead > 0 ) then - begin - // checking if thread must be terminated - EnterCriticalSection( fCritSection ); - try - if ( not Assigned( fOwner ) ) then Break; - finally - LeaveCriticalSection( fCritSection ); - end; - - // write received data to stream - fDataStream.Write( fDataBuf^, iNumRead ); - Inc( iReadCount, iNumRead ); - // update download progress - if Assigned( fOnProgress ) then fDLThread.Synchronize( On_UpdateProgress ); - end - // 'if ( iNumRead > 0 )' - else Break; - - // checking if thread must be terminated - EnterCriticalSection( fCritSection ); - try - if ( not Assigned( fOwner ) ) then - begin - CloseHandles; - Exit; - end; - finally - LeaveCriticalSection( fCritSection ); - end; - - // download complete - with ( fOwner^ ) do - begin - fDataStream.Position:= 0; - // call assigned event handler - fOnDownload( @Self, fDataStream ); - end; - - finally - FreeMem( fDataBuf ); - end; - - finally - FreeMem( Buf ); - end; - - end // 'if ( ( Assigned( fOnDownload ) and ( iErrorCode = HTTP_STATUS_OK {HTTP/1.1 200 OK} ) ) )' - else - if ( iErrorCode <> HTTP_STATUS_OK { HTTP/1.1 OK } ) then - with ( fOwner^ ) do - if Assigned( fOnError ) then fOnError( fOwner, ERROR_INTERNET_EXTENDED_ERROR ); - - CloseHandles; -end; - -//----------------------------------------------------- -destructor TDownloadWorker.Destroy; -begin - fDLThread.Free; - fHostName:= ''; - fPath:= ''; - fUserName:= ''; - fPassword:= ''; - fProxySrv:= ''; - EnterCriticalSection( fCritSection ); - try - if Assigned( fOwner ) then - fOwner.fBusy:= false; - finally - LeaveCriticalSection( fCritSection ); - end; - DeleteCriticalSection( fCritSection ); - inherited; -end; - -//----------------------------------------------------- - - -end. diff --git a/Addons/KOLHttp.pas b/Addons/KOLHttp.pas deleted file mode 100644 index f3e73c4..0000000 --- a/Addons/KOLHttp.pas +++ /dev/null @@ -1,209 +0,0 @@ -unit KOLHttp; - -interface - -uses - Windows, KOL, KOLSocket; - -type - - TKOLhttp =^TKOLhttpControl; - PKOLhttpControl =^TKOLhttpControl; - TKOLhttpControl = object(TObj) - private - fAdr: string; - fUrl: string; - fRef: string; - fUsr: string; - fPas: string; - fMth: string; - fPAd: string; - fPPr: integer; - fCod: integer; - Body: boolean; - fHdr: PStrList; - fCnt: PStrList; - fSoc: PAsyncSocket; - fPort: integer; - fOnClos: TOnEvent; - procedure OnDumm(Sender: TWMSocket); - procedure OnConn(Sender: TWMSocket); - procedure OnRead(Sender: TWMSocket); - procedure OnClos(Sender: TWMSocket); - procedure Prepare; - protected - procedure ParseUrl; - public - procedure Get; overload; - procedure Get(_Url: string); overload; - property Url: string read fUrl write fUrl; - property HostPort: integer read fPort write fPort; - property HostAddr: string read fAdr write fAdr; - property UserName: string read fUsr write fUsr; - property Password: string read fPas write fPas; - property Responce: integer read fCod write fCod; - property Header: PStrList read fHdr; - property Content: PStrList read fCnt; - property ProxyAddr: string read fPAd write fPAd; - property ProxyPort: integer read fPPr write fPPr; - property OnClose: TOnEvent read fOnClos write fOnClos; - end; - - function NewKOLhttpControl: PKOLhttpControl; - -implementation - -uses UStr, UWrd; - -const - bin2b64:string='ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'; - -function NewKOLhttpControl: PKOLhttpControl; -begin - New(Result, create); - Result.fPort := 80; - Result.fAdr := ''; - Result.fUsr := ''; - Result.fPas := ''; - Result.fMth := 'GET'; - Result.fHdr := NewStrList; - Result.fCnt := NewStrList; -end; - -function encode_line(const buf: string):string; -var - offset: shortint; - pos1,pos2: byte; - i: byte; - out: string; -begin - setlength(out, length(buf) * 4 div 3 + 4); - fillchar(out[1], length(buf) * 4 div 3 + 2, #0); - offset:=2; - pos1:=0; - pos2:=1; - out[pos2]:=#0; -while pos1 < length(buf) do begin - if offset > 0 then begin - out[pos2]:=char(ord(out[pos2]) or ((ord(buf[pos1 + 1]) and ($3f shl offset)) shr offset)); - offset:=offset-6; - inc(pos2); - out[pos2]:=#0; - end - else if offset < 0 then begin - offset:=abs(offset); - out[pos2]:=char(ord(out[pos2]) or ((ord(buf[pos1 + 1]) and ($3f shr offset)) shl offset)); - offset:=8-offset; - inc(pos1); - end - else begin - out[pos2]:=char(ord(out[pos2]) or ((ord(buf[pos1 + 1]) and $3f))); - inc(pos2); - inc(pos1); - out[pos2]:=#0; - offset:=2; - end; - end; - if offset=2 then dec(pos2); - for i:=1 to pos2 do - out[i]:=bin2b64[ord(out[i])+1]; - while (pos2 and 3)<>0 do begin - inc(pos2); - out[pos2] := '='; - end; - encode_line := copy(out, 1, pos2); -end; - -procedure TKOLhttpControl.OnDumm; -begin -end; - -procedure TKOLhttpControl.OnConn; -begin - fHdr.Clear; - fCnt.Clear; - fSoc.SendString(fMth + ' ' + fRef + ' HTTP/1.1'#13#10); - fSoc.SendString('User-Agent: KOL-HTTP'#13#10); - fSoc.SendString('Host: ' + fAdr + #13#10); - if fUsr <> '' then begin - fSoc.SendString('Authorization: Basic ' + encode_line(fUsr + ':' + fPas) + #13#10); - end; - fSoc.SendString(#13#10); -end; - -procedure TKOLhttpControl.OnRead; -var s: string; -begin - while fSoc.Count > 0 do begin - s := Wordn(fSoc.ReadLine(#10), #13, 1); - if pos('<', s) = 1 then Body := True; - if Body then fCnt.Add(s) - else fHdr.Add(s); - if pos('HTTP/1.', s) = 1 then fCod := str2int(wordn(s, ' ', 2)); - end; - if Assigned(fOnClos) then fOnClos(@self); -end; - -procedure TKOLhttpControl.OnClos; -begin - if Assigned(fOnClos) then fOnClos(@self); -end; - -procedure TKOLhttpControl.ParseUrl; -var s, - r: string; -begin - s := Url; - if pos('HTTP://', UpSt(s)) = 1 then begin - s := copy(s, 8, length(s) - 7); - end; - r := wordn(s, '@', 1); - if r <> s then begin - fUsr := wordn(r, ':', 1); - fPas := wordn(r, ':', 2); - s := wordn(s, '@', 2); - end; - r := wordn(s, ':', 2); - if r <> '' then begin - fPort := str2int(r); - s := wordn(s, ':', 1); - end; - r := wordn(s, '/', 1); - fAdr := r; - if fAdr = '' then fAdr := s; - fRef := copy(s, length(fAdr) + 1, length(s) - length(fAdr)); - if fRef = '' then fRef := '/'; -end; - -procedure TKOLhttpControl.Prepare; -begin - Body := False; - fSoc := NewAsyncSocket; - ParseUrl; - fSoc.PortNumber := fPort; - fSoc.IPAddress := fAdr; - if fPAd <> '' then begin - fSoc.IPAddress := fPAd; - fSoc.PortNumber := fPPr; - fRef := 'http://' + fAdr + fRef; - end; - fSoc.OnConnect := OnConn; - fSoc.OnRead := OnRead; - fSoc.OnError := OnDumm; - fSoc.OnClose := OnClos; -end; - -procedure TKOLhttpControl.Get; -begin - Prepare; - fMth := 'GET'; - fSoc.DoConnect; -end; - -procedure TKOLhttpControl.Get(_Url: string); -begin - Url := _Url; - Get; -end; - -end. diff --git a/Addons/KOLMHToolTip.pas b/Addons/KOLMHToolTip.pas deleted file mode 100644 index 87620dd..0000000 --- a/Addons/KOLMHToolTip.pas +++ /dev/null @@ -1,937 +0,0 @@ -//{$DEFINE DEBUG} -{$IFDEF DEBUG} -{$DEFINE interface} -{$DEFINE implementation} -{$DEFINE initialization} -{$DEFINE finalization} -{$ENDIF} - -{$IFDEF Frame} -unit KOLMHToolTip; - - -// 8-jan-2003 - -// MHDateTimePicker Компонент (MHDateTimePicker Component) -// Автор (Author): Жаров Дмитрий (Zharov Dmitry) aka Гэндальф (Gandalf) -// Дата создания (Create date): 1-авг(aug)-2002 -// Дата коррекции (Last correction Date): 13-сен(sep)-2002 -// Версия (Version): 0.91 -// EMail: Gandalf@kol.mastak.ru -// Благодарности (Thanks): -// Alexander Pravdin -// Новое в (New in): -// V0.91 -// [+] Поддержка D6 (D6 Support) [KOLnMCK] -// -// V0.9 -// [+++] Очень много (Very much) [KOLnMCK] -// [N] KOLnMCK>=1.42 -// -// Список дел (To-Do list): -// 1. Ассемблер (Asm) -// 2. Оптимизировать (Optimize) -// 3. Изменение стилей (Styles) -// 4. Отрисовка (Draw) -// 5. Подчистить (Clear Stuff) -// 6. События (Events) -// 7. Все API (All API's) - -interface - -uses Windows, KOL, Messages; - -type -{$ENDIF Frame} -{$IFDEF interface_part} - - TFE = (eTextColor, eBkColor, eAPDelay, eRDelay, eIDelay); - - TFI = record - FE: set of TFE; - Colors: array[0..1] of TColor; - Delays: array[0..3] of Integer; - end; - - PMHToolTipManager = ^TMHToolTipManager; - TKOLMHToolTipManager = PMHToolTipManager; - - PMHToolTip = ^TMHToolTip; - TKOLMHToolTip = PMHToolTip; - -{$ENDIF interface_part} - -{$IFDEF pre_interface} - PMHHint = ^TMHHint; - TKOLMHHint = PMHHint; -{$ENDIF pre_interface} - -{$IFDEF interface_part} - - TMHToolTipManager = object(TObj) - protected - destructor Destroy; virtual; - public - TTT: array of PMHToolTip; - function AddTip: Integer; - function FindNeed(FI: TFI): PMHToolTip; - function CreateNeed(FI: TFI): PMHToolTip; - end; - - //P_MHHint = ^TMHHint; - TMHHint = object(TObj) - private - function GetManager:PMHToolTipManager; - // Spec - procedure ProcBegin(var TI: TToolInfo); - procedure ProcEnd(var TI: TToolInfo); - procedure ReConnect(FI: TFI); - procedure MoveTool(T1: PMHToolTip); - procedure CreateToolTip; - function GetFI: TFI; - - // Group - function GetDelay(const Index: Integer): Integer; - procedure SetDelay(const Index: Integer; const Value: Integer); - function GetColor(const Index: Integer): TColor; - procedure SetColor(const Index: Integer; const Value: TColor); - - // Local - procedure SetText(Value: KOLString); - function GetText: KOLString; - public - ToolTip: PMHToolTip; - HasTool: Boolean; - Parent: PControl; - destructor Destroy; virtual; - procedure Pop; - procedure Popup; - - property AutoPopDelay: Integer index 2 read GetDelay write SetDelay; - property InitialDelay: Integer index 3 read GetDelay write SetDelay; - property ReshowDelay: Integer index 1 read GetDelay write SetDelay; - - property TextColor: TColor index 1 read GetColor write SetColor; - property BkColor: TColor index 0 read GetColor write SetColor; - property Text: KOLString read GetText write SetText; - end; - - TMHToolTip = object(TObj) - - private - fHandle: THandle; - Count: Integer; - - function GetDelay(const Index: Integer): Integer; - procedure SetDelay(const Index: Integer; const Value: Integer); - function GetColor(const Index: Integer): TColor; - procedure SetColor(const Index: Integer; const Value: TColor); - function GetMaxWidth: Integer; - procedure SetMaxWidth(const Value: Integer); - function GetMargin: TRect; - procedure SetMargin(const Value: TRect); - function GetActivate: Boolean; - procedure SetActivate(const Value: Boolean); -// function GetText: string; -// procedure SetText(const Value: string); -// function GetToolCount: Integer; -// function GetTool(Index: Integer): TToolInfo; - - - - protected - - public - destructor Destroy; virtual; - procedure Pop; - procedure Popup; - procedure Update; - -// function GetInfo: TToolInfo; // Hide in Info -// procedure SetInfo(Value: TToolInfo); - -// handle:Thandle; -// procedure SetC(C: PControl); -// procedure SetI(C: PControl; S: string); -// procedure Add(Value: TToolInfo); -// procedure Delete(Value: TToolInfo); -// function Connect(Value: PControl): Integer; - - -// property OnCloseUp: TOnEvent read GetOnDropDown write SetOnDropDown; - - - - property AutoPopDelay: Integer index 2 read GetDelay write SetDelay; - property InitialDelay: Integer index 3 read GetDelay write SetDelay; - property ReshowDelay: Integer index 1 read GetDelay write SetDelay; - - property TextColor: TColor index 1 read GetColor write SetColor; - property BkColor: TColor index 0 read GetColor write SetColor; - - property MaxWidth: Integer read GetMaxWidth write SetMaxWidth; - - property Margin: TRect read GetMargin write SetMargin; - property Activate: Boolean read GetActivate write SetActivate; - property Handle: THandle read fHandle; -// property Text: string read GetText write SetText; -// property ToolCount: Integer read GetToolCount; -// property Tools[Index: Integer]: TToolInfo read GetTool; - - end; - -const - Dummy = 0; - - -function NewHint(A: PControl): PMHHint; -function NewManager: PMHToolTipManager; -function NewMHToolTip(AParent: PControl): PMHToolTip; - -var - Manager: PMHToolTipManager; - -{$ENDIF interface_part} - -{$IFDEF Frame} - -implementation - -{$ENDIF Frame} - -{$IFDEF implementation} - -const - Dummy1 = 1; - - TTDT_AUTOMATIC = 0; - TTDT_RESHOW = 1; - TTDT_AUTOPOP = 2; - TTDT_INITIAL = 3; - -//function WndProcMHDateTimePicker(Sender: PControl; var Msg: TMsg; var Rslt: Integer): Boolean; -{begin - Result := False;} -//end; - -function NewMHToolTip(AParent: PControl): PMHToolTip; -//var -// Data: PDateTimePickerData; -// T: TWndClassEx; -//var a: integer; -const - CS_DROPSHADOW = $00020000; -begin - DoInitCommonControls(ICC_BAR_CLASSES); - New(Result, Create); - - Result.fHandle := CreateWindowEx(WS_EX_TOPMOST, TOOLTIPS_CLASS, '', 0, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, AParent.GetWindowHandle, 0, HInstance, nil); -// SetClassLong(Result.handle,GCL_STYLE,CS_DROPSHADOW); - -// Result := PMHToolTip(_NewControl(AParent, TOOLTIPS_CLASS, 0, False, 0)); //PMHToolTip(_NewCommonControl(AParent,TOOLTIPS_CLASS, 0{TTS_ALWAYSTIP}{WS_CHILD or WS_VISIBLE},False,0)); -// Result.Style:=0; -// Result.ExStyle:=0; -// GetMem(Data,Sizeof(Data^)); -// FillChar(Data^,Sizeof(Data^),0); -// a:=SetClassLong(Result.Handle,GCL_STYLE,CS_DROPSHADOW); -// ShowMessage(Int2Str(a)); -// Result.CustomData:=Data; - -{ T.cbSize:=SizeOf(T); - GetClassInfoEx(hInstance,TOOLTIPS_CLASS,T); - T.style:=T.style or CS_DROPSHADOW; - T.hInstance:=hInstance; - T.lpszClassName:='ZharovHint'; - a:=RegisterClassEx(T); - ShowMessage(Int2Str(a)); } -// Result.handle := CreateWindowEx(0, {'ZharovHint'} TOOLTIPS_CLASS, '', 0 {orCS_DROPSHADOW or WS_POPUP or WS_BORDER or CS_SAVEBITS or WS_CHILD or WS_CLIPSIBLINGS}, CW_USEDEFAULT, CW_USEDEFAULT, -// CW_USEDEFAULT, CW_USEDEFAULT, AParent.Handle, 0, HInstance, nil); -// Data.ttt:=CreateWindowEx (CS_IMEWS_EX_TOOLWINDOW or WS_EX_CONTROLPARENT{ or CS_SAVEBITS or WS_POPUP or WS_BORDER}{65536},{'ZharovHint'}TOOLTIPS_CLASS,'',{WS_CHILD or}{ WS_VISIBLE}{100663296}{WS_EX_TOOLWINDOW}CS_DROPSHADOW or WS_POPUP or WS_BORDER or CS_SAVEBITS or WS_CHILD or WS_CLIPSIBLINGS,CW_USEDEFAULT,CW_USEDEFAULT, -// CW_USEDEFAULT,CW_USEDEFAULT,AParent.Handle,0,HInstance,NIL); -// SetClassLong(Data.ttt,GCL_STYLE,CS_DROPSHADOW); -// SendMessage (Data.ttt,TTM_SETDELAYTIME,TTDT_INITIAL,5); -// SendMessage (Data.ttt,TTM_SETDELAYTIME,TTDT_RESHOW,20); -// SendMessage (Result.handle,TTM_SETDELAYTIME,TTDT_AUTOPOP,2000); -// Result.CreateWindow; -// Result.Parent := AParent; -// Result.Perform(TTM_SETTIPTEXTCOLOR,clRed,0); -// SendMessage (Result.handle,TTM_SETTIPTEXTCOLOR,clBlue,0); -// SendMessage (Result.handle,TTM_SETTIPTEXTCOLOR,clRed,0); -// Result.Color:=clRed; -// Result.Font.Color:=clRed; -// Data.FCalColors:=NewMonthCalColors(Result); -// Data.FOnDropDown:=nil; -// Result.AttachProc(WndProcMHDateTimePicker); -// Result.AttachProc(WndProcMHDateTimePicker); -end; - -{procedure TMHToolTip.SetC(C: PControl); -var - TI: TToolInfo; - R: Trect; -// Data:PDateTimePickerData; -begin - R := C.ClientRect; - // Control:= C.Handle; - with TI do - begin - cbSize := SizeOf(TI); - uFlags := TTF_SUBCLASS; // or TTF_IDISHWND; - hWnd := C.GetWindowHandle; //Control; - uId := 0; - rect.Left := R.Left; - rect.Top := R.Top; - rect.Right := R.Right; - rect.Bottom := R.Bottom; - hInst := 0; - lpszText := Pchar('I am ' + C.Caption); - end; - PostMessage(handle, TTM_ADDTOOL, 0, DWORD(@TI)); -// Perform(TTM_ADDTOOL, 0, DWord(@TI)); -end; } - -function TMHToolTip.GetDelay(const Index: Integer): Integer; -begin - Result := SendMessage(fHandle, TTM_GETDELAYTIME, Index, 0); -end; - - -procedure TMHToolTip.SetDelay(const Index, Value: Integer); -begin - SendMessage(handle, TTM_SETDELAYTIME, Index, MAKELONG(Value, 0)); -end; - - -function TMHToolTip.GetColor(const Index: Integer): TColor; -begin - Result := SendMessage(handle, TTM_GETTIPBKCOLOR + Index, 0, 0); -end; - -procedure TMHToolTip.SetColor(const Index: Integer; const Value: TColor); -begin - SendMessage(handle, TTM_SETTIPBKCOLOR + Index, Value, 0); -end; - -function TMHToolTip.GetMaxWidth: Integer; -begin - Result := SendMessage(fHandle, TTM_GETMAXTIPWIDTH, 0, 0); -end; - -procedure TMHToolTip.SetMaxWidth(const Value: Integer); -begin - SendMessage(fHandle, TTM_SETMAXTIPWIDTH, 0, Value); -end; - -{procedure TMHToolTip.SetI(C: PControl; S: string); -var - TI: TToolInfo; - R: Trect; -// Data:PDateTimePickerData; -begin - R := C.ClientRect; - // Control:= C.Handle; - with TI do - begin - cbSize := SizeOf(TI); - uFlags := TTF_SUBCLASS; - hWnd := C.GetWindowHandle; //Control; - uId := 0; - rect.Left := R.Left; - rect.Top := R.Top; - rect.Right := R.Right; - rect.Bottom := R.Bottom; - hInst := 0; - lpszText := PChar(S); - end; -// PostMessage (handle,TTM_ADDTOOL,0,DWORD (@TI)); -// Perform(TTM_SETTOOLINFO, 0, DWord(@TI)); -end; } - -function TMHToolTip.GetMargin: TRect; -begin - SendMessage(fHandle, TTM_GETMARGIN, 0, DWord(@Result)); -end; - -procedure TMHToolTip.SetMargin(const Value: TRect); -begin - SendMessage(fHandle, TTM_SETMARGIN, 0, DWord(@Value)); -end; - -function TMHToolTip.GetActivate: Boolean; -begin - // ?????? - Result := False; -end; - -procedure TMHToolTip.SetActivate(const Value: Boolean); -begin - SendMessage(fHandle, TTM_ACTIVATE, DWord(Value), 0); -end; - -procedure TMHToolTip.Pop; -begin - SendMessage(fHandle, TTM_POP, 0, 0); -end; - -procedure TMHToolTip.Popup; -begin - SendMessage(fHandle, $0422 {TTM_POPUP}, 0, 0); -end; - -{function TMHToolTip.GetText: string; -begin - -end; - -procedure TMHToolTip.SetText(const Value: string); -var - TI: TToolInfo; -begin - TI := GetInfo; - TI.lpszText := PChar(Value); - SetInfo(TI); -end; } - -{function TMHToolTip.GetInfo: TToolInfo; -begin - with Result do - begin - // ???? - FillChar(Result, SizeOf(Result), 0); - cbSize := SizeOf(Result); -// hWnd := Parent.GetWindowHandle; - uId := 0; - end; -// Perform(TTM_GETTOOLINFO, 0, DWord(@Result)); -end; - -procedure TMHToolTip.SetInfo(Value: TToolInfo); -begin -// Perform(TTM_SETTOOLINFO, 0, DWord(@Value)); -end;} - -{function TMHToolTip.GetToolCount: Integer; -begin -// Result := Perform(TTM_GETTOOLCOUNT, 0, 0); -end; - -function TMHToolTip.GetTool(Index: Integer): TToolInfo; -begin - FillChar(Result, SizeOf(Result), 0); // ???? - Result.cbSize := SizeOf(Result); -// Perform(TTM_ENUMTOOLS, Index, DWord(@Result)); -end; } - -{procedure TMHToolTip.Add(Value: TToolInfo); -begin -// Perform(TTM_ADDTOOL, 0, DWord(@Value)); -end;} - -{procedure TMHToolTip.Delete(Value: TToolInfo); -begin -// Perform(TTM_DELTOOL, 0, DWord(@Value)); -end;} - -procedure TMHToolTip.Update; -begin - inherited; // ??? - SendMessage(fHandle, TTM_UPDATE, 0, 0); -end; - -function NewHint(A: PControl): PMHHint; -begin - New(Result, Create); - - with Result^ do - begin - Parent := A; - ToolTip := nil; // ??? - HasTool := False; // ??? - end; - A.Add2AutoFree(Result); -end; - -function NewManager: PMHToolTipManager; -begin - New(Result, Create); -end; - -{ TMHHint } - -function TMHHint.GetDelay(const Index: Integer): Integer; -begin -// CreateToolTip; - Result := 0; - if Assigned(ToolTip) then - Result := ToolTip.GetDelay(Index); -end; - -function TMHHint.GetFI: TFI; -begin - /// !!! DANGER-WITH !!! - with Result, ToolTip^ do - begin - FE := FE + [eTextColor]; - Colors[1] := TextColor; - - FE := FE + [eBkColor]; - Colors[0] := BkColor; - - FE := FE + [eAPDelay]; - Delays[TTDT_AUTOPOP] := AutoPopDelay; - - FE := FE + [eRDelay]; - Delays[TTDT_RESHOW] := ReshowDelay; - - FE := FE + [eIDelay]; - Delays[TTDT_INITIAL] := InitialDelay; - end; -end; - -procedure TMHHint.ReConnect(FI: TFI); -var - TMP: PMHToolTip; -begin - with GetManager^ do - begin - TMP := FindNeed(FI); - if not Assigned(TMP) then - TMP := CreateNeed(FI); - if Assigned(ToolTip) and HasTool then - MoveTool(TMP); - ToolTip := TMP; - end; -end; - -procedure TMHHint.MoveTool(T1: PMHToolTip); -var - TI: TToolInfo; - TextL: array[0..255] of KOLChar; -begin - if T1 = ToolTip then - Exit; - with TI do - begin - cbSize := SizeOf(TI); - hWnd := Parent.GetWindowHandle; - uId := Parent.GetWindowHandle; - lpszText := @TextL[0]; - end; - - SendMessage(ToolTip.handle, TTM_GETTOOLINFO, 0, DWord(@TI)); - SendMessage(ToolTip.handle, TTM_DELTOOL, 0, DWORD(@TI)); - ToolTip.Count := ToolTip.Count - 1; - SendMessage(T1.handle, TTM_ADDTOOL, 0, DWORD(@TI)); - T1.Count := T1.Count - 1; - - HasTool := True; - -end; - -procedure TMHHint.SetColor(const Index: Integer; const Value: TColor); -var - FI: TFI; -begin - if Assigned(ToolTip) then - begin - if ToolTip.Count + Byte(not HasTool) = 1 then - begin - ToolTip.SetColor(Index, Value); - Exit; - end; - FI := GetFI; - end; - - case Index of - 0: FI.FE := FI.FE + [eBkColor]; - 1: FI.FE := FI.FE + [eTextColor]; - end; - FI.Colors[Index] := Value; - - ReConnect(FI); -end; - -function TMHHint.GetColor(const Index: Integer): TColor; -begin - Result := 0; - if Assigned(ToolTip) then - Result := ToolTip.GetColor(Index); -end; - -procedure TMHHint.SetDelay(const Index, Value: Integer); -var - FI: TFI; -begin - if Assigned(ToolTip) then - begin - if ToolTip.Count + Byte(not HasTool) = 1 then - begin - ToolTip.SetDelay(Index, Value); - Exit; - end; - FI := GetFI; - end; - - case Index of - TTDT_AUTOPOP: FI.FE := FI.FE + [eAPDelay]; // Spec - TTDT_INITIAL: FI.FE := FI.FE + [eIDelay]; // Spec - TTDT_RESHOW: FI.FE := FI.FE + [eRDelay]; // Spec - end; //case - - FI.Delays[Index] := Value; //Spec - - ReConnect(FI); -end; - -procedure TMHHint.SetText(Value: KOLString); -var - TI: TToolInfo; -begin - ProcBegin(TI); - - with TI do - begin - uFlags := TTF_SUBCLASS or TTF_IDISHWND; // Spec - lpszText := PKOLChar(Value); // Spec - end; - - procEnd(TI); - - if HasTool then - begin - TI.lpszText := PKOLChar(Value); - SendMessage(ToolTip.handle, TTM_SETTOOLINFO, 0, DWord(@TI)); - end; - -end; - -(* -procedure TMHHint.SetText(Value: string); -var - TI: TToolInfo; - R: Trect; - TextLine: array[0..255] of Char; -begin - if not Assigned(ToolTip) then - begin - if Length(Manager.TTT) = 0 then - Manager.AddTip; - ToolTip := Manager.TTT[0]; - end; - - with TI do - begin - cbSize := SizeOf(TI); - hWnd := Parent.GetWindowHandle; - uId := Parent.GetWindowHandle; - hInst := 0; - end; - - if not HasTool {TTool = -1} then - begin - R := Parent.ClientRect; - // Control:= C.Handle; - with TI do - begin -// cbSize := SizeOf(TI); - uFlags := TTF_SUBCLASS; -// hWnd := Parent.GetWindowHandle; //Control; -// uId := Parent.GetWindowHandle; - rect.Left := R.Left; - rect.Top := R.Top; - rect.Right := R.Right; - rect.Bottom := R.Bottom; -// hInst := 0; - lpszText := PChar(Value); - end; - SendMessage({Manager.TTT[TTip]} ToolTip.handle, TTM_ADDTOOL, 0, DWORD(@TI)); - HasTool := True; -// TTool := 0; - ToolTip {Manager.TTT[TTip]}.Count := ToolTip {Manager.TTT[TTip]}.Count + 1; - - end - else - begin - - with TI do - begin - // ???? -// FillChar(TI, SizeOf(TI), 0); -// cbSize := SizeOf(TI); -// hWnd := Parent.GetWindowHandle; -// uId := Parent.GetWindowHandle; - lpszText := @TextLine; //PChar(S); - end; - SendMessage(ToolTip {Manager.TTT[TTip]}.handle, TTM_GETTOOLINFO, 0, DWord(@TI)); - TI.lpszText := PChar(Value); -// Perform(TTM_GETTOOLINFO, 0, DWord(@Result)); - SendMessage(ToolTip {Manager.TTT[TTip]}.handle, TTM_SETTOOLINFO, 0, DWord(@TI)); - end; -// Manager.TTT[TTip].Tool[TTool].SSSetText(Value); -end; -*) - -{ TMHToolTipManager } - -{function TMHToolTipManager.AddColor(C: TColor): Integer; -begin - SetLength(TTT, Length(TTT) + 1); - TTT[Length(TTT) - 1] := NewMHToolTip(Applet); - TTT[Length(TTT) - 1].SetColor(1, C); - Result := Length(TTT) - 1; -end; } - -function TMHToolTipManager.AddTip: Integer; -begin - SetLength(TTT, Length(TTT) + 1); - TTT[Length(TTT) - 1] := NewMHToolTip(Applet); - Result := Length(TTT) - 1; -end; - -{function TMHToolTip.Connect(Value: PControl): Integer; -var - TI: TToolInfo; - R: Trect; -// Data:PDateTimePickerData; -begin - R := Value.ClientRect; - // Control:= C.Handle; - with TI do - begin - cbSize := SizeOf(TI); - uFlags := TTF_SUBCLASS; - hWnd := Value.GetWindowHandle; //Control; - uId := Value.GetWindowHandle; - rect.Left := R.Left; - rect.Top := R.Top; - rect.Right := R.Right; - rect.Bottom := R.Bottom; - hInst := 0; - lpszText := PChar('Super'); - end; - PostMessage(handle, TTM_ADDTOOL, 0, DWORD(@TI)); -// Perform(TTM_ADDTOOL, 0, DWord(@TI)); -end;} - -{function TMHToolTipManager.FindTip(N: Integer): Integer; -begin - Result := -1; -end;} - -function TMHToolTipManager.FindNeed(FI: TFI): PMHToolTip; -var - i: Integer; -begin - Result := nil; - for i := 0 to length(TTT) - 1 do - begin - if ((eTextColor in FI.FE) and (not (FI.Colors[1] = TTT[i].TextColor))) or - ((eBkColor in FI.FE) and (not (FI.Colors[0] = TTT[i].BkColor))) or - ((eAPDelay in FI.FE) and (not (FI.Delays[TTDT_AUTOPOP] = TTT[i].AutoPopDelay))) or - ((eIDelay in FI.FE) and (not (FI.Delays[TTDT_INITIAL] = TTT[i].InitialDelay))) or - ((eRDelay in FI.FE) and (not (FI.Delays[TTDT_RESHOW] = TTT[i].ReshowDelay))) then - Continue; - Result := TTT[i]; - Break; - end; -end; - -function TMHToolTipManager.CreateNeed(FI: TFI): PMHToolTip; - -begin - Setlength(TTT, length(TTT) + 1); - TTT[length(TTT) - 1] := NewMHToolTip(Applet); - with TTT[length(TTT) - 1]^ do - begin - if (eTextColor in FI.FE) then - TextColor := FI.Colors[1]; - if (eBkColor in FI.FE) then - BkColor := FI.Colors[0]; - if (eAPDelay in FI.FE) then - AutoPopDelay := FI.Delays[TTDT_AUTOPOP]; - if (eIDelay in FI.FE) then - InitialDelay := FI.Delays[TTDT_INITIAL]; - if (eRDelay in FI.FE) then - ReshowDelay := FI.Delays[TTDT_RESHOW]; - end; - Result := TTT[length(TTT) - 1]; -end; - -procedure TMHHint.ProcBegin(var TI: TToolInfo); -begin - CreateToolTip; - - with TI do - begin - cbSize := SizeOf(TI); - hWnd := Parent.GetWindowHandle; - uId := Parent.GetWindowHandle; - hInst := 0; - end; -end; - -procedure TMHHint.ProcEnd(var TI: TToolInfo); -var - TextLine: array[0..255] of KOLChar; -begin - if not HasTool then - begin - SendMessage(ToolTip.handle, TTM_ADDTOOL, 0, DWORD(@TI)); - HasTool := True; - ToolTip.Count := ToolTip.Count + 1; - end - else - begin - with TI do - begin - lpszText := @TextLine[0]; - end; - SendMessage(ToolTip.handle, TTM_SETTOOLINFO, 0, DWord(@TI)); - end; -end; - -destructor TMHToolTipManager.Destroy; -var - i: Integer; -begin - for i := 0 to Length(TTT) - 1 do - TTT[i].Free; - SetLength(TTT, 0); - inherited; -end; - -procedure TMHHint.Pop; -begin - if Assigned(ToolTip) and (HasTool) then - begin // ^^^^^^^^^^^^ ??? -// CreateToolTip; - ToolTip.Pop; - end; -end; - -procedure TMHHint.Popup; -begin - if Assigned(ToolTip) and (HasTool) then - begin // ^^^^^^^^^^^^ ??? -// CreateToolTip; - ToolTip.Popup; - end; -end; - -destructor TMHHint.Destroy; -var - TI: TToolInfo; - i: integer; -begin - with TI do - begin - cbSize := SizeOf(TI); - hWnd := Parent.GetWindowHandle; - uId := Parent.GetWindowHandle; - end; - - SendMessage(ToolTip.handle, TTM_DELTOOL, 0, DWORD(@TI)); - ToolTip.Count := ToolTip.Count - 1; - if ToolTip.Count <= 0 then begin - i:=Length(Manager.TTT); - if i > 1 then begin - Manager.TTT[i - 1].Free; - SetLength(Manager.TTT, i - 1); - end - else - Free_And_Nil(Manager); - end; - inherited; -end; - -destructor TMHToolTip.Destroy; -begin - inherited; -end; - -procedure TMHHint.CreateToolTip; -begin - if not Assigned(ToolTip) then - begin - if Length(GetManager.TTT) = 0 then - GetManager.AddTip; - ToolTip := GetManager.TTT[0]; - end; -end; - -function TMHHint.GetText: KOLString; -var - TI: TToolInfo; - TextL: array[0..255] of KOLChar; -begin - if Assigned(ToolTip) and (HasTool) then - begin - // !!! - with TI do - begin - // ???? -// FillChar(TI, SizeOf(TI), 0); - cbSize := SizeOf(TI); - hWnd := Parent.GetWindowHandle; - uId := Parent.GetWindowHandle; - lpszText := @TextL[0]; - end; - SendMessage(ToolTip.handle, TTM_GETTOOLINFO, 0, DWord(@TI)); - Result := TextL; //TI.lpszText;// := PChar(Value); - end; -end; - -function TMHHint.GetManager: PMHToolTipManager; -begin - if Manager=nil then - Manager:=NewManager; - Result:=Manager; -end; - -{$ENDIF implementation} - -{$IFDEF Frame} - -initialization -{$ENDIF Frame} -{$IFDEF initialization} - - Manager := NewManager; -{$ENDIF initialization} - -{$IFDEF Frame} -finalization -{$ENDIF Frame} -{$IFDEF finalization} -// Manager.Free; -{$ENDIF finalization} - - -{$IFDEF Frame} -end. -{$ENDIF Frame} - -{$IFDEF function} -function GetHint: PMHHint; -{$ENDIF function} - -{$IFDEF public} - property Hint: PMHHint read GetHint; - {$ENDIF public} - - {$IFDEF code} - function TControl.GetHint: PMHHint; - begin - if fHint = nil then - fHint := NewHint(@Self); - Result := fHint; - end; - {$ENDIF code} - - {$IFDEF MHdestroy} - fHint.Free; - {$ENDIF MHdestroy} - - {$IFDEF var} - fHint: PMHHint; - {$ENDIF var} \ No newline at end of file diff --git a/Addons/KOLPageSetupDialog.pas b/Addons/KOLPageSetupDialog.pas deleted file mode 100644 index 1470887..0000000 --- a/Addons/KOLPageSetupDialog.pas +++ /dev/null @@ -1,409 +0,0 @@ -unit KOLPageSetupDialog; -{* Page setup dialog. -|
-Ver 1.4 -|
-Now the information about selected printer can be transferred to TKOLPrinter. -If DC is needed directly use new psdReturnDC option. -|
-Note :page setup dialog replace print dialog marked as obsolete by Microsoft. -|
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) -|
-Note: -|
-- when custom page is selected ,DC is empty (bug?) -|
-- 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: -|
-|
  • psdMargins : allow user to select margins
    • -|
  • psdOrientation : allow user to select page orientation
    • -|
  • psdSamplePage : draw contents of the sample page
    • -|
  • psdPaperControl : allow paper size control
    • -|
  • psdPrinterControl : allow user to select printer
    • -|
  • psdHundredthsOfMillimeters : set scale to hundredths of millimeters for margins and paper size,on return indicate selected scale
    • -|
  • psdThousandthsOfInches : set scale to thousandths of inches for margins and paper size,on return indicate selected scale
    • -|
  • psdUseMargins,psdUseMinMargins : use suggested margins
    • -|
  • psdWarning : generate warning when there is no default printer
    • -|
  • psdHelp : add help button to dialog, application must process HELPMSGSTRING message
    • -|
  • psdReturnDC : returns DC of selected printer if required
    • -|
- } - - 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) - |
- 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 - |
- 1 := You must assign properties to tagPSD.Flags by yourself - |
- 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. diff --git a/Addons/KOLPrintCommon.pas b/Addons/KOLPrintCommon.pas deleted file mode 100644 index 1943486..0000000 --- a/Addons/KOLPrintCommon.pas +++ /dev/null @@ -1,30 +0,0 @@ -unit KOLPrintCommon; -{*} - -interface - -uses Windows; - -type - PDevNames = ^tagDEVNAMES; - tagDEVNAMES = packed record - wDriverOffset: Word; - wDeviceOffset: Word; - wOutputOffset: Word; - wDefault: Word; - end; - - PPrinterInfo = ^TPrinterInfo; - TPrinterInfo = packed record - {* Used for transferring information between Print/Page dialogs and TKOLPrinter.This way TKOLPrinter and Print/Page dialogs could be used separately} - ADevice : PChar; - ADriver : PChar; - APort : PChar; - ADevMode : THandle; - end; - - -implementation - -end. - \ No newline at end of file diff --git a/Addons/KOLPrintDialogs.pas b/Addons/KOLPrintDialogs.pas deleted file mode 100644 index a38409c..0000000 --- a/Addons/KOLPrintDialogs.pas +++ /dev/null @@ -1,373 +0,0 @@ -unit KOLPrintDialogs; -{* Print and printer setup dialogs, implemented in KOL object. -|
-Ver 1.4 -|
-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: -|
-|
    -|
  • pdPrinterSetup : printer setup dialog
    • -|
  • pdCollate : 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 -|
    • -|
  • pdPrintToFile : 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 -|
    • -|
  • pdPageNums : allow to select pages in dialog
    • -|
  • pdSelection : set Selection field visible in dialog
    • -|
  • pdWarning : when set, and there's no default printer in system, warning is generated (like in VCL TPrintDialog)
    • -|
  • pdDeviceDepend : disables fields : Copies,Collate if this functions aren't supported by printer driver
    • -|
  • pdHelp : Help button is visible (owner receive HELPMSGSTRING registered message)
    • -|
  • pdReturnDC : returns DC of selected printer
    • -|
-} - - -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 - |
- 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. diff --git a/Addons/KOLPrinters.pas b/Addons/KOLPrinters.pas deleted file mode 100644 index dcaf149..0000000 --- a/Addons/KOLPrinters.pas +++ /dev/null @@ -1,626 +0,0 @@ -unit KOLPrinters; -{* Replaces VCL TPrinter functionality. -|
-Author : Bogusіaw Brandys, -|
-|

Version 1.4

-|
-|History : -|
-| 17-09-2002 [+] 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) -|
-[+] 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) -|
-|
-| 15-09-2002 [-] Fix access violation when there is no printer in system (caused -by DefPrinter function and Assign procedure). -|
-|Example: -! 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; -|
-|One more note: -|
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. -|
-Notes: -|
-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... -|
-Still missing (I suppose): -|
-- 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) -|
-- printing of selected pages only (must compute pages count) -|
-- 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) -|
-- Printers property (list of printers in system),PrinterIndex and Fonts property -|
-- print preview -|
-- 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. - diff --git a/Addons/KOLProgBar.pas b/Addons/KOLProgBar.pas deleted file mode 100644 index 1ead54f..0000000 --- a/Addons/KOLProgBar.pas +++ /dev/null @@ -1,359 +0,0 @@ -unit KOLProgBar; - -interface - -uses - Windows, Messages, KOL; - -type - - TBevel = (bvUp, bvDown, bvNone); - - PColorProgBar =^TColorProgBar; - TColorProgressBar = PColorProgBar; - TColorProgBar = object(TObj) - private - { Private declarations } - fControl : PControl; - fPosition: integer; - fOldPosit: integer; - fBColor, - fFColor : TColor; - fFirst : boolean; - fBorder : integer; - fParentCl: boolean; - fBevel : TBevel; - fMin, - fMax : integer; - fStr : string; - fFont : PGraphicTool; - fCanvas : PCanvas; - OldWind, - NewWind : longint; - procedure SetFColor(C: TColor); - procedure SetBColor(C: TColor); - procedure SetPos(P: integer); - procedure SetBorder(B: integer); - procedure SetParentCl(B: boolean); - procedure SetBevel(B: TBevel); - procedure SetMin(M: integer); - procedure SetMax(M: integer); - protected - { Protected declarations } - procedure NewWndProc(var Msg: TMessage); - procedure Paint; -{ procedure WMPaint(var Msg: TMessage); message WM_PAINT; - procedure WMSize (var Msg: TMessage); message WM_SIZE; - procedure WMActiv(var Msg: TMessage); message WM_SHOWWINDOW; - procedure CMParCl(var Msg: TMessage); message CM_PARENTCOLORCHANGED;} - public - destructor Destroy; virtual; - function SetPosition(X, Y: integer): PColorProgBar; overload; - function SetSize(X, Y: integer): PColorProgBar; overload; - function SetAlign(A: TControlAlign): PColorProgBar; overload; - function GetFont: PGraphicTool; - { Public declarations } -{ constructor Create(Owner: TControl); override;} - property Font: PGraphicTool read GetFont; - property FColor: TColor read fFColor write SetFColor; - property BColor: TColor read fBColor write SetBColor; - property Border: integer read fBorder write SetBorder; - property Position: integer read fPosition write SetPos; - property Max: integer read fMax write SetMax; - property Min: integer read fMin write SetMin; - property ParentColor: boolean read fParentCl write SetParentCl; - property Bevel: TBevel read fBevel write SetBevel; - end; - -function NewTColorProgressBar(AOwner: PControl): PColorProgBar; - -implementation - -uses objects; - -function NewTColorProgressBar; -var p: PColorProgBar; - c: PControl; -begin -{ New(Result, Create);} - c := pointer(_NewControl( AOwner, 'STATIC', WS_VISIBLE or WS_CHILD or - SS_LEFTNOWORDWRAP or SS_NOPREFIX or SS_NOTIFY, - False, nil )); - c.CreateWindow; - New(p, create); - AOwner.Add2AutoFree(p); - p.fControl := c; - p.fFont := NewFont; - p.fCanvas := NewCanvas(GetDC(c.Handle)); - p.fMin := 0; - p.fMax := 100; - p.fFColor := clRed; - p.fBColor := clBtnFace; - p.fBorder := 4; - p.fBevel := bvDown; - p.fFirst := True; - p.fPosition := 50; - p.fFont.FontStyle := [fsBold]; - Result := p; - p.OldWind := GetWindowLong(c.Handle, GWL_WNDPROC); - p.NewWind := LongInt(MakeObjectInstance(p.NewWndProc)); - SetWindowLong(c.Handle, GWL_WNDPROC, p.NewWind); -end; - -destructor TColorProgBar.Destroy; -begin - SetWindowLong(fControl.Handle, GWL_WNDPROC, OldWind); - FreeObjectInstance(Pointer(NewWind)); - fCanvas.Free; - fFont.Free; - inherited; -end; - -function TColorProgBar.SetPosition(X, Y: integer): PColorProgBar; -begin - fControl.Left := X; - fControl.Top := Y; - Result := @self; -end; - -function TColorProgBar.SetSize(X, Y: integer): PColorProgBar; -begin - fControl.Width := X; - fControl.Height := Y; - Result := @self; -end; - -function TColorProgBar.SetAlign(A: TControlAlign): PColorProgBar; -begin - fControl.Align := A; - Result := @self; -end; - -function TColorProgBar.GetFont; -begin - Result := fFont; -end; - - -procedure TColorProgBar.NewWndProc; -begin - Msg.Result := CallWindowProc(Pointer(OldWind), fControl.Handle, Msg.Msg, Msg.wParam, Msg.lParam); - case Msg.Msg of -WM_PAINT: Paint; -WM_SIZE: begin - fFirst := True; - Paint; - end; -WM_ACTIVATE: - begin - fFirst := True; - Paint; - end; -{CM_PARENTCOLORCHANGED: - begin - if fParentCl then begin - if Msg.wParam <> 0 then - BColor := TColor(Msg.lParam) else - BColor := (Parent as TForm).Color; - FColor := (Parent as TForm).Font.Color; - end; - end;} - end; -end; - -procedure TColorProgBar.SetFColor; -begin - fFColor := C; - fFirst := True; - Paint; -end; - -procedure TColorProgBar.SetBColor; -begin - fBColor := C; - fFirst := True; - Paint; -end; - -procedure TColorProgBar.SetPos; -begin - fPosition := P; - Paint; -end; - -procedure TColorProgBar.SetBorder; -begin - fBorder := B; - fFirst := True; - Paint; -end; - -procedure TColorProgBar.SetParentCl; -begin - fParentCl := B; - if B then begin -{ Perform(CM_PARENTCOLORCHANGED, 0, 0);} - Paint; - end; -end; - -procedure TColorProgBar.SetBevel; -begin - fBevel := B; - fFirst := True; - Paint; -end; - -procedure TColorProgBar.SetMin; -begin - fMin := M; - fFirst := True; - if fMax = fMin then fMax := fMin + 1; - Paint; -end; - -procedure TColorProgBar.SetMax; -begin - fMax := M; - fFirst := True; - if fMin = fMax then fMin := fMax - 1; - Paint; -end; - -procedure Frame3D(Canvas: PCanvas; var Rect: TRect; TopColor, BottomColor: TColor; - Width: Integer); - - procedure DoRect; - var - TopRight, BottomLeft: TPoint; - begin - with Canvas^, Rect do - begin - TopRight.X := Right; - TopRight.Y := Top; - BottomLeft.X := Left; - BottomLeft.Y := Bottom; - Pen.Color := TopColor; - PolyLine([BottomLeft, TopLeft, TopRight]); - Pen.Color := BottomColor; - Dec(BottomLeft.X); - PolyLine([TopRight, BottomRight, BottomLeft]); - end; - end; - -begin - Dec(Rect.Bottom); Dec(Rect.Right); - while Width > 0 do - begin - Dec(Width); - DoRect; - InflateRect(Rect, -1, -1); - end; - Inc(Rect.Bottom); Inc(Rect.Right); -end; - -function ColorToRGB(Color: TColor): Longint; -begin - if Color < 0 then - Result := GetSysColor(Color and $000000FF) else - Result := Color; -end; - -procedure TColorProgBar.Paint; -var Rct: TRect; - Trc: TRect; - Twk: TRect; - Str: string; - Rht: integer; - Len: integer; - Rgn: HRgn; - Stw: integer; -begin - GetClientRect(fControl.Handle, Rct); - Trc := Rct; - if (fPosition <= fOldPosit) or fFirst then begin - case fBevel of - bvUp: begin - Frame3D(fCanvas, Rct, clWhite, clBlack, 1); - end; -bvDown: begin - Frame3D(fCanvas, Rct, clBlack, clWhite, 1); - end; - end; - - fFirst := False; - fCanvas.brush.Color := fBColor; - fCanvas.FillRect(Rct); - end; - Rct := Trc; - - InflateRect(Rct, -fBorder, -fBorder); - Rct.Right := Rct.Left + (Rct.Right - Rct.Left) * fPosition div (Max - Min); - - Str := ' ' + int2str(fPosition * 100 div (fMax - fMin)) + '% '; - - SelectObject(fCanvas.Handle, fFont.Handle); - Stw := fCanvas.TextWidth(Str); - Trc.Left := (fControl.width - Stw) div 2; - Trc.Right := (fControl.width + Stw) div 2 + 1; - Twk := Rct; - - fCanvas.brush.Color := fFColor; - if (Rct.Right <= Trc.Left) then begin - fCanvas.FillRect(Rct); - end else begin - Twk.Right := Trc.Left; - fCanvas.FillRect(Twk); - end; - - Rht := Rct.Right; - Len := Length(Str); - - Rct.Left := (fControl.width - Stw) div 2; - Rct.Right := (fControl.width + Stw) div 2 + 1; - - if fStr <> Str then begin - if (Rct.Right > Rht) or (fCanvas.TextHeight(Str) > (Rct.Bottom - Rct.Top)) then begin - Rgn := CreateRectRgn(Rht, Rct.Top, Rct.Right, Rct.Bottom); - SelectClipRgn(fCanvas.Handle, Rgn); - SelectObject(fCanvas.Handle, fFont.Handle); - SetBkColor(fCanvas.Handle, ColorToRGB(fBColor)); - SetTextColor(fCanvas.Handle, ColorToRGB(fFColor)); - DrawText(fCanvas.Handle, @Str[1], Len, Rct, DT_TOP or DT_NOCLIP); - SelectClipRgn(fCanvas.Handle, 0); - DeleteObject(Rgn); - end; - end; - - if Rht < Rct.Right then begin - Rct.Right := Rht; - end; - - Dec(Rct.Left); - Inc(Rct.Right); - - if (Rct.Right > Rct.Left) then begin - SelectObject(fCanvas.Handle, fFont.Handle); - SetBkColor(fCanvas.Handle, ColorToRGB(fFColor)); - SetTextColor(fCanvas.Handle, ColorToRGB(fBColor)); - DrawText(fCanvas.Handle, @Str[1], Len, Rct, DT_TOP); - if Rct.Right < Trc.Right then begin - Twk := Rct; - Twk.Top := Twk.Top + fCanvas.TextHeight(Str); - fCanvas.brush.Color := fFColor; - fCanvas.Fillrect(Twk); - end; - end; - - if (Rct.Right >= Trc.Right) then begin - Rct.Left := Trc.Right - 2; - Rct.Right := Rht; - SetBkColor(fCanvas.Handle, ColorToRGB(fFColor)); - fCanvas.FillRect(Rct); - end; - - fStr := Str; - fOldPosit := fPosition; -end; - -end. diff --git a/Addons/KOLQProgBar.pas b/Addons/KOLQProgBar.pas deleted file mode 100644 index c36f704..0000000 --- a/Addons/KOLQProgBar.pas +++ /dev/null @@ -1,1543 +0,0 @@ -{$I KOLDEF.inc} -unit KOLQProgBar; -{ - - ("`-''-/").___..--''"`-._ - `6_ 6 ) `-. ( ).`-.__.`) - (_Y_.)' ._ ) `._ `. ``-..-' - _..`--'_..-_/ /--'_.' ,' -(il).-'' (li).' ((!.-' - - QnnO Progress Bar (KOL) - The component that provides a set of various progress bars. - - Ported to KOL © 2007 Danger - E-Mail: - - Original excellent TQProgressBar VCL component was developed by QnnO - and was ported to KOL with his permission. Merci a Qnno! - Thanks to 'MTsv DN' for his 'standard progress bar' compatibility idea. - -} - - { ****************************************************************** } - { v 1.1 } - { Delphi (6) unit -- progressbar replacement, with } - { several features... } - { } - { Copyright © 2004 by Olivier Touzot "QnnO" } - { (http://mapage.noos.fr/qnno/delphi_en.htm - qnno@noos.fr) } - { } - { ---------------------------------- } - { } - { History : } - { v 1.1 : 2004-05-12 (!) Correction of the "extreme colors" bug in } - { the GetGradientAr2(); function by Bernd Kirchhoff, allowing} - { the use of pure white or black colors in the bars. Thanks } - { and congratulations (he made the work under cbuilder 4.0 !)} - { v 1.0 : 2004-05-11 First release ; } - { ****************************************************************** } - - // This unit is freeware, but under copyrights that remain mine for my - // parts of the code, and original writters for their parts of the code. - // This is mainly the case with : - // -> The polynomial expression of the MakeCylinder(); function, provided - // by Matthieu Contensou, (with lots of help too, on many other - // subjects (see below)). - // (http://www25.brinkster.com/waypointfrance/cpulog/index.asp) - // -> The RGBtoHLS(); and HLStoRGB(); procedures, that come from a - // Microsoft knowledge base article (Q29240), at : - // http://support.microsoft.com/default.aspx?scid=kb;en-us;29240 - // -> The GetColorBetween(); function, which computes the main gradient, - // found at efg's colors page, and which author is saddly unknown : - // http://homepages.borland.com/efg2lab/Library/Delphi/Graphics/Color.htm - // http://homepages.borland.com/efg2lab/Library/UseNet/2001/0821.txt - // -> The GetGradientAr2(); new version, by Bernd Kirchhoff, which now - // correctly handles white and black colors in bars. - // (http://home.germany.net/100-445474/) - - // This unit can be freely used in any application, freeware, shareware - // or commercial. However, I would apreciate your sending me an email if - // you decide to use it. Of course, you use it under your own and single - // responsability. Neither me, nor contributors, could be held responsible - // for any problem resulting from the use of this unit. ;-) - - // It can also be freely distributed, provided all the above (and current) - // lines remain within it unchanged, and the readme.txt file be distributed - // with it too. - - // Many thanks go to Matthieu Contensou, who spent a lot of time (and - // patience ... ) trying to explain me the subtleties of the RGB -> YUV - // and return conversions.) - // He gave the idea of using the HLS space too, which is now used in this - // component. - - {* TKOLQProgressBar is the visual component that provides a set of various progress bars. - Adapted for KOL library, this was designed with maximal usability in mind and looks nice. - Original excellent TQProgressBar VCL component was developed by QnnO and several contributors, - and was ported to KOL with his permission. Merci a Qnno! - |
-  |Copyright (C) 2004 Olivier Touzot "QnnO" and TQProgressBar contributors.
-  |It can be found on the web at http://mapage.noos.fr/qnno/delphi_en.htm.
-  |Copyright (C) 2007 Danger (danger@artline.kz).
-  |
- |TKOLQProgressBar coming under the form of a KOL library unit, it can be simply used - by creating bars at runtime, setting the necessary properties: - !uses Windows, Messages, KOL, ..., KOLQProgBar; - ! //... - !var aPBar : PQProgressBar; - ! //... - !aPBar := NewQProgressBar( AParentForm ); - !aPBar.Progress:= 55; - !aPBar. ... - |

Certainly you can use the 'MCK mirror' provided with component to manage control properties at design time - (this still actually for Delphi versions earlier than Delphi 2005). In this case the visual component will - draws itself in design time with one of two available painting methods (see Readme.txt for details). - Note that control appearance at design time isn't depends on any of KOLCtrlWrapper routines and uses native VCL stuff. - |

Known problem:
- It's latency in the drawing of the first of a series of bars. The laging one is the first one updated, if - |ShowInactivePos is set to True, and whatever are it's other characteristics (size, appearence, aso). - The problem appears only under XP (despite a high cpu speed). A workaround is to call - |Form.ProcessMessages just after the change of the position value of the first bar.

- In the demo, the four vertical bars illustrate this. They should slide all together, but the first one lags, unless - |I add the Form.ProcessMessages like this: - !procedure TForm1.TrackBar2Scroll( Sender: PTrackbar; Code: Integer ); - !begin - ! Form.ProcessMessages; // Avoids the lag. - ! QProgressBar7.Progress:= Sender.Position; - ! QProgressBar8.Progress:= Sender.Position; - ! QProgressBar9.Progress:= Sender.Position; - ! QProgressBar10.Progress:= Sender.Position; - !end; - |

} - -interface - -// ---------------------------------------------------------- -uses - Windows, Messages, KOL; - -// ---------------------------------------------------------- -type - TQBarKind = ( bkFlat, bkCylinder ); - {* Progress bar style. } - - TQBarLook = ( blMetal, blGlass ); - {* Progress bar appearance. } - - TQBarOrientation = ( boHorizontal, boVertical ); - {* Visual control orientation. } - - TRGBArray = array[0..2] of Byte; - TCLRArray = array of TColor; - THLSRange = 0..240; - - THLSRec = record // Color conversion -> RgbToHls and return - hue: THLSRange; - lum: THLSRange; - sat: THLSRange; - end; - - TPosDescr = record // Bar description, rows or column ... - isInBlock: Boolean; // ... depending on orientation - blkLimit : Integer; - end; - -// ---------------------------------------------------------- - PQProgressBar = ^TQProgressBar; - TKOLQProgressBar = PQProgressBar; - - TOnQProgressBar = procedure( Sender: PQProgressBar ) of object; - {* |Event to be called when Progress value is changed. } - - PQDataObj = ^TQDataObj; - -// ---------------------------------------------------------- - TQDataObj = object( TObj ) - fPosDescr : array of TPosDescr; // Bar description, blocks and spaces - fPixDescr : array of TCLRArray; // Bar description, pixels colors - fInactDescr : TCLRArray; // Bar description, inactive positions colors (if reversed gradient); - fBarKind : TQBarKind; // flat or rounded - fBarLook : TQBarLook; // blMetal or blGlass - fOrientation : TQBarOrientation; // horizontal or vertical - fInternalBorder, // space between the shape and the bar itself (1 or two pixels) - fUSefullDrawSpace, // size of the bar minus border - fBorderSize : Integer; // 2*(border+shape) - fHasShape : Boolean; // the surrounding line - fShapeClr : TColor; // above' color - fCorner : Integer; // shape' corner - fStartClr, // left (or bottom) color - fFinalClr, // right (or top) color - fBkgClr : TColor; // background color. - fMonoClr : Boolean; // True if StartColor = FinalColor. - fInvInactPos, // If true, and gradient, -> inverted; - fShowInactPos : Boolean; // Bars corresp. to positions above actual are drawn in fInactPosClr - fInactPosClr : TColor; // Above's color - fUSerPosPct : Real; // same as below, as percent, for displays - fUserPos, // value sent by user - fPosition, // above, normalized to width or height, and max; - fMinVisPos, // Minimum position to send to Paint(), to see at least one bar - fMaxPos : Integer; // max position as sent by user. - fByBlock, // if true, alternates colored and not colored pixels - fFullBlock : Boolean; // if true, blocks are drawn only when their max position is reached; - fSpaceSize, // space between two blocks - fBlockSize : Integer; // width (or height) of a block - fHideOnTerm : Boolean; // Hides the bar a tenth of a second after the painting of the last pixel row/column; - fCapAlign : TTextAlign; // left - right - centered - fCapPos : TPoint; // Internal - caption's top and left, based on canvas' current font - fHasCaption : Boolean; // Internal - fShowPosAsPct : Boolean; // If True, Hint and/or caption will show the value as a percent of the maximum. - fCaptionOvr : Boolean; // id. below; - fHintOvr : Boolean; // if True, each position changes => Hint <- fUserPos or fUSerPosPct dep. on ShowPosAsPct True/false; - fOnProgChange : TOnQProgressBar; // ProgressBar changing event - destructor Destroy; virtual; - end; - -// ---------------------------------------------------------- - TQProgressBar = object( TControl ) - {* This object implements all functionality of component. - - |TKOLQProgressBar is similar to a standard progress bar control and tries to emulate many of its features: - |

  • Has the same properties. Obviously you can use Progress, MaxProgress and Caption derived from - PControl with some specific caused by the component. Here its short description: - |

    • Progress is the position to be drawn on the bar. This should be the only thing changing, once setup is complete;

      • - |

    • MaxProgress is the maximum value you may send to the bar. It will be used to normalize positions sent compared to - |the size of the bar's drawspace;

      • - |

    • Caption - the control may display a basic caption. This caption's appearance depends on the bar canvas' font property. - It is neither XOR'ed nor anything like that: authors couldn't succeed at it. Moreover, despite a caption appears correctly within - horizontal bars, it certainly will give poor results within vertical bars as long as the caption stays horizontal. - |

    • - |

  • Can handle progress bar control's specific messages. You can send messages to control or receive from it (see the MSDN documentation for details) thus it behaves as an usual progress bar control: - |

    • PBM_GETPOS retrieves the current position of the progress bar;

      • - |

    • PBM_SETPOS sets the current position for a progress bar and redraws the bar to reflect the new position;

      • - |

    • PBM_GETRANGE retrieves information about the current high and low limits of a given progress bar control;

      • - |

    • PBM_SETRANGE sets the maximum value for a progress bar and redraws the bar to reflect the new range;

      • - |

    • PBM_SETRANGE32 Sets the range of a progress bar control to a 32-bit value.

- - |
Use NewQProgressBar constuction function for creation of object instance. Here is the prototype: - ! function NewQProgressBar( AParent: PControl ): PQProgressBar; } - - protected - - procedure Paint; - procedure Resize; - procedure SetUsefullWidth; - procedure InitBlockArray; - procedure InitPixArray; - function MakeCylinder( h: Real ): Extended; - function GetGradientAr2( aColor: TColor; sz: Integer ): TClrArray; - function HLStoRGB( hue, lum, sat: THLSRange ): TColor; - function RGBtoHLS( RGBColor: TColor): THLSRec; - function GetColorBetween( AStartColor, AEndColor: TColor; PointValue, Von, Bis : Extended ): TColor; - function GetOrientation: TQBarOrientation; - procedure SetOrientation( Value: TQBarOrientation ); - function GetBarKind: TQBarKind; - procedure SetBarKind ( Value: TQBarKind ); - function GetBarLook: TQBarLook; - procedure SetBarLook ( Value: TQBarLook ); - procedure SetFCorner ( IsRounded: Boolean ); - function GetBoolCorner: Boolean; - function GetBkgColor: TColor; - procedure SetBkgColor ( aColor: TColor ); - function GetShape: Boolean; - procedure SetShape ( Value: Boolean ); - function GetShapeColor: TColor; - procedure SetShapeColor ( Value: TColor ); - function GetBlockSize: Integer; - procedure SetBlockSize ( Value: Integer ); - function GetSpaceSize: Integer; - procedure SetSpaceSize ( Value: Integer ); - function GetFullBlock: Boolean; - procedure SetFullBlock ( Value: Boolean ); - function GetMaxPos: Integer; - procedure SetMaxPos ( Value: Integer ); - function GetHideOnTerm: Boolean; - procedure SetHideOnTerm ( Value: Boolean); - function GetPosition: Integer; - procedure SetPosition ( Value: Integer ); - function GetStartClr: TColor; - procedure SetStartClr ( Value: TColor ); - function GetFinalClr: TColor; - procedure SetFinalClr ( Value: TColor ); - procedure SetBothColors ( Value: TColor ); - function GetInactivePos: Boolean; - procedure SetInactivePos( Value: Boolean ); - function GetInactPosClr: TColor; - procedure SetInactPosClr( Value: TColor ); - function GetInvInactPos: Boolean; - procedure SetInvInactPos( Value: Boolean ); - procedure SetCaption ( Value: string ); - function GetCapAlign: TTextAlign; - procedure SetCapAlign ( Value: TTextAlign ); - function GetCaptionOvr: Boolean; - procedure SetCaptionOvr ( Value: Boolean ); - function GetHintOvr: Boolean; - procedure SetHintOvr ( Value: Boolean ); - function GetShowPosAsPct: Boolean; - procedure SetShowPosAsPct( Value: Boolean ); - function GetOnProgressChange: TOnQProgressBar; - procedure SetOnProgressChange( const Value: TOnQProgressBar ); - - public - property Orientation : TQBarOrientation read GetOrientation write SetOrientation; - {* |It's the control orientation parameters at the parent, i.e. if you assign it to boVertical - then the control's progress will grow up from below upwards instead of from left corner to right. - |By default: boHorizontal. } - - property BarKind : TQBarKind read GetBarKind write SetBarKind; - {* Parameter that defines how the control's progress bar row will appear. - |By default: bkFlat. } - - property BarLook : TQBarLook read GetBarLook write SetBarLook; - {* Parameter that defines how the control's bar will look. - |blMetal takes the original color luminence into account when computing each pixel; - |blGlass don't. blGlass only works on the 'basic color' part of the color of each pixel. - |By default: blMetal. } - - property RoundCorner : Boolean read GetBoolCorner write SetFCorner; - {* |If True, the bar's external shape will appear with smoothly rounded corners, - otherwise it will be a rectangle. - |By default: True. } - - property BackgroundColor : TColor read GetBkgColor write SetBkgColor; - {* Parameter that defines control background color. - |By default: clWhite. } - - property BarColor : TColor read GetStartClr write SetBothColors; - {* Parameter that allows to define a single color bar in one shot: using - ! aPBar.BarColor:= clLime; - is equivalent to : - ! aPBar.StartColor := clLime; - ! aPBar.FinalColor := clLime; } - - property StartColor : TColor read GetStartClr write SetStartClr; - {* Left color of a two-colors horizontal bar, or bottom color for vertical bars. - |By default: clLime. } - - property FinalColor : TColor read GetFinalClr write SetFinalClr; - {* Right color of a two-colors horizontal bar, or Top color for vertical bars. - |By default: clLime (default bar is thus monocolor). } - - property ShowInactivePos : Boolean read GetInactivePos write SetInactivePos; - {* Inactive position are the positions not yet reached. - |If True, they'll be drawn in the - InactivePosColor, - |if False, only the background appears there. Inactive positions share appearance - properties and behaviour (like : by blocks or not, full blocks, BarKind, aso.) with active positions. - |Only the color differs. By default: False. } - - property InvertInactPos : Boolean read GetInvInactPos write SetInvInactPos; - {* |If True, the luminance of inactive positions color array is inverted. - Notice that the result is most often really dark. There's still some work to do there. - |Applies only on bkCylinder bars. By default: False. } - - property InactivePosColor: TColor read GetInactPosClr write SetInactPosClr; - {* Base color of inactive positions. - |By default: clGray. } - - property Shaped : Boolean read GetShape write SetShape; - {* Decides whether the bar has a surrounding line or not. - |By default: True. } - - property ShapeColor : TColor read GetShapeColor write SetShapeColor; - {* The color of that surrounding line. - |By default: RGB (0, 60, 116) (Dark blue) } - - property BlockSize : Integer read GetBlockSize write SetBlockSize; - {* TKOLQProgressBars can appear under the form of a continuous area or like "blocks" - separated by not-drawn spaces (where the background appears). - BlockSize defines the size of blocks in pixels. BlockSize and SpaceSize are ignored if - one of them is set to zero or set to a value greater than the internal available draw space. - |By default: 0. } - - property SpaceSize : Integer read GetSpaceSize write SetSpaceSize; - {* TKOLQProgressBars can appear under the form of a continuous area or like "blocks" - separated by not-drawn spaces (where the background appears). - SpaceSize defines the size of none drawn parts between two blocks in pixels. BlockSize and - SpaceSize are ignored if one of them is set to zero or set to a value greater than the internal - |available draw space. By default: 0. } - - property ShowFullBlock : Boolean read GetFullBlock write SetFullBlock; - {* If both BlockSize and SpaceSize have been defined, the bar will show an alternance - of blocks and spaces. In this case, if ShowFullBlock is set - |to True, each new block is drawn only when the position sent corresponds to - |the end of a block. If set to False, blocks are filled little by little. - |By default: False. } - - property HideOnTerminate : Boolean read GetHideOnTerm write SetHideOnTerm default False; - {* |If True, the bar will hide itself after it will receive a progress position - |equal to MaxProgress. In such a case, it will be up to you to show it again if you use it again: - !uses Windows, Messages, KOL, ..., KOLQProgBar; - ! //... - !var aPBar : PQProgressBar; - ! //... - !aPBar := NewQProgressBar( AParentForm ); - !aPBar.HideOnTerminate:= true; - !aPBar. ... - !// ... do something - !// ... our jobs finished and progress bar is hidden now - !// ... restore it with Progress:= 0 - !aPBar.Progress:= 0; - !aPBar.Show; - - |By default: False. } - - property CaptionAlign : TTextAlign read GetCapAlign write SetCapAlign; - {* Vertical alignment is always almost centered, this one is horizontal alignment, - |and can be taLeft, taCenter, taRight. - |By default: taLeft. } - - property AutoCaption : Boolean read GetCaptionOvr write SetCaptionOvr; - {* |Both caption and hint can be set to display automatically the value Progress. - |If True, Hint value is refreshed each time you send a new position and Caption - value is updated within the paint method. - |By default: False. } - - property AutoHint : Boolean read GetHintOvr write SetHintOvr; - {* |Both caption and hint can be set to display automatically the value Progress. - |If True, Hint value is refreshed each time you send a new position and Caption - value is updated within the paint method. For hint to show when your user moves it's mouse over your bar, - |you must add USE_MHTOOLTIP conditional symbol into the project options list and your KOLProject - |must have the ShowHint property set to True. By default: False. } - - property ShowPosAsPct : Boolean read GetShowPosAsPct write SetShowPosAsPct; - {* |If True, both Hint and Caption will show the last received position as - |a percentage of MaxProgress, followed by the string ' %'. - |By default: False. } - - property OnProgressChange: TOnQProgressBar read GetOnProgressChange write SetOnProgressChange; - {* | Called when Progress value is changed. } - - end; - -// ---------------------------------------------------------- -const - // NIH... Out a Microsoft knowledge base article, see below "RGBtoHLS" and "HLStoRGB" - HLSMAX = High(THLSRange); // H,L, and S vary over 0-HLSMAX - RGBMAX = 255; // R,G, and B vary over 0-RGBMAX - // HLSMAX BEST IF DIVISIBLE BY 6 - // RGBMAX, HLSMAX must each fit in a byte. - // Hue is undefined if Saturation is 0 (grey-scale) - // This value determines where the Hue scrollbar is - // initially set for achromatic colors - UNDEFINED = HLSMAX * 2 div 3; - -// ---------------------------------------------------------- -function NewQProgressBar( AParent: PControl ): PQProgressBar; -// ---------------------------------------------------------- - -implementation - -// ---------------------------------------------------------- -function QProgBar_WndProc( Control: PControl; var Msg: TMsg; var Rslt: Integer): Boolean; -var - PaintStruct: TPaintStruct; - ProgressBar: PQProgressBar; -begin - Result := False; - ProgressBar:= PQProgressBar( Control ); - case ( Msg.message ) of - WM_PAINT: - begin - BeginPaint( ProgressBar.Handle, PaintStruct ); - ProgressBar.Paint; - //Result:= True; - //Rslt:= 0; - EndPaint( ProgressBar.Handle, PaintStruct ); - end; - WM_SIZE: - ProgressBar.Resize; - PBM_GETPOS: - begin - Rslt:= ProgressBar.GetPosition; - Result:= true; - end; - PBM_SETPOS: - begin - Rslt:= ProgressBar.GetPosition; - if ( Msg.wParam > 0 ) then - ProgressBar.SetPosition( Msg.wParam ) - else - ProgressBar.SetPosition( 0 ); - with PQDataObj( ProgressBar.CustomObj )^ do - if Assigned( fOnProgChange ) then - fOnProgChange( ProgressBar ); - Result := true; - end; - PBM_GETRANGE: - begin - if ( Msg.wParam ) > 0 then - Rslt:= 0 - else - Rslt:= ProgressBar.GetMaxPos; - Result:= true; - end; - PBM_SETRANGE: - begin - ProgressBar.SetMaxPos( Hi(Msg.lParam) ); - Result:= true; - end; - PBM_SETRANGE32: - begin - ProgressBar.SetMaxPos( Msg.lParam ); - Result:= true; - end; - end; // case -end; - -// ---------------------------------------------------------- -function NewQProgressBar( AParent: PControl ): PQProgressBar; -var - Data: PQDataObj; -begin - Result := PQProgressBar( _NewControl( AParent, 'QProgressBar', - WS_VISIBLE + WS_CHILD + SS_NOTIFY, False, {$IFDEF PACK_COMMANDACTIONS}@LabelActions_Packed{$ELSE}@LabelActions{$ENDIF} ) ); - - New( Data, Create ); // releases authomatically when the object destroys - Result.CustomObj := Data; - - with Data^ do - begin - SetLength( fPosDescr, 1 ); - fPosDescr[0].isInBlock := False; - fByBlock := False; - fFullBlock := False; - fBlockSize := 0; - fSpaceSize := 0; - fOrientation := boHorizontal; - fBarKind := bkFlat; - fBarLook := blMetal; - fPosition := 0; - fHasShape := True; - fShapeClr := RGB (0, 60, 116); - fStartClr := clLime; - fFinalClr := clLime; - fMonoClr := True; - fBkgClr := clWhite; - fShowInactPos := False; - fInactPosClr := clGray; - fInvInactPos := False; - fMaxPos := 100; - fInternalBorder:= 2; - fBorderSize := 4; - with Result^ do - begin - SetUsefullWidth; - InitPixArray; - end; - fCorner := 5; - fCapPos.X := 0; - fCapPos.Y := 0; - fHasCaption := False; - fCaptionOvr := False; - fHintOvr := False; - fShowPosAsPct := False; - fUserPos:= 0; - end; - - with Result^ do - begin - TabStop:= False; - Caption:= ''; - Enabled:= True; - Width:= 200; - Height:= 20; - DoubleBuffered:= true; - end; - - Result.AttachProc( QProgBar_WndProc ); -end; - - -// ---------------------------------------------------------- -procedure TQProgressBar.InitBlockArray; -// fPosDescr[n] describes each possible position, storing : -// - wether it is in a block or not ; <- drawing blocks instead of a continuous line -// - what is the block limit for this position; <- (if full blocks only are to be drawn, then -// only those which limit is below(H) above(V) current position will be drawn.) -// Computed on size/resize and blocks/space sizes changes only, to avoid computations at runTime. -var i, - blkStart, - blkStop : Integer; - D: PQDataObj; -begin - D:= PQDataObj( CustomObj ); - if ( D.fBlockSize = 0 ) or ( D.fSpaceSize = 0 ) then Exit; - - if ( D.fUSefullDrawSpace <= 0 ) then - SetLength( D.fPosDescr, 1 ) // Position 0 is always False - else SetLength( D.fPosDescr, D.fUSefullDrawSpace + 1 ); - - case ( D.fOrientation ) of - boHorizontal : - begin - D.fPosDescr[0].isInBlock := False; - blkStart := 3; - blkStop := blkStart + D.fBlockSize -1 ; - with D^ do - for i := 1 to High( fPosDescr ) do - begin - fPosDescr[i].isInBlock := (i >= blkStart) and (i <= blkStop); - fPosDescr[i].blkLimit := blkStop; - if ( i = blkStop ) then - begin - blkStart := blkStop + fSpaceSize + 1; - blkStop := blkStart + fBlockSize - 1; - if blkStop > High( fPosDescr ) then blkStop := High( fPosDescr ); - end; - end; - end; {boHrz} - else // boVertical; "Else" avoids compiler warnings - begin - D.fPosDescr[High( D.fPosDescr )].isInBlock := False; - blkStart := High( D.fPosDescr ) - 3; - blkStop := blkStart - D.fBlockSize + 1 ; - with D^ do - for i := D.fUSefullDrawSpace downto D.fBorderSize do - begin - fPosDescr[i].isInBlock := (i <= blkStart) and (i >= blkStop); - fPosDescr[i].blkLimit := blkStop; - if ( i = blkStop ) then - begin - blkStart := blkStop - fSpaceSize - 1; - blkStop := blkStart - fBlockSize + 1; - if ( blkStop < fBorderSize ) then blkStop := fBorderSize; - end; - end; - end; {boVert} - end; {case} -end; - -// ---------------------------------------------------------- -procedure TQProgressBar.InitPixArray; -// Compute and stores each pixel color, in the case of a gradient, or a double -// gradient (both directions) in order to speed up things at run time. -var i, j, - rowSz : integer; - clr : TColor; - HLSr : THLSRec; - D: PQDataObj; -begin - D:= PQDataObj( CustomObj ); - - with D^ do - case ( fOrientation ) of - boHorizontal : rowSz := Height - (fBorderSize) + 1; - else rowSz := Width - (fBorderSize) + 1; // boVertical; - end; {Case} - - with D^ do - if ( fUSefullDrawSpace <= 0 ) then - SetLength( fPixDescr, 1) // Position 0 is allways False - else SetLength( fPixDescr, fUSefullDrawSpace + 1); - - // Populates active positions colors array ; - // -> GetColorBetween works on the horizontal gradient, in the case of a - // boHorizontal bar, with two colors (or on the vertical one, if the - // bar is vertical). - // -> GetGradientAr2 then returns the row gradient, based upon the header - // pixel value for that row in order to give the cylinder appearance. - - with D^ do - for i := 0 to fUSefullDrawSpace do - begin - clr := GetColorBetween( fStartClr, fFinalClr, (i), 0, fUSefullDrawSpace ); - if ( fBarKind = bkCylinder ) then - fPixDescr[i] := GetGradientAr2( clr, rowSz ) - else - for j := 0 to rowSz -1 do - begin - SetLength( fPixDescr[i], rowSz); - fPixDescr[i, j] := clr; - end; - end; - - // inactive positions decription, used in case 'showInactive positions' is true; - with D^ do - if ( ( Height - fBorderSize ) <= 0 ) then - begin - SetLength( fInactDescr, 1 ); - fInactDescr[0] := fInactPosClr; - end - else - begin - if ( fBarKind = bkCylinder ) then - fInactDescr := GetGradientAr2( fInactPosClr, rowSz ) - else - begin - SetLength( fInactDescr,rowSz ); - for j := 0 to rowSz - 1 do - fInactDescr[j] := fInactPosClr; - end; - end; - - // case cylindric bar : the background can be basically reversed. - with D^ do - if ( ( fBarKind = bkCylinder ) and ( fInvInactPos ) ) then - for i := 0 to rowSz - 1 do - begin - HLSr := RGBtoHLS( fInactDescr[i] ); - HLSr.lum := 240 - HLSr.lum; - fInactDescr[i] := HLStoRGB(HLSr.hue, HLSr.lum, HLSr.sat); - end; - -end; - -// ---------------------------------------------------------- -function TQProgressBar.MakeCylinder( h: real): Extended; // NIH -// (c) Matthieu Contensou (http://www25.brinkster.com/waypointfrance/cpulog/index.asp) -// who computed the polynome used to provide the "cylinder" appearence to bars : -// "f (h) = -4342,9 h^5 + 10543 h^4 - 8216 h^3 + 2018,1 h^2 + 11,096 h + 164,6" -// "h is the order of the wanted pixel in a column (horizontal bar), or in -// a row (vertical bar), with a value between 0 and 1 (0 -> 100%)" -begin - Result := ( (-4342.9 * ( IntPower(h, 5) ) ) - + ( 10543 * ( IntPower(h, 4) ) ) - - ( 8216 * ( IntPower(h, 3) ) ) - + ( 2018.1 * ( IntPower(h, 2) ) ) - + ( 11.096 * h ) + 164.6 ) ; -end; - -// ---------------------------------------------------------- -function TQProgressBar.GetGradientAr2( aColor: TColor; sz: Integer): TClrArray; -// Version corrected by Bernd Kirchhoff (http://home.germany.net/100-445474/) -// Returns an array of size sz, filled up with a basic gradient; Used to -// provide the "cylindric" appearance. -var i,RP: Integer; - HLSr: THLSRec; - D: PQDataObj; -begin - D:= PQDataObj( CustomObj ); - SetLength( Result, sz ); - for i := 0 to sz - 1 do - begin - HLSr := RGBtoHLS(aColor); - // (c) Bernd Kirchhoff >>>-------------------------------------------------- - if ( D.fBarLook = blGlass ) then - HLSr.lum := Round( MakeCylinder( (i / sz)) ) - else - begin - rp:= HLSr.lum - 212; - rp:= rp + Trunc( MakeCylinder( i / sz) ); - if ( rp < 0 ) then rp:= 0; - if ( rp > 240 ) then rp:= 240; - HLSr.lum :=rp; - end; - // <<<----------------------------------------------------------------------- - Result[i] := HLStoRGB(HLSr.hue, HLSr.lum, HLSr.sat); - end; -end; - -// ---------------------------------------------------------- -function TQProgressBar.RGBtoHLS(RGBColor: TColor): THLSRec; // NIH -// (c) Microsoft. http://support.microsoft.com/default.aspx?scid=kb;en-us;29240 -// This is the translation of a Microsoft knowledge base article, pubilshed -// under number Q29240. Msft's knowledge base has a lot of interesting articles. - -//(knowledge base = http://support.microsoft.com/default.aspx?scid=FH;EN-US;KBHOWTO) - -var - R, G, B: Integer; // input RGB values - H, L, S: Integer; - cMax, cMin: Byte; // max and min RGB values - Rdelta, Gdelta, Bdelta: Integer; // intermediate value: % of spread from max -begin - // get R, G, and B out of DWORD - R := GetRValue(RGBColor); - G := GetGValue(RGBColor); - B := GetBValue(RGBColor); - - // calculate lightness - cMax := max( max(R,G), B); - cMin := min( min(R,G), B); - L := ( ( (cMax+cMin) * HLSMAX) + RGBMAX ) div (2*RGBMAX); - - if (cMax = cMin) then // r=g=b --> achromatic case - begin - S := 0; // saturation - H := UNDEFINED; // hue - end else - begin // chromatic case - if (L <= (HLSMAX div 2) ) // saturation - then S := ( ( (cMax-cMin) * HLSMAX ) + ( (cMax+cMin) div 2) ) div (cMax+cMin) - else S := ( ( (cMax-cMin) * HLSMAX ) + ( (2*RGBMAX-cMax-cMin) div 2) ) div (2*RGBMAX-cMax-cMin); - // hue - Rdelta := ( ( (cMax-R) * (HLSMAX div 6) ) + ((cMax-cMin) div 2) ) div (cMax-cMin); - Gdelta := ( ( (cMax-G) * (HLSMAX div 6) ) + ((cMax-cMin) div 2) ) div (cMax-cMin); - Bdelta := ( ( (cMax-B) * (HLSMAX div 6) ) + ((cMax-cMin) div 2) ) div (cMax-cMin); - - if R = cMax then H := Bdelta - Gdelta - else if G = cMax then H := (HLSMAX div 3) + Rdelta - Bdelta - else {B=cMax} H := ( (2*HLSMAX) div 3) + Gdelta - Rdelta; - if (H < 0) then H := H + HLSMAX; - if (H > HLSMAX) then H := H - HLSMAX; - end; - - Result.Hue := H; - Result.Lum := L; - Result.Sat := S; -end; - -// ---------------------------------------------------------- -function TQProgressBar.HLStoRGB( hue, lum, sat: THLSRange): TColor; // NIH -// (c) Microsoft. http://support.microsoft.com/default.aspx?scid=kb;en-us;29240 -var - R,G,B : Integer; // RGB component values - Magic1,Magic2: Integer; // calculated magic numbers (really!) - - - { ----------------- LOCAL -----------------} - - function HueToRGB(n1, n2, hue: Integer): Integer; // (c) Microsoft. - // utility routine for HLStoRGB - begin - // range check: note values passed add/subtract thirds of range - if hue < 0 then Inc(hue, HLSMAX) - else if hue > HLSMAX then Dec(hue, HLSMAX); - - (* return r,g, or b value from this tridrant *) - if ( hue < (HLSMAX div 6) ) - then result := ( n1 + ( ( (n2-n1) * hue + (HLSMAX div 12) ) div (HLSMAX div 6) ) ) - else if hue < (HLSMAX div 2) - then result := n2 - else if hue < ( (HLSMAX*2) div 3 ) - then result := ( n1 + ( ( (n2-n1) * ( ( (HLSMAX*2) div 3 ) - hue ) - + (HLSMAX div 12) ) div (HLSMAX div 6) ) ) - else result := n1; - end; {HueToRGB} - - { ----------------- \LOCAL\ -----------------} - -begin - if ( Sat = 0 ) then // achromatic case - begin - R := (Lum*RGBMAX) div HLSMAX; - G := R; - B := R; - if not( Hue = UNDEFINED ) then - begin - // ...trap impossible conversions (?)... - end; - end else - begin // chromatic case - if (Lum <= (HLSMAX div 2)) // set up magic numbers - then Magic2 := ( Lum * ( HLSMAX + Sat ) + ( HLSMAX div 2 ) ) div HLSMAX - else Magic2 := Lum + Sat - ( (Lum * Sat) + ( HLSMAX div 2 ) ) div HLSMAX; - Magic1 := 2*Lum - Magic2; - - // get RGB, change units from HLSMAX to RGBMAX - R := ( HueToRGB( Magic1, Magic2, Hue + ( HLSMAX div 3 ) ) * RGBMAX + ( HLSMAX div 2) ) div HLSMAX; - G := ( HueToRGB( Magic1, Magic2, Hue )* RGBMAX +(HLSMAX div 2 ) ) div HLSMAX; - B := ( HueToRGB( Magic1, Magic2, Hue - ( HLSMAX div 3 ) ) * RGBMAX + ( HLSMAX div 2) ) div HLSMAX; - end; - Result := RGB(R ,G, B); -end; - -// ---------------------------------------------------------- -function TQProgressBar.GetColorBetween( AStartColor, AEndColor: TColor; PointValue, - Von, Bis : Extended ): TColor; // NIH -// Found on efg's colors pages, at http://homepages.borland.com/efg2lab/Library/Delphi/Graphics/Color.htm -// "Color gradient" row, cworn's UseNet Post. -// Author is unknown, but remains holder for intellectual property. -// High speed function which returns the gradient color value for a pixel depending -// on start and final color, size of the gradient area , and the place of the current pixel; - -var - F: Extended; r1, r2, r3, g1, g2, g3, b1, b2, b3: Byte; - - { ----------------- LOCAL -----------------} - function CalcColorBytes(fb1, fb2: Byte): Byte; - begin - Result := fb1; - if ( fb1 < fb2 ) then Result := FB1 + Trunc( F * (fb2 - fb1) ); - if ( fb1 > fb2 ) then Result := FB1 - Trunc( F * (fb1 - fb2) ); - end; - { ----------------- \LOCAL\ -----------------} - -begin - if ( PQDataObj( CustomObj ).fMonoClr ) or ( PointValue <= Von ) then - begin - Result := AStartColor; - Exit; - end; - if ( PointValue >= Bis ) then - begin - Result := AEndColor; - Exit; - end; - F := (PointValue - Von) / (Bis - Von); - asm - mov EAX, AStartColor - cmp EAX, AEndColor - je @@exit - mov r1, AL - shr EAX,8 - mov g1, AL - shr Eax,8 - mov b1, AL - mov Eax, AEndColor - mov r2, AL - shr EAX,8 - mov g2, AL - shr EAX,8 - mov b2, AL - push ebp - mov al, r1 - mov dl, r2 - call CalcColorBytes - pop ecx - push ebp - Mov r3, al - mov dL, g2 - mov al, g1 - call CalcColorBytes - pop ecx - push ebp - mov g3, Al - mov dL, B2 - mov Al, B1 - call CalcColorBytes - pop ecx - mov b3, al - XOR EAX,EAX - mov AL, B3 - SHL EAX,8 - mov AL, G3 - SHL EAX,8 - mov AL, R3 -@@Exit: - mov @result, eax - end; -end; - -// ---------------------------------------------------------- -procedure TQProgressBar.Paint; -// Main loop. Called each time a setting changes, notably, each time -// a new position is sent. -// Surround is drawn first, then the bar itself. Caption is added lastly (if needed). - -var i,k,sp: Integer; - OldBkMode : Integer; - D: PQDataObj; -begin - D:= PQDataObj( CustomObj ); - - with Canvas^ do - begin - Brush.Color:= Parent.Color; - FillRect( MakeRect(0, 0, Width, Height )); - - // -1- Bevel - if ( D.fHasShape ) then - begin - Pen.PenWidth := 1; - Brush.BrushStyle := bsSolid; - Brush.Color:= Parent.Color; - FillRect( MakeRect(0, 0, Width, Height )); - Brush.Color := D.fBkgClr; - Pen.Color := D.fShapeClr; - RoundRect (0, 0, Width, Height, D.fCorner, D.fCorner); - end; - end; - - // -2- The bar itself - case D.fOrientation of - boHorizontal : - begin - for i := ( D.fBorderSize - 1 ) to D.fPosition do - begin - if ( D.fByBlock ) then - begin - if ( D.fPosDescr[i].isInBlock = true) then - begin - if ( (D.fFullBlock) and (D.fPosition >= D.fPosDescr[i].blkLimit) ) - or not( D.fFullBlock ) then - for k := (D.fBorderSize - 1) to (Height - (D.fBorderSize)) - do Canvas.Pixels [i,k] := D.fPixDescr[i,k] - else if (D.fShowInactPos) then - for k := (D.fBorderSize - 1) to (Height -(D.fBorderSize)) - do Canvas.Pixels [i,k] := D.fInactDescr[k]; - end; - end else - begin - for k := (D.fBorderSize - 1) to (Height -(D.fBorderSize)) do - Canvas.Pixels [i,k] := D.fPixDescr[i,k]; - end; - end; - // Now dealing with inactive positions, if they're to be drawn. - if ( D.fShowInactPos ) then - begin - if (D.fPosition < 3) then sp := 3 - else sp := D.fPosition + 1; - for i := sp to D.fUSefullDrawSpace do - begin - if (D.fByBlock) then - begin - if (D.fPosDescr[i].isInBlock = True) then - begin - for k := (D.fBorderSize -1) to (Height -(D.fBorderSize)) do - Canvas.Pixels [i,k] := D.fInactDescr[k]; - end; - end else //If not(byBlock), all pixels must be drawn - begin - for k := (D.fBorderSize - 1) to (Height -(D.fBorderSize)) do - Canvas.Pixels [i,k] := D.fInactDescr[k]; - end; - end; {for} - end; {inactive} - end; {boHorizontal} - boVertical : - begin - for i := (D.fUSefullDrawSpace-1) downto Height - D.fPosition do - begin - if (D.fByBlock) then - begin - if (D.fPosDescr[i].isInBlock = true) then - begin - if ( (D.fFullBlock) and ((Height - D.fPosition) <= D.fPosDescr[i].blkLimit) ) - or not( D.fFullBlock ) then - for k := (D.fBorderSize - 1 ) to (Width - (D.fBorderSize)) - do Canvas.Pixels [k,i] := D.fPixDescr[i,k] - else if ( D.fShowInactPos ) then - for k := (D.fBorderSize - 1) to (Width -(D.fBorderSize)) - do Canvas.Pixels [k,i] := D.fInactDescr[k]; - end; - end - else - for k := (D.fBorderSize - 1) to (Width -(D.fBorderSize)) - do Canvas.Pixels [k,i] := D.fPixDescr[i,k]; - end; - // inactive positions : - if (D.fShowInactPos) then - begin - if ( D.fPosition < 3 ) then sp := D.fUSefullDrawSpace - else sp := Height - D.fPosition - 1; - for i := sp downto D.fBorderSize do - begin - if ( D.fByBlock ) then - begin - if ( D.fPosDescr[i].isInBlock = true ) then - begin - for k := (D.fBorderSize - 1) to (Width -(D.fBorderSize)) do - Canvas.Pixels [k,i] := D.fInactDescr[k]; - end; - end else - for k := (D.fBorderSize - 1) to (Width -(D.fBorderSize)) - do Canvas.Pixels [k,i] := D.fInactDescr[k]; - end; {for... downto} - end; {inactive} - end; {boVertical} - end; // Case - - // caption management. The font is the canvas' one. Can be overrided - // using the Font property : - if ( D.fCaptionOvr ) then - begin - if ( D.fShowPosAsPct ) then SetCaption( Double2Str( D.fUSerPosPct ) + '%') - else SetCaption( Int2Str(D.fUSerPos) ); - end - else SetCaption( Caption ); - - if ( D.fHasCaption ) then - begin - OldBkMode := SetBkMode(Canvas.Handle, Windows.TRANSPARENT); - with Canvas^ do - begin - TextOut(D.fCapPos.X, D.fCapPos.Y, Caption); - end; - SetBkMode(Canvas.Handle, OldBkMode); - end; - -end; - -// ---------------------------------------------------------- -procedure TQProgressBar.Resize; -var - D: PQDataObj; -begin - D:= PQDataObj( CustomObj ); - D.fBorderSize := D.fInternalBorder shl 1; - SetUsefullWidth; - - if ( D.fByBlock ) then InitBlockArray; - InitPixArray; - SetPosition( D.fUserPos ); // position is computed, then bar is invalidated ; -end; - -// ---------------------------------------------------------- -procedure TQProgressBar.SetUsefullWidth; -var - D: PQDataObj; -begin - D:= PQDataObj( CustomObj ); - case ( D.fOrientation ) of - boHorizontal : D.fUSefullDrawSpace := ( Width - ( D.fBorderSize )); - boVertical : D.fUSefullDrawSpace := ( Height - ( D.fBorderSize )); - end; - D.fMinVisPos := D.fBorderSize + 1; -end; - -// ---------------------------------------------------------- -procedure TQProgressBar.SetFCorner( IsRounded:Boolean ); -var - D: PQDataObj; -begin - D:= PQDataObj( CustomObj ); - if ( IsRounded ) then D.fCorner := 5 - else D.fCorner := 0; - Invalidate; -end; - -// ---------------------------------------------------------- -function TQProgressBar.GetBoolCorner: Boolean; -begin - Result := ( PQDataObj( CustomObj ).fCorner > 0 ); -end; - -// ---------------------------------------------------------- -function TQProgressBar.GetBarKind: TQBarKind; -begin - Result:= PQDataObj( CustomObj ).fBarKind; -end; - -// ---------------------------------------------------------- -procedure TQProgressBar.SetBarKind( Value: TQBarKind ); -begin - PQDataObj( CustomObj ).fBarKind := Value; - InitPixArray; - Invalidate; -end; - -// ---------------------------------------------------------- -function TQProgressBar.GetBarLook: TQBarLook; -begin - Result:= PQDataObj( CustomObj ).fBarLook; -end; - -// ---------------------------------------------------------- -procedure TQProgressBar.SetBarLook( Value: TQBarLook ); -begin - PQDataObj( CustomObj ).fBarLook := Value; - InitPixArray; - Invalidate; -end; - -// ---------------------------------------------------------- -function TQProgressBar.GetOrientation: TQBarOrientation; -begin - Result:= PQDataObj( CustomObj ).fOrientation; -end; - -// ---------------------------------------------------------- -procedure TQProgressBar.SetOrientation( Value: TQBarOrientation ); -var newH, - newW: Integer; - D: PQDataObj; -begin - D:= PQDataObj( CustomObj ); - if ( Value <> D.fOrientation ) then - begin - if ( ( Value = boVertical) and ( Height < Width) ) - or ( ( Value = boHorizontal) and ( Width < Height) ) - then - begin - newW := Height; - newH := Width; - Height := newH; - Width := newW; - end; - D.fOrientation := Value; - end; - case ( Value ) of - boHorizontal : if Height < 10 - then D.fInternalBorder := 1 - else D.fInternalBorder := 2; - boVertical : if Width < 10 - then D.fInternalBorder := 1 - else D.fInternalBorder := 2; - end; //Case - D.fBorderSize := D.fInternalBorder shl 1; - SetUsefullWidth; - InitBlockArray; - InitPixArray; - Invalidate; -end; - -// ---------------------------------------------------------- -function TQProgressBar.GetBkgColor: TColor; -begin - Result:= PQDataObj( CustomObj ).fBkgClr; -end; - -// ---------------------------------------------------------- -procedure TQProgressBar.SetBkgColor( aColor: TColor ); -begin - PQDataObj( CustomObj ).fBkgClr := aColor; - Invalidate; -end; - -// ---------------------------------------------------------- -procedure TQProgressBar.SetShape( Value: Boolean ); -begin - PQDataObj( CustomObj ).fHasShape := Value; - Invalidate; -end; - -// ---------------------------------------------------------- -function TQProgressBar.GetShape: Boolean; -begin - Result:= PQDataObj( CustomObj ).fHasShape; -end; - -// ---------------------------------------------------------- -procedure TQProgressBar.SetShapeColor( Value: TColor ); -begin - PQDataObj( CustomObj ).fShapeClr := Value; - Invalidate; -end; - -// ---------------------------------------------------------- -function TQProgressBar.GetShapeColor: TColor; -begin - Result:= PQDataObj( CustomObj ).fShapeClr; -end; - -// ---------------------------------------------------------- -procedure TQProgressBar.SetBlockSize( Value:Integer ); -var - D: PQDataObj; -begin - D:= PQDataObj( CustomObj ); - case D.fOrientation of - boHorizontal : if ( Value > Width - ( D.fInternalBorder shl 1 ) ) then Exit; - boVertical : if ( Value > Height - ( D.fInternalBorder shl 1) ) then Exit; - end; {case} - - D.fBlockSize := Abs(value); - D.fByBlock := (D.fBlockSize > 0) and (D.fSpaceSize > 0); - if ( D.fByBlock ) then InitBlockArray; - InitPixArray; - Invalidate; -end; - -// ---------------------------------------------------------- -function TQProgressBar.GetBlockSize: Integer; -begin - Result:= PQDataObj( CustomObj ).fBlockSize; -end; - -// ---------------------------------------------------------- -procedure TQProgressBar.SetSpaceSize( Value: Integer); -var - D: PQDataObj; -begin - D:= PQDataObj( CustomObj ); - case D.fOrientation of - boHorizontal : if ( Value > Width - (D.fInternalBorder SHL 1) ) then Exit; - boVertical : if ( Value > Height - (D.fInternalBorder SHL 1) ) then Exit; - end; {case} - - D.fSpaceSize := Abs(value); - D.fByBlock := ( D.fBlockSize > 0 ) and ( D.fSpaceSize > 0 ); - if ( D.fByBlock ) then InitBlockArray; - InitPixArray; - Invalidate; -end; - -// ---------------------------------------------------------- -function TQProgressBar.GetSpaceSize: Integer; -begin - Result:= PQDataObj( CustomObj ).fSpaceSize; -end; - -// ---------------------------------------------------------- -procedure TQProgressBar.SetFullBlock( Value:Boolean ); -begin - PQDataObj( CustomObj ).fFullBlock := Value; - if ( Value ) then InitBlockArray; - InitPixArray; - Invalidate; -end; - -// ---------------------------------------------------------- -function TQProgressBar.GetFullBlock: Boolean; -begin - Result:= PQDataObj( CustomObj ).fFullBlock; -end; - -// ---------------------------------------------------------- -procedure TQProgressBar.SetMaxPos( Value: Integer ); -var - D: PQDataObj; -begin - D:= PQDataObj( CustomObj ); - if ( Value < 0 ) then D.fMaxPos := 0 - else D.fMaxPos := Value; - SetPosition( D.fUserPos ); -end; - -// ---------------------------------------------------------- -function TQProgressBar.GetMaxPos: Integer; -begin - Result:= PQDataObj( CustomObj ).fMaxPos; -end; - -// ---------------------------------------------------------- -procedure TQProgressBar.SetPosition( Value: Integer ); -var - tmpfPos : Real; D: PQDataObj; -begin - D:= PQDataObj( CustomObj ); - D.fUserPos := Value; - if ( D.fMaxPos = 0 ) then Exit; - try - if ( Value <= 0 ) then - begin - D.fPosition := 0; - Exit; - end - else if ( Value > D.fMaxPos ) then Value := D.fMaxPos; - - D.fUSerPosPct := (100 * Value) / D.fMaxPos; - tmpfPos := D.fUsefullDrawSpace * D.fUSerPosPct / 100; - // If value( user position) > 0, make sure that at least one bar is visible - if ( tmpfPos > 0.00 ) and ( tmpfPos < D.fMinVisPos ) - then D.fPosition := D.fMinVisPos - else if tmpfPos > D.fUsefullDrawSpace - then D.fPosition := D.fUsefullDrawSpace - else D.fPosition := Round( tmpfPos ); - // Hint is managed here (whereas caption, which ahs to be painted, - // is managed in the paint() proc). - {$IFDEF USE_MHTOOLTIP} - if ( D.fHintOvr ) then - if ( D.fShowPosAsPct ) then Hint.Text := Double2Str( D.fUSerPosPct ) + ' %' - else Hint.Text := Int2Str( D.fUSerPos ); - {$ENDIF} - finally - Invalidate; - if ( ( D.fHideOnTerm ) and ( Value = D.fMaxPos ) ) then - begin - Sleep(100); - Hide; - end; - end; -end; - -// ---------------------------------------------------------- -function TQProgressBar.GetPosition: Integer; -begin - Result:= PQDataObj( CustomObj ).fUserPos; -end; - -// ---------------------------------------------------------- -procedure TQProgressBar.SetStartClr( Value: TColor); -var - D: PQDataObj; -begin - D:= PQDataObj( CustomObj ); - D.fStartClr := Value; - D.fMonoClr := ( D.fStartClr = D.fFinalClr ); - InitPixArray; - Invalidate; -end; - -// ---------------------------------------------------------- -function TQProgressBar.GetStartClr: TColor; -begin - Result:= PQDataObj( CustomObj ).fStartClr; -end; - -// ---------------------------------------------------------- -procedure TQProgressBar.SetFinalClr( Value: TColor ); -var - D: PQDataObj; -begin - D:= PQDataObj( CustomObj ); - D.fFinalClr := Value; - D.fMonoClr := ( D.fStartClr = D.fFinalClr ); - InitPixArray; - Invalidate; -end; - -// ---------------------------------------------------------- -function TQProgressBar.GetFinalClr: TColor; -begin - Result:= PQDataObj( CustomObj ).fFinalClr; -end; - -// ---------------------------------------------------------- -procedure TQProgressBar.SetBothColors( Value: TColor ); -var - D: PQDataObj; -begin - D:= PQDataObj( CustomObj ); - D.fMonoClr := True; - D.fStartClr := Value; - D.fFinalClr := Value; - InitPixArray; - Invalidate; -end; - -// ---------------------------------------------------------- -function TQProgressBar.GetInactivePos: Boolean; -begin - Result:= PQDataObj( CustomObj ).fShowInactPos; -end; - -// ---------------------------------------------------------- -procedure TQProgressBar.SetInactivePos( Value: Boolean ); -begin - PQDataObj( CustomObj ).fShowInactPos := Value; - InitPixArray; - Invalidate; -end; - -// ---------------------------------------------------------- -function TQProgressBar.GetInactPosClr: TColor; -begin - Result:= PQDataObj( CustomObj ).fInactPosClr; -end; - -// ---------------------------------------------------------- -procedure TQProgressBar.SetInactPosClr( Value: TColor ); -begin - PQDataObj( CustomObj ).fInactPosClr := Value; - InitPixArray; - Invalidate; -end; - -// ---------------------------------------------------------- -procedure TQProgressBar.SetHideOnTerm( Value: Boolean ); -begin - PQDataObj( CustomObj ).fHideOnTerm:= Value; -end; - -// ---------------------------------------------------------- -function TQProgressBar.GetHideOnTerm: Boolean; -begin - Result:= PQDataObj( CustomObj ).fHideOnTerm; -end; - -// ---------------------------------------------------------- -function TQProgressBar.GetInvInactPos: Boolean; -begin - Result:= PQDataObj( CustomObj ).fInvInactPos; -end; - -// ---------------------------------------------------------- -procedure TQProgressBar.SetInvInactPos( Value: Boolean); -// invert Inactive Positions lum. -begin - PQDataObj( CustomObj ).fInvInactPos := Value; - InitPixArray; - Invalidate; -end; - -// ---------------------------------------------------------- -procedure TQProgressBar.SetCaption( Value: string ); -var - D: PQDataObj; -begin - D:= PQDataObj( CustomObj ); - Caption := Value; - D.fHasCaption := not( Value = '' ); - - if ( D.fHasCaption ) then - begin - //-1- Centering vertically - D.fCapPos.Y := ( Height - Canvas.textHeight( 'Pg' ) ) div 2 ; - case ( D.fCapAlign ) of - taLeft: - begin - D.fCapPos.X := 0; - end; - taCenter: - begin - D.fCapPos.X := ( Width - Canvas.textWidth( Value ) ) div 2; - end; - else begin //right alignment; -taRight- - D.fCapPos.X := ( Width - Canvas.textWidth( value ) ) -1 ; - end; - end; {case} - end; -end; - -// ---------------------------------------------------------- -function TQProgressBar.GetCapAlign: TTextAlign; -begin - Result:= PQDataObj( CustomObj ).fCapAlign; -end; - -// ---------------------------------------------------------- -procedure TQProgressBar.SetCapAlign( Value: TTextAlign ); -var - D: PQDataObj; -begin - D:= PQDataObj( CustomObj ); - D.fCapAlign := Value; - Invalidate; -end; - -// ---------------------------------------------------------- -function TQProgressBar.GetCaptionOvr: Boolean; -begin - Result:= PQDataObj( CustomObj ).fCaptionOvr; -end; - -// ---------------------------------------------------------- -procedure TQProgressBar.SetCaptionOvr( Value:Boolean ); -begin - PQDataObj( CustomObj ).fCaptionOvr := Value; - Invalidate; -end; - -// ---------------------------------------------------------- -function TQProgressBar.GetHintOvr: Boolean; -begin - Result:= PQDataObj( CustomObj ).fHintOvr; -end; - -// ---------------------------------------------------------- -procedure TQProgressBar.SetHintOvr( Value: Boolean ); -begin - PQDataObj( CustomObj ).fHintOvr:= Value; -end; - -// ---------------------------------------------------------- -procedure TQProgressBar.SetShowPosAsPct( Value: Boolean ); -begin - PQDataObj( CustomObj ).fShowPosAsPct:= Value; -end; - -// ---------------------------------------------------------- -function TQProgressBar.GetShowPosAsPct: Boolean; -begin - Result:= PQDataObj( CustomObj ).fShowPosAsPct; -end; - -// ---------------------------------------------------------- -function TQProgressBar.GetOnProgressChange: TOnQProgressBar; -begin - Result:= PQDataObj( CustomObj ).fOnProgChange; -end; - -// ---------------------------------------------------------- -procedure TQProgressBar.SetOnProgressChange( const Value: TOnQProgressBar ); -begin - PQDataObj( CustomObj ).fOnProgChange:= Value; -end; - -// ---------------------------------------------------------- -destructor TQDataObj.Destroy; -begin - @fOnProgChange:= nil; - SetLength( fPosDescr, 0); - SetLength( fPixDescr, 0); - inherited; -end; - -// ---------------------------------------------------------- - - -end. - diff --git a/Addons/KOLRarBar.pas b/Addons/KOLRarBar.pas deleted file mode 100644 index c690a5a..0000000 --- a/Addons/KOLRarBar.pas +++ /dev/null @@ -1,410 +0,0 @@ -unit KOLRarBar; - -interface - -uses Windows, Messages, Kol, Objects; - -type - PRarBar = ^TRarBar; - TRarInfoBar = PRarBar; - TRarBar = object(TObj) - private - { Private declarations } - FControl: PControl; - FPosition: integer; - FShowPerc: boolean; - FFont: PGraphicTool; - - FLineColor,FTopColor,FSideColor1,FSideColor2,FEmptyColor1,FEmptyColor2, - FEmptyFrameColor1,FEmptyFrameColor2,FBottomFrameColor,FBottomColor, - FFilledFrameColor,FFilledColor,FFilledSideColor1,FFilledSideColor2: TColor; - - TopX,TopY,Size: integer; - - FMin,FMax: integer; - OldWind,NewWind: integer; - procedure SetPos(P: integer); - procedure SetMin(M: integer); - procedure SetMax(M: integer); - procedure SetFont(F: PGraphicTool); - - procedure SetLineColor(C: TColor); - procedure SetTopColor(C: TColor); - procedure SetSideColor1(C: TColor); - procedure SetSideColor2(C: TColor); - procedure SetEmptyColor1(C: TColor); - procedure SetEmptyColor2(C: TColor); - procedure SetEmptyFrameColor1(C: TColor); - procedure SetEmptyFrameColor2(C: TColor); - procedure SetBottomFrameColor(C: TColor); - procedure SetBottomColor(C: TColor); - procedure SetFilledFrameColor(C: TColor); - procedure SetFilledColor(C: TColor); - procedure SetFilledSideColor1(C: TColor); - procedure SetFilledSideColor2(C: TColor); - procedure SetShowPerc(V: boolean); - protected - { Protected declarations } - procedure NewWndProc(var Msg: TMessage); - procedure Paint; - public - destructor Destroy; virtual; - function SetPosition(X,Y: integer): PRarBar; overload; - function SetSize(X,Y: integer): PRarBar; overload; - function SetAlign(A: TControlAlign): PRarBar; overload; - { Public declarations } - property Position: integer read FPosition write SetPos; - property Max: integer read FMax write SetMax; - property Min: integer read FMin write SetMin; - property ShowPercent: boolean read FShowPerc write SetShowPerc; - property Font: PGraphicTool read FFont write SetFont; - - property LineColor: TColor read FLineColor write SetLineColor; - property TopColor: TColor read FTopColor write SetTopColor; - property SideColor1: TColor read FSideColor1 write SetSideColor1; - property SideColor2: TColor read FSideColor2 write SetSideColor2; - property EmptyColor1: TColor read FEmptyColor1 write SetEmptyColor1; - property EmptyColor2: TColor read FEmptyColor2 write SetEmptyColor2; - property EmptyFrameColor1: TColor read FEmptyFrameColor1 write SetEmptyFrameColor1; - property EmptyFrameColor2: TColor read FEmptyFrameColor2 write SetEmptyFrameColor2; - property BottomFrameColor: TColor read FBottomFrameColor write SetBottomFrameColor; - property BottomColor: TColor read FBottomColor write SetBottomColor; - property FilledFrameColor: TColor read FFilledFrameColor write SetFilledFrameColor; - property FilledColor: TColor read FFilledColor write SetFilledColor; - property FilledSideColor1: TColor read FFilledSideColor1 write SetFilledSideColor1; - property FilledSideColor2: TColor read FFilledSideColor2 write SetFilledSideColor2; - end; - -function NewTRarInfoBar(AOwner: PControl): PRarBar; - -implementation - -function NewTRarInfoBar; -var P: PRarBar; - C: PControl; -begin - C:=pointer(_NewControl(AOwner,'STATIC',WS_VISIBLE or WS_CHILD or SS_LEFTNOWORDWRAP or SS_NOPREFIX or SS_NOTIFY,False,nil)); - C.CreateWindow; - New(P,Create); - AOwner.Add2AutoFree(P); - AOwner.Add2AutoFree(C); - P.FControl:=C; - P.FFont:=NewFont; - P.FFont.Color:=clPurple; - P.FFont.FontHeight:=-11; - P.FFont.FontName:=C.Font.FontName; - P.FFont.FontStyle:=[fsBold]; - P.FLineColor:=$FFE0E0; - P.FTopColor:=$FF8080; - P.FSideColor1:=$E06868; - P.FSideColor2:=$FF8080; - P.FEmptyFrameColor1:=$A06868; - P.FEmptyFrameColor2:=$BF8080; - P.FEmptyColor1:=$C06868; - P.FEmptyColor2:=$DF8080; - P.FBottomFrameColor:=$64408C; - P.FBottomColor:=$7A408C; - P.FFilledFrameColor:=$8060A0; - P.FFilledSideColor1:=$823C96; - P.FFilledSideColor2:=$8848C0; - P.FFilledColor:=$A060A0; - P.FShowPerc:=True; - P.FMin:=0; - P.FMax:=100; - P.FPosition:=0; - C.SetSize(70,180); - Result:=P; - P.OldWind:=GetWindowLong(C.Handle,GWL_WNDPROC); - P.NewWind:=integer(MakeObjectInstance(P.NewWndProc)); - SetWindowLong(C.Handle,GWL_WNDPROC,P.NewWind); -end; - -destructor TRarBar.Destroy; -begin - SetWindowLong(FControl.Handle,GWL_WNDPROC,OldWind); - FreeObjectInstance(Pointer(NewWind)); - inherited; -end; - -function TRarBar.SetPosition(X,Y: integer): PRarBar; -begin - FControl.Left:=X; - FControl.Top:=Y; - Result:=@Self; -end; - -function TRarBar.SetSize(X,Y: integer): PRarBar; -begin - FControl.Width:=X; - FControl.Height:=Y; - Result:=@Self; -end; - -function TRarBar.SetAlign(A: TControlAlign): PRarBar; -begin - FControl.Align:=A; - Result:=@Self; -end; - -procedure TRarBar.NewWndProc; -begin - Msg.Result:=CallWindowProc(Pointer(OldWind),FControl.Handle,Msg.Msg,Msg.wParam,Msg.lParam); - case Msg.Msg of - WM_PAINT : Paint; - WM_SIZE : Paint; - WM_ACTIVATE: Paint; - end; -end; - -procedure TRarBar.SetFont(F: PGraphicTool); -begin - FFont.Assign(F); - Paint; -end; - -procedure TRarBar.SetMin; -begin - if M>FMax then M:=FMax; - FMin:=M; - Paint; -end; - -procedure TRarBar.SetMax; -begin - if MFMax 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. - diff --git a/Addons/KOLRarProgBar.pas b/Addons/KOLRarProgBar.pas deleted file mode 100644 index e0263a7..0000000 --- a/Addons/KOLRarProgBar.pas +++ /dev/null @@ -1,377 +0,0 @@ -////////////////////////////////////////////////////////////////////// -// // -// TRarProgressBar version 1.0 // -// Description: TRarProgressBar is a component which // -// displays dual progress bar like a WinRAR // -// Author: Dimaxx // -// // -////////////////////////////////////////////////////////////////////// - -unit KOLRarProgBar; - -interface - -uses Windows, Messages, Kol, Objects; - -type - PRarProgBar =^TRarProgBar; - TRarProgressBar = PRarProgBar; - TRarProgBar = object(TObj) - private - { Private declarations } - FControl: PControl; - FPosition1: integer; - FPosition2: integer; - FPercent1,FPercent2: integer; - FDouble: boolean; - B: PBitmap; - - FLightColor1,FDarkColor,FLightColor2,FFrameColor1,FFrameColor2, - FFillColor1,FFillColor2,FBackFrameColor1,FBackFrameColor2, - FBackFillColor,FShadowColor: TColor; - - TopX,TopY,SizeX,SizeY: integer; - - FMin,FMax: integer; - OldWind,NewWind: integer; - procedure SetPos1(P: integer); - procedure SetPos2(P: integer); - procedure SetMin(M: integer); - procedure SetMax(M: integer); - procedure SetDouble(D: boolean); - - procedure SetLightColor1(C: TColor); - procedure SetLightColor2(C: TColor); - procedure SetDarkColor(C: TColor); - procedure SetFrameColor1(C: TColor); - procedure SetFrameColor2(C: TColor); - procedure SetFillColor1(C: TColor); - procedure SetFillColor2(C: TColor); - procedure SetBackFrameColor1(C: TColor); - procedure SetBackFrameColor2(C: TColor); - procedure SetBackFillColor(C: TColor); - procedure SetShadowColor(C: TColor); - protected - { Protected declarations } - procedure NewWndProc(var Msg: TMessage); - procedure Paint; - public - destructor Destroy; virtual; - function SetPosition(X,Y: integer): PRarProgBar; overload; - function SetSize(X,Y: integer): PRarProgBar; overload; - function SetAlign(A: TControlAlign): PRarProgBar; overload; - { Public declarations } - property Position1: integer read FPosition1 write SetPos1; - property Position2: integer read FPosition2 write SetPos2; - property Percent1: integer read FPercent1; - property Percent2: integer read FPercent2; - property Max: integer read FMax write SetMax; - property Min: integer read FMin write SetMin; - property Double: boolean read FDouble write SetDouble; - - property LightColor1: TColor read FLightColor1 write SetLightColor1; - property LightColor2: TColor read FLightColor2 write SetLightColor2; - property DarkColor: TColor read FDarkColor write SetDarkColor; - property FrameColor1: TColor read FFrameColor1 write SetFrameColor1; - property FrameColor2: TColor read FFrameColor2 write SetFrameColor2; - property FillColor1: TColor read FFillColor1 write SetFillColor1; - property FillColor2: TColor read FFillColor2 write SetFillColor2; - property BackFrameColor1: TColor read FBackFrameColor1 write SetBackFrameColor1; - property BackFrameColor2: TColor read FBackFrameColor2 write SetBackFrameColor2; - property BackFillColor: TColor read FBackFillColor write SetBackFillColor; - property ShadowColor: TColor read FShadowColor write SetShadowColor; - - procedure Add1(D: integer); - procedure Add2(D: integer); - end; - -function NewTRarProgressBar(AOwner: PControl): PRarProgBar; - -implementation - -function Bounds(ALeft,ATop,AWidth,AHeight: integer): TRect; -begin - with Result do - begin - Left:=ALeft; - Top:=ATop; - Right:=ALeft+AWidth; - Bottom:=ATop+AHeight; - end; -end; - -function NewTRarProgressBar; -var P: PRarProgBar; - C: PControl; -begin - C:=pointer(_NewControl(AOwner,'STATIC',WS_VISIBLE or WS_CHILD or SS_LEFTNOWORDWRAP or SS_NOPREFIX or SS_NOTIFY,False,nil)); - C.CreateWindow; - New(P,Create); - AOwner.Add2AutoFree(P); - AOwner.Add2AutoFree(C); - P.FControl:=C; - P.FMin:=0; - P.FMax:=100; - P.FPosition1:=0; - P.FPosition2:=0; - P.FDouble:=False; - P.FPercent1:=0; - P.FPercent2:=0; - P.FLightColor1:=clWhite; - P.FDarkColor:=$606060; - P.FLightColor2:=$C0FFFF; - P.FFrameColor1:=$EEE8E8; - P.FFrameColor2:=$B4D4E4; - P.FFillColor1:=$DCD6D6; - P.FFillColor2:=$A0C0D0; - P.FBackFrameColor1:=$9494B4; - P.FBackFrameColor2:=$80809E; - P.FBackFillColor:=$6E6E94; - P.FShadowColor:=$464040; - C.SetSize(204,18); - P.B:=NewBitmap(C.Width,C.Height); - Result:=P; - P.OldWind:=GetWindowLong(C.Handle,GWL_WNDPROC); - P.NewWind:=integer(MakeObjectInstance(P.NewWndProc)); - SetWindowLong(C.Handle,GWL_WNDPROC,P.NewWind); -end; - -destructor TRarProgBar.Destroy; -begin - SetWindowLong(FControl.Handle,GWL_WNDPROC,OldWind); - FreeObjectInstance(Pointer(NewWind)); - B.Free; - inherited; -end; - -function TRarProgBar.SetPosition(X,Y: integer): PRarProgBar; -begin - FControl.Left:=X; - FControl.Top:=Y; - Result:=@Self; -end; - -function TRarProgBar.SetSize(X,Y: integer): PRarProgBar; -begin - FControl.Width:=X; - FControl.Height:=Y; - B.Width:=X; - B.Height:=Y; - Result:=@Self; -end; - -function TRarProgBar.SetAlign(A: TControlAlign): PRarProgBar; -begin - FControl.Align:=A; - Result:=@Self; -end; - -procedure TRarProgBar.NewWndProc; -begin - Msg.Result:=CallWindowProc(Pointer(OldWind),FControl.Handle,Msg.Msg,Msg.wParam,Msg.lParam); - case Msg.Msg of - WM_PAINT : Paint; - WM_SIZE : Paint; - WM_ACTIVATE: Paint; - end; -end; - -procedure TRarProgBar.SetMin; -begin - if M>FMax then M:=FMax; - FMin:=M; - Paint; -end; - -procedure TRarProgBar.SetMax; -begin - if MFMax 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 Prog0 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. - diff --git a/Addons/KOLRas.pas b/Addons/KOLRas.pas deleted file mode 100644 index 120a322..0000000 --- a/Addons/KOLRas.pas +++ /dev/null @@ -1,386 +0,0 @@ -{$A+} - -unit KOLRas; - -interface - -uses - Windows, KOL, RAS; - -type - - PRASObj =^TRASObj; - TKOLRAS = PRASObj; - TOnErrorEvent = procedure (Sender: PRASObj; Error: Integer) of object; - TOnConnectingEvent = procedure (Sender: PRASObj; Msg: Integer; State: Integer; Error: Longint) of object; - - TRASObj = object(TObj) - private - FOnConnecting: TOnConnectingEvent; // event for asynchronous dialing - FOnError: TOnErrorEvent; // error event - FRASHandle: THRasConn; // connection handle - FRASName: string; // name of the RAS service - fState: TRASConnState; - fError: longint; - fTimer: PTimer; - connecting: boolean; - function GetConnected: Boolean; - function GetParams(Server: string; var DialParams: TRasDialParams): Boolean; - function GetPassword: string; - procedure GetRASHandle; - function GetUsername: string; - procedure SetRASName( Value: string ); - function GetStatusString: string; - function GetErrorString: string; - procedure OnTimer(Sender: PObj); - public - destructor Destroy; virtual; // and destroy it - procedure Connect; // make a connection - procedure DisConnect(force: boolean); // close the connection - property Connected: Boolean read GetConnected; // is service connected? - property Status: TRASConnState read fState; // current RAS state - property Error: longint read fError; // last RAS error - property RASHandle: THRASConn read fRASHandle; - property StatusString: string read GetStatusString; - property ErrorString: string read GetErrorString; - property Password: string read GetPassword; // get the password - property RASName: string read FRASName write SetRASName; // name of RAS service - property Username: string read GetUsername; // username - property OnConnecting: TOnConnectingEvent read FOnConnecting write FOnConnecting; // asynch dialing event - property OnError: TOnErrorEvent read FOnError write FOnError; // error event - end; - -function GetStatString(s: longint): string; -function GetErrString(e: longint): string; -function NewRASObj: PRASObj; -function GetRASConnected(Handles: PList): PStrList; // get all existing connections -function GetRASNames: PStrList; // get all possible connections -function IsRASConnected( const r: string ): Boolean; // test if a connection is available -procedure HangUp( const RASName: string ); - -implementation - -var RASSave: PRASObj; - CBkSave: TOnConnectingEvent; - -procedure RASCallback(Msg: Integer; State: TRasConnState; Error: Longint); stdcall; -begin - if assigned(RASSave) then begin - RASSAve.fState := State; - RASSave.fError := Error; - if Assigned(CBkSave) then begin - CBkSave( RASSave, Msg, State, Error ); - end; - if (Assigned(RASSave.FOnError)) and (Error<>0) then begin - RASSave.FOnError( RASSave, Error ); - end; - if State = $2000 then begin - RASSave.fTimer.Enabled := True; - RASSave.connecting := false; - end; - end; -end; - -function NewRASObj; -begin - New(Result, create); // create the component first - Result.FRASHandle := 0; // internal RAS handle - Result.FRASName := ''; // no default RAS name - Result.fTimer := NewTimer(1000); // watchdog timer - Result.fTimer.Enabled := True; - Result.fTimer.Enabled := False; - Result.fTimer.OnTimer := Result.OnTimer; - RASSave := Nil; - CBkSave := Nil; -end; - -destructor TRASObj.Destroy; -begin - DisConnect(True); - RASSave := Nil; - CBkSave := Nil; - fTimer.Free; - inherited Destroy; // next destroy the object -end; - -procedure TRASObj.Connect; -var DialParams: TRasDialParams; // local dial parameters -begin - if not Connected then begin // only if the service is not connected - if GetParams( FRASName, DialParams ) then begin // get actual dial parameters - connecting := true; - RASSave := @self; // save the object itself - CbkSave := FOnConnecting; - RasDial(nil, nil, DialParams, 0, @RASCallback, FRASHandle ); // call with a callback function - end; - end; -end; - -procedure TRASObj.DisConnect; -var s: TRasConnStatus; -begin - if Connected or force then begin // only if a connection is available - if FRASHandle<>0 then begin // only if a vaild handle is available - RasHangup( FRASHandle ); // hangup the RAS service - s.dwSize := sizeof(s); - repeat - sleep(0); - until RasGetConnectStatus( FRASHandle, s ) = ERROR_INVALID_HANDLE; - FRASHandle := 0; - end; - end; -end; - -function TRASObj.GetConnected: Boolean; -begin - Result := IsRASConnected( FRASName ); // test if a service with this name is established - if (Result) and (FRASHandle=0) then begin // if no handle is available - GetRASHandle; // try to read the handle - end; -end; - -function TRASObj.GetParams(Server: string; var DialParams: TRasDialParams): Boolean; -var DialPassword: LongBool; - RASResult: LongInt; -begin - Result := true; // result is first vaild - FillChar( DialParams, SizeOf(TRasDialParams), 0); // clear the result record - DialParams.dwSize := Sizeof(TRasDialParams); // set the result array size - StrPCopy(DialParams.szEntryName, Server); // set the ras service name - DialPassword := true; // get the dial password - RASResult := RasGetEntryDialParams(nil, DialParams, DialPassword); // read the ras parameters - if (RASResult<>0) then begin // if the API call was not successful - Result := false; // result is not vaild - if (Assigned(FOnError)) then begin // if an error event is assigned - FOnError( @self, RASResult ); // call the error event - end; - end; -end; - -function TRASObj.GetPassword: string; -var DialParams: TRasDialParams; // dial parameters for this service -begin - if GetParams( FRASName, DialParams ) then begin // if read of dial parameters was successful - Result := DialParams.szPassword; // copy the password string - end else begin // if read was not successful - Result := ''; // return an empty string - end; -end; - -procedure TRASObj.GetRASHandle; -const cMaxRas = 100; // maximum number of ras services -var BufferSize: LongInt; // used for size of result buffer - RASBuffer: array[1..cMaxRas] of TRasConn; // the API result buffer itself - RASCount: LongInt; // number of found ras services - i: Integer; // loop counter -begin - FRASHandle := 0; // first no handle is available - FillChar( RASBuffer, SizeOf(RASBuffer), 0 ); // clear the API Buffer - RASBuffer[1].dwSize := SizeOf(TRasConn); // set the API buffer size for a single record - BufferSize := SizeOf(TRasConn) * cMaxRas; // calc complete buffer size - if RasEnumConnections(@RASBuffer[1], BufferSize, RASCount) = 0 then begin - for i := 1 to RASCount do begin // for all found ras services - if RASBuffer[i].szEntryName = RASName then begin // if the actual name is available - FRASHandle := RASBuffer[i].hrasconn; // save the found ras handle - end; - end; - end; -end; - -function TRASObj.GetUsername: string; -var DialParams: TRasDialParams; // dial parameters for this service -begin - if GetParams( FRASName, DialParams ) then begin // if read of dial parameters was successful - Result := DialParams.szUserName; // copy the user name string - end else begin // if read was not successful - Result := ''; // return an empty string - end; -end; - -function TRASObj.GetStatusString; -begin - result := GetStatString(fState); -end; - -function GetStatString; -begin - result := 'unexpected status: ' + int2str(s); - case s of - 0: result := ''; - 1: result := 'port is opened'; - 2: result := 'call in progress'; - 3: result := 'device is connected'; - 4: result := 'all devices is connected'; - 5: result := 'authentication'; - 6: result := 'authnotify'; - 7: result := 'authretry'; - 8: result := 'authcallback'; - 9: result := 'authchangepassword'; - 10: result := 'authproject'; - 11: result := 'linkspeed'; - 12: result := 'authack'; - 13: result := 'reauthenticate'; - 14: result := 'authenticated'; - 15: result := 'prepareforcallback'; - 16: result := 'waitformodemreset'; - 17: result := 'waitforcallback'; - 18: result := 'projected'; - 19: result := 'startauthentication'; - 20: result := 'callbackcomplete'; - 21: result := 'logonnetwork'; -$1000: result := 'interactive'; -$1001: result := 'retryauthentication'; -$1002: result := 'callbacksetbycaller'; -$1003: result := 'password is expired'; -$2000: result := 'connected'; -$2001: result := 'disconnected'; - end; -end; - -function TRASObj.GetErrorString; -begin - result := GetErrString(fError); -end; - -function GetErrString(e: longint): string; -begin - result := 'unexpected error: ' + int2str(e); - case e of - 000: result := ''; - 600: result := 'operation is pending'; - 601: result := 'invalid port handle'; - 608: result := 'device does not exist'; - 615: result := 'port not found'; - 619: result := 'connection is terminated'; - 628: result := 'port was disconnected'; - 629: result := 'disconnected by remote'; - 630: result := 'hardware failure'; - 631: result := 'user disconnect'; - 633: result := 'port is in use'; - 638: result := 'PPP no address assigned'; - 651: result := 'device error'; - 676: result := 'line is busy'; - 678: result := 'no answer'; - 680: result := 'no dialtone'; - 691: result := 'authentication failure'; - 718: result := 'PPP timeout'; - 720: result := 'PPP no CP configured'; - 721: result := 'PPP no responce'; - 732: result := 'PPP is not converging'; - 734: result := 'PPP LCP terminated'; - 735: result := 'PPP adress rejected'; - 738: result := 'no PPP address assigned'; - 742: result := 'no remote encription'; - 743: result := 'remote requires encription'; - 752: result := 'script syntax error'; - 777: result := 'no answer timeout'; - 797: result := 'modem is not found'; - end; -end; - -procedure TRASObj.SetRASName( Value: string ); -var DialParams: TRasDialParams; // dial parameters for this service -begin - if GetParams( Value, DialParams ) then begin - FRASName := Value; - GetRASHandle; // try to read an existing handle - end; -end; - -function GetRASConnected; -const cMaxRas = 100; // maximum number of ras services -var BufferSize: LongInt; // used for size of result buffer - RASBuffer: array[1..cMaxRas] of TRasConn; // the API result buffer itself - RASCount: LongInt; // number of found ras services - i: Integer; // loop counter -begin - FillChar( RASBuffer, SizeOf(RASBuffer), 0 ); // clear the API Buffer - RASBuffer[1].dwSize := SizeOf(TRasConn); // set the API buffer size for a single record - BufferSize := SizeOf(TRasConn) * cMaxRas; // calc complete buffer size - Result := NewStrList; - if RasEnumConnections(@RASBuffer[1], BufferSize, RASCount) = 0 then begin - for i := 1 to RASCount do begin // for all found ras services - Result.Add( RASBuffer[i].szEntryName ); // copy the name of the ras service - if Handles <> nil then Handles.Add(pointer(RASBuffer[i].hrasconn)); - end; - end; - if assigned(RASSave) then begin - if RASSAve.FRASHandle <> 0 then begin - if RASSave.connecting then begin - i := Result.IndexOf(RASSave.FRASName); - if i = -1 then begin - i := Result.Add(RASSave.FRASName); - if Handles <> nil then Handles.Add(pointer(RASSave.FRASHandle)); - end; - if Handles <> nil then Handles.Items[i] := pointer(RASSave.FRASHandle); - end; - end; - end; -end; - -function GetRASNames; -const cMaxRas = 100; // maximum number of ras services -var BufferSize: LongInt; // used for size of result buffer - RASBuffer: array[1..cMaxRas] of TRasEntryName; // the API result buffer itself - RASCount: LongInt; // number of found ras services - i: Integer; // loop counter -begin - Result := Nil; - FillChar( RASBuffer, SizeOf(RASBuffer), 0 ); // clear the API Buffer - RASBuffer[1].dwSize := SizeOf(TRasEntryname); // set the API buffer size for a single record - BufferSize := SizeOf(TRasEntryName) * cMaxRas;// calc complete buffer size - if RasEnumEntries(nil, nil, @RASBuffer[1], BufferSize, RASCount) = 0 then begin - Result := NewStrList; - for i := 1 to RASCount do begin // for all found ras services - Result.Add( RASBuffer[i].szEntryName ); // copy the name of the ras service - end; - end; -end; - -function IsRASConnected( const r: string ): Boolean; -var n: PStrList; // result object for connected services - i: Integer; // loop counter - p: PList; -begin - Result := false; // first the result is false - p := NewList; - n := GetRasConnected(p); // create the object for connected services - for i := 0 to n.Count - 1 do begin // for all connected services - if r = n.Items[i] then begin // if the ras name was found - Result := true; // the result is true now - Break; // break the loop, one is found - end; - end; - n.Free; // destroy the object for connected services - p.Free; -end; - -procedure HangUP; -var e: PStrList; - h: PList; - i: integer; -begin - h := NewList; - e := GetRASConnected(h); - i := e.IndexOf(RASName); - if i > -1 then begin - RASHangUp(integer(h.Items[i])); - end; - e.Free; - h.Free; -end; - -procedure TRASObj.OnTimer; -begin - if not connected then begin - fTimer.Enabled := False; - Disconnect(True); - if assigned(fOnConnecting) then begin - fState := $2001; - fError := 619; - fOnConnecting(@self, 0, $2001, 619); - end; - end; -end; - -end. diff --git a/Addons/KOLReport.dcr b/Addons/KOLReport.dcr deleted file mode 100644 index 63ab373ddf0e1c7451bceaca60383cbc3a23b45d..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 1368 zcmd5*u}TCn5SM^nX(3z<|XS$;YI-!eV@rWcRXg z9%7@zCiC`XGMVHhL_{+*=G*{B_BJ890>gYl&vZ|Zw4ycL(G$=bOmEZa`Du?Y0M1IA zP^M?dbJ#i}eAIQ>p$A0k$T^1rDNGz^hd$TJ6hhdx?F(E8T5n&OcdcM+wbslmBj(du zgXud2TD!1@IbtZ<1rJy;oA<&i#EOB73Z2+doWrG;_%uUt{2tfwIlc5zMaGAnVX}%b z7nyicQOF!4BQS|ce8j=TQfA7tPfsM;U4p2!Tha|Z(CrZR7rK4uxyY2vTci75KeyJF zA#XQ+z?(2&O!B_Wt(_ZoM2(Y^$Tr3}Ey#qX8kcT?bict>o_;0f@mdm+t*Pt$2^QVv zm|N>szqu7OT;dI`$^!paLo?{+%~-?h0|(*Ce&E7h!zfs;xx50wa^G<_1(WJANEu4} Z2uBGie2wL?_527YO_8Un=RmnfsV`}poxT77 diff --git a/Addons/KOLReport.pas b/Addons/KOLReport.pas deleted file mode 100644 index 0e7b101..0000000 --- a/Addons/KOLReport.pas +++ /dev/null @@ -1,1276 +0,0 @@ -{ KOLReport v2.0 (C) 2002 by Vladimir Kladov. - - See Demo project attached for documentation. All other documentation planned - to be added later. - - In version 2.0: - [+] metafiles used, spooling size became less, printing quality increased. - [+] with new version of KOLPrinters by Boguslaw Brandys, printer setup dialog provided. -} -unit KOLReport; - -interface - -//{$DEFINE use_MHPRINTER} -// (uncomment line above to use TKOLMHPrinter prior to TKOLPrinter) - -uses Windows, Messages, KOL, - {$IFDEF use_MHPRINTER} KOLMHPrinters - {$ELSE} KOLPrinters, KOLPageSetupDialog - {$ENDIF}; - -type - {$IFDEF use_MHPRINTER} PPrinter = PMHPrinter; {$ENDIF} - - TPaperSize = ( psA4, psA5, psA6, psA3, psLetter, psCustom ); - {* Available paper sizes. } - TBandLayout = ( blLeft, blCenter, blRight, blExpandRight ); - {* Available band layouts. } - TMargins = TRect; - - TMF = HDC; // used as a handle to memory-based EnhMetafile. - - PReport = ^TReport; - - PPreviewObj = ^TPreviewObj; - TPreviewObj = object( TObj ) - {* Preview form container object. } - private - procedure SetCurPage(const Value: Integer); - procedure SetFitMode(const Value: Integer); - public - Form: PControl; - {* Form. } - TB: PControl; - {* Toolbar. } - SB: PControl; - {* Scrollbar. } - PB: PControl; - {* PaintBox. } - LB: PControl; - PSD: PPageSetupDlg; {Brandys} - Options: TPageSetupOptions; - {* Label to show current page number and total pages count. } - FFitMode: Integer; - {* Fit mode: 0 - fit height, 1 - fit width, 2 - 1:1 } - ViewMenu: PMenu; - {* Drop down menu for toolbar button TBView. } - FBuf: PBitmap; - {* Buffer where current page stored (scaled). } - protected - FReport: PReport; - {* Reference to parent Report object. } - FCurPage: Integer; - {* Current page index. } - FBufPage: Integer; - {* Buffered page index. } - procedure TBClick( Sender: PObj ); - procedure TBDropDownViewMenu( Sender: PObj ); - procedure TBViewMenuClick( Sender: PMenu; Item: Integer ); - procedure AdjustButtons( Sender: PObj ); - procedure PaintPage( Sender: PControl; DC: HDC ); - procedure AdjustFitMode; - procedure PrinterSetup; - procedure ResizePreviewForm( Sender: PObj ); - public - destructor Destroy; virtual; - {* } - property CurPage: Integer read FCurPage write SetCurPage; - {* Current page index (starting from 0). } - function PageCount: Integer; - {* Total pages count. Could be 0, if a report is empty (nothing to show). } - procedure PrintAllPages; - {* Call this method to print all pages. } - property FitMode: Integer read FFitMode write SetFitMode; - {* Fit mode: 0 - fit height, 1 - fit width, 2 - 1:1. } - end; - - TReport = object( TObj ) - {* Report object. It is used to create report and to print or preview it} - private - FDocName: String; - FReplaceFontHeight0: Integer; - FMargins: TMargins; - function GetPages(Idx: Integer): TMF; - function GetImages(Idx: Integer): HENHMETAFILE; - procedure SetMargins(const Value: TMargins); - function GetMarginsPixels( const Index: Integer ): TMargins; - protected - FPageTop: Boolean; - FY: Integer; - FOnNewPage: TOnEvent; - FPrinter: PPrinter; - FX: Integer; - FPrinting: Boolean; - FDCPages: PList; - FHDPages: PList; - FStage: Integer; - FOnPrint: TOnEvent; - FPreviewForm: PPreviewObj; - FBottom: Integer; - FPagePixelsSize: TSize; - FPaperSize: TPaperSize; - FCustomPaperSize: TSize; - FPageWidth: Integer; - FPageHeight: Integer; - FDoubleBufferedPreview: Boolean; - FCurBandHeight: Integer; - FOnEndBand: TOnEvent; - fNewPageHandling: Boolean; - fNewBandHandling: Boolean; - procedure SetPageTop(const Value: Boolean); - procedure SetPrinter(const Value: PPrinter); - function GetPageCount: Integer; - function GetPreviewForm: PPreviewObj; - procedure SetPreviewForm(const Value: PPreviewObj); - function GetCurrentPage: TMF; - function GetPrinter: PPrinter; - function GetPagePixelsSize: TSize; - function GetOrientation: TPrinterOrientation; - procedure SetPaperSize(const Value: TPaperSize); - procedure SetCustomPaperSize(const Value: TSize); - function GetPageHeight: Integer; - function GetPageWidth: Integer; - procedure GetPageWidthHeight; - procedure SetX(const Value: Integer); - procedure SetY(const Value: Integer); - protected - function AddPage: TMF; - function PaintBand( MF: TMF; Band: PControl; Xpos, Ypos: Integer ): Integer; - function ScaleX( W: Integer ): Integer; - function ScaleY( H: Integer ): Integer; - procedure DoPrintPreview( Proc: TObjectMethod ); - procedure DoPrint; - procedure DoPreview; - procedure DoPreviewModal; - public - Destructor Destroy; virtual; - procedure Clear; - {* Call this method to make report empty. If the preview form is active - for the report, it is closed too. } - procedure ClearPages; - {* Clears all pages. } - property PreviewForm: PPreviewObj read GetPreviewForm write SetPreviewForm; - {* Access to preview form object. } - property DoubleBufferedPreview: Boolean read FDoubleBufferedPreview write FDoubleBufferedPreview; - {* Set this value to TRUE, if you wish from PreviewForm to be shown - DoubleBuffered. } - property PagePixelsSize: TSize read GetPagePixelsSize; - {* Size of a page in screen pixels. } - property Orientation: TPrinterOrientation read GetOrientation; - {* Orientation of a Printer. } - property PaperSize: TPaperSize read FPaperSize write SetPaperSize; - {* Paper size type (psA4, psA3, ... psCustom). } - property CustomPaperSize: TSize read FCustomPaperSize write SetCustomPaperSize; - {* Custom paper size in millimeters. } - property PageWidth: Integer read GetPageWidth; - {* Paper width in Printer canvas pixels. } - property PageHeight: Integer read GetPageHeight; - {* Paper height in Printer canvas pixels. } - property CurrentPage: TMF read GetCurrentPage; - {* Current page metafile DC. Valid only while drawing the page. } - property Printer: PPrinter read GetPrinter write SetPrinter; - {* Printer object. } - property PageTop: Boolean read FPageTop write SetPageTop; - {* True, if current position is on top of current page. (It is set to - True just after calling OnNewPage event, i.e. *after* printing top - page colontitles). } - property X: Integer read FX write SetX; - {* Current X position. } - property Y: Integer read FY write SetY; - {* Current Y position. } - public - procedure AddBand( Band: PControl ); - {* Call this method to add a band. Band could be any control, not only - created with NewBand or NewReportLabel etc. Before adding a band, - change its contant as you wish (change Caption, adjust Frames, Color, - Font, etc.) } - procedure AddBandEx( Band: PControl; BandLayout: TBandLayout ); - {* Call this method to add a band with special aligning option. } - procedure AddFooter( Band: PControl ); - {* Adds a footer band to a current page. It is possible to add several - footers, in such case the first is added to the bottom, and all the - follows above it. } - procedure AddFooterEx( Band: PControl; BandLayout: TBandLayout ); - {* Adds a footer with special aligning option. } - procedure AddRight( Band: PControl ); - {* Adds a band or a cell just right, without shifting current Y position - onto a height of a Band, like in AddBand or AddBandEx. Calling - AddRight ands AddRightEx several times it is possible to construct - desired band from prepared cells dynamically. If there are no place - for a new band between X position and right margin of the page, new - band is added from the starting of the next horizontal band - automatically. } - procedure AddRightEx( Band: PControl; BandLayout: TBandLayout ); - {* Adds a band or a cell just right, and with additional layout options. } - procedure NewPage; - {* Forces new page. If called twice, empty page will be printed. } - property Bottom: Integer read FBottom; - {* Bottom available position (in screen pixels). Valid while drawing - onto current page. } - property PageCount: Integer read GetPageCount; - {* Total number of pages. } - property Pages[ Idx: Integer ]: TMF read GetPages; - {* Access to pages metafiles DC. Valid while drawing pages. } - property Images[ Idx: Integer ]: HENHMETAFILE read GetImages; - {* Access to page metafiles handles. If a handle for a certain page - is accessed, its metafile DC become unavailable. } - procedure Print; - {* Call this method to print all the pages. } - procedure PrintPages( FromPage, ToPage: Integer ); - {* Call this method to print given pages range. } - procedure Preview; - {* Call this method to show preview non-modal. Be sure, that the Report - object is existing while preview is active. } - procedure PreviewModal; - {* Call this method to show preview form modal. } - procedure Abort; - {* Call this method to stop current printing. } - property Printing: Boolean read FPrinting; - {* True, if pages are currently printing. } - property Stage: Integer read FStage; - {* If OnPrint event is called, this value 1 or 2 shows a stage of - printing. In the first call of OnPrint event, it has value 1, in the - second its value is 2. } - property OnPrint: TOnEvent read FOnPrint write FOnPrint; - {* If this event is assigned, perform adding all bands in this event - handler. Please remember, that OnPrint is called twice. Be sure, that - all your initializations made correctly for both stages. Mainly, this - method is used to provide printing some data which depends on total - pages count (e.g. to print Page 1 From 10. You should store total - pages count after stage 1, and use this information on stage 2). - Also, this event allows to repeat printing after showing Printer setup - dialog in case when some settings are changed (page size, layout, - margins, etc.) } - property OnNewPage: TOnEvent read FOnNewPage write FOnNewPage; - {* This event is called when new page is started (by any reason). You can - add here page header or footers, if you wish. } - property OnEndBand: TOnEvent read FOnEndBand write FOnEndBand; - {* This event can be useful when bands are created dynamically from cells - calling AddRight or AddRightEx. } - function HeightAvailable: Integer; - {* Pixels available vertically on current page (in screen pixels). If - this value is not sufficient to add a band, new page is started. It - is possible to check this value manually to ensure that a certain - number of bands could be fit, and to force new page if you wish from - some data to be located always together, e.g. subdetail title + - column header + at least 1 band of subdetail data. } - property DocumentName: String read FDocName write FDocName; - {* Assign a name of your document here. This value is shown in spooler - queue and helps to identify your report among other printing documents. } - property ReplaceFontHeight0: Integer read FReplaceFontHeight0 write FReplaceFontHeight0; - {* Change this value, if default value 18 pixels is not satisfying you. - While adding a band, all its fonts with FontHeight=0 are replaced by this - value to provide correct scaling onto Printer device. } - property Margins: TMargins read FMargins write SetMargins; - {* Margins in 0.01 millimeters. } - property MarginsPrinterPixels: TMargins index 1 read GetMarginsPixels; - {* Margins in Printer's pixels. } - property MarginsScreenPixels: TMargins index 2 read GetMarginsPixels; - {* Margins in screen pixels. } - end; - - TFrame = ( frLeft, frTop, frRight, frBottom ); - {* Frames for special band control. } - TFrames = set of TFrame; - {* } - - TPaddings = packed record - {* Paddings. } - LeftPadding, TopPadding, RightPadding, BottomPadding: Integer; - end; - -const - AllFrames: TFrames = [ frLeft, frTop, frRight, frBottom ]; - {* Use this constant to tell that all the frames are turned on. } - -function NewReport: PReport; -{* Call this function to create report object. } -procedure NewPreviewForm( var PreviewObj: PPreviewObj; AParent: PControl ); -{* This function is called automatically when Preview or PreviewModal method - is called for TReport object. } - -function NewBand( AParent: PControl; Frames: TFrames ): PControl; -{* Call this function to create special band control. It is very similar to - a panel, and can contain other controls as children. } -function NewReportLabel( AParent: PControl; const Caption: String; Frames: TFrames ): PControl; -{* Call this function to create band label. It can be used along or as a - child of a band. } -function NewWordWrapReportLabel( AParent: PControl; const Caption: String; Frames: TFrames ): PControl; -{* Like NewReportLabel, but with WordWrap. } - -procedure SetPaddings( BandCtl: PControl; LeftPadding, TopPadding, RightPadding, BottomPadding: Integer ); -{* Use this function to change band paddings. } - -type - TKOLReport = PReport; - TKOLBand = PControl; - TKOLReportLabel = PControl; - -implementation - -const TBFrst = 0; - TBPrev = 1; - TBNext = 2; - TBLast = 3; - TBPrnt = 4; - TBSetu = 5; - TBView = 6; - TBExit = 7; - -function GetProviderPrinter: PPrinter; -begin - Result := Printer; -end; - -function NewReport: PReport; -begin - new( Result, Create ); - Result.FDocName := 'Report 1'; - Result.FDCPages := NewList; - Result.FHDPages := NewList; - Result.FCustomPaperSize.cx := 210; - Result.FCustomPaperSize.cy := 270; - Result.FReplaceFontHeight0 := -12; - Result.FMargins := MakeRect( 500, 500, 500, 500 ); -end; - -procedure NewPreviewForm( var PreviewObj: PPreviewObj; AParent: PControl ); -var Pn: PControl; -begin - new( PreviewObj, Create ); - PreviewObj.Form := NewForm( AParent, 'Preview' ).SetSize( 600, 600 ) - .SetPosition( (GetSystemMetrics( SM_CXSCREEN ) - 600) div 2, - (GetSystemMetrics( SM_CYSCREEN ) - 600) div 2 ); - {Brandys} - PreviewObj.Options := [psdMargins,psdSamplePage,psdPaperControl,psdPrinterControl,psdWarning,psdHundredthsOfMillimeters,psdUseMargins,psdUseMinMargins]; - PreviewObj.PSD := NewPageSetupDialog(PreviewObj.Form,PreviewObj.Options); - PreviewObj.PSD.SetMinMargins(500,500,500,500); - PreviewObj.Form.Border := 0; - Pn := NewPanel( PreviewObj.Form, esNone ).SetSize( 0, 25 ).SetAlign( caTop ); - PreviewObj.TB := NewToolbar( Pn, caNone, [ tboNoDivider ], - THandle(-1), [ '<<', '<', '>', '>>', ' Print', 'Setup', '^View', 'Close' ], - [ -1, -1, -1, -1, 14, -2 ] ).SetAlign( caLeft ).SetSize( 440, 0 ); - PreviewObj.TB.OnClick := PreviewObj.TBClick; - PreviewObj.TB.OnTBDropDown := PreviewObj.TBDropDownViewMenu; - NewMenu( PreviewObj.Form, 0, [ '' ], nil ); - PreviewObj.ViewMenu := NewMenu( PreviewObj.Form, 0, - [ '-!Fit &Height', '-!Fit &Width', '-!&1:1' ], - PreviewObj.TBViewMenuClick ); - PreviewObj.LB := NewLabel( Pn, '' ).SetAlign( caClient ); - PreviewObj.LB.TextAlign := taRight; - PreviewObj.LB.VerticalAlign := vaCenter; - PreviewObj.Form.OnShow := PreviewObj.AdjustButtons; - PreviewObj.SB := NewScrollBoxEx( PreviewObj.Form, esLowered ).SetAlign( caClient ); - PreviewObj.PB := NewPaintBox( PreviewObj.SB ); - PreviewObj.PB.OnPaint := PreviewObj.PaintPage; - - //PreviewObj.TB.TBButtonVisible[ TBSetu ] := FALSE; - PreviewObj.Form.OnResize := PreviewObj.ResizePreviewForm; -end; - -type - PFramesData = ^TFramesData; - TFramesData = packed Record - Frames: TFrames; - Paddings: TPaddings; - end; - -procedure PaintFrames( Self_, Sender: PControl; DC: HDC ); -var Br: HBrush; - R: TRect; - procedure FillFrame( X1, Y1, X2, Y2: Integer ); - begin - if X2 <= X1 then Exit; - if Y2 <= Y1 then Exit; - FillRect( DC, MakeRect( X1, Y1, X2, Y2 ), Br ); - end; -var Data: PFramesData; - W, H, B: Integer; - Fmt: DWORD; - OldFont: HFont; - OldBk: Integer; -begin - Data := Self_.CustomData; - Br := CreateSolidBrush( Color2RGB( Self_.Font.Color ) ); - W := Self_.ClientWidth; - H := Self_.ClientHeight; - B := Self_.Border; - R := Self_.ClientRect; - if frLeft in Data.Frames then - begin - FillFrame( 0, 0, B, H ); - Inc( R.Left, B ); - end; - if frTop in Data.Frames then - begin - FillFrame( 0, 0, W, B ); - Inc( R.Top, B ); - end; - if frRight in Data.Frames then - begin - FillFrame( W - B, 0, W, H ); - Dec( R.Right, B ); - end; - if frBottom in Data.Frames then - begin - FillFrame( 0, H - B, W, H ); - Dec( R.Bottom, B ); - end; - DeleteObject( Br ); - - Br := CreateSolidBrush( Color2RGB( Self_.Color ) ); - FillRect( DC, R, Br ); - Inc( R.Left, Data.Paddings.LeftPadding ); - Inc( R.Top, Data.Paddings.TopPadding ); - Dec( R.Right, Data.Paddings.RightPadding ); - Dec( R.Bottom, Data.Paddings.BottomPadding ); - DeleteObject( Br ); - - case Self_.TextAlign of - taCenter: Fmt := DT_CENTER; - taRight: Fmt := DT_RIGHT; - else Fmt := DT_LEFT; - end; - case Self_.VerticalAlign of - vaTop: Fmt := Fmt or DT_TOP; - vaCenter: Fmt := Fmt or DT_VCENTER; - vaBottom: Fmt := Fmt or DT_BOTTOM; - end; - if Self_.WordWrap then - Fmt := Fmt or DT_WORDBREAK - else - Fmt := Fmt or DT_SINGLELINE; - OldFont := SelectObject( DC, Self_.Font.Handle ); - - OldBk := SetBkMode( DC, TRANSPARENT ); - DrawText( DC, PChar( Self_.Caption ), Length( Self_.Caption ), R, Fmt ); - SetBkMode( DC, OldBk ); - SelectObject( DC, OldFont ); - -end; - -function NewBand( AParent: PControl; Frames: TFrames ): PControl; -var Data: PFramesData; -begin - Result := NewPanel( AParent, esNone ); - Result.Color := clWhite; - Result.Border := 1; - Data := AllocMem( Sizeof( TFramesData ) ); - Result.CustomData := Data; - Data.Frames := Frames; - Data.Paddings.LeftPadding := 4; - Data.Paddings.RightPadding := 4; - Result.OnPaint := TOnPaint( MakeMethod( Result, @ PaintFrames ) ); - Result.Width := 400; - Result.Height := 40; - Result.aAutoSzX := 12; -end; - -procedure InitBandLabel( L: PControl; Frames: TFrames ); -var Data: PFramesData; -begin - L.Color := clWhite; - L.Border := 1; - Data := AllocMem( Sizeof( TFramesData ) ); - L.CustomData := Data; - Data.Frames := Frames; - Data.Paddings.LeftPadding := 4; - Data.Paddings.RightPadding := 4; - L.OnPaint := TOnPaint( MakeMethod( L, @ PaintFrames ) ); - L.aAutoSzX := 12; -end; - -function NewReportLabel( AParent: PControl; const Caption: String; Frames: TFrames ): PControl; -begin - Result := NewLabel( AParent, Caption ).AutoSize( TRUE ); - InitBandLabel( Result, Frames ); -end; - -function NewWordWrapReportLabel( AParent: PControl; const Caption: String; Frames: TFrames ): PControl; -begin - Result := NewWordWrapLabel( AParent, Caption ).AutoSize( TRUE ); - InitBandLabel( Result, Frames ); -end; - -procedure SetPaddings( BandCtl: PControl; LeftPadding, TopPadding, RightPadding, BottomPadding: Integer ); -var Data: PFramesData; - WasHPadding: Integer; -begin - Data := BandCtl.CustomData; - WasHPadding := Data.Paddings.LeftPadding + Data.Paddings.RightPadding; - Data.Paddings.LeftPadding := LeftPadding; - Data.Paddings.TopPadding := TopPadding; - Data.Paddings.RightPadding := RightPadding; - Data.Paddings.BottomPadding := BottomPadding; - BandCtl.aAutoSzX := BandCtl.aAutoSzX - WasHPadding + LeftPadding + RightPadding; - if BandCtl.IsAutoSize then - BandCtl.AutoSize( TRUE ); -end; - -{ TReport } - -procedure TReport.Abort; -begin - Clear; - if Assigned( FPrinter ) then - begin - if Printer.Printing then - Printer.Abort; - end; -end; - -procedure TReport.AddBand(Band: PControl); -begin - AddBandEx( Band, blLeft ); -end; - -procedure TReport.AddBandEx(Band: PControl; BandLayout: TBandLayout); -var MF: TMF; - OldW: Integer; -begin - if FCurBandHeight > 0 then - begin - if not fNewBandHandling then - if Assigned( OnEndBand ) then - begin - fNewBandHandling := TRUE; - OnEndBand( @ Self ); - fNewBandHandling := FALSE; - end; - FX := MarginsScreenPixels.Left; - FY := FY + FCurBandHeight; - end; - if Band.Height > HeightAvailable then - NewPage; - MF := CurrentPage; - case BandLayout of - blLeft: FY := FY + PaintBand( MF, Band, X, Y ); - blRight: FY := FY + PaintBand( MF, Band, PagePixelsSize.cx - Band.Width, Y ); - blCenter: FY := FY + PaintBand( MF, Band, (PagePixelsSize.cx - Band.Width) div 2, Y ); - blExpandRight: begin - OldW := Band.Width; - try - Band.Width := PagePixelsSize.cx - MarginsScreenPixels.Right - X; - FY := FY + PaintBand( MF, Band, X, Y ); - finally - Band.Width := OldW; - end; - end; - end; - FPageTop := FALSE; - FCurBandHeight := 0; -end; - -procedure TReport.AddFooter(Band: PControl); -begin - AddFooterEx( Band, blLeft ); -end; - -procedure TReport.AddFooterEx(Band: PControl; BandLayout: TBandLayout); -var MF: TMF; - OldW: Integer; -begin - if Band.Height > HeightAvailable then - NewPage; - MF := CurrentPage; - case BandLayout of - blLeft: FBottom := FBottom - PaintBand( MF, Band, 0, FBottom - Band.Height ); - blRight: FBottom := FBottom - PaintBand( MF, Band, - PagePixelsSize.cx - Band.Width, FBottom - Band.Height ); - blCenter: FBottom := FBottom - PaintBand( MF, Band, - (PagePixelsSize.cx - Band.Width) div 2, FBottom - Band.Height ); - blExpandRight: begin - OldW := Band.Width; - try - Band.Width := PagePixelsSize.cx - - MarginsScreenPixels.Left - MarginsScreenPixels.Right; - FBottom := FBottom - PaintBand( MF, Band, 0, FBottom - Band.Height ); - finally - Band.Width := OldW; - end; - end; - end; -end; - -function TReport.AddPage: TMF; -var MF: TMF; - R: TRect; - DC0: HDC; -begin - DC0 := GetDC( 0 ); - R := MakeRect( 0, 0, - MulDiv(PagePixelsSize.cx, GetDeviceCaps(DC0, HORZSIZE)*100, GetDeviceCaps(DC0, HORZRES)), - MulDiv(PagePixelsSize.cy, GetDeviceCaps(DC0, VERTSIZE)*100, GetDeviceCaps(DC0, VERTRES)) ); - - MF := CreateEnhMetaFile( DC0, nil, @ R, '' ); - ReleaseDC( 0, DC0 ); - - FDCPages.Add( Pointer( MF ) ); - Result := MF; - FPageTop := TRUE; - FBottom := PagePixelsSize.cy - MarginsScreenPixels.Bottom; - if not fNewPageHandling then - if Assigned( OnNewPage ) then - begin - fNewPageHandling := TRUE; - OnNewPage( @ Self ); - fNewPageHandling := FALSE; - end; -end; - -procedure TReport.AddRight(Band: PControl); -begin - AddRightEx( Band, blLeft ); -end; - -procedure TReport.AddRightEx(Band: PControl; BandLayout: TBandLayout); -var MF: TMF; - OldW: Integer; -begin - if Band.Height > HeightAvailable then - NewPage; - MF := CurrentPage; - if Band.Width > PagePixelsSize.cx - MarginsScreenPixels.Right - X then - begin - if not fNewBandHandling then - if Assigned( OnEndBand ) then - begin - fNewBandHandling := TRUE; - OnEndBand( @ Self ); - fNewBandHandling := FALSE; - end; - FX := MarginsScreenPixels.Left; - FY := FY + FCurBandHeight; - FCurBandHeight := 0; - end; - case BandLayout of - blLeft: PaintBand( MF, Band, X, Y ); - blRight: PaintBand( MF, Band, X + PagePixelsSize.cx - Band.Width, Y ); - blCenter: PaintBand( MF, Band, X + (PagePixelsSize.cx - X - Band.Width) div 2, Y ); - blExpandRight: begin - OldW := Band.Width; - try - Band.Width := PagePixelsSize.cx - MarginsScreenPixels.Right - X; - PaintBand( MF, Band, X, Y ); - finally - Band.Width := OldW; - end; - end; - end; - FX := X + Band.Width; - if FCurBandHeight < Band.Height then - FCurBandHeight := Band.Height; - FPageTop := FALSE; -end; - -procedure TReport.Clear; -begin - if FPreviewForm <> nil then - FPreviewForm.Form.Free; - ClearPages; -end; - -destructor TReport.Destroy; -begin - Clear; - FDCPages.Free; - FHDPages.Free; - FDocName := ''; - inherited; -end; - -procedure TReport.DoPreview; -begin - if PageCount = 0 then Exit; - PreviewForm.Form.DoubleBuffered := DoubleBufferedPreview; - PreviewForm.FReport := @ Self; - PreviewForm.Form.Caption := FDocName; - PreviewForm.Form.Show; -end; - -procedure TReport.DoPreviewModal; -begin - if PageCount = 0 then Exit; - PreviewForm.Form.DoubleBuffered := DoubleBufferedPreview; - PreviewForm.FReport := @ Self; - PreviewForm.Form.Caption := FDocName; - PreviewForm.Form.ShowModal; - FPreviewForm.Form.Free; - FPreviewForm := nil; -end; - -procedure TReport.DoPrint; -begin - PrintPages( 0, PageCount-1 ); -end; - -procedure TReport.DoPrintPreview(Proc: TObjectMethod); -begin - if Printing then Abort; - if Assigned( FOnPrint ) then - begin - Clear; - FStage := 1; - FOnPrint( @ Self ); - if PageCount = 0 then Exit; - Clear; - FStage := 2; - FOnPrint( @ Self ); - end; - Proc; -end; - -function TReport.GetCurrentPage: TMF; -begin - if PageCount = 0 then - Result := AddPage - else - Result := Pages[ PageCount-1 ]; -end; - -function TReport.GetOrientation: TPrinterOrientation; -begin - Result := Printer.Orientation; -end; - -function TReport.GetPageHeight: Integer; -begin - GetPageWidthHeight; - Result := FPageHeight; -end; - -function TReport.GetPagePixelsSize: TSize; -var I: Integer; - P: TPoint; - DC0: HDC; -begin - if (FPagePixelsSize.cx = 0) or (FPagePixelsSize.cy = 0) then - begin - case PaperSize of - psA3: P := MakePoint( 297, 420 ); - psA4: P := MakePoint( 210, 297 ); - psA5: P := MakePoint( 148, 210 ); - psA6: P := MakePoint( 105, 148 ); - psLetter: P := MakePoint( 216, 280 ); - else P := MakePoint( FCustomPaperSize.cx, FCustomPaperSize.cy ); - end; - DC0 := GetDC( 0 ); - FPagePixelsSize.cx := Round( (P.x * 0.039370) * GetDeviceCaps( DC0, LOGPIXELSX ) ); - FPagePixelsSize.cy := Round( (P.y * 0.039370) * GetDeviceCaps( DC0, LOGPIXELSY ) ); - ReleaseDC( 0, DC0 ); - end; - Result := FPagePixelsSize; - if Orientation = poLandscape then - begin - I := Result.cx; - Result.cx := Result.cy; - Result.cy := I; - end; -end; - -function TReport.GetPageCount: Integer; -begin - Result := FDCPages.Count; -end; - -function TReport.GetPageWidth: Integer; -begin - GetPageWidthHeight; - Result := FPageWidth; -end; - -procedure TReport.GetPageWidthHeight; -begin - if (FPageWidth <> 0) and (FPageHeight <> 0) then Exit; - if Printer.Printing then - begin - FPageWidth := Printer.PageWidth; - FPageHeight := Printer.PageHeight; - end - else - begin - Printer.BeginDoc; - TRY - FPageWidth := Printer.PageWidth; - FPageHeight := Printer.PageHeight; - FINALLY - Printer.Abort; - END; - end; -end; - -function TReport.GetPreviewForm: PPreviewObj; -begin - if FPreviewForm = nil then - begin - NewPreviewForm( FPreviewForm, Applet ); - FPreviewForm.FReport := @ Self; - end; - Result := FPreviewForm; -end; - -function TReport.GetPrinter: PPrinter; -begin - if FPrinter = nil then - FPrinter := GetProviderPrinter; - Result := FPrinter; -end; - -function TReport.HeightAvailable: Integer; -begin - Result := FBottom - FY; -end; - -procedure TReport.NewPage; -begin - FY := MarginsScreenPixels.Top; - FX := MarginsScreenPixels.Left; - AddPage; -end; - -function TReport.PaintBand(MF: TMF; Band: PControl; Xpos, Ypos: Integer): Integer; - - procedure PaintBandWithChildren( Band: PControl; DC: HDC ); - var I: Integer; - C: PControl; - P0, P: TPoint; - R0, R1, R2: TRect; - Save: Integer; - FontHeight0Replaced: Boolean; - begin - FontHeight0Replaced := FALSE; - if (ReplaceFontHeight0 <> 0) and (Band.Font.FontHeight = 0) then - begin - FontHeight0Replaced := TRUE; - Band.Font.FontHeight := ReplaceFontHeight0; - end; - Band.Perform( WM_PRINT, DC, PRF_NONCLIENT ); - GetClientRect( Band.Handle, R0 ); - P0 := MakePoint( 0, 0 ); - ClientToScreen( Band.Handle, P0 ); - GetWindowOrgEx( DC, P ); - GetWindowRect( Band.Handle, R1 ); - OffsetRect( R0, P0.x - R1.Left, P0.y - R1.Top ); - SetWindowOrgEx( DC, P.x - (P0.x - R1.Left), P.y - (P0.y - R1.Top), @ P ); - IntersectClipRect( DC, R0.Left, R0.Top, R0.Right, R0.Bottom ); - Band.Perform( WM_ERASEBKGND, DC, 0 ); - Band.Perform( WM_PAINT, DC, 0 ); - GetWindowRect( Band.Handle, R1 ); - for I := 0 to Band.ChildCount-1 do - begin - Save := SaveDC( DC ); - C := Band.Children[ I ]; - GetWindowRect( C.Handle, R2 ); - SetWindowOrgEx( DC, P.x - (R2.Left - R1.Left), P.y - (R2.Top - R1.Top), nil ); - IntersectClipRect( DC, 0, 0, R2.Right - R2.Left, R2.Bottom - R2.Top ); - PaintBandWithChildren( C, DC ); - RestoreDC( DC, Save ); - end; - if FontHeight0Replaced then - Band.Font.FontHeight := 0; - end; - -var OldParent: PControl; - WasVisible: Boolean; - WasBR: TRect; - P: TPoint; - Save: Integer; - -begin - OldParent := Band.Parent; - OldParent.CreateWindow; - WasVisible := Band.Visible; - WasBR := Band.BoundsRect; - try - Band.Visible := FALSE; - Band.Parent := Applet; - Band.Top := Applet.Height; - SetParent( Band.GetWindowHandle, Applet.Handle ); - Band.Visible := TRUE; - - Save := SaveDC( MF ); - GetWindowOrgEx( MF, P ); - SetWindowOrgEx( MF, P.x - Xpos, P.y - Ypos, nil ); - - PaintBandWithChildren( Band, MF ); - - SetWindowOrgEx( MF, P.x, P.y, nil ); - RestoreDC( MF, Save ); - - finally - Band.Visible := FALSE; - Band.Parent := OldParent; - SetParent( Band.Handle, OldParent.Handle ); - Band.BoundsRect := WasBR; - Band.Visible := WasVisible; - end; - Result := Band.Height; -end; - -procedure TReport.Preview; -begin - DoPrintPreview( DoPreview ); -end; - -procedure TReport.PreviewModal; -begin - DoPrintPreview( DoPreviewModal ); -end; - -procedure TReport.Print; -begin - DoPrintPreview( DoPrint ); -end; - -function TReport.ScaleX(W: Integer): Integer; -begin - Result := Round( W * Printer.PageWidth / PagePixelsSize.cx ); -end; - -function TReport.ScaleY(H: Integer): Integer; -begin - Result := Round( H * Printer.PageHeight / PagePixelsSize.cy ); -end; - -procedure TReport.SetCustomPaperSize(const Value: TSize); -const PapSizes: array[ TPaperSize, 1..2] of Integer = ( ( 210, 297 ), - ( 148, 210 ), ( 105, 148 ), ( 297, 420 ), (216, 280), ( 0, 0 ) ); -var PSidx: TPaperSize; -begin - FCustomPaperSize := Value; - for PSidx := Low( TPaperSize ) to Pred( High( TPaperSize ) ) do - begin - if (PapSizes[ PSidx ][ 1 ] = Value.cx) and - (PapSizes[ PSidx ][ 2 ] = Value.cy) then - begin - PaperSize := PSidx; - exit; - end; - end; - PaperSize := psCustom; -end; - -procedure TReport.SetPageTop(const Value: Boolean); -begin - FPageTop := Value; -end; - -procedure TReport.SetPaperSize(const Value: TPaperSize); -begin - if FPaperSize = Value then Exit; - if FPrinting then Abort; - FPaperSize := Value; -end; - -procedure TReport.SetPreviewForm(const Value: PPreviewObj); -begin - if FPreviewForm = Value then Exit; - if FPreviewForm <> nil then - FPreviewForm.Form.Free; - FPreviewForm := Value; -end; - -procedure TReport.SetPrinter(const Value: PPrinter); -begin - if FPrinter = Value then Exit; - if FPrinting then Abort; - FPrinter := Value; - FPageWidth := 0; - FPageHeight := 0; -end; - -procedure TReport.SetX(const Value: Integer); -begin - if FX = Value then Exit; - FX := Value; -end; - -procedure TReport.SetY(const Value: Integer); -begin - if FY = Value then Exit; - FY := Value; - FCurBandHeight := 0; -end; - -function TReport.GetPages(Idx: Integer): TMF; -begin - Result := TMF( FDCPages.Items[ Idx ] ); -end; - -function TReport.GetImages(Idx: Integer): HENHMETAFILE; -begin - while FHDPages.Count <= Idx do - FHDPages.Add( nil ); - if FHDPages.Items[ Idx ] = nil then - begin - FHDPages.Items[ Idx ] := Pointer( CloseEnhMetafile( Pages[ Idx ] ) ); - FDCPages.Items[ Idx ] := nil; - end; - Result := HENHMETAFILE( FHDPages.Items[ Idx ] ); -end; - -procedure TReport.PrintPages(FromPage, ToPage: Integer); -var I: Integer; - MF: HENHMETAFILE; - PrintingStarted: Boolean; - N: Integer; -begin - PrintingStarted := FALSE; - TRY - for I := FromPage to ToPage do - begin - MF := Images[ I ]; - if I = 0 then - begin - Printer.Title := FDocName; - Printer.BeginDoc; - PrintingStarted := TRUE; - end; - N := 1; - while PageWidth > PagePixelsSize.cx * N do - Inc( N ); - PlayEnhMetaFile( Printer.Canvas.Handle, MF, - MakeRect( 0, 0, PageWidth-1, PageHeight-1 ) ); - - if I < ToPage then - Printer.NewPage; - end; - FINALLY - if PrintingStarted then - Printer.EndDoc; - END; -end; - -procedure TReport.ClearPages; -var I: Integer; -begin - for I := PageCount-1 downto 0 do - DeleteEnhMetaFile( Images[ I ] ); - FDCPages.Clear; - FHDPages.Clear; - FY := MarginsScreenPixels.Top; - FX := MarginsScreenPixels.Left; - FPagePixelsSize.cx := 0; // force recalculation of Page size -end; - -procedure TReport.SetMargins(const Value: TMargins); -begin - if (fMargins.Left = Value.Left) and - (fMargins.Top = Value.Top) and - (fMargins.Right = Value.Right) and - (fMargins.Bottom = Value.Bottom) then Exit; - if FPrinting then Abort; - FMargins := Value; -end; - -function TReport.GetMarginsPixels( const Index: Integer ): TMargins; -var DC: HDC; -begin - if Index = 1 then DC := Printer.Canvas.Handle - else DC := GetDC( 0 ); - Result.Left := Round( Margins.Left / 1000 / 2.55 * GetDeviceCaps( DC, LOGPIXELSX ) ); - Result.Right := Round( Margins.Right / 1000 / 2.55 * GetDeviceCaps( DC, LOGPIXELSX ) ); - Result.Top := Round( Margins.Top / 1000 / 2.55 * GetDeviceCaps( DC, LOGPIXELSY ) ); - Result.Bottom := Round( Margins.Bottom / 1000 / 2.55 * GetDeviceCaps( DC, LOGPIXELSY ) ); - if Index <> 1 then - ReleaseDC( 0, DC ); -end; - -{ TPreviewObj } - -procedure TPreviewObj.AdjustButtons( Sender: PObj ); -begin - TB.TBButtonEnabled[ TBFrst ] := FCurPage > 0; - TB.TBButtonEnabled[ TBPrev ] := FCurPage > 0; - TB.TBButtonEnabled[ TBNext ] := FCurPage < PageCount - 1; - TB.TBButtonEnabled[ TBLast ] := FCurPage < PageCount - 1; - TB.TBButtonEnabled[ TBPrnt ] := PageCount > 0; - {$IFDEF use_MHPRINTER} - TB.TBButtonEnabled[ TBExit ] := TRUE; - {$ENDIF} - if PageCount = 0 then - LB.Caption := '' - else - LB.Caption := 'Page ' + Int2Str( FCurPage + 1 ) + ' from ' + Int2Str( PageCount ); -end; - -procedure TPreviewObj.AdjustFitMode; -var K: Double; -begin - if PageCount = 0 then Exit; - case FFitMode of - 0: begin // fit Height - PB.Height := SB.ClientHeight; - K := FReport.PagePixelsSize.cx / FReport.PagePixelsSize.cy; - PB.Width := Round( K * SB.ClientHeight ); - SetScrollPos( SB.Handle, SB_VERT, 0, TRUE ); - end; - 1: begin // fit Width - PB.Width := SB.ClientWidth; - K := FReport.PagePixelsSize.cy / FReport.PagePixelsSize.cx; - PB.Height := Round( K * SB.ClientWidth ); - end; - 2: begin // 1:1 - PB.Width := FReport.PagePixelsSize.cx; - PB.Height := FReport.PagePixelsSize.cy; - end; - end; -end; - -destructor TPreviewObj.Destroy; -begin - FBuf.Free; - PSD.Free;{Brandys} - inherited; -end; - -function TPreviewObj.PageCount: Integer; -begin - Result := FReport.FDCPages.Count; -end; - -procedure TPreviewObj.PaintPage(Sender: PControl; DC: HDC); -var MF: HENHMETAFILE; - Tmp: PBitmap; - R: TRect; -begin - if FCurPage >= PageCount then Exit; - MF := FReport.Images[ FCurPage ]; - AdjustFitMode; - {if (PB.Width = FReport.PagePixelsSize.cx) and - (PB.Height = FReport.PagePixelsSize.cy) then - PlayEnhMetaFile( DC, MF, MakeRect( 0, 0, PB.Width, PB.Height ) ) - else} - begin - if (FBufPage <> FCurPage) or (FBuf = nil) or - (FBuf.Width <> PB.ClientWidth) or (FBuf.Height <> PB.ClientHeight) then - begin - FBuf.Free; - FBufPage := FCurPage; - FBuf := NewDIBBitmap( PB.ClientWidth, PB.ClientHeight, pf24bit ); - FBuf.Canvas.Brush.Color := clWhite; - FBuf.Canvas.FillRect( MakeRect( 0, 0, FBuf.Width, FBuf.Height ) ); - SetStretchBltMode( FBuf.Canvas.Handle, HALFTONE ); - SetBrushOrgEx( FBuf.Canvas.Handle, 0, 0, nil ); - {R := MakeRect( FReport.MarginsScreenPixels.Left, - FReport.MarginsScreenPixels.Top, - FBuf.Width-1 - FReport.MarginsScreenPixels.Right, - FBuf.Height-1 - FReport.MarginsScreenPixels.Bottom );} - R := MakeRect( 0, 0, FBuf.Width-1, FBuf.Height-1 ); - if FBuf.Width >= FReport.PagePixelsSize.cx then - PlayEnhMetaFile( FBuf.Canvas.Handle, MF, R ) - else - begin - Tmp := NewDIBBitmap( FReport.PagePixelsSize.cx, FReport.PagePixelsSize.cy, pf24bit ); - Tmp.Canvas.Brush.Color := clWhite; - Tmp.Canvas.FillRect( MakeRect( 0, 0, Tmp.Width, Tmp.Height ) ); - PlayEnhMetaFile( Tmp.Canvas.Handle, MF, MakeRect( 0, 0, Tmp.Width-1, Tmp.Height-1 ) ); - Inc( R.Right ); Inc( R.Bottom ); - Tmp.StretchDraw( FBuf.Canvas.Handle, R ); - Tmp.Free; - end; - end; - FBuf.Draw( DC, 0, 0 ); - end; -end; - -{$IFDEF use_MHPRINTER} -procedure TPreviewObj.PrinterSetup; -begin - ShowMessage( 'Not implementer.' ); -end; -{$ELSE} -procedure TPreviewObj.PrinterSetup; -var - Orientation: TPrinterOrientation; - PgSz: TSize; - M: TRect; -begin - Orientation := Printer.Orientation; - PgSz.cx := Printer.PageWidth; - PgSz.cy := Printer.PageHeight; - if not Assigned( FReport.OnPrint ) then - Options := Options - [ psdOrientation ]; - if PSD = nil then - PSD := NewPageSetupDialog( Form, Options ); - PSD.SetMargins( FReport.FMargins.Left, FReport.FMargins.Top, - FReport.FMargins.Right, FReport.FMargins.Bottom ); - if PSD.Execute then - begin - Printer.Assign(PSD.Info);//assign selected options to printer DC - M := PSD.GetMargins; - if Assigned( FReport.OnPrint ) then - if (Printer.Orientation <> Orientation) or - (Printer.PageWidth <> PgSz.cx) or - (Printer.PageHeight <> PgSz.cy) or - not CompareMem( @ M, @ FReport.FMargins, Sizeof( M ) ) then - begin - FReport.FMargins := M; - FCurPage := 0; - FReport.ClearPages; - PgSz.cx := GetDeviceCaps( Printer.Canvas.Handle, HORZSIZE ); - PgSz.cy := GetDeviceCaps( Printer.Canvas.Handle, VERTSIZE ); - FReport.CustomPaperSize := PgSz; - FReport.OnPrint( FReport ); - end; - Printer.AssignMargins(M,mgMillimeters); - end; -end; -{$ENDIF} - -procedure TPreviewObj.PrintAllPages; -begin - FReport.DoPrint; -end; - -procedure TPreviewObj.ResizePreviewForm(Sender: PObj); -begin - AdjustFitMode; -end; - -procedure TPreviewObj.SetCurPage(const Value: Integer); -begin - FCurPage := Value; - AdjustButtons( @ Self ); -end; - -procedure TPreviewObj.SetFitMode(const Value: Integer); -begin - if FFitMode = Value then Exit; - FFitMode := Value; - AdjustFitMode; - PB.Invalidate; -end; - -procedure TPreviewObj.TBClick(Sender: PObj); -begin - case PControl(Sender).CurIndex of - TBFrst: { << } FCurPage := 0; - TBPrev: { < } if FCurPage > 0 then Dec( FCurPage ); - TBNext: { > } if FCurPage < PageCount - 1 then Inc( FCurPage ); - TBLast: { >> } FCurPage := PageCount - 1; - TBPrnt: {Print} PrintAllPages; - TBSetu: {Setup} PrinterSetup; - TBView: {View} TBDropDownViewMenu( TB ); - TBExit: {Close} begin Form.Close; Exit; end; - end; - AdjustButtons( @ Self ); -end; - -procedure TPreviewObj.TBDropDownViewMenu(Sender: PObj); -var R: TRect; -begin - R := TB.TBButtonRect[ TBView ]; - R.Top := R.Bottom; - R.TopLeft := TB.Client2Screen( R.TopLeft ); - ViewMenu.RadioCheck( FitMode ); - ViewMenu.Popup( R.Left, R.Top ); -end; - -procedure TPreviewObj.TBViewMenuClick(Sender: PMenu; Item: Integer); -begin - FitMode := Item; -end; - -end. diff --git a/Addons/KOLSocket.pas b/Addons/KOLSocket.pas deleted file mode 100644 index 97a518d..0000000 --- a/Addons/KOLSocket.pas +++ /dev/null @@ -1,845 +0,0 @@ -unit KOLSocket; - -interface - -uses - KOL, Windows, Messages, Winsock; - -const - WM_SOCKET = WM_USER + $7000; - WM_SOCKETERROR = WM_USER + $7001; - WM_SOCKETCLOSE = WM_USER + $7002; - WM_SOCKETREAD = WM_USER + $7003; - WM_SOCKETCONNECT = WM_USER + $7004; - WM_SOCKETACCEPT = WM_USER + $7005; - WM_SOCKETWRITE = WM_USER + $7006; - WM_SOCKETOOB = WM_USER + $7007; - WM_SOCKETLISTEN = WM_USER + $7008; - WM_SOCKETLOOKUP = WM_USER + $7009; - - EVENTS_DOLISTEN = FD_CLOSE OR FD_ACCEPT; - EVENTS_DOCONNECT = FD_CONNECT OR FD_CLOSE OR FD_READ; - EVENTS_SETSOCKETHANDLE = FD_READ OR FD_CLOSE OR FD_CONNECT; - - MaxWord = 65535; - MinWord = 0; - - c_FIRST = 1; - - INVALID_SOCKET = winsock.INVALID_SOCKET; - -type - - TWndMethod = procedure(var Message: TMessage) of object; - - PhWnd =^ThWnd; - ThWnd = object( TObj ) - protected - m_hWnd: hWnd; - destructor Destroy; virtual; - public - property Handle: hWnd read m_hWnd; - end; - - PAsyncSocket =^TAsyncSocket; - TKOLSocket = PAsyncSocket; - - TWMSocket = record - Msg: Word; - case Integer of - 0: ( - SocketWParam: Word; - SocketDataSize: LongInt; - SocketNumber: Longint; - SocketAddress: PAsyncSocket); - 1: ( - WParamLo: Byte; - WParamHi: Byte; - SocketEvent: Word; - SocketError: Word; - ResultLo: Word; - ResultHi: Word); - 2: ( - WParam: Word; - TaskHandle: Word; - WordHolder: Word; - pHostStruct: Pointer); - end; - - TBArray = array[0..65534] of byte; - - TBufRecord = record - i: integer; - p:^TBArray; - end; - - TSocketMessageEvent = procedure (SocketMessage: TWMSocket) of object; - - TAsyncSocket = object( TObj ) - m_SockAddr: TSockAddr; - m_Handle: TSocket; - m_hWnd: PhWnd; - fConnected: boolean; - fDNSResult: string; - fDNSHandle: integer; - FDnsBuffer: array [0..MAXGETHOSTSTRUCT] of char; - FList: PList; - FOnError: TSocketMessageEvent; - FOnLookup: TSocketMessageEvent; - FOnAccept: TSocketMessageEvent; - FOnClose: TSocketMessageEvent; - FOnConnect: TSocketMessageEvent; - FOnRead: TSocketMessageEvent; - FOnWrite: TSocketMessageEvent; - FOnListen: TSocketMessageEvent; - FOnOOB: TSocketMessageEvent; - - protected - destructor Destroy; virtual; - - private - function GetCount: LongInt; - function GetPortNumber: LongInt; - function GetIPAddress: String; - function ErrorTest(Evaluation: LongInt): LongInt; - - procedure AllocateSocket; - procedure KillWinsockBug; - procedure SetPortNumber(NewPortNumber: LongInt); - procedure SetIPAddress(NewIPAddress: String); - procedure SetSocketHandle(NewSocketHandle: TSocket); - function GetConnected: boolean; - - // Message Handlers - - procedure HWndProcedure(var Message: TMessage); - - procedure Message_Error(var Message: TWMSocket); - procedure Message_Lookup(var Message: TWMSocket); - procedure Message_Close(var Message: TWMSocket); - procedure Message_Accept(var Message: TWMSocket); - procedure Message_Read(var Message: TWMSocket); - procedure Message_Connect(var Message: TWMSocket); - procedure Message_Write(var Message: TWMSocket); - procedure Message_OOB(var Message: TWMSocket); - procedure Message_Listen(var Message: TWMSocket); - procedure DoReceive(Buffer: Pointer; var ReceiveLen: LongInt); - procedure DoFinal(Abort: boolean); - - public - procedure ProcessMessages; - function DoGetHostByAddr(IPAddr: PChar): String; - function DoGetHostByName(Name: PChar): String; - - procedure DoLookup(host: string); - procedure DoClose; - procedure DoSend(Buffer: Pointer; var SendLen: LongInt); - procedure DoListen; - procedure DoConnect; - procedure DoAccept(var AcceptSocket: PAsyncSocket); - - procedure SendString(fString: String); - - function ReadData(b: pointer; c: integer): integer; - function ReadLine(c: char): string; overload; - function ReadLine(c: char; t: integer): string; overload; - function ErrToStr(Err: LongInt): String; - function LocalIP: String; - function LocalPort: integer; - - property SocketHandle: TSocket read m_Handle write SetSocketHandle; - property IPAddress: String read GetIPAddress write SetIPAddress; - property PortNumber: LongInt read GetPortNumber write SetPortNumber; - property Count: LongInt read GetCount; - property Connected: boolean read GetConnected; - property DNSResult: string read fDNSResult write fDNSResult; - - property OnError: TSocketMessageEvent read FOnError write FOnError; - property OnLookup: TSocketMessageEvent read FOnLookup write FOnLookup; - property OnAccept: TSocketMessageEvent read FOnAccept write FOnAccept; - property OnClose: TSocketMessageEvent read FOnClose write FOnClose; - property OnConnect: TSocketMessageEvent read FOnConnect write FOnConnect; - property OnRead: TSocketMessageEvent read FOnRead write FOnRead; - property OnWrite: TSocketMessageEvent read FOnWrite write FOnWrite; - property OnOOB: TSocketMessageEvent read FOnOOB write FOnOOB; - property OnListen: TSocketMessageEvent read FOnListen write FOnListen; - end; - - function NewThWnd(WndMethod: TWndMethod): PhWnd; - function NewAsyncSocket: PAsyncSocket; - -var - InstanceCount: LongInt = 0; - -implementation - -uses objects; - -function NewThWnd; -begin - New(Result, Create); - Result.m_hWnd := AllocateHWnd(WndMethod); -end; // constructor ThWnd.Create(WndMethod: TWndMethod) - -destructor ThWnd.Destroy; -begin - DeallocateHWnd(m_hWnd); - inherited; -end; - -function NewAsyncSocket; -var - TempWSAData: TWSAData; -begin - InstanceCount := InstanceCount + 1; - New(Result, Create); - if (InstanceCount = c_FIRST) then - Result.ErrorTest(WSAStartup($101, TempWSAData)); - Result.KillWinsockBug; - Result.m_Handle := INVALID_SOCKET; - Result.m_SockAddr.sin_family := AF_INET; - Result.m_SockAddr.sin_addr.s_addr := INet_Addr('0.0.0.0'); - Result.PortNumber := 0; - Result.FList := NewList; - Result.m_hWnd := NewThWnd(Result.HWndProcedure); -end; // constructor TAsyncSocket.Create - -function TAsyncSocket.GetCount; -var i: integer; - t:^TBufRecord; -begin - result := 0; - for i := 0 to FList.Count - 1 do begin - t := FList.Items[i]; - result := result + t^.i; - end; -end; - -function TAsyncSocket.ReadData; -var n, - r: integer; - t:^TBufRecord; - u:^TBufRecord; - a:^TBArray; -begin - if FList.count = 0 then begin - result := 0; - exit; - end; - n := 0; - a := b; - while (n < c) and (n < count) do begin - r := c - n; - t := FList.Items[0]; - if r > t^.i then r := t^.i; - move(t^.p^, a^[n], r); - n := n + r; - if r = t^.i then begin - FreeMem(t^.p, t^.i); - FreeMem(t, SizeOf(TBufRecord)); - FList.Delete(0); - end else begin - GetMem(u, SizeOf(TBufRecord)); - u^.i := t^.i - r; - GetMem(u^.p, u^.i); - move(t^.p^[r], u^.p^, u^.i); - FreeMem(t^.p, t^.i); - FreeMem(t, SizeOf(TBufRecord)); - FList.Items[0] := u; - end; - end; - result := n; -end; - -function TAsyncSocket.ReadLine(c: char): string; -var i, - n, - j: integer; - t:^TBufRecord; - s: string; -begin - result := ''; - n := 0; - if count = 0 then exit; - for i := 0 to FList.Count - 1 do begin - t := FList.Items[i]; - for j := 0 to t^.i - 1 do begin - inc(n); - if chr(t^.p^[j]) = c then begin - if n > 1 then begin - setlength(s, n - 1); - ReadData(@s[1], n - 1); - ReadData(@n , 1); - result := s; - end else begin - ReadData(@n , 1); - result := ''; - end; - exit; - end; - end; - end; -end; - -function TAsyncSocket.ReadLine(c: char; t: integer): string; -var tt: longint; - Msg: tagMSG; -begin - result := ''; - tt := gettickcount; - while (result = '') and (longint(gettickcount) < tt + t * 1000) do begin - if PeekMessage(Msg, m_hWnd.m_hWnd, 0, 0, PM_REMOVE) then begin - DispatchMessage(Msg); - end; - result := ReadLine(c); - if m_Handle = INVALID_SOCKET then exit; - end; -end; - -function TAsyncSocket.GetIPAddress: String; -begin - Result := INet_NToA(m_SockAddr.sin_addr); -end; // function TAsyncSocket.GetIPAddress: String - -function TAsyncSocket.GetPortNumber: LongInt; -begin - Result := NToHS(m_SockAddr.sin_port); -end; // function TAsyncSocket.GetPortNumber: Word - -procedure TAsyncSocket.AllocateSocket; -begin - if (m_Handle = INVALID_SOCKET) then - begin - m_Handle := ErrorTest(socket(AF_INET, SOCK_STREAM, 0)); - end; // if (m_Handle = INVALID_SOCKET) then -end; // procedure TAsyncSocket.AllocateSocket - -procedure TAsyncSocket.SetSocketHandle(NewSocketHandle: TSocket); -begin - DoFinal(True); - m_Handle := NewSocketHandle; - ErrorTest(WSAAsyncSelect(m_Handle, m_hWnd.Handle, WM_SOCKET, EVENTS_SETSOCKETHANDLE)); -end; // procedure TAsyncSocket.SetSocketHandle(NewSocketHandle: TSocket) - -function TAsyncSocket.GetConnected; -begin - result := fConnected; -end; - -function TAsyncSocket.ErrorTest(Evaluation: LongInt): LongInt; -var - TempMessage: TWMSocket; -begin - if ((Evaluation = SOCKET_ERROR) OR (Evaluation = INVALID_SOCKET)) then - begin - TempMessage.Msg := WM_SOCKETERROR; - TempMessage.SocketError := WSAGetLastError; - TempMessage.SocketNumber := m_Handle; - TempMessage.SocketAddress := @self; - Message_Error(TempMessage); - Result := Evaluation; - end // if ((Evaluation = SOCKET_ERROR) OR (Evaluation = INVALID_SOCKET)) then - else - Result := Evaluation; -end; // function ErrorTest(Evaluation: LongInt): LongInt; - -procedure TAsyncSocket.KillWinsockBug; -var - Addr: Integer; -begin - Addr := 0; - // For an unknown reason, if a call is made to GetHostByName and it should - // fail, the following call to GetHostByAddr will not fail, but return '>' - // in the place of the host name. This clears the problem up. - GetHostByName(''); - GetHostByAddr(@Addr, SizeOf(Integer), PF_INET); - GetHostByName(''); -end; - -procedure TAsyncSocket.SetIPAddress(NewIPAddress: String); -var - pTempHostEnt: PHostEnt; -begin - m_SockAddr.sin_addr.s_addr := INet_Addr(PChar(NewIPAddress)); - if (m_SockAddr.sin_addr.s_addr = u_long(INADDR_NONE)) then - begin - pTempHostEnt := GetHostByName(PChar(NewIPAddress)); - if (pTempHostEnt <> Nil) then - m_SockAddr.sin_addr.s_addr := PInAddr(pTempHostEnt^.h_addr_list^)^.s_addr; - end; -end; // procedure TAsyncSocket.SetIPAddress(NewIPAddress: String) - -procedure TAsyncSocket.SetPortNumber(NewPortNumber: LongInt); -begin - if ((NewPortNumber > 0) AND (NewPortNumber <= MaxWord)) then - m_SockAddr.sin_port := HToNS(NewPortNumber); -end; // procedure TAsyncSocket.SetPortNumber(NewPortNumber: Word) - -procedure TAsyncSocket.DoReceive(Buffer: Pointer; var ReceiveLen: LongInt); -begin - ReceiveLen := recv(m_Handle, Buffer^, ReceiveLen, 0); - ErrorTest(ReceiveLen); -end; // TAsyncSocket.DoReceive(Buffer: Pointer; BufferLen: LongInt) - -procedure TAsyncSocket.DoSend(Buffer: Pointer; var SendLen: LongInt); -begin - SendLen := send(m_Handle, Buffer^, SendLen, 0); - ErrorTest(SendLen); -end; // procedure TAsyncSocket.DoSend(Buffer: Pointer; BufferLen: LongInt) - -procedure TAsyncSocket.DoLookup; -var - IPAddr : TInAddr; -begin - if Host = '' then begin - Exit; - end; - - { Cancel any pending lookup } - if FDnsHandle <> 0 then - WSACancelAsyncRequest(FDnsHandle); - - FDnsResult := ''; - - IPAddr.S_addr := Inet_addr(PChar(Host)); - if IPAddr.S_addr <> u_long(INADDR_NONE) then begin - FDnsResult := inet_ntoa(IPAddr); -{ TriggerDnsLookupDone(0);} - Exit; - end; - - FDnsHandle := WSAAsyncGetHostByName(m_hWnd.Handle, - WM_SOCKETLOOKUP, - @Host[1], - @FDnsBuffer, - SizeOf(FDnsBuffer)); - if FDnsHandle = 0 then begin - ErrorTest(WSAGetLastError); - Exit; - end; -end; - -procedure TAsyncSocket.DoClose; -begin - DoFinal(True); -end; - -procedure TAsyncSocket.DoFinal; -var - TempMessage: TWMSocket; -begin - if (m_Handle <> INVALID_SOCKET) then begin - if not Abort then begin - ProcessMessages; - end; - TempMessage.Msg := WM_SOCKETCLOSE; - TempMessage.SocketNumber := m_Handle; - TempMessage.SocketAddress := @self; - Message_Close(TempMessage); - ErrorTest(closesocket(m_Handle)); - m_Handle := INVALID_SOCKET; - end; -end; - -procedure TAsyncSocket.DoAccept(var AcceptSocket: PAsyncSocket); -var - TempSize: Integer; - TempSock: TSocket; - TempAddr: TSockAddrIn; -begin - TempSize := SizeOf(TSockAddr); - TempSock := accept(m_Handle, @TempAddr, @TempSize); - AcceptSocket.m_SockAddr := TempAddr; - if (ErrorTest(TempSock) <> INVALID_SOCKET) then - AcceptSocket.SocketHandle := TempSock; -end; // procedure TAsyncSocket.DoAccept(var AcceptSocket: TAsyncSocket) - -procedure TAsyncSocket.DoListen; -var - TempMessage: TWMSocket; -begin - DoClose; - AllocateSocket; - if - (ErrorTest(WSAAsyncSelect(m_Handle, m_hWnd.Handle, WM_SOCKET, EVENTS_DOLISTEN)) - <> SOCKET_ERROR) AND - (ErrorTest(bind(m_Handle, m_SockAddr, SizeOf(TSockAddr))) <> SOCKET_ERROR) AND - (ErrorTest(listen(m_Handle, 5)) <> SOCKET_ERROR) then - begin - TempMessage.Msg := WM_SOCKETLISTEN; - TempMessage.SocketNumber := m_Handle; - TempMessage.SocketAddress := @self; - Message_Listen(TempMessage); - end - else - DoClose; -end; // procedure TAsyncSocket.DoListen - -procedure TAsyncSocket.DoConnect; -var - TempResult: LongInt; -begin - DoClose; - AllocateSocket; - ErrorTest(WSAAsyncSelect(m_Handle, m_hWnd.Handle, WM_SOCKET, EVENTS_DOCONNECT)); - TempResult := connect(m_Handle, m_SockAddr, SizeOf(TSockAddr)); - if ((TempResult = SOCKET_ERROR) AND (WSAGetLastError <> WSAEWOULDBLOCK)) then - ErrorTest(SOCKET_ERROR); -end; // procedure TAsyncSocket.DoConnect - -procedure TAsyncSocket.SendString; -var - L: LongInt; -begin - L := Length(fString); - DoSend(PChar(fString), L); -end; - -function TAsyncSocket.DoGetHostByName(Name: PChar): String; -var - pTempHostEnt: PHostEnt; -begin - pTempHostEnt := GetHostByName(Name); - if (pTempHostEnt <> Nil) then - Result := inet_ntoa(pInAddr(pTempHostEnt^.h_addr_list^)^) - else - Result := ''; -end; - -procedure TAsyncSocket.ProcessMessages; -var Msg: TMsg; -begin - while PeekMessage(Msg, m_hWnd.m_hWnd, WM_SOCKET, WM_SOCKETLOOKUP, PM_REMOVE) do begin - DispatchMessage(Msg); - end; -end; - -function TAsyncSocket.DoGetHostByAddr(IPAddr: PChar): String; -var - pTempHostEnt: PHostEnt; - TempAddr: LongInt; -begin - TempAddr := INet_Addr(IPAddr); - pTempHostEnt := GetHostByAddr(@TempAddr, SizeOf(TempAddr), PF_INET); - if (pTempHostEnt <> Nil) then - Result := pTempHostEnt^.h_name - else - Result := ''; -end; - -procedure TAsyncSocket.HWndProcedure(var Message: TMessage); -var - TempMessage: TWMSocket; -begin - case Message.Msg of - WM_SOCKETLOOKUP: - begin - TempMessage.Msg := WM_SOCKETLOOKUP; - TempMessage.SocketNumber := m_Handle; - TempMessage.SocketAddress := @self; - Message_Lookup(TempMessage); - end; - WM_SOCKET: - begin - if (Message.LParamHi > WSABASEERR) then - begin - WSASetLastError(Message.LParamHi); - ErrorTest(SOCKET_ERROR); - end // if (Message.LParamHi > WSABASEERR) then - else - begin - case Message.LParamLo of - FD_READ: - begin - TempMessage.SocketDataSize := 0; - ErrorTest(IOCtlSocket(m_Handle, FIONREAD, TempMessage.SocketDataSize)); - TempMessage.Msg := WM_SOCKETREAD; - TempMessage.SocketNumber := m_Handle; - TempMessage.SocketAddress := @self; - Message_Read(TempMessage); - end; // FD_READ - FD_CLOSE: - begin - DoFinal(False); - end; // FD_CLOSE - FD_CONNECT: - begin - TempMessage.Msg := WM_SOCKETCONNECT; - TempMessage.SocketNumber := m_Handle; - TempMessage.SocketAddress := @self; - Message_Connect(TempMessage); - end; // FD_CONNECT - FD_ACCEPT: - begin - TempMessage.Msg := WM_SOCKETACCEPT; - TempMessage.SocketNumber := m_Handle; - TempMessage.SocketAddress := @self; - Message_Accept(TempMessage); - end; // FD_ACCEPT - FD_WRITE: - begin - TempMessage.Msg := WM_SOCKETWRITE; - TempMessage.SocketNumber := m_Handle; - TempMessage.SocketAddress := @self; - Message_Write(TempMessage); - end; // FD_WRITE - FD_OOB: - begin - TempMessage.Msg := WM_SOCKETOOB; - TempMessage.SocketNumber := m_Handle; - TempMessage.SocketAddress := @self; - Message_OOB(TempMessage); - end; // FD_OOB - end; // case Message.LParamLo of - end // else (if (Message.LParamHi > WSABASEERR) then) - end; // WM_SOCKET: - else - Message.Result := DefWindowProc(m_hWnd.m_hWnd, Message.Msg, Message.WParam, Message.LParam); - end; // case Message.Msg of -end; // procedure TAsyncSocket.HWndProcedure(var Message: TMessage) - -procedure TAsyncSocket.Message_Error(var Message: TWMSocket); -begin - if Assigned(FOnError) then FOnError(Message) - else - MessageBox(HWND_DESKTOP, PChar(ErrToStr(Message.SocketError) + ' on socket ' + - Int2Str(Message.SocketNumber)), 'Message_Error', MB_OK); -end; // procedure TAsyncSocket.Message_Error(var Message: TWMSocket) - -procedure TAsyncSocket.Message_Lookup(var Message: TWMSocket); -var p: PHostEnt; -begin - p := @fDNSBuffer; - fDNSResult := p.h_name; - if Assigned(FOnLookup) then FOnLookup(Message) - else - MessageBox(HWND_DESKTOP, PChar('WM_SOCKETLOOKUP on socket ' + Int2Str(Message.SocketNumber)), - 'Message_Lookup', MB_OK); -end; // procedure TAsyncSocket.Message_LookUp(var Message: TWMSocket) - -procedure TAsyncSocket.Message_Close(var Message: TWMSocket); -begin - fConnected := False; - if Assigned(FOnClose) then FOnClose(Message) - else - MessageBox(HWND_DESKTOP, PChar('WM_SOCKETCLOSE on socket ' + Int2Str(Message.SocketNumber)), - 'Message_Close', MB_OK); -end; // procedure TAsyncSocket.Message_Close(var Message: TWMSocket) - -procedure TAsyncSocket.Message_Accept(var Message: TWMSocket); -begin - fConnected := True; - if Assigned(FOnAccept) then FOnAccept(Message) - else - MessageBox(HWND_DESKTOP, PChar('WM_SOCKETACCEPT on socket ' + Int2Str(Message.SocketNumber)), - 'Message_Accept', MB_OK); -end; // procedure TAsyncSocket.Message_Accept(var Message: TWMSocket) - -procedure TAsyncSocket.Message_Read(var Message: TWMSocket); -var t:^TBufRecord; -begin - if Message.SocketDataSize > 0 then begin - fConnected := True; - GetMem(t, sizeof(TBufRecord)); - t^.i := Message.SocketDataSize; - GetMem(t^.p, t^.i); - DoReceive(t^.p, t^.i); - FList.Add(t); - end; - if Assigned(FOnRead) then FOnRead(Message) - else - MessageBox(HWND_DESKTOP, PChar('WM_SOCKETREAD on socket ' + Int2Str(Message.SocketNumber)), - 'Message_Read', MB_OK); -end; // procedure TAsyncSocket.Message_Read(var Message: TWMSocket) - -procedure TAsyncSocket.Message_Connect(var Message: TWMSocket); -begin - fConnected := True; - if Assigned(FOnConnect) then FOnConnect(Message) - else - MessageBox(HWND_DESKTOP, PChar('WM_SOCKETCONNECT on socket ' + Int2Str(Message.SocketNumber)), - 'Message_Connect', MB_OK); -end; // procedure TAsyncSocket.Message_Connect(var Message: TWMSocket) - -procedure TAsyncSocket.Message_Write(var Message: TWMSocket); -begin - fConnected := True; - if Assigned(FOnWrite) then FOnWrite(Message) - else - MessageBox(HWND_DESKTOP, PChar('WM_SOCKETWRITE on socket ' + Int2Str(Message.SocketNumber)), - 'Message_Write', MB_OK); -end; // procedure TAsyncSocket.Message_Write(var Message: TWMSocket) - -procedure TAsyncSocket.Message_OOB(var Message: TWMSocket); -begin - if Assigned(FOnOOB) then FOnOOB(Message) - else - MessageBox(HWND_DESKTOP, PChar('WM_SOCKETOOB on socket ' + Int2Str(Message.SocketNumber)), - 'Message_OOB', MB_OK); -end; // procedure TAsyncSocket.Message_OOB(var Message: TWMSocket) - -procedure TAsyncSocket.Message_Listen(var Message: TWMSocket); -begin - if Assigned(FOnListen) then FOnListen(Message) - else - MessageBox(HWND_DESKTOP, PChar('WM_SOCKETLISTEN on socket ' + Int2Str(Message.SocketNumber)), - 'Message_Listen', MB_OK); -end; // procedure TAsyncSocket.Message_Listen(var Message: TWMSocket) - -destructor TAsyncSocket.Destroy; -var t:^TBufRecord; - i: integer; -begin - DoClose; - if (InstanceCount = c_FIRST) then - ErrorTest(WSACleanup); - m_hWnd.Free; - for i := 0 to FList.Count - 1 do begin - t := FList.Items[i]; - FreeMem(t^.p, t^.i); - FreeMem(t, SizeOf(TBufRecord)); - end; - FList.Free; - InstanceCount := InstanceCount - 1; - inherited; -end; - -function TAsyncSocket.ErrToStr(Err: LongInt): String; -begin - case Err of - WSAEINTR: - Result := 'WSAEINTR'; - WSAEBADF: - Result := 'WSAEBADF'; - WSAEACCES: - Result := 'WSAEACCES'; - WSAEFAULT: - Result := 'WSAEFAULT'; - WSAEINVAL: - Result := 'WSAEINVAL'; - WSAEMFILE: - Result := 'WSAEMFILE'; - WSAEWOULDBLOCK: - Result := 'WSAEWOULDBLOCK'; - WSAEINPROGRESS: - Result := 'WSAEINPROGRESS'; - WSAEALREADY: - Result := 'WSAEALREADY'; - WSAENOTSOCK: - Result := 'WSAENOTSOCK'; - WSAEDESTADDRREQ: - Result := 'WSAEDESTADDRREQ'; - WSAEMSGSIZE: - Result := 'WSAEMSGSIZE'; - WSAEPROTOTYPE: - Result := 'WSAEPROTOTYPE'; - WSAENOPROTOOPT: - Result := 'WSAENOPROTOOPT'; - WSAEPROTONOSUPPORT: - Result := 'WSAEPROTONOSUPPORT'; - WSAESOCKTNOSUPPORT: - Result := 'WSAESOCKTNOSUPPORT'; - WSAEOPNOTSUPP: - Result := 'WSAEOPNOTSUPP'; - WSAEPFNOSUPPORT: - Result := 'WSAEPFNOSUPPORT'; - WSAEAFNOSUPPORT: - Result := 'WSAEAFNOSUPPORT'; - WSAEADDRINUSE: - Result := 'WSAEADDRINUSE'; - WSAEADDRNOTAVAIL: - Result := 'WSAEADDRNOTAVAIL'; - WSAENETDOWN: - Result := 'WSAENETDOWN'; - WSAENETUNREACH: - Result := 'WSAENETUNREACH'; - WSAENETRESET: - Result := 'WSAENETRESET'; - WSAECONNABORTED: - Result := 'WSAECONNABORTED'; - WSAECONNRESET: - Result := 'WSAECONNRESET'; - WSAENOBUFS: - Result := 'WSAENOBUFS'; - WSAEISCONN: - Result := 'WSAEISCONN'; - WSAENOTCONN: - Result := 'WSAENOTCONN'; - WSAESHUTDOWN: - Result := 'WSAESHUTDOWN'; - WSAETOOMANYREFS: - Result := 'WSAETOOMANYREFS'; - WSAETIMEDOUT: - Result := 'WSAETIMEDOUT'; - WSAECONNREFUSED: - Result := 'WSAECONNREFUSED'; - WSAELOOP: - Result := 'WSAELOOP'; - WSAENAMETOOLONG: - Result := 'WSAENAMETOOLONG'; - WSAEHOSTDOWN: - Result := 'WSAEHOSTDOWN'; - WSAEHOSTUNREACH: - Result := 'WSAEHOSTUNREACH'; - WSAENOTEMPTY: - Result := 'WSAENOTEMPTY'; - WSAEPROCLIM: - Result := 'WSAEPROCLIM'; - WSAEUSERS: - Result := 'WSAEUSERS'; - WSAEDQUOT: - Result := 'WSAEDQUOT'; - WSAESTALE: - Result := 'WSAESTALE'; - WSAEREMOTE: - Result := 'WSAEREMOTE'; - WSASYSNOTREADY: - Result := 'WSASYSNOTREADY'; - WSAVERNOTSUPPORTED: - Result := 'WSAVERNOTSUPPORTED'; - WSANOTINITIALISED: - Result := 'WSANOTINITIALISED'; - WSAHOST_NOT_FOUND: - Result := 'WSAHOST_NOT_FOUND'; - WSATRY_AGAIN: - Result := 'WSATRY_AGAIN'; - WSANO_RECOVERY: - Result := 'WSANO_RECOVERY'; - WSANO_DATA: - Result := 'WSANO_DATA'; - else Result := 'UNDEFINED WINSOCK ERROR'; - end; // case Err of -end; // function TAsyncSocket.ErrToStr(Err: LongInt): String - -function TAsyncSocket.LocalIP; -var Name: TSockAddrIn; - len: integer; -begin - GetSockName(m_Handle, Name, len); - Result := int2str(ord(Name.sin_addr.S_un_b.s_b1)) + '.' + - int2str(ord(Name.sin_addr.S_un_b.s_b2)) + '.' + - int2str(ord(Name.sin_addr.S_un_b.s_b3)) + '.' + - int2str(ord(Name.sin_addr.S_un_b.s_b4)); -end; - -function TAsyncSocket.LocalPort; -var Name: TSockAddrIn; - len: integer; - err: integer; - Tmp: TWMSocket; -begin - Result := 0; - err := GetSockName(m_Handle, Name, len); - if err = 0 then begin - Result := NToHS(Name.sin_port); - end else begin - Tmp.Msg := WM_SOCKETERROR; - Tmp.SocketError := WSAGetLastError; - Tmp.SocketNumber := m_Handle; - Tmp.SocketAddress := @self; - Message_Error(Tmp); - end; -end; - -end. - diff --git a/Addons/KOLZLibBzip.pas b/Addons/KOLZLibBzip.pas index 5d7aa33..f9bf5d2 100644 --- a/Addons/KOLZLibBzip.pas +++ b/Addons/KOLZLibBzip.pas @@ -145,7 +145,7 @@ function gZipCompressStream(inStream, outStream: PStream; level: TZCompressionLe function gZipDecompressStreamHeader(inStream: PStream; var gzHdr: TgzipHeader): Integer; function gZipDecompressStreamBody(inStream, outStream: PStream; const aCheckCRC: Boolean = True): Integer; function gZipDecompressStream(inStream, outStream: PStream; var gzHdr: TgzipHeader): Integer; -function gZipDecompressString(const S: String; const useheaders: Boolean = True; const aCheckCRC: Boolean = True): String; +function gZipDecompressString(const S: AnsiString; const useheaders: Boolean = True; const aCheckCRC: Boolean = True): AnsiString; {*******************************************************} { } @@ -1643,7 +1643,7 @@ begin Result := gZipDecompressStreamBody(inStream, outStream); end; -function gZipDecompressString(const S: String; const useheaders: Boolean = True; const aCheckCRC: Boolean = True): String; +function gZipDecompressString(const S: AnsiString; const useheaders: Boolean = True; const aCheckCRC: Boolean = True): AnsiString; var Rslt: Integer; gzHdr: TgzipHeader; diff --git a/Addons/ListEdit.pas b/Addons/ListEdit.pas deleted file mode 100644 index 8ded923..0000000 --- a/Addons/ListEdit.pas +++ /dev/null @@ -1,264 +0,0 @@ -unit ListEdit; - -interface -uses KOL, Windows, Messages, objects; - -const - WM_JUSTFREE = WM_USER + 51; - WM_EDITFREE = WM_USER + 52; - WM_DBLCLICK = WM_USER + 53; - WM_ROWCHANG = WM_USER + 54; - -type - - PListEdit =^TListEdit; - TKOLListEdit = PControl; - TListEdit = object(Tobj) - EList: PList; - Enter: boolean; - LView: PControl; - TabSave: boolean; - TabStrt: boolean; - OldWind: longint; - NewWind: longint; - CurEdit: integer; - destructor destroy; virtual; - procedure SetEvents(LV: PControl); - procedure NewWndProc(var Msg: TMessage); - procedure LVPaint; - procedure LVDblClk; - procedure LVChange(Store: boolean); - procedure PostFree(var Key: integer); - procedure EDChar(Sender: PControl; var Key: integer; Sh: Cardinal); - procedure EDPres(Sender: PControl; var Key: integer; Sh: Cardinal); - procedure EDentr(Sender: PObj); - end; - -function NewListEdit(AParent: PControl; Style: TListViewStyle; Options: TListViewOptions; - ImageListSmall, ImageListNormal, ImageListState: PImageList): PControl; - -implementation - -function NewListEdit; -var p: PListEdit; -begin - Result := NewListView(AParent, Style, Options, ImageListSmall, ImageListNormal, ImageListState); - Result.CreateWindow; - New(p, create); - AParent.Add2AutoFree(p); - p.LView := Result; - p.SetEvents(PControl(Result)); -end; - -destructor TListEdit.destroy; -begin - LVChange(False); - EList.Free; - SetWindowLong(LView.Handle, GWL_WNDPROC, OldWind); - FreeObjectInstance(Pointer(NewWind)); - inherited; -end; - -procedure TListEdit.SetEvents; -begin - EList := NewList; - Enter := False; - TabStrt := False; - OldWind := GetWindowLong(LV.Handle, GWL_WNDPROC); - NewWind := LongInt(MakeObjectInstance(NewWndProc)); - SetWindowLong(LV.Handle, GWL_WNDPROC, NewWind); -end; - -procedure TListEdit.NewWndProc; -var e: boolean; -begin - e := EList.Count > 0; - case Msg.Msg of -WM_LBUTTONDOWN: - begin - LVChange(True); - CurEdit := 0; - if e then PostMessage(LView.Handle, WM_DBLCLICK, 0, 0); - end; -WM_LBUTTONDBLCLK: - begin - LVDblClk; - end; -WM_KEYDOWN: - begin - if Msg.WParam = 13 then begin - LVDblClk; - end else -{ if Msg.WParam = 27 then begin - LVChange(False); - end else begin - LVChange(True); - if e then PostMessage(LView.Handle, WM_DBLCLICK, 0, 0); - end;} - end; -WM_NCPAINT: - begin - LVPaint; - end; -WM_JUSTFREE: - begin - LVChange(Msg.WParam <> 27); - end; -WM_EDITFREE: - begin - LVChange(Msg.WParam <> 27); - if e then PostMessage(LView.Handle, WM_DBLCLICK, 0, 0); - end; -WM_DBLCLICK: - begin - LVDblClk; - end; -WM_PAINT: - begin - LVPaint; - end; - end; - Msg.Result := CallWindowProc(Pointer(OldWind), LView.Handle, Msg.Msg, Msg.wParam, Msg.lParam); -end; - -procedure TListEdit.LVPaint; -var i: integer; - r: TRect; - l: integer; - e: PControl; - p: TPoint; -begin -with LView^ do begin - SendMessage(Handle, WM_SETFONT, Font.Handle, 0); - l := 0; - p := LVItemPos[0]; - for i := 0 to EList.Count - 1 do begin - r := LVItemRect(LVCurItem, lvipBounds); - r.Left := l + p.X; - r.Right := l + LVColWidth[i] + p.X; - Dec(r.Top); - Inc(r.Bottom); - e := EList.Items[i]; - e.BoundsRect := r; - l := l + LVColWidth[i]; - end; -end; -end; - -procedure TListEdit.LVDblClk; -var i: integer; - e: PControl; - r: TRect; - l: integer; - a: PControl; - p: TPoint; - o: TPoint; -begin -with LView^ do begin - if EList.Count <> 0 then LVChange(True); - if enter then exit; - enter := true; - l := 0; - a := nil; - GetCursorPos(p); - p := Screen2Client(p); - o := LVItemPos[0]; - for i := 0 to LVColCount - 1 do begin - r := LVItemRect(LVCurItem, lvipBounds); - r.Left := l + o.X; - r.Right := l + LVColWidth[i] + o.X; - l := l + LVColWidth[i]; - Dec(r.Top); - Inc(r.Bottom); - e := NewEditBox(LView, []); - EList.Add(e); - e.BoundsRect := r; - e.DoubleBuffered := True; - e.Tabstop := True; - e.Font.FontHeight := LView.Font.FontHeight; - e.Font.FontCharset := 204; - e.Text := LVItems[LVCurItem, i]; - e.OnKeyDown := EDChar; - e.OnKeyUp := EDPres; - e.OnEnter := EDEntr; - e.Show; - if a = nil then a := e; - if (CurEdit <> 0) then - if (EList.Count = CurEdit) then a := e else else - if (r.Left <= p.x) and (r.Right >= p.x) then - a := e; - end; - if a <> nil then a.Focused := True; - TabSave := TabStop; - TabStop := False; - TabStrt := True; - enter := false; -end; -end; - -procedure TListEdit.LVChange; -var e: PControl; - i: integer; - g: boolean; -begin -with LView^ do begin - if enter then exit; - enter := true; - g := False; - for i := 0 to EList.Count - 1 do begin - e := EList.Items[i]; - if Store then begin - g := g or (LVItems[LVCurItem, i] <> e.Text); - LVItems[LVCurItem, i] := e.Text; - end; - if e.Focused then CurEdit := i + 1; - e.Free; - end; - EList.Clear; - enter := false; - if TabStrt then TabStop := TabSave; - if g then - SendMessage(Parent.Handle, WM_ROWCHANG, LVCurItem, 0); -end; -end; - -procedure TListEdit.PostFree; -begin -with LView^ do begin - if Key = 27 then - PostMessage(Handle, WM_JUSTFREE, key, 0); - if Key = 13 then - PostMessage(Handle, WM_EDITFREE, key, 0); - if ((key = 40) and (LView.LVCurItem < LView.LVCount - 1)) or - ((key = 38) and (LView.LVCurItem > 0)) then begin - PostMessage(Handle, WM_EDITFREE, key, 0); - PostMessage(Handle, wm_keydown, Key, 0); - PostMessage(Handle, wm_keyup, Key, 0); - end; -end; -end; - -procedure TListEdit.EDChar; -begin - case key of - 13, - 27, - 38, - 40: PostFree(key); - end; -end; - -procedure TListEdit.EDPres; -begin - case key of - 38, - 40: key := 0; - end; -end; - -procedure TListEdit.EDentr; -begin - PControl(Sender).SelectAll; -end; - -end. diff --git a/Addons/MCKPageSetup.pas b/Addons/MCKPageSetup.pas deleted file mode 100644 index 01f9514..0000000 --- a/Addons/MCKPageSetup.pas +++ /dev/null @@ -1,104 +0,0 @@ -unit mckPageSetup; - -interface - -uses - KOL,KOLPageSetupDialog,Windows, Classes,Graphics, - mirror,mckObjs ; - -type - - TKOLPageSetupDialog = class(TKOLObj) - private - fOptions : TPageSetupOptions; - fAlwaysReset : Boolean; - protected - function AdditionalUnits: string; override; - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure SetOptions(const Value : TPageSetupOptions); - procedure SetAlwaysReset(const Value : Boolean); - public - constructor Create( AOwner: TComponent ); override; - destructor Destroy;override; - published - property Options : TPageSetupOptions read fOptions write SetOptions; - property AlwaysReset : Boolean read fAlwaysReset write SetAlwaysReset; - end; - - - - procedure Register; - -implementation - -{$R *.dcr} - - - -constructor TKOLPageSetupDialog.Create( AOwner: TComponent ); -begin -inherited Create(Aowner); -fAlwaysReset := false; -fOptions := [psdMargins,psdOrientation,psdSamplePage,psdPaperControl,psdPrinterControl]; -end; - -destructor TKOLPageSetupDialog.Destroy; -begin -inherited Destroy; -end; - - - - -procedure TKOLPageSetupDialog.SetAlwaysReset(const Value: Boolean); -begin - fAlwaysReset := Value; - Change; -end; - - -procedure TKOLPageSetupDialog.SetOptions(const Value : TPageSetupOptions); -begin - fOptions := Value; - Change; -end; - -function TKOLPageSetupDialog.AdditionalUnits; -begin - Result := ', KOLPageSetupDialog'; -end; - - -procedure TKOLPageSetupDialog.SetupFirst(SL: TStringList; const AName, - AParent, Prefix: String); - var - s : String; - begin - if (psdMargins in fOptions) then s := s + ',psdMargins'; - if (psdOrientation in fOptions) then s := s + ',psdOrientation'; - if (psdSamplePage in fOptions) then s := s + ',psdSamplePage'; - if (psdPaperControl in fOptions) then s := s + ',psdPaperControl'; - if (psdPrinterControl in fOptions) then s := s + ',psdPrinterControl'; - if (psdHundredthsOfMillimeters in fOptions) then s := s + ',psdHundredthsOfMillimeters'; - if (psdThousandthsOfInches in fOptions) then s := s + ',psdThousandthsOfInches'; - if (psdUseMargins in fOptions) then s := s + ',psdUseMargins'; - if (psdUseMinMargins in fOptions) then s := s + ',psdUseMinMargins'; - if (psdWarning in fOptions) then s := s + ',psdWarning'; - if (psdHelp in fOptions) then s := s + ',psdHelp'; - if (psdReturnDC in fOptions) then s:= s + ',psdReturnDC'; - if s <> '' then - if s[1] = ',' then s[1] := Chr(32); - SL.Add(Prefix + AName + ' := NewPageSetupDialog(' + AParent + ',[' + s + ']);'); - if fAlwaysReset then SL.Add(Prefix + AName + '.AlwaysReset := True;'); - end; - - - - -procedure Register; -begin - RegisterComponents('KOLAddons', [TKOLPageSetupDialog]); -end; - -end. - diff --git a/Addons/MCKPrintDialogs.pas b/Addons/MCKPrintDialogs.pas deleted file mode 100644 index eaabc10..0000000 --- a/Addons/MCKPrintDialogs.pas +++ /dev/null @@ -1,144 +0,0 @@ -unit mckPrintDialogs; - -interface - -uses - KOL,KOLPrintDialogs,Windows, Classes,Graphics, - mirror,mckObjs ; - -type - - TKOLPrintDialog = class(TKOLObj) - private - ftagPD : tagPD; - fOptions : TPrintDlgOptions; - fAlwaysReset : Boolean; - protected - function AdditionalUnits: string; override; - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure SetOptions(const Value : TPrintDlgOptions); - procedure SetFromPage(const Value : WORD); - procedure SetToPage(const Value : WORD); - procedure SetMinPage(const Value : WORD); - procedure SetMaxPage(const Value : WORD); - procedure SetCopies(const Value : WORD); - procedure SetAlwaysReset(const Value : Boolean); - public - constructor Create( AOwner: TComponent ); override; - published - property FromPage : WORD read ftagPD.nFromPage write SetFromPage; - property ToPage : WORD read ftagPD.nToPage write SetToPage; - property MinPage : WORD read ftagPD.nMinPage write SetMinPage; - property MaxPage : WORD read ftagPD.nMaxPage write SetMaxPage; - property Copies : WORD read ftagPD.nCopies write SetCopies; - property Options : TPrintDlgOptions read fOptions write SetOptions; - property AlwaysReset : Boolean read fAlwaysReset write SetAlwaysReset; - end; - - - procedure Register; - -implementation - -{$R *.dcr} - - - - -constructor TKOLPrintDialog.Create( AOwner: TComponent ); -begin -inherited Create(Aowner); -fAlwaysReset := false; -FromPage := 1; -ToPage := 1; -MinPage := 1; -MaxPage := 1; -Copies := 1; -end; - -procedure TKOLPrintDialog.SetAlwaysReset(const Value : Boolean); -begin - fAlwaysReset := Value; - Change; -end; - -procedure TKOLPrintDialog.SetOptions(const Value : TPrintDlgOptions); -begin - fOptions := Value; - Change; -end; - -procedure TKOLPrintDialog.SetFromPage(const Value : WORD); -begin - ftagPD.nFromPage := Value; - Change; -end; - -procedure TKOLPrintDialog.SetToPage(const Value : WORD); -begin - ftagPD.nToPage := Value; - Change; -end; - -procedure TKOLPrintDialog.SetMinPage(const Value : WORD); -begin - ftagPD.nMinPage := Value; - Change; -end; - -procedure TKOLPrintDialog.SetMaxPage(const Value : WORD); -begin - ftagPD.nMaxPage := Value; - Change; -end; - -procedure TKOLPrintDialog.SetCopies(const Value : WORD); -begin - ftagPD.nCopies := Value; - Change; -end; - - - - -function TKOLPrintDialog.AdditionalUnits; -begin - Result := ', KOLPrintDialogs'; -end; - - -procedure TKOLPrintDialog.SetupFirst(SL: TStringList; const AName, - AParent, Prefix: String); - var - s : String; - begin - if (pdPrinterSetup in fOptions) then s := s + ',pdPrinterSetup'; - if (pdCollate in fOptions) then s := s + ',pdCollate'; - if (pdPrintToFile in fOptions) then s := s + ',pdPrintToFile'; - if (pdPageNums in fOptions) then s := s + ',pdPageNums'; - if (pdSelection in fOptions) then s := s + ',pdSelection'; - if (pdWarning in fOptions) then s := s + ',pdWarning'; - if (pdDeviceDepend in fOptions) then s := s + ',pdDeviceDepend'; - if (pdHelp in fOptions) then s := s + ',pdHelp'; - if (pdReturnDC in fOptions) then s:= s + ',pdReturnDC'; - if s <> '' then - if s[1] = ',' then s[1] := Chr(32); - SL.Add( Prefix + AName + ' := NewPrintDialog(' + AParent + ',[' + s + ']);'); - if fAlwaysReset then SL.Add(Prefix + AName + '.AlwaysReset := true;'); - SL.Add(Prefix + AName + '.FromPage :=' + Int2Str(Integer(ftagPD.nFromPage)) + ';'); - SL.Add(Prefix + AName + '.ToPage :=' + Int2Str(Integer(ftagPD.nToPage)) + ';'); - SL.Add(Prefix + AName + '.MinPage :=' + Int2Str(Integer(ftagPD.nMinPage)) + ';'); - SL.Add(Prefix + AName + '.MaxPage :=' + Int2Str(Integer(ftagPD.nMaxPage)) + ';'); - SL.Add(Prefix + AName + '.Copies :=' + Int2Str(Integer(ftagPD.nCopies)) + ';'); - end; - - - - -procedure Register; -begin - RegisterComponents('KOLAddons', [TKOLPrintDialog]); -end; - -end. - diff --git a/Addons/MCKReport.pas b/Addons/MCKReport.pas deleted file mode 100644 index fb47955..0000000 --- a/Addons/MCKReport.pas +++ /dev/null @@ -1,314 +0,0 @@ -unit MCKReport; - -interface - -uses KOL, Windows, Messages, Dialogs, Forms, Classes, Controls, Graphics, SysUtils, - mirror, mckCtrls, KOLReport; - -type - TKOLReport = class( TKOLObj ) - private - FOnNewBand: TOnEvent; - FOnPrint: TOnEvent; - FOnNewPage: TOnEvent; - FDoubleBufferedPreview: Boolean; - FDocumentName: String; - procedure SetOnNewBand(const Value: TOnEvent); - procedure SetOnNewPage(const Value: TOnEvent); - procedure SetOnPrint(const Value: TOnEvent); - procedure SetDoubleBufferedPreview(const Value: Boolean); - procedure SetDocumentName(const Value: String); - protected - function AdditionalUnits: String; override; - procedure AssignEvents( SL: TStringList; const AName: String ); override; - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - published - property OnPrint: TOnEvent read FOnPrint write SetOnPrint; - property OnNewPage: TOnEvent read FOnNewPage write SetOnNewPage; - property OnNewBand: TOnEvent read FOnNewBand write SetOnNewBand; - property DoubleBufferedPreview: Boolean read FDoubleBufferedPreview write SetDoubleBufferedPreview; - property DocumentName: String read FDocumentName write SetDocumentName; - end; - - TKOLBand = class( TKOLPanel ) - private - FFrames: TFrames; - procedure SetFrames(const Value: TFrames); - protected - function SetupParams( const AName, AParent: String ): String; override; - function AdditionalUnits: String; override; - procedure Set_VA(const Value: TVerticalAlign); override; - public - constructor Create( AOwner: TComponent ); override; - function NoDrawFrame: Boolean; override; - procedure Paint; override; - published - property Frames: TFrames read FFrames write SetFrames; - end; - - TKOLReportLabel = class( TKOLLabel ) - private - FFrames: TFrames; - procedure SetFrames(const Value: TFrames); - protected - function AdditionalUnits: String; override; - public - constructor Create( AOwner: TComponent ); override; - function TypeName: String; override; - function NoDrawFrame: Boolean; override; - function AdjustVerticalAlign( Value: TVerticalAlign ): TVerticalAlign; override; - function SetupParams( const AName, AParent: String ): String; override; - procedure Paint; override; - function BorderNeeded: Boolean; override; - published - property Frames: TFrames read FFrames write SetFrames; - property Border; - end; - -procedure Register; - -{$R KOLReport.dcr} - -implementation - -procedure Register; -begin - RegisterComponents( 'KOLAddons', [ TKOLReport, TKOLBand, TKOLReportLabel ] ); -end; - -function CalcFrames( const Frames: TFrames ): String; -begin - Result := ''; - if frLeft in Frames then - Result := 'frLeft,'; - if frTop in Frames then - Result := Result + 'frTop,'; - if frRight in Frames then - Result := Result + 'frRight,'; - if frBottom in Frames then - Result := Result + 'frBottom,'; - if Result <> '' then - Delete( Result, Length( Result ), 1 ); - Result := '[' + Result + ']'; -end; - -type - TFakeControl = class( TControl ) - public - property Color; - end; - -{ TKOLReport } - -function TKOLReport.AdditionalUnits: String; -begin - Result := inherited AdditionalUnits + ', KOLReport'; -end; - -procedure TKOLReport.AssignEvents(SL: TStringList; const AName: String); -begin - inherited; - DoAssignEvents( SL, AName, [ 'OnPrint', 'OnNewPage', 'OnNewBand' ], - [ @ OnPrint, @ OnNewPage, @ OnNewBand ] ); -end; - -procedure TKOLReport.SetDocumentName(const Value: String); -begin - FDocumentName := Value; - Change; -end; - -procedure TKOLReport.SetDoubleBufferedPreview(const Value: Boolean); -begin - FDoubleBufferedPreview := Value; - Change; -end; - -procedure TKOLReport.SetOnNewBand(const Value: TOnEvent); -begin - FOnNewBand := Value; - Change; -end; - -procedure TKOLReport.SetOnNewPage(const Value: TOnEvent); -begin - FOnNewPage := Value; - Change; -end; - -procedure TKOLReport.SetOnPrint(const Value: TOnEvent); -begin - FOnPrint := Value; - Change; -end; - -procedure TKOLReport.SetupFirst(SL: TStringList; const AName, AParent, - Prefix: String); -begin - inherited; - if DoubleBufferedPreview then - SL.Add( Prefix + AName + '.DoubleBufferedPreview := TRUE;' ); - if Trim( DocumentName ) <> '' then - SL.Add( Prefix + AName + '.DocumentName := ' + String2PascalStrExpr( DocumentName ) + ';' ); -end; - -{ TKOLBand } - -function TKOLBand.AdditionalUnits: String; -begin - Result := inherited AdditionalUnits + ', KOLReport'; -end; - -constructor TKOLBand.Create(AOwner: TComponent); -begin - inherited; - EdgeStyle := esNone; - if (AOwner <> nil) and (AOwner is TControl) and - (TFakeControl(AOwner).Color = clWhite) then - else - begin - ParentColor := FALSE; - Color := clWhite; - end; - if (AOwner <> nil) and (AOwner is TControl) and - (TFakeControl(AOwner).Font.Color = clBlack) and - (TFakeControl(AOwner).Font.Name = 'Arial') then - else - begin - ParentFont := FALSE; - Font.Color := clBlack; - Font.FontName := 'Arial'; - end; - Width := 400; - Height := 40; - Border := 1; -end; - -function TKOLBand.NoDrawFrame: Boolean; -begin - Result := TRUE; -end; - -procedure TKOLBand.Paint; -var W, H, B: Integer; -begin - inherited; - Canvas.Brush.Color := Font.Color; - W := ClientWidth; - H := ClientHeight; - B := Border; - if frLeft in Frames then - Canvas.FillRect( Rect( 0, 0, B, H ) ); - if frTop in Frames then - Canvas.FillRect( Rect( 0, 0, W, B ) ); - if frRight in Frames then - Canvas.FillRect( Rect( W - B, 0, W, H ) ); - if frBottom in Frames then - Canvas.FillRect( Rect( 0, H - B, W, H ) ); -end; - -procedure TKOLBand.SetFrames(const Value: TFrames); -begin - FFrames := Value; - Change; - Invalidate; -end; - -function TKOLBand.SetupParams(const AName, AParent: String): String; -begin - Result := AParent + ', ' + CalcFrames( Frames ); -end; - -procedure TKOLBand.Set_VA(const Value: TVerticalAlign); -begin - fVerticalAlign := Value; - Change; - Invalidate; -end; - -{ TKOLReportLabel } - -function TKOLReportLabel.AdditionalUnits: String; -begin - Result := inherited AdditionalUnits + ', KOLReport'; -end; - -function TKOLReportLabel.AdjustVerticalAlign( - Value: TVerticalAlign): TVerticalAlign; -begin - Result := Value; -end; - -function TKOLReportLabel.BorderNeeded: Boolean; -begin - Result := TRUE; -end; - -constructor TKOLReportLabel.Create(AOwner: TComponent); -begin - inherited; - if (AOwner <> nil) and (AOwner is TControl) and - (TFakeControl(AOwner).Color = clWhite) then - else - begin - ParentColor := FALSE; - Color := clWhite; - end; - if (AOwner <> nil) and (AOwner is TControl) and - (TFakeControl(AOwner).Font.Color = clBlack) and - (TFakeControl(AOwner).Font.Name = 'Arial') then - else - begin - ParentFont := FALSE; - Font.Color := clBlack; - Font.FontName := 'Arial'; - end; - Border := 1; - DefaultAutoSize := TRUE; - AutoSize := TRUE; -end; - -function TKOLReportLabel.NoDrawFrame: Boolean; -begin - Result := TRUE; -end; - -procedure TKOLReportLabel.Paint; -var W, H, B: Integer; -begin - inherited; - Canvas.Brush.Color := Font.Color; - W := ClientWidth; - H := ClientHeight; - B := Border; - if frLeft in Frames then - Canvas.FillRect( Rect( 0, 0, B, H ) ); - if frTop in Frames then - Canvas.FillRect( Rect( 0, 0, W, B ) ); - if frRight in Frames then - Canvas.FillRect( Rect( W - B, 0, W, H ) ); - if frBottom in Frames then - Canvas.FillRect( Rect( 0, H - B, W, H ) ); -end; - -procedure TKOLReportLabel.SetFrames(const Value: TFrames); -begin - FFrames := Value; - Change; - Invalidate; -end; - -function TKOLReportLabel.SetupParams(const AName, AParent: String): String; -begin - Result := inherited SetupParams( AName, AParent ) + ', ' + CalcFrames( Frames ); -end; - -function TKOLReportLabel.TypeName: String; -begin - if WordWrap then - Result := 'WordWrapReportLabel' - else - Result := 'ReportLabel'; -end; - -end. diff --git a/Addons/kolTCPSocket.pas b/Addons/kolTCPSocket.pas deleted file mode 100644 index bf9e6ed..0000000 --- a/Addons/kolTCPSocket.pas +++ /dev/null @@ -1,974 +0,0 @@ -unit kolTCPSocket; - -//////////////////////////////////////////////////////////////////// -// -// TTTTTTTTTT CCCCCCCC PPPPPPPPP -// T TTTT T CCCC CCCC PPPP PPPP -// TTTT CCCC PPPP PPPP -// TTTT CCCC PPPP PPPP -// TTTT CCCC PPPPPPPPP -// TTTT CCCC CCCC PPPP -// TTTT CCCCCCCC PPPP -// -// S O C K E T -// -// TCPServer, TCPClient implementation for Key Objects Library -// -// (c) 2002 by Vorobets Roman -// Roman.Vorobets@p25.f8.n454.z2.fidonet.org -// -//////////////////////////////////////////////////////////////////// - -interface - -uses - kol,windows,winsock,messages; - -const - WM_SOCKET=WM_USER+1; - WM_SOCKETDESTROY=WM_USER+2; - -type - twndmethod=procedure(var message:tmessage) of object; - - PTCPBase=^TTCPBase; - PTCPServer=^TTCPServer; - PTCPClient=^TTCPClient; - PTCPServerClient=^TTCPServerClient; - - TKOLTCPClient=PTCPClient; - TKOLTCPServer=PTCPServer; - - TOnTCPClientEvent = procedure(Sender: PTCPClient) of object; - TOnTCPStreamSend = TOnTCPClientEvent; - TOnTCPStreamReceive = TOnTCPClientEvent; - TOnTCPConnect = TOnTCPClientEvent; - TOnTCPManualReceive = TOnTCPClientEvent; - TOnTCPDisconnect = TOnTCPClientEvent; - - TOnTCPReceive = procedure(Sender: PTCPClient; var Buf: array of byte; const Count: Integer) of object; - TOnTCPResolve = procedure(Sender: PTCPClient; const IP: String) of object; - TOnTCPAccept = function(Sender: PTCPServer; const IP: String; - const Port: SmallInt):boolean of object; - TOnTCPClientConnect = procedure(Sender: PTCPServerClient) of object; - TOnTCPError = procedure(Sender: PObj; const Error:integer) of object; - - TTCPBase=object(TObj) - private - FWnd:HWnd; - FConnecting: Boolean; - function GetWnd: HWnd; - procedure Method(var message:tmessage);virtual; - procedure DoClose; - private - FPort: SmallInt; - FOnConnect: TOnTCPConnect; - FOnDisconnect: TOnTCPDisconnect; - FOnError: TOnTCPError; - FHandle: TSocket; - FConnected: Boolean; - FSection: TRTLCriticalSection; - property Wnd:HWnd read GetWnd; - function GetPort: SmallInt; - procedure SetPort(const Value: SmallInt); - procedure SetOnConnect(const Value: TOnTCPConnect); - procedure SetOnDisconnect(const Value: TOnTCPDisconnect); - procedure SetOnError(const Value: TOnTCPError); - procedure SetHandle(const Value: TSocket); - function ErrorTest(const e: integer): boolean; - protected - procedure Creating;virtual; - destructor Destroy;virtual; - public - property Connected:Boolean read FConnected; - property Online:Boolean read FConnected; - property Connecting:Boolean read FConnecting; - property Handle:TSocket read FHandle write SetHandle; - property Port:SmallInt read GetPort{FPort} write SetPort; - property OnError:TOnTCPError read FOnError write SetOnError; - property OnConnect:TOnTCPConnect read FOnConnect write SetOnConnect; - property OnDisconnect:TOnTCPDisconnect read FOnDisconnect write SetOnDisconnect; - procedure Lock; - procedure Unlock; - procedure Disconnect;virtual; - end; - - TTCPServer=object(TTCPBase) - private - FConnections: PList; - FOnAccept: TOnTCPAccept; - FOnClientConnect: TOnTCPClientConnect; - FOnClientDisconnect: TOnTCPDisconnect; - FOnClientError: TOnTCPError; - FOnClientReceive: TOnTCPReceive; - FOnClientManualReceive: TOnTCPManualReceive; - FOnClientStreamReceive: TOnTCPStreamReceive; - FOnClientStreamSend: TOnTCPStreamSend; - procedure SetOnAccept(const Value: TOnTCPAccept); - procedure SetOnClientConnect(const Value: TOnTCPClientConnect); - procedure SetOnClientDisconnect(const Value: TOnTCPDisconnect); - procedure SetOnClientError(const Value: TOnTCPError); - procedure SetOnClientReceive(const Value: TOnTCPReceive); - function GetConnection(Index: Integer): PTCPServerClient; - function GetCount: Integer; - procedure Method(var message: tmessage); virtual; - procedure SetOnClientManualReceive(const Value: TOnTCPManualReceive); - procedure SetOnClientStreamReceive(const Value: TOnTCPStreamReceive); - procedure SetOnClientStreamSend(const Value: TOnTCPStreamSend); - protected - procedure Creating;virtual; - destructor Destroy;virtual; - public - property OnAccept:TOnTCPAccept read FOnAccept write SetOnAccept; - property OnClientError:TOnTCPError read FOnClientError write SetOnClientError; - property OnClientConnect:TOnTCPClientConnect read FOnClientConnect write SetOnClientConnect; - property OnClientDisconnect:TOnTCPDisconnect read FOnClientDisconnect write SetOnClientDisconnect; - property OnClientReceive:TOnTCPReceive read FOnClientReceive write SetOnClientReceive; - property OnClientManualReceive:TOnTCPManualReceive read FOnClientManualReceive write SetOnClientManualReceive; - property OnClientStreamSend:TOnTCPStreamSend read FOnClientStreamSend write SetOnClientStreamSend; - property OnClientStreamReceive:TOnTCPStreamReceive read FOnClientStreamReceive write SetOnClientStreamReceive; - property Count:Integer read GetCount; - property Connection[Index: Integer]: PTCPServerClient read GetConnection; - procedure Listen; - procedure Disconnect;virtual; - end; - - TTCPClient=object(TTCPBase) - private - FHost: String; - FBuffer: array[0..4095] of byte; - FOnResolve: TOnTCPResolve; - FOnReceive: TOnTCPReceive; - FOnStreamSend: TOnTCPStreamSend; - FSendStream: PStream; - FSendAutoFree: Boolean; - FReceiveStream: PStream; - FReceiveAutoFree: Boolean; - FReceiveAutoFreeSize: Integer; - FReceiveStartPos: Integer; - FOnManualReceive: TOnTCPManualReceive; - FOnStreamReceive: TOnTCPStreamReceive; - FIndex: Integer; - procedure SetHost(const Value: String); - procedure SetOnResolve(const Value: TOnTCPResolve); - procedure SetOnReceive(const Value: TOnTCPReceive); - procedure SetOnStreamSend(const Value: TOnTCPStreamSend); - procedure Method(var message:tmessage);virtual; - function SendStreamPiece: Boolean; - procedure SetOnManualReceive(const Value: TOnTCPManualReceive); - procedure SetOnStreamReceive(const Value: TOnTCPStreamReceive); - procedure SetIndex(const Value: Integer);virtual; - protected - destructor Destroy;virtual; - public - property OnReceive:TOnTCPReceive read FOnReceive write SetOnReceive; - property OnManualReceive:TOnTCPManualReceive read FOnManualReceive write SetOnManualReceive; - property OnResolve:TOnTCPResolve read FOnResolve write SetOnResolve; - property OnStreamSend:TOnTCPStreamSend read FOnStreamSend write SetOnStreamSend; - property OnStreamReceive:TOnTCPStreamReceive read FOnStreamReceive write SetOnStreamReceive; - property Host:String read FHost write SetHost; - property Index:Integer read FIndex write SetIndex; - function StreamSending:Boolean; - function StreamReceiving:Boolean; - procedure Connect;virtual; - function Send(var Buf; const Count: Integer): Integer; - procedure SendString(S: String); - function SendStream(Stream: PStream; const AutoFree: Boolean): Boolean; - procedure SetReceiveStream(Stream: PStream; const AutoFree: Boolean=false; - const AutoFreeSize: Integer=0); - function ReceiveLength: Integer; - function ReceiveBuf(var Buf; Count: Integer): Integer; - end; - - TTCPServerClient=object(TTCPClient) - private - FIP: String; - FServer: PTCPServer; - procedure SetIndex(const Value: Integer);virtual; - public - property IP: String read FIP; - procedure Connect;virtual; - procedure Disconnect;virtual; - end; - -function NewTCPServer: PTCPServer; -function NewTCPClient: PTCPClient; -function Err2Str(const id: integer): string; -function TCPGetHostByName(name: pchar): string; - -procedure Startup; -procedure Cleanup; - -implementation - -type - pobjectinstance=^tobjectinstance; - tobjectinstance=packed record - code:byte; - offset:integer; - case integer of - 0:(next:pobjectinstance); - 1:(method:twndmethod); - end; - - pinstanceblock=^tinstanceblock; - tinstanceblock=packed record - next:pinstanceblock; - code:array[1..2] of byte; - wndprocptr:pointer; - instances: array[0..$ff] of tobjectinstance; - end; - -var - instblocklist:pinstanceblock; - instfreelist:pobjectinstance; - - wsadata:twsadata; - -function NewTCPServerClient(Server: PTCPServer): PTCPServerClient;forward; - -function stdwndproc(window:hwnd;message:dword;wparam:WPARAM; - lparam:LPARAM):LRESULT;stdcall;assembler; -asm - XOR EAX,EAX - PUSH EAX - PUSH LParam - PUSH WParam - PUSH Message - MOV EDX,ESP - MOV EAX,[ECX].Longint[4] - CALL [ECX].Pointer - ADD ESP,12 - POP EAX -end; - -function calcjmpoffset(src,dest:pointer):longint; -begin - result:=longint(dest)-(longint(src)+5); -end; - -function MakeObjectInstance(Method: TWndMethod): Pointer; -const - blockcode:array[1..2] of byte=($59,$E9); - pagesize=4096; -var - block:pinstanceblock; - instance:pobjectinstance; -begin - if instfreelist=nil then - begin - block:=virtualalloc(nil,PageSize, MEM_COMMIT,PAGE_EXECUTE_READWRITE); - block^.next:=instblocklist; - move(blockcode,block^.code,sizeof(blockcode)); - block^.wndprocptr:=pointer(calcjmpoffset(@block^.code[2],@stdwndproc)); - instance:=@block^.instances; - repeat - instance^.code:=$E8; - instance^.offset:=calcjmpoffset(instance,@block^.code); - instance^.next:=instfreelist; - instfreelist:=instance; - inc(longint(instance),sizeof(tobjectinstance)); - until longint(instance)-longint(block)>=sizeof(tinstanceblock); - instblocklist:=block; - end; - result:=instfreelist; - instance:=instfreelist; - instfreelist:=instance^.next; - instance^.method:=method; -end; - -procedure FreeObjectInstance(ObjectInstance: Pointer); -begin - if objectinstance<>nil then - begin - pobjectinstance(objectinstance)^.next:=instfreelist; - instfreelist:=objectinstance; - end; -end; - -var - utilclass:twndclass=(lpfnwndproc:@defwindowproc;lpszclassname:'TCPSocket'); - -function AllocateHWnd(Method: TWndMethod): HWND; -var - tempclass:twndclass; - classregistered:boolean; -begin - utilclass.hinstance:=hinstance; - classregistered:=getclassinfo(hinstance,utilclass.lpszclassname,tempclass); - if not classregistered or (tempclass.lpfnwndproc<>@defwindowproc) then - begin - if classregistered then unregisterclass(utilclass.lpszclassname,hinstance); - registerclass(utilclass); - end; - result:=createwindowex(WS_EX_TOOLWINDOW,utilclass.lpszclassname,nil, - WS_POPUP,0,0,0,0,0,0,hinstance,nil); - if assigned(method) then setwindowlong(result,GWL_WNDPROC,longint(makeobjectinstance(method))); -end; - -procedure DeallocateHWnd(Wnd: HWND); -var - instance:pointer; -begin - instance:=pointer(getwindowlong(wnd,GWL_WNDPROC)); - destroywindow(wnd); - if instance<>@defwindowproc then freeobjectinstance(instance); -end; - -procedure Startup; -begin - if bool(wsastartup($101,wsadata)) then showmessage('WSAStartup error.'); -end; - -procedure Cleanup; -begin - if bool(wsacleanup) then showmessage('WSACleanup error'); -end; - -{ TTCPBase } - -procedure TTCPBase.Creating; -begin - startup; - initializecriticalsection(fsection); - fhandle:=SOCKET_ERROR; -end; - -destructor TTCPBase.Destroy; -begin - if fwnd<>0 then deallocatehwnd(fwnd); - doclose; - disconnect; - deletecriticalsection(fsection); - cleanup; -end; - -procedure TTCPBase.Disconnect; -begin - if fhandle<>SOCKET_ERROR then - begin - doclose; - if fconnected then - begin - fconnected:=false; - if assigned(ondisconnect) then ondisconnect(@self); - end; - fconnecting:=false; - end; -end; - -procedure TTCPBase.DoClose; -begin - if fhandle<>SOCKET_ERROR then - begin - errortest(closesocket(fhandle)); - fhandle:=SOCKET_ERROR; - end; -end; - -function TTCPBase.ErrorTest(const e: integer): boolean; -var - wsae: Integer; -begin -{ msgok(int2str(e)); - msgok(int2str(SOCKET_ERROR)); - msgok(int2str(INVALID_SOCKET)); } - - result:= (e = SOCKET_ERROR) or (e = INVALID_SOCKET); - if result then begin - wsae:=wsagetlasterror; - if wsae<>WSAEWOULDBLOCK then - begin - if assigned(onerror) then onerror(@self,wsae) else - showmessage('Socket error '+err2str(wsae)+' on socket '+int2str(fhandle)); - end else result:=false; - end; -end; - -function TTCPBase.GetWnd: HWnd; -begin - if fwnd=0 then fwnd:=allocatehwnd(method); - result:=fwnd; -end; - -procedure TTCPBase.Lock; -begin - entercriticalsection(fsection); -end; - -procedure TTCPBase.Method(var message: tmessage); -begin - if message.msg<>WM_SOCKET then exit; - if message.lparamhi>WSABASEERR then - begin - wsasetlasterror(message.lparamhi); - errortest(SOCKET_ERROR); - if fconnecting then doclose; - fconnecting:=false; - end; - case message.lparamlo of - FD_CLOSE:begin - fconnected:=false; - fconnecting:=false; - if assigned(ondisconnect) then ondisconnect(@self); - if fhandle<>SOCKET_ERROR then doclose; - end; - end; -end; - -procedure TTCPBase.SetHandle(const Value: TSocket); -begin - FHandle := Value; -end; - -procedure TTCPBase.SetOnDisconnect(const Value: TOnTCPDisconnect); -begin - FOnDisconnect := Value; -end; - -procedure TTCPBase.SetOnError(const Value: TOnTCPError); -begin - FOnError := Value; -end; - -procedure TTCPBase.SetPort(const Value: SmallInt); -begin - FPort := Value; -end; - -function TTCPBase.GetPort: SmallInt; -var buf: sockaddr_in; bufSz: Integer; -begin - if FConnected then - begin - bufSz := SizeOf(buf); - ZeroMemory( @buf, bufSz ); - getsockname(fhandle, buf, bufSz); - FPort := htons(buf.sin_port); - end; - Result := FPort; -end; - -function NewTCPServer: PTCPServer; -begin - new(result,create); - result.creating; -end; - -function NewTCPClient: PTCPClient; -begin - new(result,create); - result.creating; -end; - -function NewTCPServerClient(Server: PTCPServer): PTCPServerClient; -begin - new(result,create); - result.creating; - result.fserver:=server; -end; - -procedure TTCPBase.Unlock; -begin - leavecriticalsection(fsection); -end; - -{ TTCPClient } - -procedure TTCPClient.Connect; -var - adr: TSockAddr; -begin - disconnect; - fhandle:= socket(AF_INET, SOCK_STREAM, IPPROTO_TCP); - if not errortest(fhandle) then begin - WSAAsyncSelect(fhandle, wnd, WM_SOCKET, FD_READ or FD_WRITE or FD_CONNECT or FD_CLOSE); - with adr do begin - sin_family:= AF_INET; - sin_port:= htons(port); - //Integer(sin_addr):= inet_addr(PChar(host)); - sin_addr.S_addr:= inet_addr(PChar(host)); - - if Integer(sin_addr) = SOCKET_ERROR then begin - sin_addr.S_addr:= PInAddr(gethostbyname(PChar(Host)).h_addr_list^)^.S_addr; - end; - -//msgok('bly' + int2str(sin_addr.S_addr)); - {if Integer(sin_addr) = SOCKET_ERROR then begin - // must be WSAAsyncGetHostByName - ph:= winsock.gethostbyname(pchar(host)); - if ph=nil then showmessage('gethostbyname() error'); - move(ph.h_addr^^,sin_addr,ph.h_length); - if assigned(onresolve) then onresolve(@self,inet_ntoa(adr.sin_addr)); - end;} - - end; - fconnecting:= not errortest(Integer(adr.sin_addr)) and not errortest(WinSock.connect(fhandle, adr, SizeOf(adr))); - if not fconnecting then doclose; - end; -end; - -destructor TTCPClient.Destroy; -begin - if fsendautofree and (fsendstream<>nil) then fsendstream.free; - fsendstream:=nil; - inherited; -end; - -function TTCPClient.StreamReceiving: Boolean; -begin - Result:= Assigned(FReceiveStream); -end; - -function TTCPClient.StreamSending: Boolean; -begin - Result:= Bool(fsendstream); -end; - -procedure TTCPClient.Method(var message: tmessage); -var - sz:integer; -begin - inherited; - if (message.msg<>WM_SOCKET) then exit; - if message.lparamhi>WSABASEERR then - begin - if message.lparamlo=FD_CLOSE then - begin - if streamsending then - begin - if fsendautofree then fsendstream.free; - if assigned(onstreamsend) then onstreamsend(@self); - end; - if streamreceiving then - begin - if freceiveautofree then freceivestream.free; - if assigned(onstreamreceive) then onstreamreceive(@self); - end; - end; - end else - case message.lparamlo of - FD_CONNECT:begin - fconnected:=true; - fconnecting:=false; - if assigned(onconnect) then onconnect(@self); - end; - FD_READ:if (freceivestream=nil) and assigned(onmanualreceive) then onmanualreceive(@self) else - begin - lock; -// repeat - ioctlsocket(fhandle,FIONREAD,sz); - if sz>0 then - begin - if sz>sizeof(fbuffer) then sz:=sizeof(fbuffer); - sz:=receivebuf(fbuffer,sz); - errortest(sz); - if freceivestream<>nil then - begin - freceivestream.write(fbuffer,sz); - if assigned(onstreamreceive) then onstreamreceive(@self); - end else if assigned(onreceive) then onreceive(@self,fbuffer,sz); - end; -// until (sz<=0) or //not fmaxsendstreamspeed or -// ((freceivestream<>nil) and freceiveautofree and -// (freceivestream.size>=freceiveautofreesize)); - unlock; - if (freceivestream<>nil) and freceiveautofree and - (integer(freceivestream.position)+freceivestartpos>=freceiveautofreesize) then - begin - freceivestream.free; - freceivestream:=nil; - if assigned(onstreamreceive) then onstreamreceive(@self); - end; - end; - FD_WRITE:if streamsending then sendstreampiece;// else if assigned(onwrite) then onwrite(@self); - end; -end; - -function TTCPClient.ReceiveBuf(var Buf; Count: Integer): Integer; -begin - result:=0; - if not fconnected or (fhandle=SOCKET_ERROR) or (count<=0) then exit; - lock; - result:=recv(fhandle,buf,count,0); - errortest(result); - unlock; -end; - -function TTCPClient.ReceiveLength: Integer; -begin - if fhandle<>SOCKET_ERROR then - ioctlsocket(fhandle,FIONREAD,result) - else result:=0; -end; - -function TTCPClient.Send(var Buf; const Count: Integer): Integer; -begin - result:=winsock.send(fhandle,buf,count,0); -end; - -function TTCPClient.SendStream(Stream: PStream; const AutoFree: Boolean): Boolean; -begin - result:=false; - if fsendstream=nil then - begin - fsendstream:=stream; - fsendautofree:=autofree; - result:=sendstreampiece; - end; -end; - -function TTCPClient.SendStreamPiece: Boolean; -var - buf:array[0..4095] of byte; - startpos,amountinbuf,amountsent:integer; -begin - result:=false; - if not fconnected or (fhandle=SOCKET_ERROR) or (fsendstream=nil) then exit; - lock; - repeat - startpos:=fsendstream.position; - amountinbuf:=fsendstream.read(buf,sizeof(buf)); - if amountinbuf>0 then - begin - amountsent:=send(buf,amountinbuf); - if amountsent=SOCKET_ERROR then - begin - if errortest(SOCKET_ERROR) then - begin - fsendstream:=nil; - break; - end else - begin - fsendstream.position:=startpos; - break; - end; - end else - if amountinbuf>amountsent then fsendstream.position:=startpos+amountsent else - if fsendstream.position=fsendstream.size then - begin - if fsendautofree then fsendstream.free; - fsendstream:=nil; - break; - end; - end else - begin - fsendstream:=nil; - break; - end; - until false; - result:=true; - unlock; - if assigned(onstreamsend) then onstreamsend(@self); -end; - -procedure TTCPClient.SendString(S: String); -begin - send(s[1], length(s)); -end; - -procedure TTCPClient.SetHost(const Value: String); -begin - FHost := Value; -end; - -procedure TTCPClient.SetIndex(const Value: Integer); -begin - FIndex := Value; -end; - -procedure TTCPBase.SetOnConnect(const Value: TOnTCPConnect); -begin - FOnConnect := Value; -end; - -procedure TTCPClient.SetOnManualReceive(const Value: TOnTCPManualReceive); -begin - FOnManualReceive := Value; -end; - -procedure TTCPClient.SetOnReceive(const Value: TOnTCPReceive); -begin - FOnReceive := Value; -end; - -procedure TTCPClient.SetOnResolve(const Value: TOnTCPResolve); -begin - FOnResolve := Value; -end; - -procedure TTCPClient.SetOnStreamReceive(const Value: TOnTCPStreamReceive); -begin - FOnStreamReceive := Value; -end; - -procedure TTCPClient.SetOnStreamSend(const Value: TOnTCPStreamSend); -begin - FOnStreamSend := Value; -end; - -procedure TTCPClient.SetReceiveStream(Stream: PStream; const AutoFree: Boolean = False; const AutoFreeSize: Integer=0); -begin - if Autofree and (AutoFreeSize = 0) then Exit; - if Assigned(FReceiveStream) then FReceiveStream.free; - FReceiveAutoFree:= AutoFree; - FReceiveAutoFreeSize:= AutoFreeSize; - FReceiveStartpos:= Stream.Position; - FReceiveStream:= Stream; -end; - -{ TTCPServer } - -procedure TTCPServer.Creating; -begin - inherited; - fconnections:=newlist; -end; - -destructor TTCPServer.Destroy; -var - i:integer; -begin - for i:=0 to pred(count) do connection[i].free; - fconnections.free; - fconnections:=nil; - inherited; -end; - -procedure TTCPServer.Disconnect; -begin - if fconnections=nil then exit; - lock; - while count>0 do connection[0].disconnect; - unlock; - inherited; -end; - -function TTCPServer.GetConnection(Index: Integer): PTCPServerClient; -begin - result:=ptcpserverclient(fconnections.items[index]); -end; - -function TTCPServer.GetCount: Integer; -begin - result:=fconnections.count; -end; - -procedure TTCPServer.Listen; -var - adr:tsockaddr; -begin - if fhandle<>SOCKET_ERROR then exit; - fhandle:=socket(AF_INET,SOCK_STREAM,IPPROTO_TCP); - if not errortest(fhandle) then - begin - with adr do - begin - sin_family:=AF_INET; - sin_port:=htons(port); - integer(sin_addr):=INADDR_ANY; - end; - if errortest(bind(fhandle,adr,sizeof(adr))) then doclose else - begin - wsaasyncselect(fhandle,wnd,WM_SOCKET,FD_ACCEPT or FD_CLOSE or FD_CONNECT); - if errortest(winsock.listen(fhandle,64)) then - doclose - else - begin - FConnected := True; - if assigned(onconnect) then onconnect(@self); - end; - end; - end; -end; - -procedure TTCPServer.Method(var message: tmessage); -var - adr:tsockaddr; - sz:integer; - sock:TSocket; - sclient:ptcpserverclient; -begin - inherited; - case message.msg of - WM_SOCKET: - if message.lparamhi<=WSABASEERR then - case message.lparamlo of - FD_ACCEPT:begin - sz:=sizeof(adr); - sock:=accept(fhandle,@adr,@sz); - if not errortest(sock) then - begin - if not assigned(onaccept) or onaccept(@self,inet_ntoa(adr.sin_addr),htons(adr.sin_port)) then - begin - sclient:=newtcpserverclient(@self); - with sclient^ do - begin - wsaasyncselect(sock,wnd,WM_SOCKET,FD_READ or FD_WRITE or FD_CLOSE); - fhost:=inet_ntoa(adr.sin_addr); - fport:=htons(adr.sin_port); - fip:=fhost; - fhandle:=sock; - fconnected:=true; - fconnecting:=false; - findex:=fconnections.count; - onerror:=onclienterror; - ondisconnect:=onclientdisconnect; - onreceive:=onclientreceive; - onmanualreceive:=onclientmanualreceive; - onstreamsend:=onclientstreamsend; - onstreamreceive:=onclientstreamreceive; - end; - fconnections.add(sclient); - if assigned(onclientconnect) then onclientconnect(sclient); - end else closesocket(sock); - end; - end; - end; - WM_SOCKETDESTROY:ptcpserverclient(message.wparam).free; - end; -end; - -procedure TTCPServer.SetOnAccept(const Value: TOnTCPAccept); -begin - FOnAccept := Value; -end; - -procedure TTCPServer.SetOnClientConnect(const Value: TOnTCPClientConnect); -begin - FOnClientConnect := Value; -end; - -procedure TTCPServer.SetOnClientDisconnect(const Value: TOnTCPDisconnect); -begin - FOnClientDisconnect := Value; -end; - -procedure TTCPServer.SetOnClientError(const Value: TOnTCPError); -begin - FOnClientError := Value; -end; - -procedure TTCPServer.SetOnClientManualReceive( const Value: TOnTCPManualReceive); -begin - FOnClientManualReceive := Value; -end; - -procedure TTCPServer.SetOnClientReceive(const Value: TOnTCPReceive); -begin - FOnClientReceive := Value; -end; - -function Err2Str(const id: integer): string; -begin - case id of - WSAEINTR:result:='WSAEINTR'; - WSAEBADF:result:='WSAEBADF'; - WSAEACCES:result:='WSAEACCES'; - WSAEFAULT:result:='WSAEFAULT'; - WSAEINVAL:result:='WSAEINVAL'; - WSAEMFILE:result:='WSAEMFILE'; - WSAEWOULDBLOCK:result:='WSAEWOULDBLOCK'; - WSAEINPROGRESS:result:='WSAEINPROGRESS'; - WSAEALREADY:result:='WSAEALREADY'; - WSAENOTSOCK:result:='WSAENOTSOCK'; - WSAEDESTADDRREQ:result:='WSAEDESTADDRREQ'; - WSAEMSGSIZE:result:='WSAEMSGSIZE'; - WSAEPROTOTYPE:result:='WSAEPROTOTYPE'; - WSAENOPROTOOPT:result:='WSAENOPROTOOPT'; - WSAEPROTONOSUPPORT:result:='WSAEPROTONOSUPPORT'; - WSAESOCKTNOSUPPORT:result:='WSAESOCKTNOSUPPORT'; - WSAEOPNOTSUPP:result:='WSAEOPNOTSUPP'; - WSAEPFNOSUPPORT:result:='WSAEPFNOSUPPORT'; - WSAEAFNOSUPPORT:result:='WSAEAFNOSUPPORT'; - WSAEADDRINUSE:result:='WSAEADDRINUSE'; - WSAEADDRNOTAVAIL:result:='WSAEADDRNOTAVAIL'; - WSAENETDOWN:result:='WSAENETDOWN'; - WSAENETUNREACH:result:='WSAENETUNREACH'; - WSAENETRESET:result:='WSAENETRESET'; - WSAECONNABORTED:result:='WSAECONNABORTED'; - WSAECONNRESET:result:='WSAECONNRESET'; - WSAENOBUFS:result:='WSAENOBUFS'; - WSAEISCONN:result:='WSAEISCONN'; - WSAENOTCONN:result:='WSAENOTCONN'; - WSAESHUTDOWN:result:='WSAESHUTDOWN'; - WSAETOOMANYREFS:result:='WSAETOOMANYREFS'; - WSAETIMEDOUT:result:='WSAETIMEDOUT'; - WSAECONNREFUSED:result:='WSAECONNREFUSED'; - WSAELOOP:result:='WSAELOOP'; - WSAENAMETOOLONG:result:='WSAENAMETOOLONG'; - WSAEHOSTDOWN:result:='WSAEHOSTDOWN'; - WSAEHOSTUNREACH:result:='WSAEHOSTUNREACH'; - WSAENOTEMPTY:result:='WSAENOTEMPTY'; - WSAEPROCLIM:result:='WSAEPROCLIM'; - WSAEUSERS:result:='WSAEUSERS'; - WSAEDQUOT:result:='WSAEDQUOT'; - WSAESTALE:result:='WSAESTALE'; - WSAEREMOTE:result:='WSAEREMOTE'; - WSASYSNOTREADY:result:='WSASYSNOTREADY'; - WSAVERNOTSUPPORTED:result:='WSAVERNOTSUPPORTED'; - WSANOTINITIALISED:result:='WSANOTINITIALISED'; - WSAHOST_NOT_FOUND:result:='WSAHOST_NOT_FOUND'; - WSATRY_AGAIN:result:='WSATRY_AGAIN'; - WSANO_RECOVERY:result:='WSANO_RECOVERY'; - WSANO_DATA:result:='WSANO_DATA'; - else result:='WSAEUNKNOWN'; - end; -end; - -procedure TTCPServer.SetOnClientStreamReceive( const Value: TOnTCPStreamReceive); -begin - FOnClientStreamReceive := Value; -end; - -procedure TTCPServer.SetOnClientStreamSend(const Value: TOnTCPStreamSend); -begin - FOnClientStreamSend := Value; -end; - -{ TTCPServerClient } - -procedure TTCPServerClient.Connect; -begin - showmessage('Can''t connect ServerClient'); -end; - -procedure TTCPServerClient.Disconnect; -var - i,j:integer; - srv:ptcpserver; -begin - if fserver<>nil then - begin - srv:=fserver; - fserver:=nil; - srv.lock; - i:=srv.fconnections.indexof(@self); - for j:=pred(srv.fconnections.count) downto succ(i) do dec(srv.connection[j].findex); - srv.fconnections.delete(i); - srv.unlock; - postmessage(srv.wnd,WM_SOCKETDESTROY,integer(@self),0); - end; - inherited; -end; - -function TCPGetHostByName(name: pchar): string; -var - host:phostent; - adr:in_addr; -begin - host:=gethostbyname(name); - move(host.h_addr^^,adr,host.h_length); - result:=inet_ntoa(adr); -end; - -procedure TTCPServerClient.SetIndex(const Value: Integer); -begin - showmessage('Can''t set index of ServerClient'); -end; - -initialization - instblocklist:=nil; - instfreelist:=nil; - -end. diff --git a/Addons/mckCProgBar.dcr b/Addons/mckCProgBar.dcr deleted file mode 100644 index f72d0006dcf07a77446f1b82484f1ae653df886f..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 2184 zcmeIyJ&x2s5QgCoL_oMHS%rIy0)!?(S_B-Rj#5Xd0CA3rIRil*VWXXZz`ULwErW&- z2_bE_AAfCo#&-Y6l4RJnh30SN_NC;U*|z8Uthc(;dwkRf-08snojy_D=r!$CZf;(^ zI5%}m!_JN@s~(h*1$8ncEgjdTPOg~qI*EF&F(M4>TjnA=E4AW>+{X$pLd zbOaKG#wh83%CPr5u-8Ikl=MH%;0PoNjak#?MmhqCLSxpHhLMgyqR^N%-8>}I5l9po zvz9^`=?EkWjakd2jdTPOg~ptgP>zv~K%&qXHT`cH9Dzh(ud|kx8R-Zl3XNII&W&^g z5{1UBB^gFK0*OLn)^bfF9f3rlF>5K8k&Zy3(3rK%+ek+sQM&)J=?lM0?#EZ;wCx`o zTA-f3JDVP!%6~8d$L+dYzV`9*V70f)Q^$wH;qd5m 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. diff --git a/Addons/mckHTTP.dcr b/Addons/mckHTTP.dcr deleted file mode 100644 index 8846469d2ce8bc7cc73945e4fbd69827afcce8a9..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 696 zcmb`Cu};J=42I3o5vjMb-N=Y!#*=Pn1|%Yt;U0p==y+Qn;a;UuGDc$IK{9kGlldK| z6-Z17tBLLZ`<{11^oTy)>gX~`irA>*=$ScP^OMIF5fz$$D8 z#l_)^!7zj-zUx56%XsJO73K#I%B@?*>{F+`3K~r`epTTz=9G+oUSYXNlPZ_oR?Mt( zqylhC);kq)*!mfQG#pb5#Xq}_GBbGcIxjBpEi-j '' 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. - diff --git a/Addons/mckHTTPDownload.dcr b/Addons/mckHTTPDownload.dcr deleted file mode 100644 index d1301017426b543b7909937337ba7a2f80eb9bec..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 1736 zcmZ|Py>8S%5Ww*vK?rv#q1%%7-e8a@kU)eY677^cgR6NDH&Y<0dx)v2u04rjAHYSL ztFAEr^_~-j!1{ik^~|2vA1jN96f8?e_euNyN<_&l%az>8C%Ki+@{!)1e3cIzeUmR_ zZsk2kTf4b=`*Q2Qqx0tCg}h$VdbL&mjxNGa+*pIofMK%oQ@wO^zb zqQc+^B&vuB3KSfeBao<1vDwLoET1QJzL zxJ)T%o52xCRM8?RP#7G6MD4fDAXSCI5lGbjNURVQ21g)K`{VLLR2UqAMD33<3Q=Kj z1QNAB<}5^o!4XK*^%ZC>M1{c-NK|p|-=(14xuI==L>1@$y%Z=6jzFUJ*QSN2FgOB< z+Fz*^qQc+^Bx--%OyaIEI0A{+-rgCmfrlH7kv zfx_Sjw5|4~RSHpIa0C*yFFP$ng~1U>)V?IG5ETYTAW{2r^+Hq_9DzjbOF0TrVQ>Tz zwJ-B5M1{c-a(`ar2jiUc@fBHr?PEg^Z0mQY#s9Qx+GA-x%$I{Rt<~1*@o?M<=j)}F zC{ELKI3Bk`OU+Zu4|7Xzh4XotreV$Z^j28r=`@_#wlsx-$r-)2$8`V4Lz?P({&mM$ zF2fIp?H}|G%OyPw<9N7?KTPfPefT`=p68FlahP_yXXE$dZZ{6Yv;3Og|0_T4#*zHx z(k}C!#@3j3YwM$)hn^qD(>i<{+wgXwTb`+DyIs#O`zQI+mR^>bNn2y^X?#p?g?5rB WX$t#xU$p)9+SjSuZf@=2X!!$NGR<-T diff --git a/Addons/mckHTTPDownload.pas b/Addons/mckHTTPDownload.pas deleted file mode 100644 index 1b03f8c..0000000 --- a/Addons/mckHTTPDownload.pas +++ /dev/null @@ -1,216 +0,0 @@ -{$IFDEF FPC} - {$mode delphi} -{$ENDIF} -unit mckHTTPDownload; -{ - - ("`-''-/").___..--''"`-._ - `6_ 6 ) `-. ( ).`-.__.`) - (_Y_.)' ._ ) `._ `. ``-..-' - _..`--'_..-_/ /--'_.' ,' -(il).-'' (li).' ((!.-' - - Download with HTTP-protocol (MCK Classes) - - Copyright © 2007-2008 Denis Fateyev (Danger) - Website: - E-Mail: - -} -interface - -// ---------------------------------------------------------- -uses - Windows, Classes, Messages, Forms, SysUtils, mirror, - KOL, KOLHTTPDownload {$IFDEF FPC}, LResources {$ENDIF}; - -// ---------------------------------------------------------- -type - PKOLHttpDownload =^TKOLHttpDownload; - TKOLHttpDownload = class( TKOLObj ) - - private - fUserName: string; - fUserPass: string; - fProxyAddr: string; - fProxyPort: Integer; - fPreconfProxy: Boolean; - - fOnError: THTTPErrorEvent; - fOnDownload: THTTPDownloadEvent; - fOnProgress: THTTPProgressEvent; - fOnHeaderReceived: THTTPHdrRecvEvent; - - public - constructor Create( Owner: TComponent ); override; - - protected - function AdditionalUnits: string; override; - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: string ); override; - procedure SetupLast( SL: TStringList; const AName, AParent, Prefix: string ); override; - procedure AssignEvents( SL: TStringList; const AName: string ); override; - - procedure SetUserName( Value: string ); - procedure SetUserPass( Value: string ); - procedure SetProxyAddr( Value: string ); - procedure SetProxyPort( Value: Integer ); - procedure SetPreconfProxy( Value: Boolean ); - - procedure SetOnDownload( Value: THTTPDownloadEvent ); - procedure SetOnError( Value: THTTPErrorEvent ); - procedure SetOnProgress( Value: THTTPProgressEvent ); - procedure SetOnHeaderReceived( Value: THTTPHdrRecvEvent ); - - published - property authUserName : string read fUserName write SetUserName; - property authPassword : string read fUserPass write SetUserPass; - - property ProxyServer : string read fProxyAddr write SetProxyAddr; - property ProxyPort : Integer read fProxyPort write SetProxyPort; - property PreconfigProxy: Boolean read fPreconfProxy write SetPreconfProxy; - - property OnDownload : THTTPDownloadEvent read fOnDownload write SetOnDownload; - property OnProgress : THTTPProgressEvent read fOnProgress write SetOnProgress; - property OnHeaderReceived : THTTPHdrRecvEvent read fOnHeaderReceived write SetOnHeaderReceived; - property OnError : THTTPErrorEvent read fOnError write SetOnError; - - end; - -// ---------------------------------------------------------- -procedure Register; - -implementation - -// ---------------------------------------------------------- -procedure Register; -begin - RegisterComponents('KOLAddons', [TKOLHttpDownload]); -end; - -// ---------------------------------------------------------- -{ TKOLHttpDownload } - -constructor TKOLHttpDownload.Create; -begin - inherited Create( Owner ); - fPreconfProxy:= false; -end; - -// ---------------------------------------------------------- -procedure TKOLHttpDownload.SetUserName; -begin - fUserName:= Value; - Change; -end; - -// ---------------------------------------------------------- -procedure TKOLHttpDownload.SetUserPass; -begin - fUserPass:= Value; - Change; -end; - -// ---------------------------------------------------------- -procedure TKOLHttpDownload.SetProxyAddr; -begin - fProxyAddr:= Value; - Change; -end; - -// ---------------------------------------------------------- -procedure TKOLHttpDownload.SetProxyPort; -begin - if fProxyAddr = '' then fProxyPort:= 0 - else fProxyPort := Value; - Change; -end; - -// ---------------------------------------------------------- -procedure TKOLHttpDownload.SetPreconfProxy; -begin - fPreconfProxy:= Value; - Change; -end; - -// ---------------------------------------------------------- -procedure TKOLHttpDownload.SetOnDownload; -begin - fOnDownload:= Value; - Change; -end; - -// ---------------------------------------------------------- -procedure TKOLHttpDownload.SetOnError; -begin - fOnError:= Value; - Change; -end; - -// ---------------------------------------------------------- -procedure TKOLHttpDownload.SetOnProgress; -begin - fOnProgress:= Value; - Change; -end; - -// ---------------------------------------------------------- -procedure TKOLHttpDownload.SetOnHeaderReceived; -begin - fOnHeaderReceived := Value; - Change; -end; - -// ---------------------------------------------------------- -function TKOLHttpDownload.AdditionalUnits; -begin - Result := ', KOLHTTPDownload'; -end; - -// ---------------------------------------------------------- -procedure TKOLHttpDownload.SetupFirst(SL: TStringList; const AName, - AParent, Prefix: String); -begin - SL.Add( Prefix + AName + ' := NewHTTPDownload;' ); - if ( fPreconfProxy ) then - SL.Add( Prefix + AName + '.UsePreconfigProxy:= true; ') - else - begin - if ( fProxyAddr <> '' ) then - begin - SL.Add( Prefix + AName + '.ProxyServer := ''' + fProxyAddr + ''';'); - if ( fProxyPort <> 0 ) then - SL.Add( Prefix + AName + '.ProxyPort := ' + IntToStr( fProxyPort ) + ';'); - end; - end; - - if ( fUserName <> '' ) or ( fUserPass <> '' ) then - SL.Add( Prefix + AName + '.SetAuthInfo( ''' + fUserName + ''', ''' + fUserPass +''' );'); -end; - -// ---------------------------------------------------------- -procedure TKOLHttpDownload.SetupLast(SL: TStringList; const AName, - AParent, Prefix: String); -begin - // -end; - -// ---------------------------------------------------------- -procedure TKOLHttpDownload.AssignEvents(SL: TStringList; const AName: String); -begin - inherited; - DoAssignEvents( SL, AName, [ 'OnDownload' ], [ @OnDownload ]); - DoAssignEvents( SL, AName, [ 'OnProgress' ], [ @OnProgress ]); - DoAssignEvents( SL, AName, [ 'OnHeaderReceived' ], [ @OnHeaderReceived ]); - DoAssignEvents( SL, AName, [ 'OnError' ], [ @OnError ]); -end; - -// ---------------------------------------------------------- -{$IFDEF FPC} -initialization - {$I mckHTTPDownload.lrs} -{$ENDIF} - -// ---------------------------------------------------------- - -end. - diff --git a/Addons/mckKOLTable.dcr b/Addons/mckKOLTable.dcr deleted file mode 100644 index dad1ac16e9231e1a5092e413bc1a16e4f40f4667..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 8600 zcmeI%v5w?K5P;zVZ9qs$R^f#N1Ox&7!GdiI{s(O9)!` z9Dzik#e~BY#aJDIM4{)YsZtsofkdI_X`50S9Dzik=ajfo8XSQ{q33jkQW_kAM4{(Y zrcxRlfkdI_G?!8u9DzikmrG!+lma8!QCzdhz6V0bL+9mKR_xz{rbhPyKNc=X=?e?wtb?0w%bFu8RG`?i()ji8;e2nGd zif!$u6YVqZW;6q@`&pfETBi9(Y<2owfKAW>-Y2Z6%i2qX$EbOnXM z5l9r8{6U~FI0A`6lRpR)21g)KXkmCL#+f_DnkY2+gFs<$1QLZNe-J1PjzFT&Tzg(iOxC=8B3qR`|I0)@d5NEDjpSI6d7OLZs&2&D@$ly+UI-eqKDCZI*ks_@mFK;wqS>g_KPfHbhF3L zPRBU=3!e66Sq^a9VOHknh@bth-(E(K`0+}=h+lVG%ccKymUjQic0B*}l#H zat!A;-F7@2|D6B*n`7;I{?=Fjy4ODc=WmYF`#0wQe0^_Rzr*!CT)ln%m&-anj+f_r zfyc3}{jW!UUH(=3_5N>td*l`$bNMcFi|_c=;yJ%t{50>QcX*?2Z6%i2qX$k?jTSY9Dzik$sGg=gCmeAG`WL7VQ>Tzg%-Mk!r%xb z3Qg`HP#7G6M4`zY1PX&AkSMe;JQU;19b-)tn%qI4FgOB9`n23EnIjgBT;B_2!X=j2qX$ECIZD+9f3rl$sq&^gCmeA zG&zJoVQ>Tzg(im(C=8B3qR_(bP#7G6M4`zc1PX&AkSH`cgg{|%1QLZNhY%6q+1DpfETBi9!qEP#7G6#8{ggLZC1>0*OMCLkJWGM<7vXatMLK;0PoN zJ#W`gN`oViDD=FQQz;FOK%&s|HZP?#I0FCE{DNzBxjc9zpWmXlUZKmr%YTH{9*(b| zwVgNBeABS+jsC}fla}`v``v866~B&n{%_QS_$@scecl*<8+24|jK2lFM*QWmtmk(X zKffM*otJG;D*JNLz8>@=^S{UM(WAEYzs5iIdf!fZW(R*eJ-Cj)PCx!?{NrISTkElp Pa?Ib{J{SL;^y2g<-mQiI diff --git a/Addons/mckKOLTable.pas b/Addons/mckKOLTable.pas deleted file mode 100644 index 456ad63..0000000 --- a/Addons/mckKOLTable.pas +++ /dev/null @@ -1,526 +0,0 @@ -unit mckKOLTable; - -interface - -uses - Windows, Classes, Messages, Forms, SysUtils, - mirror, mckCtrls, Graphics, KOLEdb, ADOdb, - ADOConEd, mckListEdit, DB, KOL, - ExptIntf, ToolIntf, EditIntf, // DsgnIntf -////////////////////////////////////////////////// - {$IFDEF VER140} // - DesignIntf, DesignEditors, DesignConst, // - Variants // - {$ELSE} // - DsgnIntf // - {$ENDIF} // -////////////////////////////////////////////////// - {$IFNDEF VER90}{$IFNDEF VER100}, ToolsAPI{$ENDIF}{$ENDIF}, - TypInfo, Consts; - -type - - PKOLDataSource =^TKOLDataSource; - TKOLDataSource = class(TKOLObj) - private - fConnection: WideString; - AQ: TADOQuery; - protected - function AdditionalUnits: string; override; - function TypeName: string; override; - function CompareFirst( c, n: string): boolean; override; - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - function GetConnection: WideString; - procedure SetConnection(Value: WideString); - public - constructor Create(AOwner: TComponent); override; - published - property Connection: WideString read GetConnection write SetConnection; - end; - - TKOLSession = class(TKOLObj) - private - fDataSource: TKOLDataSource; - protected - function AdditionalUnits: string; override; - function TypeName: string; override; - function CompareFirst( c, n: string): boolean; override; - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure SetDataSource(DS: TKOLDataSource); - published - property DataSource: TKOLDataSource read fDataSource write SetDataSource; - end; - - TKOLQuery = class(TKOLObj) - private - fSession: TKOLSession; - fTableName: WideString; - fText: string; - protected - function AdditionalUnits: string; override; - function TypeName: string; override; - function CompareFirst( c, n: string): boolean; override; - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure SetSession(SS: TKOLSession); - procedure SetText (Tt: string); - function GetTableName: WideString; - procedure SetTableName(Value: WideString); - published - property Session: TKOLSession read fSession write SetSession; - property SQL: string read fText write SetText; - property TableName: WideString read GetTableName write SetTableName; - end; - - TTableStringProperty = class(TStringProperty) - public - function GetAttributes: TPropertyAttributes; override; - procedure Edit; override; - end; - - TTableNameProperty = class(TStringProperty) - private - FConnection: TADOConnection; - public - function AutoFill: Boolean; override; - function GetAttributes: TPropertyAttributes; override; - function GetConnection(Opened: Boolean): TADOConnection; - procedure GetValueList(List: TStrings); - procedure GetValues(Proc: TGetStrProc); override; - end; - - TKOLListData = class(TKOLListEdit) - private - fAutoOpen: boolean; - fOnRowChanged: TOnEvent; - fQuery: TKOLQuery; - fColCount: integer; - protected - function AdditionalUnits: string; override; - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure AssignEvents( SL: TStringList; const AName: String ); override; - procedure SetAutoOpen(Value: boolean); - function GetColCount: integer; - procedure SetColCount(Value: integer); - procedure SetQuery(Value: TKOLQuery); - procedure SetOnRowChanged(Value: TOnEvent); - procedure DoRequest(Full: boolean); - procedure Loaded; override; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - procedure UpdateColumns; override; - published - property AutoOpen: boolean read fAutoOpen write SetAutoOpen; - property ColCount read GetColCount write SetColCount; - property Query: TKOLQuery read fQuery write SetQuery; - property OnRowChanged: TOnEvent read fOnRowChanged write SetOnRowChanged; - end; - - procedure Register; - -implementation - -uses Ustr; - -{$R *.dcr} - -function TTableStringProperty.GetAttributes: TPropertyAttributes; -begin - Result := [paDialog]; -end; - -procedure TTableStringProperty.Edit; -begin - if EditConnectionString((GetComponent(0) as TKOLDataSource).AQ) then begin - Modified; - end; -end; - -constructor TKOLDataSource.Create; -begin - inherited; - AQ := TADOQuery.Create(self); -end; - -function TKOLDataSource.AdditionalUnits; -begin - Result := ', OLETable, KOLEdb'; -end; - -function TKOLDataSource.TypeName; -begin - Result := 'TKOLDataSource'; -end; - -function TKOLDataSource.CompareFirst; -begin - Result := False; - if c = '' then Result := True; -end; - -procedure TKOLDataSource.SetupFirst; -var s: string; - c: string; - t: string; -begin - SL.Add( Prefix + AName + ' := NewDataSource('); - c := '''' + fConnection + ''');'; - repeat - t := Prefix + copy(c, 1, 77 - length(Prefix)); - delete(c, 1, 77 - length(Prefix)); - if c <> '' then begin - t := t + ''' +'; - c := '''' + c; - end; - SL.Add(t); - until length(c) = 0; -end; - -function TKOLDataSource.GetConnection; -begin - fConnection := AQ.ConnectionString; - Result := fConnection; -end; - -procedure TKOLDataSource.SetConnection; -begin - fConnection := Value; - AQ.ConnectionString := Value; - Change; -end; - -function TKOLSession.AdditionalUnits; -begin - Result := ', OLETable, KOLEdb'; -end; - -function TKOLSession.TypeName; -begin - Result := 'TKOLSession'; -end; - -function TKOLSession.CompareFirst; -begin - Result := False; - if c = '' then Result := True; - if c = 'TKOLDataSource' then Result := True; -end; - -procedure TKOLSession.SetupFirst; -begin - SL.Add( Prefix + AName + ' := NewSession( Result.' + fDataSource.Name + ' );' ); -end; - -procedure TKOLSession.SetDataSource; -begin - fDataSource := DS; - Change; -end; - -function TKOLQuery.AdditionalUnits; -begin - Result := ', OLETable, KOLEdb'; -end; - -function TKOLQuery.TypeName; -begin - Result := 'TKOLQuery'; -end; - -function TKOLQuery.CompareFirst; -begin - Result := False; - if c = '' then Result := True; - if c = 'TKOLDataSource' then Result := True; - if c = 'TKOLSession' then Result := True; -end; - -procedure TKOLQuery.SetupFirst; -begin - SL.Add( Prefix + AName + ' := NewQuery( Result.' + fSession.Name + ' );' ); - if fText <> '' then begin - SL.Add( Prefix + AName + '.Text := ''' + fText + ''';'); - end else - if fTableName <> '' then begin - SL.Add( Prefix + AName + '.Text := ''Select * from ' + fTableName + ''';'); - end; -end; - -procedure TKOLQuery.SetSession; -begin - fSession := SS; - Change; -end; - -procedure TKOLQuery.SetText; -begin - fText := Tt; - Change; -end; - -function TTableNameProperty.GetAttributes: TPropertyAttributes; -begin - Result := [paValueList, paSortList, paMultiSelect]; -end; - -function TTableNameProperty.GetConnection(Opened: Boolean): TADOConnection; -var - Component: TComponent; - Connection: string; -begin - Result := FConnection; - Component := (GetComponent(0) as TKOLQuery).Session.DataSource; - Connection := TypInfo.GetStrProp(Component, - TypInfo.GetPropInfo(Component.ClassInfo, 'Connection')); - if Connection = '' then Exit; - FConnection := TADOConnection.Create(nil); - FConnection.ConnectionString := Connection; - FConnection.LoginPrompt := False; - Result := FConnection; - Result.Open; -end; - -procedure TTableNameProperty.GetValueList(List: TStrings); -var - Connection: TADOConnection; -begin - Connection := GetConnection(True); - if Assigned(Connection) then - try - Connection.GetTableNames(List); - finally - FConnection.Free; - FConnection := nil; - end; -end; - -procedure TTableNameProperty.GetValues; -var l: TStringList; - i: integer; -begin - l := TStringList.Create; - GetValueList(l); - for i := 0 to l.Count - 1 do - Proc(l[i]); - l.Free; -end; - -function TTableNameProperty.AutoFill: Boolean; -var - Connection: TADOConnection; -begin - Connection := GetConnection(False); - Result := Assigned(Connection) and Connection.Connected; -end; - -constructor TKOLListData.Create; -begin - inherited; - IsListData := True; -end; - -destructor TKOLListData.Destroy; -begin - inherited; -end; - -function TKOLListData.AdditionalUnits; -begin - Result := ', OLETable, KOLEdb'; -end; - -procedure TKOLListData.SetupFirst; -begin - inherited; - DoRequest(True); - if fQuery <> nil then begin - if not fQuery.fSession.fDataSource.AQ.Active then fAutoOpen := False; - SL.Add( Prefix + AName + '.Query := Result.' + fQuery.Name + ';'); - end; -end; - -procedure TKOLListData.SetupLast; -begin - inherited; - if fQuery <> nil then begin - if fAutoOpen then - SL.Add( Prefix + AName + '.Open;' ); - end; -end; - -procedure TKOLListData.AssignEvents; -begin - inherited; - DoAssignEvents( SL, AName, - [ 'OnRowChanged'], - [ @OnRowChanged ]); -end; - -procedure TKOLListData.SetAutoOpen; -begin - fAutoOpen := Value; - Change; -end; - -function TKOLListData.GetColCount; -begin - Result := fColCount; -end; - -procedure TKOLListData.SetColCount; -var i: integer; - n: integer; - a: TADOQuery; - t: TListEditColumnsItem; - e: boolean; -begin - if Value > 0 then begin - fColCount := Value; - end; - while Columns.Count > fColCount do begin - Columns.Delete(Columns.Count - 1); - end; - DoRequest(True); - a := nil; - if fQuery <> nil then begin - if fQuery.fSession <> nil then begin - if fQuery.fSession.fDataSource <> nil then begin - a := fQuery.fSession.fDataSource.AQ; - end; - end; - end; - if a <> nil then begin - for i := 0 to a.FieldCount - 1 do begin - e := True; - for n := 0 to Columns.Count - 1 do begin - t := Columns.Items[n]; - if t.FieldName = a.Fields[i].FieldName then begin - e := False; - break; - end; - end; - if e and (Columns.Count < fColCount) then begin - t := TListEditColumnsItem(Columns.Add); - t.Caption := a.Fields[i].FieldName; - t.FieldName := a.Fields[i].FieldName; - case a.Fields[i].DataType of - ftString, - ftWideString: t.Alignment := taLeftJustify; - else - t.Alignment := taRightJustify; - end; - t.Width := Canvas.TextWidth(Replicate('Q', a.Fields[i].DisplayWidth)); - end; - end; - UpDateColumns; - end; -end; - -procedure TKOLListData.SetOnRowChanged; -begin - fOnRowChanged := Value; - Change; -end; - -procedure TKOLListData.DoRequest; -begin -if fQuery <> nil then begin - if fQuery.fText <> '' then begin - fQuery.fSession.fDataSource.AQ.SQL.Clear; -{ fQuery.fSession.fDataSource.AQ.SQL.Add(fQuery.fText);} - fQuery.fSession.fDataSource.AQ.SQL.Add('Select * from ' + fQuery.fTableName); - try - fQuery.fSession.fDataSource.AQ.Open; - except - on E: Exception do MsgOK(E.Message); - end; - end else - if fQuery.fTableName <> '' then begin - fQuery.fSession.fDataSource.AQ.SQL.Clear; - fQuery.fSession.fDataSource.AQ.SQL.Add('Select * from ' + fQuery.fTableName); - try - fQuery.fSession.fDataSource.AQ.Open; - except - on E: Exception do MsgOK(E.Message); - end; - end; -end; -end; - -procedure TKOLListData.Loaded; -var i: integer; - n: integer; - a: TADOQuery; - t: TListEditColumnsItem; - e: boolean; -begin - inherited; - DoRequest(True); - a := nil; - if fQuery <> nil then begin - if fQuery.fSession <> nil then begin - if fQuery.fSession.fDataSource <> nil then begin - a := fQuery.fSession.fDataSource.AQ; - end; - end; - end; - if a <> nil then begin - Columns.FieldNames.Clear; - for i := 0 to a.FieldCount - 1 do begin - Columns.FieldNames.Add(a.Fields[i].FieldName); - end; - end; -end; - -procedure TKOLListData.UpdateColumns; -var s: string; - i: integer; - f: string; -begin - s := ''; - for i := 0 to Columns.Count - 1 do begin - if Columns.Items[i].FieldName <> '' then begin - s := s + '[' + Columns.Items[i].FieldName + ']' + ','; - end; - end; - s := copy(s, 1, length(s) - 1); - if fQuery = nil then begin - MsgOK('Query is not defined !'); - exit; - end; - i := pos('FROM', UpSt(fQuery.fText)); - if i > 0 then f := copy(fQuery.fText, i + 5, length(fQuery.fText) - i - 4) - else f := fQuery.TableName; - if trim(s) = '' then s := '*'; - if trim(f) = '' then f := fQuery.TableName; - fQuery.fText := 'Select ' + s + ' from ' + f; - Change; -end; - -function TKOLQuery.GetTableName; -begin - Result := fTableName; -end; - -procedure TKOLQuery.SetTableName; -begin - fTableName := Value; - Change; -end; - -procedure TKOLListData.SetQuery; -begin - fQuery := Value; - Change; -end; - -procedure Register; -begin - RegisterComponents ('KOLData', [TKOLDataSource, TKOLSession, TKOLQuery, TKOLListData]); - RegisterPropertyEditor (TypeInfo(WideString), TKOLDataSource, 'Connection', TTableStringProperty); - RegisterPropertyEditor (TypeInfo(WideString), TKOLQuery, 'TableName', TTableNameProperty); -end; - -end. - diff --git a/Addons/mckListEdit.dcr b/Addons/mckListEdit.dcr deleted file mode 100644 index d80b59fdc033c3fc9d94f1235306537472c14091..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 480 zcmZ`#F%E+;5HnTP2`P*n8T*7j;5t;Tl%YH*BO71J19%KW_p6gjX^^Pl?i^#x2>|F> zs#c^Mj16$5qI$r92Rxp}_{0B?j~gPoKW5M$(n zv|Ji$gWdL3%oUQeppCksjnneeC)1rSS$A;i#>9(`tcw>>^O(+n0J`%RAdm%sUb&EMIl-ZSkm8uD)Wv$?g^FPT4gy}5S) diff --git a/Addons/mckListEdit.pas b/Addons/mckListEdit.pas deleted file mode 100644 index 575b94f..0000000 --- a/Addons/mckListEdit.pas +++ /dev/null @@ -1,226 +0,0 @@ -unit mckListEdit; - -interface - -uses - Windows, Classes, Messages, Forms, SysUtils, - mckCtrls, Graphics; - -type - - TListEditColumns = class; - - TKOLListEdit = class(TKOLListView) - private - fColumns: TListEditColumns; - fColCount: integer; - fListData: boolean; - protected - function AdditionalUnits: string; override; - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure AssignEvents( SL: TStringList; const AName: String ); override; - function GetCaption: string; - function GetStyle: TKOLListViewStyle; - function GetOptions: TKOLListViewOptions; - procedure SetOptions(v: TKOLListViewOptions); - function GetColumns: TListEditColumns; virtual; - procedure SetColumns(v: TListEditColumns); - function GetColCount: integer; - procedure SetColCount(v: integer); - public - constructor Create(Owner: TComponent); override; - property IsListData: boolean read fListData write fListData; - procedure UpdateColumns; virtual; - published - property Caption: string Read GetCaption; - property Style: TKOLListViewStyle Read GetStyle; - property Options: TKOLListViewOptions read GetOptions write SetOptions; - property Columns: TListEditColumns read fColumns write SetColumns; - property ColCount: integer read GetColCount write SetColCount; - end; - - TListEditColumnsItem = class(TCollectionItem) - private - fCaption: string; - fAlign: TAlignment; - fWidth: integer; - fFieldName: string; - protected - procedure SetAlignment(a: TAlignment); - procedure SetCaption(c: string); - procedure SetWidth(w: integer); - published - property Alignment: TAlignment read fAlign write fAlign; - property Caption: string read fCaption write fCaption; - property Width: integer read fWidth write fWidth; - property FieldName: string read fFieldName write fFieldName; - end; - - TListEditColumns = class(TCollection) - private - FOwner: TKOLListEdit; - function GetItem(Index: Integer): TListEditColumnsItem; - procedure SetItem(Index: Integer; Value: TListEditColumnsItem); - protected - function GetOwner: TPersistent; override; - public - FieldNames: TStringList; - constructor Create(AOwner: TKOLListEdit); - destructor Destroy; override; - function Owner: TKOLListEdit; - property Items[Index: Integer]: TListEditColumnsItem read GetItem write SetItem; default; - end; - - procedure Register; - -implementation - -{$R *.dcr} - -constructor TKOLListEdit.Create; -begin - inherited; - inherited Style := lvsDetail; - inherited Options := [lvoRowSelect]; - Font.FontCharset := 204; - fColumns := TListEditColumns.Create(self); -end; - -procedure TKOLListEdit.UpdateColumns; -begin - Change; -end; - -function TKOLListEdit.AdditionalUnits; -begin - Result := ', ListEdit'; -end; - -procedure TKOLListEdit.SetupFirst; -var i: integer; - s: string; -begin - inherited; - for i := 0 to fColumns.Count - 1 do begin - case fColumns.Items[i].Alignment of - taLeftJustify: s := 'taLeft'; - taCenter: s := 'taCenter'; - taRightJustify: s := 'taRight'; - end; - SL.Add( Prefix + AName + '.LVColAdd(''' + fColumns.Items[i].Caption + ''',' + s + ' , ' + intTostr(fColumns.Items[i].Width) + ');' ); - end; -end; - -procedure TKOLListEdit.SetupLast; -begin - inherited AssignEvents(SL, AName); -end; - -procedure TKOLListEdit.AssignEvents; -begin - inherited; -end; - -function TKOLListEdit.GetCaption; -begin - Result := inherited Caption; -end; - -function TKOLListEdit.GetStyle; -begin - Result := lvsDetail; -end; - -function TKOLListEdit.GetOptions; -begin - Result := inherited Options; -end; - -procedure TKOLListEdit.SetOptions; -begin - inherited Options := v + [lvoRowSelect]; -end; - -function TKOLListEdit.GetColumns; -begin - Result := fColumns; -end; - -procedure TKOLListEdit.SetColumns; -begin - fColumns.Assign(v); - Change; -end; - -function TKOLListEdit.GetColCount; -begin - Result := fColumns.Count; -end; - -procedure TKOLListEdit.SetColCount; -begin - fColCount := v; - if fColCount < 0 then fColCount := 0; - while fColCount > fColumns.Count do fColumns.Add; - while fColCount < fColumns.Count do fColumns[fColumns.Count - 1].Free; - Change; -end; - -procedure TListEditColumnsItem.SetAlignment; -begin - fAlign := A; - TListEditColumns(GetOwner).FOwner.Change; -end; - -procedure TListEditColumnsItem.SetCaption; -begin - fCaption := C; -end; - -procedure TListEditColumnsItem.SetWidth; -begin - fWidth := W; -end; - -constructor TListEditColumns.Create; -begin - inherited create(TListEditColumnsItem); - fOwner := AOwner; - FieldNames := TStringList.Create; -end; - -destructor TListEditColumns.Destroy; -begin - FieldNames.Free; - inherited; -end; - -function TListEditColumns.GetItem; -begin - result := TListEditColumnsItem(inherited GetItem(Index)); -end; - -procedure TListEditColumns.SetItem; -begin - inherited SetItem(Index, Value); - FOwner.Change; -end; - -function TListEditColumns.GetOwner; -begin - result := FOwner; -end; - -function TListEditColumns.Owner; -begin - result := FOwner; -end; - -procedure Register; -begin - RegisterComponents('KOLAddons', [TKOLListEdit]); -end; - -end. - diff --git a/Addons/mckPageSetup.dcr b/Addons/mckPageSetup.dcr deleted file mode 100644 index 08eb4a076a90211b8cd702966d73d28414305c71..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 492 zcmZ{gOKOBb5QcvTi7Q{btYnsRje!XgA|w!V4;O*nL~xm7c?5T^8fGrgc!SPgmWl(D zYOCw(dUdq`aHM*#O1zWb0JzZO{Q))J@Qw-}IHSZ1KB+anc)sA3zKYRusm`*eaBXxV zJTDqR-ADF)EFHiPU8jaS5q;m&NVj@W8tuA8gMB` zJQ)*9&g?fo!h`023)`q+n`q9l1MlS^QfuunA!SQpAoYF%VsheAU~*3R%7SF(Aa`tZ jE5uKxC@0S4d9miZf@`V$m$!U*A+q`2?dhi7{Sx~JAM3b& diff --git a/Addons/mckPrintDialogs.dcr b/Addons/mckPrintDialogs.dcr deleted file mode 100644 index b7ea2ef0ea7e392c40f2ac394f13edb086b3f392..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 484 zcmZvXK?=e!5Ji8b*j2Slmo7bo8$l3JtcVB6Lg>aqmmaG}$gZnEPaxhP{>d~|!QUqH z@-vxC0AR`Cy$<4!9tp6fn>A27fy{a;HR8%RaLp<1i!iq zTg|@-yUegm7IK{By=+9zI%i*)vt(d5_x?39FtX)=aIf?k`w>=29hJq0XFYj%Krg<1 S28Dj2pa15^ryJCm` z83q6{hKLX1m+lF$W<_L%EB2^xzzIj3NhR|R7d~5T$b-^!F&}tESoV>?mov`%Ee-I6 z*4~(j42`yJ+31$+OuRAsy*vLyc^)qrlZRvdGN$fZ#zqL33`3$8$#WCH%IiVtJZAY!? - - Original excellent TQProgressBar VCL component was developed by QnnO - and was ported to KOL with his permission. Merci a Qnno! - -} -interface - -// ---------------------------------------------------------- -uses - Windows, Messages, KOL, SysUtils, Math, Classes, Controls, - KOLQProgBar, mirror, Graphics; -// ---------------------------------------------------------- - -type - TKOLQProgressBar = class( TKOLControl ) - - private - fOrientation: TQBarOrientation; - fBarKind: TQBarKind; - fBarLook: TQBarLook; - fRoundCorner: Boolean; - fBackColor: TColor; - fBarColor: TColor; - fStartColor: TColor; - fFinalColor: TColor; - fShowInactPos: Boolean; - fInvertInactPos: Boolean; - fInactPosColor: TColor; - fShaped: Boolean; - fShapeColor: TColor; - fBlockSize: Integer; - fSpaceSize: Integer; - fShowFullBlock: Boolean; - fMaximum: Integer; - fPosition: Integer; - fHideOnTerm: Boolean; - fCaptionAlign: TTextAlign; - fAutoCaption: Boolean; - fAutoHint: Boolean; - fShowPosAsPct: Boolean; - fFont: TKOLFont; - - fCorner: Integer; - fBorderSize: Integer; - fByBlock: Boolean; - fPosDescr: array of TPosDescr; - fPixDescr: array of TCLRArray; - fInactDescr: TCLRArray; - fUSefullDrawSpace: Integer; - fMonoClr: Boolean; - fUserPos: Integer; - fUSerPosPct: Real; - fHasCaption: Boolean; - fCapPos: TPoint; - fMinVisPos: Integer; - fInternalBorder: Integer; - fOnProgressChange: TOnQProgressBar; - fNotAvailable: Boolean; - fColorNotAvailable: TColor; - fOnPaintNotAvailable: TOnPaint; - - procedure SetOrientation( Value: TQBarOrientation ); - procedure SetBarKind( Value: TQBarKind ); - procedure SetBarLook( Value: TQBarLook); - procedure SetRoundCorner( Value: Boolean ); - procedure SetBackColor( Value: TColor ); - procedure SetBarColor( Value: TColor ); - procedure SetStartColor( Value: TColor ); - procedure SetFinalColor(Value: TColor ); - procedure SetShowInactPos( Value: Boolean ); - procedure SetInvertInactPos( Value: Boolean ); - procedure SetInactPosColor( Value: TColor ); - procedure SetShaped( Value: Boolean ); - procedure SetShapeColor( Value: TColor ); - procedure SetBlockSize( Value: Integer ); - procedure SetSpaceSize( Value: Integer ); - procedure SetShowFullBlock( Value: Boolean ); - procedure SetMaximum( Value: Integer ); - procedure SetPosition( Value: Integer ); - procedure SetHideOnTerm( Value: Boolean ); - procedure SetCaptionAlign( Value: TTextAlign ); - procedure SetAutoCaption( Value: Boolean ); - procedure SetAutoHint( Value: Boolean ); - procedure SetShowPosAsPct( Value: Boolean ); - - procedure SetUsefullWidth; - procedure InitBlockArray; - procedure InitPixArray; - function GetGradientAr2( aColor: TColor; sz:Integer ): TClrArray; - function HLStoRGB( hue, lum, sat: THLSRange ): TColor; - function GetColorBetween( StartColor, EndColor: TColor; Pointvalue, - Von, Bis : Extended ): TColor; - function RGBtoHLS( RGBColor: TColor ): THLSRec; - function MakeCylinder( h: Real ): Extended; - procedure SetCaption( Value: string ); - procedure SetFont( Value: TKOLFont ); - - protected - procedure Paint; override; - procedure Resize; override; - function AdditionalUnits: string; 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; - procedure AssignEvents( SL: TStringList; const AName: string ); override; - procedure SetOnProgressChange( Value: TOnQProgressBar ); - - public - constructor Create( AOwner: TComponent ); override; - - published - property Orientation: TQBarOrientation read fOrientation write SetOrientation; - property BarKind: TQBarKind read fBarKind write SetBarKind; - property BarLook: TQBarLook read fBarLook write SetBarLook; - property RoundCorner: Boolean read fRoundCorner write SetRoundCorner; - property BackgroundColor: TColor read fBackColor write SetBackColor; - property BarColor: TColor read fBarColor write SetBarColor; - property StartColor: TColor read fStartColor write SetStartColor; - property FinalColor: TColor read fFinalColor write SetFinalColor; - property ShowInactivePos: Boolean read fShowInactPos write SetShowInactPos; - property InvertInactPos: Boolean read fInvertInactPos write SetInvertInactPos; - property InactivePosColor: TColor read fInactPosColor write SetInactPosColor; - property Shaped: Boolean read fShaped write SetShaped; - property ShapeColor: TColor read fShapeColor write SetShapeColor; - property BlockSize: Integer read fBlockSize write SetBlockSize; - property SpaceSize: Integer read fSpaceSize write SetSpaceSize; - property ShowFullBlock: Boolean read fShowFullBlock write SetShowFullBlock; - property MaxProgress: Integer read fMaximum write SetMaximum; - property Progress: Integer read fUserPos write SetPosition; - property HideOnTerminate: Boolean read fHideOnTerm write SetHideOnTerm; - property CaptionAlign: TTextAlign read fCaptionAlign write SetCaptionAlign; - property AutoCaption: Boolean read fAutoCaption write SetAutoCaption; - property AutoHint: Boolean read fAutoHint write SetAutoHint; - property ShowPosAsPct: Boolean read fShowPosAsPct write SetShowPosAsPct; - property Caption: string read fCaption write SetCaption; - property Font: TKOLFont read fFont write SetFont; - property OnProgressChange: TOnQProgressBar read fOnProgressChange write SetOnProgressChange; - property DoubleBuffered: Boolean read fNotAvailable; - property Ctl3D: Boolean read fNotAvailable; - property Color: TColor read fColorNotAvailable; - property EraseBackground: Boolean read fNotAvailable; - property OnEraseBkgnd: TOnPaint read fOnPaintNotAvailable; - end; - -// ---------------------------------------------------------- -procedure Register; - -implementation - -// ---------------------------------------------------------- -procedure Register; -begin - RegisterComponents( 'KOLAddons', [ TKOLQProgressBar ] ); -end; - -// ---------------------------------------------------------- -{ TKOLQProgressBar } - -function TKOLQProgressBar.AdditionalUnits: String; -begin - Result := ', KOLQProgBar'; -end; - -// ---------------------------------------------------------- -constructor TKOLQProgressBar.Create( AOwner: TComponent ); -begin - inherited; - Width:= 200; - DefaultWidth:= Width; - Height:= 20; - DefaultHeight:= Height; - ControlStyle := ControlStyle + [ csAcceptsControls ]; - SetLength( fPosDescr, 1 ); - fPosDescr[0].IsInBlock := False; - fFont := TKOLFont.Create( Self ); - - fShowFullBlock:= false; - fBlockSize:= 0; - fSpaceSize:= 0; - fOrientation:= boHorizontal; - fBarKind:= bkFlat; - fBarLook:= blMetal; - fPosition:= 0; - fShaped:= true; - fShapeColor:= $00743C00; - fBarColor:= clLime; - fStartColor:= clLime; - fFinalColor:= clLime; - fBackColor:= clWhite; - fShowInactPos:= false; - fInactPosColor:= clGray; - fInvertInactPos:= false; - fMaximum:= 100; - fAutoCaption:= false; - fAutoHint:= false; - fShowPosAsPct:= false; - fHideOnTerm:= false; - fRoundCorner:= true; - fCaptionAlign:= taLeft; - - SetUsefullWidth; - InitPixArray; - fCorner:= 5; - fBorderSize:= 4; - fByBlock:= False; - fMonoClr:= True; - fHasCaption:= False; - fCaption:= ''; - fCapPos.X:= 0; - fCapPos.Y:= 0; - fInternalBorder:= 2; -end; - -// ---------------------------------------------------------- -procedure TKOLQProgressBar.Resize; -begin - inherited Resize; - fBorderSize := fInternalBorder shl 1; - SetUsefullWidth; - - if ( fByBlock ) then InitBlockArray; - InitPixArray; - Progress := fUserPos; - SetCaption( fCaption ); -end; - -// ---------------------------------------------------------- -procedure TKOLQProgressBar.SetCaption( Value: string); -begin - fCaption := Value; - fHasCaption := not(Value = ''); - if ( fHasCaption ) then - begin - //-1- Centering vertically - fCapPos.Y := ( Height - Canvas.textHeight('Pg')) div 2 ; - - case ( fCaptionAlign ) of - taLeft : - begin - fCapPos.X := 0; - end; - taCenter : - begin - fCapPos.X := ( Width - Canvas.textWidth(value) ) div 2; - end; - else - begin //right alignment; - fCapPos.X := ( Width - Canvas.textWidth(value) ) -1 ; - end; - end; {case} - end; - if not( fAutoCaption ) then Invalidate; - Change; -end; - -// ---------------------------------------------------------- -procedure TKOLQProgressBar.SetFont( Value: TKOLFont ); -begin - fFont.Assign( Value ); - Invalidate; - Change; -end; - -// ---------------------------------------------------------- -procedure TKOLQProgressBar.InitBlockArray; -// fPosDescr[n] describes each possible position, storing : -// - wether it is in a block or not ; <- drawing blocks instead of a continuous line -// - what is the block limit for this position; <- (if full blocks only are to be drawn, then -// only those which limit is bellow(H) above(V) current position will be drawn.) -// Computed on size/resize and blocks/space sizes changes only, to avoid computations at runTime. -var i, - blkStart, - blkStop : Integer; -begin - if (fBlockSize = 0) or (fSpaceSize = 0) then Exit; - - if fUSefullDrawSpace <= 0 - then SetLength(fPosDescr, 1) // Position 0 is allways False - else SetLength(fPosDescr, fUSefullDrawSpace+1); - - case ( fOrientation ) of - boHorizontal : - begin - fPosDescr[0].isInBlock := False; - blkStart := 3; - blkStop := blkStart + fBlockSize -1 ; - for i := 1 to High(fPosDescr) do - begin - fPosDescr[i].isInBlock := (i >= blkStart) and (i <= blkStop); - fPosDescr[i].blkLimit := blkStop; - if i = blkStop then - begin - blkStart := blkStop + fSpaceSize + 1; - blkStop := blkStart + fBlockSize - 1; - if blkStop > High(fPosDescr) then blkStop := High(fPosDescr); - end; - end; - end; {boHrz} - else // boVertical; "Else" avoids compiler warnings - begin - fPosDescr[High(fPosDescr)].isInBlock := False; - blkStart := High(fPosDescr)-3; - blkStop := blkStart - fBlockSize + 1 ; - for i := fUSefullDrawSpace downTo fBorderSize do - begin - fPosDescr[i].isInBlock := (i <= blkStart) and (i >= blkStop); - fPosDescr[i].blkLimit := blkStop; - if i = blkStop then - begin - blkStart := blkStop - fSpaceSize - 1; - blkStop := blkStart - fBlockSize + 1; - if blkStop < fBorderSize then blkStop := fBorderSize; - end; - end; - end; {boVert} - end; {case} -end; - -// ---------------------------------------------------------- -function TKOLQProgressBar.RGBtoHLS( RGBColor: TColor ): THLSRec; // NIH -// (c) Microsoft. http://support.microsoft.com/default.aspx?scid=kb;en-us;29240 -// This is the translation of a Microsoft knowledge base article, pubilshed -// under number Q29240. Msft's knowledge base has a lot of interesting articles. - -//(knowledge base = http://support.microsoft.com/default.aspx?scid=FH;EN-US;KBHOWTO) - -var - R, G, B: Integer; // input RGB values - H, L, S: Integer; - cMax, cMin: Byte; // max and min RGB values - Rdelta,Gdelta,Bdelta: Integer; // intermediate value: % of spread from max -begin - // get R, G, and B out of DWORD - R := GetRValue(RGBColor); - G := GetGValue(RGBColor); - B := GetBValue(RGBColor); - - // calculate lightness - cMax := max( max(R,G), B); - cMin := min( min(R,G), B); - L := ( ( (cMax+cMin) * HLSMAX) + RGBMAX ) div (2*RGBMAX); - - if (cMax = cMin) then // r=g=b --> achromatic case - begin - S := 0; // saturation - H := UNDEFINED; // hue - end else - begin // chromatic case - if (L <= (HLSMAX div 2) ) // saturation - then S := ( ( (cMax-cMin) * HLSMAX ) + ( (cMax+cMin) div 2) ) div (cMax+cMin) - else S := ( ( (cMax-cMin) * HLSMAX ) + ( (2*RGBMAX-cMax-cMin) div 2) ) div (2*RGBMAX-cMax-cMin); - // hue - Rdelta := ( ( (cMax-R) * (HLSMAX div 6) ) + ((cMax-cMin) div 2) ) div (cMax-cMin); - Gdelta := ( ( (cMax-G) * (HLSMAX div 6) ) + ((cMax-cMin) div 2) ) div (cMax-cMin); - Bdelta := ( ( (cMax-B) * (HLSMAX div 6) ) + ((cMax-cMin) div 2) ) div (cMax-cMin); - - if R = cMax then H := Bdelta - Gdelta - else if G = cMax then H := (HLSMAX div 3) + Rdelta - Bdelta - else {B=cMax} H := ( (2*HLSMAX) div 3) + Gdelta - Rdelta; - if (H < 0) then H := H + HLSMAX; - If (H > HLSMAX) then H := H - HLSMAX; - end; - - Result.Hue := H; - Result.Lum := L; - Result.Sat := S; -end; - -// ---------------------------------------------------------- -function TKOLQProgressBar.HLStoRGB( hue, lum, sat: THLSRange ): TColor; // NIH -// (c) Microsoft. http://support.microsoft.com/default.aspx?scid=kb;en-us;29240 -var - R,G,B : Integer; // RGB component values - Magic1,Magic2: Integer; // calculated magic numbers (really!) - - - { ----------------- LOCAL -----------------} - - function HueToRGB(n1,n2,hue: Integer): Integer; // (c) Microsoft. - // utility routine for HLStoRGB - begin - // range check: note values passed add/subtract thirds of range - if hue < 0 then Inc(hue, HLSMAX) - else if hue > HLSMAX then Dec(hue, HLSMAX); - - (* return r,g, or b value from this tridrant *) - if hue < (HLSMAX div 6) - then result := ( n1 + ( ( (n2-n1) * hue + (HLSMAX div 12) ) div (HLSMAX div 6) ) ) - else if hue < (HLSMAX div 2) - then result := n2 - else if hue < ( (HLSMAX*2) div 3 ) - then result := ( n1 + ( ( (n2-n1) * ( ( (HLSMAX*2) div 3 ) - hue ) - + (HLSMAX div 12) ) div (HLSMAX div 6) ) ) - else result := n1; - end;{HueToRGB} - - { ----------------- \LOCAL\ -----------------} - -begin - if Sat = 0 then // achromatic case - begin - R :=(Lum*RGBMAX) div HLSMAX; - G := R; - B := R; - if not(Hue = UNDEFINED) then - begin - // ...trap impossible conversions (?)... - end; - end else - begin // chromatic case - if (Lum <= (HLSMAX div 2)) // set up magic numbers - then Magic2 := ( Lum * ( HLSMAX + Sat ) + ( HLSMAX div 2 ) ) div HLSMAX - else Magic2 := Lum + Sat - ( (Lum * Sat) + ( HLSMAX div 2 ) ) div HLSMAX; - Magic1 := 2*Lum - Magic2; - - // get RGB, change units from HLSMAX to RGBMAX - R := ( HueToRGB( Magic1, Magic2, Hue + ( HLSMAX div 3 ) ) * RGBMAX + ( HLSMAX div 2) ) div HLSMAX; - G := ( HueToRGB( Magic1, Magic2, Hue )* RGBMAX +(HLSMAX div 2 ) ) div HLSMAX; - B := ( HueToRGB( Magic1, Magic2, Hue - ( HLSMAX div 3 ) ) * RGBMAX + ( HLSMAX div 2) ) div HLSMAX; - end; - Result := RGB(R,G,B); -end; - -// ---------------------------------------------------------- -function TKOLQProgressBar.MakeCylinder( h: Real ):Extended; // NIH -// (c) Matthieu Contensou (http://www25.brinkster.com/waypointfrance/cpulog/index.asp) -// who computed the polynome used to provide the "cylinder" appearence to bars : -// "f (h) = -4342,9 h^5 + 10543 h^4 - 8216 h^3 + 2018,1 h^2 + 11,096 h + 164,6" -// "h is the order of the wanted pixel in a column (horizontal bar), or in -// a row (vertical bar), with a value between 0 and 1 (0 -> 100%)" -begin - Result := ( (-4342.9 * ( Power(h,5) ) ) - + ( 10543 * ( Power(h,4) ) ) - - ( 8216 * ( Power(h,3) ) ) - + ( 2018.1 * ( Power(h,2) ) ) - + ( 11.096 * h ) + 164.6 ) ; -end; - -// ---------------------------------------------------------- -function TKOLQProgressBar.GetColorBetween(StartColor, EndColor: TColor; Pointvalue, - Von, Bis : Extended): TColor; // NIH -// Found on efg's colors pages, at http://homepages.borland.com/efg2lab/Library/Delphi/Graphics/Color.htm -// "Color gradient" row, cworn's UseNet Post. -// Author is unknown, but remains holder for intellectual property. -// High speed function which returns the gradient color value for a pixel depending -// on start and final color, size of the gradient area , and the place of the current pixel; - -var F: Extended; r1, r2, r3, g1, g2, g3, b1, b2, b3: Byte; - function CalcColorBytes(fb1, fb2: Byte): Byte; - begin - Result := fb1; - if fb1 < fb2 then Result := FB1 + Trunc(F * (fb2 - fb1)); - if fb1 > fb2 then Result := FB1 - Trunc(F * (fb1 - fb2)); - end; -begin - if ( (fMonoClr) or (Pointvalue <= Von) ) then - begin - Result := StartColor; - Exit; - end; - if ( Pointvalue >= Bis ) then - begin - Result := EndColor; - Exit; - end; - F := (Pointvalue - von) / (Bis - Von); - asm - mov EAX, Startcolor - cmp EAX, EndColor - je @@exit - mov r1, AL - shr EAX,8 - mov g1, AL - shr Eax,8 - mov b1, AL - mov Eax, Endcolor - mov r2, AL - shr EAX,8 - mov g2, AL - shr EAX,8 - mov b2, AL - push ebp - mov al, r1 - mov dl, r2 - call CalcColorBytes - pop ecx - push ebp - Mov r3, al - mov dL, g2 - mov al, g1 - call CalcColorBytes - pop ecx - push ebp - mov g3, Al - mov dL, B2 - mov Al, B1 - call CalcColorBytes - pop ecx - mov b3, al - XOR EAX,EAX - mov AL, B3 - SHL EAX,8 - mov AL, G3 - SHL EAX,8 - mov AL, R3 -@@Exit: - mov @Result, eax - end; -end; - -// ---------------------------------------------------------- -procedure TKOLQProgressBar.InitPixArray; -// Compute and stores each pixel color, in the case of a gradient, or a double -// gradient (both directions) in order to speed up things at run time. -var i, j, - rowSz : integer; - clr : TColor; - HLSr : THLSRec; -begin - - case ( fOrientation ) of - boHorizontal : rowSz := Height - (fBorderSize) + 1; - else rowSz := Width - (fBorderSize) + 1; // boVertical; - end; {Case} - - if ( fUSefullDrawSpace <= 0 ) - then SetLength(fPixDescr, 1) // Position 0 is allways False - else SetLength(fPixDescr, fUSefullDrawSpace + 1); - - // Populates active positions colors array ; - // -> GetColorBetween works on the horizontal gradient, in the case of a - // boHorizontal bar, with two colors (or on the vertical one, if the - // bar is vertical). - // -> GetGradientAr2 then returns the row gradient, based upon the header - // pixel value for that row in order to give the cylinder appearance. - for i := 0 to fUSefullDrawSpace do - begin - clr := GetColorBetween(fStartColor, fFinalColor, (i), 0, fUSefullDrawSpace); - if fBarKind = bkCylinder - then fPixDescr[i] := GetGradientAr2( clr, rowSz ) - else for j := 0 to rowSz -1 do - begin - SetLength(fPixDescr[i],rowSz); - fPixDescr[i,j] := clr; - end; - end; - // inactive positions decription, used in case 'showInactive positions' is true; - if ( Height - fBorderSize ) <= 0 Then - begin - SetLength( fInactDescr, 1 ); - fInactDescr[0] := fInactPosColor; - end else - begin - if fBarKind = bkCylinder - then fInactDescr := GetGradientAr2(fInactPosColor, rowSz ) - else - begin - SetLength(fInactDescr,rowSz); - for j := 0 to rowSz -1 do - fInactDescr[j] := fInactPosColor; - end; - end; - // case cylindric bar : the background can be basically reversed. - if (fBarKind = bkCylinder) and (fInvertInactPos) then - for i := 0 to rowSz -1 do - begin - HLSr := RGBtoHLS(fInactDescr[i]); - HLSr.lum := 240-HLSr.lum; - fInactDescr[i] := HLStoRGB(HLSr.hue,HLSr.lum,HLSr.sat); - end; -end; - -// ---------------------------------------------------------- -procedure TKOLQProgressBar.SetUsefullWidth; -begin - case fOrientation of - boHorizontal : fUSefullDrawSpace := (Width - ( fBorderSize )); - boVertical : fUSefullDrawSpace := (Height - ( fBorderSize )); - end; - fMinVisPos := fBorderSize + 1; -end; - -// ---------------------------------------------------------- -function TKOLQProgressBar.GetGradientAr2( aColor: TColor; sz: Integer): TClrArray; -// Version corrected by Bernd Kirchhoff (http://home.germany.net/100-445474/) -// Returns an array of size sz, filled up with a basic gradient; Used to -// provide the "cylindric" appearance. -var i,RP: Integer; - HLSr: THLSRec; -begin - SetLength(result,sz); - for i := 0 to sz - 1 do - Begin - HLSr := RGBtoHLS(aColor); - // (c) Bernd Kirchhoff >>>-------------------------------------------------- - if self.fBarLook = blGlass then - HLSr.lum := Round(MakeCylinder( (i / sz)) ) - else - begin - rp:= HLSr.lum - 212; - rp:= rp+Trunc(MakeCylinder( i / sz)); - if ( rp < 0 ) then rp:=0; - if ( rp > 240 ) then rp:=240; - HLSr.lum := rp; - end; - // <<<----------------------------------------------------------------------- - Result[i] := HLStoRGB(HLSr.hue,HLSr.lum,HLSr.sat); - end; -end; - -// ---------------------------------------------------------- -procedure TKOLQProgressBar.Paint; -var i,k,sp: Integer; - OldBkMode : Integer; -begin - // -1- Bevel - if ( fShaped ) then - with Canvas do - begin - Pen.Width := 1; - Brush.Style := bsSolid; - Brush.Color := fBackColor; - Pen.Color := fShapeColor; - RoundRect (0, 0, Width, Height, fCorner, fCorner); - end; - - // -2- The bar itself - case fOrientation of - boHorizontal : - begin - for i := (fBorderSize - 1) to fPosition do - begin - if (fByBlock) then - begin - if (fPosDescr[i].isInBlock = true) then - begin - if ( (fShowFullBlock) and (fPosition >= fPosDescr[i].blkLimit) ) - or ( not fShowFullBlock ) - then for k := (fBorderSize -1) to (Height -(fBorderSize)) - do Canvas.Pixels [i,k] := fPixDescr[i,k] - else if ( fShowInactPos ) then - for k := (fBorderSize -1) to (Height -(fBorderSize)) - do Canvas.Pixels [i,k] := fInactDescr[k]; - end; - end else - begin - for k := (fBorderSize -1) to (Height -(fBorderSize)) do - Canvas.Pixels [i,k] := fPixDescr[i,k]; - end; - end; - // Now dealing with inactive positions, if they're to be drawn. - if ( fShowInactPos ) then - begin - if fPosition < 3 then sp := 3 else sp := fPosition + 1; - for i := sp to fUSefullDrawSpace do - begin - if (fByBlock) then - begin - if (fPosDescr[i].isInBlock = True) then - begin - for k := (fBorderSize -1) to (Height -(fBorderSize)) do - Canvas.Pixels [i,k] := fInactDescr[k]; - end; - end - else //If not(byBlock), all pixels must be drawn - begin - for k := (fBorderSize -1) to (self.Height -(fBorderSize)) do - Canvas.Pixels [i,k] := fInactDescr[k]; - end; - end; {for} - end; {inactive} - end; {boHorizontal} - boVertical : - begin - for i := (fUSefullDrawSpace-1) downto ( height - fPosition ) do - begin - if (fByBlock) then - begin - if (fPosDescr[i].isInBlock = true) then - begin - if ( (fShowFullBlock) and ((height - fPosition) <= fPosDescr[i].blkLimit) ) - or not( fShowFullBlock ) - then for k := (fBorderSize - 1) to (self.Width -(fBorderSize)) - do Canvas.Pixels [k,i] := fPixDescr[i,k] - else if fShowInactPos then - for k := (fBorderSize - 1) to (Width -(fBorderSize)) - do Canvas.Pixels [k,i] := fInactDescr[k]; - end; - end - else for k := (fBorderSize - 1) to (Width -(fBorderSize)) - do Canvas.Pixels [k,i] := fPixDescr[i,k]; - end; - // inactive positions : - if ( fShowInactPos ) then - begin - if fPosition < 3 then sp := Self.fUSefullDrawSpace - else sp := height - fPosition - 1; - for i := sp downto fBorderSize do - begin - if ( fByBlock ) then - begin - if (fPosDescr[i].isInBlock = true) then - begin - for k := (fBorderSize -1) to (Width -(fBorderSize)) do - Canvas.Pixels [k,i] := fInactDescr[k]; - end; - end - else - for k := (fBorderSize -1) to (Width -(fBorderSize)) - do Canvas.Pixels [k,i] := fInactDescr[k]; - end; {for... downto} - end; {inactive} - end; {boVertical} - end; // Case - - // caption management. The font is the canvas' one. Can be overrided - // using the Font property : - if ( fAutoCaption ) then - if ( fShowPosAsPct ) then SetCaption( FloatToStr(fUSerPosPct) + '%' ) - else SetCaption( IntToStr(fUSerPos) ); - - if ( fHasCaption ) then - begin - if ( fParentFont ) then - // attach KOLForm change events to this control - PrepareCanvasFontForWYSIWIGPaint( Canvas ) - else - with Canvas do - begin - // use control font instead of KOLForm's one. - Font.Name:= fFont.FontName; - Font.Height:= fFont.FontHeight; - Font.Style:= fFont.FontStyle; - end; - with Canvas do - begin - // set transparent mode (actually for canvas font) - OldBkMode := SetBkMode( Handle, Windows.TRANSPARENT ); - Font.Color:= fFont.Color; - TextOut( fCapPos.X, fCapPos.Y, fCaption ); - end; - SetBkMode(Canvas.Handle, OldBkMode); - end; -end; - -// ---------------------------------------------------------- -procedure TKOLQProgressBar.SetupConstruct(SL: TStringList; const AName, - AParent, Prefix: string); -var - S: string; -begin - S := GenerateTransparentInits; - SL.Add( Prefix + AName + ' := PQProgressBar( New' + TypeName + '( ' - + SetupParams( AName, AParent ) + ' )' + S + ');' ); -end; - -// ---------------------------------------------------------- -procedure TKOLQProgressBar.SetupFirst(SL: TStringList; const AName, - AParent, Prefix: string); -var - FontStyle: string; -begin - inherited; - if ( fShowFullBlock ) then - SL.Add( Prefix + AName + '.ShowFullBlock:= true;' ); - if ( fBlockSize <> 0 ) then - SL.Add( Prefix + AName + '.BlockSize:= ' + IntToStr( BlockSize ) + ';' ); - if ( fSpaceSize <> 0 ) then - SL.Add( Prefix + AName + '.SpaceSize:= ' + IntToStr( SpaceSize ) + ';' ); - if ( fOrientation <> boHorizontal ) then - SL.Add( Prefix + AName + '.Orientation:= boVertical;' ); - if ( fBarKind <> bkFlat ) then - SL.Add( Prefix + AName + '.BarKind:= bkCylinder;' ); - if ( fBarLook <> blMetal ) then - SL.Add( Prefix + AName + '.BarLook:= blGlass;' ); - if ( fPosition <> 0 ) then - SL.Add( Prefix + AName + '.Progress:= ' + IntToStr( Progress ) + ';' ); - if ( fMaximum <> 100 ) then - SL.Add( Prefix + AName + '.MaxProgress:= ' + IntToStr( MaxProgress ) + ';' ); - if ( not Shaped ) then - SL.Add( Prefix + AName + '.Shaped:= false;' ); - if ( fShapeColor <> $00743C00 ) then - SL.Add( Prefix + AName + '.ShapeColor:= ' + Color2Str( ShapeColor ) + ';'); - if ( fStartColor <> clLime ) then - SL.Add( Prefix + AName + '.StartColor:= ' + Color2Str( StartColor ) + ';'); - if ( fFinalColor <> clLime ) then - SL.Add( Prefix + AName + '.FinalColor:= ' + Color2Str( FinalColor ) + ';'); - if ( fBackColor <> clWhite ) then - SL.Add( Prefix + AName + '.BackgroundColor:= ' + Color2Str( BackgroundColor ) + ';'); - if ( fInactPosColor <> clGray ) then - SL.Add( Prefix + AName + '.InactivePosColor:= ' + Color2Str( InactivePosColor ) + ';'); - if ( fShowInactPos ) then - SL.Add( Prefix + AName + '.ShowInactivePos:= true;' ); - if ( fInvertInactPos ) then - SL.Add( Prefix + AName + '.InvertInactPos:= true;' ); - if ( fAutoCaption ) then - SL.Add( Prefix + AName + '.AutoCaption:= true;' ) - else - if ( Caption <> '' ) then - SL.Add( Prefix + AName + '.Caption:= ''' + Caption + ''';'); - if ( fAutoHint ) then - SL.Add( Prefix + AName + '.AutoHint:= true;' ); - if ( fShowPosAsPct ) then - SL.Add( Prefix + AName + '.ShowPosAsPct:= true;' ); - if ( fHideOnTerm ) then - SL.Add( Prefix + AName + '.HideOnTerminate:= true;' ); - if ( not fRoundCorner ) then - SL.Add( Prefix + AName + '.RoundCorner:= false;' ); - if ( fCaptionAlign <> taLeft ) then - begin - if ( fCaptionAlign = taCenter ) then - SL.Add( Prefix + AName + '.CaptionAlign:= taCenter;' ); - if ( fCaptionAlign = taRight ) then - SL.Add( Prefix + AName + '.CaptionAlign:= taRight;' ); - end; - - if ( not fParentFont ) then - begin - SL.Add( Prefix + AName + '.Font.FontHeight:= ' + Int2Str( fFont.FontHeight ) + ';' ); - SL.Add( Prefix + AName + '.Font.FontName:= ''' + fFont.FontName + ''';' ); - if ( fFont.FontWeight <> 0 ) then - SL.Add( Prefix + AName + '.Font.FontWeight:= '+ Int2Str( fFont.FontWeight ) + ';' ); - if ( fFont.FontWidth <> 0 ) then - SL.Add( Prefix + AName + '.Font.FontWidth:= '+ Int2Str( fFont.FontWidth ) + ';' ); - if ( fFont.Color <> clWindowText ) then - SL.Add( Prefix + AName + '.Font.Color:= '+ Color2Str( fFont.Color ) + ';'); - - FontStyle := ''; - if ( fsBold in fFont.FontStyle ) then FontStyle := FontStyle + 'fsBold, '; - if ( fsItalic in fFont.FontStyle ) then FontStyle := FontStyle + 'fsItalic, '; - if ( fsUnderline in fFont.FontStyle ) then FontStyle := FontStyle + 'fsUnderline, '; - if ( fsStrikeOut in fFont.FontStyle ) then FontStyle := FontStyle + 'fsStrikeOut, '; - - if ( Length( FontStyle ) > 0 ) then - begin - SetLength( FontStyle, Length( FontStyle ) - 2 ); - SL.Add( Prefix + AName + '.Font.FontStyle := [' + FontStyle + '];'); - end; - - end; -end; - -// ---------------------------------------------------------- -function TKOLQProgressBar.SetupParams( const AName, AParent: string ): string; -begin - Result:= AParent; -end; - -// ---------------------------------------------------------- -procedure TKOLQProgressBar.AssignEvents(SL: TStringList; const AName: string); -begin - inherited; - DoAssignEvents( SL, AName, [ 'OnProgressChange' ], [ @OnProgressChange ]); -end; - -// ---------------------------------------------------------- -procedure TKOLQProgressBar.SetOrientation( Value: TQBarOrientation ); -var tmpClr: TColor; - newH, - newW: Integer; -begin - if ( value <> fOrientation ) then - begin - if ( (value = boVertical) and (Height < width) ) - or ( (value = boHorizontal) and (width < height) ) then - begin - newW := Height; - newH := Width; - Height := newH; - Width := newW; - end; - fOrientation := value; - if ( csDesigning in componentState ) then - begin - tmpClr := fStartColor; - fStartColor := fFinalColor; - fFinalColor := tmpClr; - end; - end; - case ( value ) of - boHorizontal : if Height < 10 - then fInternalBorder := 1 - else fInternalBorder := 2; - boVertical : if Width < 10 - then fInternalBorder := 1 - else fInternalBorder := 2; - end; // Case - fBorderSize := fInternalBorder shl 1; - SetUsefullWidth; - InitBlockArray; - InitPixArray; - Progress:= fUserPos; - Invalidate; - Change; -end; - -// ---------------------------------------------------------- -procedure TKOLQProgressBar.SetBarKind( Value: TQBarKind ); -begin - fBarKind:= Value; - InitPixArray; - Invalidate; - Change; -end; - -// ---------------------------------------------------------- -procedure TKOLQProgressBar.SetBarLook( Value: TQBarLook); -begin - fBarLook:= Value; - InitPixArray; - Invalidate; - Change; -end; - -// ---------------------------------------------------------- -procedure TKOLQProgressBar.SetRoundCorner( Value: Boolean ); -begin - fRoundCorner:= Value; - if ( Value ) then fCorner:= 5 - else fCorner:= 0; - Invalidate; - Change; -end; - -// ---------------------------------------------------------- -procedure TKOLQProgressBar.SetBackColor( Value: TColor ); -begin - fBackColor:= Value; - Invalidate; - Change; -end; - -// ---------------------------------------------------------- -procedure TKOLQProgressBar.SetBarColor( Value: TColor ); -begin - fMonoClr := True; - fBarColor:= Value; - fStartColor:= Value; - fFinalColor:= Value; - InitPixArray; - Invalidate; - Change; -end; - -// ---------------------------------------------------------- -procedure TKOLQProgressBar.SetStartColor( Value: TColor ); -begin - fStartColor:= Value; - fMonoClr := (fStartColor = fFinalColor); - InitPixArray; - Invalidate; - Change; -end; - -// ---------------------------------------------------------- -procedure TKOLQProgressBar.SetFinalColor(Value: TColor ); -begin - fFinalColor:= Value; - fMonoClr := (fStartColor = fFinalColor); - InitPixArray; - Invalidate; - Change; -end; - -// ---------------------------------------------------------- -procedure TKOLQProgressBar.SetShowInactPos( Value: Boolean ); -begin - fShowInactPos:= Value; - InitPixArray; - Invalidate; - Change; -end; - -// ---------------------------------------------------------- -procedure TKOLQProgressBar.SetInvertInactPos( Value: Boolean ); -begin - fInvertInactPos:= Value; - InitPixArray; - Invalidate; - Change; -end; - -// ---------------------------------------------------------- -procedure TKOLQProgressBar.SetInactPosColor( Value: TColor ); -begin - fInactPosColor:= Value; - InitPixArray; - Invalidate; - Change; -end; - -// ---------------------------------------------------------- -procedure TKOLQProgressBar.SetShaped( Value: Boolean ); -begin - fShaped:= Value; - Invalidate; - Change; -end; - -// ---------------------------------------------------------- -procedure TKOLQProgressBar.SetShapeColor( Value: TColor ); -begin - fShapeColor:= Value; - Invalidate; - Change; -end; - -// ---------------------------------------------------------- -procedure TKOLQProgressBar.SetBlockSize( Value: Integer ); -begin - case ( fOrientation ) of - boHorizontal : if value > Width - (fInternalBorder SHL 1) then Exit; - boVertical : if value > Height - (fInternalBorder SHL 1) then Exit; - end; {case} - - fBlockSize := Abs(value); - fByBlock := (fBlockSize > 0) And (fSpaceSize > 0); - if ( fByBlock ) then InitBlockArray; - InitPixArray; - Invalidate; - Change; -end; - -// ---------------------------------------------------------- -procedure TKOLQProgressBar.SetSpaceSize( Value: Integer ); -begin - case ( fOrientation ) of - boHorizontal : if value > Self.Width - (fInternalBorder shl 1) then Exit; - boVertical : if value > Self.Height - (fInternalBorder shl 1) then Exit; - end; {case} - - fSpaceSize := Abs(value); - fByBlock := (fBlockSize > 0) and (fSpaceSize > 0); - if ( fByBlock ) then InitBlockArray; - InitPixArray; - Invalidate; - Change; -end; - -// ---------------------------------------------------------- -procedure TKOLQProgressBar.SetShowFullBlock( Value: Boolean ); -begin - fShowFullBlock := value; - InitBlockArray; - InitPixArray; - Invalidate; - Change; -end; - -// ---------------------------------------------------------- -procedure TKOLQProgressBar.SetMaximum( Value: Integer ); -begin - fMaximum:= Value; - SetPosition( fUserPos ); - Invalidate; - Change; -end; - -// ---------------------------------------------------------- -procedure TKOLQProgressBar.SetPosition( Value: Integer); -var tmpfPos : real; -begin - fUserPos := value; - if ( fMaximum = 0 ) then exit; - try - if (value <= 0) Then - begin - fPosition := 0; - Exit; - end - else - if ( value > fMaximum ) then value := fMaximum; - - fUSerPosPct := (100 * value)/fMaximum; - tmpfPos := fUsefullDrawSpace * fUSerPosPct / 100; - // If value( user position) > 0, make sure that at least one bar is visible - if (tmpfPos > 0.00) and (tmpfPos < fMinVisPos ) - then fPosition := fMinVisPos - else if ( tmpfPos > fUsefullDrawSpace ) - then fPosition := fUsefullDrawSpace - else fPosition := Round( tmpfPos ); - finally - Invalidate; - end; - Change; -end; - -// ---------------------------------------------------------- -procedure TKOLQProgressBar.SetHideOnTerm( Value: Boolean ); -begin - fHideOnTerm:= Value; - Change; -end; - -// ---------------------------------------------------------- -procedure TKOLQProgressBar.SetCaptionAlign( Value: TTextAlign ); -begin - fCaptionAlign:= Value; - SetCaption( fCaption ); - Invalidate; - Change; -end; - -// ---------------------------------------------------------- -procedure TKOLQProgressBar.SetAutoCaption( Value: Boolean ); -begin - fAutoCaption:= Value; - Invalidate; - Change; -end; - -// ---------------------------------------------------------- -procedure TKOLQProgressBar.SetAutoHint( Value: Boolean ); -begin - fAutoHint:= Value; - Invalidate; - Change; -end; - -// ---------------------------------------------------------- -procedure TKOLQProgressBar.SetShowPosAsPct( Value: Boolean ); -begin - fShowPosAsPct:= Value; - Invalidate; - Change; -end; - -// ---------------------------------------------------------- -procedure TKOLQProgressBar.SetOnProgressChange( Value: TOnQProgressBar ); -begin - fOnProgressChange:= Value; - Change; -end; - -// ---------------------------------------------------------- - - -end. diff --git a/Addons/mckRAS.dcr b/Addons/mckRAS.dcr deleted file mode 100644 index f31f7d929598594328ab48c0e108a95d403ba12d..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 468 zcmZvWu};J=42E5VL~kP9*tn5_EjMOCWFyi^zyoE3t+$c4sZ@`Vc$J>G@g(!d?hQy- zas1W(e>X%#Tcn63@K1bnM33l*T+utd(4G>#(i6R{D(7ylFNO!e-I^U)dkg>nk%@39 zXDhgY$V}5TVbC7bideyIZ)_E@VAiI}hhZ3;;?aHeeQ$if6vWE1$@%kEHI7^;r56Tq_32b~cT#$^r;pB_cn8d2NfF(*=J4-HYDO diff --git a/Addons/mckRAS.pas b/Addons/mckRAS.pas deleted file mode 100644 index 24304be..0000000 --- a/Addons/mckRAS.pas +++ /dev/null @@ -1,94 +0,0 @@ -unit mckRAS; - -interface - -uses - Windows, Classes, Messages, Forms, SysUtils, - KOLRAS, mirror; - -type - - TKOLRAS = class(TKOLObj) - private - - fRASName: string; - FOnConnecting: TOnConnectingEvent; - FOnError: TOnErrorEvent; - - protected - - function AdditionalUnits: string; override; - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure AssignEvents( SL: TStringList; const AName: String ); override; - - procedure SetRASName(Value: string); - procedure SetOnConnecting(Value: TOnConnectingEvent); - procedure SetOnError(Value: TOnErrorEvent); - - published - - property RASName: string read FRASName write SetRASName; - property OnConnecting: TOnConnectingEvent read FOnConnecting write SetOnConnecting; - property OnError: TOnErrorEvent read FOnError write SetOnError; - - end; - - procedure Register; - -implementation - -{$R *.dcr} - -procedure TKOLRAS.SetRASName(Value: String); -begin - fRASName := Value; - Change; -end; - -procedure TKOLRAS.SetOnConnecting; -begin - fOnConnecting := Value; - Change; -end; - -procedure TKOLRAS.SetOnError; -begin - fOnError := Value; - Change; -end; - -function TKOLRAS.AdditionalUnits; -begin - Result := ', KOLRAS'; -end; - -procedure TKOLRAS.SetupFirst(SL: TStringList; const AName, - AParent, Prefix: String); -begin - SL.Add( Prefix + AName + ' := NewRASObj;' ); - if fRASName <> '' then - SL.Add( Prefix + AName + '.RASName := ''' + fRASName + ''';'); -end; - -procedure TKOLRAS.SetupLast(SL: TStringList; const AName, - AParent, Prefix: String); -begin - // -end; - -procedure TKOLRAS.AssignEvents(SL: TStringList; const AName: String); -begin - inherited; - DoAssignEvents( SL, AName, - [ 'OnConnecting', 'OnError' ], - [ @OnConnecting , @OnError ]); -end; - -procedure Register; -begin - RegisterComponents('KOLAddons', [TKOLRAS]); -end; - -end. - diff --git a/Addons/mckRarInfoBar.dcr b/Addons/mckRarInfoBar.dcr deleted file mode 100644 index 800ffa141e055df0748d283da4c09d5753b28b28..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 1724 zcmciCJ#JJ%48U=dAj0cXLg$hLZ~#MrgtP()?EzeJ3?Cq6(z`&M!!<`pD13zUTP**1 zlZ}+kre$V-&$IUXn)gOeL`1RQPYj>5pKnAylG*RiWGg@96TZqf`6A!t^ZIY@etG%+ z_2Iw|4BkC>C2!ZXogJ#jF+})D#0+d1N>xeyExG^mn;SGZC}^V4A|_BUFh?L!Xb~4E z4E*sxqR5g<9Dzik=Ob|?8XSQ{q37cYB^n%oM4{)SOeGo|fkdI_V=g5c9Dzik z*H>VzM1v!cD6|Cg4^fPnJ4R0wT0#X1gCmeA^n7imM1v!cDD-@#u0(?)kSO$g-CQKX z;0PoNJ(of%(clOq3O$!eDbe5vBnrJQp=c!<9DzikrI>$-!r%xbM(??_REY*hAW`VK z>`aLUM<7w?xg=eQ21g)K=($`&i3Ud?QRumpQ;7ygAW`VK%u9&|MVZLXFZ+EJeL$vpdSPVK*;a5DeW`LDLu%k}ozb+2j5x_P|+F<5T5 lYkqrobf34h<&O5>^W&;Gy6(7@wLQ&`DUg1aTqk+R{sZ0!%^Ls! diff --git a/Addons/mckRarInfoBar.pas b/Addons/mckRarInfoBar.pas deleted file mode 100644 index 0429711..0000000 --- a/Addons/mckRarInfoBar.pas +++ /dev/null @@ -1,372 +0,0 @@ -unit mckRarInfoBar; - -interface - -uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, - ComCtrls, ExtCtrls, Mirror; - -const - Boolean2Str: array [Boolean] of string = ('False','True'); - -type - TRarInfoBar = class(TKOLControl) - private - { Private declarations } - FPosition: integer; - FMin,FMax: integer; - FShowPerc: boolean; - - FLineColor,FTopColor,FSideColor1,FSideColor2,FEmptyColor1,FEmptyColor2, - FEmptyFrameColor1,FEmptyFrameColor2,FBottomFrameColor,FBottomColor, - FFilledFrameColor,FFilledColor,FFilledSideColor1,FFilledSideColor2: TColor; - - TopX,TopY,Size: integer; - - procedure SetPos(P: integer); - procedure SetMin(M: integer); - procedure SetMax(M: integer); - procedure SetShowPerc(V: boolean); - - procedure SetLineColor(C: TColor); - procedure SetTopColor(C: TColor); - procedure SetSideColor1(C: TColor); - procedure SetSideColor2(C: TColor); - procedure SetEmptyColor1(C: TColor); - procedure SetEmptyColor2(C: TColor); - procedure SetEmptyFrameColor1(C: TColor); - procedure SetEmptyFrameColor2(C: TColor); - procedure SetBottomFrameColor(C: TColor); - procedure SetBottomColor(C: TColor); - procedure SetFilledFrameColor(C: TColor); - procedure SetFilledColor(C: TColor); - procedure SetFilledSideColor1(C: TColor); - procedure SetFilledSideColor2(C: TColor); - protected - { Protected declarations } - procedure WMPaint(var Msg: TMessage); message WM_PAINT; - procedure WMSize(var Msg: TMessage); message WM_SIZE; - procedure WMActiv(var Msg: TMessage); message WM_SHOWWINDOW; - function AdditionalUnits: string; override; - procedure SetupFirst(SL: TStringList; const AName,AParent,Prefix: string); override; - public - { Public declarations } - constructor Create(Owner: TComponent); override; - procedure Paint; override; - published - { Published declarations } - property Position: integer read FPosition write SetPos; - property Max: integer read FMax write SetMax; - property Min: integer read FMin write SetMin; - property ShowPercent: boolean read FShowPerc write SetShowPerc; - - property LineColor: TColor read FLineColor write SetLineColor; - property TopColor: TColor read FTopColor write SetTopColor; - property SideColor1: TColor read FSideColor1 write SetSideColor1; - property SideColor2: TColor read FSideColor2 write SetSideColor2; - property EmptyColor1: TColor read FEmptyColor1 write SetEmptyColor1; - property EmptyColor2: TColor read FEmptyColor2 write SetEmptyColor2; - property EmptyFrameColor1: TColor read FEmptyFrameColor1 write SetEmptyFrameColor1; - property EmptyFrameColor2: TColor read FEmptyFrameColor2 write SetEmptyFrameColor2; - property BottomFrameColor: TColor read FBottomFrameColor write SetBottomFrameColor; - property BottomColor: TColor read FBottomColor write SetBottomColor; - property FilledFrameColor: TColor read FFilledFrameColor write SetFilledFrameColor; - property FilledColor: TColor read FFilledColor write SetFilledColor; - property FilledSideColor1: TColor read FFilledSideColor1 write SetFilledSideColor1; - property FilledSideColor2: TColor read FFilledSideColor2 write SetFilledSideColor2; - end; - -procedure Register; - -implementation - -{$R mckRarInfoBar.dcr} - -procedure Register; -begin - RegisterComponents('KOLAddons', [TRarInfoBar]); -end; - -constructor TRarInfoBar.Create; -begin - inherited; - Width:=70; - Height:=180; - FMin:=0; - FMax:=100; - FPosition:=0; - FLineColor:=$FFE0E0; - FTopColor:=$FF8080; - FSideColor1:=$E06868; - FSideColor2:=$FF8080; - FEmptyFrameColor1:=$A06868; - FEmptyFrameColor2:=$BF8080; - FEmptyColor1:=$C06868; - FEmptyColor2:=$DF8080; - FBottomFrameColor:=$64408C; - FBottomColor:=$7A408C; - FFilledFrameColor:=$8060A0; - FFilledSideColor1:=$823C96; - FFilledSideColor2:=$8848C0; - FFilledColor:=$A060A0; - FShowPerc:=True; - Font.FontStyle:=[fsBold]; - Font.Color:=clPurple; -end; - -procedure TRarInfoBar.WMPaint; -begin - inherited; - Paint; -end; - -procedure TRarInfoBar.WMSize; -begin - inherited; - Paint; -end; - -procedure TRarInfoBar.WMActiv; -begin - inherited; - Paint; -end; - -function TRarInfoBar.AdditionalUnits; -begin - Result:=', KOLRarBar'; -end; - -procedure TRarInfoBar.SetupFirst; -begin - inherited; - SL.Add(Prefix+AName+'.Position := '+IntToStr(FPosition)+';'); - SL.Add(Prefix+AName+'.Min := '+IntToStr(FMin)+';'); - SL.Add(Prefix+AName+'.Max := '+IntToStr(FMax)+';'); - SL.Add(Prefix+AName+'.ShowPercent := '+Boolean2Str[FShowPerc]+';'); - SL.Add(Prefix+AName+'.LineColor := '+Color2Str(FLineColor)+';'); - SL.Add(Prefix+AName+'.TopColor := '+Color2Str(FTopColor)+';'); - SL.Add(Prefix+AName+'.SideColor1 := '+Color2Str(FSideColor1)+';'); - SL.Add(Prefix+AName+'.SideColor2 := '+Color2Str(FSideColor2)+';'); - SL.Add(Prefix+AName+'.EmptyFrameColor1 := '+Color2Str(FEmptyFrameColor1)+';'); - SL.Add(Prefix+AName+'.EmptyFrameColor2 := '+Color2Str(FEmptyFrameColor2)+';'); - SL.Add(Prefix+AName+'.EmptyColor1 := '+Color2Str(FEmptyColor1)+';'); - SL.Add(Prefix+AName+'.EmptyColor2 := '+Color2Str(FEmptyColor2)+';'); - SL.Add(Prefix+AName+'.BottomFrameColor := '+Color2Str(FBottomFrameColor)+';'); - SL.Add(Prefix+AName+'.BottomColor := '+Color2Str(FBottomColor)+';'); - SL.Add(Prefix+AName+'.FilledFrameColor := '+Color2Str(FFilledFrameColor)+';'); - SL.Add(Prefix+AName+'.FilledSideColor1 := '+Color2Str(FFilledSideColor1)+';'); - SL.Add(Prefix+AName+'.FilledSideColor2 := '+Color2Str(FFilledSideColor2)+';'); - SL.Add(Prefix+AName+'.FilledColor := '+Color2Str(FFilledColor)+';'); -end; - -procedure TRarInfoBar.SetPos; -begin - if P>FMax then P:=FMax; - FPosition:=P; - Paint; -end; - -procedure TRarInfoBar.SetMin; -begin - if M>FMax then M:=FMax; - FMin:=M; - Paint; -end; - -procedure TRarInfoBar.SetMax; -begin - if MSize-10 then Prog:=Size-10; - Canvas.Brush.Color:=Color; - Canvas.FillRect(Canvas.ClipRect); - DrawFrame(Canvas); - Canvas.Brush.Color:=FTopColor; - Canvas.FloodFill(TopX+7,TopY+5,Canvas.Pixels[TopX+(15 div 2),TopY+5],fsSurface); - Canvas.Brush.Color:=FSideColor1; - Canvas.FloodFill(TopX+1,TopY+6,Canvas.Pixels[TopX+1,TopY+6],fsSurface); - Canvas.Brush.Color:=FSideColor2; - Canvas.FloodFill(TopX+29,TopY+6,Canvas.Pixels[TopX+29,TopY+6],fsSurface); - if Prog>0 then - begin - Canvas.MoveTo(TopX,TopY+Size-5); - Canvas.Pen.Color:=FBottomFrameColor; - Canvas.LineTo(Canvas.PenPos.X+15,Canvas.PenPos.Y-5); - Canvas.LineTo(Canvas.PenPos.X+15,Canvas.PenPos.Y+5); - Canvas.Brush.Color:=FBottomColor; - Canvas.FloodFill(TopX+7,TopY+Size-5,FSideColor1,fsSurface); - Canvas.FloodFill(TopX+22,TopY+Size-5,FSideColor2,fsSurface); - Canvas.Brush.Color:=FFilledColor; - Canvas.Pen.Color:=FFilledFrameColor; - Points[1]:=Point(TopX+15,TopY+Size-Prog); - Points[2]:=Point(TopX,TopY+Size-Prog-5); - Points[3]:=Point(TopX+15,TopY+Size-Prog-10); - Points[4]:=Point(TopX+30,TopY+Size-Prog-5); - Canvas.Polygon(Points); - Canvas.Brush.Color:=FFilledSideColor1; - Canvas.FloodFill(TopX+1,TopY+Size-5-(Prog div 2),FSideColor1,fsSurface); - Canvas.Brush.Color:=FFilledSideColor2; - Canvas.FloodFill(TopX+29,TopY+Size-5-(Prog div 2),FSideColor2,fsSurface); - DrawFrame(Canvas); - end - else - begin - {EMPTY} - Canvas.MoveTo(TopX,TopY+Size-5); - Canvas.Pen.Color:=FEmptyFrameColor1; - Canvas.LineTo(Canvas.PenPos.X+15,Canvas.PenPos.Y-5); - Canvas.Pen.Color:=FEmptyFrameColor2; - Canvas.LineTo(Canvas.PenPos.X+15,Canvas.PenPos.Y+5); - DrawFrame(Canvas); - Canvas.Brush.Color:=FEmptyColor1; - Canvas.FloodFill(TopX+7,TopY+Size-5,FSideColor1,fsSurface); - Canvas.Brush.Color:=FEmptyColor2; - Canvas.FloodFill(TopX+22,TopY+Size-5,FSideColor2,fsSurface); - end; - if FShowPerc then - begin - Canvas.Font.Name:=Font.FontName; - Canvas.Font.Height:=Font.FontHeight; - Canvas.Font.Color:=Font.Color; - Canvas.Font.Style:=Font.FontStyle; - Canvas.Brush.Color:=Color; - S:=IntToStr(Perc)+' %'; - Canvas.TextOut(TopX+33,TopY+Size-Prog-Canvas.TextHeight(S),S); - end; -end; - -end. - diff --git a/Addons/mckRarProgBar.dcr b/Addons/mckRarProgBar.dcr deleted file mode 100644 index 9ef91704cfb0db3c65f3e0a5473cf4a0495ffb54..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 484 zcmaJ*u?oU45PcOtprdXb-Me&fQ4mK({f5v#(9MES4l?*LE`=-|9sH;G(ljAL@sjuM z-MhOG04NA+Jt%)dGGI-|+8Hi5VM82=1NP({&OF<}^=o;)oQDTi6pIlVyj}3U>1Y66 zG>uPWN}@sE_iVTix@3JK`#)Pq5|6Tql{T+3l)5s;j4f?C9d##Bb5ZNKort>)A#w}; rllt>^N93PQ=C3h=Igwkb>z3qN%u104t%SbvI-NFMax then P:=FMax; - FPosition1:=P; - Paint; -end; - -procedure TRarProgressBar.SetPos2; -begin - if FDouble then if P>FPosition1 then P:=FPosition1; - FPosition2:=P; - Paint; -end; - -procedure TRarProgressBar.SetMin; -begin - if M>FMax then M:=FMax; - FMin:=M; - Paint; -end; - -procedure TRarProgressBar.SetMax; -begin - if M0 then - begin - Canvas.Brush.Color:=FLightColor1; - Canvas.FillRect(Bounds(TopX,TopY,TopX+Prog-2,TopY+SizeY-2)); - if Prog>1 then - begin - Canvas.Brush.Color:=FFillColor1; - Canvas.FillRect(Bounds(TopX+1,TopY+1,TopX+Prog-3,TopY+SizeY-3)); - Canvas.Brush.Color:=FFrameColor1; - Canvas.FrameRect(Bounds(TopX+1,TopY+1,TopX+Prog-3,TopY+SizeY-3)); - end; - Canvas.Brush.Color:=FDarkColor; - Canvas.FillRect(Bounds(TopX+Prog,TopY,1,TopY+SizeY-1)); - if Prog0 then - begin - Canvas.Brush.Color:=FLightColor2; - Canvas.FillRect(Bounds(TopX,TopY,TopX+Prog-2,TopY+SizeY-2)); - if Prog>1 then - begin - Canvas.Brush.Color:=FFillColor2; - Canvas.FillRect(Bounds(TopX+1,TopY+1,TopX+Prog-3,TopY+SizeY-3)); - Canvas.Brush.Color:=FFrameColor2; - Canvas.FrameRect(Bounds(TopX+1,TopY+1,TopX+Prog-3,TopY+SizeY-3)); - end; - end; - end; -end; - -procedure TRarProgressBar.Add1; -begin - Inc(FPosition1,D); - Paint; -end; - -procedure TRarProgressBar.Add2; -begin - Inc(FPosition2,D); - Paint; -end; - -end. - diff --git a/Addons/mckSocket.dcr b/Addons/mckSocket.dcr deleted file mode 100644 index 225227284b481b2ef9357c082622fc3ba246063b..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 476 zcmcJKJr2S!42542QedJZV@D3a4G>e27~n3+Mz-cyxmDTBb4)5Cb>%6xKfO3V27rMf zVnJ+_I^ax4WP>M0+;PK$`9i+Zsp|Xvw(^N^{6+_}2i~);2yh`rE6haXoLO~4Kc+>j zFxy`Rz7cy=PR(5^Dtstip|Z@ra`3N(C-3L#PtL9LPfti`IjaxUvkm|EEm6J8TsFGR IUdAoy1D&IjTmS$7 diff --git a/Addons/mckSocket.pas b/Addons/mckSocket.pas deleted file mode 100644 index c30ca96..0000000 --- a/Addons/mckSocket.pas +++ /dev/null @@ -1,182 +0,0 @@ -unit mckSocket; - -interface - -uses - Windows, Classes, Messages, Winsock, Forms, SysUtils, - KOLSocket, mirror; - -type - - TSocketMessageEvent = procedure (SocketMessage: TWMSocket) of object; - - TKOLSocket = class(TKOLObj) - private - fIPAddress: string; - fPortNumber: word; - FOnError: TSocketMessageEvent; - FOnAccept: TSocketMessageEvent; - FOnClose: TSocketMessageEvent; - FOnConnect: TSocketMessageEvent; - FOnRead: TSocketMessageEvent; - FOnWrite: TSocketMessageEvent; - FOnListen: TSocketMessageEvent; - FOnOOB: TSocketMessageEvent; - protected - function AdditionalUnits: string; override; - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure AssignEvents( SL: TStringList; const AName: String ); override; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - - function GetPortNumber: LongInt; - function GetIPAddress: String; - - procedure SetPortNumber(NewPortNumber: LongInt); - procedure SetIPAddress(NewIPAddress: String); - - procedure SetOnAccept(Value: TSocketMessageEvent); - procedure SetOnClose(Value: TSocketMessageEvent); - procedure SetOnConnect(Value: TSocketMessageEvent); - procedure SetOnError(Value: TSocketMessageEvent); - procedure SetOnListen(Value: TSocketMessageEvent); - procedure SetOnOOB(Value: TSocketMessageEvent); - procedure SetOnRead(Value: TSocketMessageEvent); - procedure SetOnWrite(Value: TSocketMessageEvent); - - published - property IPAddress: String read GetIPAddress write SetIPAddress; - property PortNumber: LongInt read GetPortNumber write SetPortNumber; - property OnError: TSocketMessageEvent read FOnError write SetOnError; - property OnAccept: TSocketMessageEvent read FOnAccept write SetOnAccept; - property OnClose: TSocketMessageEvent read FOnClose write SetOnClose; - property OnConnect: TSocketMessageEvent read FOnConnect write SetOnConnect; - property OnRead: TSocketMessageEvent read FOnRead write SetOnRead; - property OnWrite: TSocketMessageEvent read FOnWrite write SetOnWrite; - property OnOOB: TSocketMessageEvent read FOnOOB write SetOnOOB; - property OnListen: TSocketMessageEvent read FOnListen write SetOnListen; - end; - - procedure Register; - -implementation - -{$R *.dcr} - -constructor TKOLSocket.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - InstanceCount := InstanceCount + 1; -end; // constructor TKOLSocket.Create - -destructor TKOLSocket.Destroy; -begin - inherited Destroy; -end; // destructor TKOLSocket.Destroy; - -function TKOLSocket.GetIPAddress: String; -begin - Result := fIPAddress; -end; // function TKOLSocket.GetIPAddress: String - -function TKOLSocket.GetPortNumber: LongInt; -begin - Result := fPortNumber; -end; // function TKOLSocket.GetPortNumber: Word - -procedure TKOLSocket.SetIPAddress(NewIPAddress: String); -begin - fIPAddress := NewIPAddress; - Change; -end; // procedure TKOLSocket.SetIPAddress(NewIPAddress: String) - -procedure TKOLSocket.SetPortNumber(NewPortNumber: LongInt); -begin - fPortNumber := NewPortNumber; - Change; -end; // procedure TKOLSocket.SetPortNumber(NewPortNumber: Word) - -procedure TKOLSocket.SetOnAccept; -begin - fOnAccept := Value; - Change; -end; - -procedure TKOLSocket.SetOnClose; -begin - fOnClose := Value; - Change; -end; - -procedure TKOLSocket.SetOnConnect; -begin - fOnConnect := Value; - Change; -end; - -procedure TKOLSocket.SetOnError; -begin - fOnError := Value; - Change; -end; - -procedure TKOLSocket.SetOnListen; -begin - fOnListen := Value; - Change; -end; - -procedure TKOLSocket.SetOnOOB; -begin - fOnOOB := Value; - Change; -end; - -procedure TKOLSocket.SetOnRead; -begin - fOnRead := Value; - Change; -end; - -procedure TKOLSocket.SetOnWrite; -begin - fOnWrite := Value; - Change; -end; - -function TKOLSocket.AdditionalUnits; -begin - result := ', KOLSocket'; -end; - -procedure TKOLSocket.SetupFirst(SL: TStringList; const AName, - AParent, Prefix: String); -begin - SL.Add( Prefix + AName + ' := NewAsyncSocket;' ); - SL.Add( Prefix + AName + '.PortNumber := ' + inttostr(fPortNumber) + ';'); - SL.Add( Prefix + AName + '.IPAddress := ''' + fIPAddress + ''';'); -end; - -procedure TKOLSocket.SetupLast(SL: TStringList; const AName, - AParent, Prefix: String); -begin - // -end; - -procedure TKOLSocket.AssignEvents(SL: TStringList; const AName: String); -begin - inherited; - DoAssignEvents( SL, AName, - [ 'OnConnect', 'OnAccept', 'OnListen', 'OnRead', 'OnWrite', 'OnOOB', 'OnClose', 'OnError' ], - [ @OnConnect , @OnAccept , @OnListen , @OnRead , @OnWrite , @OnOOB , @OnClose , @OnError ]); -end; - -procedure Register; -begin - RegisterComponents('KOLAddons', [TKOLSocket]); -end; - -end. - diff --git a/Addons/mckTCPSocket.dcr b/Addons/mckTCPSocket.dcr deleted file mode 100644 index 34a66eeaa9639ebceb16bbe9298c2a3d687858f0..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 928 zcmd5(v5LY#5Pgb88o^RKNhLyhd$~fCJGqnlj_YFQcG>30Kcvi8?c>pkFh`1oVf$jkdc0~HvVT})LSeMx13vc+ux6N*3G@1puQ8FHW-@gS!!WT{BFB{3}Gd160B>tEgpf8~GwmUMDO_ulEJ!!!Lm qQi2z4&2TSA-@8im{{7HF@0n`(*W#Rrf`4fm_(5lXT$;dN)4vNcXq#aG diff --git a/Addons/mckTCPSocket.pas b/Addons/mckTCPSocket.pas deleted file mode 100644 index e2e7f42..0000000 --- a/Addons/mckTCPSocket.pas +++ /dev/null @@ -1,289 +0,0 @@ -unit mckTCPSocket; - -interface - -uses - Windows, Classes, Messages, Winsock, Forms, SysUtils, kolTCPSocket, mirror; - -type - TKOLTCPClient = class(TKOLObj) - private - FPort: smallint; - FHost: string; - FOnConnect: TOnTCPConnect; - FOnDisconnect: TOnTCPDisconnect; - FOnError: TOnTCPError; - FOnReceive: TOnTCPReceive; -// FOnResolve: TOnTCPResolve; - FOnManualReceive: TOnTCPManualReceive; - FOnStreamReceive: TOnTCPStreamReceive; - FOnStreamSend: TOnTCPStreamSend; - procedure SetHost(const Value: string); - procedure SetOnConnect(const Value: TOnTCPConnect); - procedure SetOnDisconnect(const Value: TOnTCPDisconnect); - procedure SetOnError(const Value: TOnTCPError); - procedure SetOnReceive(const Value: TOnTCPReceive); -// procedure SetOnResolve(const Value: TOnTCPResolve); - procedure SetPort(const Value: smallint); - procedure SetOnManualReceive(const Value: TOnTCPManualReceive); - procedure SetOnStreamReceive(const Value: TOnTCPStreamReceive); - procedure SetOnStreamSend(const Value: TOnTCPStreamSend); - protected - function AdditionalUnits: string; override; - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure AssignEvents( SL: TStringList; const AName: String ); override; - public - published - property Host:string read FHost write SetHost; - property Port:smallint read FPort write SetPort; - property OnDisconnect:TOnTCPDisconnect read FOnDisconnect write SetOnDisconnect; - property OnError:TOnTCPError read FOnError write SetOnError; - property OnReceive:TOnTCPReceive read FOnReceive write SetOnReceive; - property OnManualReceive:TOnTCPManualReceive read FOnManualReceive write SetOnManualReceive; - property OnStreamSend:TOnTCPStreamSend read FOnStreamSend write SetOnStreamSend; - property OnStreamReceive:TOnTCPStreamReceive read FOnStreamReceive write SetOnStreamReceive; - property OnConnect:TOnTCPConnect read FOnConnect write SetOnConnect; - end; - - TKOLTCPServer = class(TKOLObj) - private - FPort: smallint; - FOnClientError: TOnTCPError; - FOnAccept: TOnTCPAccept; - FOnError: TOnTCPError; - FOnConnect: TOnTCPConnect; - FOnClientReceive: TOnTCPReceive; - FOnClientConnect: TOnTCPClientConnect; - FOnClientDisconnect: TOnTCPDisconnect; - FOnClientManualReceive: TOnTCPManualReceive; - FOnClientStreamReceive: TOnTCPStreamReceive; - FOnClientStreamSend: TOnTCPStreamSend; - procedure SetOnAccept(const Value: TOnTCPAccept); - procedure SetOnError(const Value: TOnTCPError); - procedure SetPort(const Value: smallint); - procedure SetOnConnect(const Value: TOnTCPConnect); - procedure SetOnClientError(const Value: TOnTCPError); - procedure SetOnClientReceive(const Value: TOnTCPReceive); - procedure SetOnClientConnect(const Value: TOnTCPClientConnect); - procedure SetOnClientDisconnect(const Value: TOnTCPDisconnect); - procedure SetOnClientManualReceive(const Value: TOnTCPManualReceive); - procedure SetOnClientStreamReceive(const Value: TOnTCPStreamReceive); - procedure SetOnClientStreamSend(const Value: TOnTCPStreamSend); - protected - function AdditionalUnits: string; override; - procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure SetupLast( SL: TStringList; const AName, AParent, Prefix: String ); override; - procedure AssignEvents( SL: TStringList; const AName: String ); override; - public - published - property Port:smallint read FPort write SetPort; - property OnAccept:TOnTCPAccept read FOnAccept write SetOnAccept; - property OnError:TOnTCPError read FOnError write SetOnError; - property OnConnect:TOnTCPConnect read FOnConnect write SetOnConnect; - property OnClientError:TOnTCPError read FOnClientError write SetOnClientError; - property OnClientReceive:TOnTCPReceive read FOnClientReceive write SetOnClientReceive; - property OnClientManualReceive:TOnTCPManualReceive read FOnClientManualReceive write SetOnClientManualReceive; - property OnClientConnect:TOnTCPClientConnect read FOnClientConnect write SetOnClientConnect; - property OnClientDisconnect:TOnTCPDisconnect read FOnClientDisconnect write SetOnClientDisconnect; - property OnClientStreamSend:TOnTCPStreamSend read FOnClientStreamSend write SetOnClientStreamSend; - property OnClientStreamReceive:TOnTCPStreamReceive read FOnClientStreamReceive write SetOnClientStreamReceive; - end; - - procedure Register; - -implementation - -{$R *.dcr} - -procedure Register; -begin - RegisterComponents('KOLAddons', [TKOLTCPClient,TKOLTCPServer]); -end; - -{ TKOLTCPClient } - -function TKOLTCPClient.AdditionalUnits; -begin - result:=', kolTCPSocket'; -end; - -procedure TKOLTCPClient.SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); -begin - sl.add(prefix+aname+':=newtcpclient;'); - sl.add(prefix+aname+'.port:='+inttostr(fport)+';'); - sl.add(prefix+aname+'.host:='#39+fhost+#39';'); -end; - -procedure TKOLTCPClient.SetupLast(SL: TStringList; const AName, AParent, Prefix: String); -begin - // -end; - -procedure TKOLTCPClient.AssignEvents(SL: TStringList; const AName: String); -begin - inherited; - doassignevents(sl,aname, - ['OnConnect','OnDisconnect','OnError','OnReceive','OnManualReceive', - 'OnStreamSend','OnStreamReceive'], - [@OnConnect,@OnDisconnect,@OnError,@OnReceive,@OnManualReceive, - @OnStreamSend,@OnStreamReceive]); -end; - -procedure TKOLTCPClient.SetHost(const Value: string); -begin - FHost := Value; - change; -end; - -procedure TKOLTCPClient.SetOnConnect(const Value: TOnTCPConnect); -begin - FOnConnect := Value; - change; -end; - -procedure TKOLTCPClient.SetOnDisconnect(const Value: TOnTCPDisconnect); -begin - FOnDisconnect := Value; - change; -end; - -procedure TKOLTCPClient.SetOnError(const Value: TOnTCPError); -begin - FOnError := Value; - change; -end; - -procedure TKOLTCPClient.SetOnReceive(const Value: TOnTCPReceive); -begin - FOnReceive := Value; - change; -end; - -{procedure TKOLTCPClient.SetOnResolve(const Value: TOnTCPResolve); -begin - FOnResolve := Value; - change; -end; -} -procedure TKOLTCPClient.SetPort(const Value: smallint); -begin - FPort := Value; - change; -end; - -procedure TKOLTCPClient.SetOnManualReceive( const Value: TOnTCPManualReceive); -begin - FOnManualReceive := Value; - change; -end; - -procedure TKOLTCPClient.SetOnStreamReceive(const Value: TOnTCPStreamReceive); -begin - FOnStreamReceive := Value; - change; -end; - -procedure TKOLTCPClient.SetOnStreamSend(const Value: TOnTCPStreamSend); -begin - FOnStreamSend := Value; - change; -end; - -{ TKOLTCPServer } - -function TKOLTCPServer.AdditionalUnits: string; -begin - result:=', kolTCPSocket'; -end; - -procedure TKOLTCPServer.AssignEvents(SL: TStringList; - const AName: String); -begin - inherited; - doassignevents(sl,aname, - ['OnConnect','OnAccept','OnError','OnClientError','OnClientConnect','OnClientDisconnect','OnClientReceive', - 'OnClientManualReceive','OnClientStreamSend','OnClientStreamReceive'], - [@OnConnect,@OnAccept,@OnError,@OnClientError,@OnClientConnect,@OnClientDisconnect,@OnClientReceive, - @OnClientManualReceive,@OnClientStreamSend,@OnClientStreamReceive]); -end; - -procedure TKOLTCPServer.SetOnConnect(const Value: TOnTCPConnect); -begin - FOnConnect := Value; - change; -end; - -procedure TKOLTCPServer.SetOnAccept(const Value: TOnTCPAccept); -begin - FOnAccept := Value; - change; -end; - -procedure TKOLTCPServer.SetOnClientConnect( const Value: TOnTCPClientConnect); -begin - FOnClientConnect := Value; - change; -end; - -procedure TKOLTCPServer.SetOnClientDisconnect( const Value: TOnTCPDisconnect); -begin - FOnClientDisconnect := Value; - change; -end; - -procedure TKOLTCPServer.SetOnClientError(const Value: TOnTCPError); -begin - FOnClientError := Value; - change; -end; - -procedure TKOLTCPServer.SetOnClientManualReceive( const Value: TOnTCPManualReceive); -begin - FOnClientManualReceive := Value; - change; -end; - -procedure TKOLTCPServer.SetOnClientReceive(const Value: TOnTCPReceive); -begin - FOnClientReceive := Value; - change; -end; - -procedure TKOLTCPServer.SetOnClientStreamReceive( const Value: TOnTCPStreamReceive); -begin - FOnClientStreamReceive := Value; - change; -end; - -procedure TKOLTCPServer.SetOnClientStreamSend( const Value: TOnTCPStreamSend); -begin - FOnClientStreamSend := Value; - change; -end; - -procedure TKOLTCPServer.SetOnError(const Value: TOnTCPError); -begin - FOnError := Value; - change; -end; - -procedure TKOLTCPServer.SetPort(const Value: smallint); -begin - FPort := Value; - change; -end; - -procedure TKOLTCPServer.SetupFirst(SL: TStringList; const AName, AParent, Prefix: String); -begin - sl.add(prefix+aname+':=newtcpserver;'); - sl.add(prefix+aname+'.port:='+inttostr(fport)+';'); -end; - -procedure TKOLTCPServer.SetupLast(SL: TStringList; const AName, AParent, Prefix: String); -begin -// -end; - -end. - diff --git a/Addons/richprint.pas b/Addons/richprint.pas deleted file mode 100644 index 78878d2..0000000 --- a/Addons/richprint.pas +++ /dev/null @@ -1,202 +0,0 @@ -unit RichPrint; -{* By Savva. A unit to print rich edit control content. } - -interface - -uses Windows, KOL, {$IFNDEF NOT_USE_PRINTER_OBJ} - {$IFDEF USE_MHPRINTER} KOLMHPrinters {$ELSE} KOLPrinters {$ENDIF} - ,{$ENDIF} - RichEdit, CommDlg; - -procedure FilePrint(ACaption : string;fRichEdit : PControl); -{* печать без использования объекта Printer } - -{$IFNDEF NOT_USE_PRINTER_OBJ} -procedure PrintRichEdit(CONST fRichEdit : PControl;const Caption: string); -{* печать c использованием объекта Printer } -{$ENDIF} - -implementation - -//***************************************************** -// печать без использования объекта Printer -// ----------------------------------------------------- -// Функция FilePrint -// ----------------------------------------------------- -procedure FilePrint(ACaption : string;fRichEdit : PControl); -var - fr : FORMATRANGE; - docInfo : TDOCINFO; - lLastChar, lTextSize :integer ; - pd : TPRINTDLG ; - nRc : integer ; - hPrintDC : HDC ; - - szErr : string; - dwErr :DWORD ; - //TextLenEx: TGetTextLengthEx; - -begin - // Инициализируем поля структуры PRITDLG - - ZeroMemory(@pd, sizeof(pd)); - pd.lStructSize := sizeof(TPRINTDLG); - pd.hwndOwner := fRichEdit.Handle; - pd.hInstance := HInstance; - pd.Flags := PD_RETURNDC or PD_NOPAGENUMS or PD_NOSELECTION or PD_PRINTSETUP or -PD_ALLPAGES; - pd.nFromPage := $ffff; - pd.nToPage := $ffff; - pd.nMinPage := 0; - pd.nMaxPage := $ffff; - pd.nCopies := 1; - - - // Выводим на экран диалоговую панель, предназначенную - // для печати документа - if PrintDlg(pd) then begin -// if(TRUE) then begin - hPrintDC := pd.hDC; - - // Инициализируем поля структуры FORMATRANGE - ZeroMemory(@fr, sizeof(fr)); - - // Будем печатать с использованием контекста - // принтера, полученного от функции PrintDlg - fr.hdc := hPrintDC; - fr.hdcTarget:=fr.hdc; - - // Печатаем весь документ - fr.chrg.cpMin := 0; - fr.chrg.cpMax := -1; - - // Устанавливаем размеры страницы в TWIPS-ах - fr.rcPage.top := 0; - fr.rcPage.left := 0; - fr.rcPage.right := - MulDiv(GetDeviceCaps(hPrintDC, PHYSICALWIDTH), - 1440, GetDeviceCaps(hPrintDC, LOGPIXELSX)); - - fr.rcPage.bottom := MulDiv(GetDeviceCaps(hPrintDC, - PHYSICALHEIGHT),1440, - GetDeviceCaps(hPrintDC, LOGPIXELSY)); - fr.rc := fr.rcPage; - - // Оставляем поля - if (fr.rcPage.right > 2*3*1440/4+1440) then begin - fr.rc.left := 3*1440 div 4; - fr.rc.right :=fr.rc.right - (fr.rc.left); - end; - if(fr.rcPage.bottom > 3*1440) then begin - fr.rc.top := 1440; - fr.rc.bottom:=fr.rc.bottom - (fr.rc.top); - end; - - // Заполняем поля структуры DOCINFO - ZeroMemory(@docInfo, sizeof(DOCINFO)); - docInfo.cbSize := sizeof(DOCINFO); - docInfo.lpszOutput := nil; - docInfo.lpszDocName := PChar(ACaption); - - - // Начинаем печать документа - nRc := StartDoc(hPrintDC, docInfo); - - // Если произошла ошибка, получаем и выводим на экран - // код ошибки - if (nRc < 0) then begin - dwErr := GetLastError(); - - szErr:=format( 'Print Error %ld \r\n %s', [dwErr,SysErrorMessage(dwErr)]); - - MessageBox(0, PChar(szErr), - 'Error printing', MB_OK or MB_ICONEXCLAMATION); - - DeleteDC(hPrintDC); - exit; - end; - - // Начинаем печать страницы - StartPage(hPrintDC); - - lLastChar := 0; - - // Определяем длину текста - lTextSize := fRichEdit.RE_TextSizePrecise; - // Цикл по всем страницам документа - while (lLastChar < lTextSize) do begin - // Форматируем данные для принтера и печатаем их - lLastChar := SendMessage(fRichEdit.Handle, EM_FORMATRANGE, DWORD(TRUE), - LPARAM( @fr)); - - if(lLastChar < lTextSize) then begin - // Завершаем печать очередной страницы - EndPage(hPrintDC); - - // Начинаем новую страницу - StartPage(hPrintDC); - fr.chrg.cpMin := lLastChar; - fr.chrg.cpMax := -1; - end; - end; - - // Удаляем информацию, которая хранится в - // органе управления Rich Edit - SendMessage(fRichEdit.Handle, EM_FORMATRANGE, DWORD(TRUE), LPARAM(nil)); - - // Завершаем печать страницы - EndPage(hPrintDC); - - // Завершаем печать документа - EndDoc(hPrintDC); - - // Удаляем контекст принтера - DeleteDC(hPrintDC); - end; -end; - -{$IFNDEF NOT_USE_PRINTER_OBJ} -//***************************************************** -// печать c использованием объекта Printer -procedure PrintRichEdit(CONST fRichEdit : PControl;const Caption: string); -var - Range: TFormatRange; - LastChar, MaxLen, LogX, LogY, OldMap: Integer; - SaveRect: TRect; -begin - FillChar(Range, SizeOf(TFormatRange), 0); - Printer.Title := Caption; - Printer.BeginDoc; - Range.hdc := Printer.Handle; - Range.hdcTarget := Range.hdc; - LogX := GetDeviceCaps(Printer.Handle, LOGPIXELSX); - LogY := GetDeviceCaps(Printer.Handle, LOGPIXELSY); - - Range.rc.right := Printer.PageWidth * 1440 div LogX; - Range.rc.bottom := Printer.PageHeight * 1440 div LogY; - Range.rcPage := Range.rc; - SaveRect := Range.rc; - LastChar := 0; -// MaxLen := fRichEdit.Perform(WM_GETTEXTLENGTH, 0, 0); - MaxLen := fRichEdit.RE_TextSizePrecise; - Range.chrg.cpMax := -1; - // ensure printer DC is in text map mode - OldMap := SetMapMode(range.hdc, MM_TEXT); - fRichEdit.Perform(EM_FORMATRANGE, 0, 0); // flush buffer - try - repeat - Range.rc := SaveRect; - Range.chrg.cpMin := LastChar; - LastChar := fRichEdit.Perform(EM_FORMATRANGE, 1, Longint(@Range)); - if (LastChar < MaxLen) and (LastChar <> -1) then Printer.NewPage; - until (LastChar >= MaxLen) or (LastChar = -1); - Printer.EndDoc; - finally - fRichEdit.Perform(EM_FORMATRANGE, 0, 0); // flush buffer - SetMapMode(Range.hdc, OldMap); // restore previous map mode - end; -end; -{$ENDIF} - - -end.