VBA/Excel/Access/Word/File Path/Drive — различия между версиями
Admin (обсуждение | вклад) м (1 версия) |
Admin (обсуждение | вклад) м (1 версия) |
(нет различий)
|
Текущая версия на 12:47, 26 мая 2010
Содержание
- 1 Display Drive information
- 2 Get Drive Information
- 3 Returns a string that describes the drive type
- 4 Returns the drive letter using an index
- 5 Returns the number of drives
- 6 Returns the number of free bytes for a drive
- 7 Returns the total storage capacity for a drive
- 8 Returns True if a specified drive letter exists
- 9 The NumberOfBytesFree Function
- 10 The TypeOfDrive Function
Display Drive information
Sub cmdDriveInfo_Click()
Dim myFileSystemObject As FileSystemObject, aDrive As Drive
Set myFileSystemObject = New FileSystemObject
Set aDrive = myFileSystemObject.GetDrive("C:\")
With aDrive
Debug.Print "Volume Name: " & .VolumeName & vbCrLf
Debug.Print "Free Space: " & Format(.FreeSpace / 1000000000#, "#0.00") & "GB" & vbCrLf
Debug.Print "Total Size: " & Format(.TotalSize / 1000000000#, "#0.00") & "GB" & vbCrLf
Debug.Print "Ready: " & .IsReady
End With
Set myFileSystemObject = Nothing
Set aDrive = Nothing
End Sub
Private Sub AddFolders()
Get Drive Information
Declare Function abGetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Declare Function abGetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters As Long) As Long
"The GetDriveInfo Procedure
Sub GetDriveInfo()
Dim intDrive As Integer
Dim strDriveLetter As String
Dim strDriveType As String
Dim strSpaceFree As String
"Loop through all drives
For intDrive = 65 To 90 "A through Z
strDriveLetter = (Chr(intDrive) & ":\")
"Get Drive Type
strDriveType = TypeOfDrive(strDriveLetter)
"Get Space Free
strSpaceFree = NumberOfBytesFree(strDriveLetter)
Debug.Print Left(strDriveLetter, 2) & _
" - " & strDriveType & _
IIf(strDriveType <> "Drive Doesn"t Exist", _
strSpaceFree, "") & _
vbCrLf
Next intDrive
End Sub
Returns a string that describes the drive type
Private Declare Function GetDriveType32 Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Function DriveType(DriveLetter As String) As String
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
Sub Main()
Debug.Print DriveType("c:\")
End Sub
Returns the drive letter using an index
Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Function DriveName(index As Integer) As String
Dim Buffer As String * 255
Dim BuffLen As Long
Dim TheDrive As String
Dim DriveCount As Integer
BuffLen = GetLogicalDriveStrings(Len(Buffer), Buffer)
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 Main()
Debug.Print DriveName(3)
End Sub
Returns the number of drives
Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Function NumberofDrives() As Integer
Dim Buffer As String * 255
Dim BuffLen As Long
Dim DriveCount As Integer
BuffLen = GetLogicalDriveStrings(Len(Buffer), Buffer)
DriveCount = 0
For i = 1 To BuffLen
If Asc(Mid(Buffer, i, 1)) = 0 Then _
DriveCount = DriveCount + 1
Next i
NumberofDrives = DriveCount
End Function
Sub Main()
Debug.Print NumberofDrives
End Sub
Returns the number of free bytes for a drive
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
Sub FreeDiskSpace()
Dim SectorsPerCluster As Long
Dim BytesPerSector As Long
Dim NumberofFreeClusters As Long
Dim TotalClusters As Long
x = GetDiskFreeSpace("c:\", SectorsPerCluster, _
BytesPerSector, NumberofFreeClusters, TotalClusters)
If x = 0 Then "Error occurred
Exit Sub
End If
Debug.Print SectorsPerCluster
Debug.Print BytesPerSector
Debug.Print NumberofFreeClusters
End Sub
Returns the total storage capacity for a drive
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
Sub TotalDiskSpace()
Dim SectorsPerCluster As Long
Dim BytesPerSector As Long
Dim NumberofFreeClusters As Long
Dim TotalClusters As Long
x = GetDiskFreeSpace("c:\", SectorsPerCluster, _
BytesPerSector, NumberofFreeClusters, TotalClusters)
If x = 0 Then "Error occurred
Exit Sub
End If
Debug.Print SectorsPerCluster
Debug.Print BytesPerSector
Debug.Print TotalClusters
End Sub
Returns True if a specified drive letter exists
Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Function DriveExists(DriveLetter As String) As Boolean
Dim Buffer As String * 255
Dim BuffLen As Long
DLetter = Left(DriveLetter, 1)
BuffLen = GetLogicalDriveStrings(Len(Buffer), Buffer)
DriveExists = False
For i = 1 To BuffLen
If UCase(Mid(Buffer, i, 1)) = UCase(DLetter) Then
DriveExists = True
Exit Function
End If
Next i
End Function
Sub Main()
Debug.Print DriveExists("c:\")
End Sub
The NumberOfBytesFree Function
Function NumberOfBytesFree(ByVal strDrive As String) As String
Dim lngSectors As Long
Dim lngBytes As Long
Dim lngFreeClusters As Long
Dim lngTotalClusters As Long
Dim intErrNum As Integer
intErrNum = abGetDiskFreeSpace(strDrive, lngSectors, _
lngBytes, lngFreeClusters, lngTotalClusters)
NumberOfBytesFree = " with " & _
Format((CDbl(lngBytes) * CDbl(lngSectors)) * _
CDbl(lngFreeClusters), "#,##0") & _
" Bytes Free"
End Function
The TypeOfDrive Function
Function TypeOfDrive(ByVal strDrive As String) As String
Dim intDriveType As Integer
Dim strDriveType As String
intDriveType = abGetDriveType(strDrive)
Select Case intDriveType
Case DRIVE_UNKNOWN
strDriveType = "Type Unknown"
Case DRIVE_UNAVAILABLE
strDriveType = "Drive Doesn"t Exist"
Case DRIVE_REMOVABLE
strDriveType = "Removable Drive"
Case DRIVE_FIXED
strDriveType = "Fixed Drive"
Case DRIVE_REMOTE
strDriveType = "Network Drive"
Case DRIVE_CDROM
strDriveType = "CD-ROM"
Case DRIVE_RAMDISK
strDriveType = "RAM Disk"
End Select
TypeOfDrive = strDriveType
End Function