clsFSO.cls

 VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsFSO"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Option Explicit

' ***************************************************************************
' Module:        clsFSO
'
' Description:   Module with several routines to make use of the
'                Scripting.fileSystemObject.  Be sure to make a reference
'                to "Microsoft Scripting Runtime" (scrrun.dll) in your
'                project.
'
'                Visit http://msdn.microsoft.com/default.asp and type
'                "FileSystemObject" (without the quotes) in the search box
'                to get additional information.
'
'                To get a hard copy of the VBScript documentation or an updated
'                version, visit:
'
'    http://msdn.microsoft.com/scripting/default.htm?/scripting/vbscript/doc/default.htm
'
'                and click on "Downloads" on the right side.
'                o  Click on the first hot link at the top of the page to get
'                   the latest version of the scripting engine.  Scroll to
'                   the bottom of the page.
'                o  Click on the "32-bit Vbscript ..." hot link to get the
'                   documentation.
' ===========================================================================
'    DATE      NAME / DESCRIPTION
' -----------  --------------------------------------------------------------
' 26-NOV-2000  Kenneth Ives  kenaso@home.com
'              Routine created
' 24-MAR-2001  Kenneth Ives  kenaso@home.com
'              Added routines and documentation
' ***************************************************************************

' ---------------------------------------------------------------------------
' MISCELLANEOUS CONSTANTS
' ---------------------------------------------------------------------------
  Private Const BIF_RETURNONLYFSDIRS      As Long = 1
  Private Const INVALID_HANDLE_VALUE      As Long = -1
  Private Const FILE_ATTRIBUTE_DIRECTORY  As Long = &H10
  Private Const SEE_MASK_INVOKEIDLIST     As Long = &HC
  Private Const SEE_MASK_NOCLOSEPROCESS   As Long = &H40
  Private Const SEE_MASK_FLAG_NO_UI       As Long = &H400
  Private Const OF_READWRITE              As Long = &H2
  Private Const MAX_SIZE                  As Long = 260
  Private Const MAX_FILE_COUNT            As Long = 32768
 
' ---------------------------------------------------------------------------
' Store drive information
' ---------------------------------------------------------------------------
  Private Type DriveInfo
       DriveLetter      As String
       ShareName        As String
       Path             As String
       RootFolder       As String
       SerialNumber     As String
       VolumeName       As String
       TotalSize        As String
       AvailableSpace   As String
       FreeSpace        As String
       DriveType        As String
       FileSystem       As String
       IsReady          As String
  End Type
 
' ---------------------------------------------------------------------------
' Store file information
' ---------------------------------------------------------------------------
  Private Type FileInfo
       Drive             As String
       Path              As String
       ParentFolder      As String
       Size              As String
       Type              As String
       Extension         As String
       DateLastAccessed  As String
       DateLastModified  As String
       DateCreated       As String
       Attributes        As String
  End Type
 
' ---------------------------------------------------------------------------
' Required for SHBrowseForFolder API call
' ---------------------------------------------------------------------------
  Private Type BrowseInfo
       hWndOwner         As Long
       pIDLRoot          As Long
       pszDisplayName    As Long
       lpszTitle         As Long
       ulFlags           As Long
       lpfnCallback      As Long
       lParam            As Long
       iImage            As Long
  End Type

  Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
 
  Private Declare Function SHBrowseForFolder Lib "shell32" _
          (lpbi As BrowseInfo) As Long
 
  Private Declare Function SHGetPathFromIDList Lib "shell32" _
          (ByVal pidList As Long, ByVal lpBuffer As String) As Long

  Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" _
          (ByVal lpString1 As String, ByVal lpString2 As String) As Long

' ---------------------------------------------------------------------------
' Needed for a list of all available drive letters
' ---------------------------------------------------------------------------
  Private Declare Function GetLogicalDriveStrings Lib "kernel32" _
          Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, _
          ByVal lpBuffer As String) As Long

' ---------------------------------------------------------------------------
' Needed to reference/create temporary folders/files
' ---------------------------------------------------------------------------
  Private Declare Function GetTempPath Lib "kernel32.dll" _
          Alias "GetTempPathA" (ByVal nBufferLength As Long, _
          ByVal lpBuffer As String) As Long
           
  Private Declare Function GetTempFileName Lib "kernel32.dll" _
          Alias "GetTempFileNameA" (ByVal lpszPath As String, _
          ByVal lpPrefixString As String, ByVal wUnique As Long, _
          ByVal lpTempFileName As String) As Long

' ---------------------------------------------------------------------------
' Needed to determine space requirements of a drive
' ---------------------------------------------------------------------------
  ' Do we have the ability to use GetDiskFreeSpaceEx
  Private Declare Function LoadLibrary Lib "kernel32" _
          Alias "LoadLibraryA" _
          (ByVal lpLibFileName As String) As Long
         
  ' Verify the proceedure address within the kernel32 dll
  Private Declare Function GetProcAddress Lib "kernel32" _
          (ByVal hModule As Long, ByVal lpProcName As String) As Long
         
  ' Decrement the DLL counter when we are finished.  This is
  ' our safety net.
  Private Declare Function FreeLibrary Lib "kernel32" _
          (ByVal hLibModule As Long) As Long
         
  ' Drives over 2GB (2,147,483,647 bytes)
  Private Declare Function GetDiskFreeSpaceEx Lib "kernel32" _
          Alias "GetDiskFreeSpaceExA" (ByVal lpRootPathName As String, _
          FreeBytesAvailableToCaller As Currency, _
          TotalNumberOfBytes As Currency, _
          TotalNumberOfFreeBytes As Currency) As Long
         
  ' Drives under 2GB (2,147,483,647 bytes)
  Private Declare Function GetDiskFreeSpace Lib "kernel32" _
          Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, _
          lpSectorsPerCluster As Long, lpBytesPerSector As Long, _
          lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters As Long) As Long
         
' ---------------------------------------------------------------------------
' Define module level variables
' ---------------------------------------------------------------------------
  Private FI          As FileInfo
  Private DI          As DriveInfo
  Private m_dblCount  As Double
 
' ---------------------------------------------------------------------------
' Make a reference to "Microsoft Scripting Runtime"  (scrrun.dll)
' ---------------------------------------------------------------------------
  Private FSO As Scripting.FileSystemObject
 
' ---------------------------------------------------------------------------
' Used by an external click event to stop processing when doing something in
' a loop, like gathering a list of files.
'
' Example code in form cmdStop_Click event
'
'         g_blnStopProcessing = True
'         cFSO.CancelProcessing = True
'
' The class module looks for CancelProcessing while the external code looks
' for a global variable named g_blnStopProcessing.  To get this to work, I
' had to make cFSO a global variable.
' ---------------------------------------------------------------------------
  Public CancelProcessing As Boolean

' ---------------------------------------------------------------------------
' This event used to display the file count as they are located.
' See Get_FileList() routine.
' ---------------------------------------------------------------------------
  Public Event CountFiles(dblCount As Double, strPath As String)
 
' ---------------------------------------------------------------------------
' This event used to display the accumulation count as it is incremented.
' See Get_Totals() routine.
' ---------------------------------------------------------------------------
  Public Event CountTotals(dblCount As Double, strText As String)

Public Property Let Count(ByVal dblData As Double)

' ---------------------------------------------------------------------------
' used when assigning a value to the property, on the left side of an
' assignment.    Syntax: X.Count = 5
' ---------------------------------------------------------------------------
  m_dblCount = dblData

End Property

Public Property Get Count() As Double

' ---------------------------------------------------------------------------
' used when retrieving value of a property, on the right side of an
' assignment.    Syntax: Debug.Print X.Count
' ---------------------------------------------------------------------------
  Count = m_dblCount

End Property
 
Public Function IsDriveReady(ByVal strDrive As String) As Boolean
  
' ***************************************************************************
' Routine:       IsDriveReady
'
' Description:   Test whether a drive is ready.  Do not use a trailing
'                backslash
'
' Syntax:        IsDriveReady("A:")
'
' Parameters:    strDrive - drive to be tested
'
' Returns:       True or False
'
' ===========================================================================
'    DATE      NAME / DESCRIPTION
' -----------  --------------------------------------------------------------
' 26-NOV-2000  Kenneth Ives  kenaso@home.com
'              Routine created
' ***************************************************************************

' ---------------------------------------------------------------------------
' Instantsiate Scripting object
' ---------------------------------------------------------------------------
  Set FSO = New Scripting.FileSystemObject

' ---------------------------------------------------------------------------
' Capture the first character and convert to uppercase
' ---------------------------------------------------------------------------
  strDrive = StrConv(Left$(strDrive, 1), vbUpperCase)
 
' ---------------------------------------------------------------------------
' Make sure we have the right drive letter syntax
' ---------------------------------------------------------------------------
  Select Case Asc(strDrive)
         ' verify this is a letter of the alphabet
         Case 65 To 90
              strDrive = strDrive & ":"
              ' Is this drive available to be accessed
              IsDriveReady = FSO.GetDrive(strDrive).IsReady
             
         ' invalid drive letter passed
         Case Else
              IsDriveReady = False
  End Select

' ---------------------------------------------------------------------------
' Free object from memory
' ---------------------------------------------------------------------------
  Set FSO = Nothing
 
End Function

Public Function Create_Dir_Struct(ByVal strPath As String) As Boolean
  
' ***************************************************************************
' Routine:       Create_Dir_Struct
'
' Description:   Create nested directories.  Must end with a backslash.
'
' Syntax:        Create_Dir_Struct "C:\Program Files\MyDir\Level 1\Level 2"
'
' Parameters:    strPath = Folder path to be created if it does not exist
'
' Returns:       True or False
'
' ===========================================================================
'    DATE      NAME / DESCRIPTION
' -----------  --------------------------------------------------------------
' 26-NOV-2000  Kenneth Ives  kenaso@home.com
'              Routine created
' ***************************************************************************

  On Error GoTo Create_Dir_Struct_Errors
' ---------------------------------------------------------------------------
' Define local variables
' ---------------------------------------------------------------------------
  Dim intIndex    As Integer
  Dim strTmpPath  As String
 
' ---------------------------------------------------------------------------
' Instantsiate Scripting object
' ---------------------------------------------------------------------------
  Set FSO = New Scripting.FileSystemObject

' ---------------------------------------------------------------------------
' See if anything was passed to this routine
' ---------------------------------------------------------------------------
  If Len(Trim$(strPath)) = 0 Then
      Create_Dir_Struct = False
      GoTo Normal_Exit
  End If
 
' ---------------------------------------------------------------------------
' Make sure there is a traling backslash
' ---------------------------------------------------------------------------
  strPath = Add_Trailing_Slash(strPath)
  intIndex = 0

' ---------------------------------------------------------------------------
' See if any of the folders have to be created
' ---------------------------------------------------------------------------
  Do
      ' get the next path chunk
      intIndex = InStr(intIndex + 1, strPath, "")
     
      If intIndex > 0 Then
          strTmpPath = Left$(strPath, intIndex - 1)
      Else
          Exit Do
      End If
     
      ' see if this folder exists
      If Not FSO.FolderExists(strTmpPath) Then
          ' Create this folder.
          ' If there is an error, it will be trapped
          ' below and a msgbox displayed.
          FSO.CreateFolder strTmpPath
      End If
  Loop
   
' ---------------------------------------------------------------------------
' We were successful
' ---------------------------------------------------------------------------
  Create_Dir_Struct = True
 
Normal_Exit:
  On Error GoTo 0    ' nullify this error routine
  Set FSO = Nothing
  Exit Function

' ---------------------------------------------------------------------------
' An error occured creating this path
' ---------------------------------------------------------------------------
Create_Dir_Struct_Errors:
  MsgBox "Error: " & CStr(Err.Number) & "  " & Err.Description & _
         vbCrLf & vbCrLf & "An error occured while trying to create " & _
         strTmpPath, vbInformation + vbOKOnly, "Error creating folder"
  Create_Dir_Struct = False
  GoTo Normal_Exit
 
End Function
Public Function Get_Extension(ByVal strFilename As String) As String

' ---------------------------------------------------------------------------
' Capture just the file extension
' ---------------------------------------------------------------------------
  Set FSO = New Scripting.FileSystemObject
  Get_Extension = FSO.GetExtensionName(strFilename)
  Set FSO = Nothing
 
End Function

Public Function Get_Filename(ByVal strFilename As String) As String

' ---------------------------------------------------------------------------
' Capture just the filename
' ---------------------------------------------------------------------------
  Set FSO = New Scripting.FileSystemObject
  Get_Filename = FSO.GetFileName(strFilename)
  Set FSO = Nothing
 
End Function

Public Function Get_Path(ByVal strFilename As String) As String

' ---------------------------------------------------------------------------
' Capture full path only
' ---------------------------------------------------------------------------
  Set FSO = New Scripting.FileSystemObject
  Get_Path = FSO.GetParentFolderName(strFilename)
  Set FSO = Nothing
 
End Function

Public Function Get_Version(ByVal strFilename As String) As String

' ---------------------------------------------------------------------------
' Get file version
' ---------------------------------------------------------------------------
  Set FSO = New Scripting.FileSystemObject
  Get_Version = FSO.GetFileVersion(strFilename)
  Set FSO = Nothing
 
End Function

Public Function Drive_Exist(ByVal strSearchData As String, _
                            ByRef lngDriveType As Long) As Boolean

' ***************************************************************************
' Routine:       Drive_Exist
'
' Description:   Checks to see if the drive we are to query is available
'
' Parameters:    strSearchData - full path\filename
'
' Returns:       True or False
'
' ===========================================================================
'    DATE      NAME / DESCRIPTION
' -----------  --------------------------------------------------------------
' 26-NOV-2000  Kenneth Ives  kenaso@home.com
'              Routine created
' ***************************************************************************

  On Error GoTo Normal_Exit
' ---------------------------------------------------------------------------
' Define local variables
' ---------------------------------------------------------------------------
  Dim objDrive   As Object
  Dim strHex     As String
  Dim strSerial  As String
  Dim strDrive   As String
 
' ---------------------------------------------------------------------------
' Instantsiate Scripting object
' ---------------------------------------------------------------------------
  Set FSO = New Scripting.FileSystemObject
  lngDriveType = 0
 
' ---------------------------------------------------------------------------
' separate the drive letter
' ---------------------------------------------------------------------------
  If Mid$(strSearchData, 2, 1) = ":" Then
      ' capture just the drive letter and colon
      strDrive = Left$(strSearchData, 2)
  Else
      ' bad input data.  Leave here.
      Drive_Exist = False
      GoTo Normal_Exit
  End If
 
' ---------------------------------------------------------------------------
' Get the drive information.  If a floppy drive, a disk does not have to be
' present to determine its existance.  A disk does have to be present to
' gather any additional information.  This is why we use the "IsReady"
' property.
' ---------------------------------------------------------------------------
  If FSO.DriveExists(strDrive) Then
     
      Set objDrive = FSO.GetDrive(strDrive)
     
      ' See if the drive is ready to be queried
      If IsDriveReady(strDrive) Then
          With DI
               .DriveLetter = objDrive.DriveLetter
               .ShareName = objDrive.ShareName
               .Path = objDrive.Path
               .RootFolder = objDrive.RootFolder
                
               ' format drive serial number
               strHex = Right$(String$(8, "0") & Hex(objDrive.SerialNumber), 8)
               strSerial = Left$(strHex, 4) & "-" & Right$(strHex, 4)
               .SerialNumber = StrConv(strSerial, vbUpperCase)
                
               ' get volume label, if any
               .VolumeName = objDrive.VolumeName
                              
               ' Disk space data (handles all sizes)
               .TotalSize = objDrive.TotalSize
               .AvailableSpace = objDrive.AvailableSpace
               .FreeSpace = objDrive.FreeSpace
              
               ' Drive type:
               '    0  Unknown drive type
               '    1  Local hard drive
               '    2  Floppy or other removable drive
               '    3  Local hard drive (sometimes network drive)
               '    4  Shared Network drive
               '    5  CD-Rom device
               '    6  Virtual memory disk
               .DriveType = objDrive.DriveType
                           
               .FileSystem = objDrive.FileSystem  ' FAT, NTFS, etc.
               .IsReady = IIf(objDrive.IsReady = True, "1", "0")
          End With
         
          lngDriveType = DI.DriveType
          Drive_Exist = True   ' Success
      Else
          Drive_Exist = False  ' not ready to be queried
      End If
  Else
      Drive_Exist = False      ' Drive does not exist
  End If
     
Normal_Exit:
  On Error GoTo 0    ' nullify this error routine
  Set objDrive = Nothing
  Set FSO = Nothing
 
End Function
 
Public Function File_Exist(strSearchItem As String) As Boolean

' ***************************************************************************
' Routine:       File_Exist
'
' Description:   Test to see if a file exists. Need the fully qualified path.
'
' Parameters:    strSearchItem - Path\filename to be queried.
'
' Returns:       True or False
'
' ===========================================================================
'    DATE      NAME / DESCRIPTION
' -----------  --------------------------------------------------------------
' 26-NOV-2000  Kenneth Ives  kenaso@home.com
'              Routine created
' ***************************************************************************

' ---------------------------------------------------------------------------
' Define local variables
' ---------------------------------------------------------------------------
  Dim lngType      As Long
  Dim strDriveLtr  As String
 
' ---------------------------------------------------------------------------
' See if anything valid was passed here
' ---------------------------------------------------------------------------
  If Len(Trim$(strSearchItem)) = 0 Then
      File_Exist = False
      Exit Function
  End If
 
' ---------------------------------------------------------------------------
' Initialize variables
' ---------------------------------------------------------------------------
  lngType = 0
  strDriveLtr = Left$(strSearchItem, 2)
 
' ---------------------------------------------------------------------------
' see if this is a valid drive letter
' ---------------------------------------------------------------------------
  If Not Drive_Exist(strDriveLtr, lngType) Then
      File_Exist = False
      Exit Function
  End If
 
' ---------------------------------------------------------------------------
' Determine the drive type.
'    Unknown       = 0  unknown drive type
'    DRV_FIXED1    = 1  Local hard drive
'    DRV_REMOVABLE = 2  Floppy or other removeable drive
'    DRV_FIXED2    = 3  Local hard drive (sometimes network drive)
'    DRV_NETWORK   = 4  Shared Network drive
'    DRV_CDROM     = 5  CD-Rom device
'    DRV_RAMDISK   = 6  Virtual memory disk
' ---------------------------------------------------------------------------
  If lngType = 0 Then
      File_Exist = False
      Exit Function
  End If
 
' ---------------------------------------------------------------------------
' Check to see if this is a valid folder or are we in the root directory?
' If the length is equal to three then this must be the root and we have
' already tested the drive letter.
' ---------------------------------------------------------------------------
  If Len(strSearchItem) > 3 Then
      If Not Folder_Exist(strSearchItem) Then
          File_Exist = False
          Exit Function
      End If
  End If

' ---------------------------------------------------------------------------
' Instantsiate Scripting object
' ---------------------------------------------------------------------------
  Set FSO = New Scripting.FileSystemObject
 
' ---------------------------------------------------------------------------
' Return either TRUE or FALSE
' ---------------------------------------------------------------------------
  If FSO.FileExists(strSearchItem) Then
      File_Exist = True
  Else
      File_Exist = False
  End If
 
' ---------------------------------------------------------------------------
' Free object from memory
' ---------------------------------------------------------------------------
  Set FSO = Nothing
 
End Function

Public Function Folder_Exist(ByVal strFolder As String) As Boolean
 
' ***************************************************************************
' Routine:       Folder_Exist
'
' Description:   Test for the existance of a folder.
'
' Parameters:    strFolder - full path/folder name
'
' Returns:       True or False
'
' ===========================================================================
'    DATE      NAME / DESCRIPTION
' -----------  --------------------------------------------------------------
' 26-NOV-2000  Kenneth Ives  kenaso@home.com
'              Routine created
' ***************************************************************************

' ---------------------------------------------------------------------------
' Instantsiate Scripting object
' ---------------------------------------------------------------------------
  Set FSO = New Scripting.FileSystemObject

' ---------------------------------------------------------------------------
' See if a file extension is found
' ---------------------------------------------------------------------------
  If InStr(1, Right$(strFolder, 5), ".") > 0 Then
      strFolder = FSO.GetParentFolderName(strFolder)
  End If
 
' ---------------------------------------------------------------------------
' Make sure there are no trailing backslashes
' ---------------------------------------------------------------------------
  strFolder = Remove_Trailing_Slash(strFolder)

' ---------------------------------------------------------------------------
' test for the folder existance
' ---------------------------------------------------------------------------
  If FSO.FolderExists(strFolder) Then
      Folder_Exist = True
  Else
      Folder_Exist = False
  End If
  
' ---------------------------------------------------------------------------
' Free object from memory
' ---------------------------------------------------------------------------
  Set FSO = Nothing
 
End Function

Public Function Available_Drives() As Variant

' ***************************************************************************
' Routine:       Available_Drives
'
' Description:   Get the list of available drive letters, each separated by
'                a null character.  (i.e.  a:\ c:\ d:\)
'
' Returns:       Array of available drive letters.  REceiving array must
'                be a string array.
'
' ===========================================================================
'    DATE      NAME / DESCRIPTION
' -----------  --------------------------------------------------------------
' 12-MAY-1999  Kenneth Ives  kenaso@home.com
'              Routine created
' ***************************************************************************

' ---------------------------------------------------------------------------
' Define local variables
' ---------------------------------------------------------------------------
  Dim strDriveLtrs  As String
  Dim arDrives()    As String
  Dim intPosition   As Integer
 
' ---------------------------------------------------------------------------
' Use spaces and not null values.  Reduces your chance for errors.
' ---------------------------------------------------------------------------
  strDriveLtrs = Space$(MAX_SIZE)
 
' ---------------------------------------------------------------------------
' capture all the available drives in one long string
' ---------------------------------------------------------------------------
  GetLogicalDriveStrings Len(strDriveLtrs), strDriveLtrs
 
' ---------------------------------------------------------------------------
' get rid of excess trailing blank spaces
' ---------------------------------------------------------------------------
  strDriveLtrs = Trim$(strDriveLtrs)
 
' ---------------------------------------------------------------------------
' get rid of trailing nulls
' ---------------------------------------------------------------------------
  intPosition = InStrRev(strDriveLtrs, "", Len(strDriveLtrs))
  strDriveLtrs = Left$(strDriveLtrs, intPosition)
 
' ---------------------------------------------------------------------------
' load drive letters into an array
' ---------------------------------------------------------------------------
  arDrives = Split(strDriveLtrs, Chr$(0))
 
' ---------------------------------------------------------------------------
' Return the array of drive letters
' ---------------------------------------------------------------------------
  Available_Drives = arDrives()

End Function

Public Function IsThisRestricted(strPath As String) As Boolean

' ***************************************************************************
' Routine:       IsThisRestricted
'
' Description:   Determines if we have read, write, delete authority
'
' Parameters:    strPath - area to test
'
' Returns:       True - If this area does not allow updates
'                False - If this is a valid work area
'
' ===========================================================================
'    DATE      NAME / DESCRIPTION
' -----------  --------------------------------------------------------------
' 12-MAY-1999  Kenneth Ives  kenaso@home.com
'              Routine created
' ***************************************************************************

  On Error GoTo IsThisRestricted_Errors
' ---------------------------------------------------------------------------
' Define local variables
' ---------------------------------------------------------------------------
  Dim intFile      As Integer
  Dim strTmpPath   As String
 
' ---------------------------------------------------------------------------
' initialize local variables
' ---------------------------------------------------------------------------
  intFile = FreeFile
  strTmpPath = Trim$(strPath)
 
' ---------------------------------------------------------------------------
' See if there is a file parameter on the end of these path strings.  If so,
' remove it so we can see if we have access to their areas.
' ---------------------------------------------------------------------------
  If Len(Trim$(strTmpPath)) > 0 Then
 
      ' add trailing "" if missing and the dummy filename
      strTmpPath = Add_Trailing_Slash(strTmpPath)
      strTmpPath = strTmpPath & "_Test.$$$"
     
      ' Test to see if we have full authority in this area.
      ' First - Create, Write, Save
      Open strTmpPath For Output As #intFile  ' Open the file
      Print #intFile, "X"                     ' Write to the file
      Close #intFile                          ' Save the file
     
      ' Second - Read, Update
      Open strTmpPath For Append As #intFile  ' Open the file
      Print #intFile, "ABC"                   ' add to the file
      Close #intFile                          ' Save the file
     
      ' Third - Delete
      Kill strTmpPath                         ' Delete the file
      '
      IsThisRestricted = False
  Else
      IsThisRestricted = True
  End If
 
  Exit Function
 
' ---------------------------------------------------------------------------
' If an error occurs on any of the above steps, we are in a restricted area.
' ---------------------------------------------------------------------------
IsThisRestricted_Errors:
  IsThisRestricted = True
  On Error GoTo 0
 
End Function

Public Function Get_FileInfo(strFilename As String) As Boolean
   
' ***************************************************************************
' Routine:       Get_FileInfo
'
' Description:   Gathers all information about a file
'
' Parameters:    strFileName - fully qualified path\filename to be queried
'
' Returns:       True or False
'
' ===========================================================================
'    DATE      NAME / DESCRIPTION
' -----------  --------------------------------------------------------------
' 26-NOV-2000  Kenneth Ives  kenaso@home.com
'              Routine created
' ***************************************************************************

  On Error GoTo Normal_Exit
' ---------------------------------------------------------------------------
' Define local variables
' ---------------------------------------------------------------------------
  Dim objFile    As Object
  Dim strAttr    As String
 
' ---------------------------------------------------------------------------
' Instantsiate Scripting object
' ---------------------------------------------------------------------------
  strAttr = ""
  Get_FileInfo = False
  Set FSO = New Scripting.FileSystemObject

' ---------------------------------------------------------------------------
' Verify something was passed here
' ---------------------------------------------------------------------------
  If Len(Trim$(strFilename)) = 0 Then
      Exit Function
  End If
       
' ---------------------------------------------------------------------------
' get the file data
' ---------------------------------------------------------------------------
  Set objFile = FSO.GetFile(strFilename)
 
' ---------------------------------------------------------------------------
' Store the file information
' ---------------------------------------------------------------------------
  With FI
       .Drive = objFile.Drive
       .Path = objFile.Path
       .ParentFolder = objFile.ParentFolder
       .Size = objFile.Size
       .Type = objFile.Type
       .Extension = FSO.GetExtensionName(objFile.Path)
       .DateLastAccessed = objFile.DateLastAccessed
       .DateLastModified = objFile.DateLastModified
       .DateCreated = objFile.DateCreated
       .Attributes = Attribute_String(CLng(objFile.Attributes))
  End With
 
  Get_FileInfo = True
 
Normal_Exit:
  On Error GoTo 0    ' nullify this error routine
  Set objFile = Nothing
  Set FSO = Nothing
 
End Function

Public Function Attribute_String(ByVal lngValue As Long) As String

' ***************************************************************************
' Routine:       Attribute_String
'
' Description:   The numeric value representing the attributes of a
'                directory or file are passed and the alphabetic
'                representation is returned.
'
'                Syntax::    Attribute_String 35
'                            Returns   "RHA"
'
' Parameters:    lngValue - numeric attribute representation passed into this
'                           routine
'
' Returns:       Alphabetic attributes are returned
'
' ===========================================================================
'    DATE      NAME / DESCRIPTION
' -----------  --------------------------------------------------------------
' 26-NOV-2000  Kenneth Ives  kenaso@home.com
'              Routine created
' ***************************************************************************

' ---------------------------------------------------------------------------
' Define local variables
' ---------------------------------------------------------------------------
  Dim strTmp As String
 
' ---------------------------------------------------------------------------
' Intialize variables
' ---------------------------------------------------------------------------
  strTmp = ""
 
' ---------------------------------------------------------------------------
' Determine the attribute combination
' ---------------------------------------------------------------------------
  Select Case lngValue
         Case 1:  strTmp = "R"
         Case 2:  strTmp = "H"
         Case 3:  strTmp = "RH"
         Case 4:  strTmp = "S"
         Case 5:  strTmp = "RS"
         Case 6:  strTmp = "HS"
         Case 7:  strTmp = "RHS"
         Case 8:  strTmp = "V"
         Case 16: strTmp = "D"
         Case 17: strTmp = "DR"
         Case 18: strTmp = "DH"
         Case 19: strTmp = "DRH"
         Case 20: strTmp = "DS"
         Case 23: strTmp = "DRHS"
         Case 32: strTmp = "A"
         Case 33: strTmp = "RA"
         Case 34: strTmp = "HA"
         Case 35: strTmp = "RHA"
         Case 36: strTmp = "RHSA"
         Case 48: strTmp = "DA"
         Case 49: strTmp = "DRA"
         Case 50: strTmp = "DHA"
         Case 51: strTmp = "DRHA"
         Case 52: strTmp = "DSA"
         Case 53: strTmp = "DRSA"
         Case 54: strTmp = "DHSA"
         Case 55: strTmp = "DRHSA"
         Case 64: strTmp = "Alias"
         Case Else: strTmp = ""
  End Select

' ---------------------------------------------------------------------------
' Return the attribute string
' ---------------------------------------------------------------------------
  Attribute_String = strTmp
 
End Function

Public Function Move_File(strSource As String, strTarget As String) As Boolean
   
  On Error GoTo Move_File_Errors
' ---------------------------------------------------------------------------
' Define local variables
' ---------------------------------------------------------------------------
  Dim intAttr  As Integer
  Dim intResp  As Integer
  Dim varMsg   As Variant
 
' ---------------------------------------------------------------------------
' Instantsiate Scripting object
' ---------------------------------------------------------------------------
  Set FSO = New Scripting.FileSystemObject

' ---------------------------------------------------------------------------
' See if the target file already exist
' ---------------------------------------------------------------------------
  If FSO.FileExists(strTarget) Then
      varMsg = "File already exist at" & vbCrLf & strTarget & vbCrLf
      varMsg = varMsg & FI.DateLastModified & vbCrLf
      varMsg = varMsg & FI.Size & vbCrLf & vbCrLf & "Do you want to replace it?"
     
      intResp = MsgBox(varMsg, vbQuestion + vbYesNo + vbDefaultButton1, "Replace File?")
     
      If intResp = vbNo Then
          Move_File = False
          GoTo Normal_Exit
      Else
          SetAttr strTarget, vbNormal ' remove target file attributes
          Kill strTarget              ' delete the target file
      End If
  End If
 
' ---------------------------------------------------------------------------
' Move the file
' ---------------------------------------------------------------------------
  intAttr = GetAttr(strSource)
  FSO.MoveFile strSource, strTarget
  SetAttr strTarget, intAttr
  Move_File = True
 
Normal_Exit:
  On Error GoTo 0    ' nullify this error routine
  Set FSO = Nothing
  Exit Function

Move_File_Errors:
  MsgBox "Error: " & CStr(Err.Number) & "  " & Err.Description & vbCrLf & _
         vbCrLf & "Error while moving a file" & vbCrLf & vbCrLf & _
         "FROM: " & strSource & vbCrLf & "TO: " & strTarget, _
         vbInformation + vbOKOnly, "Errors detected"
  Move_File = False
  GoTo Normal_Exit
   
End Function

Public Function Copy_File(strSource As String, strTarget As String) As Boolean
   
' ***************************************************************************
' Routine:       Copy_File
'
' Description:   copies a file to another location
'
' Parameters:    strSource - Full qualified path and file name to be copied
'                strTarget - Full qualified path as a destination
'
' Returns:       TRUE/FALSE
'
' ===========================================================================
'    DATE      NAME / DESCRIPTION
' -----------  --------------------------------------------------------------
' 26-NOV-2000  Kenneth Ives  kenaso@home.com
'              Routine created
' ***************************************************************************

  On Error GoTo Copy_File_Errors
' ---------------------------------------------------------------------------
' Define local variables
' ---------------------------------------------------------------------------
  Dim intAttr  As Integer
  Dim intResp  As Integer
  Dim varMsg   As Variant
 
' ---------------------------------------------------------------------------
' Instantsiate Scripting object
' ---------------------------------------------------------------------------
  Set FSO = New Scripting.FileSystemObject

' ---------------------------------------------------------------------------
' See if the target file already exist
' ---------------------------------------------------------------------------
  If FSO.FileExists(strTarget) Then
      varMsg = "File already exist at" & vbCrLf & strTarget & vbCrLf
      varMsg = varMsg & FI.DateLastModified & vbCrLf
      varMsg = varMsg & FI.Size & vbCrLf & vbCrLf & "Do you want to replace it?"
     
      intResp = MsgBox(varMsg, vbQuestion + vbYesNo + vbDefaultButton1, "Replace File?")
     
      If intResp = vbNo Then
          Copy_File = False
          GoTo Normal_Exit
      Else
          SetAttr strTarget, vbNormal ' remove target file attributes
          Kill strTarget              ' delete the target file
      End If
  End If
 
' ---------------------------------------------------------------------------
' Copy the file to the new destination
' ---------------------------------------------------------------------------
  intAttr = GetAttr(strSource)
  FSO.CopyFile strSource, strTarget, True
  SetAttr strTarget, intAttr
  Copy_File = True
   
   
Normal_Exit:
  On Error GoTo 0    ' nullify this error routine
  Set FSO = Nothing
  Exit Function

Copy_File_Errors:
  MsgBox "Error: " & CStr(Err.Number) & "  " & Err.Description & vbCrLf & _
         vbCrLf & "Error while copying a file" & vbCrLf & vbCrLf & _
               "FROM: " & strSource & vbCrLf & "TO: " & strTarget, _
               vbExclamation + vbOKOnly, "Error Detected"
  Copy_File = False
  GoTo Normal_Exit
   
End Function

Public Function DelTree32(strPath As String) As Boolean
 
' ***************************************************************************
' Routine:       DelTree32
'
' Description:   Deletes a path and all of its subfolders
'
' Parameters:    strPath - Full path to be queried
'
' Returns:       TRUE/FALSE
'
' ===========================================================================
'    DATE      NAME / DESCRIPTION
' -----------  --------------------------------------------------------------
' 26-NOV-2000  Kenneth Ives  kenaso@home.com
'              Routine created
' ***************************************************************************

  On Error GoTo DelTree32_Errors
' ---------------------------------------------------------------------------
' Instantsiate Scripting object
' ---------------------------------------------------------------------------
  Set FSO = New Scripting.FileSystemObject

' ---------------------------------------------------------------------------
' Delete complete directory and its sub-directories
' ---------------------------------------------------------------------------
  FSO.DeleteFolder strPath, True
  DelTree32 = True
   
   
Normal_Exit:
  On Error GoTo 0    ' nullify this error routine
  Set FSO = Nothing
  Exit Function

DelTree32_Errors:
  MsgBox "Error: " & CStr(Err.Number) & "  " & Err.Description & vbCrLf & _
         vbCrLf & "Error while deleting path " & vbCrLf & strPath & _
         vbExclamation + vbOKOnly, "Error Detected"
  DelTree32 = False
  GoTo Normal_Exit
   
End Function

Public Function Add_Trailing_Slash(ByVal strPath As String) As String

' ***************************************************************************
' Routine:       Add_Trailing_Slash
'
' Description:   Add the trailing backslash from the path if it does not exist
'
' Parameters:    strPath - Full path to be queried
'
' Returns:       Reformatted path
'
' ===========================================================================
'    DATE      NAME / DESCRIPTION
' -----------  --------------------------------------------------------------
' 26-NOV-2000  Kenneth Ives  kenaso@home.com
'              Routine created
' ***************************************************************************

' ---------------------------------------------------------------------------
' Initialize variables
' ---------------------------------------------------------------------------
  strPath = Trim$(strPath)
  
' ---------------------------------------------------------------------------
' Test for trailing backslash
' ---------------------------------------------------------------------------
  If Right$(strPath, 1) = "" Then
      Add_Trailing_Slash = strPath
  Else
      Add_Trailing_Slash = strPath & ""
  End If
  
End Function

Public Function Remove_Trailing_Slash(ByVal strPath As String) As String

' ***************************************************************************
' Routine:       Remove_Trailing_Slash
'
' Description:   Removes the trailing backslash from the path if it exist
'
' Parameters:    strPath - Full path to be queried
'
' Returns:       Reformatted path
'
' ===========================================================================
'    DATE      NAME / DESCRIPTION
' -----------  --------------------------------------------------------------
' 26-NOV-2000  Kenneth Ives  kenaso@home.com
'              Routine created
' ***************************************************************************

' ---------------------------------------------------------------------------
' Initialize variables
' ---------------------------------------------------------------------------
  strPath = Trim$(strPath)
  
' ---------------------------------------------------------------------------
' Remove the trailing backslash if it exist
' ---------------------------------------------------------------------------
  If Right$(strPath, 1) = "" Then
      Remove_Trailing_Slash = Left$(strPath, Len(strPath) - 1)
  Else
      Remove_Trailing_Slash = strPath
  End If
  
End Function

Public Function TextSearch(strPath As String, strText As String) As Variant

' ***************************************************************************
' Routine:       TextSearch
'
' Description:   How to search the files in a directory for a piece of
'                text. The most basic way to do this manually is to loop
'                through the files in a directory, open each one, and
'                search the text using a function like InStr.
'
' Parameters:    strPath - path to be searched
'                strText - Data string to look for
'
' Returns:       An array with the finames that contain this string
'
' ===========================================================================
'    DATE      NAME / DESCRIPTION
' -----------  --------------------------------------------------------------
' 26-NOV-2000  Kenneth Ives  kenaso@home.com
'              Routine created
' ***************************************************************************

' ---------------------------------------------------------------------------
' Define local variables
' ---------------------------------------------------------------------------
  Dim objStream  As Scripting.TextStream
  Dim objFolder  As Scripting.Folder
  Dim objFile    As Scripting.File
  Dim strTmp     As String
  Dim arData()   As String
  Dim lngIndex   As Long
 
' ---------------------------------------------------------------------------
' Instantsiate Scripting object
' ---------------------------------------------------------------------------
  Set FSO = New Scripting.FileSystemObject

' ---------------------------------------------------------------------------
' Initialize local variables
' ---------------------------------------------------------------------------
  Set objFolder = FSO.GetFolder(strPath)
  lngIndex = 0
  ReDim arData(100)
 
' ---------------------------------------------------------------------------
' Open each file and look for the text string
' ---------------------------------------------------------------------------
  For Each objFile In objFolder.Files
 
      ' open the file for read only
      Set objStream = objFile.OpenAsTextStream(ForReading)
         
      ' dump the contents into a variable
      strTmp = objStream.ReadAll
     
      If InStr(1, strTmp, strText, vbTextCompare) > 0 Then
          arData(lngIndex) = objFile.Path    ' save the file path information
          lngIndex = lngIndex + 1            ' increment the index
         
          ' see if we have to increase the array size
          ' by another 100 elements
          If lngIndex = UBound(arData) Then
              ReDim Preserve arData(lngIndex + 100)
          End If
      End If
  Next

' ---------------------------------------------------------------------------
' See if we found anything. If nothing was found, return "N/A" in the first
' element of the array.
' ---------------------------------------------------------------------------
  If lngIndex > 0 Then
      lngIndex = lngIndex - 1         ' readjust the index (backup one)
      ReDim Preserve arData(lngIndex) ' resize array to just what was used
  Else
      Erase arData()                  ' empty the array
      ReDim arData(1)                 ' resize to the smallest amount
      arData(0) = "N/A"               ' Show we did not find anything
  End If
 
' ---------------------------------------------------------------------------
' Return the array of data
' ---------------------------------------------------------------------------
  TextSearch = arData()
 
' ---------------------------------------------------------------------------
' Free objects from memory
' ---------------------------------------------------------------------------
  Set objStream = Nothing
  Set objFile = Nothing
  Set objFolder = Nothing
  Set FSO = Nothing
 
End Function

Public Function Get_Totals(ByVal strPath As String, _
              Optional intDataType As Integer = 1, _
              Optional strPattern As String = "*.*", _
              Optional ByVal blnSearchSubfolders As Boolean = True) As String
   
' ***************************************************************************
' Routine:       Get_Totals
'
' Description:   Gather certain file information as a total
'
' Parameters:    strPath - directory path to be parsed
'                intDataType - Type of data to be returned
'                1 - Total amount of data in this path based on a pattern
'                2 - Total number of files last accessed  on or after a certain date
'                3 - Total number of files last modified on or after a certain date
'                4 - Total number of files created on or after a certain date
'                strPattern - file search pattern (i.e. "*.*" or "*.exe") or
'                    a date (i.e. "10/02/1995)" or "10/2/95")
'                blnSearchSubfolders [OPTIONAL] TRUE-[DEFAULT] Search designated
'                            folder and any subfolders
'                    FALSE - Search designated folder only, do not search any
'                            subfolders
'
' Returns:       Either total amount or count
'
' NOTE:  There are certain files that Scrrun.dll will not report on.  One is
'        the swap file (c:\pagefile.sys").
'
' ===========================================================================
'    DATE      NAME / DESCRIPTION
' -----------  --------------------------------------------------------------
' 26-NOV-2000  Kenneth Ives  kenaso@home.com
'              Routine created
' ***************************************************************************

' ---------------------------------------------------------------------------
' Define local variables
' ---------------------------------------------------------------------------
  Dim objFolder    As Scripting.Folder
  Dim strTmp       As String
  Dim strFileList  As String
  Dim strList()    As String
  Dim strFileData  As String
  Dim strInfo      As String
  Dim lngIndex     As Long
  Dim lngMax       As Long
  Dim dblCounter   As Double
  Dim intPosition  As Integer

' ---------------------------------------------------------------------------
' Initialize variables
' ---------------------------------------------------------------------------
  dblCounter = 0
  strInfo = ""
  strFileData = strPattern
   
' ---------------------------------------------------------------------------
' Instantsiate Scripting object
' ---------------------------------------------------------------------------
  Set FSO = New Scripting.FileSystemObject

' ---------------------------------------------------------------------------
' Make sure something valid was passed here
' ---------------------------------------------------------------------------
  If intDataType < 1 Or intDataType > 4 Then
      GoTo Normal_Exit
  ElseIf Len(Trim$(strPath)) = 0 Then
      GoTo Normal_Exit
  End If
 
' ---------------------------------------------------------------------------
' Make sure a date was passed to this routine, if we are comparing dates.
' ---------------------------------------------------------------------------
  If intDataType > 1 Then
      On Error Resume Next
      If Not IsDate(CDate(strFileData)) Then
          MsgBox "An invalid date was passed.", _
                 vbInformation + vbOKOnly, "Invalid date format"
          GoTo Normal_Exit
      End If
      On Error GoTo 0
  End If
                      
  On Error GoTo Get_Totals_Errors
' ---------------------------------------------------------------------------
' let the private subroutine do all the work
' ---------------------------------------------------------------------------
  strFileList = Get_FileList(strPath, blnSearchSubfolders, strPattern)
 
' ---------------------------------------------------------------------------
' Remove the trailing ";" (semi-colon)
' ---------------------------------------------------------------------------
  If Right$(strFileList, 1) = ";" Then
      strFileList = Left$(strFileList, Len(strFileList) - 1)
  End If
 
' ---------------------------------------------------------------------------
' load the returned data into an array
' ---------------------------------------------------------------------------
  strList = Split(strFileList, ";")
  lngMax = UBound(strList)
 
' ---------------------------------------------------------------------------
' Loop thru the array of file names and collect the file information
' ---------------------------------------------------------------------------
  For lngIndex = 0 To lngMax - 1
 
       ' see if there is an empty element is this array
       If Len(Trim$(strList(lngIndex))) = 0 Then
           Exit For   ' leave if we do not have any data
       End If
      
       ' gather the file information
       If Get_FileInfo(strList(lngIndex)) Then
      
           ' evaluate the type of data to be returned
           Select Case intDataType
                 
                  Case 1: ' Total amount of data in this path
                       dblCounter = dblCounter + FI.Size
                       RaiseEvent CountTotals(dblCounter, strList(lngIndex))
                 
                  Case 2: ' Total number of files accessed on or after a certain date
                      
                       ' capture just the last accessed date
                       intPosition = InStr(1, FI.DateLastAccessed, Chr$(32))
                      
                       If intPosition = 0 Then
                           strTmp = FI.DateLastAccessed
                       Else
                           strTmp = Left$(FI.DateLastAccessed, intPosition - 1)
                       End If
                      
                       ' make the comparison
                       If CDate(strTmp) >= CDate(strFileData) Then
                           dblCounter = dblCounter + 1
                           RaiseEvent CountTotals(dblCounter, strList(lngIndex))
                       End If
          
                  Case 3: ' Total number of files modified on or after a certain date
                      
                       ' capture just the last modified date
                       intPosition = InStr(1, FI.DateLastModified, Chr$(32))
                      
                       If intPosition = 0 Then
                           strTmp = FI.DateLastModified
                       Else
                           strTmp = Left$(FI.DateLastModified, intPosition - 1)
                       End If
                                             
                       ' make the comparison
                       If CDate(strTmp) >= CDate(strFileData) Then
                           dblCounter = dblCounter + 1
                           RaiseEvent CountTotals(dblCounter, strList(lngIndex))
                       End If
          
                  Case 4: ' Total number of files created on or after a certain date
                      
                       ' capture just the created date
                       intPosition = InStr(1, FI.DateCreated, Chr$(32))
                      
                       If intPosition = 0 Then
                           strTmp = FI.DateCreated
                       Else
                           strTmp = Left$(FI.DateCreated, intPosition - 1)
                       End If
                      
                       ' make the comparison
                       If CDate(strTmp) >= CDate(strFileData) Then
                           dblCounter = dblCounter + 1
                           RaiseEvent CountTotals(dblCounter, strList(lngIndex))
                       End If
                 
                  Case 5: ' Total number of a particular type of file.
                       ' A text compare is performed because it does not
                       ' distinguish between upper and lower case characters
                       If StrComp(FI.Type, strFileData, vbTextCompare) = 0 Then
                           dblCounter = dblCounter + 1
                           RaiseEvent CountTotals(dblCounter, strList(lngIndex))
                       End If
          End Select
      End If
  Next
 
Normal_Exit:
' ---------------------------------------------------------------------------
' Convert to a string before leaving.
' ---------------------------------------------------------------------------
  On Error GoTo 0    ' nullify this error routine
  Get_Totals = CStr(dblCounter)
 
' ---------------------------------------------------------------------------
' Free objects from memory
' ---------------------------------------------------------------------------
  Set objFolder = Nothing
  Set FSO = Nothing
  Exit Function
 
Get_Totals_Errors:
  MsgBox "Error: " & CStr(Err.Number) & "  " & Err.Description & vbCrLf & vbCrLf & _
         "File: " & strList(lngIndex) & vbCrLf & _
         "Size: " & Format$(FI.Size, "#,0") & vbCrLf & _
         "Created:  " & FI.DateCreated & vbCrLf & _
         "Modified: " & FI.DateLastModified & vbCrLf & _
         "Accessed: " & FI.DateLastAccessed, vbInformation + vbOKOnly, _
         "Errors detected"
  dblCounter = 0
  GoTo Normal_Exit

End Function

Public Function Get_FileList(ByVal strFolder As String, _
                             Optional ByVal blnSearchSubfolders As Boolean = True, _
                             Optional strPattern As String = "*.*") As Variant
   
' ***************************************************************************
' Routine:       Get_FileList
'
' Description:   procedure that returns a file list as a comma-delimited
'                list of files
'
' Parameters:    strFolder - Full path to folder
'                blnSearchSubfolders [OPTIONAL] TRUE-[DEFAULT] Search designated
'                          folder and any subfolders
'                          FALSE - Search designated folder only, do not
'                          search any subfolders
'                strPattern - [OPTIONAL] [DEFAULT] "*.*" (all files)
'
' Returns:       A string of files delimited by ";"
'
' Syntax:        Get_FileList("C:\Zip", True, "*.zip")
'                Ex:  Return a list of all ZIP files
'                C:\Zip\File1.zip;C:\Zip\File2.zip;...C:\Zip\Level9\File1.zip;
'
' ===========================================================================
'    DATE      NAME / DESCRIPTION
' -----------  --------------------------------------------------------------
' 26-NOV-2000  Kenneth Ives  kenaso@home.com
'              Routine created
' 26-MAR-2001  Kenneth Ives  kenaso@home.com
'              Modified search pattern capabilities and documented
' ***************************************************************************

' ---------------------------------------------------------------------------
' Define local variables
' ---------------------------------------------------------------------------
  Dim objFile         As Scripting.File
  Dim objFolder       As Scripting.Folder
  Dim objSubFolder    As Scripting.Folder
  Dim strFileExt      As String
  Dim strTestExt      As String
  Dim strNewFolder    As String
  Dim blnGetAllFiles  As Boolean
 
' ---------------------------------------------------------------------------
' see if the user cancelled processing
' ---------------------------------------------------------------------------
  DoEvents
  If CancelProcessing Then
      Exit Function
  End If
     
' ---------------------------------------------------------------------------
' Instantsiate Scripting object
' ---------------------------------------------------------------------------
  Set FSO = New Scripting.FileSystemObject
  
' ---------------------------------------------------------------------------
' get the starting folder
' ---------------------------------------------------------------------------
  Set objFolder = FSO.GetFolder(strFolder)
 
' ---------------------------------------------------------------------------
' Test the pattern we are looking for
' ---------------------------------------------------------------------------
  If strPattern = "*.*" Then
      blnGetAllFiles = True
  ElseIf InStr(strPattern, "*") = 0 Then
      blnGetAllFiles = True
  Else
     ' looking for a specific pattern
      blnGetAllFiles = False
      strTestExt = StrConv(FSO.GetExtensionName(strPattern), vbLowerCase)
  End If
 
' ---------------------------------------------------------------------------
' Check all the files in this directory
' ---------------------------------------------------------------------------
  For Each objFile In objFolder.Files
 
      ' see if the user cancelled processing
      DoEvents
      If CancelProcessing Then
          Exit For
      End If
     
      If blnGetAllFiles Then
          ' capture all files
          Get_FileList = Get_FileList & objFile.Path & ";"
      Else
          ' look for a specific extension
          strFileExt = StrConv(FSO.GetExtensionName(objFile.Path), vbLowerCase)
         
          ' See if the file extensions match
          If StrComp(strTestExt, strFileExt, vbTextCompare) = 0 Then
              Get_FileList = Get_FileList & objFile.Path & ";"
              m_dblCount = m_dblCount + 1
              RaiseEvent CountFiles(m_dblCount, objFile.Path)
          End If
      End If
  Next
       
' ---------------------------------------------------------------------------
' see if the user cancelled processing
' ---------------------------------------------------------------------------
  DoEvents
  If CancelProcessing Then
      Get_FileList = ""
  Else
      ' if requested, also search subdirectories.
      If blnSearchSubfolders Then
     
          For Each objSubFolder In objFolder.SubFolders
             
              ' see if the user cancelled processing
              DoEvents
              If CancelProcessing Then
                  Exit For
              End If
             
              strNewFolder = objSubFolder
             
              ' Do recursive calls from here.
              Get_FileList = Get_FileList & _
                             Get_FileList(strNewFolder, blnSearchSubfolders, strPattern)
          Next
      End If
  End If
   
Normal_Exit:
' ---------------------------------------------------------------------------
' Free objects from memory
' ---------------------------------------------------------------------------
  Set objFile = Nothing
  Set objFolder = Nothing
  Set objSubFolder = Nothing
  Set FSO = Nothing
 
End Function

Public Function Get_DirList(ByVal strPath As String) As String
   
' ***************************************************************************
' Routine:       Get_DirList
'
' Description:   procedure that returns a list of folders in a string
'                delimited by a semi-colon
'
' Parameters:    strPath - path to be parsed
'
' Returns:       A directory list
'
' ===========================================================================
'    DATE      NAME / DESCRIPTION
' -----------  --------------------------------------------------------------
' 26-NOV-2000  Kenneth Ives  kenaso@home.com
'              Routine created
' ***************************************************************************

' ---------------------------------------------------------------------------
' Define local variables
' ---------------------------------------------------------------------------
  Dim objFolder     As Scripting.Folder
  Dim objSubFolder  As Scripting.Folder
  Dim strList       As String
 
' ---------------------------------------------------------------------------
' Initialize variables
' ---------------------------------------------------------------------------
  strList = ""
 
' ---------------------------------------------------------------------------
' Instantsiate Scripting object
' ---------------------------------------------------------------------------
  Set FSO = New Scripting.FileSystemObject
  Set objFolder = FSO.GetFolder(strPath)

' ---------------------------------------------------------------------------
' list all the folders within this folder
' ---------------------------------------------------------------------------
  For Each objSubFolder In objFolder.SubFolders
      ' see if the user cancelled processing
      DoEvents
      If CancelProcessing Then
          Exit For
      End If
     
      strList = strList & objSubFolder.Path & ";"
  Next
       
' ---------------------------------------------------------------------------
' see if the user cancelled processing
' ---------------------------------------------------------------------------
  DoEvents
  If CancelProcessing Then
      strList = ""
  Else
      ' Remove the last ";" (semi-colon)
      If Right$(strList, 1) = ";" Then
          strList = Left$(strList, Len(strList) - 1)
      End If
  End If
 
' ---------------------------------------------------------------------------
' Return the list of directories in a semi-colon delimited string
' ---------------------------------------------------------------------------
  Get_DirList = strList
 
' ---------------------------------------------------------------------------
' Free objects from memory
' ---------------------------------------------------------------------------
  Set objSubFolder = Nothing
  Set objFolder = Nothing
  Set FSO = Nothing
 
End Function

Public Function Create_Tmp_Filename(Optional strTmpFolder As String = vbNullString) As String

' ***************************************************************************
' Routine:       Create_Tmp_Filename
'
' Description:   System generated temporary folder and file.  The folder
'                will be located in the Windows default temp directory and
'                is system generated.
'
'                Found this example at http://www.vbapi.com/
'
' Parameters:    strTmpFolder - Path to the temporary folder.
'
' Returns:       Unique name of a temporary file
'
' ===========================================================================
'    DATE      NAME / DESCRIPTION
' -----------  --------------------------------------------------------------
' 02-DEC-1999  Kenneth Ives  kenaso@home.com
'              Routine created
' ***************************************************************************
  
' ---------------------------------------------------------------------------
' Define local variables
' ---------------------------------------------------------------------------
  Dim strPrefix   As String
  Dim strTmpFile  As String
  Dim lngRetCode  As Long
 
' ---------------------------------------------------------------------------
' Use spaces and not null values.  Reduces your errors.
' ---------------------------------------------------------------------------
  strPrefix = ""
  strTmpFile = Space$(MAX_SIZE)
     
' ---------------------------------------------------------------------------
' See if the temp folder path was passed.  If not, go get it.
' ---------------------------------------------------------------------------
  If Len(Trim$(strTmpFolder)) = 0 Then
      strTmpFolder = Space$(MAX_SIZE)                  ' initialize buffer
      lngRetCode = GetTempPath(MAX_SIZE, strTmpFolder) ' read the path name
 
      ' extract data from the variable (ex:  "C:\Temp")
      If lngRetCode Then
          ' We found the Windows default Temp folder.  Remove
          ' the trialing nulls and append the name of our
          ' temporary folder.
          strTmpFolder = Remove_Nulls(strTmpFolder)
          strTmpFolder = Add_Trailing_Slash(strTmpFolder)
      Else
          ' use root directory of drive C:\
          strTmpFolder = "C:"
      End If
  End If
 
' ---------------------------------------------------------------------------
' Create a unique temporary file name.  I define the prefix.  A four
' digit hex number is returned.  (Ex: 49489 becomes C151)
' ---------------------------------------------------------------------------
  strPrefix = Create_Tmp_Name(4)              ' Ex:  "res" will return "_res"
  lngRetCode = GetTempFileName(strTmpFolder, strPrefix, 0&, strTmpFile)

' ---------------------------------------------------------------------------
' Note that the file is also created for you. Extract data from the variable
' (Ex:  "C:\Temp\_resC151.TMP")
' ---------------------------------------------------------------------------
  strTmpFile = Remove_Nulls(strTmpFile)
 
' ---------------------------------------------------------------------------
' Return the path and name of the temp file
' ---------------------------------------------------------------------------
  Create_Tmp_Filename = strTmpFile
 
End Function

Public Function Create_Tmp_Folder() As String

' ***************************************************************************
' Routine:       Create_Tmp_Folder
'
' Description:   System generated temporary folder and file.  The folder
'                will be located in the Windows default temp directory and
'                is system generated.
'
'                Found this example at http://www.vbapi.com/
'
' Returns:       Name of the temp folder
'
' ===========================================================================
'    DATE      NAME / DESCRIPTION
' -----------  --------------------------------------------------------------
' 02-DEC-1999  Kenneth Ives  kenaso@home.com
'              Routine created
' ***************************************************************************
  
' ---------------------------------------------------------------------------
' Define local variables
' ---------------------------------------------------------------------------
  Dim strUniqueName  As String
  Dim strTmpFolder   As String
  Dim lngRetCode     As Long
 
' ---------------------------------------------------------------------------
' Instantsiate Scripting object
' ---------------------------------------------------------------------------
  Set FSO = New Scripting.FileSystemObject
 
' ---------------------------------------------------------------------------
' See if we can find the Windows temporary directory path.
' ---------------------------------------------------------------------------
  strUniqueName = Create_Tmp_Name(8)               ' Create a unique folder name
  strTmpFolder = Space$(MAX_SIZE)                  ' initialize buffer
  lngRetCode = GetTempPath(MAX_SIZE, strTmpFolder) ' read the path name
 
' ---------------------------------------------------------------------------
' extract data from the variable (ex:  "C:\Temp")
' ---------------------------------------------------------------------------
  If lngRetCode Then
      ' We found the Windows default Temp folder.  Remove
      ' the trialing nulls and append the name of our
      ' temporary folder.
      strTmpFolder = Remove_Nulls(strTmpFolder)
      strTmpFolder = Add_Trailing_Slash(strTmpFolder)
      strTmpFolder = strTmpFolder & strUniqueName
  Else
      ' We did not find the Windows default temp folder
      strTmpFolder = "C:" & strUniqueName
  End If
 
' ---------------------------------------------------------------------------
' Crate the new temp subfolder
' ---------------------------------------------------------------------------
  strTmpFolder = Remove_Trailing_Slash(strTmpFolder)
     
  If Not FSO.FolderExists(strTmpFolder) Then
      ' create the temp folder within the Windows temp folder
      FSO.CreateFolder (strTmpFolder)
  End If
 
' ---------------------------------------------------------------------------
' Return the full path to the new temp folder
' ---------------------------------------------------------------------------
  strTmpFolder = Add_Trailing_Slash(strTmpFolder)
  Create_Tmp_Folder = strTmpFolder
  Set FSO = Nothing
 
End Function

Public Function Remove_Nulls(strInput As String) As String
   
' ***************************************************************************
' Routine:       Remove_Nulls
'
' Description:   Receives a data string and looks for the first null.  If
'                found, the string is truncated at that point and returned.
'
' Parameters:    strInput - Input string to be inspected
'
' Returns:       Data string with the trailing nulls
'
' ===========================================================================
'    DATE      NAME / DESCRIPTION
' -----------  --------------------------------------------------------------
' 23-FEB-2000  Kenneth Ives  kenaso@home.com
'              Routine created
' ***************************************************************************

' ---------------------------------------------------------------------------
' Define local variables
' ---------------------------------------------------------------------------
  Dim intPosition As Integer
   
' ---------------------------------------------------------------------------
' Look for first null in the data string
' ---------------------------------------------------------------------------
  intPosition = InStr(1, strInput, Chr$(0))
 
' ---------------------------------------------------------------------------
' if we found one, then save all the data up to that position
' ---------------------------------------------------------------------------
  If intPosition Then
      Remove_Nulls = Left$(strInput, intPosition - 1)
  Else
      Remove_Nulls = strInput     ' no nulls found
  End If
     
End Function

Public Function Create_Tmp_Name(intLength As Integer) As String

' ***************************************************************************
' Routine:       Create_Tmp_Name
'
' Description:   System generated temporary name.  User determines the length
'                of the name, not to exceed eight characters.
'
' Parameters:    intLength - length of character string desired
'
' Returns:       New name
'
' ===========================================================================
'    DATE      NAME / DESCRIPTION
' -----------  --------------------------------------------------------------
' 09-APR-2000  Kenneth Ives  kenaso@home.com
'              Routine created
' ***************************************************************************
  
' ---------------------------------------------------------------------------
' Define local variables
' ---------------------------------------------------------------------------
  Dim strTmp    As String
  Dim intChar   As Integer
  Dim intIndex  As Integer
 
' ---------------------------------------------------------------------------
' Initialize variables
' ---------------------------------------------------------------------------
  strTmp = "_"  ' underscore is the first character
 
' ---------------------------------------------------------------------------
' Test length passed.  0=exit function;  1=save what we got and leave
' ---------------------------------------------------------------------------
  If intLength < Len(strTmp) Then
      Exit Function
  ElseIf intLength = Len(strTmp) Then
      Create_Tmp_Name = strTmp
      Exit Function
  End If
 
' ---------------------------------------------------------------------------
' Create string using 0-9, A-Z, a-z characters only
' ---------------------------------------------------------------------------
  Do
      intChar = Int(Rnd2(48, 122))      ' create character 0-9, A-Z, a-z
     
      Select Case intChar               ' test character creatation
             Case 58 To 64, 91 To 96
                  intChar = intChar + 7 ' add 7 to unwanted char value
      End Select
     
      strTmp = strTmp & Chr$(intChar)   ' append new char to output string
     
  Loop Until Len(strTmp) = intLength

' ---------------------------------------------------------------------------
' Return the new name
' ---------------------------------------------------------------------------
  Create_Tmp_Name = StrConv(strTmp, vbLowerCase)
 
End Function

Public Function Rnd2(sngLow As Single, sngHigh As Single) As Single
 
' ***************************************************************************
' Routine:       Rnd2
'
' Description:   Create a random value between two values.  We are assuming
'                that the random number generator has already been seeded.
'
' Parameters:    sngLow  - Low end value
'                sngHign - High end value
'
' Return Values: A random generated value
'
' ===========================================================================
'    DATE      NAME / eMAIL
'              DESCRIPTION
' -----------  --------------------------------------------------------------
' 26-JUN-1999  The VB2TheMax Team  fbalena@vb2themax.com
'              Routine created
' 03-OCT-2000  Kenneth Ives  kenaso@home.com
'              Modified and documented
' ***************************************************************************
  DoEvents        ' gives the system clock time to advance a few milliseconds
  Randomize (CDbl(Now()) + Timer)     ' Reseed the VB random number generator
  Rnd2 = (Rnd * (sngHigh - sngLow)) + sngLow

End Function

Public Function BrowseForFolder(Optional frm As Form = Nothing, _
                                Optional strPrompt As String = "") As String

' ***************************************************************************
' Routine:       BrowseForFolder
'
' Description:   Opens the Browse Dialog box so a folder may be slected by
'                the user.  Both parameters are optional.
'
' Parameters:    frm - name of form to align the upper left corner of the
'                      browse dialog box
'                strPrompt - Additional title line in the Browse dialog box
'
' Returns:       Full path to the folder
'
' ===========================================================================
'    DATE      NAME / DESCRIPTION
' -----------  --------------------------------------------------------------
' 23-FEB-1999  Kenneth Ives  kenaso@home.com
'              Routine created
' ***************************************************************************

' ---------------------------------------------------------------------------
' Define local variables
' ---------------------------------------------------------------------------
  Dim lngFolderList  As Long
  Dim lngRetCode     As Long
  Dim strTmpPath     As String
  Dim BI             As BrowseInfo

' ---------------------------------------------------------------------------
' Initialize variables
' ---------------------------------------------------------------------------
  strTmpPath = ""
  lngFolderList = 0
 
' ---------------------------------------------------------------------------
' Set up Browse Dialog Box parameters
' ---------------------------------------------------------------------------
  With BI
       ' See if form name was passed.  if not use a 0
       If frm Is Nothing Then
           .hWndOwner = 0&
       Else
           .hWndOwner = frm.hwnd
       End If
      
       ' strPrompt will be the title on the Browse dialog box
       .lpszTitle = lstrcat(strPrompt, "")
      
       ' Display only directories
       .ulFlags = BIF_RETURNONLYFSDIRS
  End With

' ---------------------------------------------------------------------------
' display the browse dialog box and  create an index of the folders in the
' dialog box
' ---------------------------------------------------------------------------
  lngFolderList = SHBrowseForFolder(BI)
 
' ---------------------------------------------------------------------------
' If a folder was highlighted then format the folder name so it can be
' returned
' ---------------------------------------------------------------------------
  If lngFolderList Then
     
      ' set up a pre-padded buffer area for the folder name.
      ' Use spaces and not null values.  Reduces your errors.
      strTmpPath = Space$(MAX_SIZE)
     
      ' Get the name of the folder from the list
      lngRetCode = SHGetPathFromIDList(lngFolderList, strTmpPath)
      Call CoTaskMemFree(lngFolderList)
     
      ' Strip any null characters from the folder name
      strTmpPath = Remove_Nulls(strTmpPath)
  End If

' ---------------------------------------------------------------------------
' return the formatted folder name
' ---------------------------------------------------------------------------
  BrowseForFolder = strTmpPath

End Function

Public Function Shrink_2_Fit(ByVal strPath_to_Resize As String, _
                             intMaxLen As Integer) As String

' ***************************************************************************
' Routine:       Shrink_2_Fit
'
' Description:   This function will shorten a directory name to the length
'                passed to the Max parameter.
'
' Syntax:
'        Shrink_2_Fit "C:\Program Files\Navigator\Programs\Bookmark.htm", 30
'        Returns -->  "C:\...\Programs\Bookmark.htm"
'
' Parameters:    strPath_to_Resize - Path to be resized for display
'                intMaxLen - Maximum length of the return string
'
' Returns:       Resized path
'
' ===========================================================================
'    DATE      NAME / DESCRIPTION
' -----------  --------------------------------------------------------------
' 23-FEB-1998  Kenneth Ives  kenaso@home.com
'              Routine created
' ***************************************************************************

' ---------------------------------------------------------------------------
' Define local variables
' ---------------------------------------------------------------------------
  Dim intPosition  As Integer
  Dim intStart     As Integer
  Dim intNeeded    As Integer
  Dim intLength    As Integer
  Dim strTmp       As String
  Dim strPrefix    As String
 
' ---------------------------------------------------------------------------
' Initialize variables
' ---------------------------------------------------------------------------
  strTmp = Trim$(strPath_to_Resize)

' ---------------------------------------------------------------------------
' if the string is equal to or less than the desired length then leave
' this routine
' ---------------------------------------------------------------------------
  If Len(strTmp) <= intMaxLen Then
      Shrink_2_Fit = strTmp
      Exit Function
  End If

' ---------------------------------------------------------------------------
' Prepare the drive and the elipces.  Start in the third position in case
' this is a UNC (Universal Naming Convention) path
' ---------------------------------------------------------------------------
  If Left$(strTmp, 2) = "\" Or Mid$(strTmp, 2, 1) = ":" Then
      intPosition = InStr(3, strTmp, "")            ' search for next backslash
      intStart = intPosition + 1                     ' calc new starting position
      intNeeded = intMaxLen - (intPosition + 3)      ' Add for 3 elipces
  Else
      Shrink_2_Fit = strTmp   ' do not know what this is.  get rid of it.
      Exit Function
  End If
 
' ---------------------------------------------------------------------------
' Build the prefix.  A drive letter or server_name, backslash and 3 elipces
' Example:   "C:\..." or "\\Server\..."
' ---------------------------------------------------------------------------
  strPrefix = Left$(strTmp, intPosition) & "..."
 
' ---------------------------------------------------------------------------
' prepare the suffix part of the path to the desired length
' ---------------------------------------------------------------------------
  Do
      intPosition = InStr(intStart, strTmp, "") ' look for a backslash
     
      If intPosition > 0 Then
          strTmp = Mid$(strTmp, intPosition)      ' Reformat string length
          intLength = Len(strTmp)
      Else
          Exit Do                                ' could not find "", so leave
      End If
     
  Loop Until intNeeded >= intLength
 
' ---------------------------------------------------------------------------
' Return the readjusted data string
' ---------------------------------------------------------------------------
  Shrink_2_Fit = strPrefix & strTmp
 
End Function

Public Function Get_Disk_Space(ByVal strPath As String, _
                               dblTotalSpace As Double, _
                               dblFreeSpace As Double, _
                               dblUsedSpace As Double) As Boolean
 
' ***************************************************************************
' Routine:       Get_Disk_Space
'
' Description:   Get the total number of bytes, total number of free bytes,
'                and total number of used bytes on a hard drive.  This  will
'                also determine which API call to make based on the size of
'                the drive.
'
' Parameters:    strDriveLtr   - drive to be queried (ex:  C:)
'                dblTotalSpace - Value to be returned
'                dblFreeSpace  - Value to be returned
'                dblUsedSpace  - Value to be returned
'
' Returns:       Total number of bytes, total number of free bytes, and total
'                number of used bytes on a drive.
'
' ===========================================================================
'    DATE      NAME             DESCRIPTION
' -----------  ---------------  ---------------------------------------------
' 03-MAR-2000  Kenneth Ives     Wrote routine
' 14-MAR-2000  Kenneth Ives     Modified and documented to handle under and
'                               over 2gb drives
' ***************************************************************************

' ---------------------------------------------------------------------------
' Define local variables
' ---------------------------------------------------------------------------
  Dim lngHandle                 As Long
  Dim lngRetCode                As Long
  Dim lngProcAddress            As Long
  Dim lngSectorsPerCluster      As Long
  Dim lngBytesPerSector         As Long
  Dim lngNumberOfFreeClusters   As Long
  Dim lngTotalNumberOfClusters  As Long
  Dim curFreeBytesToCaller      As Currency
  Dim curTotalFreeBytes         As Currency
  Dim curTotalBytes             As Currency
  Dim strDriveLtr               As String
 
'  Const TWO_GB                  As Double = 2147483647#
  Const TWO_GB                  As Double = 2200000000#
 
' ---------------------------------------------------------------------------
' Initialize variables
' ---------------------------------------------------------------------------
  dblFreeSpace = 0
  dblTotalSpace = 0
  dblUsedSpace = 0
  curFreeBytesToCaller = 0
  curTotalFreeBytes = 0
  curTotalBytes = 0
  lngSectorsPerCluster = 0
  lngBytesPerSector = 0
  lngNumberOfFreeClusters = 0
  lngTotalNumberOfClusters = 0
  strDriveLtr = Trim$(strPath)
 
' ---------------------------------------------------------------------------
' Verify data was passed
' ---------------------------------------------------------------------------
  If Len(Trim$(strDriveLtr)) = 0 Then
      Exit Function
  End If
 
' ---------------------------------------------------------------------------
' Remove any trailing backslashes
' ---------------------------------------------------------------------------
  strDriveLtr = Left$(strDriveLtr, 1) & ":"

  On Error GoTo Over_2gb_Not_Supported
' ---------------------------------------------------------------------------
' First, determine if we can call the GetDiskFreeSpaceEx function.
' ---------------------------------------------------------------------------
  lngHandle = LoadLibrary("kernel32.Dll")
 
' ---------------------------------------------------------------------------
' if the return code is not zero, we were successful
' ---------------------------------------------------------------------------
  If lngHandle Then
      lngProcAddress = GetProcAddress(lngHandle, "GetDiskFreeSpaceExA")
     
      If lngProcAddress Then
         
          ' Make API call to query the hard drive for space information.
          ' if there is an error, we will assume that this operating
          ' system does not support hard drives over 2gb and then jump
          ' to the area where we can make the correct API call.
          lngRetCode = GetDiskFreeSpaceEx(strDriveLtr, _
                                          curFreeBytesToCaller, _
                                          curTotalBytes, _
                                          curTotalFreeBytes)
           
          ' Just to be safe, decrement Dll's usage counter.
          FreeLibrary lngHandle
           
          ' If we were successful, then multiply the results
          ' by 10000 to move the decimal to the right 4 positions
          If lngRetCode Then
              ' Calculate size of the hard drive
              dblTotalSpace = CDbl(curTotalBytes * 10000)
              ' Calculate the amount of free space
              dblFreeSpace = CDbl(curTotalFreeBytes * 10000)
              ' Calculate the amount of used space
              dblUsedSpace = dblTotalSpace - dblFreeSpace
          End If
      End If

      ' Just to be safe, decrement Dll's usage counter.
      FreeLibrary lngHandle
  End If

' ---------------------------------------------------------------------------
' If an error brought us to here then make sure we reset all variables
' ---------------------------------------------------------------------------
Over_2gb_Not_Supported:
  If Err.Number <> 0 Then
      Err.Clear           ' reset error code
      dblTotalSpace = 0   ' empty variables
      dblFreeSpace = 0
      dblUsedSpace = 0
      lngRetCode = 0
  End If
 
  On Error GoTo 0
  On Error GoTo Get_Disk_Space_Errors
' ---------------------------------------------------------------------------
' If this drive is less than 2GB in total size then reset values and make
' the correct API call.
' ---------------------------------------------------------------------------
  If dblTotalSpace <= TWO_GB Then
      dblTotalSpace = 0
      dblFreeSpace = 0
      dblUsedSpace = 0
      lngRetCode = 0
  Else
      Get_Disk_Space = True
      Exit Function
  End If
 
' ---------------------------------------------------------------------------
' if we get here, GetDiskFreeSpaceEx isn't available or raised an error or
' the drive is less than 2GB in size.
' ---------------------------------------------------------------------------
  lngRetCode = GetDiskFreeSpace(strDriveLtr, lngSectorsPerCluster, _
                                lngBytesPerSector, lngNumberOfFreeClusters, _
                                lngTotalNumberOfClusters)
                                 
' ---------------------------------------------------------------------------
' Test the return code to see if we had a successful call
' ---------------------------------------------------------------------------
  If lngRetCode Then
      ' Calculate size of the hard drive
      dblFreeSpace = CDbl(lngNumberOfFreeClusters * lngSectorsPerCluster * _
                          lngBytesPerSector)
      ' Calculate the amount of free space
      dblTotalSpace = CDbl(lngTotalNumberOfClusters * lngSectorsPerCluster * _
                          lngBytesPerSector)
      ' Calculate the amount of used space
      dblUsedSpace = dblTotalSpace - dblFreeSpace
      Get_Disk_Space = True
  Else
      Get_Disk_Space = False
  End If

Normal_Exit:
  Exit Function
 
Get_Disk_Space_Errors:
  Get_Disk_Space = False
  Resume Normal_Exit
 
End Function

Private Sub Class_Initialize()

' ---------------------------------------------------------------------------
' Initialize holding areas
' ---------------------------------------------------------------------------
  Dim FI_dummy   As FileInfo
  Dim DI_dummy   As DriveInfo
 
  FI = FI_dummy      ' fill structures with empty values
  DI = DI_dummy
  m_dblCount = 0
 
End Sub

Private Sub Class_Terminate()

' ---------------------------------------------------------------------------
' Initialize holding areas
' ---------------------------------------------------------------------------
  Dim FI_dummy   As FileInfo
  Dim DI_dummy   As DriveInfo
 
  FI = FI_dummy      ' fill structures with empty values
  DI = DI_dummy
  m_dblCount = 0
 
End Sub

Project Homepage: