AW: USB/Disk Infos mit VB auslesen
27.02.2023 22:51:35
Firmus
Hi Piet,
einen kleinen Beitrag kann ich dir geben.
Option Explicit
Sub VI__0100_Laufwerke()
'
'benötigt Verweis auf "Microsoft Scripting Runtime"
'Global DiskIndex As Variant
Dim fso As New FileSystemObject
Dim LW As Drive
Dim LW_Text As String
Dim Zeile As Long, SPoff As Long
Dim icol As Long, iRow As Long
Dim xSheetDISK As String
Dim xfilename As String
Dim Rechnername As String
Dim wks As Worksheet
Rechnername = Environ("COMPUTERNAME")
xfilename = Rechnername & "_IDX_" & Format((Now), "YYYYMMDD-hhmmss")
xSheetDISK = "VideoIndex_" & Format((Now), "YYYYMMDD-hhmmss")
icol = 1
iRow = 1
Workbooks.Add
Worksheets(1).Name = xSheetDISK
On Error Resume Next
SPoff = 1
Zeile = 2
'======================================================================================================
' Überschriften setzen, Spalten formatieren, anschließend speichern
'======================================================================================================'
Worksheets(xSheetDISK).Activate
Range(Cells(1, SPoff + 1), Cells(99, SPoff + 15)).ClearContents
Range(Cells(1, SPoff + 1), Cells(1, SPoff + 15)) = Array( _
"AvailableSpace", _
"FreeSpace", _
"Available Space", _
"DriveLetter", _
"DriveType", _
"FileSystem", _
"IsReady", _
"Path", _
"RootFolder", _
"SerialNumber", _
"ShareName", _
"VolumeName", _
"RootFolderType", _
"DriveType", _
"Select:")
ActiveWorkbook.SaveAs Filename:=xfilename 'save file-backup mit timestamp
' Set wks = Worksheets(xSheetDISK)
' With wks
' End With
For Each LW In fso.Drives
If LW.DriveType = 1 Then 'Diskette
Cells(Zeile, SPoff + 1) = Format(LW.AvailableSpace / 1000000, "0.00") & " MB"
Cells(Zeile, SPoff + 2) = Format(LW.FreeSpace / 1000000, "0.00") & " MB"
Cells(Zeile, SPoff + 3) = Format(LW.TotalSize / 1000000, "0.00") & " MB"
Else
Cells(Zeile, SPoff + 1) = Format(LW.AvailableSpace / 1000000000, "0.00") & " GB"
Cells(Zeile, SPoff + 2) = Format(LW.FreeSpace / 1000000000, "0.00") & " GB"
Cells(Zeile, SPoff + 3) = Format(LW.TotalSize / 1000000000, "0.00") & " GB"
End If
Cells(Zeile, SPoff + 4) = LW.DriveLetter
Cells(Zeile, SPoff + 5) = LW.DriveType
Cells(Zeile, SPoff + 6) = LW.FileSystem
Cells(Zeile, SPoff + 7) = LW.IsReady
Cells(Zeile, SPoff + 8) = LW.Path
Cells(Zeile, SPoff + 9) = LW.RootFolder
Cells(Zeile, SPoff + 10) = LW.SerialNumber
Cells(Zeile, SPoff + 11) = LW.ShareName
Cells(Zeile, SPoff + 12) = LW.VolumeName
Cells(Zeile, SPoff + 13) = LW.RootFolder.Type
LW_Text = "unknown"
If LW.DriveType = 1 Then LW_Text = "Removable" 'Diskette
If LW.DriveType = 2 Then LW_Text = "Fixed"
If LW.DriveType = 3 Then LW_Text = "Remote-Access"
If LW.DriveType = 4 Then LW_Text = "CD-ROM"
Cells(Zeile, SPoff + 14) = LW_Text
Zeile = Zeile + 1
Next
Zeile = Zeile
'======================================================================================================
' Formate setzen
'======================================================================================================'
Cells.Select
Cells.EntireColumn.AutoFit
Range("C2").Select
ActiveWindow.FreezePanes = True
Columns(SPoff + 0).ColumnWidth = 8 'Spalte "A"
Range(Cells(1, SPoff + 1), Cells(99, SPoff + 15)).HorizontalAlignment = xlLeft
Range(Cells(1, SPoff + 1), Cells(99, SPoff + 15)).HorizontalAlignment = xlRight
Range(Cells(1, SPoff + 1), Cells(1, SPoff + 15)).Interior.ColorIndex = 35
Range(Cells(1, SPoff + 1), Cells(1, SPoff + 15)).Font.Bold = True
Range(Columns(1, SPoff + 15)).Columns.AutoFit
Columns("M:M").Select 'VolumeName
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("E:E").Select 'Drive Letter
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Zeile = Zeile
ActiveWorkbook.Save 'As Filename:=xFilename 'save file-backup mit timestamp
End Sub
Läuft bei mir auf win7 mit xls2013
Gruß,
Firmus