VB 5/6-Tipp 0775: Belegte Zuordnungseinheiten eines Datenträgers ermitteln und anzeigen
von Towerberlin
Beschreibung
Wollten Sie schon immer mal wissen welche Zuordnungseinheiten eines Datenträgers belegt sind und dies ggf. grafisch darstellen? Dann ist dieser Tip genau das Richtige für Sie. In diesem Beispiel werden die Werte für das jeweilige Laufwerk ermittelt und in eine Picture-Box dargestellt. Mit dieser Methode läßt sich allerdings nicht ermitteln, ob Dateien fragmentiert sind.
Schwierigkeitsgrad: | Verwendete API-Aufrufe: CloseHandle, CreateFileA (CreateFile), DeviceIoControl, FormatMessageA (FormatMessage), GetDiskFreeSpaceA (GetDiskFreeSpace) | Download: |
'Dieser Quellcode stammt von http://www.activevb.de 'und kann frei verwendet werden. Für eventuelle Schäden 'wird nicht gehaftet. 'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum. 'Ansonsten viel Spaß und Erfolg mit diesem Source! '------------- Anfang Projektdatei Projekt1.vbp ------------- '--------- Anfang Formular "Form1" alias Form1.frm --------- ' Steuerelement: Schaltfläche "Command1" ' Steuerelement: Schaltfläche "Command2" ' Steuerelement: Festplattenauswahlliste "Drive1" ' Steuerelement: Bildfeld-Steuerelement "Picture1" Option Explicit Private Sub Form_Load() Caption = MsgboxTitel Left = Screen.Width / 2 - Width / 2 Top = Screen.Height / 2 - Height / 2 End Sub Private Sub Command1_Click() Drive1.Refresh End Sub Private Sub Command2_Click() Screen.MousePointer = 11 If GetVolumeBitmap(Left(Drive1.Drive, 2)) Then Call DispVolumeBitmap(Picture1) End If End Sub '---------- Ende Formular "Form1" alias Form1.frm ---------- '--------- Anfang Modul "Module1" alias Module1.bas --------- Option Explicit Type SECURITY_ATTRIBUTES nLength As Long lpSecurityDescriptor As Long bInheritHandle As Long End Type Type VOLUME_BITMAP_BUFFER StartingLcn As Long BitmapSize As Long End Type Declare Function CreateFile Lib "kernel32.dll" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long Declare Function DeviceIoControl Lib "kernel32" (ByVal hDevice As Long, ByVal dwIoControlCode As Long, lpInBuffer As Any, ByVal nInBufferSize As Long, lpOutBuffer As Any, ByVal nOutBufferSize As Long, lpBytesReturned As Long, lpOverlapped As Any) As Long Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters As Long) As Long Global ClusterBitmap() As Byte Global Const MsgboxTitel As String = "Demo - GetVolumeBitmap" Global Const FILE_SHARE_READ As Long = &H1 Global Const FILE_SHARE_WRITE As Long = &H2 Global Const GENERIC_READ As Long = &H80000000 Global Const GENERIC_WRITE As Long = &H40000000 Global Const OPEN_EXISTING As Long = &H3 Global Const FSCTL_GET_VOLUME_BITMAP As Long = &H9006F Global Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000 Global Const INVALID_HANDLE_VALUE As Long = -1 Function SysErrText(ErrNum As Long) As String Dim Buffer As String, BufferLen As Long, RetVal As Long Buffer = Space(256) BufferLen = 256 RetVal = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, 0&, ErrNum, 0&, Buffer, BufferLen, ByVal 0&) If Mid(Buffer, RetVal - 1, 2) = vbCrLf Then RetVal = RetVal - 2 SysErrText = Left(Buffer, RetVal) End Function Function GetVolumeBitmap(Laufwerk As String) As Boolean Dim Handle As Long, ArrLen As Long, ArrLenRetval As Long, ErrNum As Long, ErrTxt As String Dim SecAttr As SECURITY_ATTRIBUTES, VolBitBuf As VOLUME_BITMAP_BUFFER Rem Anzahl Zuordnungeinheiten ermitteln If GetDiskFreeSpace(Laufwerk, ByVal 0&, ByVal 0&, ByVal 0&, ArrLenRetval) = 0 Then ErrNum = 1 Goto Fertig End If Rem Laufwerkshandle SecAttr.nLength = Len(SecAttr) SecAttr.bInheritHandle = True SecAttr.lpSecurityDescriptor = 0 Handle = CreateFile("\\.\" + Laufwerk, GENERIC_READ Or GENERIC_WRITE, FILE_SHARE_READ Or FILE_SHARE_WRITE, SecAttr, OPEN_EXISTING, 0&, 0&) If Handle = INVALID_HANDLE_VALUE Then ErrNum = 2 Goto Fertig End If Rem Clusterbitmap dimensionieren ArrLen = Int((ArrLenRetval + 7) / 8) + 16 ReDim ClusterBitmap(ArrLen - 1) Rem DeviceIOControl VolBitBuf.StartingLcn = 0 VolBitBuf.BitmapSize = 0 ArrLenRetval = 0 If DeviceIoControl(Handle, FSCTL_GET_VOLUME_BITMAP, VolBitBuf, Len(VolBitBuf), ClusterBitmap(0), ArrLen, ArrLenRetval, ByVal 0&) = 0 Then ErrNum = 3 Goto Fertig: Rem CloseHandle kommt später End If Call CloseHandle(Handle) Rem erfolgreich GetVolumeBitmap = Not (ArrLenRetval = 0) ErrNum = IIf(ArrLenRetval = 0, 4, 0) Fertig: If Not ErrNum = 0 Then ReDim ClusterBitmap(0): Rem Speicher freigeben Select Case ErrNum Case 1: ErrTxt = "Anzahl Volume-Cluster konnte nicht ermittelt werden." Case 2: ErrTxt = "Das Laufwerks-Handle ist ungültig." Case 3: ErrTxt = "Cluster-Bitmap konnte nicht ermittelt werden." Case 4: ErrTxt = "DeviceIOControl gibt 0 Zuordnungseinheiten zurück." End Select ErrTxt = ErrTxt + vbCrLf + SysErrText(Err.LastDllError) If ErrNum = 3 Then Call CloseHandle(Handle): Rem erst hier, weil sich sonst "Err.LastDllError" nicht auf "DeviceIOControl" bezieht End If Screen.MousePointer = 0 MsgBox ErrTxt, vbCritical, MsgboxTitel GetVolumeBitmap = False End If End Function Sub DispVolumeBitmap(PictBox As PictureBox) Dim BitmapLen As Long, PictPixels As Long, Consul As Long, Expand As Long Dim FarbeGrD As Long, FarbeGrH As Long, FarbeWe As Long, PictX As Long, PictY As Long, PictW As Long, PictH As Long Dim PixelFarbe As Long, PixelWert As Long, BitmapIndex As Long, BitmapBitMask As Long, TempC As Long Rem Bitmap an die Anzahl Pixel der Picturebox anpassen PictPixels = PictBox.ScaleHeight * PictBox.ScaleWidth BitmapLen = UBound(ClusterBitmap) + 1 TempC = (BitmapLen - 16) * 8: Rem Anzahl Bits ohne die ersten 16 Bytes If TempC > PictPixels Then Consul = Int((TempC + PictPixels - 1) / PictPixels) Expand = 1 Else Consul = 1 Expand = Int(PictPixels / TempC) End If FarbeGrD = RGB(0, 64, 0) FarbeGrH = RGB(0, 160, 0) FarbeWe = RGB(255, 255, 255) Rem altes Image löschen und Dimensionen ermitteln PictBox.Cls PictBox.Refresh PictX = 0 PictY = 0 PictW = PictBox.ScaleWidth - 1 PictH = PictBox.ScaleHeight - 1 Rem Volume-Bitmap darstellen BitmapIndex = 16 BitmapBitMask = 1 Do Until BitmapIndex = BitmapLen Rem Werte ggf zusammenfassen PixelWert = 0 For TempC = 1 To Consul If ClusterBitmap(BitmapIndex) And BitmapBitMask Then PixelWert = PixelWert + 100: Rem in der Endrechnung wie Pixelwert * 100 End If If BitmapBitMask = 128 Then BitmapIndex = BitmapIndex + 1 If BitmapIndex = BitmapLen Then Exit For BitmapBitMask = 1 Else BitmapBitMask = BitmapBitMask * 2 End If Next If TempC > Consul Then TempC = Consul PixelWert = PixelWert / TempC: Rem Ergibt Prozentwert, siehe "Pixelwert = Pixelwert + 100" If PixelWert < 15 Then PixelFarbe = FarbeWe Else PixelFarbe = IIf(PixelWert > 85, FarbeGrD, FarbeGrH) End If Rem Pixel ggf ausbreiten For TempC = 1 To Expand PictBox.PSet (PictX, PictY), PixelFarbe If PictX = PictW Then PictX = 0 PictY = PictY + 1 Else PictX = PictX + 1 End If Next Loop Screen.MousePointer = 0 Rem Speicher freigeben ReDim ClusterBitmap(0) End Sub '---------- Ende Modul "Module1" alias Module1.bas ---------- '-------------- Ende Projektdatei Projekt1.vbp --------------
Tipp-Kompatibilität:
Windows/VB-Version | Win32s | Win95 | Win98 | WinME | WinNT4 | Win2000 | WinXP |
VB4 | |||||||
VB5 | |||||||
VB6 |
Ihre Meinung
Falls Sie Fragen zu diesem Artikel haben oder Ihre Erfahrung mit anderen Nutzern austauschen möchten, dann teilen Sie uns diese bitte in einem der unten vorhandenen Themen oder über einen neuen Beitrag mit. Hierzu können sie einfach einen Beitrag in einem zum Thema passenden Forum anlegen, welcher automatisch mit dieser Seite verknüpft wird.