首页 > 编程学习 > VB+MFTPX.OCX访问ftp服务器的小例子

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

发布时间:2022/9/29 22:22:10

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

  首先当然要引用MFTPX.OCX 。

  代码如下:

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As LongByVal lpOperation As StringByVal lpFile As StringByVal lpParameters As StringByVal lpDirectory As StringByVal nShowCmd As LongAs 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()
 
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()
   mFtp1.Host 
= "192.168.31.189"
   mFtp1.Port 
= "8088"
   mFtp1.Connect 
"wy""wy"
End Sub


'选择文件
Private 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()
   
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(ByVal newFileName As StringByVal 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(ByVal str As StringAs 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(ByVal str As StringByVal fLen As LongAs String
    fillCode 
= Mid(CStr(10 ^ (fLen - Len(str))), 2& str
End Function


'删除
Private 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()
   
   
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()
   
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 / 30
   ListView1.ColumnHeaders.Add 
2"oldfile""OldFileName", ListView1.Width / 30
   ListView1.ColumnHeaders.Add 
3"udate""UploadDate", ListView1.Width / 30
   ListView1.GridLines 
= True
   ListView1.FullRowSelect 
= True
   ListView1.LabelEdit 
= lvwManual
   ListView1.MultiSelect 
= False
   pbar.Visible 
= False
   pbar.Caption 
= ""
End Sub


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



 

运行界面:

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


本文链接:https://www.ngui.cc/el/1460881.html
Copyright © 2010-2022 ngui.cc 版权所有 |关于我们| 联系方式| 豫B2-20100000