Code programmgesteuert hinzufügen und Laufwerktyp anzeigen.

Es wird ermittelt, welche Laufwerke am Rechner angeschlossen sind, für jedes vorhandene wird ein Eintrag in ein Popupmenü hinzugefügt. Die Prozeduren, die beim Klick aufgerufen werden, sind vorher programmgesteuert hinzugefügt worden.

Beispieldatei (popuplaufwerk.zip 15 kB)

Option Explicit

'In ein Modul mit Namen "myLaufwerke"
Declare Function GetLogicalDrives& Lib "kernel32" ()
Private Declare Function GetDriveType Lib _
    "kernel32" Alias "GetDriveTypeA" _
    (ByVal nDrive As String) As Long
Private Const DRIVE_CDROM = 5
Private Const DRIVE_FIXED = 3
Private Const DRIVE_RAMDISK = 6
Private Const DRIVE_REMOTE = 4
Private Const DRIVE_REMOVABLE = 2

Sub PopupErzeugen()
Dim a As Long, L As Long, CBName As String
Dim LW  As String, Prozedur  As String
Dim VBCount As Long
Dim meineLeiste As CommandBar
Dim KonBef As CommandBarButton
On Error Resume Next
VBCount = Application.VBE.VBProjects.Count
'Objektvariable myLaufwerk erstellen, notfalls Komponente hinzu
With Application.VBE.VBProjects(VBCount).VBComponents("myLaufwerke").CodeModule
    'Commandbar "Laufwerk" löschen, wenn vorhanden
    'ansonsten On Error Resume Next
    Application.CommandBars("Laufwerk").Delete
    'Commandbar "Laufwerk" hinzufügen
    Set meineLeiste = Application.CommandBars _
    .Add(Name:="Laufwerk", Position:=msoBarPopup, Temporary:=True)
    'Bitmaske mit Laufwerken holen
    L = GetLogicalDrives
    For a = 97 To 123
        If L And 2 ^ (a - 97) Then
            'Wenn Bit 0 gesetzt, dann LW a vorhanden
            'Wenn Bit 1 gesetzt, dann LW b vorhanden
            'usw.
            LW = Chr(a)
            If Not .Find("Sub LW_" & LW & "()", 1, 1, .CountOfLines, .CountOfLines) Then
                'Prozeduren für die Laufwerke hinzufügen
                'wenn Änderungen hier, vorher alle löschen
                Prozedur = "Sub LW_" & LW & " " & vbCrLf
                Prozedur = Prozedur & "LaufwerktypAnzeigen """ & LW & """" & vbCrLf
                Prozedur = Prozedur & "End Sub"
                .AddFromString (Prozedur)
            End If
            'Control hinzufügen für jedes Laufwerk
            Set KonBef = meineLeiste.Controls.Add(msoControlButton)
            With KonBef
                'Im Popup angezeigter Text
                .Caption = "Laufwerk : " & Chr(a)
                'Im Popup angezeigtes Icon
                .FaceId = 3
                'Prozedur, die nach Klick aufgerufen wird
                .OnAction = "LW_" & Chr(a)
            End With
        End If
    Next
End With
'Wenn die Prozeduren hinzugefügt wurden, gibt
'es beim direkten Aufruf manchmal Probleme
Application.OnTime Now + TimeSerial(0, 0, 1), "PopupAnzeigen"
End Sub

Private Sub LaufwerktypAnzeigen(a As String)
Dim Meldung As String
Select Case GetDriveType(a & ":\")
    Case DRIVE_CDROM
        Meldung = "CDROM"
    Case DRIVE_FIXED
        Meldung = "Festplatte"
    Case DRIVE_RAMDISK
        Meldung = "RAMDISK"
    Case DRIVE_REMOTE
        Meldung = "Netzlaufwerk"
    Case DRIVE_REMOVABLE
        Meldung = "Diskette"
End Select
MsgBox "Laufwerk = " & a & vbCrLf & "Typ = " & Meldung
End Sub

Public Sub PopupAnzeigen()
    Application.CommandBars("Laufwerk").ShowPopup
End Sub