Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0545: Virtuelle Netzlaufwerke unter Windows NT verwalten

VB 5/6-Tipp 0545: Virtuelle Netzlaufwerke unter Windows NT verwalten

 von B. Berndt

Schwierigkeitsgrad:

Verwendete API-Aufrufe: WNetAddConnectionA (WNetAddConnection), WNetCancelConnectionA (WNetCancelConnection), WNetGetConnectionA (WNetGetConnection)

Download: Download des Beispielprojektes [4,69 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 Simply.vbp --------------
'--------- Anfang Formular "Form1" alias Simply.frm ---------
' Steuerelement: Schaltfläche "Command4"
' Steuerelement: Listen-Steuerelement "List2"
' Steuerelement: Schaltfläche "Command3"
' Steuerelement: Schaltfläche "Command2"
' Steuerelement: Listen-Steuerelement "List1"
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Beschriftungsfeld "Label1"
Option Explicit



Private obj As New clsBeWNETsimple

Private Sub Command1_Click()
    Dim s As String
    Me.List1.Clear
    Do While (obj.hasMoreConnections)
        s = obj.getNextDriveLetter
        Me.List1.AddItem (s & obj.getSharedName(s))
    Loop
End Sub

Private Sub Command2_Click()
    Call obj.refresh
    Call Command1_Click
End Sub

Private Sub Command3_Click()
    If (List1.ListIndex >= 0) Then
        Call List2.AddItem(List1.Text)
        Call obj.disconnectDrive(Left$(List1.Text, 2))
        Call Command2_Click
    Else
        MsgBox "Bitte wählen Sie"
    End If
End Sub

Private Sub Command4_Click()
    If (List2.ListIndex >= 0) Then
        Call obj.setSharedName(Left$(List2.Text, 2), _
            Mid$(List2.Text, 3))
        Call List2.RemoveItem(List2.ListIndex)
        Call Command2_Click
    Else
        MsgBox "Bitte wählen Sie"
    End If
End Sub

Private Sub List1_Click()
    If (obj.isRemembered(Left$(List1.Text, 2))) Then
        Me.Label1.Caption = "Remembered"
    Else
        Me.Label1.Caption = "Connected"
    End If
End Sub

'---------- Ende Formular "Form1" alias Simply.frm ----------
'--- Anfang Klasse "clsBeWNETsimple" alias BeWNETsimple.cls ---
'Name:      clsBeWNETsimple
'
'Zweck:     Klasse dient zum Anlegen/Abfragen wiederherstellen von Netzwerkanbindungen.
'           Es können auch "Remembered Connections"(werden im Explorer mit rotem Kreuz markiert)
'           aktiviert werden, indem die Methode "reconnectDrive" aufgerufen wird.
'
'Änd-Dat    Autor   Grund
'tt.mm.jj   BAB     Ursprungsversion

'***************************************************************************************************
'***                                        VB-CONFIGURATION                                     ***
'***************************************************************************************************
Option Explicit
Option Base 0


'***************************************************************************************************
'***                                        CONSTANTS                                            ***
'***************************************************************************************************
Private Const NUL                           As Long = 0
Private Const BABERR                        As Long = vbObjectError + &HBAB
Private Const MAX_PATH                      As Long = 260
Private Const ERROR_SUCCESS                 As Long = 0&
Private Const ERROR_INVALID_PASSWORD        As Long = 86&
Private Const ERROR_BAD_NET_NAME            As Long = 67&
Private Const UBOUNDDRIVE                   As Integer = 23


'***************************************************************************************************
'***                                        USERDEFINED TYPES                                    ***
'***************************************************************************************************
Private Type UDT_Drives
    DriveLetter                             As String * 2
    UNCpath                                 As String * MAX_PATH
    UNCpathLen                              As Long
    status                                  As ENM_status
End Type


'***************************************************************************************************
'***                                        EXTERN DECLARES                                      ***
'***************************************************************************************************
Private Declare Function WNetGetConnection Lib "mpr.dll" Alias "WNetGetConnectionA" _
        (ByVal lpszLocalName As String, ByVal lpszRemoteName As String, cbRemoteName As Long) _
        As Long
Private Declare Function WNetAddConnection Lib "mpr.dll" Alias "WNetAddConnectionA" _
        (ByVal lpszNetPath As String, ByVal lpszPassword As String, ByVal lpszLocalName As String) _
        As Long
Private Declare Function WNetCancelConnection Lib "mpr.dll" Alias "WNetCancelConnectionA" _
        (ByVal lpszName As String, ByVal bForce As Long) As Long


'***************************************************************************************************
'***                                        ENUMERATIONS                                         ***
'***************************************************************************************************
Public Enum ENM_status
    SHARE = 0
    NOSHARE = 2250
    REMEMBERED = 1201
End Enum


'***************************************************************************************************
'***                                        VARIABLES                                            ***
'***************************************************************************************************
Private udtDrives(1 To UBOUNDDRIVE)         As UDT_Drives
Private index                               As Integer
Private found                               As Integer
Private count                               As Integer
Private readed                              As Boolean
Private internCall                          As Boolean


'***************************************************************************************************
'***                                        PROPERTYS                                            ***
'***************************************************************************************************
Public Property Get hasMoreConnections() As Boolean
    If (Not readed) Then Call Me.refresh
    If (found < count) Then
        hasMoreConnections = True
    Else
        hasMoreConnections = False
    End If
End Property

'---------------------------------------------------------------------------------------------------
Public Property Get isRemembered(ByRef pstrDriveLetter As String) As Boolean
    
    Dim index                   As Integer
    
    index = checkDriveLetter(pstrDriveLetter)
    If (Not readed) Then Call Me.refresh
    If (index) Then
        If (udtDrives(index).status = REMEMBERED) Then
            isRemembered = True
        Else
            isRemembered = False
        End If
    End If
End Property

'---------------------------------------------------------------------------------------------------
Public Property Get isShared(ByRef pstrDriveLetter As String) As Boolean
    
    Dim index                   As Integer
    
    index = checkDriveLetter(pstrDriveLetter)
    If (Not readed) Then Call Me.refresh
    If (index) Then
        With udtDrives(index)
            If (.status = SHARE Or .status = REMEMBERED) Then
                isShared = True
            Else
                isShared = False
            End If
        End With
    End If
End Property


'***************************************************************************************************
'***                                        FUNCTIONS                                            ***
'***************************************************************************************************
'***                                        PUBLIC                                               ***
'***************************************************************************************************
Public Function refresh() As Boolean
    
    Dim i                       As Integer
    Dim oldUNC                  As String
    
    index = LBound(udtDrives())
    count = 0
    found = 0
    
    For i = LBound(udtDrives()) To UBound(udtDrives()) Step 1
        With udtDrives(i)
            If (Not readed) Then
                .DriveLetter = Chr$(67 + i) & ":"       ' 'C' + offs
                .status = ENM_status.NOSHARE
            End If
            oldUNC = Left$(.UNCpath, .UNCpathLen)
            Call getConnection(udtDrives(i))
            If (.status = REMEMBERED Or .status = SHARE) Then
                count = count + 1
            End If
            If (Not oldUNC = Left$(.UNCpath, .UNCpathLen)) Then
                refresh = True
            End If
        End With
    Next i
    readed = True
End Function

'---------------------------------------------------------------------------------------------------
Public Function getDriveLetter(ByVal pstrUNCpath As String, _
                                Optional ByVal pbooIgnoreCase As Boolean = False) _
                                As String
    
    Dim i                       As Integer
    Dim tmp                     As String
    
    If (pbooIgnoreCase) Then
        pstrUNCpath = UCase$(pstrUNCpath)
    End If
    If (Not readed) Then Call Me.refresh
    For i = LBound(udtDrives()) To UBound(udtDrives())
        With udtDrives(i)
            If (pbooIgnoreCase) Then
                tmp = UCase$(Left$(.UNCpath, .UNCpathLen))
            Else
                tmp = Left$(.UNCpath, .UNCpathLen)
            End If
            If (tmp = pstrUNCpath) Then
                getDriveLetter = .DriveLetter
                Exit Function
            End If
        End With
    Next i
End Function

'---------------------------------------------------------------------------------------------------
Public Function getSharedName(ByRef pstrDriveLetter As String) As String
    
    Dim index                   As Integer
    
    index = checkDriveLetter(pstrDriveLetter)
    If (Not readed) Then Call Me.refresh
    If (index) Then
        With udtDrives(index)
            If (.status = SHARE Or .status = REMEMBERED) Then
                getSharedName = Left$(.UNCpath, .UNCpathLen)
            End If
        End With
    Else
        getSharedName = ""
    End If
End Function

'---------------------------------------------------------------------------------------------------
Public Sub setSharedName(ByRef pstrDriveLetter As String, ByRef pstrNewShare As String)
    
    Dim index                   As Integer
    Dim ret                     As Long
    
    index = checkDriveLetter(pstrDriveLetter)
    If (Not readed) Then Call Me.refresh
    If (index) Then
        With udtDrives(index)
            If (.status = SHARE Or .status = REMEMBERED) Then
                Call WNetCancelConnection(pstrDriveLetter, True)
                .status = REMEMBERED
                .UNCpath = String$(MAX_PATH, Chr$(0))
                .UNCpathLen = 0
            End If
            ret = WNetAddConnection(pstrNewShare, NUL, pstrDriveLetter)
            If (Not ret = ERROR_SUCCESS) Then
                Err.Raise BABERR + 0, TypeName(Me), getError(ret)
            End If
        End With
    End If
    If Not internCall Then
        Me.refresh
    End If
End Sub

'---------------------------------------------------------------------------------------------------
Public Sub disconnectDrive(ByRef pstrDriveLetter As String)
    
    Dim index                   As Integer
    
    index = checkDriveLetter(pstrDriveLetter)
    If (index) Then
        With udtDrives(index)
            Call WNetCancelConnection(pstrDriveLetter, True)
            .status = REMEMBERED
            .UNCpath = String$(MAX_PATH, Chr$(0))
            .UNCpathLen = 0
        End With
    End If
End Sub

'---------------------------------------------------------------------------------------------------
Public Sub reconnectDrive(ByRef pstrDriveLetter As String, _
                          Optional ByVal pbooWithForce As Boolean = False)
    
    Dim index                   As Integer
    
    index = checkDriveLetter(pstrDriveLetter)
    If (Not readed) Then Call Me.refresh
    
    If (index) Then
        With udtDrives(index)
            If .status = REMEMBERED Or (.status = SHARE And pbooWithForce = True) Then
                Call WNetCancelConnection(pstrDriveLetter, True)
                Call Me.setSharedName(.DriveLetter, Left$(.UNCpath, .UNCpathLen))
                Call getConnection(udtDrives(index))
            End If
        End With
    End If
End Sub

'---------------------------------------------------------------------------------------------------
Public Sub reconnectAllDrives(Optional ByVal pbooWithForce As Boolean)
    
    Dim i                       As Integer
    
    If (Not readed) Then Call Me.refresh
    
    For i = LBound(udtDrives()) To UBound(udtDrives()) Step 1
        With udtDrives(i)
            If (.status = REMEMBERED Or (.status = SHARE And pbooWithForce = True)) Then
                internCall = True
                Call WNetCancelConnection(.DriveLetter, True)
                Call Me.setSharedName(.DriveLetter, Left$(.UNCpath, .UNCpathLen))
                Call getConnection(udtDrives(i))
                internCall = False
            End If
        End With
    Next i
    Me.refresh
End Sub

'---------------------------------------------------------------------------------------------------
Public Function getNextDriveLetter() As String
    Do While (index <= UBound(udtDrives()))
        If (udtDrives(index).status = REMEMBERED Or udtDrives(index).status = SHARE) Then
            getNextDriveLetter = udtDrives(index).DriveLetter
            found = found + 1
            index = index + 1
            Exit Function
        Else
            index = index + 1
        End If
    Loop
End Function


'***************************************************************************************************
'***                                        PRIVATE                                              ***
'***************************************************************************************************
Private Function checkDriveLetter(ByRef pstrDriveLetter As String) As Integer
    
    Dim tmp                     As String * 1
    
    If (Len(pstrDriveLetter) > 2) Then
        Exit Function
    End If
    If (Not Right$(pstrDriveLetter, 1) = ":") Then
        Exit Function
    End If
    
    tmp = UCase$(Left$(pstrDriveLetter, 1))
    Select Case tmp
        Case "D" To "Z":
            checkDriveLetter = Asc(tmp) - Asc("D") + LBound(udtDrives())
    End Select
End Function

'---------------------------------------------------------------------------------------------------
Private Function getConnection(ByRef pudtDrives As UDT_Drives)
    Dim pos                     As String
    With pudtDrives
        .UNCpathLen = MAX_PATH
        .UNCpath = String$(MAX_PATH, Chr$(0))
        .status = WNetGetConnection(.DriveLetter, .UNCpath, .UNCpathLen)
        .UNCpathLen = InStr(.UNCpath, Chr$(0)) - 1
    End With
End Function

'---------------------------------------------------------------------------------------------------
Private Function getError(ByVal plngError As Long) As String
    Select Case plngError
        Case ERROR_INVALID_PASSWORD:
            getError = "The specified network password is not correct."
        Case ERROR_BAD_NET_NAME:
            getError = "The network name cannot be found."
    End Select
End Function
'--- Ende Klasse "clsBeWNETsimple" alias BeWNETsimple.cls ---
'--------------- Ende Projektdatei Simply.vbp ---------------

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 1 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.