home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 7_2009-2012.ISO / data / zips / Video_Surv21911810202010.psc / FrmSelDir.frm < prev    next >
Text File  |  2010-05-07  |  4KB  |  122 lines
  1. VERSION 5.00
  2. Begin VB.Form FrmSelDir 
  3.    ClientHeight    =   3090
  4.    ClientLeft      =   60
  5.    ClientTop       =   450
  6.    ClientWidth     =   4680
  7.    LinkTopic       =   "Form2"
  8.    ScaleHeight     =   3090
  9.    ScaleWidth      =   4680
  10.    StartUpPosition =   1  'CenterOwner
  11.    Begin VB.CommandButton Command2 
  12.       Caption         =   "New"
  13.       Height          =   315
  14.       Left            =   4080
  15.       TabIndex        =   3
  16.       Top             =   480
  17.       Width           =   495
  18.    End
  19.    Begin VB.CommandButton Command1 
  20.       Caption         =   "Select"
  21.       Height          =   375
  22.       Left            =   3720
  23.       TabIndex        =   2
  24.       Top             =   2400
  25.       Width           =   855
  26.    End
  27.    Begin VB.DirListBox Dir1 
  28.       Height          =   2340
  29.       Left            =   120
  30.       TabIndex        =   1
  31.       Top             =   480
  32.       Width           =   3495
  33.    End
  34.    Begin VB.DriveListBox Drive1 
  35.       Height          =   315
  36.       Left            =   120
  37.       TabIndex        =   0
  38.       Top             =   120
  39.       Width           =   2175
  40.    End
  41. End
  42. Attribute VB_Name = "FrmSelDir"
  43. Attribute VB_GlobalNameSpace = False
  44. Attribute VB_Creatable = False
  45. Attribute VB_PredeclaredId = True
  46. Attribute VB_Exposed = False
  47. Private Sub Command1_Click()
  48. FrmSelDir.Tag = Dir1.Path
  49. FrmSelDir.Visible = False
  50. End Sub
  51.  
  52. Private Sub Command2_Click()
  53. Dim cadena, dircompleto As String
  54. cadena = InputBox("Nuevo directorio:", "Crear directorio en " + Dir1.Path, "NUEVO")
  55. If cadena <> "" Then
  56.    dircompleto = Dir1.Path + "\" + cadena + "\"
  57.    Call Create_Directory(dircompleto)
  58.    Dir1.Refresh
  59. End If
  60. End Sub
  61.  
  62. Private Sub Dir1_Change()
  63. If Mid$(Drive1.drive, 1, 2) <> Mid$(Dir1.Path, 1, 2) Then
  64.    Drive1.drive = Dir1.Path
  65. End If
  66. End Sub
  67.  
  68. Private Sub Drive1_Change()
  69. Dir1.Path = Drive1.drive
  70. End Sub
  71.  
  72. Sub Create_Directory(sdirectory As String)
  73.  
  74. '---------------CREATE A DIRECTORY-----------------------
  75. 'This procedure creates the directory where the file(s)
  76. 'are to be installed. There is some error handling in
  77. 'it incase the directory already exists.
  78. '--------------------------------------------------
  79.  
  80. Dim strpath As String       'The directory which will be created...
  81. Dim intOffset As Integer    'Searches for a "\" so it can create the dirs...
  82. Dim intAnchor As Integer    'Equal to the above variable...
  83. Dim strOldPath As String    'Returns the CurDir to the old path(the dir
  84.                             'the setup file is in)...
  85.  
  86. On Error Resume Next        'Error handling...
  87.  
  88. strOldPath = CurDir$        'Find the current Directory...
  89. intAnchor = 0               'Reset intAnchor...
  90.  
  91. 'Searches for the "\" to create the dirs properly...
  92. intOffset = InStr(intAnchor + 1, sdirectory, "\")
  93. intAnchor = intOffset   'Equal to the above...
  94. Do
  95.     intOffset = InStr(intAnchor + 1, sdirectory, "\")
  96.     intAnchor = intOffset
  97.     
  98.     If intAnchor > 0 Then   'If there is 1 or more "\" then...
  99.         
  100.         'Create the directory using the text before the "\"...
  101.         strpath = Left$(sdirectory, intOffset - 1)
  102.         
  103.         ' Determine if this directory already exists...
  104.         Err = 0
  105.         ChDir strpath   'If it does, change to that directory...
  106.         
  107.         If Err Then     'If it doesn't exist...
  108.             
  109.             ' We must create this directory...
  110.             Err = 0
  111.             MkDir strpath   'Make the Directory...
  112.         End If
  113.     End If
  114. Loop Until intAnchor = 0    'Loop until all directories have been made
  115.                             'I.e C:\Prog\David\Cowan is 3 directories...
  116. Done:
  117.     ChDir strOldPath        'Change back to the the 'old' current directory...
  118. Err = 0                     'Reset the error number...
  119. End Sub
  120.  
  121.  
  122.