fmvbftpjr.frm

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

        Else
            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
        End If

        .hwnd = Me.hwnd
        .wFunc = FO_DELETE
        .pFrom = sfile & vbNullChar & vbNullChar
        result = SHFileOperation(fileop)
        
        If result <> 0 Then
            MsgBox "对不起，操作失败！", vbExclamation
        Else
            If fileop.fAnyOperationsAborted <> 0 Then
                MsgBox "对不起，操作失败！", vbExclamation
            End If
        End If
        DoEvents
    End With
    
    DoEvents
    mnuResreshs_Click
    Exit Sub
    
Errhandle:
    ErrView Err.Description
End Sub

Private Sub mnuMoveDir_Click()
On Error GoTo Errhandle
    Dim i As Long
    Dim r As Long, t As Long
    Dim hWndDesk As Long
    Dim sfile As String
    Dim params As String
    Dim result As Long, fileop As SHFILEOPSTRUCT
    
    Dim bi As BROWSEINFO
    Dim rtn&, pidl&, path$, pos%
    
    bi.hOwner = Me.hwnd
    bi.lpszTitle = "请选择目标文件夹..."
    bi.ulFlags = BIF_RETURNONLYFSDIRS
    pidl& = SHBrowseForFolder(bi)
    path = Space(255)
    t = SHGetPathFromIDList(ByVal pidl&, ByVal path)

    If t = 0 Then Exit Sub
    
    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
                    sfile = sfile & IIf(sfile = "", "", Chr(0)) & txtPathLocal.Text & lvPath.ListItems(i).Text
                End If
            Next
        Else
            For i = 1 To lvPath.ListItems.Count
                If lvPath.ListItems(i).Selected Then
                    sfile = sfile & IIf(sfile = "", "", Chr(0)) & txtPathLocal.Text & "\" & lvPath.ListItems(i)
                End If
            Next
        End If

        .hwnd = Me.hwnd
        .wFunc = FO_MOVE
        .pFrom = sfile & vbNullChar & vbNullChar
        path = Space(512)
        t = SHGetPathFromIDList(ByVal pidl&, ByVal path)

        Dim SpecIn, SpecOut
        
        pos% = InStr(path$, Chr$(0))
        SpecIn = Left(path$, pos - 1)
        If Right$(SpecIn, 1) = "\" Then
            SpecOut = SpecIn
        Else
            SpecOut = SpecIn + "\"
        End If
        
        .pTo = SpecOut & vbNullChar & vbNullChar
        result = SHFileOperation(fileop)
        
        If result <> 0 Then
            MsgBox "对不起，操作失败！", vbExclamation
        Else
            If fileop.fAnyOperationsAborted <> 0 Then
                MsgBox "对不起，操作失败！", vbExclamation
            End If
        End If
        DoEvents
    End With
    
    DoEvents
    mnuResreshs_Click
    Exit Sub
    
Errhandle:
    ErrView Err.Description
End Sub

Private Sub mnuNew_Click()
On Error GoTo Errhandle
    If hConnection = 0 Then Exit Sub

    mnuNew.Tag = "New"

    lvPathSrv.ListItems.Add(, , GetNewFolder, "Path", "Path").Selected = True
    lvPathSrv.StartLabelEdit

    Exit Sub
Errhandle:
    ErrView Err.Description
End Sub

Private Sub mnuNews_Click()
On Error GoTo Errhandle
    Dim ls_Folder As String, i As Long
    
    mnuNews.Tag = "News"
    ls_Folder = "新建文件夹"

    If Dir(txtPathLocal.Text & "\" & ls_Folder, vbDirectory) <> "" Then
        For i = 2 To 100
            ls_Folder = "新建文件夹 (" & i & ")"
            If Dir(txtPathLocal.Text & "\" & ls_Folder, vbDirectory) = "" Then Exit For
        Next
    End If
    
    lvPath.ListItems.Add(, , ls_Folder, "Path", "Path").Selected = True
    lvPath.StartLabelEdit
  
  Exit Sub
Errhandle:
  ErrView Err.Description
End Sub

Private Sub mnuProperty_Click()
On Error GoTo Errhandle
    Dim i As Long, ll_Rtn As Long, ls_FileName As String
    Dim lv_Item As ListItem
    
    Set lv_Item = lvPath.SelectedItem
    
    If lv_Item Is Nothing Then Exit Sub
    
    If lvPath.SelectedItem.Icon = "Path" Then
        If Right(txtPathLocal.Text, 1) = "\" Then
            ll_Rtn = ShowFileProperties(txtPathLocal.Text & lv_Item.Text, Me.hwnd)   'To show the properties dialog pass the filename and the owner of the dialog
        Else
            ll_Rtn = ShowFileProperties(txtPathLocal.Text & "\" & lv_Item.Text, Me.hwnd)   'To show the properties dialog pass the filename and the owner of the dialog
        End If
    
        If ll_Rtn <= 32 Then MsgBox "出现错误！", vbExclamation
    Else
        If Right(File1.path, 1) = "\" Then
            For i = 1 To lvPath.ListItems.Count
                If lvPath.ListItems(i).Selected Then
                    ls_FileName = ls_FileName & IIf(ls_FileName = "", "", Chr(0)) & File1.path & lvPath.ListItems(i).Text
                End If
            Next
        Else
            For i = 1 To lvPath.ListItems.Count
                If lvPath.ListItems(i).Selected Then
                    ls_FileName = ls_FileName & IIf(ls_FileName = "", "", Chr(0)) & File1.path & "\" & lvPath.ListItems(i).Text
                End If
            Next
        End If
        ll_Rtn = ShowFileProperties(ls_FileName, Me.hwnd)    'To show the properties dialog pass the filename and the owner of the dialog
        If ll_Rtn <= 32 Then MsgBox "出现错误！", vbExclamation
    End If
    
    Exit Sub
Errhandle:
    ErrView Err.Description
End Sub

Private Sub mnuRefresh_Click()
On Error Resume Next
    RefreshListView
End Sub

Private Sub mnuRename_Click()
On Error GoTo Errhandle
    mnuNew.Tag = "Rename"
    lvPathSrv.StartLabelEdit

    Exit Sub
Errhandle:
    ErrView Err.Description
End Sub

Private Sub mnuRenames_Click()
On Error GoTo Errhandle
    mnuNews.Tag = "Rename"
    lvPath.StartLabelEdit
    
    Exit Sub
Errhandle:
    ErrView Err.Description
End Sub

Private Sub mnuResreshs_Click()
On Error GoTo Errhandle
    Dir1.Refresh
    File1.Refresh
    ChangePath ""
    
    Exit Sub
Errhandle:
  ErrView Err.Description
End Sub


Private Sub optAscii_Click()
On Error Resume Next
    dwType = FTP_TRANSFER_TYPE_ASCII
End Sub

Private Sub optBin_Click()
On Error Resume Next
    dwType = FTP_TRANSFER_TYPE_BINARY
End Sub

Private Function StartSession()
On Error GoTo Errhandle
  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)
  
  Exit Function
Errhandle:
  ErrView Err.Description
End Function

Private Function CloseSession()
On Error GoTo Errhandle
  If hConnection <> 0 Then InternetCloseHandle (hConnection)
  If hOpen <> 0 Then InternetCloseHandle (hOpen)
  hConnection = 0
  hOpen = 0
  If bActiveSession Then lvPathSrv.ListItems.Clear
  bActiveSession = False
  ClearTextBoxAndBag
  EnableUI (False)
  
  Exit Function
Errhandle:
  ErrView Err.Description
End Function

'如果目录下有多个新建文件夹，取得新建文件的最大号
Private Function GetNewFolder() As String
On Error Resume Next
    Dim i As Long, ll_Index, ll_Num
    Dim ls_FileName As String
    
    For i = 1 To EnumItemNameBag.Count
        If EnumItemAttributeBag.Item(i) = FILE_ATTRIBUTE_DIRECTORY Then
            ls_FileName = EnumItemNameBag.Item(i)
            If Left(ls_FileName, 5) = "新建文件夹" Then
                ll_Index = InStr(ls_FileName, "(")
                If ll_Index <> 0 Then
                    ls_FileName = Mid(ls_FileName, ll_Index + 1)
                    If ll_Num < CInt(Left(ls_FileName, Len(ls_FileName) - 1)) Then
                      ll_Num = CInt(Left(ls_FileName, Len(ls_FileName) - 1))
                    End If
                Else
                    ll_Num = 1
                End If
            End If
        End If
    Next
    
    If ll_Num = 0 Then
      GetNewFolder = "新建文件夹"
    Else
      GetNewFolder = "新建文件夹 (" & ll_Num + 1 & ")"
    End If
End Function

'改变路径,并添加到本地目录列表框中
Private Sub ChangePath(ByVal strPath As String)
On Error GoTo Errhandle
    Dim Item As ListItem
    Dim i As Long, k As Long
    Dim ls_FilePath As String, ls_Icon As String
    
    If strPath <> "" Then Dir1.path = strPath
    lvPath.ListItems.Clear
    For i = 0 To Dir1.ListCount - 1
        Set Item = lvPath.ListItems.Add(, , GetPath(Dir1.List(i)), "Path", "Path")

        Item.ListSubItems.Add , , ""
        Item.ListSubItems.Add , , "文件夹"
        Item.ListSubItems.Add , , Format(FileDateTime(Dir1.List(i)), "YYYY-MM-DD HH:MM")
    Next i
    For i = 0 To File1.ListCount - 1
        k = 0
        ls_Icon = UCase(Right(File1.List(i), 3))
        Set Item = lvPath.ListItems.Add(, , File1.List(i), , ls_Icon)

        ls_FilePath = Dir1.path & "\" & File1.List(i)
        Item.ListSubItems.Add , , Format(FileLen(ls_FilePath) / 1000, "0KB")
        Item.ListSubItems.Add , , "文件"
        Item.ListSubItems.Add , , Format(FileDateTime(ls_FilePath), "YYYY-MM-DD HH:MM")
    Next i
    
    Exit Sub
Errhandle:
    If Err.Number = 35601 Then
        k = k + 1
        If k = 1 Then
            ls_Icon = UCase(Right(File1.List(i), 2))
        ElseIf k = 2 Then
            ls_Icon = UCase(Right(File1.List(i), 1))
        ElseIf k >= 3 Then
            ls_Icon = "NO"
        End If

        Resume
    Else
        Resume Next
    End If
End Sub

'从后往前数,取第一个"\"号后面的路径
Private Function GetPath(ByVal StrLongPath As String) As String
On Error GoTo Errhandle
    If Len(StrLongPath) < 4 Then
      GetPath = ""
      Exit Function
    End If
    
    StrLongPath = StrReverse(StrLongPath)
    
    StrLongPath = Left(StrLongPath, InStr(StrLongPath, "\") - 1)
    GetPath = StrReverse(StrLongPath)
    
    Exit Function
Errhandle:
    ErrView Err.Description
End Function

'从后往前数,取第一个"\"号前面的路径
Private Function GetPaths(ByVal StrLongPath As String) As String
On Error GoTo Errhandle
    If Len(StrLongPath) < 4 Then Exit Function
    
    If Right(StrLongPath, 1) = "\" Then StrLongPath = Left(StrLongPath, Len(StrLongPath) - 1)
    StrLongPath = StrReverse(StrLongPath)
    
    StrLongPath = Mid(StrLongPath, InStr(StrLongPath, "\"))
    GetPaths = StrReverse(StrLongPath)
    
    Exit Function
Errhandle:
    ErrView Err.Description
End Function

'刷新文件视窗
Private Function RefreshListView()
On Error Resume Next
    FtpEnumDirectory (".")
    FillListViewControl ("")
End Function

Private Sub PicSep_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error Resume Next
    SetCapture PicSep.hwnd
    If Button = vbLeftButton Then PicSep.BackColor = &H808080
End Sub

Private Sub PicSep_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error Resume Next
    If Button = vbLeftButton Then
        If PicSep.Left >= (1600 - X) And PicSep.Left <= (Me.Width - 1600 -