Netzlaufwerk verbinden

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo
Wenn du Username und Passwort hast, kein Problem
Sub Open_File_on_Not_Yet_Shared_Network_Drive()
    '(C) by Ramses
    'Öffnet den GetOpenFile-Dialog direkt auf eine Datei
    'auf einem Netzlaufwerk dessen Server und Freigabe-Name zwar bekannt
    'dessen LW-Bezeichnung jedoch nicht bekannt ist
    'Kommt häufig vor in Firmen oder wenn manuelle
    'Laufwerke gemappt werden, oder USB-Laufwerke
    'verwendet werden, welche die normalen Laufwerksbezeichnungen
    'verändern
    Dim i As Byte, x As Variant
    Dim OrigDrive As String, FreeDrive As String
    Dim defShare As String, defPath As String, defName As String
    Dim openFile As String, defDrive As String
    Dim shUsername As String, shPassword As String, shDomain As String
    OrigDrive = Left(ThisWorkbook.FullName, 1)
    'Backslash beachten !!!
    'Zur Freigabe auf dem jeweiligen Rechner
    defShare = "\\ServerName\Freigabename"
    'Unterstruktur bis zur Datei
    defPath = "\Unterordner\"
    'Dateiname
    defName = "Datei.xls"
    'Username der auf die Netzwerkfreigabe zugreifen darf
    shUsername = "Ramses"
    'Passwort des berechtigten Users
    shPassword = "Ramses"
    'Eventuel Domäne in der der User bekannt ist
    'wenn nicht aus der lokalen Domäne
    shDomain = "Domäne"
    If myFreeDrive = "Null" Then
        'normales öffnen zum Browsen
        'wenn kein Laufwerksname mehr zur Verfügung steht
        MsgBox "Datei kann nicht direkt angezeigt werden." & Chr$(13) & _
            "Die Datei: """ & defName & """ liegt auf: """ & defShare & defPath & """"
        'Alle Laufwerksbezeichnungen sind verwendet
        'Der User muss nun manuell auf die Datei browsen
        openFile = Application.GetOpenFilename(defName & " (*.xls), *.xls")
    Else
        defDrive = myFreeDrive
        'Erstellen eines temporären Netzlaufwerkes ohne Username und Passwort
        x = Shell("cmd.exe /C net use " & defDrive & ": " & defShare)
        'Erstellen eines temporären Netzlaufwerkes mit Username und Passwort
        'Ohne Domäne
        'x = Shell("cmd.exe /C net use " & defDrive & ": " & defShare & _
            " " & shPassword & " /User:" & shUsername)
        'Mit fremder Domäne
        'x = Shell("cmd.exe /C net use " & defDrive & ": " & defShare & _
            " " & shPassword & " /User:" & shDomain & "\" & shUsername)
        'in das Verzeichnis wechseln
        ChDrive defDrive
        'in den Unterordner wechseln
        ChDir defDrive & ":" & defPath
        'dialog anzeigen
        openFile = Application.GetOpenFilename(defName & " (*.xls), *.xls")
        'Temporäres Laufwerk wieder löschen
        x = Shell("cmd.exe /C net use " & defDrive & " /Delete")
    End If
    'Die gewählte Datei öffnen
    Workbooks.Open (openFile)
End Sub

Function myFreeDrive() As String
    '(c) ramses
    'Sucht den nächsten freien Laufwerksnamen
    Dim myFSO As Object, myDrv As Object, drvCount, drvStr As String, vName As String, drvTyp As String
    Dim drvmax As Byte, drvNum As Byte
    Set myFSO = CreateObject("Scripting.FileSystemObject")
    Set drvCount = myFSO.Drives
    For Each myDrv In drvCount
        Select Case myDrv.DriveType
                'DriveType 3 sind netzlaufwerke
                'diese werden normalerweise von Z absteigend
                'gemappt. Relative Fehlerquelle !!!
                'Wenn sich der Admin nicht an die Convention hält :-)
            Case 3: drvmax = 90 - 1
            Case Else:
                'Val(Asc(myDrv.DriveLetter))
                'erstellt einen nummerischen Wert aus dem Buchstaben
                If drvNum = 0 Then
                    drvNum = Val(Asc(myDrv.DriveLetter))
                End If
                If drvNum < Val(Asc(myDrv.DriveLetter)) Then
                    drvNum = Val(Asc(myDrv.DriveLetter))
                End If
        End Select
    Next
    If drvmax <= drvNum Then
        myFreeDrive = "Null"
    Else
        'Wandelt die entsprechende Nummer + 1
        'in einen zulässigen Laufwerksbuchstaben um
        myFreeDrive = Chr(drvNum + 1)
    End If
End Function

Gruss Rainer

Beliebteste Forumthreads (12 Monate)

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread