Passwortgeschützte Datenbank auslesen?

Hallo Leute,
ich habe da eine Frage. Über nachfolgende Makros lese ich Datenbankdaten aus oder übertrage Daten in die DB.
Option Explicit
Option Private Module
Public LgLastRow As Long
Public xDate1 As String
Public xDate2 As String
Public Verbindung_DB As ADODB.Connection
Public cmd As ADODB.Command
Public rs As New ADODB.Recordset
Public catDB As New ADOX.Catalog
Public riStartnummer As ADODB.Recordset
Public j As Integer
Public i As Integer
Public db_Path As String
Public sqlText As String
Public iStartnummer As String
Public iStartnummer1 As Range
Public iStartnummer2 As Range
Public s2 As String
Public s3 As String
Public s4 As String
Public s5 As String
Public ok As Boolean
Public vw As Object
Public ok1 As Boolean
Public ok2 As Boolean
Public iTabelle As Integer
Public xTyp As Boolean
Public Const db_MDB = "AnReSo_Angebots_DB.mdb"
'Tabellenname in der Datenbank festlegen
Public Const mdb_Angebote = "Angebotsdaten"
'Tabellenname in der Exceldatei festlegen
'Public Const xls_Teilnehmer = "Angebotsdaten"
Public Export_läuft As Boolean
Const db_View_dummy = "Angebotsdaten"


Sub ExportToAccess_Angebotsdaten()
60  Modulname = "ExportToAccess_Angebotsdaten"
61  On Error GoTo ERRORHANDLER
'alle Datensätze in der Exceltabelle, die in der Spalte 'A' mit blauer _
Schrift formatiert sind, werden in die Access-DB zurückgeschrieben
'mit dem Save-Button wird diese Formatierung erzeugt _
'Nach dem Zurückschreiben in die Access-DB wird die schriftfarbe wieder auf schwarz gesetzt
Export_läuft = True
'Wenn keine Teilnehmerdaten vorhanden, Prozedur beenden
If Angebotsdaten.Range("A2") = "" Then Exit Sub
'bestimmte Applications-Eigenschaften abschalten, damit es schneller geht
69  GetMoreSpeed True
'Alle Daten in Datenbanktabelle löschen, extra Makro
72  'DeleteToAccess_Teilnehmer
74  LgLastRow = Angebotsdaten.Range("A65536").End(xlUp).Row
'Schriftfarbe der Spalte A auf blau umstellen
77  'Sheets(xls_Teilnehmer).Range("A2:A" & LgLastRow).Font.ColorIndex = 5
79  db_Path = Tabelle_Hilfstabelle.Range("B21")
'Tabellenbereich in der Exceltabelle'
82  Set iStartnummer1 = Angebotsdaten.Range("A2:A" & LgLastRow)
''Verbindung zur DB
84  Set Verbindung_DB = New ADODB.Connection
85  Verbindung_DB.Open "Provider =Microsoft.Jet.OLEDB.4.0; Data Source = " & db_Path & db_MDB &  _
87  rs.Open mdb_Angebote, Verbindung_DB, CursorType:=adOpenKeyset, LockType:=adLockOptimistic
89  For Each iStartnummer2 In iStartnummer1
'Erkennungszeichen für 1 gespeicherten DS in der Exceltabelle
91  If iStartnummer2.Font.ColorIndex = 5 Then 'blaue Schrift
92  iStartnummer = iStartnummer2.Value
'Suchvariable konfigurieren
95  iStartnummer = "[Angebotsnummer] = " & iStartnummer
'MsgBox iStartnummer
'Suchen in der Accesstabelle
99  rs.Find iStartnummer
101 If (rs.BOF Or rs.EOF) Then
'DS nicht gefunden
104 rs.AddNew
105 ok = True
106 Else
107 ok = False
108 End If
'Daten nach Access übertragen
'If iTabelle = 1 Then Call Teilnehmer_in_Access_übertragen(Rs, iStartnummer2, ok)
'If iTabelle = 2 Then Call Vereine_in_Access_übertragen(Rs, iStartnummer2, ok)
112 Call Angebotsdaten_in_Access_übertragen(rs, iStartnummer2, ok)
113 rs.Update
114 End If
115 Next iStartnummer2
'alle Objekte-Variablen schließen bzw. Zeiger entfernen
117 rs.Close
118 Set rs = Nothing
120 Set cmd = Nothing
121 Verbindung_DB.Close
122 Set Verbindung_DB = Nothing
'Farbe Spalte "A" in Exceltabelle auf 'schwarz setzen
125 iStartnummer1.Font.ColorIndex = 0
127 Set iStartnummer1 = Nothing
'Next iTabelle
129 GetMoreSpeed False
'Variable auf False setzen, wird benötigt um beim Schließen festzustellen, dass eine _
Änderung an Datei durchgeführt wurde.
Export_läuft = False
'Prozedur beenden
137 Exit Sub
'Dieser Bereich wird abgearbeitet, sollte ein Fehler in Code auftretetn. Dann erscheint  _
eine Bildschirmmeldung
ERRORHANDLER:
142 Fehlerzeile = Erl
143 Fehlerort = "Modul_Im_und_Export_Access"
144 Fehlerereignis = Modulname
145 Logdatei_erzeugen
End Sub

'#############################################################################################################


Sub ImportFromACCESS_Angebotsdaten()
151 Modulname = "ImportFromACCESS_Angebotsdaten"
152 On Error GoTo ERRORHANDLER
''folgende Vba-Verweise müssen gesetzt sein:
''Microsoft ActiveX Data Object 2.x Library (wegen ADODB)
''Microsoft ADO Ext. 2.x for Dll and Security (wegen ADOX)
'Variable auf True setzen, wird benötigt um beim Schließen festzustellen, dass eine _
Änderung an Datei durchgeführt wurde.
162 xTyp = True
163 LgLastRow = Angebotsdaten.Range("A65536").End(xlUp).Row
'alles korrekt bzw. beide Datunsfelder sind leer dann kann es weitergehen
'bestimmte Applications-Eigenschaften abschalten, damit es schneller geht
169 GetMoreSpeed True
171 Angebotsdaten.Cells.ClearContents
'Pfad, in der sich die Exceldatei befindet, _
hier muß z.Z. auch die Access-Datei sein
175 db_Path = Tabelle_Hilfstabelle.Range("B21")
'diese nachfolgende Abfrage wird per ADOX von Excel aus in der Access-DB erstellt und _
mit dem Quelltext gefüllt, der sonst von Ecxel aus gestartet wird
'Hintergrund: Da MS-Access 1 Standalone-DB ist, liefert Access/ADODB immer alle passenden  _
Datensätze _
zurück, ohne die in der Abfrage definierte Where-Klauselauszuwerten! _
Das muß dann Excel machen. Damit Access auch die Where-Klausel berücksichtigt, _
wird der SQL-Quelltext direkt in die Access-Abfrage geschrieben (per ADOX) und _
Excel ruft dann diese Access-Abfrage auf.
''Verbindung zur DB
190 Set Verbindung_DB = New ADODB.Connection
191 Verbindung_DB.Open "Provider =Microsoft.Jet.OLEDB.4.0; Data Source = " & db_Path & db_MDB &  _
''Abfrage1 mit geändertem Quelltext öffnen
194 s5 = "Select * From " & db_View_dummy & ";"
195 rs.Open s5, Verbindung_DB, CursorType:=adOpenForwardOnly, LockType:=adLockReadOnly
197 If (rs.EOF Or (Err.Number > 0)) Then
198 If Err.Number > 0 Then
MsgBox "Es ist ein Fehler aufgetreten" & vbCrLf & vbCrLf & _
Err.Description, 16, "Fehler-Nr. " & Err.Number
201 Else
''Recordset ist leer
MsgBox "keine DS gefunden im Bereich:" & vbCrLf & vbCrLf & _
iStartnummer & IIf(""  s2, " bis " & s2, "")
205 End If
206 Else
207 j = 2 ' in Zeile 2 beginnen
'Blatt "Angebotsdaten"
208 With Angebotsdaten
209 .Range("A2:A" & LgLastRow).Font.ColorIndex = 0
210 If xTyp Then
'1. bis 17. Spalte des Recordsets
212 For i = 0 To 68
'Feldnamen des RecordSets als Überchriften schreiben
214 .Cells(j - 1, i + 1).Value = rs.Fields(i).Name
215 Next i
216 End If
''Alles aus dem Recordset schreiben
219 .Cells(j, 1).CopyFromRecordset rs
221 End With
222 End If
''alle Objekte-Variablen schließen bzw. Zeiger entfernen
225 rs.Close
226 Set rs = Nothing
228 Set cmd = Nothing
229 Set catDB = Nothing
230 Verbindung_DB.Close
231 Set Verbindung_DB = Nothing
'Teilnehmertabelle nach Angebotsnummer sortieren
234 Angebotsdaten.Cells.Sort Key1:=Angebotsdaten.Range("A2"), Order1:=xlAscending, Header:= _
xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
238 GetMoreSpeed False
'Prozedur beenden
242 Exit Sub
'Dieser Bereich wird abgearbeitet, sollte ein Fehler in Code auftretetn. Dann erscheint  _
eine Bildschirmmeldung
ERRORHANDLER:
247 Fehlerzeile = Erl
248 Fehlerort = "Modul_Im_und_Export_Access"
249 Fehlerereignis = Modulname
250 Logdatei_erzeugen
End Sub

'#############################################################################################################


Sub DeleteToAccess_Angebotsdaten()
256 Modulname = "DeleteToAccess_Angebotsdaten"
257 On Error GoTo ERRORHANDLER
259 db_Path = Tabelle_Hilfstabelle.Range("B21")
' open the database
262 Set Verbindung_DB = New ADODB.Connection
263 Verbindung_DB.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & db_Path & db_MDB & ";" _
264 Set rs = New ADODB.Recordset
265 rs.Open mdb_Angebote, Verbindung_DB, adOpenStatic, adLockOptimistic, adCmdTable
267 While Not rs.EOF
268 rs.MoveFirst
269 rs.Delete
270 rs.MoveFirst
271 Wend
273 rs.Close
274 Set rs = Nothing
275 Verbindung_DB.Close
276 Set Verbindung_DB = Nothing
'Prozedur beenden
280 Exit Sub
'Dieser Bereich wird abgearbeitet, sollte ein Fehler in Code auftretetn. Dann erscheint  _
eine Bildschirmmeldung
ERRORHANDLER:
285 Fehlerzeile = Erl
286 Fehlerort = "Modul_Im_und_Export_Access"
287 Fehlerereignis = Modulname
288 Logdatei_erzeugen
End Sub

'#############################################################################################################


Function setChr34(xTyp As String)
'übergebenen String in Anführungsstriche setzen
294 setChr34 = Chr(34) & xTyp & Chr(34)
295 End Function

'#############################################################################################################


Sub Angebotsdaten_in_Access_übertragen(xRS As ADODB.Recordset, xRg As Range, xOk As Boolean)
299 Modulname = "Angebotsdaten_in_Access_übertragen"
300 On Error GoTo ERRORHANDLER
302 With xRS
303 If xOk Then
304 xRS.Fields("Angebotsnummer").Value = xRg.Offset(0, 0).Value
305 End If
306 .Fields("Anrede").Value = xRg.Offset(0, 1).Value
307 .Fields("Name").Value = xRg.Offset(0, 2).Value
308 .Fields("Strasse").Value = xRg.Offset(0, 3).Value
.Fields("Plz").Value = xRg.Offset(0, 4).Value
.Fields("Ort").Value = xRg.Offset(0, 5).Value
.Fields("Bearbeiter").Value = xRg.Offset(0, 6).Value
345 End With
'Prozedur beenden
349 Exit Sub
'Dieser Bereich wird abgearbeitet, sollte ein Fehler in Code auftretetn. Dann erscheint  _
eine Bildschirmmeldung
ERRORHANDLER:
354 Fehlerzeile = Erl
355 Fehlerort = "Modul_Im_und_Export_Access"
356 Fehlerereignis = Modulname
357 Logdatei_erzeugen
End Sub

'#############################################################################################################


Sub ExportToAccess_Zeile_löschen()
Modulname = "ExportToAccess_Zeile_löschen"
On Error GoTo ERRORHANDLER
'alle Datensätze in der Exceltabelle, die in der Spalte 'A' mit blauer _
Schrift formatiert sind, werden in die Access-DB zurückgeschrieben
'mit dem Save-Button wird diese Formatierung erzeugt _
'Nach dem Zurückschreiben in die Access-DB wird die schriftfarbe wieder auf schwarz gesetzt
Export_läuft = True
'Wenn keine Teilnehmerdaten vorhanden, Prozedur beenden
If Angebotsdaten.Range("A2") = "" Then Exit Sub
'bestimmte Applications-Eigenschaften abschalten, damit es schneller geht
GetMoreSpeed True
'Alle Daten in Datenbanktabelle löschen, extra Makro
'DeleteToAccess_Teilnehmer
LgLastRow = Angebotsdaten.Range("A65536").End(xlUp).Row
'Schriftfarbe der Spalte A auf blau umstellen
'Sheets(xls_Teilnehmer).Range("A2:A" & LgLastRow).Font.ColorIndex = 5
db_Path = Tabelle_Hilfstabelle.Range("B21")
'Tabellenbereich in der Exceltabelle'
Set iStartnummer1 = Angebotsdaten.Range("A2:A" & LgLastRow)
''Verbindung zur DB
Set Verbindung_DB = New ADODB.Connection
Verbindung_DB.Open "Provider =Microsoft.Jet.OLEDB.4.0; Data Source = " & db_Path & db_MDB &  _
rs.Open mdb_Angebote, Verbindung_DB, CursorType:=adOpenKeyset, LockType:=adLockOptimistic
For Each iStartnummer2 In iStartnummer1
'Erkennungszeichen für 1 gespeicherten DS in der Exceltabelle
If iStartnummer2.Font.ColorIndex = 5 Then 'blaue Schrift
iStartnummer = iStartnummer2.Value
'Suchvariable konfigurieren
iStartnummer = "[Angebotsnummer] = " & iStartnummer
'MsgBox iStartnummer
'Suchen in der Accesstabelle
rs.Find iStartnummer
If (rs.BOF Or rs.EOF) Then
'DS nicht gefunden
'rs.AddNew
ok = True
Else
ok = False
End If
rs.Delete
'Zeile des Datensatzes in Tabellenblatt löschen
Angebotsdaten.Rows(iStartnummer2.Row).Delete
'Call Angebotsdaten_in_Access_übertragen(rs, iStartnummer2, ok)
'rs.Update
End If
Next iStartnummer2
'alle Objekte-Variablen schließen bzw. Zeiger entfernen
rs.Close
Set rs = Nothing
Set cmd = Nothing
Verbindung_DB.Close
Set Verbindung_DB = Nothing
'Farbe Spalte "A" in Exceltabelle auf 'schwarz setzen
iStartnummer1.Font.ColorIndex = 0
Set iStartnummer1 = Nothing
'Next iTabelle
GetMoreSpeed False
'Variable auf False setzen, wird benötigt um beim Schließen festzustellen, dass eine _
Änderung an Datei durchgeführt wurde.
Export_läuft = False
'Prozedur beenden
Exit Sub
'Dieser Bereich wird abgearbeitet, sollte ein Fehler in Code auftretetn. Dann erscheint  _
eine Bildschirmmeldung
ERRORHANDLER:
Fehlerzeile = Erl
Fehlerort = "Modul_Im_und_Export_Access"
Fehlerereignis = Modulname
Logdatei_erzeugen
End Sub

'#############################################################################################################
Nun möchte ich aber, weil sich in der Datenbank auch Daten befinden, die nicht von jedem Mitarbeiter eingesehen werden sollen, die Datenbank mit einem Passwort schützen. Wenn ich dann aber die Makros ausführe, funktionieren die natürlich nicht mehr, wegen des Passwortes. Ich habe in der Zeile
Verbindung_DB.Open "Provider =Microsoft.Jet.OLEDB.4.0; Data Source = " & db_Path & db_MDB & ";", Password:="1234"
hinten das Passwort angehängt, aber leider ohne Erfolg. Kann mir jemand sagen, wie ich das Passwort übergeben kann, so dass ich die Daten in bzw. aus der Datenbank trotz Passwort bekomme?
Danke Euch,
Kasimir

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Kasimir,
mein gesamtes Makro sieht so aus und es funktioniert einwandfrei:

'
'   Achtung der Verweis auf: Microsoft ActiveX Data Objects 2.0 Library
'   oder eine höhere Version (2.1, 2.5) muss aktiviert sein.
'
'   Hier soll eine Access-Datenbank, die passwortgeschützt ist gelesen werden.
'
'   Achtung: Die Namen in Access dürfen keinen Bindestrich, sondern immer
'            den Unterstrich als Text-Trennung enthalten - z. B. PSTLZ_Straße.
'
Sub DBZugriff()
Dim Connect    As Connection  ' die Verbindung zu Access
Dim RecSet     As Recordset   ' der Access RecordSet
Dim SQLString  As String      ' der SQL Befehl
Dim Ziel       As Worksheet   ' Excel-Tabellenblatt
Dim Zeile      As Integer     ' Zeile
Dim Spalte     As Integer     ' Spalte
Dim DBPfad     As String      ' Pfad der Access-Anwendung
Dim DBDatei    As String      ' Name der Access-Datei bzw. DB
Dim DBTab      As String      ' Name der Access-Tabelle
Dim Suchbegr   As String      ' String als Suchbegriff
   DBPfad = "C:\Dokumente und Einstellungen\Administrator\Eigene Dateien\Access-DBs\"
   DBDatei = "SUMPF-MIS.mdb"
   DBTab = "adressen"
   Set Ziel = Worksheets("Tabelle8")   ' Ziel Tabellenblatt in Excel
'  Die Datenbank öffnen
   Set Connect = New ADODB.Connection
   With Connect  ' für Access 2000 und höhere                     '~~~~~~~~~~~~~~~~
      .Provider = "Microsoft.Jet.OLEDB.4.0" + ";Jet OLEDB:Database Password=welcome"
      .ConnectionString = "Data Source=" & DBPfad & DBDatei       '~~~~~~~~~~~~~~~~
      .Open
   End With
'
'  ******************************************************************************
'  im SQL-String definieren was geholt werden soll => hier verschiedene Varianten
'  ******************************************************************************
'
'    hier alles - die komplette Access-Tabelle
   'SQLString = "SELECT Adressen.* FROM Adressen" ' <-- Hier die Datenbanktabelle
   SQLString = "SELECT " & DBTab & _
                ".* FROM " & DBTab & "" ' <-- Hier die Datenbanktabelle
   If SQLString = "" Then
      MsgBox "hier ist der Wurm drin, der SQLString ist leer - Abbruch.", _
         16, "   der SQLString wurde nicht gefüllt."
      Exit Sub
    Else
      'MsgBox SQLString      ' den SQL-String anzeigen
   End If
   Set RecSet = New ADODB.Recordset
   RecSet.Open SQLString, Connect, adOpenDynamic, adLockReadOnly
   Cells.ClearContents    ' den alten Inhalt löschen
   Call Kopf_entfaerben   ' die alten Kopfzeilen entfernen
   Application.ScreenUpdating = False
'  Die Feldnamen der Datenbanktabelle in die erste Zeile des
'           Excel Ziel-Tabellenblattes schreiben
   For Spalte = 0 To RecSet.Fields.Count - 1
      Ziel.Cells(1, Spalte + 1) = RecSet.Fields.Item(Spalte).Name
   Next Spalte
   Call Kopf_farbig(RecSet.Fields.Count) ' die neuen Kopfzeilen farbig, fett
'  Jetzt alle selektierten Sätze holen und in das Excel-Tabellenblatt schreiben
   Zeile = 1
   If RecSet.EOF = False Then  ' kein EOF => es gibt also Daten !
      RecSet.MoveFirst         ' auf dem ersten Datensatz aufsetzen
    Else
      MsgBox "es konnte nichts selektiert werden => Abbruch.", _
         16, "    fehlerhafte Selektion ?"
      Exit Sub
   End If
   Do While RecSet.EOF = False
      Zeile = Zeile + 1
      For Spalte = 0 To RecSet.Fields.Count - 1
         If IsNull(RecSet.Fields.Item(Spalte).Value) = False Then
            Ziel.Cells(Zeile, Spalte + 1) = RecSet.Fields.Item(Spalte).Value
            Ziel.Rows(Zeile & ":" & Zeile).RowHeight = 13.2
         End If
      Next Spalte
      RecSet.MoveNext
   Loop
   Cells.EntireColumn.AutoFit
   [A1].Select
   Application.ScreenUpdating = True
   RecSet.Close
   Connect.Close
End Sub

Gruß Peter

Beliebteste Forumthreads (12 Monate)

Passwortgeschützte Datenbank auslesen?

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