Programmer Plus 2007/Programmer-Plus-2007.iso/Programming/Visual Basic new SourceCode and Projects/Directory Mapper/Directory.frm

Visual Basic Form | 1999-06-19 | 5.4 KB | 192 lines

VERSION 5.00
Begin VB.Form frmDirectory
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Drive Mapper"
   ClientHeight    =   2205
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   5280
   Icon            =   "Directory.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   147
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   352
   StartUpPosition =   3  'Windows Default
   Begin VB.Label lblFile
      Height          =   315
      Left            =   150
      TabIndex        =   3
      Top             =   1650
      Width           =   4965
      WordWrap        =   -1  'True
   End
   Begin VB.Label lblFil
      AutoSize        =   -1  'True
      Caption         =   "File:"
      Height          =   195
      Left            =   150
      TabIndex        =   2
      Top             =   1275
      Width           =   285
   End
   Begin VB.Label lblDirectory
      Height          =   465
      Left            =   150
      TabIndex        =   1
      Top             =   525
      Width           =   4965
      WordWrap        =   -1  'True
   End
   Begin VB.Label lblDir
      AutoSize        =   -1  'True
      Caption         =   "Directory:"
      Height          =   195
      Left            =   150
      TabIndex        =   0
      Top             =   150
      Width           =   675
   End
Attribute VB_Name = "frmDirectory"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Const COLON = ":"
Dim Drives As New Collection
Dim Directory As New Collection
Dim Files As New Collection
Dim FileTree As New Collection
Dim TreeLevel As Integer
Dim FilePath As String
Dim DriveLetter As String
Dim PathName As String
Dim DriveNum As Integer
Dim FolderName As String
Dim IsDrive As Boolean
Dim CancelProg As Boolean
Sub DeleteCollection(ByRef Col As Collection)
Dim BlankCollection As New Collection
    Set Col = BlankCollection
End Sub
Function GetDriveLetter(DriveIndex As Integer) As String
    GetDriveLetter = Left(Right(Drives(DriveIndex), 3), 1)
End Function
Sub GetDrives()
Dim i As Integer, MyDrive As String
    On Error Resume Next
    DeleteCollection Drives
    For i = 0 To 25
        MyDrive = Chr(i + 65) & COLON
        If Dir(MyDrive, vbVolume) > "" Then
            Drives.Add Dir(MyDrive, vbVolume) & " (" & MyDrive & ")"
        End If
    Next i
End Sub
Sub GetDirectory()
Dim i As Integer, MyDir As String
    DeleteCollection Directory
    MyDir = Dir(PathName, vbDirectory)
    Do While MyDir <> vbNullString
        If MyDir <> "." And MyDir <> ".." Then
            If (GetAttr(PathName & MyDir) And vbDirectory) = vbDirectory Then
                Directory.Add UCase(MyDir)
                DoEvents
            End If
        End If
        MyDir = Dir()
    Loop
End Sub
Sub GetFiles()
Dim i As Integer, MyFile As String
    DeleteCollection Files
    MyFile = Dir(PathName, vbArchive + vbHidden + vbSystem + vbReadOnly)
    Do While MyFile <> vbNullString
        DoEvents
        Files.Add UCase(MyFile)
        MyFile = Dir()
    Loop
End Sub
Sub GetPath()
Dim i As Integer, s As String
    DeleteCollection FileTree
    Do
        i = InStr(1, PathName, "\")
        If i > 0 Then
            s = Left(PathName, i - 1)
            PathName = Right(PathName, Len(PathName) - i)
            FileTree.Add s
        End If
    Loop Until i = 0
End Sub
Sub RefreshDir()
    GetDrives
    GetDirectory
    GetFiles
End Sub
Private Sub Form_Load()
    On Error Resume Next
    FilePath = App.Path & "\DRIVES.MAP"
    Kill FilePath
    Open FilePath For Random As #1
    Close
    Open FilePath For Output As #1
    RefreshDir
    Show
    StoreDrivesData
End Sub
Sub StoreDrivesData()
    GetDrives
    For DriveNum = 1 To Drives.Count
        PathName = GetDriveLetter(DriveNum) & ":\"
        IsDrive = True
        If CancelProg Then Exit Sub
        StoreDirData
    Next DriveNum
    End
End Sub
Sub StoreDirData()
Dim FldVar As Integer, Path As String
Dim OldDirectory As New Collection
    On Error Resume Next
    If CancelProg Then Exit Sub
    TreeLevel = TreeLevel + 1
    FolderName = "-> " & Dir(Left(PathName, Len(PathName) - 1), vbDirectory)
    If IsDrive Then FolderName = "-> " & PathName
    PrintToFile String((TreeLevel - 1) * 2, " ") & FolderName
    lblDirectory = PathName
    Path = PathName
    lblFile = ""
    GetDirectory
    IsDrive = False
    Set OldDirectory = Directory
    StoreFilesData
    For FldVar = 1 To OldDirectory.Count
        PathName = Path & OldDirectory(FldVar) & "\"
        StoreDirData
        PathName = Path
    Next FldVar
    TreeLevel = TreeLevel - 1
End Sub
Sub StoreFilesData()
Dim FilVar As Integer
    GetFiles
    For FilVar = 1 To Files.Count
        DoEvents
        PrintToFile String((TreeLevel - 1) * 2, " ") & Files(FilVar)
        lblFile = Files(FilVar)
    Next FilVar
End Sub
Sub PrintToFile(Text As String)
    Debug.Print Text
    Print #1, Text
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    CancelProg = True
End Sub
Private Sub Form_Unload(Cancel As Integer)
    Close
End Sub