Code Snippets
rename an existing file
delete a file in a folder
copy a file to a different folder
move a file to a different folder
File_ReadAllowed
Function File_ReadAllowed(sFullPath As String) As Boolean
Dim fso As New Scripting.FileSystemObject
Dim fsofile As Scripting.File
Set fsofile = fso.GetFile(sfullpath)
Set fso = Nothing
End Function
Finding a File
Writing to a Log File
Reading a File
Dim fso As Scripting.FileSystemObject
Dim fsoTextStream As Scripting.TextStream
Set fso = New Scripting.FileSystemObject
Set fsoTextStream = fso.OpenTextFile(sfullpath, ForReading)
With fsoTextStream
Do While Not .AtEndOfStream
stext = .ReadLine
Loop
End With
Sub ShowFreeSpace(drvPath)
Dim fs, d, s
Set fs = CreateObject("Scripting.FileSystemObject")
Set d = fs.GetDrive(fs.GetDriveName(drvPath))
s = "Drive " & UCase(drvPath) & " - "
s = s & d.VolumeName & vbCrLf
s = s & "Free Space: " & FormatNumber(d.FreeSpace/1024, 0)
s = s & " Kbytes"
MsgBox s
End Sub
Sub ShowDriveList
Dim fs, d, dc, s, n
Set fs = CreateObject("Scripting.FileSystemObject")
Set dc = fs.Drives
For Each d in dc
s = s & d.DriveLetter & " - "
If d.DriveType = Remote Then
n = d.ShareName
Else
n = d.VolumeName
End If
s = s & n & vbCrLf
Next
MsgBox s
End Sub
Returns just the filename only
Private Function FileNameOnly(sFullPathName) As String
Dim icharcount As Integer
Dim ipathlength As Integer
Dim stemp As String
ipathlength = Len(sFullPathName)
stemp = ""
For icharcount = ipathlength To 1 Step -1
If Mid(sFullPathName, icharcount, 1) = Application.PathSeparator Then
FileNameOnly = stemp
Exit Function
End If
stemp = Mid(sFullPathName, icharcount, 1) & stemp
Next icharcount
FileNameOnly = sFullPathName
End Function
Checks if a directory path exists
Private Function DirectoryExists(sFullPathName) As Boolean
Dim stemp As String
On Error Resume Next
stemp = GetAttr(sFullPathName) And 0
If Err = 0 Then DirectoryExists = True _
Else DirectoryExists = False
End Function
' 32-bit API declarations
Private Declare Function GetDriveType32 Lib "kernel32" _
Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Function GetLogicalDriveStrings Lib "kernel32" _
Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, _
ByVal lpBuffer As String) As Long
Private Declare Function GetDiskFreeSpace Lib "kernel32" _
Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, _
lpSectorsPerCluster As Long, lpBytesPerSector As Long, _
lpNumberOfFreeClusters As Long, lpTtoalNumberOfClusters As Long) _
As Long
Function FreeDiskSpace(DriveLetter As String) As Double
' Returns the number of free bytes for a drive
Dim SectorsPerCluster As Long
Dim BytesPerSector As Long
Dim NumberofFreeClusters As Long
Dim TotalClusters As Long
DLetter = Left(DriveLetter, 1) & ":\"
x = GetDiskFreeSpace(DLetter, SectorsPerCluster, _
BytesPerSector, NumberofFreeClusters, TotalClusters)
If x = 0 Then 'Error occurred
FreeDiskSpace = -99 'Assign an arbitrary error value
Exit Function
End If
FreeDiskSpace = _
SectorsPerCluster * BytesPerSector * NumberofFreeClusters
End Function
Function TotalDiskSpace(DriveLetter As String) As Long
' Returns the total storage capacity for a drive
Dim SectorsPerCluster As Long
Dim BytesPerSector As Long
Dim NumberofFreeClusters As Long
Dim TotalClusters As Long
DLetter = Left(DriveLetter, 1) & ":\"
x = GetDiskFreeSpace(DLetter, SectorsPerCluster, _
BytesPerSector, NumberofFreeClusters, TotalClusters)
If x = 0 Then 'Error occurred
TotalDiskSpace = -99 'Assign an arbitrary error value
Exit Function
End If
TotalDiskSpace = _
SectorsPerCluster * BytesPerSector * TotalClusters
End Function
Function DriveType(DriveLetter As String) As String
' Returns a string that describes the drive type
DLetter = Left(DriveLetter, 1) & ":"
DriveCode = GetDriveType32(DLetter)
Select Case DriveCode
Case 1: DriveType = "Local"
Case 2: DriveType = "Removable"
Case 3: DriveType = "Fixed"
Case 4: DriveType = "Remote"
Case 5: DriveType = "CD-ROM"
Case 6: DriveType = "RAM Disk"
Case Else: DriveType = "Unknown Drive Type"
End Select
End Function
Function DriveExists(DriveLetter As String) As Boolean
' Returns True if a specified drive letter exists
Dim Buffer As String * 255
Dim BuffLen As Long
DLetter = Left(DriveLetter, 1)
BuffLen = GetLogicalDriveStrings(Len(Buffer), Buffer)
DriveExists = False
' Search for the string
For i = 1 To BuffLen
If UCase(Mid(Buffer, i, 1)) = UCase(DLetter) Then
' Found it
DriveExists = True
Exit Function
End If
Next i
End Function
Function NumberofDrives() As Integer
' Returns the number of drives
Dim Buffer As String * 255
Dim BuffLen As Long
Dim DriveCount As Integer
BuffLen = GetLogicalDriveStrings(Len(Buffer), Buffer)
DriveCount = 0
' Search for a null -- which separates the drives
For i = 1 To BuffLen
If Asc(Mid(Buffer, i, 1)) = 0 Then _
DriveCount = DriveCount + 1
Next i
NumberofDrives = DriveCount
End Function
Function DriveName(index As Integer) As String
' Returns the drive letter using an index
' Returns an empty string if index > number of drives
Dim Buffer As String * 255
Dim BuffLen As Long
Dim TheDrive As String
Dim DriveCount As Integer
BuffLen = GetLogicalDriveStrings(Len(Buffer), Buffer)
' Search thru the string of drive names
TheDrive = ""
DriveCount = 0
For i = 1 To BuffLen
If Asc(Mid(Buffer, i, 1)) <> 0 Then _
TheDrive = TheDrive & Mid(Buffer, i, 1)
If Asc(Mid(Buffer, i, 1)) = 0 Then 'null separates drives
DriveCount = DriveCount + 1
If DriveCount = index Then
DriveName = UCase(Left(TheDrive, 1))
Exit Function
End If
TheDrive = ""
End If
Next i
End Function
Sub ShowDriveInfo()
' This sub writes information for all drives
' to a range of cells
' Demonstrates the use of the custom drive functions
Dim i As Integer
Dim DLetter As String
Dim NumDrives As Integer
NumDrives = NumberofDrives()
' Write info for all drives to active cell location
If TypeName(Selection) <> "Range" Then
MsgBox "Select a cell"
Exit Sub
End If
' Insert headings
Application.ScreenUpdating = False
With ActiveCell
.Offset(0, 0).Value = "Drive"
.Offset(0, 1).Value = "Type"
.Offset(0, 2).Value = "Bytes Free"
.Offset(0, 3).Value = "Total Bytes"
' Insert data for each drive
For i = 1 To NumDrives
DLetter = DriveName(i)
Drive name
.Offset(i, 0).Value = DLetter & ":\"
Drive type
.Offset(i, 1) = DriveType(DLetter)
' Free space
.Offset(i, 2) = Format(FreeDiskSpace(DLetter), "#,##0")
' Total space
.Offset(i, 3) = Format(TotalDiskSpace(DLetter), "#,##0")
Next i
' Format the table
.AutoFormat Format:=xlSimple, Number:=True, Font:=True, _
Alignment:=True, Border:=True, Pattern:=True, Width:=True
End With
End Sub
File Association
Private Declare Function FindExecutableA Lib "shell32.dll" _
(ByVal lpFile As String, ByVal lpDirectory As String, _
ByVal lpResult As String) As Long
Function GetExecutable(strFile As String) As String
Dim strPath As String
Dim intLen As Integer
strPath = String(255, 0)
intLen = FindExecutableA(strFile, "\", strPath)
If intLen > 32 Then
GetExecutable = Left(strPath, intLen)
Else
GetExecutable = ""
End If
End Function
Sub GetFileName()
Dim fname As String
fname = Application.GetOpenFilename
MsgBox "The executable file is " & GetExecutable(fname), vbInformation, fname
End Sub
Folder recursion using the FileSystemObject
Sub EnumerateFilesAndFolders( _
FolderPath As String, _
Optional MaxDepth As Long = -1, _
Optional CurrentDepth As Long = 0, _
Optional Indentation As Long = 2)
Dim FSO As Scripting.FileSystemObject
Set FSO = New Scripting.FileSystemObject
'Check the folder exists
If FSO.FolderExists(FolderPath) Then
Dim fldr As Scripting.Folder
Set fldr = FSO.GetFolder(FolderPath)
'Output the starting directory path
If CurrentDepth = 0 Then
Debug.Print fldr.Path
End If
'Enumerate the subfolders
Dim subFldr As Scripting.Folder
For Each subFldr In fldr.SubFolders
Debug.Print Space$((CurrentDepth + 1) * Indentation) & subFldr.Name
If CurrentDepth < MaxDepth Or MaxDepth = -1 Then
'Recursively call EnumerateFilesAndFolders
EnumerateFilesAndFolders subFldr.Path, MaxDepth, CurrentDepth + 1, Indentation
End If
Next subFldr
'Enumerate the files
Dim fil As Scripting.File
For Each fil In fldr.Files
Debug.Print Space$((CurrentDepth + 1) * Indentation) & fil.Name
Next fil
End If
End Sub
© 2024 Better Solutions Limited. All Rights Reserved. © 2024 Better Solutions Limited TopPrevNext