Code Snippets


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, i, 1) = Application.PathSeparator Then
          FileNameOnly = temp
          Exit Function
      End If
      stemp = Mid(sFullPathName, icharcount, 1) & stemp
   Next i
   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


© 2019 Better Solutions Limited. All Rights Reserved. © 2019 Better Solutions Limited TopPrevNext