BackBtn.Click;
end;
procedure TMainForm.Toolbar3Click(Sender: TObject);
begin
with Sender as TMenuItem do
begin
Checked := not Checked;
Coolbar1.Visible := Checked;
end;
end;
procedure TMainForm.Statusbar2Click(Sender: TObject);
begin
with Sender as TMenuItem do
begin
Checked := not Checked;
StatusBar1.Visible := Checked;
end;
end;
procedure TMainForm.HomePageRequest(var Message: TMessage);
begin
URLs.Text := 'http://www.altavista.com';
UpdateCombo := True;
FindAddress;
end;
procedure TMainForm.FormCreate(Sender: TObject);
begin
HistoryIndex := -1;
HistoryList := TStringList.Create;
{ Load the animation from the AVI file in the startup directory. An
alternative to this would be to create a .RES file including the cool.avi
as an AVI resource and use the ResName or ResId properties of Animate1 to
point to it. }
Animate1.FileName := ExtractFilePath(Application.ExeName) + 'cool.avi';
{ Find the home page - needs to be posted because HTML control hasn't been
registered yet. }
PostMessage(Handle, CM_HOMEPAGEREQUEST, 0, 0);
end;
procedure TMainForm.FormDestroy(Sender: TObject);
begin
HistoryList.Free;
end;
procedure TMainForm.ToolButton2Click(Sender: TObject);
begin
TMail.create(Application).showmodal;
end;
procedure TMainForm.ToolButton3Click(Sender: TObject);
begin
TMyFtp.create(Application).showmodal;
end;
procedure TMainForm.ToolButton4Click(Sender: TObject);
begin
TNewsForm.create(Application).showmodal;
end;
procedure TMainForm.ToolButton9Click(Sender: TObject);
begin
TChatForm.create(Application).showmodal;
end;
end.
файл chat.pas
unit chat;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Menus, StdCtrls, Buttons, ScktComp, ExtCtrls, ComCtrls;
type
TChatForm = class(TForm)
MainMenu1: TMainMenu;
File1: TMenuItem;
Exit1: TMenuItem;
FileConnectItem: TMenuItem;
FileListenItem: TMenuItem;
StatusBar1: TStatusBar;
Bevel1: TBevel;
Panel1: TPanel;
Memo1: TMemo;
Memo2: TMemo;
N1: TMenuItem;
SpeedButton1: TSpeedButton;
Disconnect1: TMenuItem;
ServerSocket: TServerSocket;
ClientSocket: TClientSocket;
procedure FileListenItemClick(Sender: TObject);
procedure FileConnectItemClick(Sender: TObject);
procedure Exit1Click(Sender: TObject);
procedure Memo1KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure FormCreate(Sender: TObject);
procedure ServerSocketError(Sender: TObject; Number: Smallint;
var Description: string; Scode: Integer; const Source,
HelpFile: string; HelpContext: Integer; var CancelDisplay: Wordbool);
procedure Disconnect1Click(Sender: TObject);
procedure ClientSocketConnect(Sender: TObject;
Socket: TCustomWinSocket);
procedure ClientSocketRead(Sender: TObject; Socket: TCustomWinSocket);
procedure ServerSocketClientRead(Sender: TObject;
Socket: TCustomWinSocket);
procedure ServerSocketAccept(Sender: TObject;
Socket: TCustomWinSocket);
procedure ServerSocketClientConnect(Sender: TObject;
Socket: TCustomWinSocket);
procedure ClientSocketDisconnect(Sender: TObject;
Socket: TCustomWinSocket);
procedure ClientSocketError(Sender: TObject; Socket: TCustomWinSocket;
ErrorEvent: TErrorEvent; var ErrorCode: Integer);
procedure ServerSocketClientDisconnect(Sender: TObject;
Socket: TCustomWinSocket);
protected
IsServer: Boolean;
end;
var
ChatForm: TChatForm;
Server: String;
implementation
{$R *.DFM}
procedure TChatForm.FileListenItemClick(Sender: TObject);
begin
FileListenItem.Checked := not FileListenItem.Checked;
if FileListenItem.Checked then
begin
ClientSocket.Active := False;
ServerSocket.Active := True;
Statusbar1.Panels[0].Text := 'Listening...'
end
else
begin
if ServerSocket.Active then
ServerSocket.Active := False;
Statusbar1.Panels[0].Text := '';
end;
end;
procedure TChatForm.FileConnectItemClick(Sender: TObject);
begin
if ClientSocket.Active then ClientSocket.Active := False;
if InputQuery('Computer to connect to', 'Address Name:', Server) then
if Length(Server) > 0 then
with ClientSocket do
begin
Host := Server;
Active := True;
end;
end;
procedure TChatForm.Exit1Click(Sender: TObject);
begin
ServerSocket.Close;
ClientSocket.Close;
Close;
end;
procedure TChatForm.Memo1KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if Key = VK_Return then
if IsServer then
ServerSocket.Socket.Connections[0].SendText(Memo1.Lines[Memo1.Lines.Count - 1])
else
ClientSocket.Socket.SendText(Memo1.Lines[Memo1.Lines.Count - 1]);
end;
procedure TChatForm.FormCreate(Sender: TObject);
begin
FileListenItemClick(nil);
end;
procedure TChatForm.ServerSocketError(Sender: TObject; Number: Smallint;
var Description: string; Scode: Integer; const Source, HelpFile: string;
HelpContext: Integer; var CancelDisplay: Wordbool);
begin
ShowMessage(Description);
end;
procedure TChatForm.Disconnect1Click(Sender: TObject);
begin
ClientSocket.Close;
FileListenItemClick(nil);
end;
procedure TChatForm.ClientSocketConnect(Sender: TObject;
Socket: TCustomWinSocket);
begin
Statusbar1.Panels[0].Text := 'Connected to: ' + Socket.RemoteHost;
end;
procedure TChatForm.ClientSocketRead(Sender: TObject;
Socket: TCustomWinSocket);
begin
Memo2.Lines.Add(Socket.ReceiveText);
end;
procedure TChatForm.ServerSocketClientRead(Sender: TObject;
Socket: TCustomWinSocket);
begin
Memo2.Lines.Add(Socket.ReceiveText);
end;
procedure TChatForm.ServerSocketAccept(Sender: TObject;
Socket: TCustomWinSocket);
begin
IsServer := True;
Statusbar1.Panels[0].Text := 'Connected to: ' + Socket.RemoteAddress;
end;
procedure TChatForm.ServerSocketClientConnect(Sender: TObject;
Socket: TCustomWinSocket);
begin
Memo2.Lines.Clear;
end;
procedure TChatForm.ClientSocketDisconnect(Sender: TObject;
Socket: TCustomWinSocket);
begin
FileListenItemClick(nil);
end;
procedure TChatForm.ClientSocketError(Sender: TObject;
Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
var ErrorCode: Integer);
begin
Memo2.Lines.Add('Error connecting to : ' + Server);
ErrorCode := 0;
end;
procedure TChatForm.ServerSocketClientDisconnect(Sender: TObject;
Socket: TCustomWinSocket);
begin
ServerSocket.Active := False;
FileListenItem.Checked := not FileListenItem.Checked;
FileListenItemClick(nil);
end;
end.
файл ftp.pas
unit ftp;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Buttons, StdCtrls, ComCtrls, OleCtrls, Menus, ExtCtrls, isp3;
const
FTPServer = 0;
Folder = 1;
OpenFolder = 2;
type
TMyFtp = class(TForm)
Bevel1: TBevel;
Panel1: TPanel;
Panel2: TPanel;
Panel3: TPanel;
StatusBar: TStatusBar;
FileList: TListView;
DirTree: TTreeView;
ConnectBtn: TSpeedButton;
FTP: TFTP;
RefreshBtn: TSpeedButton;
MainMenu1: TMainMenu;
FileMenu: TMenuItem;
FileNewItem: TMenuItem;
FileDeleteItem: TMenuItem;
FileRenameItem: TMenuItem;
N2: TMenuItem;
FileExitItem: TMenuItem;
View1: TMenuItem;
ViewLargeItem: TMenuItem;
ViewSmallItem: TMenuItem;
ViewListItem: TMenuItem;
ViewDetailsItem: TMenuItem;
N1: TMenuItem;
ViewRefreshItem: TMenuItem;
FilePopup: TPopupMenu;
DeleteItem: TMenuItem;
RenameItem: TMenuItem;
CopyItem: TMenuItem;
Bevel2: TBevel;
Label1: TLabel;
Bevel3: TBevel;
Bevel5: TBevel;
Label2: TLabel;
SaveDialog1: TSaveDialog;
CopyButton: TSpeedButton;
LargeBtn: TSpeedButton;
SmallBtn: TSpeedButton;
ListBtn: TSpeedButton;
DetailsBtn: TSpeedButton;
Tools1: TMenuItem;
ToolsConnectItem: TMenuItem;
ToolsDisconnectItem: TMenuItem;
FileCopyItem: TMenuItem;
PasteFromItem: TMenuItem;
OpenDialog1: TOpenDialog;
SmallImages: TImageList;
procedure ConnectBtnClick(Sender: TObject);
procedure FTPProtocolStateChanged(Sender: TObject;
ProtocolState: Smallint);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormCreate(Sender: TObject);
procedure FTPBusy(Sender: TObject; isBusy: Wordbool);
procedure DirTreeChange(Sender: TObject; Node: TTreeNode);
procedure RefreshBtnClick(Sender: TObject);
procedure DirTreeChanging(Sender: TObject; Node: TTreeNode;
var AllowChange: Boolean);
procedure FTPStateChanged(Sender: TObject; State: Smallint);
procedure Open1Click(Sender: TObject);
procedure FileExitItemClick(Sender: TObject);
procedure FormResize(Sender: TObject);
procedure ViewLargeItemClick(Sender: TObject);
procedure ViewSmallItemClick(Sender: TObject);
procedure ViewListItemClick(Sender: TObject);
procedure ViewDetailsItemClick(Sender: TObject);
procedure ViewRefreshItemClick(Sender: TObject);
procedure CopyItemClick(Sender: TObject);
procedure ToolsDisconnectItemClick(Sender: TObject);
procedure FileNewItemClick(Sender: TObject);
procedure DeleteItemClick(Sender: TObject);
procedure PasteFromItemClick(Sender: TObject);
procedure FilePopupPopup(Sender: TObject);
procedure FileMenuClick(Sender: TObject);
procedure FileDeleteItemClick(Sender: TObject);
procedure FTPListItem(Sender: TObject; const Item: FTPDirItem);
private
Root: TTreeNode;
function CreateItem(const FileName, Attributes, Size, Date: Variant): TListItem;
procedure Disconnect;
public
function NodePath(Node: TTreeNode): String;
end;
var
Myftp: TMyFtp;
UserName,
Pwd: String;
implementation
{$R *.DFM}
uses ShellAPI, UsrInfo;
function FixCase(Path: String): String;
var
OrdValue: byte;
begin
if Length(Path) = 0 then exit;
OrdValue := Ord(Path[1]);
if (OrdValue >= Ord('a')) and (OrdValue <= Ord('z')) then
Result := Path
else
begin
Result := AnsiLowerCaseFileName(Path);
Result[1] := UpCase(Result[1]);
end;
end;
procedure TMyFtp.ConnectBtnClick(Sender: TObject);
begin
if FTP.State = prcConnected then
Disconnect;
ConnectForm := TConnectForm.Create(Self);
try
if ConnectForm.ShowModal = mrOk then
with FTP, ConnectForm do
begin
UserName := UserNameEdit.Text;
Pwd := PasswordEdit.Text;
RemoteHost := RemoteHostEdit.Text;
RemotePort := StrToInt(RemotePortEdit.Text);
Connect(RemoteHost, RemotePort);
Root := DirTree.Items.AddChild(nil, RemoteHost);
Root.ImageIndex := FTPServer;
Root.SelectedIndex := FTPServer;
DirTree.Selected := Root;
end;
finally
ConnectForm.Free;
end;
end;
procedure TMyFtp.FTPProtocolStateChanged(Sender: TObject;
ProtocolState: Smallint);
begin
case ProtocolState of
ftpAuthentication: FTP.Authenticate(UserName, Pwd);
ftpTransaction: FTP.List('/');
end;
end;
procedure TMyFtp.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if FTP.Busy then
begin
FTP.Cancel;
FTP.Quit;
while FTP.Busy do
Application.ProcessMessages;
end;
end;
function TMyFtp.CreateItem(const FileName, Attributes, Size, Date: Variant): TListItem;
var
Ext: String;
ShFileInfo: TSHFILEINFO;
begin
Result := FileList.Items.Add;
with Result do
begin
Caption := FixCase(Trim(FileName));
if Size > 0 then
begin
if Size div 1024 <> 0 then
begin
SubItems.Add(IntToStr(Size div 1024));
SubItems[0] := SubItems[0] + 'KB';
end
else
SubItems.Add(Size);
end
else
SubItems.Add('');
if Attributes = '1' then
begin
SubItems.Add('File Folder');
ImageIndex := 3;
end
else
begin
Ext := ExtractFileExt(FileName);
ShGetFileInfo(PChar('c:\*' + Ext), 0, SHFileInfo, SizeOf(SHFileInfo),
SHGFI_SMALLICON or SHGFI_SYSICONINDEX or SHGFI_TYPENAME);
if Length(SHFileInfo.szTypeName) = 0 then
begin
if Length(Ext) > 0 then
begin
System.Delete(Ext, 1, 1);
SubItems.Add(Ext + ' File');
end
else
SubItems.Add('File');
end
else
SubItems.Add(SHFileInfo.szTypeName);
ImageIndex := SHFileInfo.iIcon;
end;
SubItems.Add(Date);
end;
end;
procedure TMyFtp.Disconnect;
begin
FTP.Quit;
Application.ProcessMessages;
end;
procedure TMyFtp.FormCreate(Sender: TObject);
var
SHFileInfo: TSHFileInfo;
begin
with DirTree do
begin
DirTree.Images := SmallImages;
SmallImages.ResourceLoad(rtBitmap, 'IMAGES', clOlive);
end;
with FileList do
begin
SmallImages := TImageList.CreateSize(16,16);
SmallImages.ShareImages := True;
SmallImages.Handle := ShGetFileInfo('*.*', 0, SHFileInfo,
SizeOf(SHFileInfo), SHGFI_SMALLICON or SHGFI_ICON or SHGFI_SYSICONINDEX);
LargeImages := TImageList.Create(nil);
LargeImages.ShareImages := True;
LargeImages.Handle := ShGetFileInfo('*.*', 0, SHFileInfo,
SizeOf(SHFileInfo), SHGFI_LARGEICON or SHGFI_ICON or SHGFI_SYSICONINDEX);
end;
end;
procedure TMyFtp.FTPBusy(Sender: TObject; isBusy: Wordbool);
begin
if isBusy then
begin
Screen.Cursor := crHourGlass;
FileList.Items.BeginUpdate;
FileList.Items.Clear;
end
else
begin
Screen.Cursor := crDefault;
FileList.Items.EndUpdate;
end;
end;
function TMyFtp.NodePath(Node: TTreeNode): String;
begin
if Node = Root then
Result := '.'
else
Result := NodePath(Node.Parent) + '/' + Node.Text;
end;
procedure TMyFtp.DirTreeChange(Sender: TObject; Node: TTreeNode);
var
NP: String;
begin
if (FTP.State <> prcConnected) or FTP.Busy then exit;
if Node <> nil then
begin
NP := NodePath(DirTree.Selected);
FTP.List(NP);
Label2.Caption := Format('Contents of: ''%s/''',[NP]);
end;
end;
procedure TMyFtp.RefreshBtnClick(Sender: TObject);
begin
FTP.List(NodePath(DirTree.Selected));
end;
procedure TMyFtp.DirTreeChanging(Sender: TObject; Node: TTreeNode;
var AllowChange: Boolean);
begin
AllowChange := not FTP.Busy;
end;
procedure TMyFtp.FTPStateChanged(Sender: TObject; State: Smallint);
begin
with FTP, Statusbar.Panels[0] do
case State of
prcConnecting : Text := 'Connecting';
prcResolvingHost: Text := 'Connecting';
prcHostResolved : Text := 'Host resolved';
prcConnected :
begin
Text := 'Connected to: ' + RemoteHost;
ConnectBtn.Hint := 'Disconnect';
FileNewItem.Enabled := True;
ViewLargeItem.Enabled := True;
ViewSmallItem.Enabled := True;
ViewListItem.Enabled := True;
ViewDetailsItem.Enabled := True;
ViewRefreshItem.Enabled := True;
ToolsDisconnectItem.Enabled := True;
LargeBtn.Enabled := True;
SmallBtn.Enabled := True;
ListBtn.Enabled := True;
DetailsBtn.Enabled := True;
RefreshBtn.Enabled := True;
end;
prcDisconnecting: Text := 'Disconnecting';
prcDisconnected :
begin
Text := 'Disconnected';
ConnectBtn.Hint := 'Connect';
DirTree.Items.Clear;
FileNewItem.Enabled := False;