VB+MFTPX.OCX访问ftp服务器的小例子

　　mftpx.ocx是一个不错的控件，只是不支持中文的路径和空格，比较让人恼火。最后只能通过其他的手段来弥补他的这个不足。 

　　首先当然要引用MFTPX.OCX 。

　　代码如下：

Private   Declare   Function ShellExecute() Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Const SW_SHOWNORMAL = 1
Dim fso As Scripting.FileSystemObject
Dim tmpFolder As String
Dim tmpFile_ As String
Dim tmpFullFile As String

Private Sub Check1_Click()Sub Check1_Click()
 If Check1.Value = 0 Then
    Command1.Enabled = True
    Command2.Enabled = True
    Command3.Enabled = True
    Command4.Enabled = True
    Command5.Enabled = True
  Else
    Command1.Enabled = False
    Command2.Enabled = False
    Command3.Enabled = False
    Command4.Enabled = False
  End If
End Sub

'连接ftp
Private Sub Command1_Click()Sub Command1_Click()
   mFtp1.Host = "192.168.31.189"
   mFtp1.Port = "8088"
   mFtp1.Connect "wy", "wy"
End Sub

'选择文件
Private Sub Command2_Click()Sub Command2_Click()
   If Check1.Value = 1 Then Exit Sub
   cd1.Filter = "word文件(*.doc)|*.doc|autocad图纸(*.dwg)|*.dwg|所有文件(*.*)|*.*"
   cd1.DialogTitle = "选择要上传的文件"
   cd1.ShowOpen

   If cd1.FileName <> "" Then
      Text1.Text = cd1.FileName
      tmpFile = createFileName(cd1.FileTitle) & "." & Mid(cd1.FileTitle, InStr(cd1.FileTitle, ".") + 1)
      tmpFullFile = tmpFolder & "" & tmpFile
      fso.CopyFile cd1.FileName, tmpFullFile
   End If
   
End Sub

'上传
Private Sub Command3_Click()Sub Command3_Click()
   On Error GoTo errEnd
   If Check1.Value = 1 Then Exit Sub
   If mFtp1.State = 0 Then
      Command1_Click
   End If
   If mFtp1.State = 1 Then
      If InStr(cd1.FileTitle, ".") > 0 Then
         Dim myName As String
         pbar.Caption = "正在上传……"
         pbar.Visible = True
         Command1.Enabled = False
         Command2.Enabled = False
         Command3.Enabled = False
         Command4.Enabled = False
         mFtp1.PutFile tmpFullFile, tmpFile
         appendFile tmpFile, cd1.FileTitle
         fso.DeleteFile tmpFullFile
         Text1.Text = ""
         pbar.Caption = ""
         pbar.Visible = False
         Command1.Enabled = True
         Command2.Enabled = True
         Command3.Enabled = True
         Command4.Enabled = True
      End If
   End If
   Exit Sub
errEnd:
    pbar.Caption = ""
    pbar.Visible = False
         Command1.Enabled = True
         Command2.Enabled = True
         Command3.Enabled = True
         Command4.Enabled = True
    MsgBox "出错了，错误提示：" & Err.Description
End Sub

'处理
Private Sub appendFile()Sub appendFile(ByVal newFileName As String, ByVal oldFileName As String)
   Dim lstItem As ListItem
   Set lstItem = ListView1.ListItems.Add(, , newFileName)
   lstItem.SubItems(1) = oldFileName
   lstItem.SubItems(2) = Now
End Sub


'构造文件名
Private Function createFileName()Function createFileName(ByVal str As String) As String
   Dim newStr As String
   newStr = ""
   If str <> "" Then
       newStr = CStr(Year(Date)) & fillCode(CStr(Month(Date)), 2) & fillCode(CStr(Day(Date)), 2) & fillCode(CStr(Hour(Time)), 2) & fillCode(CStr(Minute(Time)), 2) & fillCode(CStr(Second(Time)), 2)
       newStr = newStr & CStr(CInt(Round(1000 * Rnd(Minute(Time) & Second(Time)))))
   End If
   createFileName = newStr
End Function
'给字符串前加 0 补码
Private Function fillCode()Function fillCode(ByVal str As String, ByVal fLen As Long) As String
    fillCode = Mid(CStr(10 ^ (fLen - Len(str))), 2) & str
End Function

'删除
Private Sub Command4_Click()Sub Command4_Click()
   If Check1.Value = 1 Then Exit Sub
   If mFtp1.State = 0 Then
      Command1_Click
   End If
   If mFtp1.State = 1 Then
      If ListView1.ListItems.Count > 0 Then
         If ListView1.SelectedItem <> "" Then
              mFtp1.Delete ListView1.SelectedItem.Text
              ListView1.ListItems.Remove (ListView1.SelectedItem.Index)
         End If
      End If
   End If
End Sub

'打开文件
Private Sub Command5_Click()Sub Command5_Click()
   
   If mFtp1.State = 0 Then
      Command1_Click
   End If
   If mFtp1.State = 1 Then
      If ListView1.ListItems.Count > 0 Then
         If ListView1.SelectedItem <> "" Then
            Dim myName As String
            myName = tmpFolder & "" & ListView1.SelectedItem.SubItems(1)

            If Not fso.FileExists(myName) Then
                 pbar.Caption = "正在下载……"
                 pbar.Visible = True
                 If Check1.Value = 0 Then
                    Command1.Enabled = False
                    Command2.Enabled = False
                    Command3.Enabled = False
                    Command4.Enabled = False
                    Command5.Enabled = False
                 End If
                 mFtp1.GetFile ListView1.SelectedItem.Text, tmpFolder & "" & ListView1.SelectedItem.Text
                 fso.CopyFile tmpFolder & "" & ListView1.SelectedItem.Text, myName
                 fso.DeleteFile tmpFolder & "" & ListView1.SelectedItem.Text
            End If
            ShellExecute hwnd, "open", myName, vbNullString, vbNullString, 1
            
            Text1.Text = ""
            pbar.Caption = ""
            pbar.Visible = False
            If Check1.Value = 0 Then
                Command1.Enabled = True
                Command2.Enabled = True
                Command3.Enabled = True
                Command4.Enabled = True
                Command5.Enabled = True
            End If
         End If
      End If
   End If
End Sub

'装载表单
Private Sub Form_Load()Sub Form_Load()
   Set fso = New Scripting.FileSystemObject
   tmpFolder = "c:Northsnow070101"
   If Not fso.FolderExists(tmpFolder) Then
     fso.CreateFolder tmpFolder
   End If
   ListView1.View = lvwReport
   ListView1.ColumnHeaders.Add 1, "newfile", "NewFileName", ListView1.Width / 3, 0
   ListView1.ColumnHeaders.Add 2, "oldfile", "OldFileName", ListView1.Width / 3, 0
   ListView1.ColumnHeaders.Add 3, "udate", "UploadDate", ListView1.Width / 3, 0
   ListView1.GridLines = True
   ListView1.FullRowSelect = True
   ListView1.LabelEdit = lvwManual
   ListView1.MultiSelect = False
   pbar.Visible = False
   pbar.Caption = ""
End Sub

Private Sub Form_Unload()Sub Form_Unload(Cancel As Integer)
   If fso.FolderExists(tmpFolder) Then
     fso.DeleteFolder tmpFolder, True
   End If
   Set fso = Nothing
End Sub

 

运行界面：

请输入大于5个字符的标题