VBA code is not working in win7_64

hi all

this code is working in win7_32 but is not working in win7_64

Please modify below code to be working in win7_64

HTML Code:

---

Option Explicit

Private Declare Function GetDriveType Lib "kernel32" _
    Alias "GetDriveTypeA" (ByVal nDrive As String) As Long

Private Declare Function GetDiskFreeSpaceEx Lib "kernel32" _
    Alias "GetDiskFreeSpaceExA" (ByVal lpDirectoryName As String, _
    lpFreeBytesAvailableToCaller As Currency, _
    lpTotalNumberOfBytes As Currency, _
    lpTotalNumberOfFreeBytes As Currency) As Long

Function DriveSize(DriveLetter As String) As String
    Dim Status As Long
    Dim TotalBytes As Currency
    Dim FreeBytes As Currency
    Dim BytesAvailableToCaller As Currency
    Status = GetDiskFreeSpaceEx(DriveLetter & ":\", _
        BytesAvailableToCaller, TotalBytes, FreeBytes)
    If Status <> 0 Then
        DriveSize = TotalBytes * 10000
    Else
        DriveSize = ""
    End If
End Function

Function DriveSpaceFree(DriveLetter As String) As String
    Dim Status As Long
    Dim TotalBytes As Currency
    Dim FreeBytes As Currency
    Dim BytesAvailableToCaller As Currency
    Status = GetDiskFreeSpaceEx(DriveLetter & ":\", _
        BytesAvailableToCaller, TotalBytes, FreeBytes)
    If Status <> 0 Then
        DriveSpaceFree = FreeBytes * 10000
    Else
        DriveSpaceFree = ""
    End If
End Function

Function DriveType(DriveLetter As String) As String
'  Returns a string that describes the type of drive of DriveLetter
    DriveLetter = Left(DriveLetter, 1) & ":\"
    Select Case GetDriveType(DriveLetter)
        Case 0: DriveType = "Unknown"
        Case 1: DriveType = "Non-existent"
        Case 2: DriveType = "Removable drive"
        Case 3: DriveType = "Fixed drive"
        Case 4: DriveType = "Network drive"
        Case 5: DriveType = "CD-ROM drive"
        Case 6: DriveType = "RAM disk"
        Case Else: DriveType = "Unknown drive type"
  End Select
End Function

Sub ShowAllDrives()
    Dim LetterCode As Long
    Dim Row As Long
    Dim DT As String
    Range("A1:D1") = Array("Drive", "Type", "Total Bytes", "Free Bytes")
    Row = 2
    For LetterCode = 65 To 90
        DT = DriveType(Chr(LetterCode))
        If DT <> "Non-existent" Then
            Cells(Row, 1) = Chr(LetterCode) & ":\"
            Cells(Row, 2) = DT
            Cells(Row, 3) = DriveSize(Chr(LetterCode))
            Cells(Row, 4) = DriveSpaceFree(Chr(LetterCode))
            Row = Row + 1
        End If
    Next LetterCode
End Sub

---

Thanks in advance for all your help!!

mokhtar

See: www.jkp-ads.com/articles/apideclarations.asp

I'm sorry for being late in my reply ..
Thanks a lot Mr. jan
I'll try modification the declarations
Thanks again

Hello Mr. Jan Karel Pieterse
your's site wonderful and helpful ....
i tried modification the declarations without any result, my experience of macros is limited
Please , update declarations of code to works on win7 32bit and win7 64bit
Thanks in advance for all your help!!
mokhtar

See if this works for you:

Code:

---

Option Explicit

#If VBA7 Then
Private Declare PtrSafe Function GetDriveType Lib "kernel32" Alias _
    "GetDriveTypeA" (ByVal sDrive As String) As LongPtr
Private Declare PtrSafe Function GetDiskFreeSpaceEx Lib "kernel32" Alias _
    "GetDiskFreeSpaceExA" (ByVal lpDirectoryName As String, _
    lpFreeBytesAvailableToCaller As Currency, lpTotalNumberOfBytes As _
    Currency, lpTotalNumberOfFreeBytes As Currency) As LongPtr
#Else
Private Declare Function GetDriveType Lib "kernel32" Alias _
    "GetDriveTypeA" (ByVal sDrive As String) As Long
Private Declare Function GetDiskFreeSpaceEx Lib "kernel32" _
    Alias "GetDiskFreeSpaceExA" (ByVal lpDirectoryName As String, _
    lpFreeBytesAvailableToCaller As Currency, _
    lpTotalNumberOfBytes As Currency, _
    lpTotalNumberOfFreeBytes As Currency) As Long
#End If

Function DriveSize(DriveLetter As String) As String
    #If VBA7 Then
        Dim Status As LongPtr
    #Else
        Dim Status As Long
    #End If
    Dim TotalBytes As Currency
    Dim FreeBytes As Currency
    Dim BytesAvailableToCaller As Currency
    Status = GetDiskFreeSpaceEx(DriveLetter & ":\", _
                                BytesAvailableToCaller, TotalBytes, FreeBytes)
    If Status <> 0 Then
        DriveSize = TotalBytes * 10000
    Else
        DriveSize = ""
    End If
End Function
Function DriveSpaceFree(DriveLetter As String) As String
    #If VBA7 Then
        Dim Status As LongPtr
    #Else
        Dim Status As Long
    #End If
    Dim TotalBytes As Currency
    Dim FreeBytes As Currency
    Dim BytesAvailableToCaller As Currency
    Status = GetDiskFreeSpaceEx(DriveLetter & ":\", _
        BytesAvailableToCaller, TotalBytes, FreeBytes)
    If Status <> 0 Then
        DriveSpaceFree = FreeBytes * 10000
    Else
        DriveSpaceFree = ""
    End If
End Function
Function DriveType(DriveLetter As String) As String
'  Returns a string that describes the type of drive of DriveLetter
    DriveLetter = Left(DriveLetter, 1) & ":\"
    Select Case GetDriveType(DriveLetter)
        Case 0: DriveType = "Unknown"
        Case 1: DriveType = "Non-existent"
        Case 2: DriveType = "Removable drive"
        Case 3: DriveType = "Fixed drive"
        Case 4: DriveType = "Network drive"
        Case 5: DriveType = "CD-ROM drive"
        Case 6: DriveType = "RAM disk"
        Case Else: DriveType = "Unknown drive type"
  End Select
End Function
Sub ShowAllDrives()
    Dim LetterCode As Long
    Dim Row As Long
    Dim DT As String
    Range("A1:D1") = Array("Drive", "Type", "Total Bytes", "Free Bytes")
    Row = 2
    For LetterCode = 65 To 90
        DT = DriveType(Chr(LetterCode))
        If DT <> "Non-existent" Then
            Cells(Row, 1) = Chr(LetterCode) & ":\"
            Cells(Row, 2) = DT
            Cells(Row, 3) = DriveSize(Chr(LetterCode))
            Cells(Row, 4) = DriveSpaceFree(Chr(LetterCode))
            Row = Row + 1
        End If
    Next LetterCode
End Sub

---

Thanks a lot Mr. Jan Karel Pieterse

I'll try it

Regards,

mokhtar

Thanks a lot Mr. Jan Karel Pieterse
This works perfectly Thanks Thanks Thanks
Regards,
mokhtar