в 16:33, 26 мая 2010

2010-05-26T16:33:00Z

Admin: 1 версия

2010-05-26T12:47:11Z

1 версия

Новая страница

==Display Drive information==



<source lang="vb">

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()
</source>

==Get Drive Information==



<source lang="vb">

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
</source>

==Returns a string that describes the drive type==



<source lang="vb">

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
</source>

==Returns the drive letter using an index==



<source lang="vb">

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
</source>

==Returns the number of drives==



<source lang="vb">

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
</source>

==Returns the number of free bytes for a drive==



<source lang="vb">

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
</source>

==Returns the total storage capacity for a drive==



<source lang="vb">

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
</source>

==Returns True if a specified drive letter exists==



<source lang="vb">

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
</source>

==The NumberOfBytesFree Function==



<source lang="vb">

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
</source>

==The TypeOfDrive Function==



<source lang="vb">

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
</source>

← Предыдущая	Версия 16:33, 26 мая 2010
(нет различий)

VBA/Excel/Access/Word/File Path/Drive - История изменений

в 16:33, 26 мая 2010

Admin: 1 версия