ftp.frm

一个简单实用的FTP上传工具

   Begin VB.Label LocalPWD 
      BorderStyle     =   1  'Fixed Single
      Height          =   255
      Left            =   120
      TabIndex        =   29
      Top             =   7680
      Width           =   2715
   End
   Begin VB.Label RemotePWD 
      BorderStyle     =   1  'Fixed Single
      Height          =   255
      Left            =   3120
      TabIndex        =   27
      Top             =   7680
      Width           =   2715
   End
   Begin VB.Label XsWz 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "状态"
      ForeColor       =   &H00FF0000&
      Height          =   180
      Left            =   120
      TabIndex        =   19
      Top             =   6960
      Width           =   360
   End
End
Attribute VB_Name = "Main"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim XsZ As String
Dim CancelFlag As Boolean
Sub RefreshAll()
RefreshLocal
RefreshRemote
End Sub
Sub RefreshLocal()
LocalDirectories.Refresh
LocalFiles.Refresh
LocalPWD.Caption = LocalDirectories.Path
End Sub
Sub RefreshRemote()
RemotePWD.Caption = FTP.RemoteDirectory
RemoteDirectories.Clear
RemoteFiles.Clear
FTP.GetDirectory ("*.*")
End Sub
Private Sub DriveXz_Change()
LocalDirectories.Path = DriveXz.Drive
End Sub
Private Sub Exit_Click()
Unload Me
End Sub
Private Sub Form_Load()
FTP.Binary = True
DriveXz.Drive = "D:\"
LocalDirectories.Path = "D:\交换文件"
Host.AddItem "www.bacocis.com"
Host.AddItem "www.changhong.com"
Host.AddItem "www.ex-tre.com"
UserName.AddItem "mqkng"
UserName.AddItem "baco"
UserName.AddItem "audio"
XsZ = "系统准备就绪，孟庆康于2004年12月24日开发设计 013608129686"
End Sub
Private Sub FTP_NextDirectoryEntry(ByVal FileName As String, ByVal Attributes As Long, ByVal Length As Double)
If (Attributes And 16) = 16 Or Attributes = 0 Then
RemoteDirectories.AddItem FileName
Else
RemoteFiles.AddItem FileName
End If
End Sub
Private Sub FTP_TransferProgress(ByVal BytesTransferred As Long, ByVal TotalBytes As Long)
XsZ = BytesTransferred & "/" & TotalBytes
If CancelFlag = True Then FTP.CancelTransfer = True
DoEvents
End Sub
Private Sub GyCommand_Click()
XsZ = "孟庆康于2004年12月24日开发设计 013608129686 版权所有 1996-2004"
End Sub
Private Sub LocalDEL_Click()
If LocalFiles.ListIndex = -1 Then Exit Sub
On Error Resume Next
Kill LocalFiles.FileName
If Err <> 0 Then
XsZ = "本机文件保护，不能删除！"
Else
RefreshLocal
XsZ = "本机文件删除成功！"
End If
End Sub
Private Sub LocalDirectories_DblClick()
If LocalDirectories.ListIndex = -1 Then Exit Sub
ChDir LocalDirectories.Path
RefreshLocal
End Sub
Private Sub LocalDirectories_Change()
LocalFiles.Path = LocalDirectories.Path
LocalPWD.Caption = LocalDirectories.Path
End Sub
Private Sub LocalFiles_DblClick()
ToRemote.Value = True
End Sub
Private Sub LocalMD_Click()
Dim NewDirectory As String
NewDirectory = InputBox$("请输入本机文件夹名称！")
If NewDirectory = "" Then Exit Sub
On Error Resume Next
MkDir NewDirectory
If Err <> 0 Then
XsZ = "本机不允许建立或修改文件夹！"
Else
RefreshLocal
XsZ = "本机新建文件夹成功！"
End If
End Sub
Private Sub LocalRD_Click()
If LocalDirectories.ListIndex = -1 Then Exit Sub
On Error Resume Next
RmDir LocalDirectories.Path
If Err <> 0 Then
XsZ = "本机不允许删除这个文件！"
Else
RefreshLocal
XsZ = "本机删除文件成功！"
End If
End Sub
Private Sub RemoteDEL_Click()
If RemoteFiles.ListIndex = -1 Then Exit Sub
On Error Resume Next
FTP.DeleteFile RemoteFiles.Text
If Err <> 0 Then
XsZ = "服务器文件保护，不能删除！"
Else
RefreshRemote
XsZ = "服务器文件删除成功！"
End If
End Sub
Private Sub RemoteDirectories_DblClick()
On Error Resume Next
FTP.RemoteDirectory = RemoteDirectories.Text
If Err <> 0 Then
XsZ = "文件保护，不能更改！"
Else
RefreshRemote
End If
End Sub
Private Sub RemoteFiles_DblClick()
ToLocal.Value = True
End Sub
Private Sub RemoteMD_Click()
Dim NewDirectory As String
NewDirectory = InputBox$("请输入服务器新建文件夹名称！")
If NewDirectory = "" Then Exit Sub
On Error Resume Next
FTP.MkDir NewDirectory
If Err <> 0 Then
XsZ = "服务器不允许建立或修改文件夹！"
Else
RefreshRemote
XsZ = "服务器新建文件夹成功！"
End If
End Sub
Private Sub RemoteRD_Click()
If RemoteDirectories.ListIndex = -1 Then Exit Sub
On Error Resume Next
FTP.RmDir RemoteDirectories.Text
If Err <> 0 Then
XsZ = "服务器文件夹保护，不能删除！"
Else
RefreshRemote
XsZ = "服务器文件夹目录删除成功！"
End If
End Sub
Private Sub ToLocal_Click()
If RemoteFiles.ListIndex = -1 Then Exit Sub
FTP.RemoteFile = RemoteFiles.Text
FTP.LocalFile = RemoteFiles.Text
If FTP.ProfessionalEdition = True Then CancelFlag = False: DoEvents
On Error Resume Next
FTP.GetFile
If Err <> 0 Then
XsZ = "不允许传送文件系统！"
Else
If CancelFlag = True Then
On Error GoTo 0
FTP.Disconnect
FTP.Connect
FTP.RemoteDirectory = RemotePWD.Caption
CancelFlag = False
End If
RefreshLocal
XsZ = "服务器文件成功下载到本机！"
End If
End Sub
Private Sub ToRemote_Click()
DoEvents
If LocalFiles.ListIndex = -1 Then Exit Sub
FTP.LocalFile = LocalFiles.FileName
FTP.RemoteFile = LocalFiles.FileName
If FTP.ProfessionalEdition = True Then CancelFlag = False: DoEvents
On Error Resume Next
FTP.PutFile
If Err <> 0 Then
XsZ = "服务器不允许传送文件系统！"
Else
If CancelFlag = True Then
On Error GoTo 0
FTP.Disconnect
FTP.Connect
FTP.RemoteDirectory = RemotePWD.Caption
CancelFlag = False
End If
RefreshRemote
End If
XsZ = "本机文件成功上传到服务器！"
End Sub
Private Sub OK_Click()
XsZ = "正在与服务器连接中......"
XsWz.Caption = Time & "   " & XsZ
FTP.RemoteAddress = Host.Text
FTP.UserName = UserName.Text
FTP.Password = Password.Text
On Error Resume Next
FTP.Connect
If Err <> 0 Then
XsZ = "服务器不能连接成功，请检查服务器之用户名、密码等设置！"
Exit Sub
Else
XsZ = "服务器连接成功！"
FTP.Binary = True
FTP.UseCache = False
RefreshAll
OK.Enabled = False
ZzCommand.Enabled = True
ToRemote.Enabled = True
RemoteMD.Enabled = True
RemoteRD.Enabled = True
RemoteDEL.Enabled = True
ToLocal.Enabled = True
End If
End Sub
Private Sub UserName_Click()
Password.Text = ""
Password.SetFocus
End Sub
Private Sub XsZt_Timer()
XsWz.Caption = Now & "   " & XsZ
End Sub
Private Sub ZzCommand_Click()
CancelFlag = True
ZzCommand.Enabled = False
ToRemote.Enabled = False
RemoteMD.Enabled = False
RemoteRD.Enabled = False
RemoteDEL.Enabled = False
ToLocal.Enabled = False
OK.Enabled = True
End Sub