Zipper une BD

Bonjour.

il va être très difficile de compresser ta base en cours car elle est en
utilisation. Il te faudra certainement passer par un script ou .bat lancé
par access par Shell. quel que soit le mode utilisé il faudra construire la
commande à lancer qui sera différente selon les logiciels ( winzip, rar
etc...).
pour winzip voir la page : http://www.winzip.com/prodpagecl.htm
pour rar, la doc fournie avec le logiciel inclus les ordres de la command
line.

--
@+
Raymond Access MVP
http://access.seneque.free.fr/
http://access.vba.free.fr/
http://access2003.free.fr/
http://users.skynet.be/mpfa/ pour débuter sur le forum


"Gérard" <anonymous@discussions.microsoft.com> a écrit dans le message de
news:8e0101c485ef$daad3980$a501280a@phx.gbl...
J'aimerais créer une SUB qui "Zippe" ma base de donnée.

Pouvez-vous m'aider?

Merci

Pour compléter ce que dit Raymond, tu dois déjà faire une sauvegarde de la
base en cours avant de lancer la compression.
Un des nombreux (le mot est faible !) trucs que m'a appris Laurent Paris est
justement que tu peux automatiser la sauvegarde de la base en cours. C'est
d'ailleurs du code que j'ajoute systématiquement à toutes mes bases pour
avoir un bouton qui se charge de faire la sauvegarde.
Je te mets un ci-dessous du code (j'espère avoir réuni tous les morceaux !)
qui se charge de ça.
Tu lances la procédure "TestEnregistrerSous" pour comprendre.
Si t'as trop de problèmes avec les retours à la ligne, je peux te mailer
tout ça dans un fichier txt.
Ensuite, concernant le zip, soit tu utilises une des méthodes que Raymond te
donne, soit tu utilises des dll que tu dois installer sur chaque ordi
utilisant ton prg (si cette méthode t'intéresse, cherche dans l'historique
"zip.dll" et "unzip.dll").

'***************** Code Start **************
'This code was originally written by Ken Getz.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
' Code courtesy of:
' Microsoft Access 95 How-To
' Ken Getz and Paul Litwin
' Waite Group Press, 1996

'Traduit par je ne sais pas qui

Type tagOPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
strFilter As String
strCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
strFile As String
nMaxFile As Long
strFileTitle As String
nMaxFileTitle As Long
strInitialDir As String
strTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
strDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

Declare Function aht_apiGetOpenFileName Lib "comdlg32.dll" _
Alias "GetOpenFileNameA" (OFN As tagOPENFILENAME) As Boolean
Declare Function aht_apiGetSaveFileName Lib "comdlg32.dll" _
Alias "GetSaveFileNameA" (OFN As tagOPENFILENAME) As Boolean
Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long
Global Const ahtOFN_READONLY = &H1
Global Const ahtOFN_OVERWRITEPROMPT = &H2
Global Const ahtOFN_HIDEREADONLY = &H4
Global Const ahtOFN_NOCHANGEDIR = &H8
Global Const ahtOFN_SHOWHELP = &H10
' You won't use these.
'Global Const ahtOFN_ENABLEHOOK = &H20
'Global Const ahtOFN_ENABLETEMPLATE = &H40
'Global Const ahtOFN_ENABLETEMPLATEHANDLE = &H80
Global Const ahtOFN_NOVALIDATE = &H100
Global Const ahtOFN_ALLOWMULTISELECT = &H200
Global Const ahtOFN_EXTENSIONDIFFERENT = &H400
Global Const ahtOFN_PATHMUSTEXIST = &H800
Global Const ahtOFN_FILEMUSTEXIST = &H1000
Global Const ahtOFN_CREATEPROMPT = &H2000
Global Const ahtOFN_SHAREAWARE = &H4000
Global Const ahtOFN_NOREADONLYRETURN = &H8000
Global Const ahtOFN_NOTESTFILECREATE = &H10000
Global Const ahtOFN_NONETWORKBUTTON = &H20000
Global Const ahtOFN_NOLONGNAMES = &H40000
' New for Windows 95
Global Const ahtOFN_EXPLORER = &H80000
Global Const ahtOFN_NODEREFERENCELINKS = &H100000
Global Const ahtOFN_LONGNAMES = &H200000


Sub TestEnregistrerSous()
EnregistrerSous
End Sub
Function EnregistrerSous(Optional ChoixDuChemin As Boolean = True)
Dim Nom_Compl As String
Dim Nom_Base As String
Dim strFilter As String
Dim lngFlags As Long
Dim Chem_Base As String
Dim Nom_Sauveg As String
Dim Nom_Compl_Sauv As String
Dim Ext_Base As String
Dim bTmp As Long
Dim btmp2 As Long
Dim n As Byte
Dim sNomSansExt As String
Dim FS, f

Nom_Compl = CurrentDb.Name
Chem_Base = Chem_Fich2(Nom_Compl)
Nom_Base = Nom_Fich(Nom_Compl)
Ext_Base = Ext_Fichier(Nom_Compl)
sNomSansExt = "Sauveg" & Enleve_Ext(Nom_Base) & Format(Date, "yymmdd")
Nom_Sauveg = sNomSansExt & "." & Ext_Base

If Dir(Chem_Base & "" & Nom_Sauveg) <> "" Then 'le fichier de
sauvegarde existe déjà
For n = 1 To 200
If Dir(Chem_Base & "" & sNomSansExt & "(" & n & ")." & Ext_Base) "" Then 'le fichier de sauvegarde n'existe pas
Nom_Sauveg = sNomSansExt & "(" & n & ")." & Ext_Base
Exit For
End If
Next
End If

If ChoixDuChemin Then
strFilter = ahtAddFilterItem(strFilter, "Access Files (*.mde,
*.mdb)", _
"*.MDE;*.MDB")
Nom_Compl_Sauv = ahtCommonFileOpenSave(InitialDir:=Chem_Base, _
Filter:=strFilter, FilterIndex:=3, DefaultExt:="mdb",
FileName:=Nom_Sauveg, Flags:=lngFlags, _
DialogTitle:="Enregistrer_Sous...", OpenFile:úlse)
Else
Nom_Compl_Sauv = Chem_Base & "" & Nom_Sauveg
End If

If Nom_Compl_Sauv = vbNullString Then
MsgBox "Procédure annulée." & vbCrLf & "Fichier non sauvegardé"
Exit Function
End If

If Dir(Nom_Compl_Sauv) <> vbNullString Then
If MsgBox("Le fichier existe déjà." & vbCrLf & "Voulez-vous le
remplacer ?", vbCritical + vbYesNo + vbDefaultButton1) = vbNo Then
MsgBox "Procédure annulée." & vbCrLf & "Fichier non sauvegardé"
Exit Function
End If
End If

If Nom_Compl_Sauv <> "" Then
Set FS = CreateObject("Scripting.FileSystemObject")
Set f = FS.GetFile(Nom_Compl)

bTmp = InStrRev2(Nom_Compl_Sauv, ".")
btmp2 = InStrRev2(Nom_Compl_Sauv, "")
If bTmp <> 0 And bTmp < btmp2 Then
Nom_Compl_Sauv = Left(Nom_Compl_Sauv, Len(Nom_Compl_Sauv) -
bTmp)
End If
Nom_Compl_Sauv = Nom_Compl_Sauv & "." & Ext_Base

f.Copy Nom_Compl_Sauv

Set f = Nothing
Set FS = Nothing

End If

End Function


Function Chem_Fich2(CheminComplet As String) As String
'Renvoie le chemin du fichier sans l'antislash final
'C:Mes documents
Dim n As Integer
Dim Lng_Nom As Integer

If CheminComplet = vbNullString Then Exit Function

Lng_Nom = Len(CheminComplet)
For n = Lng_Nom To 1 Step -1
If Mid(CheminComplet, n, 1) = "" Then
Chem_Fich2 = Left(CheminComplet, n - 1)
Exit For
End If
Next
End Function

Function Nom_Fich(ByVal CheminComplet As String) As String
Dim n As Integer
Dim Lng_Nom As Integer

If CheminComplet = vbNullString Then Exit Function

Lng_Nom = Len(CheminComplet)
For n = Lng_Nom To 1 Step -1
If Mid(CheminComplet, n, 1) = "" Then
Nom_Fich = Mid(CheminComplet, n + 1)
Exit For
End If
Next
End Function

Function Ext_Fichier(NomComplet As String) As String
If NomComplet = vbNullString Then Exit Function
Ext_Fichier = Right(NomComplet, 3)
End Function

Function Enleve_Ext(NomComplet As String) As String
If NomComplet = vbNullString Then Exit Function
Enleve_Ext = Left(NomComplet, Len(NomComplet) - InStrRev2(NomComplet,
"."))
End Function

Function InStrRev2(ChaineOuChercher, CaractereCherché) As Integer
Dim n As Integer
Dim i As Integer
Dim Compteur As Integer

If IsNull(ChaineOuChercher) Or IsNull(CaractereCherché) Then
InStrRev2 = 0
Exit Function
End If

i = Len(ChaineOuChercher)
For n = i To 1 Step -1
If Mid(ChaineOuChercher, n, 1) = CaractereCherché Then
Compteur = i - n + 1
Exit For
End If
Next
InStrRev2 = Compteur
End Function

Function TestIt()
Dim strFilter As String
Dim lngFlags As Long
strFilter = ahtAddFilterItem(strFilter, "Access Files (*.mda, *.mdb)", _
"*.MDA;*.MDB")
strFilter = ahtAddFilterItem(strFilter, "dBASE Files (*.dbf)", "*.DBF")
strFilter = ahtAddFilterItem(strFilter, "Text Files (*.txt)", "*.TXT")
strFilter = ahtAddFilterItem(strFilter, "All Files (*.*)", "*.*")
MsgBox "You selected: " & ahtCommonFileOpenSave(InitialDir:="C:", _
Filter:=strFilter, FilterIndex:=3, Flags:=lngFlags, _
DialogTitle:="Hello! Open Me!")
' On a fourni les options dans lngFlags,
' la fonction y place donc les options en sortie.
Debug.Print Hex(lngFlags)
End Function
Function GetOpenFile(Optional varDirectory As Variant, _
Optional varTitleForDialog As Variant) As Variant
' Un exemple pour obtenir une base de données Access.
Dim strFilter As String
Dim lngFlags As Long
Dim varFileName As Variant
' On désire que le fichier existe déjà,
' on ne veut pas changer de répertoire, en sortie
' et on n'affiche pas la mention "lecture seule"
' qui ne fait qu'embrouiller les gens
lngFlags = ahtOFN_FILEMUSTEXIST Or _
ahtOFN_HIDEREADONLY Or ahtOFN_NOCHANGEDIR
If IsMissing(varDirectory) Then
varDirectory = ""
End If
If IsMissing(varTitleForDialog) Then
varTitleForDialog = ""
End If

' Définir les filtres et utiliser "c"
' Copier cette ligne pour ajouter
' d'autres filtres.
strFilter = ahtAddFilterItem(strFilter, _
"Access (*.mdb)", "*.MDB;*.MDA")
' Et maintenant, obtenir le nom du fichier.
varFileName = ahtCommonFileOpenSave( _
OpenFile:=True, _
InitialDir:=varDirectory, _
Filter:=strFilter, _
Flags:=lngFlags, _
DialogTitle:=varTitleForDialog)
If Not IsNull(varFileName) Then
varFileName = TrimNull(varFileName)
End If
GetOpenFile = varFileName
End Function
Function ahtCommonFileOpenSave( _
Optional ByRef Flags As Variant, _
Optional ByVal InitialDir As Variant, _
Optional ByVal Filter As Variant, _
Optional ByVal FilterIndex As Variant, _
Optional ByVal DefaultExt As Variant, _
Optional ByVal FileName As Variant, _
Optional ByVal DialogTitle As Variant, _
Optional ByVal HWND As Variant, _
Optional ByVal OpenFile As Variant) As Variant
'Point d'entrée pour le contrôle commun
' "file open/save dialog". Les paramètres sont
' listés par après, et sont tous optionels.
'
' *In:
' Flags: un ou plusieurs constantes de ahtOFN_* constants, unie par des OR
' InitialDir: le répertoire présenté à l'usager
' Filter: une série de filtres pour les fichiers; utiliser
' AddFilterItem. Voir l'exemple.
' FilterIndex: Index, base 1, fournissant le filtre par défaut
' (1, si non spécifié)
' DefaultExt: Extension à utiliser si l'usager n'en entre pas.
' Seulement pour les sauvegardes.
' FileName: Valeur par défaut pour le nom du fichier.
' DialogTitle: Titre dans la barre titre du formulaire.
' hWnd: handle Win32 du parent de ce dialogue
' OpenFile: Booléen(True=Open File/False=Save As)
' *Out:
' Return Value: Soit Null, soit le nom choisi
Dim OFN As tagOPENFILENAME
Dim strFileName As String
Dim strFileTitle As String
Dim fResult As Boolean
' Fournir le caption (étiquette) du titre.
If IsMissing(InitialDir) Then InitialDir = CurDir
If IsMissing(Filter) Then Filter = ""
If IsMissing(FilterIndex) Then FilterIndex = 1
If IsMissing(Flags) Then Flags = 0&
If IsMissing(DefaultExt) Then DefaultExt = ""
If IsMissing(FileName) Then FileName = ""
If IsMissing(DialogTitle) Then DialogTitle = ""
If IsMissing(HWND) Then HWND = Application.hWndAccessApp
If IsMissing(OpenFile) Then OpenFile = True
' Créer une chaîne pour recevoir le résultat.
strFileName = Left(FileName & String(256, 0), 256)
strFileTitle = String(256, 0)
' Initialiser la structure avant d'appeler la fonction
With OFN
.lStructSize = Len(OFN)
.hwndOwner = HWND
.strFilter = Filter
.nFilterIndex = FilterIndex
.strFile = strFileName
.nMaxFile = Len(strFileName)
.strFileTitle = strFileTitle
.nMaxFileTitle = Len(strFileTitle)
.strTitle = DialogTitle
.Flags = Flags
.strDefExt = DefaultExt
.strInitialDir = InitialDir
' On ne pense pas que quelqu'un veut vraiment utiliser
' ces options.
.hInstance = 0
.strCustomFilter = ""
.nMaxCustFilter = 0
.lpfnHook = 0
' Pour NT 4.0
.strCustomFilter = String(255, 0)
.nMaxCustFilter = 255
End With
' Transmettre la structure de données au
' Windows API qui, à son tour, affichera
' le formulaire "Open/Save As".
If OpenFile Then
fResult = aht_apiGetOpenFileName(OFN)
Else
fResult = aht_apiGetSaveFileName(OFN)
End If

' La fonction retourne le nom dans le membre strFileTitle
' de la structure. Il nous faut écrire du code pour
' retrouver ce qui nous intéresse.
If fResult Then
' Vous pouvez vérifier les membres de la structure
' pour obtenir plus d'information sur le fichier choisi.
' Dans cet exemple, si vous avez fourni un argument pour
' les options, on vous retourne les indicateurs (flags) dans
' cette même variable.
If Not IsMissing(Flags) Then Flags = OFN.Flags
ahtCommonFileOpenSave = TrimNull(OFN.strFile)
Else
ahtCommonFileOpenSave = vbNullString
End If
End Function
Function ahtAddFilterItem(strFilter As String, _
strDescription As String, Optional varItem As Variant) As String
' Ajoute un nouvel ensemble de données formant un nouveau filtre.
' Par exemple, aux filtres existants, ajouter une description,
' (tel "Databases"), un caractère null, la grille passe-partout
' (tel "*.mdb;*.mda") et un dernier caractère null.

If IsMissing(varItem) Then varItem = "*.*"
ahtAddFilterItem = strFilter & _
strDescription & vbNullChar & _
varItem & vbNullChar
End Function
Private Function TrimNull(ByVal strItem As String) As String
Dim intPos As Integer
intPos = InStr(strItem, vbNullChar)
If intPos > 0 Then
TrimNull = Left(strItem, intPos - 1)
Else
TrimNull = strItem
End If
End Function

'************** Code End *****************
'To call the actual dialog from your code, see the enclosed function
TestIt() within the module or use the following example as a guideline and

'Dim strFilter As String
'Dim strInputFileName As String

'strFilter = ahtAddFilterItem(strFilter, "Excel Files (*.XLS)", "*.XLS")
'strInputFileName = ahtCommonFileOpenSave(Filter:=strFilter, OpenFile:=True,
_
DialogTitle:="Please select an input file...", _
Flags:=ahtOFN_HIDEREADONLY)

'Note that in order to call the Save As dialog box, you can use the same
wrapper function by just setting the OpenFile option as False. For example,


'Ask for SaveFileName
'strFilter = ahtAddFilterItem(myStrFilter, "Excel Files (*.xls)", "*.xls")
'strSaveFileName = ahtCommonFileOpenSave(OpenFile:úlse, Filter:=strFilter,
_
Flags:=ahtOFN_OVERWRITEPROMPT Or ahtOFN_READONLY)

Bonsoir Snack.

se remettre dans le bain avec cette procédure, un jeudi soir, c'est limite.
bon pour péter une durit.
j'ai oublié de dire que sous la version 2003, le problème ne se pose pas car
on peut sauvegarder la base en cours et faire un zip de la sauvegarde.

--
@+
Raymond Access MVP
http://access.seneque.free.fr/
http://access.vba.free.fr/
http://access2003.free.fr/
http://users.skynet.be/mpfa/ pour débuter sur le forum


"snack" <ZZZ_snackz@free.fr> a écrit dans le message de
news:%23Wa0SxghEHA.1392@TK2MSFTNGP11.phx.gbl...

Pour compléter ce que dit Raymond, tu dois déjà faire une sauvegarde de la
base en cours avant de lancer la compression.