home *** CD-ROM | disk | FTP | other *** search
/ Mastering Visual Basic 6 / mastvb6.iso / ch_code / ch12 / dirmap / optimzd / dirmap.frm (.txt) < prev    next >
Encoding:
Visual Basic Form  |  1996-03-07  |  7.5 KB  |  239 lines
  1. VERSION 5.00
  2. Object = "{3B7C8863-D78F-101B-B9B5-04021C009402}#1.1#0"; "RICHTX32.OCX"
  3. Begin VB.Form DirMapForm 
  4.    Caption         =   "Directory Map (optimized)"
  5.    ClientHeight    =   6150
  6.    ClientLeft      =   60
  7.    ClientTop       =   345
  8.    ClientWidth     =   8415
  9.    LinkTopic       =   "Form1"
  10.    ScaleHeight     =   6150
  11.    ScaleWidth      =   8415
  12.    StartUpPosition =   3  'Windows Default
  13.    Begin VB.FileListBox File1 
  14.       BeginProperty Font 
  15.          Name            =   "Verdana"
  16.          Size            =   8.25
  17.          Charset         =   0
  18.          Weight          =   400
  19.          Underline       =   0   'False
  20.          Italic          =   0   'False
  21.          Strikethrough   =   0   'False
  22.       EndProperty
  23.       Height          =   675
  24.       Left            =   135
  25.       TabIndex        =   5
  26.       Top             =   1125
  27.       Visible         =   0   'False
  28.       Width           =   2430
  29.    End
  30.    Begin VB.DirListBox Dir2 
  31.       BeginProperty Font 
  32.          Name            =   "Verdana"
  33.          Size            =   8.25
  34.          Charset         =   0
  35.          Weight          =   400
  36.          Underline       =   0   'False
  37.          Italic          =   0   'False
  38.          Strikethrough   =   0   'False
  39.       EndProperty
  40.       Height          =   990
  41.       Left            =   6000
  42.       TabIndex        =   3
  43.       Top             =   150
  44.       Visible         =   0   'False
  45.       Width           =   2055
  46.    End
  47.    Begin VB.CommandButton Command1 
  48.       Caption         =   "Map this Folder"
  49.       BeginProperty Font 
  50.          Name            =   "Verdana"
  51.          Size            =   9
  52.          Charset         =   0
  53.          Weight          =   400
  54.          Underline       =   0   'False
  55.          Italic          =   0   'False
  56.          Strikethrough   =   0   'False
  57.       EndProperty
  58.       Height          =   495
  59.       Left            =   6000
  60.       TabIndex        =   2
  61.       Top             =   1305
  62.       Width           =   2205
  63.    End
  64.    Begin VB.DirListBox Dir1 
  65.       BeginProperty Font 
  66.          Name            =   "Verdana"
  67.          Size            =   8.25
  68.          Charset         =   0
  69.          Weight          =   400
  70.          Underline       =   0   'False
  71.          Italic          =   0   'False
  72.          Strikethrough   =   0   'False
  73.       EndProperty
  74.       Height          =   1440
  75.       Left            =   2805
  76.       TabIndex        =   1
  77.       Top             =   360
  78.       Width           =   2925
  79.    End
  80.    Begin VB.DriveListBox Drive1 
  81.       BeginProperty Font 
  82.          Name            =   "Verdana"
  83.          Size            =   8.25
  84.          Charset         =   0
  85.          Weight          =   400
  86.          Underline       =   0   'False
  87.          Italic          =   0   'False
  88.          Strikethrough   =   0   'False
  89.       EndProperty
  90.       Height          =   315
  91.       Left            =   135
  92.       TabIndex        =   0
  93.       Top             =   345
  94.       Width           =   2430
  95.    End
  96.    Begin RichTextLib.RichTextBox RichTextBox1 
  97.       Height          =   3450
  98.       Left            =   135
  99.       TabIndex        =   4
  100.       Top             =   2550
  101.       Width           =   8130
  102.       _ExtentX        =   14340
  103.       _ExtentY        =   6085
  104.       _Version        =   393217
  105.       ScrollBars      =   3
  106.       RightMargin     =   8e6
  107.       TextRTF         =   $"DirMap.frx":0000
  108.       BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
  109.          Name            =   "Verdana"
  110.          Size            =   9.75
  111.          Charset         =   0
  112.          Weight          =   400
  113.          Underline       =   0   'False
  114.          Italic          =   0   'False
  115.          Strikethrough   =   0   'False
  116.       EndProperty
  117.    End
  118.    Begin VB.Label Label1 
  119.       BeginProperty Font 
  120.          Name            =   "Verdana"
  121.          Size            =   9.75
  122.          Charset         =   0
  123.          Weight          =   400
  124.          Underline       =   0   'False
  125.          Italic          =   0   'False
  126.          Strikethrough   =   0   'False
  127.       EndProperty
  128.       Height          =   315
  129.       Left            =   180
  130.       TabIndex        =   6
  131.       Top             =   2145
  132.       Width           =   5340
  133.    End
  134. Attribute VB_Name = "DirMapForm"
  135. Attribute VB_GlobalNameSpace = False
  136. Attribute VB_Creatable = False
  137. Attribute VB_PredeclaredId = True
  138. Attribute VB_Exposed = False
  139. Option Explicit
  140. Dim InitialFolder As String
  141. Dim currentDepth As Integer
  142. Dim DirStructure As String
  143. Dim tmpDirStructure As String
  144. Dim totalFolders As Integer, totalFiles As Integer
  145. Dim T1 As Long
  146. Const newLine = "{\par }"
  147. Function DoubleSlashes(txt As String) As String
  148. Dim k As Integer
  149. Dim newtxt As String
  150.     For k = 1 To Len(txt)
  151.         If Mid$(txt, k, 1) = "\" Then
  152.             newtxt = newtxt & "\\"
  153.         Else
  154.             newtxt = newtxt & Mid$(txt, k, 1)
  155.         End If
  156.     Next
  157.     DoubleSlashes = newtxt
  158. End Function
  159. Private Sub Command1_Click()
  160. T1 = Timer
  161.     totalFiles = 0
  162.     totalFolders = 0
  163.     currentDepth = 1
  164.     InitialFolder = CurDir
  165.     tmpDirStructure = ""
  166.     DirStructure = "{"
  167.     DirStructure = DirStructure & "{\b " & DoubleSlashes(Dir2.List(-1)) & "}" + newLine
  168.     Screen.MousePointer = vbHourglass
  169.     DoEvents
  170.     ScanFolders
  171.     If tmpDirStructure <> "" Then
  172.         DirStructure = DirStructure & tmpDirStructure
  173.     End If
  174.     DirStructure = DirStructure & "}"
  175.     RichTextBox1.TextRTF = DirStructure
  176.     Label1.Caption = "Scanned " & totalFolders & " folders containing " & totalFiles & " files"
  177.     Screen.MousePointer = vbDefault
  178. MsgBox Timer - T1
  179. End Sub
  180. Sub ScanFolders()
  181. Dim subFolders As Integer
  182. Dim txtLine As String
  183. Dim j As Integer, i As Integer
  184.     txtLine = ""
  185.     totalFiles = totalFiles + File1.ListCount
  186.     For j = 0 To File1.ListCount - 1
  187.         txtLine = txtLine & Space(currentDepth * 5) + File1.List(j) & newLine
  188.     Next
  189.     tmpDirStructure = tmpDirStructure & txtLine
  190.     subFolders = Dir2.ListCount
  191.     totalFolders = totalFolders + subFolders
  192.     Label1.Caption = "Processed " & totalFolders & " folders"
  193.     DoEvents
  194.     If subFolders > 0 Then
  195.         currentDepth = currentDepth + 1
  196.         For i = 0 To subFolders - 1
  197. 'msgbox "moving from " & CurDir & " to " & Dir2.List(i)
  198.             tmpDirStructure = tmpDirStructure & "{\b " & DoubleSlashes(Dir2.List(i)) & "}" & newLine
  199.             If Len(tmpDirStructure) > 8000 Then
  200.                 DirStructure = DirStructure & tmpDirStructure
  201.                 tmpDirStructure = ""
  202.             End If
  203.             File1.Path = Dir2.List(i)
  204.             ChDir CurDir    'Dir2.List(i)
  205.             Dir2.Path = Dir2.List(i)
  206.             ScanFolders
  207.         Next
  208.         currentDepth = currentDepth - 1
  209.         DoEvents
  210.     End If
  211.     MoveUp
  212.     File1.Path = Dir2.Path
  213. End Sub
  214. Sub MoveUp()
  215.     If Dir2.List(-1) <> InitialFolder Then
  216.         ChDir Dir2.List(-2)
  217.         Dir2.Path = Dir2.List(-2)
  218.     End If
  219. End Sub
  220. Private Sub Dir1_Change()
  221.     ChDir Dir1.Path
  222.     Dir2.Path = Dir1.Path
  223.     File1.Path = Dir2.Path
  224. End Sub
  225. Private Sub Drive1_Change()
  226.     ChDrive Drive1.Drive
  227.     Dir1.Path = Drive1.Drive
  228.     Dir2.Path = Drive1.Drive
  229. End Sub
  230. Private Sub Form_Load()
  231.     ChDrive Left(CurDir, 3)
  232.     'Drive1.Drive = Left(CurDir, 3)
  233.     ChDir CurDir
  234.     'File1.Path = App.Path
  235. End Sub
  236. Private Sub Form_Resize()
  237.     RichTextBox1.Height = DirMapForm.Height - RichTextBox1.Top - 525
  238. End Sub
  239.