fmvbftpjr.frm

用VB实现的非常全面的FTP管理工具源码

    Dim EnumItemFile As New Collection, EnumItemPath As New Collection, EnumItemFileDate As New Collection, EnumItemPathDate As New Collection, EnumItemFileSize As New Collection

    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 '此目录是空的
            
        Else
            ErrorOut nLastError, "FtpFindFirstFile"
        End If
        Exit Sub
    End If
    
    dError = NO_ERROR
    Dim bRet As Boolean
    Dim strItemName As String

    strItemName = Left(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
    If pData.dwFileAttributes = FILE_ATTRIBUTE_DIRECTORY Then
        EnumItemPath.Add strItemName
        EnumItemPathDate.Add vbGetFileDate(pData.ftLastWriteTime)
    Else
        EnumItemFile.Add strItemName
        EnumItemFileDate.Add vbGetFileDate(pData.ftLastWriteTime)
        EnumItemFileSize.Add vbGetFileSizeKBStr(pData.nFileSizeHigh + pData.nFileSizeLow)
    End If

    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
            strItemName = Left(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
            If pData.dwFileAttributes = FILE_ATTRIBUTE_DIRECTORY Then
                EnumItemPath.Add strItemName
                EnumItemPathDate.Add vbGetFileDate(pData.ftLastWriteTime)
            Else
                EnumItemFile.Add strItemName
                EnumItemFileDate.Add vbGetFileDate(pData.ftLastWriteTime)
                EnumItemFileSize.Add vbGetFileSizeKBStr(pData.nFileSizeHigh + pData.nFileSizeLow)
            End If
       End If
    Loop

    For i = 1 To EnumItemPath.Count
        EnumItemNameBag.Add EnumItemPath.Item(i)
        EnumItemAttributeBag.Add FILE_ATTRIBUTE_DIRECTORY
        EnumItemDate.Add EnumItemPathDate.Item(i)
        EnumItemSize.Add ""
    Next
    
    For i = 1 To EnumItemFile.Count
        EnumItemNameBag.Add EnumItemFile.Item(i)
        EnumItemAttributeBag.Add FILE_ATTRIBUTE_NORMAL
        EnumItemDate.Add EnumItemFileDate.Item(i)
        EnumItemSize.Add EnumItemFileSize.Item(i)
    Next

    Set EnumItemFile = Nothing
    Set EnumItemPath = Nothing
    Set EnumItemPathDate = Nothing
    Set EnumItemFileDate = Nothing
    Set EnumItemFileSize = Nothing
    InternetCloseHandle (hFind)

    Exit Sub
Errhandle:
'    ErrView Err.Description
End Sub


Private Sub lvPath_AfterLabelEdit(Cancel As Integer, NewString As String)
On Error GoTo Errhandle
    Dim hWndDesk As Long
    Dim sFromFile As String, sToFile As String
    Dim params As String
    Dim result As Long
    Dim lReturn As Long, fileop As SHFILEOPSTRUCT

    If lvPath.SelectedItem Is Nothing Then Exit Sub
    
    If mnuNews.Tag = "News" Then
        RmDir txtPathLocal.Text & "\" & lvPath.SelectedItem.Text
        MkDir txtPathLocal.Text & "\" & NewString
        Dir1.Refresh
    Else
        With fileop
            params = vbNullString
            hWndDesk = GetDesktopWindow()
            
            If Right(txtPathLocal.Text, 1) = "\" Then
                sFromFile = txtPathLocal.Text & lvPath.SelectedItem.Text
                sToFile = txtPathLocal.Text & NewString
            Else
                sFromFile = txtPathLocal.Text & "\" & lvPath.SelectedItem.Text
                sToFile = txtPathLocal.Text & "\" & NewString
            End If
    
            .hwnd = Me.hwnd
            .wFunc = FO_RENAME
            .pFrom = sFromFile & vbNullChar & vbNullChar
            .pTo = sToFile & vbNullChar & vbNullChar
            result = SHFileOperation(fileop)
            
            If result <> 0 Then
                '操作失败
            Else
                If fileop.fAnyOperationsAborted <> 0 Then
                    MsgBox "对不起，操作失败！", vbExclamation
                End If
            End If
            DoEvents
        End With
    End If
    DoEvents
    mnuResreshs_Click
    
    Exit Sub
Errhandle:
    ErrView Err.Description
End Sub

Private Sub lvPath_BeforeLabelEdit(Cancel As Integer)
On Error Resume Next
    MkDir txtPathLocal.Text & "\" & lvPath.SelectedItem.Text
End Sub

Private Sub lvPath_DblClick()
On Error GoTo Errhandle
    If lvPath.SelectedItem.Icon <> "Path" Then Exit Sub
    
    Screen.MousePointer = 11
    ChangePath lvPath.SelectedItem.Text
    lvPath.Tag = Dir1.path
    txtPathLocal = Dir1.path
    Screen.MousePointer = 0
    
    Exit Sub
Errhandle:
    Screen.MousePointer = 0
    ErrView Err.Description
End Sub

Private Sub lvPath_GotFocus()
On Error Resume Next
    txtPathLocal.BackColor = vbBlue
    txtPathLocal.ForeColor = vbWhite
    txtPathSrv.BackColor = &H8000000F
    txtPathSrv.ForeColor = vbBlack
End Sub

Private Sub lvPath_KeyDown(KeyCode As Integer, Shift As Integer)
On Error Resume Next
    If KeyCode = vbKeyDelete Then
        mnuDeletes_Click
    ElseIf KeyCode = vbKeyReturn Then
        lvPath_DblClick
    End If
End Sub

Private Sub lvPath_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error Resume Next
'     If lvPath.SelectedItem.Selected Then
'        lvPath.SelectedItem.Selected = False
'     End If
End Sub

Private Sub lvPath_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error Resume Next
    If Button = vbRightButton Then PopupMenu mnuPopupLocal
    
'    Dim mlvRip As MSComctlLib.ListItem, i As Long
'    With lvPath
'        Set mlvRip = .HitTest(x, Y)
'        If mlvRip Is Nothing Then
'            For i = 1 To .ListItems.Count
'                .ListItems(i).Selected = False
'            Next i
'            'If Button = 2 Then mAb.Bands("bpFileNoSel").PopupMenu
'        Else
'            'If Button = 2 Then mAb.Bands("bpFileSel").PopupMenu
'        End If
'    End With
End Sub

Private Sub lvPath_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error Resume Next
    If lvPath.Tag = "False" Then Call DownFileAndPath
End Sub

Private Sub lvPath_OLEStartDrag(Data As MSComctlLib.DataObject, AllowedEffects As Long)
On Error Resume Next
    lvPath.Tag = "True"
    lvPathSrv.Tag = "False"
End Sub

Private Sub lvPathSrv_AfterLabelEdit(Cancel As Integer, NewString As String)
On Error GoTo Errhandle
    If mnuNew.Tag = "New" Then
        Call FtpRemoveDirectory(hConnection, txtPathSrv.Text & "\" & lvPathSrv.SelectedItem.Text)
        If FtpCreateDirectory(hConnection, txtPathSrv.Text & "\" & NewString) <> 1 Then
            MsgBox "创建文件夹失败，文件夹名称可能存在！", vbExclamation
            'lvPathSrv.SelectedItem.Text = lvPathSrv.SelectedItem.Text
            'lvPathSrv.StartLabelEdit
        End If
    Else
        If FtpRenameFile(hConnection, txtPathSrv.Text & "\" & lvPathSrv.SelectedItem.Text, txtPathSrv.Text & "\" & NewString) <> 1 Then
            MsgBox "重命名文件夹失败，文件夹名称可能存在！", vbExclamation
            'lvPathSrv.SelectedItem.Text = lvPathSrv.SelectedItem.Text
            'lvPathSrv.StartLabelEdit
        End If
    End If

    DoEvents
    mnuRefresh_Click
    
    Exit Sub
Errhandle:
    ErrView Err.Description
End Sub

Private Sub lvPathSrv_BeforeLabelEdit(Cancel As Integer)
On Error Resume Next
    Call FtpCreateDirectory(hConnection, txtPathSrv.Text & "\" & lvPathSrv.SelectedItem.Text)
    FtpEnumDirectory (".")
End Sub

Private Sub lvPathSrv_DblClick()
On Error GoTo Errhandle
    Dim lvItem As ListItem, ls_FindString As String, ll_Rtn As Long
    
    Set lvItem = lvPathSrv.SelectedItem

    If Not bActiveSession Or lvItem Is Nothing Then Exit Sub
    
    If lvItem.Icon <> "Path" Then Exit Sub
    Screen.MousePointer = 11
    
    If lvPathSrv.SelectedItem.Icon = "Path" Then
        ls_PathSrv = ls_PathSrv & IIf(Right(ls_PathSrv, 1) = "\", "", "\") & lvPathSrv.SelectedItem.Text
    End If
    
    ls_FindString = ls_PathSrv & Chr(0)
    ll_Rtn = SendMessage(cmbPathSrv.hwnd, CB_FINDSTRINGEXACT, -1, ByVal ls_FindString)
    If ll_Rtn = -1 Then
        cmbPathSrv.AddItem ls_PathSrv
        cmbPathSrv.ListIndex = cmbPathSrv.ListCount - 1
    Else
        cmbPathSrv.ListIndex = ll_Rtn
    End If
    
    txtPathSrv.Text = ls_PathSrv
    'FtpEnumDirectory (lvItem.Text)
    'FillListViewControl ("")
    Screen.MousePointer = 0
    
    Exit Sub
Errhandle:
    Screen.MousePointer = 0
    ErrView Err.Description
End Sub

Private Sub lvPathSrv_GotFocus()
On Error Resume Next
    txtPathLocal.BackColor = &H8000000F
    txtPathLocal.ForeColor = vbBlack
    txtPathSrv.BackColor = vbBlue
    txtPathSrv.ForeColor = vbWhite
End Sub

Private Sub lvPathSrv_KeyDown(KeyCode As Integer, Shift As Integer)
On Error Resume Next
    If KeyCode = vbKeyDelete Then
        mnuDelete_Click
    ElseIf KeyCode = vbKeyReturn Then
        lvPathSrv_DblClick
    End If
End Sub

Private Sub lvPathSrv_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error Resume Next
    If Button = vbRightButton Then PopupMenu mnuPopupSrv
End Sub

Private Sub lvPathSrv_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error Resume Next
    If lvPathSrv.Tag = "False" And bActiveSession Then UpFileAndPath
End Sub

Private Sub lvPathSrv_OLEStartDrag(Data As MSComctlLib.DataObject, AllowedEffects As Long)
On Error Resume Next
    lvPathSrv.Tag = "True"
    lvPath.Tag = "False"
End Sub

Private Sub mnuComment_Click()
On Error GoTo Errhandle
    Dim Item As ListItem
    
    Set Item = lvPathSrv.SelectedItem
    If Item Is Nothing Then Exit Sub

    If Item.Icon = "Path" Then
        Me.Tag = "Path" & ls_PathSrv & IIf(Right(ls_PathSrv, 1) = "\", "", "\") & Item.Text
    Else
        Me.Tag = "File" & ls_PathSrv & IIf(Right(ls_PathSrv, 1) = "\", "", "\") & Item.Text
    End If
    
    Exit Sub
Errhandle:
    ErrView Err.Description
End Sub

Private Sub mnuDelete_Click()
On Error GoTo Errhandle
    Dim i As Long, j As Long
    
    If lvPathSrv.SelectedItem Is Nothing Then Exit Sub
    
    If MsgBox("确定要删除所选择的全部内容吗？", vbQuestion + vbYesNo) = vbYes Then
        lstStatus.AddItem "━━删除操作━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ """
        For i = 1 To lvPathSrv.ListItems.Count
            If lvPathSrv.ListItems(i).Selected Then
                If lvPathSrv.ListItems(i).Icon = "Path" Then
                    ClearUpFileBag
                    ShowFloderSrvDelete ls_PathSrv & IIf(Right(ls_PathSrv, 1) = "\", "", "\") & lvPathSrv.ListItems(i).Text
                    For j = 1 To EnumUpFile(1).Count
                        lstStatus.AddItem EnumUpFile(1).Item(j) & " == " & EnumUpFile(2).Item(j)
                        lstStatus.Selected(lstStatus.ListCount - 1) = True
                    Next
                    
                    For j = EnumUpFile(1).Count To 1 Step -1
                        If EnumUpFile(2).Item(j) = "Path" Then
                            Call FtpRemoveDirectory(hConnection, EnumUpFile(1).Item(j))
                        Else
                            Call FtpDeleteFile(hConnection, EnumUpFile(1).Item(j))
                        End If
                        DoEvents
                    Next
                    FtpRemoveDirectory hConnection, ls_PathSrv & IIf(Right(ls_PathSrv, 1) = "\", "", "\") & lvPathSrv.ListItems(i).Text
                Else
                    FtpDeleteFile hConnection, lvPathSrv.ListItems(i).Text
                    lstStatus.AddItem lvPathSrv.ListItems(i).Text
                    lstStatus.Selected(lstStatus.ListCount - 1) = True
                End If
            End If
        Next
    End If
    mnuRefresh_Click
    
    Exit Sub
Errhandle:
    ErrView Err.Description
End Sub

Private Sub mnuDeletes_Click()
On Error GoTo Errhandle
    Dim lv_Item As ListItem, i As Long
    Dim hWndDesk As Long
    Dim sfile As String
    Dim params As String
    Dim result As Long
    Dim lReturn As Long, fileop As SHFILEOPSTRUCT
    
    With fileop
        params = vbNullString
        hWndDesk = GetDesktopWindow()
        
        If Right(txtPathLocal.Text, 1) = "\" Then
            For i = 1 To lvPath.ListItems.Count
                If lvPath.ListItems(i).Selected Then
                    Set lv_Item = lvPath.ListItems(i)

                    sfile = sfile & IIf(sfile = "", "", Chr(0)) & txtPathLocal.Text & lv_Item.Text
                End If
            Next