' CompactDatabase komprimiert die Datenbank, deren Dateipfad als Parameter angegeben ist.
' Leider ist die verwendete Methode CompactDatabase der DAO.DBEngine nicht sehr effektiv.
' Mit der Funktion in Microsoft Access bekommt man bessere Ergebnisse. Deshalb wird vorher
' versucht, die Komprimierung mit Bordmitteln von Access, der Methode CompactRepair
' durchzuführen. Wenn Access nicht installiert ist, wird dann halt DAO benutzt.

' Copyright ©2004 Carstens & Co. GmbH Informationsmanagement
' CompactDatabase-Version 1.0.1, Build 3 vom 25.02.2005

' Lizenz:
' This program is free software; you can redistribute it and/or modify it under the terms
' of the GNU General Public License as published by the Free Software Foundation; either
' version 2 of the License, or (at your option) any later version.
' See: http://www.gnu.org/licenses/gpl.html

' Kontakt:
' Carstens & Co. GmbH Informationsmanagement
' Jacobistraße 21
' 01309 Dresden
' Germany
' Tel: +49 (351) 3156980
' WWW: http://www.carstens-informationsmanagement.de
' E-Mail: info@carstens-informationsmanagement.de

Const messageTitle = "Compact Database"

doCompactDatabseMain

Sub doCompactDatabseMain()
Dim strOrgDb, strTempDb, comDlgObj, comDlg
On Error Resume Next
	If WScript.Arguments.Count = 1 Then
		strOrgDb = WScript.Arguments(0)
		strTempDb = strOrgDb & "~temp~"
		doCompactWithAccess strOrgDb, strTempDb
	ElseIf WScript.Interactive Then
		comDlgObj = "MSComDlg.CommonDialog"
		Set comDlg = CreateObject(comDlgObj)
		If Err < 0 Then
			Err.Clear
			' Das Objekt MSComDlg.CommonDialog kann unter WinXP nicht erstellt werden, daher noch eine Alternative
			comDlgObj = "UserAccounts.CommonDialog"
			Set comDlg = CreateObject(comDlgObj)
		End If
		If Err = 0 Then
			comDlg.Flags = OFN_EXPLORER Or OFN_LONGNAMES Or OFN_FILEMUSTEXIST Or OFN_NOREADONLYRETURN
			comDlg.MaxFileSize = 260
			comDlg.InitDir = ""
			comDlg.Filter = "Access-Datenbanken|*.mdb"
			comDlg.DialogTitle = "Zu komprimierende Datenbank &ouml;ffnen"
			comDlg.CancelError = True
			Err.Clear
			comDlg.ShowOpen
			If (Err = 0) And (comDlg.FileName > "") Then
				strOrgDb = comDlg.FileName
				strTempDb = strOrgDb & "~temp~"
				doCompactWithAccess strOrgDb, strTempDb
			ElseIf Not ((Err = 0) Or (Err = 32755)) Then ' Fehler 32755 wird ausgel&ouml;st, wenn der Benutzer den Dateidialog abbricht.
				WScript.Echo "Beim Öffnen des Dateidialogs ist ein Fehler aufgetreten!" & vbNewLine & "Fehler " & Err.Number & ": " & Err.Description
			End If
			Set comDlg = Nothing
		Else
			WScript.Echo "Kann ActiveX-Objekt '" & comDlgObj & "' nicht erstellen!" & vbNewLine & "Fehler " & Err.Number & ": " & Err.Description
		End If
	Else
		WScript.Echo "CompactDatabase.vbe <Datenbankdateipfad>. Der Parameter fehlt!"
	End If
End Sub

Sub doCompactWithAccess(strOrgDb, strTempDb)
Dim DBengine, strVersionTest
On Error Resume Next
	WScript.Echo "Versuche Komprimierung mit installiertem Microsoft Access!"
	Set DBengine = CreateObject("Access.Application")
	If Err = 0 Then
		strVersionTest = DBengine.Version
		If Err = 0 Then
			DBengine.CompactRepair strOrgDb, strTempDb, True
			If Err = 0 Then
				doOverwriteDatabaseFile strOrgDb, strTempDb
			Else
				WScript.Echo "Kann Datenbank '" & strOrgDb & "' nicht in Datenbank '" & strTempDb & "' komprimieren!" & vbNewLine & "Fehler " & Err.Number & ": " & Err.Description
			End If
		Else
			WScript.Echo "Das ActiveX-Objekt 'Access.Application' hat eine &auml;ltere Version als Microsoft Access 2002 benutzt!" & vbNewLine & "Fehler " & Err.Number & ": " & Err.Description
			doCompactWithDAO strOrgDb, strTempDb
		End If
		DBEngine.Quit
		Set DBEngine = Nothing
	Else
		WScript.Echo "Kann ActiveX-Objekt 'Access.Application' nicht erstellen!" & vbNewLine & "Fehler " & Err.Number & ": " & Err.Description
		doCompactWithDAO strOrgDb, strTempDb
	End If
End Sub

Sub doCompactWithDAO(strOrgDb, strTempDb)
Dim DBengine
On Error Resume Next
	WScript.Echo "Versuche Komprimierung mit DAO Database Engine!"
	Set DBengine = CreateObject("DAO.DBEngine.36")
	If Err = 0 Then
		DBengine.CompactDatabase strOrgDb, strTempDb
		If Err = 0 Then
			doOverwriteDatabaseFile strOrgDb, strTempDb
		Else
			WScript.Echo "Kann Datenbank '" & strOrgDb & "' nicht in Datenbank '" & strTempDb & "' komprimieren!" & vbNewLine & "Fehler " & Err.Number & ": " & Err.Description
		End If
		Set DBEngine = Nothing
	Else
		WScript.Echo "Kann ActiveX-Objekt 'DAO.DBEngine.36' nicht erstellen!" & vbNewLine & "Fehler " & Err.Number & ": " & Err.Description
	End If
End Sub

Sub doOverwriteDatabaseFile(strOrgDb, strTempDb)
Dim FSO
On Error Resume Next
	Set FSO = CreateObject("Scripting.FileSystemObject")
	If Err = 0 Then
		FSO.DeleteFile strOrgDb
		If Err = 0 Then
			FSO.MoveFile strTempDb, strOrgDb
			If Err = 0 Then
				WScript.Echo "Datenbank '" & strOrgDb & "' erfolgreich komprimiert."
			Else
				WScript.Echo "Kann Datenbank '" & strTempDb & "' nicht in Datenbank '" & strOrgDb & "' umbenennen!" & vbNewLine & "Fehler " & Err.Number & ": " & Err.Description
			End If
		Else
			WScript.Echo "Kann Datenbank '" & strOrgDb & "' nicht l&ouml;schen!" & vbNewLine & "Fehler " & Err.Number & ": " & Err.Description
		End If
		Set FSO = Nothing
	Else
		WScript.Echo "Kann ActiveX-Objekt 'Scripting.FileSystemObject' nicht erstellen!" & vbNewLine & "Fehler " & Err.Number & ": " & Err.Description
	End If
End Sub