Source code for Issue Number 7

Copyright 1997-2000 by C&D Programming Corp. All Rights Reserved. Source code may not be reproduced except for use in a compiled executable. All rights reserved. If you would like to reprint any or all of this code please email us at info@codeoftheweek.com

Code of the Week Home


Source Code

Just paste this code into any module (this is the desired way) or form.

'----------------------------------------------------------------------
'
'   Module Name:    basFileSystem
'   Written By:     C&D Programming Corp.
'   Create Date:    10/22/97
'   Copyright:      Copyright 1997 by C&D Programming Corp.  Source
'                   code may not be reproduced except for use in a
'                   compiled executable.  All rights reserved.  If
'                   you would like to reprint any or all of this
'                   code please email us at info@codeoftheweek.com
'
'   Purpose:        Create a complete directory path, such as
'                   C:\TEMP\MYAPP
'
'
'----------------------------------------------------------------------

Option Explicit

Function MakeDirectories (ByVal sNewDir As String) As Integer
   Const ATTR_DIRECTORY = 16
   Dim bDone As Integer
   Dim sDirStr As String
   Dim iBackPos As Integer
   Dim iCopyPos As Integer

   On Error Resume Next
   iBackPos = 1
   While Not bDone
      iCopyPos = InStr(iBackPos, sNewDir, "\")
      If iCopyPos = 0 Then
         iCopyPos = Len(sNewDir) + 1
         bDone = True
      End If
      sDirStr = Left(sNewDir, iCopyPos - 1)
      iBackPos = Len(sDirStr) + 2
      If Len(sDirStr) > 3 Then  ' If the path is more than D:\
         If Dir(sDirStr, ATTR_DIRECTORY) = "" Then
            MkDir sDirStr
            If Err <> 0 Then
               MsgBox "Error " & Err & " creating directory " & sDirStr & "." & Chr$(13) & "Error Message: " & Error$
               MakeDirectories = False
               Exit Function
            End If
         End If
      End If
   Wend
   MakeDirectories = True
End Function