[共享]使用Wininet的VBA FTP操作的类模块

unixzyy

用楼主的方法FTP下载文件后，EXCEL退出时死机，一直白屏，只有用任务管理器终止EXCEL，这是怎么回事？

kdkboy

支持多线程下载吗

还有个问题是下载线程如果僵死，它的DDL支持自动kill吗。不过这些问题都超出Excel的范围了

Unix下面的压缩文件要用Bin方式下载

a19410593

Sub UploadFile()
    Dim strRemoteFile As String
    Dim strLocalFile As String
    Set cF = New cFTP
    cF.SetModePassive
    strLocalFile = "d:\1212.txt"   '这里放你想上传导FTP的文件名
    strRemoteFile = "1212.txt"
    If cF.OpenConnection("127.0.0.1:3721", "aaa", "123") = False Then
        GoTo errhandle
    End If
    If cF.FTPUploadFile(strLocalFile, strRemoteFile) = False Then
        GoTo errhandle
    End If
    cF.CloseConnection
    Exit Sub
errhandle:
    MsgBox cF.GetLastErrorMessage
    cF.CloseConnection
End Sub
我的FTP是3721端口，使用时出现“internetConnect error code: 12031 Message: 与服务器的连接被重置”
请问这是FTP的问题，还是这段代码不支持端口。（我的FTP用FTP上传工具或直接打开都可以正常上传和下载文件的）

怎样修改以上代码才能实现上传正在运行的excel文件，也就是上传自己

[ 本帖最后由 a19410593 于 2010-3-15 06:34 编辑 ]

a19410593

晕````都没老师关注！

winland

关于自定义端口，原来的程序是默认使用21端口。如果要自定义端口的话，可以将InternetConnect函数的第3个参数改成你要的端口。
Public Function OpenConnection(sServer As String, sUser As String, sPassword As String) As Boolean
    If hConnection <> 0 Then
        InternetCloseHandle hConnection
    End If
    hConnection = InternetConnect(hOpen, sServer, INTERNET_INVALID_PORT_NUMBER, sUser, sPassword, INTERNET_SERVICE_FTP, dwSeman, 0)
    If hConnection = 0 Then
        ErrorOut Err.LastDllError, "InternetConnect"
        OpenConnection = False
        Exit Function
    Else
        OpenConnection = True
    End If
End Function
改成：
hConnection = InternetConnect(hOpen, sServer, 3721, sUser, sPassword, INTERNET_SERVICE_FTP, dwSeman, 0)

a19410593

非常感谢Winland版主的指点，完全知道怎么使用了。

cjy75751886

UP
马上就要用到的东西，这个真是太好了

zxylxw

导入类模块（升级CFTP类）的命名问题.rar (17.62 KB, 下载次数: 74)

2010-7-11 18:28 上传

点击文件名下载附件

删除原有模块时，按理模块名应释放出来，
但导入类模块的以该名命名时会出现名称冲突!
如何解决呢？请教各路高手
Private Sub CommandButton1_Click()
'勾取信任
            Dim Chgset As Boolean
            Debug.Print ThisWorkbook.VBProject.Protection
            If Err.Number = 1004 Then
                Err.Clear
                Application.SendKeys "%TMS%T%V{ENTER}"
                Chgset = True
                DoEvents
            End If
'删除类模块CFTP
    Dim Vbc As VBComponent
    For Each Vbc In Application.ThisWorkbook.VBProject.VBComponents
        Select Case Vbc.Type
        Case 1, 2, 3
            With Application.VBE.ActiveVBProject.VBComponents
                .Remove .Item(Vbc.Name)
            End With
        Case vbext_ct_ClassModule
            With Application.VBE.ActiveVBProject.VBComponents
                .Remove .Item(Vbc.Name)
            End With
        Case Else
            Vbc.CodeModule.DeleteLines 1, Vbc.CodeModule.CountOfLines
        End Select
    Next
  '导入升级版类模块CFTP
    Dim FileName As String, ClassName As String
    FileName = ThisWorkbook.Path & "\CFTP.cls"
    ClassName = Left(FileName, InStr(1, FileName, ".") - 1)
    Set Vbc = ThisWorkbook.VBProject.VBComponents.Import(FileName)  '会自动命名为CFTP1，以致原用类引用失效
    Vbc.Name = ClassName  '此处出错
END SUB

[ 本帖最后由 zxylxw 于 2010-7-11 18:28 编辑 ]

hysj02

你的 ClassName 附带着路径，当然不对。

hysj02

cFTP 类中 FTPUploadFile() 中有个bug
  Get #1, , Data
  If (InternetWriteFile(hFile, Data(0), Size Mod BUFFERSIZE, Written) = 0) Then
    FTPUploadFile = False
    ErrorOut Err.LastDllError, "InternetWriteFile2"
    Exit Function
  End If
当 (Size Mod BUFFERSIZE = 0) 时会出现bug，所以这段代码应改为
If Size Mod BUFFERSIZE <> 0 Then
  Get #1, , Data
  If (InternetWriteFile(hFile, Data(0), Size Mod BUFFERSIZE, Written) = 0) Then
    FTPUploadFile = False
    ErrorOut Err.LastDllError, "InternetWriteFile2"
    Exit Function
  End If
End If