form1.frm

VB源码,是初学者的福因.让你很快掌握VB编程

VERSION 5.00
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX"
Begin VB.Form form1 
   Caption         =   "Form1"
   ClientHeight    =   3525
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4815
   LinkTopic       =   "Form1"
   ScaleHeight     =   3525
   ScaleWidth      =   4815
   StartUpPosition =   3  '窗口缺省
   Begin ComctlLib.TreeView TreeView1 
      Height          =   2295
      Left            =   360
      TabIndex        =   4
      Top             =   1200
      Width           =   4335
      _ExtentX        =   7646
      _ExtentY        =   4048
      _Version        =   327682
      Style           =   7
      ImageList       =   "ImageList1"
      Appearance      =   1
   End
   Begin VB.CommandButton cmdDisconnect 
      Caption         =   "Disconnect"
      Height          =   375
      Left            =   3120
      TabIndex        =   3
      Top             =   600
      Width           =   1215
   End
   Begin VB.CommandButton cmdConnect 
      Caption         =   "Connect"
      Height          =   375
      Left            =   600
      TabIndex        =   2
      Top             =   600
      Width           =   1335
   End
   Begin VB.TextBox txtServer 
      Height          =   375
      Left            =   1200
      TabIndex        =   0
      Top             =   120
      Width           =   3015
   End
   Begin ComctlLib.ImageList ImageList1 
      Left            =   4200
      Top             =   120
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   -2147483643
      ImageWidth      =   13
      ImageHeight     =   13
      MaskColor       =   12632256
      _Version        =   327682
      BeginProperty Images {0713E8C2-850A-101B-AFC0-4210102A8DA7} 
         NumListImages   =   4
         BeginProperty ListImage1 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "form1.frx":0000
            Key             =   ""
         EndProperty
         BeginProperty ListImage2 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "form1.frx":00FA
            Key             =   ""
         EndProperty
         BeginProperty ListImage3 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "form1.frx":01F4
            Key             =   ""
         EndProperty
         BeginProperty ListImage4 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "form1.frx":02EE
            Key             =   ""
         EndProperty
      EndProperty
   End
   Begin VB.Label Label2 
      Caption         =   "FTP Server:"
      Height          =   255
      Left            =   120
      TabIndex        =   1
      Top             =   240
      Width           =   1695
   End
End
Attribute VB_Name = "form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim hOpen As Long, hConnection As Long
Dim EnumItemNameBag As New Collection
Dim EnumItemAttributeBag As New Collection
    

Private Sub Form_Load()
    hOpen = 0
    hConnection = 0
    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
    hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)
    If hOpen = 0 Then ErrorOut Err.LastDllError, "InternetOpen"
    cmdDisconnect.Enabled = False
End Sub

Private Sub Form_Unload(Cancel As Integer)
    If hConnection <> 0 Then InternetCloseHandle (hConnection)
    If hOpen <> 0 Then InternetCloseHandle (hOpen)
    hConnection = 0
    hOpen = 0
    txtServer.Text = ""
    ClearBag
End Sub

Private Sub cmdConnect_Click()
    If hOpen <> 0 Then
        If txtServer.Text = "" Then
            MsgBox "Please enter a server name!"
            Exit Sub
        End If
        hConnection = InternetConnect(hOpen, txtServer.Text, INTERNET_INVALID_PORT_NUMBER, _
                txtUser, txtPassword, INTERNET_SERVICE_FTP, 0, 0)
        If hConnection = 0 Then
            ErrorOut Err.LastDllError, "InternetConnect"
        Else
            FillTreeViewControl (txtServer.Text)
            FtpEnumDirectory ("")
            If EnumItemNameBag.Count = 0 Then Exit Sub
            FillTreeViewControl (txtServer.Text)
            cmdDisconnect.Enabled = True
            cmdConnect.Enabled = False
       End If
    End If
End Sub

Private Sub cmdDisconnect_Click()
    bDirEmpty = True
    If hConnection <> 0 Then InternetCloseHandle hConnection
    hConnection = 0
    ClearBag
    TreeView1.Nodes.Remove txtServer.Text
    cmdDisconnect.Enabled = False
    cmdConnect.Enabled = True
End Sub

Private Sub ClearBag()
    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

Private Sub FillTreeViewControl(strParentKey As String)
    Dim nodX As Node
    Dim strImg As String
    Dim nCount As Integer, i As Integer
    Dim nAttr As Integer
    Dim strItem As String
    
    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


Private Sub rcd(pszDir As String)
    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

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 & "Close Connection and Session?", vbYesNo) = vbYes Then
        If hConnection Then InternetCloseHandle hConnection
        If hOpen Then InternetCloseHandle hOpen
        hConnection = 0
        hOpen = 0
        TreeView1.Nodes.Remove txtServer.Text
        txtServer.Text = ""
        ClearBag
        cmdDisconnect.Enabled = False
        cmdConnect.Enabled = False
    End If
End Function

Private Sub FtpEnumDirectory(strDirectory As String)
    ClearBag
    Dim hFind As Long
    Dim nLastError As Long
    Dim dError As Long
    Dim ptr As Long
    Dim pData As WIN32_FIND_DATA
    
    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
        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 TreeView1_DblClick()
    Dim nodX As Node
    Set nodX = TreeView1.SelectedItem
    If nodX Is Nothing Then
        MsgBox "no Selection to enumerate"
    End If
    If nodX.Image = "closed" Then
        nodX.Image = "open"
        FtpEnumDirectory (nodX.Text)
        FillTreeViewControl (nodX.Text)
    Else
        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