fmvbftpjr.frm

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

    If hFind = 0 Then
        If (nLastError = ERROR_NO_MORE_FILES) Then '此目录是空的

        End If
        Exit Sub
    End If
    
    dError = NO_ERROR

    strItemName = Left(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)

    If pData.dwFileAttributes = FILE_ATTRIBUTE_DIRECTORY Then
        If strItemName <> "." And strItemName <> ".." Then
            EnumFilePath.Add strItemName
            EnumUpFile(1).Add strDirectory & "\" & strItemName
            EnumUpFile(2).Add "Path"
        End If
    Else
        EnumUpFile(1).Add strDirectory & "\" & strItemName
        EnumUpFile(2).Add "File"
    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 strItemName <> "." And strItemName <> ".." Then
                If pData.dwFileAttributes = FILE_ATTRIBUTE_DIRECTORY Then
                    EnumFilePath.Add strItemName
                    EnumUpFile(1).Add strDirectory & "\" & strItemName
                    EnumUpFile(2).Add "Path"
                Else
                    EnumUpFile(1).Add strDirectory & "\" & strItemName
                    EnumUpFile(2).Add "File"
                    szFileLocal = ls_PathOld & Mid(strDirectory, Len(ls_PathSrvOld) + 1) & "\" & strItemName
                    szFileRemote = strDirectory & "\" & strItemName
                End If
                
                DoEvents
            End If
        End If
    Loop

    InternetCloseHandle (hFind)

    For i = 1 To EnumFilePath.Count
        ShowFloderSrvDelete (strDirectory & "\" & EnumFilePath.Item(i))
    Next
    
    For i = 1 To EnumFilePath.Count
        EnumFilePath.Remove 1
    Next
    
    Set EnumFilePath = Nothing
End Sub

Private Sub cmbPathSrv_Click()
On Error Resume Next
    ls_PathSrv = cmbPathSrv.Text
    txtPathSrv.Text = ls_PathSrv
    FtpEnumDirectory (ls_PathSrv)
    FillListViewControl ("")
End Sub

Private Sub cmbPathSrv_GotFocus()
On Error Resume Next
    lvPathSrv_GotFocus
End Sub

Private Sub Drive1_GotFocus()
On Error Resume Next
    lvPath_GotFocus
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
On Error Resume Next
    If KeyCode = vbKeyF5 Then
        If txtPathLocal.BackColor = vbBlue Then
            mnuResreshs_Click
        ElseIf txtPathSrv.BackColor = vbBlue Then
            mnuRefresh_Click
        End If
    ElseIf KeyCode = vbKeyF2 Then
        If txtPathLocal.BackColor = vbBlue Then
            lvPath.StartLabelEdit
        ElseIf txtPathSrv.BackColor = vbBlue Then
            lvPathSrv.StartLabelEdit
        End If
    End If
End Sub

Private Sub Form_Load()
On Error GoTo Errhandle
    Screen.MousePointer = 11
    '-----------------------
    If UCase(ls_User) <> "ADMIN" Then
        mnuResSet.Enabled = False
        mnuUserManage.Enabled = False
        mnuCode.Enabled = False
    End If
    '-----------------------
    bActiveSession = False
    hOpen = 0
    hConnection = 0
    chkPassive.Value = 1
    optBin.Value = 1
    dwType = FTP_TRANSFER_TYPE_BINARY
    PicSep.BackColor = &H8000000F
    picSeps.BackColor = &H8000000F
    EnableUI (False)
    StartSession 'Start Internet Sessions
    ChDrive Left(Drive1.Drive, 2)
    ChDir Left(Drive1.Drive, 2) & "\"
    Dir1.path = CurDir
    ChangePath ""
    txtPathLocal = Dir1.path
    cmbPathSrv.AddItem "\"
    Screen.MousePointer = 0

    Exit Sub
Errhandle:
    Screen.MousePointer = 0
    ErrView Err.Description
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
On Error Resume Next
    CloseSession    '关闭 Internew 连接
    ClearBag        '清除集合内容
    ClearUpFileBag  '清除集合内容
    
    '将集合变量销毁，清空内存
    Set EnumItemNameBag = Nothing
    Set EnumItemAttributeBag = Nothing
    Set EnumUpFile(1) = Nothing
    Set EnumUpFile(2) = Nothing
    Set EnumItemDate = Nothing
    Set EnumItemSize = Nothing
End Sub

Private Sub Form_Resize()
On Error Resume Next
    lvPath.Width = Me.Width / 2 - 100
    lvPathSrv.Width = Me.Width / 2 - 100
    lvPath.Height = Me.Height - lstStatus.Height - 1730
    lvPathSrv.Height = lvPath.Height
    PicSep.Left = lvPath.Left + lvPath.Width - 10
    lvPathSrv.Left = PicSep.Left + PicSep.Width - 10
    PicSep.Height = Me.Height - lstStatus.Height - 1000
    txtPathLocal.Width = lvPath.Width
    txtPathSrv.Left = lvPathSrv.Left
    txtPathSrv.Width = lvPathSrv.Width
    Drive1.Width = lvPath.Width - 430
    Toolbar1.Left = Drive1.Left + Drive1.Width + 60
    cmbPathSrv.Left = lvPathSrv.Left
    cmbPathSrv.Width = lvPathSrv.Width - 430
    Toolbar2.Left = cmbPathSrv.Left + cmbPathSrv.Width + 70
    picSeps.Top = lvPath.Top + lvPath.Height
    picSeps.Width = Me.Width - 180
    lstStatus.Top = picSeps.Top + 60
    lstStatus.Width = picSeps.Width
    fmeLine.Width = Me.Width - 10
End Sub

Private Sub cmdInternetOpen_Click()
On Error GoTo Errhandle
    Screen.MousePointer = 11
    If Len(txtProxy.Text) <> 0 Then
        hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_PROXY, txtProxy.Text, vbNullString, 0)
    Else
        hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)
    End If
    If hOpen = 0 Then ErrorOut Err.LastDllError, "InternetOpen"
    EnableUI (True)
    Screen.MousePointer = 0
    
    Exit Sub
Errhandle:
    Screen.MousePointer = 0
    ErrView Err.Description
End Sub

Private Sub ClearTextBoxAndBag()
On Error Resume Next
    txtProxy.Text = ""
    ClearBag
End Sub

Private Sub ClearBag()
On Error Resume Next
    Dim Num As Integer
    
    For Num = 1 To EnumItemNameBag.Count
        EnumItemNameBag.Remove 1
        EnumItemAttributeBag.Remove 1
        EnumItemSize.Remove 1
        EnumItemDate.Remove 1
    Next Num
End Sub

Private Sub ClearUpFileBag()
On Error Resume Next
    Dim Num As Integer
    
    For Num = 1 To EnumUpFile(1).Count
        EnumUpFile(1).Remove 1
    Next Num
    
    For Num = 1 To EnumUpFile(2).Count
        EnumUpFile(2).Remove 1
    Next Num
End Sub

'添充LISTVIEW控件内容
Private Sub FillListViewControl(strParentKey As String)
On Error GoTo Errhandle
    Dim Item As ListItem
    Dim strImg As String
    Dim nCount As Integer, i As Integer, nAttr As Integer, k As Long
    Dim strItem As String, ls_FilePath, ls_Icon As String
    
    lvPathSrv.ListItems.Clear
    nCount = EnumItemAttributeBag.Count
    If nCount = 0 Then Exit Sub

    Screen.MousePointer = 11
    For i = 1 To nCount
        nAttr = EnumItemAttributeBag.Item(i)
        strItem = EnumItemNameBag(i)
        
        If strItem <> "." And strItem <> ".." Then
            If nAttr = FILE_ATTRIBUTE_DIRECTORY Then
                Set Item = lvPathSrv.ListItems.Add(, , strItem, "Path", "Path")
                Item.ListSubItems.Add , , ""
                Item.ListSubItems.Add , , "文件夹"
                Item.ListSubItems.Add , , EnumItemDate.Item(i)
            Else
                k = 0
                strImg = UCase(Right(strItem, 3))
                Set Item = lvPathSrv.ListItems.Add(, , strItem, , strImg)
                ls_FilePath = strItem
                Item.ListSubItems.Add , , EnumItemSize.Item(i)
                Item.ListSubItems.Add , , "文件"
                Item.ListSubItems.Add , , EnumItemDate.Item(i)
            End If
        End If
    Next
    Screen.MousePointer = 0
    
    Exit Sub
Errhandle:
    Screen.MousePointer = 0
    If Err.Number = 35601 Then
        k = k + 1
        If k = 1 Then
            strImg = UCase(Right(strItem, 2))
        ElseIf k = 2 Then
            strImg = UCase(Right(strItem, 1))
        ElseIf k >= 3 Then
            strImg = "NO"
        End If

        Resume
    Else
        Resume Next
    End If
End Sub

Private Sub Dir1_Change()
On Error GoTo Errhandle
  File1.path = Dir1.path
  
  Exit Sub
Errhandle:
  ErrView Err.Description
End Sub

Private Sub Drive1_Change()
On Error GoTo ErrProc
    ChDrive Left(Drive1.Drive, 2)
    ChDir Left(Drive1.Drive, 2) & "\"
    Dir1.path = Drive1.Drive
    txtPathLocal.Text = Dir1.path
    lvPath.Tag = Dir1.path
    
    ChangePath ""
    
    Exit Sub
ErrProc:
    If Err.Number = 68 Then
        MsgBox "对不起，驱动器没有准备好！", vbExclamation
    Else
        ErrView Err.Description
    End If
    Drive1.Drive = Dir1.path
End Sub

'设置当前路径
Private Function rcd(pszDir As String) As Boolean
On Error GoTo Errhandle
    If pszDir = "" Then
        MsgBox "Please enter the directory to CD"
        Exit Function
    Else
        Dim sPathFromRoot As String
        Dim bRet As Boolean
        
        If InStr(1, pszDir, ls_HostName) Then
          sPathFromRoot = Mid(pszDir, Len(ls_HostName) + 1, Len(pszDir) - Len(ls_HostName))
        Else
          sPathFromRoot = pszDir
        End If

        If sPathFromRoot = "" Then sPathFromRoot = "/"

        bRet = FtpSetCurrentDirectory(hConnection, sPathFromRoot)

        If bRet = False Then
            rcd = False
        Else
            rcd = True
        End If
    End If
    
    Exit Function
Errhandle:
    ErrView Err.Description
End Function

Function ErrorOut(dError As Long, szCallFunction As String)
On Error Resume Next
    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, vbExclamation
    End If
    
Exit Function
    
    If MsgBox(szCallFunction & " Err: " & dError & vbCrLf & "Close Connection and Session?", vbExclamation + vbYesNo) = vbYes Then
        If hConnection Then InternetCloseHandle hConnection
        If hOpen Then InternetCloseHandle hOpen
        hConnection = 0
        hOpen = 0

        bActiveSession = False
        ClearTextBoxAndBag
        EnableUI (False)
    End If
End Function

Private Sub EnableUI(bEnabled As Boolean)
On Error Resume Next
    Toolbar3.Buttons("Connect").Enabled = bEnabled And Not bActiveSession
    Toolbar3.Buttons("DisConnect").Enabled = bEnabled And bActiveSession
    chkPassive.Enabled = bEnabled
    txtProxy.Enabled = Not bEnabled
    optBin.Enabled = bEnabled
    optAscii.Enabled = bEnabled
    Toolbar3.Buttons("Down").Enabled = bEnabled And bActiveSession
    Toolbar3.Buttons("Up").Enabled = bEnabled And bActiveSession
End Sub

Private Sub FtpEnumDirectory(strDirectory As String)
On Error GoTo Errhandle
    ClearBag
    Dim hFind As Long, i As Long
    Dim nLastError As Long
    Dim dError As Long
    Dim ptr As Long
    Dim pData As WIN32_FIND_DATA