frmftp2.frm

vb网络通信协议,参考例程

If hConnection <> 0 Then
    InternetCloseHandle hConnection
End If
hConnection = 0
ClearBag
TreeView1.Nodes.Remove txtServer.Text
bActiveSession = False
cmdConnect.Enabled = True
cmdDisconnect.Enabled = False
txtServer.Enabled = True
txtPort.Enabled = True
txtUser.Enabled = True
txtPassword.Enabled = True
chkAnon.Enabled = True
EnableUI (False)
End Sub

Private Sub cmdGet_Click()
'下载选中的在FTP服务器上的文件
Dim bRet As Boolean
Dim szFileRemote As String, szDirRemote As String, szFileLocal As String
Dim szTempString As String
Dim nPos As Long, nTemp As Long
Dim nodX As Node
Set nodX = TreeView1.SelectedItem
If bActiveSession Then
    If nodX Is Nothing Then
        MsgBox "请选择要下载的文件!"
        Exit Sub
    End If
    szTempString = TreeView1.SelectedItem.Text
    szFileRemote = szTempString
    nPos = 0
    nTemp = 0
    Do
        nTemp = InStr(1, szTempString, "/", vbBinaryCompare)
        If nTemp = 0 Then Exit Do
        szTempString = Right(szTempString, Len(szTempString) - nTemp)
        nPos = nTemp + nPos
    Loop
    'do....loop的语句的作用是把文件的地址中的文件夹的路径的位置
    szDirRemote = Left(szFileRemote, nPos)
    '抽取文件夹的路径
    szFileRemote = Right(szFileRemote, Len(szFileRemote) - nPos)
    '抽取文件名
    szFileLocal = File1.Path
    rcd szDirRemote
    '将ftp服务器的当前目录设置为szDirRemote
    bRet = FtpGetFile(hConnection, szFileRemote, szFileLocal & "/" & szFileRemote, False, _
    INTERNET_FLAG_RELOAD, dwType, 0)
    '下载文件到本地机的当前目录
    File1.Refresh
    If bRet = False Then ErrorOut Err.LastDllError, "FtpGetFile"
Else
    MsgBox "Not in session"
End If
End Sub

Private Sub cmdMdDir_Click()
'在本地计算机上创建目录
Dim temp
temp = MsgBox("在本地计算机创建目录请按 “是”" & vbCrLf _
& "在FTP服务器上创建目录请按“否”", vbYesNoCancel)
If temp = vbCancel Then Exit Sub
If temp = vbYes Then
    Dim strDirName As String
    strDirName = InputBox$("请输入在本地计算机上要创建的目录名" & vbCrLf _
    & "本地计算机的当前目录是：" & Dir1.Path, "在本地计算机上创建目录")
    If strDirName <> "" Then
        MkDir (Dir1.Path & "\" & strDirName)
        Dir1.Refresh
    End If
Exit Sub
End If
'在FTP服务器当前目录创建目录
Dim bRet As Boolean
Dim szFileRemote As String, szDirRemote As String, szFileLocal As String
Dim szTempString As String
Dim nPos As Long, nTemp As Long
Dim nodX As Node
Set nodX = TreeView1.SelectedItem
If bActiveSession Then
    If nodX Is Nothing Then
        MsgBox "请选择要创建目录的FTP服务器的文件夹!"
        Exit Sub
    End If
    If nodX.Image = "leaf" Then
        MsgBox "不能在文件下建立目录，请选择文件夹!"
        Exit Sub
    End If
    szTempString = nodX.Text
    szDirRemote = Right(szTempString, Len(szTempString) - Len(txtServer.Text))
    If (szDirRemote = "") Then szDirRemote = "\"
    rcd szDirRemote
    Dim strTemp As String
    strTemp = InputBox$("请输入要创建的文件夹的名字" & vbCrLf & _
     "当前FTP服务器的路径是：" & szDirRemote, "FTP客户端程序")
    If strTemp <> "" Then
        Dim bMake As Boolean
        '在FTP服务器当前的目录下创建文件夹
        bMake = FtpCreateDirectory(hConnection, strTemp)
        '创建目录文件夹成功返回值bMake为TRUE
        If bMake Then
            MsgBox "文件夹创建成功！"
            '将ftp服务器当前目录下的节点去除
            Dim nodChild As Node, nodNextChild As Node
            Set nodChild = nodX.Child
            Do
                If nodChild Is Nothing Then Exit Do
                Set nodNextChild = nodChild.Next
                TreeView1.Nodes.Remove nodChild.Index
                If nodNextChild Is Nothing Then Exit Do
                Set nodChild = nodNextChild
            Loop
            If nodX.Image = "closed" Then
                nodX.Image = "open"
            End If
            FtpEnumDirectory (nodX.Text)
            FillTreeViewControl (nodX.Text)
        Else
            MsgBox "目录创建失败！"
            ErrorOut Err.LastDllError, "创建目录文件夹"
        End If
    End If
End If
End Sub

Private Sub cmdPut_Click()
 '此子程序的作用是将本地机的文件上传到ftp服务器
Dim bRet As Boolean
Dim szFileRemote As String, szDirRemote As String, szFileLocal As String
Dim szTempString As String
Dim nPos As Long, nTemp As Long
Dim nodX As Node
Set nodX = TreeView1.SelectedItem
If bActiveSession Then
    If nodX Is Nothing Then
        MsgBox "请选择上载文件的目录!"
        Exit Sub
    End If
    If nodX.Image = "leaf" Then
        MsgBox "请选择上载文件的目录!"
        Exit Sub
    End If
    If File1.FileName = "" Then
        MsgBox "请在本地计算机选择要上载的文件"
        Exit Sub
    End If
    szTempString = nodX.Text
    szDirRemote = Right(szTempString, Len(szTempString) - Len(txtServer.Text))
    szFileRemote = File1.FileName
    szFileLocal = File1.Path & "\" & File1.FileName
    If (szDirRemote = "") Then szDirRemote = "\"
    rcd szDirRemote
    '以上是先取得要上载文件的ftp服务器的目录，并设置为ftp当前目录
    '再用FtpPutFile上载
    bRet = FtpPutFile(hConnection, szFileLocal, szFileRemote, _
     dwType, 0)
    If bRet = False Then
        ErrorOut Err.LastDllError, "FtpPutFile"
        Exit Sub
    End If
    '将ftp服务器当前目录下的节点去除
    Dim nodChild As Node, nodNextChild As Node
    Set nodChild = nodX.Child
    Do
      If nodChild Is Nothing Then Exit Do
      Set nodNextChild = nodChild.Next
        TreeView1.Nodes.Remove nodChild.Index
        If nodNextChild Is Nothing Then Exit Do
        Set nodChild = nodNextChild
    Loop
    If nodX.Image = "closed" Then
        nodX.Image = "open"
    End If
    '查找nodX.text目录下的所有文件将其名字及属性加入集合中
    FtpEnumDirectory (nodX.Text)
    '重新根据集合中元素设置treeview中目录nodx.text下的各节点
    FillTreeViewControl (nodX.Text)
End If
End Sub

Private Sub Dir1_Change()
    File1.Path = Dir1.Path
End Sub

Private Sub Drive1_Change()
On Error GoTo ErrProc
Dir1.Path = Drive1.Drive
Exit Sub
ErrProc:
    Drive1.Drive = "c:"
    Dir1.Path = Drive1.Drive
End Sub

Private Sub Form_Load()
chkPassive.Value = 1
optBin.Value = 1
dwType = FTP_TRANSFER_TYPE_BINARY
'为ListImage控件加载Images
Dim imgI As ListImage
Set imgI = ImageList1.ListImages.Add(, "open", LoadPicture("open.bmp"))
Set imgI = ImageList1.ListImages.Add(, "closed", LoadPicture("closed.bmp"))
Set imgI = ImageList1.ListImages.Add(, "leaf", LoadPicture("leaf.bmp"))
Set imgI = ImageList1.ListImages.Add(, "root", LoadPicture("root.bmp"))
TreeView1.ImageList = ImageList1
TreeView1.Style = tvwTreelinesPictureText
'初始化各个控件的属性
txtServer.Text = "166.111.167.44"
txtUser.Text = "zhongjun"
txtPassword.Text = "zhongjun"
txtPort.Text = 21
cmdConnect.Enabled = True
cmdDisconnect.Enabled = False
txtServer.Enabled = True
txtPort.Enabled = True
txtUser.Enabled = True
txtPassword.Enabled = True
EnableUI (False)
End Sub

Private Sub Form_Unload(Cancel As Integer)
'关闭Internet连接，清除集合的内容
ClearTextBoxAndBag
If hConnection <> 0 Then
    InternetCloseHandle hConnection
End If
hConnection = 0
End Sub

Private Sub optAscii_Click()
'选择文件的传输方式为ASCII方式
dwType = FTP_TRANSFER_TYPE_ASCII
End Sub

Private Sub optBin_Click()
'选择文件的传输方式为BINARY方式
dwType = FTP_TRANSFER_TYPE_BINARY
End Sub

Private Sub TreeView1_DblClick()
Dim nodX As Node
Set nodX = TreeView1.SelectedItem
If Not bActiveSession Then
    MsgBox "No in session!"
    Exit Sub
End If
If nodX Is Nothing Then
    MsgBox "没有选中相应的节点！"
End If
'如果文件夹是关闭的，打开文件夹，显示该文件夹下的目录及文件
If nodX.Image = "closed" Then
    nodX.Image = "open"
    FtpEnumDirectory (nodX.Text)
    FillTreeViewControl (nodX.Text)
Else
'如果文件夹是打开的，去除其下面的节点，并将文件夹的image设置为"closed"
    If nodX.Image = "open" Then
        nodX.Image = "closed"
        Dim nodChild As Node, nodNextChild As Node
        Set nodChild = nodX.Child
        Do
            Set nodNextChild = nodChild.Next
            TreeView1.Nodes.Remove nodChild.Index
            If nodNextChild Is Nothing Then Exit Do
            Set nodChild = nodNextChild
        Loop
    End If
End If
End Sub
Private Sub FtpEnumDirectory(strDirectory As String)
 '取得FTP服务器当前目录下的文件夹和文件
 '清除集合的各元素
ClearBag
Dim hFind As Long
Dim nLastError As Long
Dim dError As Long
Dim ptr As Long
Dim pData As WIN32_FIND_DATA
'设置FTP当前目录为strDirectory,并取得此目录下的第一个文件
If Len(strDirectory) > 0 Then rcd (strDirectory)
    pData.cFileName = String(MAX_PATH, 0)
    hFind = FtpFindFirstFile(hConnection, "*.*", pData, 0, 0)
    nLastError = Err.LastDllError
    If hFind = 0 Then
        If (nLastError = ERROR_NO_MORE_FILES) Then
            MsgBox "This directory is empty!"
        Else
            ErrorOut nLastError, "FtpFindFirstFile"
        End If
        Exit Sub
    End If
    dError = NO_ERROR
    Dim bRet As Boolean
    Dim strItemName As String
    '将取得的第一个文件名及其属性加入相应集合中
    EnumItemAttributeBag.Add pData.dwFileAttributes
    strItemName = Left(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
    EnumItemNameBag.Add strItemName
    'do....loop是查找此目录下的所有文件，并把他们的属性及名字加入相应的集合中
    Do
        pData.cFileName = String(MAX_PATH, 0)
        bRet = InternetFindNextFile(hFind, pData)
        If Not bRet Then
            dError = Err.LastDllError
            If dError = ERROR_NO_MORE_FILES Then
                Exit Do
            Else
                ErrorOut dError, "InternetFindNextFile"
                InternetCloseHandle (hFind)
               Exit Sub
            End If
        Else
            EnumItemAttributeBag.Add pData.dwFileAttributes
            strItemName = Left(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
            EnumItemNameBag.Add strItemName
       End If
    Loop
    InternetCloseHandle (hFind)
End Sub


Private Sub EnableUI(bEnabled As Boolean)
optBin.Enabled = bEnabled
optAscii.Enabled = bEnabled
cmdGet.Enabled = bEnabled
cmdPut.Enabled = bEnabled
cmdMdDir.Enabled = bEnabled
cmdDelDir.Enabled = bEnabled
cmdDelFile.Enabled = bEnabled
End Sub


Private Sub rcd(pszDir As String)
'将FTP服务器的当前目录设置为pszDir
'如果pszDir为空则退出子程序
'如果pszDir中包含txtServer.text(即服务器的字符串，）则抽取除去此字符串
If pszDir = "" Then
    MsgBox "Please enter the directory to CD"
    Exit Sub
Else
    Dim sPathFromRoot As String
    Dim bRet As Boolean
    If InStr(1, pszDir, txtServer.Text) Then
        sPathFromRoot = Mid(pszDir, Len(txtServer.Text) + 1, Len(pszDir) - Len(txtServer.Text))
    Else
        sPathFromRoot = pszDir
    End If
    If sPathFromRoot = "" Then sPathFromRoot = "/"
    bRet = FtpSetCurrentDirectory(hConnection, sPathFromRoot)
    If bRet = False Then ErrorOut Err.LastDllError, "rcd"
End If
End Sub
Private Sub FillTreeViewControl(strParentKey As String)
'对象集合EnumItemAttributeBag中记录的是取得文件的属性
'当属性值为FILE_ATTRIBUTE_DIRECTORY---则字符串的属性为文件夹
'否则为文件
Dim nodX As Node
Dim strImg As String
Dim nCount As Integer, i As Integer
Dim nAttr As Integer
Dim strItem As String
'如果名字集合里的元素为零并且strPatentKey的值为服务器的ip值，设定根节点，退出子程序
If EnumItemNameBag.Count = 0 And strParentKey = txtServer.Text Then
    Set nodX = TreeView1.Nodes.Add(, tvwFirst, txtServer.Text, txtServer.Text, "root")
    Exit Sub
End If
'如果属性集合的元素个数为零，退出子程序
nCount = EnumItemAttributeBag.Count
If nCount = 0 Then Exit Sub
For i = 1 To nCount
    nAttr = EnumItemAttributeBag.Item(i)
    strItem = EnumItemNameBag(i)
    If nAttr = FILE_ATTRIBUTE_DIRECTORY Then
        strImg = "closed"
    Else
        strImg = "leaf"
    End If
    '重新根据属性集合和名字集合的元素设置节点
    Set nodX = TreeView1.Nodes.Add(strParentKey, tvwChild, strParentKey & "/" & strItem, _
        strParentKey & "/" & strItem, strImg)
Next
nodX.EnsureVisible
End Sub
Public Sub ClearTextBoxAndBag()
'将窗体的文本框和所有的对象集合（这些对象集合是用来记录一些辅助信息的）
'ClearBag---清除对象集合的元素
txtServer.Text = ""
txtUser.Text = ""
txtPassword.Text = ""
txtPort.Text = ""
ClearBag
End Sub

Public Sub ClearBag()
'将集合对象EnumItemNameBag和EnumItemAttributeBag的所有项删除
Dim Num As Integer
For Num = 1 To EnumItemNameBag.Count
    EnumItemNameBag.Remove 1
Next Num
For Num = 1 To EnumItemAttributeBag.Count
    EnumItemAttributeBag.Remove 1
Next Num
End Sub
Function ErrorOut(dError As Long, szCallFunction As String)
'输出错误信息
Dim dwIntError As Long, dwLength As Long
Dim strBuffer As String
If dError = ERROR_INTERNET_EXTENDED_ERROR Then
    InternetGetLastResponseInfo dwIntError, vbNullString, dwLength
    strBuffer = String(dwLength + 1, 0)
    InternetGetLastResponseInfo dwIntError, strBuffer, dwLength
    MsgBox szCallFunction & " Extd Err: " & dwIntError & " " & strBuffer
End If
If MsgBox(szCallFunction & " Err: " & dError & _
    vbCrLf & "关闭连接及进程?", vbYesNo) = vbYes Then
    If hConnection Then InternetCloseHandle hConnection
    If hOpen Then InternetCloseHandle hOpen
    hConnection = 0
    hOpen = 0
    If bActiveSession Then TreeView1.Nodes.Remove txtServer.Text
    bActiveSession = False
    ClearTextBoxAndBag
    EnableUI (False)
    Unload Me
End If
End Function