General – Zipper le contenu d'un répertoire

Auteur : Laurent Godard – Conseil et Développement – dev.godard@wanadoo.fr

Révision : 1

Zippe le contenu d'un répertoire et de ses sous répertoires vers un fichier cible en respectant l'arborescence

Note : Faire un copier/coller de l’ensemble.

sub ExempleAppel

call ZipUnRepertoire("C:\MesFichiers\Ooo\Rep","C:\resultat.zip")

end sub

'----------------------------------------------------------------------

sub ZipUnRepertoire(source as string, cible as string)

dim retour() as string

'création de l'instance du fichier Zip

LeFichierZip=createUnoService("com.sun.star.packages.Package")

dim args(0)

args(0)=ConvertToURL(cible)

LeFichierZip.initialize(args())

'création de la structure des repertoires dans le zip

call Recursedirectory(source, retour)

dim argsDir(0)

argsDir(0)=true

'on saute le premier --> repertoire contenant

'Pourra etre une option a terme

Repbase=retour(1)

for i=2 to ubound(retour)

chaine=mid(retour(i),len(repbase)+2)

decoupe=split(mid(retour(i),len(repbase)+1),getPathSeparator)

repZip=decoupe(ubound(decoupe))

azipper=LeFichierZip.createInstanceWithArguments(argsDir())

if len(chaine)<>len(repZip) then

RepPere=left(chaine,len(chaine)-len(repZip)-1)

RepPere=RemplaceChaine(reppere, getpathseparator, "/", false)

else

RepPere=""

endif

RepPereZip=LeFichierZip.getByHierarchicalName(RepPere)

RepPereZip.insertbyname(repzip, azipper)

next i

'insertion des fichiers dans les bons repertoires

dim args2(0)

args2(0)=false

oUcb = createUnoService("com.sun.star.ucb.SimpleFileAccess")

for i=1 to ubound(retour)

chaine=mid(retour(i),len(repbase)+2)

repzip=remplacechaine(chaine, getpathseparator, "/", false)

fichier=dir(retour(i)+getPathSeparator,0)

while fichier<>""

azipper=LeFichierZip.createInstanceWithArguments(args2())

oFile = oUcb.OpenFileRead(ConvertToURL(retour(i)+"/"+fichier))

azipper.SetInputStream(ofile)

RepPere=LeFichierZip.getByHierarchicalName(repZip)

RepPere.insertbyname(fichier, azipper)

fichier=dir()

wend

next i

'Valide les changements

LeFichierZip.commitChanges()

msgbox "C'est fini"

end sub

'----------------------------------------------------------------------

sub RecurseDirectory(chemin, reponse as variant)

'reponse est un tableau contenant la liste de tous les sous répertoires de chemin

redim preserve reponse(1 to 1)

compte=1

reponse(1)=chemin

repbase=1

rep=dir(convertTourl(chemin+"/"),16)

while rep<>""

if rep<>"." and rep<>".." then

compte=compte+1

redim preserve reponse(1 to compte)

reponse(compte)=convertfromurl(reponse(RepBase)+"/"+rep)

endif

rep=dir()

while rep="" and repbase<compte

repbase=repbase+1

rep=dir(convertToURL(reponse(repbase)+"/"),16)

wend

wend

end sub

'----------------------------------------------------------------------

Function RemplaceChaine(ByVal chaine As String, src As String, dest As String, casse As Boolean)

'Auteurs: Laurent Godard & Bernard Marcelly

' fournit une chaine dont toutes les occurences de src ont été remplacées par dest

'casse = true pour distinguer majuscules/minuscules, = false sinon

Dim lsrc As Integer, i As Integer, kas As Integer

dim limite as string

limite=""

kas = iif(casse, 0, 1)

lsrc = len(src)

i = instr(1, chaine, src, kas)

while i<>0

while i<0

limite=limite+left(chaine,32000)

chaine=mid(chaine,32001)

i=instr(1, chaine, src, kas)

wend

' ici i est toujours positif non nul

if i>1 then

limite = limite + Left(chaine, i-1) +dest

else ' ici i vaut toujours 1

limite = limite +dest

endif

' raccourcir en deux temps car risque : i+src > 32767

chaine = Mid(chaine, i)

chaine = Mid(chaine, 1+lsrc)

i = instr(1, chaine, src, kas)

wend

RemplaceChaine = limite + chaine

End Function

Licence

'********************************************************************************

'Copyright (C) 2003 Laurent Godard

'dev.godard@wanadoo.fr

'This library is free software; you can redistribute it and/or

'modify it under the terms of the GNU Lesser General Public

'License as published by the Free Software Foundation; either

'version 2.1 of the License, or (at your option) any later version.

'This library is distributed in the hope that it will be useful,

'but WITHOUT ANY WARRANTY; without even the implied warranty of

'MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU

'Lesser General Public License for more details.

'http://www.opensource.org/licenses/lgpl-license.php

'You should have received a copy of the GNU Lesser General Public

'License along with this library; if not, write to the Free Software

'Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

'******************************************************************************

Sophie Gautier

2003-05-04T09:01:58