'--------------------------------------------------------------------------------------------
' Reparer par duplication ver 1.2
' Auteur : IDEOVA\vodiem - 14 janvier 2012
'--------------------------------------------------------------------------------------------
Dim VBSPathDst
Dim oFSO
Dim Contenu()
Dim accfile

Set WshShell = WScript.CreateObject("WScript.Shell")
Set oFSO = CreateObject("Scripting.FileSystemObject")

If WScript.Arguments.Count <> 0 Then
	accfile = WScript.Arguments.Item(0)
	
	Set re = New RegExp
	re.IgnoreCase = True
	re.Pattern = "((mdb)|(accdb))$"
	Set matches = re.Execute(accfile)
	If matches.Count > 0 Then
		Execute(matches(0))
		MsgBox "Duplication terminée."
	End If
Else
	Set WshProcessEnv = WshShell.Environment("Process")
	VBSPathSrc = WScript.ScriptFullName
	VBSPathDst = WshProcessEnv("ProgramFiles") & "\IDEOVA"
	If Not oFSO.FolderExists(VBSPathDst) Then oFSO.CreateFolder VBSPathDst
	VBSPathDst = WshProcessEnv("ProgramFiles") & "\IDEOVA\VBS"
	If Not oFSO.FolderExists(VBSPathDst) Then oFSO.CreateFolder VBSPathDst
	oFSO.CopyFile VBSPathSrc, VBSPathDst & "\", true

	AddTo "mdb"
	AddTo "accdb"

	MsgBox "Installation terminée."
End If

Sub Execute(fileExtension)
	accfilesrc = oFSO.BuildPath(oFSO.GetParentFolderName(accfile),oFSO.GetBaseName(accfile) & " - Sauvegarde" & "." & oFSO.GetExtensionName(accfile))
	If oFSO.FileExists(accfilesrc) Then oFSO.DeleteFile(accfilesrc)
	oFSO.MoveFile accfile, accfilesrc

	assoc = WshShell.RegRead ("HKCR\." & fileExtension & "\")
	clsid = WshShell.RegRead ("HKCR\" & assoc & "\CLSID\")
	progid = WshShell.RegRead ("HKCR\CLSID\" & clsid & "\ProgID\")
	
	Set Dst = CreateObject(progid)
	Dst.NewCurrentDatabase accfile
	Dst.CloseCurrentDatabase
	Dst.Quit

	Set Src = CreateObject(progid)
	Src.OpenCurrentDatabase (accfilesrc)

	On Error Resume Next
	AddContentDB Src.CurrentData.AllDatabaseDiagrams
	AddContentDB Src.CurrentData.AllFunctions
	AddContentDB Src.CurrentData.AllQueries
	AddContentDB Src.CurrentData.AllStoredProcedures
	AddContentDB Src.CurrentData.AllTables
	AddContentDB Src.CurrentData.AllViews
	AddContent Src, "Forms", 2
	AddContent Src, "Modules", 5
	AddContent Src, "Reports", 3
	AddContent Src, "Scripts", 4
	On Error GoTo 0

	On Error Resume Next
	For i = 1 To UBound(Contenu, 2)
		If Left(Contenu(1, i), 4) <> "MSys" Then
			Src.Application.DoCmd.TransferDatabase 1, "Microsoft Access", accfile, Contenu(2, i), Contenu(1, i), Contenu(1, i), False
			If Err<>0 then MsgBox Err.Description, vbOkOnly, "Erreur avec : " & Contenu(1,i) : Err.Clear
		End If
	Next
	On Error GoTo 0

	Src.CloseCurrentDatabase
	Src.Quit
End Sub

Sub AddContentDB(o)
For Each e In o
    On Error Resume Next
    ReDim Preserve Contenu(2, UBound(Contenu, 2) + 1)
    If Err <> 0 Then ReDim Contenu(2, 1): Err.Clear
    On Error GoTo 0
    Contenu(1, UBound(Contenu, 2)) = e.Name: Contenu(2, UBound(Contenu, 2)) = e.Type
Next
End Sub

Sub AddContent(o, ContentName, acTypeContent)
For i = 0 To o.CurrentDb.Containers.Count - 1
    For j = 0 To o.CurrentDb.Containers(i).Documents.Count - 1
        If (o.CurrentDb.Containers(i).Name = ContentName) Then
            On Error Resume Next
            ReDim Preserve Contenu(2, UBound(Contenu, 2) + 1)
            If Err <> 0 Then ReDim Contenu(2, 1): Err.Clear
            
            Contenu(1, UBound(Contenu, 2)) = o.CurrentDb.Containers(i).Documents(j).Name
            Contenu(2, UBound(Contenu, 2)) = acTypeContent
        End If
    Next
Next
End Sub

Sub AddTo(fileExtension)
	On Error Resume Next
	assoc = WshShell.RegRead ("HKCR\." & fileExtension & "\")
	ftype = WshShell.RegRead ("HKCR\" & assoc & "\shell\Open\command\")

	Set re = New RegExp
	re.IgnoreCase = True
	re.Pattern = "("".*MSACCESS.EXE"")"
	Set matches = re.Execute(ftype)
	If matches.Count > 0 Then
		WshShell.RegWrite "HKCR\" & assoc & "\shell\RepairByDuplication\", "Réparer par duplication", "REG_SZ"
		WshShell.RegWrite "HKCR\" & assoc & "\shell\RepairByDuplication\command\", "wscript.exe """ & VBSPathDst & "\" & WScript.ScriptName & """ ""%1""", "REG_SZ"
	Else
		MsgBox "Extension Access non trouvé : """ & fileExtension & """"
	End If
End Sub