VB 5/6-Tipp 0586: ADO-Datenbanken komprimieren

'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 ADOCompress.vbp  -----------
' Es muss ein Verweis auf 'Microsoft Jet and Replication Objects 2.6 Library' gesetzt werden.
' Die Komponente 'Microsoft Common Dialog Control 6.0 (SP3) (COMDLG32.OCX)' wird benötigt.

'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Rahmensteuerelement "Frame1"
' Steuerelement: Schaltfläche "cmd_compress" auf Frame1
' Steuerelement: Schaltfläche "cmd_auswahl" auf Frame1
' Steuerelement: Textfeld "txt_filename" auf Frame1
' Steuerelement: Beschriftungsfeld "Label1" auf Frame1
' Steuerelement: Standarddialog-Steuerelement "CommonDialog1"
' Steuerelement: Schaltfläche "cmd_Quit"

Option Explicit

Private Sub cmd_auswahl_Click()
  Me.CommonDialog1.Filter = "Datenbanken (*.mdb)|*.mdb"
  Me.CommonDialog1.FilterIndex = 1
  Me.CommonDialog1.DefaultExt = "mdb"
  Me.CommonDialog1.ShowOpen
  Me.txt_filename = CommonDialog1.FileName
End Sub

Private Sub cmd_compress_Click()
  'Für die Verwendung von CompactDatabase mit ADO:
  'Benötigt in den Verweisen:
  'MS Jet and Replikation Objects 2.6 Library,
  'sollte mit allen Access-Versionen gehen.
  
  Dim ADO_JRO As New JRO.JetEngine
  Dim DBOriginal As String
  Dim DBTemp As String
  Dim TMPDB1 As String
  Dim TMPDB2 As String
  
  DBOriginal = Replace(txt_filename.Text, "\\", "\")
  DBTemp = Replace(App.Path & "\Help.mdb", "\\", "\")
  
  MsgBox "Die Datenbank hat eine Grösse von: " & Format(FileLen(DBOriginal), "#,###") & " Byte"
  
  If Dir(DBTemp) <> "" Then
    Kill DBTemp
  End If
  
  TMPDB1 = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source= " & DBOriginal
  TMPDB2 = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source= " & DBTemp
  
  ADO_JRO.CompactDatabase TMPDB1, TMPDB2
  
  Set ADO_JRO = Nothing
  Kill DBOriginal
  FileCopy DBTemp, DBOriginal
  Kill DBTemp
  MsgBox "Die Datenbank hat eine Grösse von: " & Format(FileLen(DBOriginal), "#,###") & " Byte"
End Sub

Private Sub cmd_Quit_Click()
  Unload Me
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'------------ Ende Projektdatei ADOCompress.vbp  ------------

Kommentar von mischarichter am 27.08.2008 um 12:33

mit einer kleinen Änderung geht dann die Öffnung von kennwortgesch. DBs doch:

TMPDB1 = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source= " & DBOriginal & "; Jet OLEDB:Database Password=" & "123"

TMPDB2 = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source= " & DBTemp & "; Jet OLEDB:Database Password=" & "123"


Jedenfalls bei mir mit VB6 und o.g. Provider zu den lokalen MDB-Files.

Mischa

Kommentar von pks am 27.08.2008 um 12:19

es können auch PWD geschützte MDBs comprimiert werden

'Datenbank komprimieren, optional Passwort ändern
'liefert den neuen Namen der ursprünglichen mdb
Public Function CompactMDB(ActConn As ADODB.Connection, _
                        Optional doNotChangePWD As Boolean = True, _
                        Optional NewPWD As String = "", _
                        Optional ErrNumber As Long = 0, _
                        Optional ErrDescription As String = "", _
                        Optional ShowErrorMsg As Boolean = True) _
                        As String

   Dim objJRO As Object
   Dim dbName As String, dbNew As String
   Dim EngineTyp As String
   Dim OldPwd As String, Dummy As String
   Dim Con1 As String, Con2 As String
   Dim i As Long
      
      'DB Name, Passwort und EngineTyp ermitteln
      dbName = ActConn.Properties("Data Source").Value
      OldPwd = ActConn.Properties("Jet OLEDB:Database Password").Value
      EngineTyp = ActConn.Properties("Jet OLEDB:Engine Type").Value
   
      'neues Passwort festlegen
      If doNotChangePWD Then
         NewPWD = OldPwd
      End If
      
      'SaveMDB ermitteln
      dbNew = dbName
      i = InStrRev(dbNew, ".")
      dbNew = Left(dbNew, i - 1) & "_" & _
              Format(Now, "yyyymmdd\_hhnnss") & ".mdb"
      
      'ein Dummy für die Umbenennung
      i = InStrRev(dbName, "\")
      Dummy = Left(dbName, i)
      i = 0
      Do
         If Len(Dir(Dummy & "dummy" & i & ".mdb")) = 0 Then
            Dummy = Dummy & "dummy" & i & ".mdb"
            Exit Do
         End If
         i = i + 1
      Loop
         
      'ConnectionStrings festlegen
      Con1 = "Data Source=" & dbName & ";" & _
             "Jet OLEDB:Database Password=" & OldPwd & ";" & _
             "Jet OLEDB:Engine Type=" & EngineTyp & ";"
   
      Con2 = "Data Source=" & dbNew & ";" & _
             "Jet OLEDB:Database Password=" & NewPWD & ";" & _
             "Jet OLEDB:Engine Type=" & EngineTyp & ";"
   
      On Error Goto Fehler
   
      'Connection schliessen
      ActConn.Close
   
      'Jet-Engine starten
      Set objJRO = CreateObject("JRO.JetEngine")

      'Datenbank komprimieren
      objJRO.CompactDatabase Con1, Con2
   
      'umbenennen
      Name dbName As Dummy
      Name dbNew As dbName
      Name Dummy As dbNew
      CompactMDB = dbNew
      
Fehler:
      If Err.Number <> 0 Then
         ErrNumber = Err.Number
         ErrDescription = Err.Description
         If ShowErrorMsg Then
            FehlerAnzeige Err.Number, Err.Description, "CompactMDB"
         End If
      End If
      On Error Goto 0
      
      'Connection wieder öffnen
      ActConn.Open
End Function


'Anzahl (und Namen/Computer) der aktuelle mdb Nutzer
Public Function CurrentUserCount(ActConn As ADODB.Connection, _
                                     Optional sUser As String = "") As Long

   Dim Rs As ADODB.Recordset
   Dim User As String, Computer As String
   Dim s() As String
   Dim i As Long, j As Long
  
      Set Rs = ActConn.OpenSchema(adSchemaProviderSpecific, , _
               "{947bb102-5d43-11d1-bdbf-00c04fb92675}")
      
      i = Rs.RecordCount
      CurrentUserCount = i
      
      ReDim s(i - 1)
      i = 0
      Do While Not Rs.EOF
         User = Rs.Fields("Login_Name").Value
         j = InStr(1, User, Chr(0))
         If j > 0 Then
            User = Left(User, j - 1)
         End If
         Computer = Rs.Fields("Computer_Name").Value
         j = InStr(1, Computer, Chr(0))
         If j > 0 Then
            Computer = Left(Computer, j - 1)
         End If
         
         s(i) = User & ":" & Computer
         i = i + 1
         Rs.MoveNext
      Loop
      
      sUser = Join(s, ";")
      Rs.Close
      Set Rs = Nothing
End Function

Kommentar von mischarichter am 27.08.2008 um 11:26

der code geht bei password-geschützten DBs nicht.
an ADO_JRO.CompactDatabase TMPDB1, TMPDB2 kann kein pw übergeben werden.

Mischa Richter

Kommentar von Rüdiger Jörder am 10.11.2003 um 16:18

Wie kann ich den Verweis in VB 4.0 voreinstellen. Verweis funktioniert nämlich nur, wenn ich VB 4.0 öffne, den Verweis einstelle und dann das VB-Programm starte.

MfG

Kommentar von Helmut Kubasek am 29.07.2003 um 16:01

Hallo,

ich habe folgendes Problem:
Der Programmcode soll bei Beenden meines Programmes ausgeführt werden, aber ich erhalte die Fehlermeldung, dass auf die Datenbank nicht zugegriffen werden kann, weil sie bereits geöffnet ist. Ich habe allerdings vorher die Datenbank geschlossen[DB.Close].
Was läuft da schief ?

Vielen Dank

Gruß Helmut

Kommentar von Ini am 30.05.2003 um 22:20

Hi

Wie gehe ich vor, wenn meine DB an eine System Database (xy.mdw) gebunden ist.
Die Definition von User ID und Password funktioniert bei mir nicht.

Gruss Ini

Kommentar von pks am 11.05.2003 um 17:40

1. der FileCopy ist überflüssig, ein Umbenennen mit Name reicht völlig aus
2. ich lasse in solchen Fällen das Original aus Sicherheitsgründen noch auf der Platte und benenne es
einfach um wie DBNameyyyymmddhhnnss.mdb und lösche es zu einem späteren Zeitpunkt