frmtest.frm

网络文件上传下载通信工具,界面友好,操作简单.

                    sDetails(2) = ""
                    lvItem.Tag = "DIR"
                Else
                    Set lvItem = ListView1.ListItems.Add(, , sDetails(1), 2, 2)
                    lvItem.Tag = "FILE"
                End If
                lvItem.SubItems(1) = sDetails(2)
                lvItem.SubItems(2) = sDetails(3)
            Next
        End If
    Else
        If FTP1.List(sNames(), bFiles(), dtDateTimes(), lSizes()) > 0 Then
            If UBound(sNames()) > 0 Then
                lNumLines = UBound(sNames())
                ' Loop through and put directories in first:
                For lLoop = 1 To lNumLines
                    If Not bFiles(lLoop) Then
                        Set lvItem = ListView1.ListItems.Add(, , sNames(lLoop), 1, 1)
                        lvItem.SubItems(1) = ""
                        lvItem.SubItems(2) = dtDateTimes(lLoop)
                        lvItem.Tag = "DIR"
                    End If
                Next
                For lLoop = 1 To lNumLines
                    If bFiles(lLoop) Then
                        Set lvItem = ListView1.ListItems.Add(, , sNames(lLoop), 2, 2)
                        lvItem.SubItems(1) = lSizes(lLoop)
                        lvItem.SubItems(2) = dtDateTimes(lLoop)
                        lvItem.Tag = "FILE"
                    End If
                Next
            End If
        End If
    End If
    'Me.Caption = "Test - " + FTP1.CurrentDir
    Me.Caption = "FTP"
    StatusBar1.SimpleText = CStr(lNumLines) + "个文件" '" item(s)..."
    Screen.MousePointer = vbDefault
    ListView1.SetFocus
End Sub

Function Tokenise(ByVal sList As String, ByVal sSeparator As String, ByRef sTokens() As String) As Integer
    Dim iPos As Integer
    Dim iNextPos As Integer
    Dim iTokenCount As Integer
    Dim bFirstToken As Boolean
    Dim bOneElement As Boolean

    On Error Resume Next
    
    ' Initialise
    iPos = 0
    iTokenCount = 0
    bFirstToken = True
    
    ' Start the search...
    iPos = InStr(1, sList, sSeparator)
    bOneElement = (iPos = 0)
    
    Do While iPos >= 1
        iTokenCount = iTokenCount + 1
        ReDim Preserve sTokens(iTokenCount)
    
        If bFirstToken Then
            ' If we've found the first delimiter, take the bit of string
            ' between the start and the first delimiter
            sTokens(iTokenCount) = Left$(sList, iPos - 1)
            bFirstToken = False
        Else
            ' Look for next delimiter:
            iNextPos = InStr(iPos + 1, sList, sSeparator)
    
            ' If we found another delimiter, get the bit of string between them:
            If iNextPos <> 0 Then
                sTokens(iTokenCount) = Mid$(sList, iPos + 1, iNextPos - iPos - 1)
            Else ' Get the bit of string between the delimiter and the end:
                sTokens(iTokenCount) = Mid$(sList, iPos + 1, Len(sList) - iPos)
            End If
    
            iPos = iNextPos
        End If
    
    Loop
    
    ' If no delimiters were found, return the original string:
    If bOneElement Then
        iTokenCount = 1
        ReDim Preserve sTokens(iTokenCount)
        sTokens(1) = sList
    End If
    ' Return number of tokens found
    Tokenise = iTokenCount

End Function

Private Sub chkAlwaysIncludeDirs_Click()
    FTP1.AlwaysIncludeDirs = chkAlwaysIncludeDirs.Value And vbChecked
    If FTP1.WildCard <> "*.*" Then doDir
End Sub

Private Sub chkUseListStr_Click()
    doDir
End Sub


Private Sub cmdConnect_Click()
    Screen.MousePointer = vbHourglass
    StatusBar1.SimpleText = "连接到" + txtServer.Text
    If FTP1.Connect(txtServer.Text, txtUser.Text, txtPassword.Text) <> ftpSuccess Then
        cmdConnect.Enabled = True
        txtServer.Enabled = True
        txtPort.Enabled = True
        txtUser.Enabled = True
        txtPassword.Enabled = True
        cmdMkDir.Enabled = False
        cmdDisconnect.Enabled = False
        chkUseListStr.Enabled = False
        chkAlwaysIncludeDirs.Enabled = False
        Drive1.Enabled = False
        Dir1.Enabled = False
        File1.Enabled = False
        ListView1.Enabled = False
        StatusBar1.SimpleText = "Connect failed: " + FTP1.LastError
        MsgBox "Connect failed: " + vbNewLine + FTP1.LastError
    Else
        ListView1.Enabled = True
        doDir
        cmdConnect.Enabled = False
        txtServer.Enabled = False
        txtPort.Enabled = False
        txtUser.Enabled = False
        txtPassword.Enabled = False
        cmdMkDir.Enabled = True
        cmdDisconnect.Enabled = True
        Drive1.Enabled = True
        Dir1.Enabled = True
        File1.Enabled = True
        chkUseListStr.Enabled = True
        chkAlwaysIncludeDirs.Enabled = True
        SaveSetting App.Title, "Connection", "Server", txtServer.Text
        SaveSetting App.Title, "Connection", "Port", txtPort.Text
        SaveSetting App.Title, "Connection", "User", txtUser.Text
        StatusBar1.SimpleText = "已连接"
    End If
    Screen.MousePointer = vbDefault
End Sub

Private Sub cmdDisconnect_Click()
    SaveSetting App.Title, "General", "UseListStr", chkUseListStr.Value
    SaveSetting App.Title, "General", "LocalDrive", Drive1.Drive
    SaveSetting App.Title, "General", "LocalDir", File1.Path
    SaveSetting App.Title, "General", "RemoteDir", FTP1.CurrentDir
    FTP1.Disconnect
    cmdConnect.Enabled = True
    txtServer.Enabled = True
    txtPort.Enabled = True
    txtUser.Enabled = True
    txtPassword.Enabled = True
    cmdMkDir.Enabled = False
    cmdDisconnect.Enabled = False
    chkUseListStr.Enabled = False
    Drive1.Enabled = False
    Dir1.Enabled = False
    File1.Enabled = False
    ListView1.Enabled = False
    ListView1.ListItems.Clear
    StatusBar1.SimpleText = "未连接..."
End Sub

Private Sub cmdGet_Click()
    ' Example Version 1.1.0 allows Multi-Selection:
    Dim i As Integer
    Screen.MousePointer = vbHourglass
    'StatusBar1.Visible = False
    'ProgressBar1.Visible = True
    For i = 1 To ListView1.ListItems.Count
        If ListView1.ListItems(i).Selected Then
            If ListView1.ListItems(i).Tag = "FILE" Then
                StatusBar1.SimpleText = "正在下载文件" + ListView1.ListItems(i).Text + "..."
                If FTP1.GetFile(ListView1.ListItems(i).Text, File1.Path) <> ftpSuccess Then MsgBox "Geting '" + ListView1.ListItems(i).Text + "' failed: " + vbNewLine + FTP1.LastError
            End If
        End If
    Next
    File1.Refresh
    Screen.MousePointer = vbDefault
    'StatusBar1.Visible = True
    'ProgressBar1.Visible = False
    StatusBar1.SimpleText = "下载完毕！"
End Sub

Private Sub cmdDeleteFile_Click()
    Dim i As Integer
    If MsgBox("Are you sure you want to delete the selected file(s)?", vbYesNo) = vbYes Then
        Screen.MousePointer = vbHourglass
        For i = 1 To ListView1.ListItems.Count
            If ListView1.ListItems(i).Selected Then
                If ListView1.ListItems(i).Tag = "FILE" Then
                    StatusBar1.SimpleText = "正在删除文件" + ListView1.ListItems(i).Text + "'..."
                    If FTP1.Delete(ListView1.ListItems(i).Text) <> ftpSuccess Then MsgBox "DeleteFile failed: " + vbNewLine + FTP1.LastError
                End If
            End If
        Next
        doDir
        Screen.MousePointer = vbDefault
    End If
End Sub

Private Sub cmdMkDir_Click()
    Dim sNewDir As String
    sNewDir = InputBox("Enter the name of the directory to create:", "MkDir", "")
    If sNewDir <> "" Then
        If FTP1.MkDir(sNewDir) = ftpSuccess Then
            StatusBar1.SimpleText = "创建文件夹"
            doDir
        Else
            StatusBar1.SimpleText = "MkDir failed: " + FTP1.LastError
            MsgBox "MkDir failed: " + vbNewLine + FTP1.LastError
        End If
    End If
End Sub

Private Sub cmdPut_Click()
    Dim i As Integer
    For i = 0 To File1.ListCount - 1
        If File1.Selected(i) Then
            StatusBar1.SimpleText = "正在上载文件" + File1.List(i) + "'"
            If FTP1.PutFile(File1.Path + "\" + File1.List(i), "") <> ftpSuccess Then
                StatusBar1.SimpleText = "Put failed: " + FTP1.LastError
                MsgBox "Put failed: " + vbNewLine + FTP1.LastError
            End If
            doDir
        End If
    Next i
End Sub

Private Sub cmdRenameFile_Click()
    Dim sNewName As String
    If Len(ListView1.SelectedItem.Text) > 0 Then
        If ListView1.SelectedItem.Tag = "FILE" Then
            sNewName = InputBox("请输入新文件名" + ListView1.SelectedItem.Text + "':", "Rename", ListView1.SelectedItem.Text)
            If sNewName <> "" Then
                If FTP1.Rename(ListView1.SelectedItem.Text, sNewName) <> ftpSuccess Then
                    MsgBox "Rename failed: " + vbNewLine + FTP1.LastError
                    StatusBar1.SimpleText = "Rename failed: " + FTP1.LastError
                Else
                    StatusBar1.SimpleText = "Renamed File"
                    doDir
                End If
            End If
        End If
    End If
End Sub

Private Sub cmdRmDir_Click()
    If Len(ListView1.SelectedItem.Text) > 0 Then
        If ListView1.SelectedItem.Tag = "DIR" Then
            If FTP1.RmDir(ListView1.SelectedItem.Text) = ftpSuccess Then
                StatusBar1.SimpleText = "删除文件夹"
                doDir
            Else
                StatusBar1.SimpleText = "RmDir failed: " + FTP1.LastError
                MsgBox "RmDir failed: " + vbNewLine + FTP1.LastError
            End If
        End If
    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 File1_Click()
    cmdPut.Enabled = (File1.ListIndex > -1) And FTP1.Connected
End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
    If Not FTP1.Connected And KeyCode = vbKeyReturn Then cmdConnect_Click
End Sub

Private Sub Form_Load()
    Dim sPort As String
    Me.Caption = Me.Caption '+ " (FTP Version " + FTP1.Version + ")"
    txtServer.Text = GetSetting(App.Title, "Connection", "Server", txtServer.Text)
    txtUser.Text = GetSetting(App.Title, "Connection", "User", txtUser.Text)
    If LCase$(txtUser.Text) = "ftp" Then
        txtPassword.Text = "ftp"
    Else
        txtPassword.Text = ""
    End If
    txtServer.SelStart = 0
    txtServer.SelLength = Len(txtServer.Text)
    sPort = GetSetting(App.Title, "Connection", "Port", txtPort.Text)
    If IsNumeric(sPort) Then txtPort.Text = sPort
    chkUseListStr.Value = GetSetting(App.Title, "General", "UseListStr", chkUseListStr.Value)
    Drive1.Drive = GetSetting(App.Title, "General", "LocalDrive", Drive1.Drive)
    File1.Path = GetSetting(App.Title, "General", "LocalDir", File1.Path)
    StatusBar1.SimpleText = "未连接..."
End Sub

Private Sub ListView1_ColumnClick(ByVal ColumnHeader As ColumnHeader)
    ListView1.SortKey = ColumnHeader.Index - 1
    ListView1.Sorted = True
    If ListView1.SortOrder = lvwAscending Then
        ListView1.SortOrder = lvwDescending
    Else
        ListView1.SortOrder = lvwAscending
    End If
End Sub

Private Sub ListView1_DblClick()
    On Error GoTo GiveUp
    If ListView1.SelectedItem.Tag = "DIR" Then
        FTP1.CD ListView1.SelectedItem.Text
        doDir
    ElseIf ListView1.SelectedItem.Tag = "FILE" Then
        cmdGet_Click
    End If
GiveUp:
End Sub

Private Sub ListView1_ItemClick(ByVal Item As ListItem)
    cmdGet.Enabled = (Item.Tag = "FILE") And FTP1.Connected
    cmdDeleteFile.Enabled = (Item.Tag = "FILE") And FTP1.Connected
    cmdRenameFile.Enabled = (Item.Tag = "FILE") And FTP1.Connected
                            'False
    cmdRmDir.Enabled = (Item.Text <> "..") And (Item.Tag = "DIR") And FTP1.Connected
End Sub

Private Sub ListView1_KeyUp(KeyCode As Integer, Shift As Integer)
    Select Case KeyCode
        Case vbKeyReturn
            ListView1_DblClick
        Case vbKeyBack
            FTP1.CD ".."
            doDir
    End Select
End Sub

Private Sub txtServer_GotFocus()
    txtServer.SelStart = 0
    txtServer.SelLength = Len(txtServer.Text)
End Sub

Private Sub txtPort_GotFocus()
    txtPort.SelStart = 0
    txtPort.SelLength = Len(txtPort.Text)
End Sub

Private Sub txtUser_GotFocus()
    txtUser.SelStart = 0
    txtUser.SelLength = Len(txtUser.Text)
End Sub

Private Sub txtPassword_GotFocus()
    txtPassword.SelStart = 0
    txtPassword.SelLength = Len(txtPassword.Text)
End Sub

Private Sub cmdApplyWildCard_Click()
    FTP1.WildCard = txtWildCard.Text
    doDir
End Sub

Private Sub txtWildCard_Change()
    cmdApplyWildCard.Enabled = True
End Sub