Startseite / Tipps / VB 5/6-Tipp 0500: Virtuelle Laufwerke erstellen

VB 5/6-Tipp 0500: Virtuelle Laufwerke erstellen

 von Hans-Jörg Stradtmann

'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 subs.vbp ---------------
'---------- Anfang Formular "Form1" alias subs.frm ----------
' Steuerelement: Schaltfläche "Command2"
' Steuerelement: Festplattenauswahlliste "Drive1"
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Verzeichnisauswahlliste "Dir1"
' Steuerelement: Listen-Steuerelement "List2"
' Steuerelement: Listen-Steuerelement "List1"
' Steuerelement: Beschriftungsfeld "Label2"
' Steuerelement: Beschriftungsfeld "Label1"

Option Explicit

'Hinweis:
'Unter WindowsNT und den daruaf aufbauenden Betriebssystemen gibt es auch eine
'API-Funktion, die genau das erledigen soll
'
'Private Declare Function DefineDosDevice Lib "kernel32.dll" Alias _
'       "DefineDosDeviceA" (ByVal dwFlags As Long, _
'       ByVal lpDeviceName As String, _
'       Optional ByVal lpTargetPath As String = vbNullString) As Long
'
'Private Const DDD_CREATE_DEFINITION As Long = &H0   ' LW-Zuordnung
'Private Const DDD_REMOVE_DEFINITION As Long = &H2   ' LW-Zuordnung wieder aufheben

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliSeconds As Long)

'Ergänzung am 13.11.2002 zum Verwenden von Ordnern, die ein Space im Namen haben etc.
Private Declare Function GetShortPathName Lib "kernel32" _
    Alias "GetShortPathNameA" ( _
    ByVal lpszLongPath As String, _
    ByVal lpszShortPath As String, _
    ByVal cchBuffer As Long) As Long
        
Dim strShell, strPath, sbstfn(25) As String
Dim sbstf, l1, l2 As Long

Private Sub Command1_Click()
    'Virtl. Laufwerk erstellen
    
    'Ergänzung am 13.11.2002
    Dim strDosPath As String
    Dim Result As Long
    
    strDosPath = Space(255)
    Result = GetShortPathName(strPath, strDosPath, Len(strDosPath))
    strDosPath = Mid$(strDosPath, 1, Result)
    
    strShell = "subst " & List1.List(l1) & " " & strDosPath
    'Ergänzung ende
    
    List2.AddItem List1.List(l1)
    List1.RemoveItem (l1)
    sbstf = sbstf + 1
    sbstfn(sbstf) = strPath
    Shell strShell
    Command2.Enabled = True
End Sub

Private Sub Command2_Click()
    'Virtl. Laufwerk löschen
    
    Dim i As Long
    
    If sbstf > -1 Then
        strShell = "subst " & List2.List(l2) & " /D"
        List1.AddItem List2.List(l2)
        List2.RemoveItem (l2)
        Shell strShell
        For i = l2 + 1 To sbstf
            sbstfn(i - 1) = sbstfn(i)
        Next i
        sbstf = sbstf - 1
    End If
    If sbstf = -1 Then Command2.Enabled = False
End Sub

Private Sub Dir1_Change()
    strPath = Dir1.Path
End Sub

Private Sub Drive1_Change()
    Dir1.Path = Drive1.Drive
End Sub

Private Sub Form_Load()
    Dim i As Long
    Dim ff As Long
    
    ff = FreeFile
    Command2.Enabled = False
    sbstf = -1
    strShell = App.Path & "\subs.bat"
    
    
    Open strShell For Output As #ff
       Print #ff, "subst > subst.txt"
    Close #ff
    Sleep (100)
    Shell strShell
    Sleep (100)
    
    Form1.Show
    If Len(Dir(CurDir$ & "\subst.txt")) > 0 Then
        Open CurDir$ & "\subst.txt" For Input As #ff
            While Not EOF(ff)
                Line Input #ff, strShell
                List2.AddItem (Left$(strShell, 2))
                sbstf = sbstf + 1
                sbstfn(sbstf) = Right$(strShell, Len(strShell) - 6)
            Wend
            Command2.Enabled = True
        Close #ff
        Sleep 100
        Kill (CurDir$ & "\subst.txt")
    End If
    For i = 65 To 90
            List1.AddItem Chr$(i) & ":"
    Next i
    Call Dir1_Change
End Sub

Private Sub List1_Click()
    If List1.ListIndex <> -1 Then
        l1 = List1.ListIndex
    End If
End Sub

Private Sub List2_Click()
    If List2.ListIndex <> -1 Then
        l2 = List2.ListIndex
        Dir1.Path = sbstfn(l2)
    End If
End Sub
'----------- Ende Formular "Form1" alias subs.frm -----------
'---------------- Ende Projektdatei subs.vbp ----------------

Tipp-Kompatibilität:

Windows/VB-Version	Win32s	Win95	Win98	WinME	WinNT4	Win2000	WinXP
VB4
VB5
VB6

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

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version: VB6 VB5 VB4

Windows-Version: Windows XP Windows 2000 Windows NT4 Windows Me Windows 98 Windows 95 Win32s

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 12 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.