Datei nur von bestimmten Speicherort starten

Guten Morgen zusammen,
ich habe eine Excel-Datei in unserem Netzwerk bereitgestellt. Die Datei soll nur von diesem Ort aus lauffähig sein, damit sich nicht jemand die Datei auf den eigenen Rechner zieht und irgendwann mal mit einer alten Version arbeitet.
Hierzu wollte ich den Pfad unter Thisworkbook.path mit dem Netzwerkpfad vergleichen. Aber leider geht das nicht aufgrund der unterschiedlichen Schreibweisen (Q\xxx\xxxx\Datei.xlsm im Vergleich zum Netzwerkpfad \\xxx\xxxx\Datei.xlsm).
Wenn die Datei mit einem bestimmten Button gespeichert wird, bekommt sie ein Kennzeichen gesetzt, so das die Speicherortüberprüfung beim nächsten Start ausgesetzt wird.
Hat jemand eine Idee, wie man das realisieren kann ?
Bin für Eure Vorschläge dankbar.
Viele Grüße
Stefan

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

'------------------------------------------------------------------------------------- ' Diese Code in ein Modul ' translate DOS-Based DrivePathFilename to UNC-Notation Public Function UNCpath(ByVal sPathWithDriveLetter As String) As String Dim objNtWork As Object Dim objDrives As Object Dim lxDrive As Long Set objNtWork = CreateObject("WScript.Network") Set objDrives = objNtWork.enumnetworkdrives UNCpath = sPathWithDriveLetter For lxDrive = 0 To objDrives.Count - 1 Step 2 If UCase(objDrives.Item(lxDrive)) = UCase(Left(sPathWithDriveLetter, 2)) Then UNCpath = objDrives.Item(lxDrive + 1) & Right(sPathWithDriveLetter, Len( _ sPathWithDriveLetter) - 2) Exit For End If Next Set objNtWork = Nothing Set objDrives = Nothing End Function Sub Test() ' "UNC Pfad anpassen" If UNCpath(ThisWorkbook.FullName) = "\\Server\Dir\SubDir\" & ThisWorkbook.Name Then MsgBox "Ist auf dem Netzwerk!", vbInformation Else MsgBox "Ist lokal gespeichert!", vbCritical End If End Sub

Hallo
du könntest dir den UNC- Pfad aus den jeweils "Lokalen Pfaden" ermitteln und den dann abgleichen.
z.B. mit folgender Function.


Private Declare Function WNetGetConnection Lib "mpr.dll" _
    Alias "WNetGetConnectionA" (ByVal lpszLocalName As String, _
                                ByVal lpszRemoteName As String, _
                                cbRemoteName As Long) As Long

Public Function GetUNCPath(ByVal sLocalPath As String) As String
'// ----------------------------------------------------------------- 
'// Methode:   | Konvertiert einen Pfad in UNC-Pfad (\\SERVER\...) 
'// ----------------------------------------------------------------- 
'// Parameter: | sLocalPath = gültiger, lokaler Pfad (X:\..) 
'// ----------------------------------------------------------------- 
'// Rückgabe:  | bei Erfolg = UNC-Pfad 
'//            | bei Fehler = sLocalPath 
'// ----------------------------------------------------------------- 
    Const NO_ERROR  As Long = 0
    Dim sUNCPath    As String
    Dim sResult     As String
    Dim sDrive      As String
   
    GetUNCPath = sLocalPath
    If VBA.Mid$(sLocalPath, 2, 1) <> ":" Then Exit Function
'// Die API-Funktion benötigt nur das Laufwerk! 
    sDrive = VBA.Left$(sLocalPath, 2)
    sUNCPath = VBA.String(260, 0)
    If WNetGetConnection(sDrive, sUNCPath, VBA.Len(sUNCPath)) = NO_ERROR Then
        sResult = VBA.Left$(sUNCPath, VBA.InStr(sUNCPath, vbNullChar) - 1)
        If VBA.Len(sResult) > 0 Then
            GetUNCPath = sResult & VBA.Mid$(sLocalPath, 3)
        End If
    End If
End Function

Aufrufen z.B. so..

Sub HAllo()
    Dim DerRichtigePfad As String
    
    DerRichtigePfad = "\\Server\Freigabe\...\Test.xlsm"
    If GetUNCPath(ThisWorkbook.FullName) = DerRichtigePfad Then
        MsgBox "erlaubt"
    Else
        MsgBox "leider nein"
        Exit Sub
    End If
End Sub

LG UweD

'Makro unter diese Arbeitsmappe Private Sub Workbook_Open() Dim Kennzeichen Dim strPfad Kennzeichen = "" 'kennzeichen einlesen 'anpassen !!!! If Kennzeichen = "" Then 'Kennzeichen ist noch nicht gesetzt 'Prüfen der ersten 3 Zeichen der Speicherpfades Select Case LCase(Left(Me.Path, 3)) 'ggf. weiter lokale Laufwerke oder Standard verviundene Netzlaufwerke _ ergänzen Case Is = "a:\", "b:\", "d:\", "e:\", "f:\", "g:\", "y:" MsgBox "Diese Datei darf nicht von diesem Laufwerk " _ & Left(Me.Path, 3) & "gestartet werden!" & vbLf & vbLf _ & "Datei wird wieder geschlossen!" Me.Close savechanges:=False Case Else 'ermitteln des Speicherpfades If InStr(Me.Path, "\\") > 0 Then strPfad = LCase(Mid(Me.Path, InStr(Me.Path, "\\") + 1)) Else strPfad = LCase(Mid(Me.Path, InStr(Me.Path, ":\") + 1)) End If 'Prüfen des Speicherpfades If strPfad = LCase("\xxx\xxxx\xxxx") Then 'anpassen !!!! 'Datei wurde zum 1. mal geöffnet aus dem richtigen Verzeichnis Else MsgBox "Diese Datei wurde nicht vom korrekten Speicherort " & _ "aus gestartet!" & vbLf & vbLf _ & "Datei wird wieder geschlossen!" Me.Close savechanges:=False End If End Select Else 'Datei wurde schon mal gespeichert End If End Sub

Beliebteste Forumthreads (12 Monate)

Datei nur von bestimmten Speicherort starten

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread