ftp_api.pas

< Delphi网络通信协议分析与应用实现>>一书的源代码。

unit FTP_API;

interface

uses
  Windows, Messages, Variants,SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ToolWin, ComCtrls, Buttons, ExtCtrls,StrUtils,
  SyncObjs, Wininet,  QControls,  QDialogs,  QImgList,  IdTunnelCommon,
  QMenus,  commctrl, ShellApi, ImgList, FileCtrl;
type
  TFTPMain = class(TForm)
    ToolBar1: TToolBar;
    SbtnConnect: TSpeedButton;
    SbtnDisconn: TSpeedButton;
    SbtnMakedir: TSpeedButton;
    SbtnDown: TSpeedButton;
    SbtnUpload: TSpeedButton;
    SbtnRemoteUpdateList: TSpeedButton;
    Memo1: TMemo;
    Splitter2: TSplitter;
    StatusBar1: TStatusBar;
    ToolButton1: TToolButton;
    ToolButton2: TToolButton;
    EditPass: TEdit;
    ToolButton3: TToolButton;
    Label1: TLabel;
    Label2: TLabel;
    EditUser: TEdit;
    Label3: TLabel;
    EditIP: TEdit;
    drive1: TDriveComboBox;
    ckAnonymous: TCheckBox;
    ToolButton4: TToolButton;
    ImageList1: TImageList;
    Panel1: TPanel;
    GBox1: TGroupBox;
    LView1: TListView;
    Splitter1: TSplitter;
    GBox2: TGroupBox;
    LView2: TListView;
    procedure SbtnConnectClick(Sender: TObject);
    procedure SbtnDisconnClick(Sender: TObject);
    procedure SbtnMakedirClick(Sender: TObject);
    procedure SbtnDownClick(Sender: TObject);
    procedure SbtnUploadClick(Sender: TObject);
    procedure RemoteUpdateListing;
    procedure MsgOk(msgstr:string);
    procedure CollectSelectedItems(aListView:TListView;var aList:tstringlist);
    procedure LocalUpdateListing;
    procedure FormCreate(Sender: TObject);
    procedure LvAdd(Caption1:string;imageidx1:integer;selimage:integer;item2:TListItem);
    function FileSizeToString(const Size: Int64): string;
    function GetFileTypeDescription(const Name: string; UseAttr: Boolean): string;
    procedure LView1CustomDrawItem(Sender: TCustomListView;
      Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean);
    function GetFileTypeIcon(const Name: string; UseAttr: Boolean): HICON;
    procedure LView2CustomDrawItem(Sender: TCustomListView;
      Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean);
    procedure LView2DblClick(Sender: TObject);
    procedure LView1DblClick(Sender: TObject);
    procedure AddMemo(msgstr:string);
    procedure SetStatus(idx:integer;msgstr:string);
    procedure ckAnonymousClick(Sender: TObject);
    procedure EditIPKeyPress(Sender: TObject; var Key: Char);
    procedure drive1Change(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  FTPMain: TFTPMain;
var
    FtpHandle: HInternet;
    InetHandle: HInternet;
    FLocalPath: string;
    FRemotePath: string;
    RemoteSort:Boolean=false;
    TotalBytesSend, TotalBytesReceived:int64;

implementation


{$R *.dfm}

procedure InetCallback(HInternet: HINTERNET; dwContext, dwInternetStatus: DWORD;
  lpStatusInfo: Pointer; dwStatusInfoLen: DWORD); stdcall;
begin
    case dwInternetStatus of
    INTERNET_STATUS_RESOLVING_NAME:
        FTPMain.AddMemo('Resolving Name');
    INTERNET_STATUS_NAME_RESOLVED:
    begin
        FTPMain.AddMemo('Name Resolved');
    end;
    INTERNET_STATUS_CONNECTING_TO_SERVER:
        FTPMain.AddMemo('Connected');
    INTERNET_STATUS_CONNECTED_TO_SERVER:
        FTPMain.AddMemo('Connected to Server');
    INTERNET_STATUS_SENDING_REQUEST:
        FTPMain.AddMemo('Sending Request');
    INTERNET_STATUS_REQUEST_SENT:
    begin
        FTPMain.AddMemo('Request Send');
        TotalBytesSend:=TotalBytesSend+DWORD(lpStatusInfo^);
        FTPMain.SetStatus(1,'发送了：'+IntToStr(TotalBytesSend) + ' bytes');
    end;
    INTERNET_STATUS_RECEIVING_RESPONSE:
        FTPMain.AddMemo('Receiving Response');
    INTERNET_STATUS_RESPONSE_RECEIVED:
    begin
        FTPMain.AddMemo('Response Received');
        TotalBytesReceived:=TotalBytesReceived+DWORD(lpStatusInfo^);
        FTPMain.SetStatus(1,'接收了'+IntToStr(TotalBytesReceived) + ' bytes');
    end;
    INTERNET_STATUS_CTL_RESPONSE_RECEIVED:
        FTPMain.AddMemo('Ctl Response Received');
    INTERNET_STATUS_PREFETCH:
        FTPMain.AddMemo('Prefetch');
    INTERNET_STATUS_CLOSING_CONNECTION:
        FTPMain.AddMemo('Closing Connection');
    INTERNET_STATUS_CONNECTION_CLOSED:
        FTPMain.AddMemo('Connection Closed');
    INTERNET_STATUS_HANDLE_CREATED:
        FTPMain.AddMemo('Handle Created');
    INTERNET_STATUS_HANDLE_CLOSING:
        FTPMain.AddMemo('Handle Closing');
    INTERNET_STATUS_REQUEST_COMPLETE:
        FTPMain.AddMemo('Request Complete');
    INTERNET_STATUS_REDIRECT:
        FTPMain.AddMemo('Redirect');
    INTERNET_STATUS_INTERMEDIATE_RESPONSE:
        FTPMain.AddMemo('Intermediate Response');
    INTERNET_STATUS_STATE_CHANGE:
        FTPMain.AddMemo('Changing');
    else
        FTPMain.AddMemo('Status Unknown');
    end;
end;

procedure TFTPMain.MsgOk(msgstr:string);
begin
    application.MessageBox(pchar(msgstr),'注意');
end;

procedure TFTPMain.AddMemo(msgstr:string);
begin
    memo1.lines.add(msgstr);
end;

procedure TFTPMain.SetStatus(idx:integer;msgstr:string);
begin
    statusbar1.panels[idx].text:=msgstr;
end;

procedure TFTPMain.SbtnConnectClick(Sender: TObject);
var
    Server, Usr, Pw: string;
    Port: Integer;
begin
    if editip.text='' then
    begin
        msgok('输入IP地址');
        exit;
    end
    else
    begin
        SbtnDisconn.click;
        InetHandle := InternetOpen(PChar('KOLFTP'), 0, nil, nil, 0);
        InternetSetStatusCallback(InetHandle, @InetCallback);
        Server := editip.text;//HostAddressName.Text;
        Usr    := edituser.text;//EdiUserName.Text;
        Pw     := editpass.text;//EdiPassword.Text;
        Port   := 21;//StrToInt(EdiPort.Text);
        if ckAnonymous.Checked then
            FtpHandle := InternetConnect(InetHandle, PChar(Server), Port, nil,
            nil, INTERNET_SERVICE_FTP, 0, 255)
        else
            FtpHandle := InternetConnect(InetHandle, PChar(Server), Port, PChar(Usr),
            PChar(Pw), INTERNET_SERVICE_FTP, 0, 255);
        if not Assigned(FtpHandle) then
        begin
            InternetCloseHandle(InetHandle);
            application.MessageBox('Connection Failed','警告');
        end
        else
        begin
            RemoteUpdateListing;
        end;
    end;
end;

procedure TFTPMain.SbtnDisconnClick(Sender: TObject);
begin
    InternetCloseHandle(FtpHandle);
    InternetCloseHandle(InetHandle);
    FtpHandle:=nil;
    inetHandle:=nil;
    statusbar1.Panels[0].Text:='Disconnected';
    Toolbar1.buttons[0].enabled:=True;
end;

procedure TFTPMain.SbtnMakedirClick(Sender: TObject);
var
    Name: string;
    i:integer;
    F:Boolean;
begin
    if ftphandle=nil then begin MsgOk('Not Connected');exit;end;
    Name:=inputbox('输入文件夹名称', '！！！','New Folder');

    F:= FtpCreateDirectory(FtpHandle, PChar(FRemotePath + Name));
    if(F<>true) then
        msgok('创建失败！');
    RemoteUpdateListing;
end;

procedure TFTPMain.SbtnDownClick(Sender: TObject);
var
    FileList: Tstringlist;
    I: Integer;
begin
    FileList := Tstringlist.create;
    with lView2 do
    try
        CollectSelectedItems(LView2,FileList);
        for I := 0 to FileList.Count - 1 do
        if not FtpGetFile(FtpHandle, PChar(FRemotePath + FileList.strings[I]), PChar(FLocalPath + FileList.strings[I]),
            True, FILE_ATTRIBUTE_NORMAL, FTP_TRANSFER_TYPE_BINARY or INTERNET_FLAG_RELOAD, 255)
        then application.messagebox('下载错误','!!!!');//getLastError,
    finally
        FileList.free;
        LocalUpdateListing;
    end;
end;

procedure TFTPMain.SbtnUploadClick(Sender: TObject);
var
    FileList: Tstringlist;
    I: Integer;
begin
    FileList := Tstringlist.create;
    with lView1 do
    try
        CollectSelectedItems(lView1,FileList);
        for I := 0 to FileList.Count - 1 do
        begin
        if not FtpPutFile(FtpHandle, PChar(FlocalPath + FileList.strings[I]), PChar(FRemotePath + FileList.strings[I]),
            FTP_TRANSFER_TYPE_BINARY, 255) then application.messagebox('error','!!!!');//ShowError(getlasterror);
        end;
    finally
        FileList.free;
        RemoteUpdateListing;
    end;
end;

procedure TFTPMain.RemoteUpdateListing;
var
    F: TWin32FindData;
    Enum: HInternet;
    R: Bool;
    FileName: string;
    FileSize: Int64;
    Magic:integer;
    item1:Tlistitem;
begin
    Enum := nil;
    with Lview2 do
    try
        Clear;
        Update;
        Enum := FtpFindFirstFile(FtpHandle, PChar(FRemotePath + '*.*'), F, 0, 255);
        R := Enum <> nil;
        item1:=Lview2.Items.Add();
        item1.SubItems.Add('');
        item1.SubItems.Add('');
        item1.SubItems.Add('');
        LvAdd('..',0,0,item1);
    while R do
    begin
        FileName := F.cFileName;
        if Filename<>'.' then
        begin
            item1:=Lview2.Items.Add();
            item1.SubItems.Add('');
            item1.SubItems.Add('');
            item1.SubItems.Add('');
            LvAdd(Filename,0,0,item1);
            FileSize := (F.nFileSizeHigh shl 32) or (F.nFileSizeLow);
            if F.dwFileAttributes and faDirectory = faDirectory then