Die Community zu .NET und Classic VB.
Menü

VB 5/6-Tipp 0775: Belegte Zuordnungseinheiten eines Datenträgers ermitteln und anzeigen

 von 

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:

Schwierigkeitsgrad 1

Verwendete API-Aufrufe:

CloseHandle, CreateFileA (CreateFile), DeviceIoControl, FormatMessageA (FormatMessage), GetDiskFreeSpaceA (GetDiskFreeSpace)

Download:

Download des Beispielprojektes [5.19 KB]

'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-VersionWin32sWin95Win98WinMEWinNT4Win2000WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version:

Windows-Version:

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.