'--------------------------------------------------------------------------------------------
' Ajuster les increments auto ver 1.1
' Auteur : IDEOVA\vodiem - 16 janvier 2012
'--------------------------------------------------------------------------------------------
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 "Ajustement terminé."
	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)
	assoc = WshShell.RegRead ("HKCR\." & fileExtension & "\")
	clsid = WshShell.RegRead ("HKCR\" & assoc & "\CLSID\")
	progid = WshShell.RegRead ("HKCR\CLSID\" & clsid & "\ProgID\")

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

	'sauvegarde
	accfilesrc = oFSO.BuildPath(oFSO.GetParentFolderName(accfile), oFSO.GetBaseName(accfile) & " - Sauvegarde" & "." & oFSO.GetExtensionName(accfile))
	oFSO.CopyFile accfile, accfilesrc, True

	'delete relations
	For Each r In Src.CurrentDb.Relations: Src.CurrentDb.Relations.Delete r.Name: Next

	'adjust numauto
	On Error Resume Next
	For Each t In Src.CurrentDb.TableDefs
		For Each c In t.Fields
			If (Left(t.Name, 4) <> "MSys") And (Left(t.Name, 1) <> "~") And (c.Type = 4) And (c.Attributes = 17) Then
				Debug.Print "Table : " & t.Name & " Colonne : " & c.Name & " Type: " & c.Type
				max = Src.DMax(c.Name, t.Name)
				if isnull(max) then max=0
				max = max+ 1
				Src.DoCmd.RunSQL "ALTER TABLE [" & t.Name & "] ALTER COLUMN [" & c.Name & "] COUNTER(" & max & ",1)"
				If Err.Number <> 438 Then
					MsgBox "Erreur " & Err & " s'est produite sur la table :" & vbCrLf & t.Name & vbCrLf & _
						"l'ajustement de l'auto incrément du champ :" & vbCrLf & c.Name & vbCrLf & _
						"n'a pas pu être effectué"
					Err.Clear
				end if
			End If
		Next
	Next
	On Error GoTo 0

	'restore relations
	Set Svg = CreateObject(progid)
	Svg.OpenCurrentDatabase (accfilesrc)

	ErrRel = False
	On Error Resume Next
	For Each r In Svg.CurrentDb.Relations
		Set rel = Src.CurrentDb.CreateRelation(r.Name, r.Table, r.ForeignTable, r.Attributes)
		For Each fld In r.Fields
			rel.Fields.Append rel.CreateField(fld.Name)
			rel.Fields(fld.Name).ForeignName = r.Fields(fld.Name).ForeignName
		Next
		Src.CurrentDb.Relations.Append rel
		If Err <> 0 Then ErrRel = True: Err.Clear
	Next
	On Error GoTo 0
	If ErrRel Then MsgBox "Une erreur s'est produite lors du rétablissement des relations"

	'exit
	Svg.CloseCurrentDatabase
	Svg.Quit
	Src.CloseCurrentDatabase
	Src.Quit
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\AdjustNumauto\", "Ajuster les incréments auto", "REG_SZ"
		WshShell.RegWrite "HKCR\" & assoc & "\shell\AdjustNumauto\command\", "wscript.exe """ & VBSPathDst & "\" & WScript.ScriptName & """ ""%1""", "REG_SZ"
	Else
		MsgBox "Extension Access non trouvé : """ & fileExtension & """"
	End If
End Sub