自创改编小控件，不是一个哟！！
仔细看一下，你一定会喜欢的！
unit tcpip;
(*@/// interface *)
interface
(*$x+ *)
(*@/// uses *)
uses
sysutils,
classes,
controls,
forms,
winsock,
(*$ifdef ver80 *)
winprocs,
wintypes,
(*$else *)
windows,
(*$endif *)
messages,
ip_misc;
(*@\\\*)
type
t_socket_state = (invalid,valid,connected,state_unknown);
t_timemode = (tzUTC,tzLocal);
t_ftp_mode = (tftp_download,tftp_upload,tftp_getdir);
t_filetype = (ft_none, ft_dir, ft_file, ft_link);
t_lpr_types = (lp_plain, lp_ascii, lp_dvi, lp_plot, lp_ditroff, lp_ps,
lp_pr, lp_fortran, lp_troff, lp_raster, lp_cif);
t_encoding = (ec_base64, ec_quotedprintable, ec_none);
TTraceLevel = (tt_proto_sent, tt_proto_get, tt_socket);
(*@/// t_filedata=record ... end; *)
t_filedata=packed record
filetype: t_filetype;
size: integer;
name: string;
datetime: TDateTime;
end;
(*@\\\*)
ETcpIpError=class(Exception);
(*@/// ESocketError=class(ETcpIpError) *)
ESocketError=class(ETcpIpError)
errornumber: word;
constructor Create(number:word);
end;
(*@\\\0000000301*)
(*@/// EProtocolError=class(ETcpIpError) *)
EProtocolError=class(ETcpIpError)
errornumber: word;
protocoll: string;
constructor Create(const proto,Msg:String; number:word);
end;
(*@\\\0000000401*)
(*@/// EProtocolBusy=class(ETcpIpError) *)
EProtocolBusy=class(ETcpIpError)
constructor Create;
end;
(*@\\\0000000201*)
TTraceProc = procedure (const s:string; level:TTraceLevel) of object;
TDataTransferProc = procedure (Sender:TObject; mode: t_ftp_mode; bytes: integer) of object;
TFTPActionCompleteProc = procedure (Sender:TObject; mode: t_ftp_mode) of object;
{ The base component }
(*@/// T_TcpIp = class(TComponent) *)
T_TcpIp = class(TComponent)
protected
f_handle: THandle;
f_Socket: tsocket;
f_hostname: string;
f_tracer: TTraceProc;
f_socket_number: smallint;
ip_address: longint; (* Network order! *)
f_eof: boolean;
f_newdata: boolean;
f_stream: TStream;
f_buffer: pointer;
f_async: boolean;
f_logged_in: boolean;
procedure WndProc(var Msg : TMessage); virtual;
function Create_Socket:TSocket;
procedure connect_socket(var socket:TSocket; Socket_number:smallint;ip_address:longint);
procedure bind_socket(var socket:TSocket; out_port_min,out_port_max: word);
procedure open_socket_out(var socket:TSocket; Socket_number:smallint;ip_address:longint); virtual;
procedure open_socket_in(var socket:TSocket; Socket_number:smallint;ip_address:longint);
procedure close_socket(var socket:TSocket);
procedure close_socket_linger(var socket:TSocket);
function accept_socket_in(socket:TSocket; var SockInfo:TSockAddr):TSocket;
function socket_state(socket:TSocket):T_Socket_State;
function Socket_by_name(const service:string):smallint;
function read_line(f_socket:TSocket):string;
procedure read_var(f_socket:TSocket; var buf; size:integer; var _ok:integer);
procedure write_buf(f_socket:TSocket; const buf; size:integer);
procedure write_s(f_socket:TSocket; const s:string);
procedure SetStream(value:TStream); (* for the property write of f_stream *)
procedure action; VIRTUAL;
{ property Async:boolean read f_async write f_async default false; }
procedure SendCommand(const s:string); VIRTUAL;
public
procedure Login; virtual;
procedure Logout; virtual;
property OnTrace:TTraceProc read f_tracer write f_tracer;
constructor Create(Aowner:TComponent); override;
destructor Destroy; override;
function eof(f_socket:TSocket):boolean; VIRTUAL;
end;
(*@\\\0000002901*)
{ Finger client and demon // RFC 1288 }
(*@/// T_Finger = class(T_TcpIp) *)
T_Finger = class(T_TcpIp)
protected
f_user: string;
public
constructor Create(Aowner:TComponent); override;
property stream: TStream read f_stream;
procedure action; override;
published
property Hostname: string read f_hostname write f_hostname;
property User: string read f_user write f_user;
end;
(*@\\\0000000118*)
(*@/// T_Fingerd = class(T_TcpIp) *)
type
(*@/// TFingerInfo=record *)
TFingerInfo=record
hostname: string;
address: longint;
request: string;
end;
(*@\\\0000000203*)
TFingerRequest=procedure (Sender:TObject; FingerInfo:TFingerInfo) of object;
T_Fingerd = class(T_TcpIp)
protected
f_fingerrequest: TFingerRequest;
f_answer: TStringList;
procedure WndProc(var Msg : TMessage); override;
procedure SetAnswer(Value: TStringList);
procedure do_action; virtual; (* The real action *)
public
constructor Create(Aowner:TComponent); override;
destructor Destroy; override;
procedure action; override; (* Only to set up *)
published
property OnFingerRequest:TFingerRequest read f_fingerrequest write f_fingerrequest;
property Answer: TStringList read f_answer write SetAnswer;
end;
(*@\\\0000000503*)
{ HTTP and FTP - the file transfer protocols }
(*@/// T_HTTP = class(T_TcpIp) // RFC 1945 (V1.0), RFC 2068 (V1.1) *)
T_HTTP = class(T_TcpIp)
protected
f_url: string;
f_path: string; (* The real request string, calculated internally *)
f_proxy: string;
f_sender: string;
f_reference: string;
f_agent: string;
f_nocache: boolean;
f_status_nr: integer;
f_status_txt: string;
f_size: integer;
f_type: string;
f_author: string;
f_do_author: TStringList;
f_content_post: string;
procedure GetHead;
procedure GetBody;
procedure sendrequest(const method,version: string);
procedure getanswer;
public
property stream: TStream read f_stream write SetStream;
property content_size: integer read f_size;
property content_type: string read f_type;
property status_number: integer read f_status_nr;
property status_text: string read f_status_txt;
procedure action; override; (* the GET method *)
procedure Post; (* the POST method, untested! *)
constructor Create(Aowner:TComponent); override;
destructor Destroy; override;
procedure DoBasicAuthorization(const username,password:string);
property AuthorizationRequest: TStringList read f_do_author;
property Authorization: string read f_author write f_author;
published
property URL: string read f_url write f_url;
property Proxy: string read f_proxy write f_proxy;
property Sender: string read f_sender write f_sender;
property Agent: string read f_agent write f_agent;
property Reference: string read f_reference write f_reference;
property NoCache: boolean read f_nocache write f_nocache;
property ContentTypePost: string read f_content_post write f_content_post;
property OnTrace;
end;
(*@\\\0000000C01*)
(*@/// T_FTP = class(T_TcpIp) // RFC 959 *)
T_FTP = class(T_TcpIp)
protected
f_url: string;
f_status_nr: integer;
f_status_txt: string;
f_user: string;
f_password: string;
f_comm_socket: tsocket;
f_passive: boolean;
f_port: word;
f_mode: t_ftp_mode;
f_mode_intern: t_ftp_mode;
f_cur_dir: TStringList;
f_cur_dir_index: integer;
f_size: integer;
f_busy: boolean;
f_onaction: TFTPActionCompleteProc;
f_ondata_got: TDataTransferProc;
f_dir_stream: TMemoryStream;
f_async_data: boolean;
procedure response;
function read_line_comm:string;
procedure SendCommand(const s:string); override;
procedure get_datasocket;
procedure WndProc(var Msg : TMessage); override;
function do_write:boolean;
function do_read:boolean;
procedure finish_upload;
procedure finish_download;
procedure finish_getdir;
public (* will become public once tested *)
procedure changedir(const f_dir:string);
procedure removefile(const filename:string);
procedure removedir(const dirname:string);
procedure makedir(const dirname:string);
procedure renamefile(const prior,after:string);
procedure getdir(const dirname:string);
function getdirentry:t_filedata;
public
property stream: TStream read f_stream write SetStream;
property status_number: integer read f_status_nr;
property status_text: string read f_status_txt;
property busy: boolean read f_busy;
procedure login; override;
procedure logout; override;
procedure download;
procedure upload;
procedure abort;
procedure noop;
constructor Create(Aowner:TComponent); override;
destructor Destroy; override;
procedure action; override;
property Size:integer read f_size;
published
property Hostname: string read f_hostname write f_hostname;
property URI: string read f_url write f_url;
property Password:string read f_password write f_password;
property Username:string read f_user write f_user;
property Passive:boolean read f_passive write f_passive default true;
property Port:word read f_port write f_port default 21;
property Mode:t_ftp_mode read f_mode write f_mode default tftp_download;
property OnDataReceived:TDataTransferProc read f_ondata_got write f_ondata_got;
property OnActionComplete:TFTPActionCompleteProc read f_onaction write f_onaction;
property Async:boolean read f_async_data write f_async_data;
property OnTrace;
end;
(*@\\\0000003501*)
{ Time, RExec, LPR - the most useful UNIX services }
(*@/// T_Time = class(T_TcpIp) // RFC 868 *)
T_Time = class(T_TcpIp)
protected
f_time: TDateTime;
f_timemode: T_TimeMode;
public
constructor Create(Aowner:TComponent); override;
procedure action; override;
property time: TDateTime read f_time;
published
property Hostname: string read f_hostname write f_hostname;
property TimeMode: T_TimeMode read f_timemode write f_timemode default tzUTC;
end;
(*@\\\0000000103*)
(*@/// T_RCommon = class(T_TcpIp) *)
T_RCommon = class(T_TcpIp)
protected
procedure open_socket_out(var socket:TSocket; Socket_number:smallint;ip_address:longint); override;
public
procedure action; override;
property stream: TStream read f_stream;
published
property Hostname: string read f_hostname write f_hostname;
end;
(*@\\\0000000103*)
(*@/// T_RExec = class(T_RCommon) *)
T_RExec = class(T_RCommon)
protected
f_user: string;
f_pass: string;
f_command: string;
procedure login; override;
public
constructor Create(Aowner:TComponent); override;
published
property UserName: string read f_user write f_user;
property Password: string read f_pass write f_pass;
property Command: string read f_command write f_command;
end;
(*@\\\0000000113*)
(*@/// T_Rsh = class(T_RCommon) *)
T_Rsh = class(T_RCommon)
protected
f_user_r: string;
f_user_l: string;
f_command: string;
procedure login; override;
public
constructor Create(Aowner:TComponent); override;
published
property LocalUser: string read f_user_l write f_user_l;
property RemoteUser: string read f_user_r write f_user_r;
property Command: string read f_command write f_command;
end;
(*@\\\0000000111*)
(*@/// T_lpr = class(T_TcpIp) // RFC 1179 *)
T_lpr = class(T_TcpIp)
protected
f_printtype: t_lpr_types;
f_banner: boolean;
f_count: integer;
f_user: string;
f_queue: string;
f_user_mail: string;
f_jobname: string;
f_title: string;
procedure response;
procedure open_socket_out(var socket:TSocket; Socket_number:smallint;ip_address:longint); override;
public
constructor Create(Aowner:TComponent); override;
property stream: TStream read f_stream write SetStream;
procedure action; override;
procedure SendPrintData;
procedure GetQueueStatus(detailed:boolean);
published
property Hostname: string read f_hostname write f_hostname;
property User: string read f_user write f_user;
property PrintQueue: string read f_queue write f_queue;
property MailTo: string read f_user_mail write f_user_mail;
property JobName: string read f_jobname write f_jobname;
property PrintType:t_lpr_types read f_printtype write f_printtype default lp_ascii;
property CopyCount:integer read f_count write f_count default 1;
property PrintBanner:boolean read f_banner write f_banner default false;
property PrintTitle:string read f_title write f_title;
end;
(*@\\\0000000103*)
{ The Mail and News protocols }
(*@/// T_SMTP = class(T_TcpIp) // RFC 821 *)
T_SMTP = class(T_TcpIp)
protected
f_user, f_host: string;
f_status_nr: integer;
f_status_txt: string;
f_receipts, f_body: tstringlist;
procedure SetBody(Value: TStringList);
procedure SetRecipients(Value: TStringList);
procedure response;
public
constructor Create(Aowner:TComponent); override;
destructor Destroy; override;
procedure action; override;
property Recipients: TStringlist read f_receipts write SetRecipients;
property Message: TStringList read f_body write SetBody;
property Sender: string read f_user write f_user;
published
property Hostname: string read f_hostname write f_hostname;
property OnTrace;
end;
(*@\\\0000001001*)
(*@/// T_Pop3 = class(T_TcpIp) // RFC 1725 *)
T_Pop3 = class(T_TcpIp)
protected
f_user: string;
f_pass: string;
f_list: TList;
f_mail: TStringList;
procedure response;
public
property Mail: TStringlist read f_mail;
constructor Create(Aowner:TComponent); override;
destructor Destroy; override;
procedure action; override; (* retrieval of first message *)
procedure Login; override;
procedure GetHeaders;
procedure Logout; override;
procedure GetMail(index: integer);
procedure DeleteMail(index:integer);
published
property Hostname: string read f_hostname write f_hostname;
property UserName: string read f_user write f_user;
property Password: string read f_pass write f_pass;
property OnTrace;
end;
(*@\\\0000001701*)
(*@/// T_NNTP = class(T_TcpIp) // RFC 977 *)
T_NNTP = class(T_TcpIp)
protected
f_news: TStringList;
f_newsgroups: TStringList;
f_status_nr: integer;
f_status_txt: string;
procedure response;
procedure action; override; (* ??? *)
procedure SetNews(value:TStringlist);
procedure GetArticleInternally;
public
property News: TStringlist read f_news write SetNews;
property NewsGroups: TStringlist read f_newsgroups;
constructor Create(Aowner:TComponent); override;
destructor Destroy; override;
procedure Login; override;
procedure Logout; override;
(* To get an article from a URL like nntp://hostname/number *)
procedure GetArticle(const group:string; index:integer);
(* To get an article from a URL like news:msgid *)
procedure GetArticleID(const msgid:string);
procedure PostArticle;
(* Methods more for a Newsreader *)
procedure GetAllNewsgroups;
procedure GetNewNewsgroups(since:TDateTime);
procedure SetGroup(const group:string; var low,high,count: integer);
procedure GetArticleNr(index:integer);
procedure SetCurrentArticle(index:integer);
procedure GetCurrentArticle;
procedure GetNextArticle;
procedure GetPreviousArticle;
published
property Hostname: string read f_hostname write f_hostname;
property OnTrace;
end;
(*@\\\0000002301*)
{ Mail and News text components }
(*@/// T_MailNews = class(TComponent) *)
T_MailNews = class(TComponent)
protected
f_from, f_sender, f_subject: string;
f_body: TStringlist;
f_add_header: TStringlist;
f_message: TStringlist;
f_references: string;
f_replyto: string;
procedure SetBody(Value: TStringList);
procedure SetHeader(Value: TStringList);
public
constructor Create(Aowner:TComponent); override;
destructor Destroy; override;
procedure action; VIRTUAL;
published
property Sender: string read f_sender write f_sender;
property From: string read f_from write f_from;
property Body: TStringList read f_body write SetBody;
property Header: TStringList read f_add_header write SetHeader;
property Subject:string read f_subject write f_subject;
property References:string read f_references write f_references;
property ReplyTo:string read f_replyto write f_replyto;
end;
(*@\\\0000001001*)
(*@/// T_Mail = class(T_MailNews) // RFC 822 *)
T_Mail = class(T_MailNews)
protected
f_smtp: T_SMTP;
f_receipts: TStringlist;
f_cc: TStringlist;
f_bcc: TStringlist;
f_disclose_receipts: boolean;
procedure SetRecipients(Value: TStringList);
procedure SetCC(Value: TStringList);
procedure SetBCC(Value: TStringList);
public
constructor Create(Aowner:TComponent); override;
destructor Destroy; override;
procedure action; override;
published
property SMTP: T_SMTP read f_smtp write f_smtp;
property Disclose_Receipts: boolean read f_disclose_receipts write f_disclose_receipts default false;
property Recipients: TStringlist read f_receipts write SetRecipients;
property CC: TStringlist read f_cc write SetCC;
property BCC: TStringlist read f_bcc write SetBCC;
end;
(*@\\\0000000601*)
(*@/// T_News = class(T_MailNews) // RFC 850 *)
T_News = class(T_MailNews)
protected
f_nntp: T_NNTP;
f_newsgroups: TStringlist;
f_organization: string;
procedure SetNewsgroups(Value: TStringList);
public
constructor Create(Aowner:TComponent); override;
destructor Destroy; override;
procedure action; override;
published
property NNTP: T_NNTP read f_nntp write f_nntp;
property Newsgroups: TStringlist read f_newsgroups write SetNewsgroups;
property Organization: string read f_organization write f_organization;
end;
(*@\\\0000000C14*)
(*@/// T_Attachment = class(TObject) *)
T_Attachment = class(TObject)
protected
f_kind: string;
f_disposition: string;
f_data: TStream;
f_text: TStringList;
f_encoding: T_Encoding;
procedure SetText(value:TStringList);
procedure SetData(value:TStream);
public
constructor Create;
destructor Destroy; override;
property Kind: string read f_kind write f_kind;
property Disposition: string read f_disposition write f_disposition;
property Encoding: T_Encoding read f_encoding write f_encoding;
property Text:TStringlist read f_text write SetText;
property Data:TStream read f_data write SetData;
end;
(*@\\\0000000D01*)
(*@/// T_Mime = class(TComponent) // RFC 1521 *)
T_Mime = class(TComponent)
protected
f_mail: T_MailNews;
boundary: string;
f_attachment: TList;
function GetNumberOfAttachments: integer;
public
constructor Create(Aowner:TComponent); override;
destructor Destroy; override;
function AttachFile(const filename:string):integer;
function AttachText(text: TStringList):integer;
procedure RemoveAllAttachments;
procedure action;
procedure SetMail(mail: TStringlist);
function GetAttachment(index: integer):T_Attachment;
procedure RemoveAttachment(index: integer);
property Attachment[index:integer]:T_Attachment read GetAttachment;
property NumberOfAttachments: integer read GetNumberOfAttachments;
published
property Mail: T_MailNews read f_mail write f_mail;
end;
(*@\\\0000000A01*)
const
uwm_socketevent = wm_user+$100; (* my magic message number *)
var
lpr_count: integer; (* the current job number *)
procedure Register;
(*@\\\0000003B03*)
(*@/// implementation *)
implementation
本文地址：http://com.8s8s.com/it/it5972.htm