VBA Tipp: Vertrauenswürdigen Speicherort einrichten

Aus DBWiki
Wechseln zu: Navigation, Suche

Vorbemerkung

Wenn (ab Access 2007) eine Datenbank zum ersten Mal geöffnet wird, wird eine Statusleiste mit einer Sicherheitswarnung und der Aufforderung, den Inhalt zu aktivieren, eingeblendet. Nach dem Ausführen des Aktivierungsvorgangs wird nur die aktuelle Datenbank je nach Access-Version einmalig oder dauerhaft aktiviert. Auch wird diese Sicherheitsmeldung erneut angezeigt, sobald eine neue Kopie dieser Datenbank an dieser Stelle eingefügt wird, oder die Datenbank umbenannt wird, oder eine andere Datenbank an diese Stelle kopiert wird. Um diese für den Benutzer störende Meldung in Zukunft zu vermeiden, kann das aktuelle Datenbankverzeichnis in den Access-Optionen als Vertrauenswürdiger Speicherort definiert werden.

Anforderung

Ich möchte einen Vertrauenswürdigen Speicherort per VBA einrichten.

Lösung

Das geht mit folgender Sub-Prozedur, die in einem allgemeinen (globalen) Modul gespeichert wird. Die Prozedur verwendet die WMI (Windows Management Instrumentation).

Public Sub VertrauenswürdigenSpeicherortEinrichten( _
           PfadSpeicherort As String, _
           Optional UnterordnerEinbeziehen As Boolean, _
           Optional Beschreibung As String, _
           Optional ImNetzwerkZulassen As Boolean)
 
 ' Late Binding: Kein Verweis auf 'Microsoft WMI Scripting V1.2 Library' notwendig
 ' Quelle: http://www.dbwiki.net/
 
 Dim objReg               As Object  ' WbemScripting.SWbemObject
 Dim strComputer          As String
 Dim strBasisschlüssel    As String
 Dim arrUnterschlüssel    As Variant
 Dim varUnterschlüssel    As Variant
 Dim strSchlüsselwert     As String
 Dim lngret               As Long
 Dim bolexistiert         As Boolean
 Dim lngNum               As Long
 
 ' Ggf Backslash hinzufügen
 If Not Right(PfadSpeicherort, 1) = "\" Then
   PfadSpeicherort = PfadSpeicherort & "\"
 End If
 
 ' Konstante für HKEY_CURRENT_USER
 Const HKCU = &H80000001
 
 strComputer = "."
 Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
                        strComputer & "\root\default:StdRegProv")
 
 ' Basisschlüssel (incl. Access-Version)
 strBasisschlüssel = "Software\Microsoft\Office\" & _
                     Application.Version & _
                     "\Access\Security\Trusted Locations\"
 
 ' Alle Unterschlüssel in Array einlesen
 lngret = objReg.EnumKey(HKCU, strBasisschlüssel, arrUnterschlüssel)
 
 ' Wenn der Basisschlüssel nicht existiert
 If lngret Then Exit Sub
 
 ' Wenn mindestens 1 Unterschlüssel gefunden wurde
 If IsArray(arrUnterschlüssel) Then
 
   For Each varUnterschlüssel In arrUnterschlüssel
 
     ' Wert von "Path" auslesen
     lngret = objReg.GetStringValue(HKCU, strBasisschlüssel & varUnterschlüssel, _
                                    "Path", strSchlüsselwert)
 
     ' Nächste freie lfd. Nummer für neuen Schlüsselnamen ermitteln
     If varUnterschlüssel = "Location" & lngNum Then
       lngNum = lngNum + 1
     End If
 
     ' Wenn der gewünschte Vertrauenswürdige Speicherort bereits existiert
     If strSchlüsselwert = PfadSpeicherort Then
       bolexistiert = True
       Exit Sub
     End If
 
   Next varUnterschlüssel
 
 End If
 
 ' Wenn der Vertrauenswürdige Speicherort noch nicht existiert
 If bolexistiert = False Then
 
   ' Basisschlüssel:
   ' Wert setzen: Vertrauenswürdige Speicherorte im Netzwerk zulassen (REG_DWORD)
   If ImNetzwerkZulassen Then
     Call objReg.SetDWORDValue(HKCU, strBasisschlüssel, "AllowNetworkLocations", 1)
   Else
     Call objReg.SetDWORDValue(HKCU, strBasisschlüssel, "AllowNetworkLocations", 0)
   End If
 
   ' Unterschlüssel:
   ' Anlegen
   Call objReg.CreateKey(HKCU, strBasisschlüssel & "Location" & CStr(lngNum))
 
   ' Wert setzen: Unterordner einbeziehen (REG_DWORD)
   If UnterordnerEinbeziehen Then
     Call objReg.SetDWORDValue(HKCU, strBasisschlüssel & "Location" & CStr(lngNum), _
                               "AllowSubfolders", 1)
   Else
     Call objReg.SetDWORDValue(HKCU, strBasisschlüssel & "Location" & CStr(lngNum), _
                               "AllowSubfolders", 0)
   End If
 
   ' Wert setzen: Datum (REG_SZ)
   Call objReg.SetStringValue(HKCU, strBasisschlüssel & "Location" & CStr(lngNum), _
                              "Date", Format(Now(), "dd.mm.yyyy hh:nn"))
 
   ' Wert setzen: Beschreibung (REG_SZ)
   Call objReg.SetStringValue(HKCU, strBasisschlüssel & "Location" & CStr(lngNum), _
                              "Description", Beschreibung)
 
   ' Wert setzen: Pfad (REG_SZ)
   Call objReg.SetStringValue(HKCU, strBasisschlüssel & "Location" & CStr(lngNum), _
                              "Path", PfadSpeicherort)
 
 End If
 
End Sub

Aufruf

In den meisten Fällen soll ein Vertrauenswürdiger Speicherort per VBA für eine aktuell (noch) nicht aktivierte Datenbank eingerichtet werden. Da aber in einer nicht aktivierten Datenbank kein VBA-Code ausgeführt werden kann, muss der Benutzer dazu aufgefordert werden, den Aktivierungsvorgang einmalig durchzuführen.


Als mögliche Lösung kann dem aktuell verwendeten Startformular der Datenbank (Name z.B. frmStart) ein weiteres Formular (Name z.B. frmErststart) "vorgeschaltet", und dieses dann als Startformular in den Access-Optionen eingestellt werden. Das Formular frmErststart erledigt dann Beim Öffnen das Einrichten des Vertrauenswürdigen Speicherorts, öffnet anschließend das eigentliche Startformular frmStart für den Benutzer und schließt sich zum Schluß selbst.

Aufbau des Formulars frmErststart:

  • Kleines Popup-Formular
  • mit einem Bezeichnungsfeld mit folgender oder ähnlicher Beschriftung (evtl. in roter Textfarbe):
 Die Datenbank wurde an diesem Speicherort noch nicht aktiviert. 
  Bitte "Alle Makros anhalten" anklicken und 
  Bitte "Inhalt aktivieren" anklicken, 
 um die Datenbank zu aktivieren.
Die Meldung Alle Makros anhalten erscheint nur, wenn ein autoexec-Makro existiert.
  • In das Formular-Ereignis "Beim Öffnen" wird dann folgender Code eingefügt:
Private Sub Form_Open(Cancel As Integer)
 
 ' Beim Öffnen von Formular "frmErststart"
 
 Dim strPfad As String
 
 ' Vertrauenswürdigen Speicherort einrichten
 strPfad = CurrentProject.Path
 ' oder strPfad = "\\Ein Servername\Users\Ein Computername"
 Call VertrauenswürdigenSpeicherortEinrichten(strPfad, True)
 
 ' Offizielles Startformular "frmStart" öffnen
 DoCmd.OpenForm "frmStart"
 
 ' Formular "frmErststart" schließen
 DoCmd.Close acForm, "frmErststart"
 
End Sub

Für den Programmierer der Datenbank (Arbeiten im Entwurfsmodus) ist die Einrichtung eines zusätzlichen Vertrauenswürdigen Speicherorts zu empfehlen:

 ' Vertrauenswürdigen Speicherort für den Programmierer einrichten
 strPfad = SysCmd(acSysCmdAccessDir)
 Call VertrauenswürdigenSpeicherortEinrichten(strPfad, True, "Nur für Programmierzwecke")

Weblinks