frmdir.frm

大量优秀的vb编程

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmdir 
   Caption         =   "简易资源管理器"
   ClientHeight    =   6000
   ClientLeft      =   420
   ClientTop       =   1536
   ClientWidth     =   11220
   Icon            =   "frmdir.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   6000
   ScaleWidth      =   11220
   Begin MSComctlLib.ImageList ImgFilesSmall 
      Left            =   10560
      Top             =   5310
      _ExtentX        =   995
      _ExtentY        =   995
      BackColor       =   -2147483643
      ImageWidth      =   16
      ImageHeight     =   16
      MaskColor       =   128
      _Version        =   393216
      BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628} 
         NumListImages   =   1
         BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmdir.frx":000C
            Key             =   "File"
         EndProperty
      EndProperty
   End
   Begin MSComctlLib.ImageList ImgFilesLarge 
      Left            =   9960
      Top             =   5310
      _ExtentX        =   995
      _ExtentY        =   995
      BackColor       =   -2147483643
      ImageWidth      =   32
      ImageHeight     =   32
      MaskColor       =   128
      _Version        =   393216
      BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628} 
         NumListImages   =   1
         BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmdir.frx":0120
            Key             =   "File"
         EndProperty
      EndProperty
   End
   Begin MSComctlLib.ListView lstMain 
      Height          =   5925
      Left            =   3300
      TabIndex        =   1
      Top             =   30
      Width           =   7875
      _ExtentX        =   13885
      _ExtentY        =   10435
      Sorted          =   -1  'True
      LabelWrap       =   -1  'True
      HideSelection   =   -1  'True
      AllowReorder    =   -1  'True
      _Version        =   393217
      Icons           =   "ImgFilesLarge"
      SmallIcons      =   "ImgFilesSmall"
      ForeColor       =   -2147483640
      BackColor       =   -2147483643
      BorderStyle     =   1
      Appearance      =   1
      NumItems        =   5
      BeginProperty ColumnHeader(1) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
         Text            =   "Name"
         Object.Width           =   3175
      EndProperty
      BeginProperty ColumnHeader(2) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
         Alignment       =   1
         SubItemIndex    =   1
         Text            =   "Size"
         Object.Width           =   1588
      EndProperty
      BeginProperty ColumnHeader(3) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
         SubItemIndex    =   2
         Text            =   "Type"
         Object.Width           =   3175
      EndProperty
      BeginProperty ColumnHeader(4) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
         SubItemIndex    =   3
         Text            =   "Modified"
         Object.Width           =   3175
      EndProperty
      BeginProperty ColumnHeader(5) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
         SubItemIndex    =   4
         Text            =   "Attributes"
         Object.Width           =   1764
      EndProperty
   End
   Begin MSComctlLib.ImageList img 
      Left            =   6420
      Top             =   3270
      _ExtentX        =   995
      _ExtentY        =   995
      BackColor       =   -2147483643
      ImageWidth      =   16
      ImageHeight     =   16
      MaskColor       =   128
      _Version        =   393216
      BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628} 
         NumListImages   =   7
         BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmdir.frx":03B4
            Key             =   "Closed"
         EndProperty
         BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmdir.frx":04D0
            Key             =   "NetDrive"
         EndProperty
         BeginProperty ListImage3 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmdir.frx":05E4
            Key             =   "MyComputer"
         EndProperty
         BeginProperty ListImage4 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmdir.frx":06F8
            Key             =   "Open"
         EndProperty
         BeginProperty ListImage5 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmdir.frx":0814
            Key             =   "HardDrive"
         EndProperty
         BeginProperty ListImage6 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmdir.frx":0928
            Key             =   "Floppy"
         EndProperty
         BeginProperty ListImage7 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmdir.frx":0A3C
            Key             =   "CDRom"
         EndProperty
      EndProperty
   End
   Begin MSComctlLib.TreeView dirtree 
      CausesValidation=   0   'False
      Height          =   5925
      Left            =   0
      TabIndex        =   0
      Top             =   30
      Width           =   3255
      _ExtentX        =   5736
      _ExtentY        =   10435
      _Version        =   393217
      Indentation     =   529
      Style           =   7
      ImageList       =   "img"
      Appearance      =   1
   End
End
Attribute VB_Name = "frmdir"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Private nNode As Node
Private lItem As ListItem
Private lFileSys As New Scripting.FileSystemObject


Private Sub Form_Load()
    On Error Resume Next
    
    'Add all the drives to the treeview control
    Set nNode = dirtree.Nodes.Add(, , "root", "My Computer", "MyComputer")
    nNode.Expanded = True
    
    For Each lDrive In lFileSys.Drives
        If (lFileSys.DriveExists(lDrive)) Then
            'see what type of drive it is
            sImg = "HardDrive"
            Select Case lDrive.DriveType
            Case Removable
                sImg = "Floppy"
            Case CDRom
                sImg = "CDRom"
            Case Remote
                sImg = "NetDrive"
            End Select

            sVolName = lDrive.VolumeName
            sDrvLetter = lDrive.DriveLetter
            tmp = sVolName & " (" & sDrvLetter & ":)"
            Set nNode = dirtree.Nodes.Add("root", tvwChild, lDrive, Trim(tmp), sImg)
            sVolName = "": sDrvLetter = ""
        End If
    Next

End Sub

Private Sub dirTree_NodeClick(ByVal Node As MSComctlLib.Node)
    'get all the files in the current directory
    If Node.Key = "root" Then Exit Sub
    Pth = Node.Key
    If Right(Pth, 1) <> "\" Then Pth = Pth & "\"
    If Node.Tag = "" Then
        DisplayDir Pth, Node.Key
        Node.Tag = "Done"
    End If
    Node.Expanded = True
    GetFiles Pth
    
End Sub

Sub DisplayDir(Pth, Parent)
    Dim lFolder As Folder, lSubFolder As Folder
    
    On Error GoTo ErrHnd:
    'Pth    - The directory to get the directories for
    'Parent - The key name or index of the node to parent the directories
    '         to.
    
    'Make sure the path is vaild
    
    Set lFolder = lFileSys.GetFolder(Pth)
    'loop for the amount of directories there are
    For Each lSubFolder In lFolder.SubFolders
        'Add the directory the the treeview control
        Set nNode = dirtree.Nodes.Add(Parent, tvwChild, lSubFolder.Path, lSubFolder.Name, "Closed")
        nNode.Expanded = False
        nNode.ExpandedImage = "Open"
    Next
    Exit Sub
ErrHnd:
    Resume Next
End Sub

Sub GetFiles(Pth)
    Dim lFiles As Files, lFile As File, largeImg As ListImage, smallImg As ListImage
    Dim lFolder As Folder, lSubFolder As Folder
    'On Error GoTo ErrHnd
    
    Set lFiles = lFileSys.GetFolder(Pth).Files
    Set lFolder = lFileSys.GetFolder(Pth)
    
    lstMain.ListItems.Clear
    'ImgFilesLarge.ListImages.Clear
    'ImgFilesSmall.ListImages.Clear
        
    For Each lFile In lFiles
        'z = SHGetFileInfo(lFile.Path, 0, FileInfo, Len(FileInfo), SHGFI_SMALLICON Or SHGFI_SYSICONINDEX)
        'ImgFilesSmall.ListImages.Add , , z
        
        'z = SHGetFileInfo(lFile.Path, 0, FileInfo, Len(FileInfo), SHGFI_LARGEICON Or SHGFI_SYSICONINDEX)
        'Set largeImg = ImgFilesSmall.ListImages.Add(, , FileInfo.hIcon)
        
        Set lItem = lstMain.ListItems.Add(, , lFile.Name, "File", "File")
        lItem.SubItems(1) = GetSize(lFile.Size)
        lItem.SubItems(2) = lFile.Type
        lItem.SubItems(3) = Format(lFile.DateLastModified, "dd/mm/yy h:mm")
        lItem.SubItems(4) = GetAttrib(lFile.Attributes)
    Next
    Exit Sub
ErrHnd:
    Resume Next
End Sub

Private Sub lstMain_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
    If lstMain.SortKey = ColumnHeader.SubItemIndex Then
        If lstMain.SortOrder = lvwAscending Then
            lstMain.SortOrder = lvwDescending
        Else
            lstMain.SortOrder = lvwAscending
        End If
    Else
        lstMain.SortKey = ColumnHeader.SubItemIndex
        lstMain.SortOrder = lvwAscending
    End If
End Sub

Private Function GetSize(Size As Long) As String
    If Size = 0 Then
        GetSize = "0KB"
    ElseIf Size < 1024 Then
        GetSize = "1KB"
    Else
        GetSize = Int(Size / 1024) + 1 & "KB"
    End If
End Function

Private Function GetAttrib(Attrib As Long) As String
    If Attrib And ReadOnly Then
        GetAttrib = "R"
    Else
        GetAttrib = "--"
    End If
    If Attrib And Archive Then
        GetAttrib = GetAttrib & "A"
    Else
        GetAttrib = GetAttrib & "--"
    End If
    If Attrib And System Then
        GetAttrib = GetAttrib & "S"
    Else
        GetAttrib = GetAttrib & "--"
    End If
    If Attrib And Hidden Then
        GetAttrib = GetAttrib & "H"
    Else
        GetAttrib = GetAttrib & "--"
    End If
    If Attrib And Compressed Then
        GetAttrib = GetAttrib & "C"
    Else
        GetAttrib = GetAttrib & "--"
    End If
End Function