HDD Ayrıntılı Bilgi

[bezl]

Merhaba kod arşivlerinde hdd ayrıntılı bilgi diye aşağıdaki kod var ama çalışmıyor. Sorun ne olabilir acaba...

Option Explicit
Sub Festplatten()
Const TEILER As Long = 1073741824
Dim objFSO As Object, objDrive As Object, colDrives As Object, varFree, intCount As Integer
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set colDrives = objFSO.Drives
intCount = 5
With LW
.[b6:i100].ClearContents
For Each objDrive In colDrives
If objDrive.DriveType = 2 Then
intCount = intCount + 1
.Cells(intCount, 2) = objDrive.DriveLetter
.Cells(intCount, 3) = objDrive.TotalSize
.Cells(intCount, 4) = objDrive.TotalSize / TEILER
.Cells(intCount, 5) = objDrive.FreeSpace
.Cells(intCount, 6) = objDrive.FreeSpace / TEILER
If objDrive.IsReady Then
.Cells(intCount, 7) = "Bereit"
Else
.Cells(intCount, 7) = "Nicht bereit"
End If
.Cells(intCount, 8) = objDrive.SerialNumber
.Cells(intCount, 9) = objDrive.VolumeName
End If
Next
End With
End
End Sub

 

[leumruk]

Merhaba,
Aşağıdaki gibi deneyin:

Sub Festplatten()
Const TEILER As Long = 1073741824
Dim objFSO As Object, objDrive As Object, colDrives As Object, varFree, intCount As Integer
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set colDrives = objFSO.Drives
intCount = 5
[b6:i100].ClearContents
For Each objDrive In colDrives
If objDrive.DriveType = 2 Then
intCount = intCount + 1
Cells(intCount, 2) = objDrive.DriveLetter
Cells(intCount, 3) = objDrive.TotalSize
Cells(intCount, 4) = objDrive.TotalSize / TEILER
Cells(intCount, 5) = objDrive.FreeSpace
Cells(intCount, 6) = objDrive.FreeSpace / TEILER
If objDrive.IsReady Then
Cells(intCount, 7) = "Bereit"
Else
Cells(intCount, 7) = "Nicht bereit"
End If
Cells(intCount, 8) = objDrive.SerialNumber
Cells(intCount, 9) = objDrive.VolumeName
End If
Next
End
End Sub

 

[bezl]

Teşekkürler

 

[leumruk]

Teşekkürler

k::İyi çalışmalar.