Function CdRomDrives
 ' Returns array of all local CD-ROM drives
 Dim drive, aTmp(), i
 i = -1
  For Each drive In CreateObject("Scripting.FileSystemObject").Drives
    If drive.DriveType = 4 Then
     i = i + 1
     ReDim Preserve aTmp(i)
   aTmp(i) = drive.DriveLetter
    End If
  Next
  CdRomDrives = aTmp
End Function

Function DeleteIfEmpty(sFldr)
 ' Deletes a folder IF there is nothing in it
 Dim FSO, Flder, HasFiles, HasFlders
 Set FSO = CreateObject("Scripting.FileSystemObject")
 Set Fldr = FSO.GetFolder(sFldr)
 HasFiles = CBool(Fldr.Files.Count)
 HasFlders = CBool(Fldr.SubFolders.Count)
 If ( (HasFiles = False) And (HasFlders = False) ) Then
  FSO.DeleteFolder sFldr
 End If
End Function

Function DriveType(drvpath)
' Modified from WSH 5.6 Docs
' drivepath should be in form "x","x:", or "x:\"
' Returns human-readable drive type
   Dim fso, d, t
   Set fso = CreateObject("Scripting.FileSystemObject")
   Set d = fso.GetDrive(drvpath)
   Select Case d.DriveType
      Case 0: ShowDriveType = "Unknown"
      Case 1: ShowDriveType = "Removable"
      Case 2: ShowDriveType = "Fixed"
      Case 3: ShowDriveType = "Network"
      Case 4: ShowDriveType = "CD-ROM"
      Case 5: ShowDriveType = "RAM Disk"
   End Select
End Function


Sub fAppend(FilePath, sData)
 'Given the path to a file, will append sData to it
 With CreateObject("Scripting.FileSystemObject")._
  OpenTextFile(FilePath, 8)
  .Write sData: .Close
 End With 
End Sub

Function FileAge(sPath)
 ' Returns file age in days
 With CreateObject("Scripting.FileSystemObject")._
  GetFile(sPath)
  FileAge = CDbl(Now) - CDbl(.DateLastModified)
 End With
End Function


Function FolderSet(FolPath)
 ' finds all folders in path FolPath
 ' WARNING - UNCOMMENT NEXT TWO LINES IF
 ' FSO NOT DECLARED IN MAIN BODY
 ' Dim FSO
 ' Set FSO = CreateObject("Scripting.FileSystemObject")
 Dim Fol, strTemp, aFols(), oFolder, subFolder, aTmp, i
 ReDim aFols(-1)
 Set oFolder = FSO.GetFolder(FolPath)
 For Each Fol In oFolder.SubFolders
   ReDim Preserve aFols(UBound(aFols) + 1)
   aFols(UBound(aFols)) = Fol.Path
 Next
 'Recurse through all of the folders
 For Each subFolder In oFolder.subFolders
  aTmp = FolderSet(subFolder)
  For i = 0 To UBound(aTmp)
   ReDim Preserve aFols(UBound(aFols) + 1)
   aFols(UBound(aFols)) = aTmp(i)
   i = i + 1
  Next
 Next
 FolderSet = aFols
End Function

Function FolderSize(folspec)
 FolderSize = CreateObject( _
  "Scripting.FileSystemObject")._
  GetFolder(folspec).size
End Function


Function folIsEmpty(sFldr)
 folIsEmpty = CStr(CBool(CreateObject(_
  "Scripting.FileSystemObject")._
  GetFolder(sFldr).Files.Count))
End Function


Function fRead(FilePath)
 'Given the path to a file, will return entire contents
 ' works with either ANSI or Unicode
 Const ForReading = 1, TristateUseDefault = -2, _
  DoNotCreateFile = False
 With CreateObject("Scripting.FileSystemObject")._
  OpenTextFile(FilePath, ForReading, _
  False, TristateUseDefault)
  fRead = .ReadAll: .Close
 End With
End Function

Function FreeDrive(sFirst,sLast)
 'Finds first available drive letter in a sequence
 ' specify like this: fDrive = FreeDrive("C","Z")
 ' WARNING: recommended uses is to start with C
 ' since some systems will not correctly handle
 ' A or B used for mapping.
  Dim I
  With CreateObject("Scripting.FileSystemObject")
  For I = Asc(sFirst) To Asc(sLast)
    If Not .DriveExists(Chr(I)) Then
      Freedrive = Chr(I) & ":"
      Exit Function
    End If
  Next
  End With
End Function

Sub fWrite(FilePath, sData)
 'writes sData to FilePath
 With CreateObject("Scripting.FileSystemObject")._
  OpenTextFile(FilePath, 2, True)
  .Write sData: .Close
 End With
End Sub

Function GetRemovableDrive
 Dim drive
  for each drive in CreateObject("Scripting.FileSystemObject").Drives
    if drive.DriveType = 1 Then
       GetRemovableDrive = drive.DriveLetter + ":\"
       exit function
    end if
  next
end function


Function HasRights(folderspec)
 ' Returns true if user has at least list rights
 ' to path; can be a disk or UNC path
 On Error Resume Next
 Dim fso, f, fc, f1
 HasRights = CStr(False)
 Set fso = CreateObject("Scripting.FileSystemObject")
 Set f = fso.GetFolder(folderspec)
 Set fc = f.Files
 For Each f1 In fc
  If Err.Number <> 0 Then Exit For
  HasRights = CStr(True)
  Exit Function
 Next
 Err.Clear
 On Error GoTo 0
End Function

Function Head(fil, nlines)
 'Given the path to a file, will return 
 ' count nlines # of lines
 ' lines will be separated with vbCrLF if more than
 ' one is specified
 ' works with either ANSI or Unicode
 Const ForReading = 1, TristateUseDefault = -2, _
  DoNotCreateFile = False
 With CreateObject("Scripting.FileSystemObject")._
  OpenTextFile(fil, ForReading, _
  False, TristateUseDefault)
  For i = 1 To nlines
  If Not .AtEndOfStream Then 
   Head = Head & .ReadLine
   If i < nlines Then Head = Head & vbCrLf
  Else Exit For
  End If
  Next
  .Close
 End With
End Function

Sub HideFolder(strFolder)
 'Hides a folder passed to it with path strFolder
 'From a Michael Harris script
 Set FSO = createobject("scripting.filesystemobject")
 With FSO.getfolder(strFolder)
  .Attributes = .Attributes Or 2
 End With
End Sub


Sub Include(FilePath)
 ' Given the path to a file, will execute entire contents
 ' in global context
 Const ForReading = 1, TristateUseDefault = -2, _
  DoNotCreateFile = False
 With CreateObject("Scripting.FileSystemObject")._
  OpenTextFile(FilePath, ForReading, _
  False, TristateUseDefault)
  ExecuteGlobal .ReadAll: .Close
 End With
End Sub

Function IsDcUp(Server)
 ' Verify whether a DC is uo or not
 On Error Resume Next
 CreateObject("Scripting.FileSystemObject")._
  GetFolder("\\" & Server & "\netlogon")
 If Err.Number <> 0 Then
  IsDcUp = False
  Err.Clear
 Else
  IsDcUp = True
 End If
 On Error Goto 0
End Function


Function IsFile(sPath)
 ' Returns true if a file exists
 IsFile = False
 If CreateObject("Scripting.FileSystemObject"). _
    FileExists(sPath) Then IsFile = True
End Function 'IsFile


Function IsFolder(sPath)
 IsFolder = CStr(False)
 If CreateObject("Scripting.FileSystemObject")._
  FolderExists(sPath) Then IsFolder = CStr(True)
End Function


Function IsHiddenFile(strFile)
 'Hides a folder passed to it with path strFolder
 Set FSO = createobject("scripting.filesystemobject")
 With FSO.getfile(strFile)
  IsHiddenFile = CBool(.Attributes And 2)
 End With
End Function


Function IsHiddenFolder(strFolder)
 'Hides a folder passed to it with path strFolder
 Set FSO = createobject("scripting.filesystemobject")
 With FSO.getfolder(strFolder)
  IsHiddenFolder = CBool(.Attributes And 2)
 End With
End Function


Function IsShare(sPath)
 On Error Resume Next
 CreateObject("Scripting.FileSystemObject")._
  GetFolder(sPath)
 If Err.Number = 0 then 
  IsShare = True
 Else
  Err.Clear
  IsShare = False
 End If
 On Error Goto 0
End Function


Function IsUnicodeFile(filename)
 Dim FSO, ts, char1, char2
 Set FSO = createobject("scripting.filesystemobject")
 Set ts = fso.opentextfile(filename)
 IsUnicodeFile = False
 char1 =ts.read(1)
 char2 =ts.read(1)
 ts.close
 if asc(char1) = 255 and asc(char2) = 254 then
  IsUnicodeFile = True
 End If
End Function


Function LargestNumberedSubFolder(sPath)
 ' Finds the highest numbered subfolder within
 ' a given directory
 Dim FSO, f, f1, fc, s, Largest
 Largest = 0
 Set FSO = CreateObject("Scripting.FileSystemObject")
 Set f = FSO.GetFolder(sPath)
 Set fc = f.SubFolders
 On Error Resume Next
 For Each f1 in fc
  s = CInt(f1.name)
  If Err.Number = 0 Then
   If s > Largest Then _
    Largest = s
  Else
   Err.Clear
  End If
 Next
 LargestNumberedSubFolder = Largest
End Function


Function LinesInFile(sFil)
 'Returns total line count for sFil
 Set FSO = CreateObject("Scripting.FileSystemObject")
 Set fil = FSO.OpenTextFile(sFil, 1)
 fil.Readall
 LinesInFile = fil.Line
End Function


Sub Logger(FilePath, sData)
 'Given the path to a file, will append timestamped data
 With CreateObject("Scripting.FileSystemObject")._
  OpenTextFile(FilePath, 8, True)
  .Write Now & " | " & sData & vbCrLf: .Close
 End With 
End Sub

Sub LowerCaseFSO(Folspec)
 ' lowercases all file and folder names within the path specified
 Dim fil, fils, fol, fols, FSO, sFolders()
 Dim lngCounter, sFilName, sFolName
 Const READONLY = 1, HIDDEN = 2, SYSTEM = 4
 ReDim sFolders(0)
 Set FSO = CreateObject("Scripting.FileSystemObject")
 sFolders(0) = FSO.GetAbsolutePathName(Folspec)
 lngCounter = 0
 Do Until lngCounter > UBound(sFolders,1)
  'Next folder to process
  Set fol = FSO.GetFolder(sFolders(lngCounter))
  'Get each file in turn
  Set fils = fol.Files
  If Err.Number <> 0 Then Exit Sub
  For Each fil In fils
   sFilName = LCase(fil.Name)
   If fil.Name <> sFilName Then
    fil.Name = FSO.GetTempName: fil.Name = sFilName
   End If
  Next
  'Check for any sub folders and add them to the folder array
  Set fols = fol.SubFolders
  For Each fol In fols
   If Lcase(fol.Name) <> "recycled" Then
    ReDim Preserve sFolders(UBound(sFolders,1) + 1)
    sFolders(UBound(sFolders,1)) = fol.Path
   End If
   sFolName = LCase(fol.Name)
   If fol.Name <> sFolName Then
    fol.Name = FSO.GetTempName: fol.Name = sFolName
   End If
  Next
  lngCounter = lngCounter + 1
 Loop
End Sub

Function Map(sDrive,SPath)
 ' Returns boolean for maping success
 on Error Resume Next
 set oNet = CreateObject("WScript.Network")
 oNet.MapNetworkDrive sDrive, sPath
 If Err.Number <> 0 Then
  Map = False
 Else
  Map = True
 End If
 Err.Clear
End Function


Sub md(fldr)
 ' Recursively create the directory path provided in fldr
 ' May be used with UNC paths
 Dim aPath, FSO, fol, i
 aPath = Split(fldr,"\")
 Set FSO = CreateObject("Scripting.FileSystemObject")
 fol = aPath(0)
 If Len(Replace(fol,":",""))=Len(fol) Then fol = "\\" & fol
 For i = 1 To UBound(aPath)
  fol = fol & "\" & aPath(i)
  If Not FSO.FolderExists(fol) Then FSO.CreateFolder(fol)
 Next
End Sub

Function MoveFile(oldname,newname)
   Dim fso
   On Error Resume Next
   Err.Clear
   Set fso = CreateObject("Scripting.FileSystemObject")
   fso.MoveFile oldname,newname
   If Err.Number<>0 Then
    MoveFile = False
       Err.Clear
   Else
    MoveFile = True
   End If
End Function


Sub NetSend(from, Host, message)
 With CreateObject("Scripting.FileSystemObject")
 slot = "\\" & Host & "\MAILSLOT\messngr"
 .CreateTextFile(slot, True).Write from & chr(0) & Host _
  & chr(0) & message & chr(0)
 End With
End Sub


Function ShowFileAccessInfo(filespec)
  Dim fso, f, s
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set f = fso.GetFile(filespec)
  s = UCase(filespec) & VBCRLF
  s = s & "Created: " & f.DateCreated & VBCRLF
  s = s & "Last Accessed: " & f.DateLastAccessed & VBCRLF
  s = s & "Last Modified: " & f.DateLastModified  & VBCRLF
  s = s & "File Size (Bytes): " & f.Size & VBCRLF
  s = s & "File Type: " & f.Type & VBCRLF
  s = s & "Short Name: " & f.ShortName & VBCRLF
  s = s & "Path: "& f.Path & VBCRLF
  s = s & "Attributes: "& f.Attributes & VBCRLF
  ShowFileAccessInfo = s
  Set f = Nothing
  Set fso = Nothing
End Function


Sub ShowFolder(strFolder)
 'Un-hides a folder passed to it with path strFolder
 'Michael Harris, of course
 Set FSO = createobject("scripting.filesystemobject")
 With FSO.getfolder(strFolder)
  .Attributes = .Attributes XOr 2
 End With
End Sub


Function SysDir()
  SysDir = CreateObject("Scripting.FileSystemObject"). _
    GetSpecialFolder(1).Path
End Function 'SysDir


Function Tail(fil, nlines)
 'Returns last nlines lines from file fil
 Const ForReading = 1, TristateUseDefault = -2, _
  DoNotCreateFile = False
 With CreateObject("Scripting.FileSystemObject")._
  OpenTextFile(fil, ForReading, _
  False, TristateUseDefault)
 .Readall
 LinesToSkip = .Line - nlines: .Close
 End With
 With CreateObject("Scripting.FileSystemObject")._
  OpenTextFile(fil, ForReading, _
  False, TristateUseDefault) 
  If LinesToSkip <0 Then LinesToSkip = 0
  For i = 1 To LinesToSkip: .Skipline: Next
  For i = 1 To nlines
   If Not .AtEndOfStream Then 
    Tail = Tail & .ReadLine
   End If
   If i < nlines Then Tail = Tail & vbCrLf
  Next
  .Close
 End With
End Function

Function TempDir()
  TempDir = CreateObject("Scripting.FileSystemObject"). _
    GetSpecialFolder(2).Path
End Function 'SysDir


Function TempFile
 TempFile = CreateObject( _
  "Scripting.FileSystemObject").GetTempName
End Function

Function TempFileBase
 Set FSO = CreateObject("Scripting.FileSystemObject")
 Const TemporaryFolder = 2
 Set folTemp = FSO.GetSpecialFolder(TemporaryFolder)
 ' Returns path to a unique, randomly generated file name
 ' within the %TEMP% folder
 'Following sequence allows 360,040,606,269,696 unique file names
 chrList = _
  "abcdefghijklmnopqrstuvwxyz0123456789,~-_&[]()#@!`;+="
 uLimit = Len(chrList)
 Randomize
 For i = 1 To 8
  sTmp = sTmp & Mid(chrList, ((uLimit) * Rnd + 1), 1)
 Next
 TempFileBase = folTemp & "\" & sTmp
End Function

Sub TrimFileSize(filspec,toSize)
 ' Based on (lightly) modified code from Eric Phelps
 ' This script reduces the size of line-oriented log files.
 ' It erases the first (oldest) lines in a log file until
 ' it gets the log down below the specified size.
 Dim ts, fs, sText
 Const ForReading = 1 'Scripting.IOMode
 Const ForWriting = 2 'Scripting.IOMode
 Set fs = CreateObject("Scripting.FileSystemObject")
 ' If it fails anywhere, just quit.
 On Error Resume Next
 ' Read the file
 Set ts = fs.OpenTextFile(filspec, ForReading)
 If Err.Number <> 0 Then exit sub
 sText = ts.ReadAll
 ts.Close
 ' See if the file is already below desired size
 If Len(sText) < toSize Then: exit sub
 sText = Right(sText, toSize)  ' Trim the file
 If (Instr(sText, vbCrlf) = 0) _
  Or (Instr(sText, vbCrlf) + 3 > Len(sText)) Then
  exit sub
 Else
  sText = Mid(sText, Instr(sText, vbCrlf) + 2)
 End If
 ''''''''''Write the shortened file
 Set ts = fs.OpenTextFile(filspec, ForWriting)
 If Err.Number <> 0 Then exit sub
 ts.Write sText: ts.Close
End Sub


Function UtfRead(FilePath)
 Const TriStateTrue = -1
 'Given the path to a file, will return entire contents
 With CreateObject("Scripting.FileSystemObject")._
  OpenTextFile(FilePath, 1, False, TriStateTrue)
 UtfRead = .ReadAll: .Close
 End With 
End Function


Sub UtfWrite(FilePath, sData)
 Const TriStateTrue = -1
 'Given the path to a file, will return entire contents
 With CreateObject("Scripting.FileSystemObject")._
  OpenTextFile(FilePath, 2, False, TriStateTrue)
  .Write sData: .Close
 End With 
End Sub


Function VerFile(sPath)
 On Error Resume Next
 VerFile = 0
  If IsFile(sPath) Then
  VerFile = CreateObject("Scripting.FileSystemObject"). _
    GetFileVersion(sPath)
  End If
  Err.Clear
End Function


Function WinDir()
  WinDir = CreateObject("Scripting.FileSystemObject"). _
    GetSpecialFolder(0).Path
End Function 'SysDir