-
Notifications
You must be signed in to change notification settings - Fork 0
/
clsybZip.cls
3167 lines (2867 loc) · 153 KB
/
clsybZip.cls
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "clsZip"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Description = "Regroupement dans une classe pour faciliter la mise en oeuvre des fonctions pour Zipper et déZipper de ZLIB.DLL, libre de droits. Facilite le partage de cette classe commune à plusieurs applications."
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
'BlosHome (c) FFh Lab / Eric Lequien, 2009-2013 - http://ffh-lab.com
'Class binding zlib and ZIP format ; adaptation by Jack from a Andrew Mc Millan code (see below)
'NB : to optimize code, I've just commented all unused constants, variables and functions
'***TODO : translate original comments from Jack below
'--------------------------------------------------------------------------------------------
'Auteur : Jack ([email protected])
' qui a lui-même adapté le Code original : Andrew McMillan ([email protected])
'Ajout du 11 juin 2006 par Jack :
'- Conversion des chaines des noms de fichiers de ISO en ASCII étendu (et réciproquement)
' afin d'être compatible avec WinZip (clsZip_File et clsZip_UnZip)
'- Déclaration des Functions de DLL avec les types corrects (pour VB 2005)
'- Correction : Le chemin dans un Zip ne doit jamais comporter le nom d'un disque??
'Dépendances : Zlib.dll - Free (libre de droits)
'Objectifs et modif faites :
'-Regroupement dans une classe les 2 classes de Jack, (Zip et Unzip) pour faciliter l'intégration
'et la mise en oeuvre des fonctions de la librairie ZLIB.DLL, libre de droits, dans un projet.
'-J'ai ajouté un évènement ProgressLoad car l'opération de chargement d'un fichier peut être longue
'si sa taille est importante et l'utilisateur peut croire que le système est planté en ajoutant
'1 barre de progression lié à ce nouvel évènement on solutionne cet inconvénient.
'De ce fait, j'ai rebâptisé l'évènement Progress -> ProgressExtract
'En fait cet évènement n'est plus très utile depuis la fonction ybGetCentralDirEndPos qui rend le chargement instantané !
'-Le 10/07/2006 : ajout de 3 méthodes et modification de l'organisation du zippage pour permettre
'un zip de très grande taille (j'ai testé 1 zip de 1,900 Go avec succès) et améliorer les performances.
'Les méthodes ajoutées sont: createZip, ybFileAdd, WriteEndZip. Elles doivent être employées ensemble.
'Il est toujours possible d'utiliser l'autre concept, (FileAdd qui crée 1 collection de fichiers à zipper et
'WriteZip qui crée le fichier zip et écrit la collection dans le fichier zip), mais pas simultanément.
'Néanmoins il faut se souvenir que ce concept est gourmand en ressources (conso mémoire, lenteur)
'car il maintient des tableaux d'octets des fichiers à zipper pendant toute l'élaboration de la collection,
'ce qui limite la taille du fichier zip final à la saturation de la mémoire. Utilisable plutôt ponctuellement.
'Mon concept est de créer et ouvrir un fichier Zip par CreateZip dans lequel on ira ajouter
'au fur et à mesure le LocalFileHeader de chaque fichier à zipper, ce qui permet de vider la
'mémoire au fur et à mesure des compressions réalisées et ne limite donc plus la taille du fichier
'final et améliore considérablement les performances. Ceci est réalisé par ybFileAdd. A la fin de
'l'élaboration de la collection des fichiers à zipper, on écrit le CentralFileHeader, le commentaire
'la signature et colCentralDirEnd avec WriteEndZip.
'-Le 14/06/2006 : gestion compression et décompression de fichiers de taille 0 octet.
'-Le 11/07/2006 : transformation de CompressBytes sub en fonction pour qu'elle renvoie 0 ou 1 code erreur
'pour gestion possible dans la méthode appelante ou créer 1 évènement afin que le programme utilisant
'cette classe puisse gérer l'erreur. Test de l'erreur Dépassement de mémoire pour les gros fichiers
'à zipper et éviter 1 plantage. Dans ce cas, pour l'instant empacter le gros fichier dans le zip final
'avec le calcul de son crc32 hors Zlib,tout en renvoyant 1 message d'info adapté à l'utilisateur.
'Par contre lenteur liée à taille du fichier ! et double lecture du fichier source (déjà gros), 1 calcul
'du crc, l'autre empactage. Il faudra réduire à 1 seule lecture + tard lorsqu'on compressera ces gros fichiers !
'-Le 30/07/2006: ajout d'une méthode FileAddIntoZip qui permet d'ajouter 1 fichier à zipper dans 1 zip
'déjà existant.
'-Le 01/08/2006: ajout d'une méthode FileRemoveFromZip qui permet de supprimer 1 fichier d'un zip existant.
'-du 08/08/2006 au 12/11/2006: transformation de l'objet ZipFile et sa collection en 1 tableau typé
'pour fusionner les 2 classes clsZip et Zipfile (clarté du code, faciliter intégration dans 1 projet)
'et optimiser l'utilisation mémoire, et donc la vitesse. Regroupement également des champs communs
'de localFileHeader et CentralFileHeader dans 1 type commun pour économiser mémoire.
'-Le 30/10/2006 : adaptation de la mise à jour de Jack (version du 18/09/2006) sur la gestion des accents.
'-du 13/11/2006 au 15/11/2006: Remplacement des appels FSO par les API FindFirstFile et FindNextFile
'pour éliminer dépendances et faciliter l'intégration de la classe dans un projet, améliorer vitesse.
'-Le 23/11/2006 : _ajout de possibilités d'interface avec l'utilisateur sur l'évènement ZipError.
' _ajout de possibilités de neutraliser le Crc32 dans les méthodes de zippage pour
' améliorer la vitesse, mais cette option peut conduire le zip à être incompatible
' avec certains logiciels de décompression, les méthodes concernées sont donc paramétrées
' par défaut avec calcul du CRC32. Pour éliminer le calcul du crc il faut placer excludeCRC32 à True.
'-Le 05/12/2006 : gestion du niveau de compression, initialisé au taux par défaut, (niv 6) (ajout propriété LevelCompression)
'-Semaine 03/2007: -ajout d'1 méthode ExtractSgFileToTmp pour décompresser au + vite dans le répertoire Temp de Windows
' afin d'obtenir rapidemment des infos sur le fichier compressé (genre version, dates, commentaires ...)
' et préparation à un chargement "à la volée" du fichier (sans décompression apparente !...)
' -à cette occasion mise en place d'1 option "KeepModDate" sur les méthodes de décompression
' pour choisir de décompresser le ou les fichiers en conservant leur date de dernière modif.
' (peut-être important lorsqu'il y a des tests de dates par des applis tiers sur les fichiers !)
'-Semaine 06/2007 : -ajout méthode pour lancer directement une fichier dont le type est connu sans le dézipper
' (dans la réalité il y a quand-même décompression mais dans le rép Temp et la suppression est gérée
' c'est don transparent pour l'ulisateur.) La méthode sous-entend d'avoir exécuté ExtractSgFileToTemp au préalable!
'--------------------------------------------------------------------------------------------
'Inconvénients à l'origine : cette classe ne peut pas gèrer 1 fichier zip final de grande taille
'(en zippage ou dézippage)**, ainsi que zipper-dézipper des gros fichiers (*W)
'** dézippage de grandes tailles devenue possible par ybGetCentralDirEndPos, (précédemment limité à #200Mo)
'** zippage de grande taille éliminé le 10/07/2006 par nouveau concept YB.
'(*W) J'ai utilisé 1 parade pour le zippage d'1 gros fichier, en fait j'empacte ce fichier mais sans le
'zipper, forcément c'est long, d'autant que je contrôle quand même son Crc32 pour compatibilité avec
'définition d'un fichier Zip et donc accès du Zip pour logiciels externes, mais au moins c'est empacté
'et il n'y a donc plus de limite dans aucun sens ni fichier zip final de grande taille, ni fichier de grande
'taille dans 1 fichier zip. La seule contrainte qui reste c'est 1 contrainte système, la FAT32 !
'Ceci reste à améliorer, il faudrait pouvoir compresser et contrôler le crc32 rapidement !!!!
'
'---------------------------------------------------------------------------------------------
'/////////////Méthodes :
' ++++zippage
'FileAdd(ByVal FilePath As String, _
ByVal PathChoice As enumPathChoice, _
Optional ByVal RecurseDirectories As Boolean = False, _
Optional excludeCRC32 As Boolean = False) As Long : ajout de fichier au tableau de fichiers à ZIPPER
'FileAddSingle(ByVal FilePath As String, _
ByVal PathChoice As enumPathChoice, _
Optional excludeCRC32 As Boolean = False) As Long : Ajout d'un seul fichier à la collection à Zipper ?
'FileDel(ByVal Index As Long) As Boolean : Supprime un des fichiers de la collection (avant création du zip)
'WriteZip(FilePath As String, _
Optional Overwrite As Boolean) As Boolean : Créé le fichier ZIP lui même à partir de la collection
' qui en fait utilise la classe ZipFile de A. McMillan qui réalise la compression
' (A) ces méthodes doivent s'employer ensemble mais pas avec les anciennes qui précèdent
' (A) CreateZip(FilePath As String, Optional Overwrite As Boolean) As Long : Crée le fichier Zip avec gestion overwrite
' (A) ybFileAdd(ByVal FilePath As String, ByVal PathChoice As enumPathChoice, lgNoFileZip As Long, _
Optional ByVal RecurseDirectories As Boolean = False, Optional excludeCRC32 As Boolean = False) As Long : ajoute le
' fichier à zipper au fichier zip ouvert dont le canal est indiqué en lgNoFileZip.
' (A) WriteEndZip(lgNoFileZip As Long) As Boolean : termine l'écriture du fichier zip ouvert dont le canal est indiqué en lgNoFileZip.
'FileAddIntoZip(strZipPath As String, strFilePath As String, PathChoice As enumPathChoice, _
Optional excludeCRC32 As Boolean = False, Optional OverWrite As Boolean = False) As Boolean : permet d'ajouter 1 fichier
' à zipper dans 1 zip déjà existant avec Option OverWrite, par défaut à False, si OverWrite par de gestion de date, overwrite brut.
'FileRemoveFromZip(strZipPath As String, strFilePath As String) As Boolean : permet de supprimer 1 zip d'un zip existant.
' ++++informations/dézippage
'ZipOpen(ByVal ZipPath As String) As Boolean : ouvre le fichier zip (le charge pour analyse en lecture)
'ExtractAllFiles(ByVal FolderPath As String, _
Optional ByVal PreservePath As Boolean, _
Optional ByVal Overwrite As Boolean, _
Optional ByVal KeepModDate As Boolean) As Boolean : extrait tous les fichiers du zip
'ExtractSingleFile(ByVal FileNumber As Long, _
ByVal FolderPath As String, _
Optional ByVal PreservePath As Boolean, _
Optional ByVal Overwrite As Boolean, _
Optional ByVal KeepModDate As Boolean) As Boolean : extrait un fichier d'après son n° dans le catalogue du zip
'ExtractSgFileToTmp(lgNuFile As Long) As String : extrait un fichier dans le Temp de Windows en conservant sa date de modif
' (voir commentaires dans la fonction)
'LoadZippedFile(strFilePath As String) as Boolean : lance l'exécutable attaché au fichier apparemment sans le dézipper.
' (voir commentaires dans la fonction)
'
'////////////Propriétés :
'FileCount() As Long : nombre de fichiers inclus dans le tableau-collection à zipper
'FileName(ByVal Index As Long) As String : nom du fichier correspondant à l'index dans la collection à zipper
'Comment() As String (lecture/écriture) : commentaire du Zip en lecture/écriture avant création du fichier
'SizeCompressed(ByVal Index As Long) As Long: renvoie taille du fichier compressé dans la collection
'SizeUncompressed(ByVal Index As Long) As Long :Renvoie la taille décompressée (originale) du fichier
'inFileCount() As Long : Renvoie le nombre de fichiers contenus dans le fichier Zip en excluant les répertoires
' pas la récursivité mais le nombre de répertoires
'ZipIsOpen() As Boolean : Renvoie True si un Zip est déjà ouvert
'ZipComment() As String : Renvoie le commentaire du Zip
'inFileName(ByVal Index As Long) As String : Renvoie le nom du fichier désigné par Index
'FileCompressedSize(ByVal Index As Long) As Long : Renvoie la taille du fichier compressé désigné par Index
'FileUncompressedSize(ByVal Index As Long) As Long :Renvoie la taille originale du fichier désigné par Index
'FileDateAndTime(ByVal Index As Long) As Date : Renvoie la date et l'heure du fichier original désigné par Index
'ZLibVersion() As String : Renvoie la version de la Zlib.DLL
'LevelCompression() as eLevelCompres : fixe ou renvoie le niveau de compression qui est initialisé au taux par défaut
''
'///////////Evènements :
'ProgressExtract(ByVal Percent As Long, ByRef Cancel As Boolean) : renvoie % de progression (décompress)
'Status(ByVal Text As String) : renvoie info déroulement
'ZipError(ByVal Number As eZipError, ByVal Description As String, Cancel as boolean): renvoie une erreur
' dont la gestion peut être contrôlée par Cancel. (information/dézippage)
'FileZipErr(strFilePath as string, lgErr as long, strDescription as string) : erreur pendant zippage
'
'Enumérations :
'enumPathChoice : options sur Path
'eZipError : erreurs possibles gérées (information/dézippage)
'eLevelCompres : les taux de compression
'
'------------------------------------------------------------------------------------------------
'Fonctionnement : ++Zippage: création d'un tableau (précédemment collection) de fichiers à compresser et intégrer
' au fichier Zip définitif. Le tableau peut être manipulé (ajouter ou supprimer ou ... des fichiers)
' tant que le fichier zip définitif n'est pas créé.
' +Autre méthode (ajout YB 07/2006): Création du fichier zip dès le départ, ajout des données compressées
' au fur et à mesure dans le fichier zip, écriture à la fin du process de la structure et fermeture du fichier zip.
' ++DéZippage : charge le fichier en mémoire par openFile, recherche le catalogue des fichiers
' inclus dans le zip (structure du fichier), puis manipule les fichiers d'après leur index
' auquel correspond 1 offset dans le zip.
'-----------------------------------------------------------------------------------------------
'Améliorations envisagées :
' -Gérer compression et calcul crc32 de gros fichiers à zipper (actuellement empactés mais non compressés)
' (pour y parvenir, il faudrait changer l'entrée-srotie de Compress et Uncompress de Zlib qui sont
' actuellement des tableaux d'octets ce qui conduit à des dépassements de mémoire lors de gros fichiers,
' en étudiant + les possibilités de Zlib, il y a peut-être la réponse à ce problème, ou alors
' gérer la compression hors de zlib, mais alors le crc des gros fichiers étant déjà externe à zlib
' quid de passer par zlib !
' -Utiliser les API ReadFile et WriteFile pour optimiser performances et réduire les limites de tailles !
' -Crypter/décrypter le fichier ZIP (voir définition fichier zip, éventuelles fonctions dans Zlib version + récente)
'--------------------------------------------------------------------------------------------------
Option Explicit
'API lecture/écriture Fichiers ReadFile et WriteFile ---------------------------------------------
Const FILE_BEGIN = 0
Const FILE_SHARE_READ = &H1
Const FILE_SHARE_WRITE = &H2
'Const CREATE_NEW = 1
'Const CREATE_ALWAYS = 2
Const OPEN_EXISTING = 3
Const GENERIC_READ = &H80000000
Const GENERIC_WRITE = &H40000000
'Const FILE_END = 2
'Const FILE_CURRENT = 1
Const INVALID_HANDLE_VALUE As Long = -1
Const ERROR As Long = &HFFFFFFFF
Private Declare Function ReadFile Lib "kernel32" _
(ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal lpOverlapped As Any) As Long
'Private Declare Function WriteFile Lib "kernel32" _
(ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Any) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" _
(ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function SetFilePointer Lib "kernel32" _
(ByVal hFile As Long, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
Private Declare Function GetFileSize Lib "kernel32" _
(ByVal hFile As Long, lpFileSizeHigh As Long) As Long
' déclarations autres API ------------------------------------------------------------------------------
'Private Declare Function CopyMemory_Long_Byte Lib "kernel32" Alias "RtlMoveMemory" (dest As Long, Src As Byte, ByVal Length As Long) As Long
Private Declare Function CopyMemory_Byte_Byte Lib "kernel32" Alias "RtlMoveMemory" (dest As Byte, Src As Byte, ByVal Length As Long) As Long
Private Declare Sub CopyMemory_Int_Byte Lib "kernel32" Alias "RtlMoveMemory" (dest As Integer, Source As Byte, ByVal Length As Long)
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpBuffer As String, ByVal lpString As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Long) As Long
' API pour Récupérer le chemin du répertoire temporaire ---------------------------------------------------
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
'API pour gérer les dates du type FileTime
'FileTimeToSystemTime avec Api Infos et recherche Fichiers
'Private Declare Function FileTimeToLocalFileTime Lib "kernel32" (lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long '
Private Declare Function LocalFileTimeToFileTime Lib "kernel32" (lpLocalFileTime As FILETIME, lpFileTime As FILETIME) As Long
Private Declare Function SetFileTime Lib "kernel32" (ByVal hFile As Long, lpCreationTime As Any, lpLastAccessTime As Any, lpLastWriteTime As Any) As Long
Private Declare Function SystemTimeToFileTime Lib "kernel32" (lpSystemTime As SYSTEMTIME, lpFileTime As FILETIME) As Long
' API Noms de fichiers Longs vers Petits ---------------------------------------------------------------------------------------
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, _
ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
' déclarations API Infos et recherche Fichiers -------------------------------------------------------------
Private Declare Function DosDateTimeToFileTime Lib "kernel32.dll" (ByVal wFatDate As Long, ByVal wFatTime As Long, lpFileTime As FILETIME) As Long
Private Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
Private Declare Function GetFullPathName Lib "kernel32" Alias "GetFullPathNameA" (ByVal lpFileName As String, ByVal nBufferLength As Long, _
ByVal lpBuffer As String, ByVal lpFilePart As String) As Long
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
' API et constantes pour lancer appli à partir d'un fichier ------------------------------------------------
Private Declare Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" (ByVal lpFile As String, ByVal lpDirectory As String, _
ByVal lpResult As String) As Long
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
'Const NORMAL_PRIORITY_CLASS = &H20&
'Const REALTIME_PRIORITY_CLASS = &H100
'Const INFINITE = -1&
'Const SW_SHOWMAXIMIZED = 3
'Const SW_SHOWMINIMIZED = 2
'Const SW_SHOWNORMAL = 1
'Const STARTF_USESHOWWINDOW = &H1
' API, Type Infos mémoire -------------------------------------------------------------------------------------------
Private Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS)
Private Type MEMORYSTATUS
dwLength As Long 'la taille de la structure.
dwMemoryLoad As Long 'le % de mémoire actuellement utilisé.
dwTotalPhys As Long 'la taille totale de la mémoire physique (en octets).
dwAvailPhys As Long 'la taille de la mémoire physique disponible (en octets).
dwTotalPageFile As Long 'la taille totale que peut atteindre le fichier d'échange (en octets).
dwAvailPageFile As Long 'l'espace disponible dans le fichier d'échange (en octets).
dwTotalVirtual As Long 'la mémoire totale pouvant être utilisée par l'application courante (en octets).
dwAvailVirtual As Long 'l'espace libre totale (en octets).
End Type
'API mise à jour Bdr -------------------------------------------------------------------------------------------------
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" _
(ByVal hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" _
(ByVal hkey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, _
lpData As Any, ByVal cbData As Long) As Long
' déclarations Zlib ----------------------------------------------------------------------------------------
Private Declare Function Compress_Byte_Long_Byte Lib "zlib.dll" Alias "compress" (dest As Any, destLen As Long, Src As Byte, ByVal srcLen As Long) As Long
Private Declare Function Crc32_Byte Lib "zlib.dll" Alias "crc32" (ByVal crc As Long, buffer As Byte, ByVal Length As Long) As Long
Private Declare Function ZLibVer Lib "zlib" Alias "zlibVersion" () As Long
Private Declare Function UnCompress_Byte_Long_Byte Lib "zlib.dll" Alias "uncompress" (dest As Byte, destLen As Long, Src As Byte, ByVal srcLen As Long) As Long
Private Declare Function lCRC32_Byte Lib "zlib.dll" Alias "crc32" (ByVal crc As Long, buffer As Byte, ByVal Length As Long) As Long
' autres déclarations pour Zlib (pour zStream)
Private Declare Function deflate Lib "zlib.dll" (vStream As zStream, ByVal flush As Long) As Long
Private Declare Function deflateEnd Lib "zlib.dll" (vStream As zStream) As Long
Private Declare Function deflateInit2 Lib "zlib.dll" Alias "deflateInit2_" (vStream As zStream, ByVal Level As Long, _
ByVal method As Long, ByVal windowBits As Long, ByVal memLevel As Long, _
ByVal strategy As Long, ByVal Version As String, ByVal stream_size As Long) As Long
'Private Declare Function inflate Lib "zlib.dll" (vStream As zStream, ByVal vflush As Long) As Long
'Private Declare Function inflateEnd Lib "zlib.dll" (vStream As zStream) As Long
'Private Declare Function inflateInit2 Lib "zlib.dll" Alias "inflateInit2_" (vStream As zStream, _
ByVal vWindowBits As Long, ByVal vVersion As String, ByVal vLen As Long) As Long
''compress2 ??
' Types et variables ------------------------------------------------------------------
Private Type zStream
next_in As Long
avail_in As Long
total_in As Long
next_out As Long
avail_out As Long
total_out As Long
Msg As Long
state As Long
zalloc As Long
zfree As Long
opaque As Long
data_type As Long
adler As Long
Reserved As Long
End Type
Private Type typCenteralDirEnd
EndOFCentralDirSignature As Long
NumberOfThisDisk As Integer
NumberOfDiskWithCentralDir As Integer
EntriesInTheCentralDirThisOnDisk As Integer
EntriesInTheCentralDir As Integer
SizeOfCentralDir As Long
OffSetOfCentralDir As Long
ZipFileCommentLength As Integer
End Type
Private Type typComFileHeader
GeneralPurposeBitFlag As Integer
CompressionMethod As Integer
LastModFileTime As Integer
LastModFileDate As Integer
CRC32 As Long
CompressedSize As Long
UncompressedSize As Long
FileNameLength As Integer
ExtraFieldLength As Integer
End Type
Private Type typCentralFileHeaderA
CentralFileHeaderSigniature As Long
VersionMadeBy As Integer
VersionNeededToExtract As Integer
End Type
Private Type typCentralFileHeaderC
FileCommentLength As Integer
DiskNumberStart As Integer
InternalFileAttributes As Integer
ExternalFileAttributes As Long
RelativeOffsetOfLocalHeader As Long
End Type
Private Type typLocalFileHeader
LocalFileHeaderSignature As Long
VersionNeededToExtract As Integer
End Type
Private Type typFileInfos
FileName As String
CompressedSize As Long
UncompressedSize As Long
LastModFileDate As Long
LastModFileTime As Long
End Type
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Private Const MAX_PATH = 260
'Private Const FILE_ATTRIBUTE_READONLY = &H1
'Private Const FILE_ATTRIBUTE_HIDDEN = &H2
'Private Const FILE_ATTRIBUTE_SYSTEM = &H4
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
'Private Const FILE_ATTRIBUTE_ARCHIVE = &H20
'Private Const FILE_ATTRIBUTE_NORMAL = &H80
'Private Const FILE_ATTRIBUTE_TEMPORARY = &H100
'Private Const FILE_ATTRIBUTE_COMPRESSED = &H800
'Private Const MAXDWORD = &HFFFF
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Private Const EndOFCentralDirSignature As Long = &H6054B50
Private Const CentralFileHeaderSigniature As Long = &H2014B50
Private Const LocalFileHeaderSignature As Long = &H4034B50
'Private Const ExtLocSig As Long = &H8074B50
'Autres constantes Zlib pour Inflate/deflate---
Private Const ZLIB_VERSION As String = "1.1.4"
'----------------------------------------------
'Private Const Z_NO_FLUSH As Long = 0
'Private Const Z_PARTIAL_FLUSH As Long = 1
'Private Const Z_SYNC_FLUSH As Long = 2
'Private Const Z_FULL_FLUSH As Long = 3
Private Const Z_FINISH As Long = 4
'----------------------------------------------
Private Const Z_OK As Long = 0
'Private Const Z_STREAM_END As Long = 1
'Private Const Z_NEED_DICT As Long = 2
'Private Const Z_ERRNO As Long = (-1)
'Private Const Z_STREAM_ERROR As Long = (-2)
'Private Const Z_DATA_ERROR As Long = (-3)
'Private Const Z_MEM_ERROR As Long = (-4)
'Private Const Z_BUF_ERROR As Long = (-5)
'Private Const Z_VERSION_ERROR As Long = (-6)
'----------------------------------------------
Private Const Z_DEFAULT_STRATEGY As Long = 0
'Private Const Z_FILTERED As Long = 1
'Private Const Z_HUFFMAN_ONLY As Long = 2
'----------------------------------------------
Private Const Z_BINARY As Long = 0
'Private Const Z_ASCII As Long = 1
'Private Const Z_UNKNOWN As Long = 2
'----------------------------------------------
Private Const Z_DEFLATED As Long = 8
'Private Const Z_NULL As Long = 0
Private Const MAX_MEM_LEVEL As Long = 9
Private Const MAX_WBITS As Long = 15
'----------------------------------------------
Public Enum enumPathChoice
WithoutPath = 0 ' Pas de mémorisation du chemin du fichier
WithCompletePath = 1 ' Avec mémorisation du chemin du fichier
WithRelativePath = 2 ' Avec mémorisation du chemin du fichier par
' rapport au répertoire actuel
End Enum
Public Enum eZipError
zeZLibNotInstalled = 1
zeNotZipFile = 2
zeNoZipOpenFile = 3
zeUnsupportedCompressionMethod = 4
zeChecksumError = 5
zeFileNotFound = 10
zeFileAlreadyExists = 11
zeCantRemoveFile = 12
zeCantCreateFolder = 13
zeStructureError = 14
zeMemory = 15
zeUnKnownError = 16
zeDeflate = 17
zeNoexecutable = 18
End Enum
Public Enum eLevelCompres
Z_NO_COMPRESSION = 0 'pas de compression
Z_BEST_SPEED = 1 'meilleure vitesse, mais compression faible
Z_LOW_LEVEL2 = 2
Z_LOW_LEVEL3 = 3
Z_LOW_LEVEL4 = 4
Z_MIDDLE_LEVEL5 = 5
Z_DEFAULT_COMPRESSION = (-1) 'compression standard optimisée, équivalent niveau 6.
Z_MIDDLE_LEVEL7 = 7
Z_HIGH_LEVEL8 = 8
Z_BEST_COMPRESSION = 9 'meilleure compression, mais vitesse lente
End Enum
' gestion des accents du 31/10/2006
Private Enum eOEMStringTypeConversion
[ANSI to ASCII]
[ASCII to ANSI]
End Enum
Private sASCI As String ' Voir leur remplissage dans Class_Initialize
Private sANSI As String
'
'variables tableau dynamique typé pour remplacer collection d'objets ZipFile, annoncé + rapide
Private Type cls_ZipFile
commun As typComFileHeader
localFileHeaderZF As typLocalFileHeader
centralFileHeaderZFA As typCentralFileHeaderA
centralFileHeaderZFC As typCentralFileHeaderC
FileNameZF As String
extraFieldZF As String
commentZF As String
ASCIIFNZF As String
filedataZF() As Byte
bigFileZF As Boolean
End Type
Private varCommunZF As typComFileHeader
Private tabFiles() As cls_ZipFile 'tableau collection Fichiers à zipper
Private cptTab As Long 'Index et compteur tableau collection Fichiers à zipper
'table pour calcul du crc32
Private arrCRC32(255) As Long
'
' variables internes
Private Fh As Long ' n° d'ouverture du fichier Zip (dézippage)
Private CentralFileHeaderA As typCentralFileHeaderA
Private CentralFileHeaderC As typCentralFileHeaderC
Private CentralDirEnd As typCenteralDirEnd
Private CentralDirEndPos As Long
Private LocalFileHeader As typLocalFileHeader
Private colCentralDirEnd As typCenteralDirEnd ' pour la structure des données
Private ZipFileComment As String ' pour le commentaire du Zip
Private mFileInfos() As typFileInfos
Private mFileCountTemp As Long ' Nb fichiers (y compris les sous-rép)
Private mFileCount As Long ' Nb fichiers corrigé (valeur public)
Private mZipComment As String
Private sFileName As String
Private sASCII_FileName As String
Private ExtraField As String
'Private FileComment As String
Private m_Nombre As Long ' interne à fonction CheckInsert
Private m_LevelComp As Long ' taux de compression
Private arrDelFile() As String ' tableau pour renseigner les fichiers déprov dans Temp à détruire au redémarrage de Windows
' Conversion ASCII étendu <--> ISO 8859-1 (de l'OS)
' Voir Conv_ISO_ASCII et Conv_ASCII_ISO
Private Table_Conversion_ASCII_ISO As Variant
' Conversion ASCII étendu <--> ISO 8859-1 (de VB)
' Voir Conv_ISO_ASCII et Conv_ASCII_ISO
Private Table_Conversion_ISO_ASCII As Variant
Public Event ProgressExtract(ByVal Percent As Long, ByRef Cancel As Boolean) 'en passant Cancel à True on stoppe l'opération
Public Event ProgressLoad(ByVal Percent As Long, ByRef Cancel As Boolean) 'en passant Cancel à True on stoppe l'opération
Public Event Status(ByVal Text As String)
Public Event ZipError(ByVal Number As eZipError, ByVal Description As String, Cancel As Boolean) ' en passant Cancel à True on intervient sur l'opération
Public Event FileZipErr(strFilePath As String, lgErr As Long, strDescription As String)
'
Public Property Get FileCount() As Long
' Renvoie le nombre de fichiers déjà ajoutés au tableau des éléments à zipper
On Error GoTo Erreur
FileCount = UBound(tabFiles)
Exit Property
Erreur:
FileCount = 0 'il y erreur s'il n'y a pas de données dans le tableau
End Property
Public Property Get Comment() As String
' Relit le commentaire du Zip
Comment = ZipFileComment
End Property
Public Property Let Comment(s As String)
' Dépose un Commentaire au Zip
ZipFileComment = s
colCentralDirEnd.ZipFileCommentLength = Len(s)
End Property
Public Property Get FileName(ByVal index As Long) As String
' Renvoie le nom du fichier dont l'index est Index (judicieux, non ?)
If index > UBound(tabFiles) Then Exit Property
FileName = tabFiles(index).FileNameZF
End Property
Public Property Get SizeCompressed(ByVal index As Long) As Long
' Renvoie la taille compressée du fichier
If index > UBound(tabFiles) Then Exit Property
SizeCompressed = tabFiles(index).commun.CompressedSize
End Property
Public Property Get SizeUncompressed(ByVal index As Long) As Long
' Renvoie la taille décompressée (originale) du fichier
If index > UBound(tabFiles) Then Exit Property
SizeUncompressed = tabFiles(index).commun.UncompressedSize
End Property
Public Function FileDel(ByVal index As Long) As Boolean
' Supprime un des fichiers à zipper du tableau (avant création du zip)
On Error GoTo Erreur
Dim I As Long
If index > UBound(tabFiles) Or index < 1 Then Exit Function
If index < UBound(tabFiles) Then ' si la suppression n'est pas le dernier enregistrement
For I = index + 1 To UBound(tabFiles)
'transfert tous les éléments qui suivent la suppression à partir de sa place dans le tableau
tabFiles(I - 1).commun = tabFiles(I).commun
tabFiles(I - 1).localFileHeaderZF = tabFiles(I).localFileHeaderZF
tabFiles(I - 1).centralFileHeaderZFA = tabFiles(I).centralFileHeaderZFA
tabFiles(I - 1).centralFileHeaderZFC = tabFiles(I).centralFileHeaderZFC
tabFiles(I - 1).FileNameZF = tabFiles(I).FileNameZF
tabFiles(I - 1).extraFieldZF = tabFiles(I).extraFieldZF
tabFiles(I - 1).commentZF = tabFiles(I).commentZF
tabFiles(I - 1).ASCIIFNZF = tabFiles(I).ASCIIFNZF
tabFiles(I - 1).filedataZF = tabFiles(I).filedataZF
tabFiles(I - 1).bigFileZF = tabFiles(I).bigFileZF
Next
End If
'supprime le dernier enregistrement du tableau (dans tous les cas)
If UBound(tabFiles) > 1 Then 'si on a encore + d'1 enregistremt ds le tableau
ReDim Preserve tabFiles(1 To UBound(tabFiles) - 1)
Else 'si on est le dernier enregist du tableau
Erase tabFiles 'on l'efface directement
End If
cptTab = cptTab - 1 'maintenance du compteur de tabFiles
FileDel = True
Exit Function
Erreur:
FileDel = False
End Function
Public Function FileAdd(ByVal FilePath As String, _
ByVal PathChoice As enumPathChoice, _
Optional ByVal RecurseDirectories As Boolean = False, _
Optional excludeCRC32 As Boolean = False) As Long
' Ajoute un ou des fichiers à la collection/tableau
' FilePath : Fichier avec son chemin complet
' PathChoice : Définit si on veut garder le chemin du fichier
' RecurseDirectories : Définit s'il faut chercher les fichiers dans les sous-répertoires
Dim NbFichiers As Long
Dim StrFilter As String 'variable filtre de FindFirstFile ...
' Par défaut, pas d'ajout de fichier
FileAdd = 0
' Récupère le nom réel complet(au cas où on utilise des \..\
' ou bien si on ne précise pas de chemin
'par api
Dim buffer As String, Ret As Long
buffer = Space(IIf(Len(FilePath) < 255, 255, Len(FilePath) + 1)) 'parfois des noms de fichiers provenance Internet sont > 255 de windows
Ret = GetFullPathName(FilePath, Len(buffer), buffer, "")
FilePath = Left(buffer, Ret)
If InStr(1, FilePath, "*") + InStr(1, FilePath, "?") = 0 Then ' il s'agit d'1 seul fichier à zipper
'si le fichier existe bien
If FichierExiste(FilePath) Then
' On l'insère parmi les fichiers à zipper
NbFichiers = NbFichiers + FileAddSingle(FilePath, PathChoice, excludeCRC32)
Else
Exit Function
End If
Else ' détection des fichiers concernés
'fonction checkInsert : recherche les fichiers correspondants au filtre, avec gestion
'option récursif ou pas, et ajoute les fichiers trouvés au tableau-collection à zipper.
StrFilter = GetFileName(FilePath) 'extrait le nom du fichier et son extension avec ou pas des caractères génériques
'pour servir de filtre aux Api FindFirstFile ...
NbFichiers = NbFichiers + CheckInsert(Replace(FilePath, StrFilter, ""), StrFilter, 0, PathChoice, RecurseDirectories, excludeCRC32)
End If 'traitement orienté 1 fichier ou plusieurs avec caractères génériques
' Retourne le nombre de fichiers ajoutés
FileAdd = NbFichiers
End Function
Private Function FileAddSingle(ByVal FilePath As String, _
ByVal PathChoice As enumPathChoice, _
Optional excludeCRC32 As Boolean = False) As Long
' C'était la fonction originale (ou presque de l'auteur)
' On l'utilise pour ajouter un (seul) fichier au tableau
' (Voir FileAdd)
FileAddSingle = 0
' test éliminé pour éliminer redondance test existance, en effet, sauf si FileAddSingle est appelée
' seule, l'existance du fichier a déjà été testée dans les procédures ou fonctions qui la précédent,
' d'autre part si cette fonction est appelée en autonome, l'absence éventuelle du fichier sera traitée dans
' la gestion d'erreurs. Evite donc éventuel test redondant !
''' ' On ressort si le fichier n'existe pas
''' If FichierExiste(FilePath) = False Then
''' Exit Function
''' End If
Dim lgTab As Long, cZipError As Long, d As Date
On Error GoTo errFAS
d = FileDateTime(FilePath)
'pour économiser des ressources ajoute 1 enregistrement au tableau pour stocker le tableau
'd'octets comprimés directement dans le tableau typé. Si lors du contrôle du compress ou d'1
'erreur, cet enregistrement devait être supprimé il suffira de faire 1 redim - 1 du tableau
'et du compteur pour le supprimer, mais on évite de transférer les données compressées dans
'1 tableau d'octets qu'il faudra copier ensuite dans ce tableau typé et donc doubler l'utilisation
'mémoire avant de supprimer les données de ce tableau intermédiaire et faire 1 copie de plus !
lgTab = UBound(tabFiles) + 1
cptTab = lgTab 'place le cpteur sur 1 nouvel enregistrement
ReDim Preserve tabFiles(1 To lgTab)
' Par défaut, le nom du fichier est zippé sans le chemin
' mais il faut (ici) fournir le nom avec le chemin
' Par défaut, on ne garde que le nom du fichier (pas le path)
sFileName = GetFileName(FilePath)
sASCII_FileName = OEMConvert(sFileName, [ANSI to ASCII])
With varCommunZF
.FileNameLength = Len(sFileName)
.LastModFileDate = GetDOSDate(d)
.LastModFileTime = GetDOSTime(d)
'lance la compression et stocke éventuelles erreurs qui seront gérées en amont
cZipError = CompressBytes(FilePath, tabFiles(cptTab).filedataZF, .CompressedSize, .UncompressedSize, excludeCRC32)
' Si on veut garder le chemin, on le dit ici
Select Case PathChoice
Case WithoutPath ' Sans le chemin
' rien à faire, c'est comme ça par défaut
Case WithCompletePath ' Avec le chemin complet
sFileName = FilePath
sASCII_FileName = OEMConvert(sFileName, [ANSI to ASCII])
.FileNameLength = Len(sFileName)
Case WithRelativePath ' Avec un chemin relatif
' ... relatif au chemin actuel
If Left(UCase(FilePath), Len(CurDir)) = UCase(CurDir) Then
' Si le chemin actuel est dans le nom du fichier, Ok
sFileName = Mid(FilePath, Len(CurDir) + 2)
sASCII_FileName = OEMConvert(sFileName, [ANSI to ASCII])
.FileNameLength = Len(sFileName)
Else
' Sinon, on met le chemin complet
sFileName = FilePath
sASCII_FileName = OEMConvert(sFileName, [ANSI to ASCII])
.FileNameLength = Len(sFileName)
End If
End Select
End With
'controle qu 'il n'y a pas d'erreur et complète l'ajout de l'enregistrement du fichier au tableau
'ou le supprimer en cas d'erreur
Select Case cZipError
Case 0, 7 ' c'est OK on complète les données au tableau
With tabFiles(cptTab)
.commun = varCommunZF
.localFileHeaderZF = LocalFileHeader
.centralFileHeaderZFA = CentralFileHeaderA
.centralFileHeaderZFC = CentralFileHeaderC
.FileNameZF = sFileName
.ASCIIFNZF = sASCII_FileName
If cZipError = 7 Then
.bigFileZF = True
RaiseEvent FileZipErr(FilePath, 7, "Fichier trop important pour être compressé, le fichier a été empacté dans le fichier final mais sans compression !")
End If
End With
' Signale que l'ajout c'est bien passé (tout est dans le tableau)
FileAddSingle = 1
Case Else 'erreur qui entraîne retrait de l'enregistrement ajouté au tableau
'on n'ajoute pas l'enregistrement au tableau, on replace l'index à la bonne valeur
cptTab = cptTab - 1
'supprime l'enregistrement ajouté au tableau
ReDim Preserve tabFiles(1 To cptTab)
'par défaut FileAddSingle est à 0 donc on le laisse
'on gère le message d'erreur en fonction de son n°
If cZipError = 70 Then 'permission refusée (violation de partage)
RaiseEvent FileZipErr(FilePath, 70, "Violation de Partage, le fichier a été exclus du traitement")
Else 'autre
RaiseEvent FileZipErr(FilePath, cZipError, "Erreur non testée, le fichier a été exclus du traitement")
End If
End Select
On Error GoTo 0
Exit Function
errFAS:
If Err.Number = 9 Then 'au cas où le tableau ne serait pas encore initialisé on aurait indice hors plage
lgTab = 1
Resume Next
Else
'on n'ajoute pas l'enregistrement au tableau, on replace l'index à la bonne valeur
cptTab = cptTab - 1
'supprime l'enregistrement ajouté au tableau
If cptTab > 0 Then
ReDim Preserve tabFiles(1 To cptTab)
Else
ReDim tabFiles(0)
End If
'par défaut FileAddSingle est à 0 donc on le laisse
RaiseEvent FileZipErr(FilePath, Err.Number, "Erreur non testée, le fichier a été exclus du traitement")
Exit Function
End If
End Function
Public Function WriteZip(FilePath As String, _
Optional OverWrite As Boolean) As Boolean
' Crée le fichier ZIP lui même à partir du tableau élaboré
' FilePath : Nom du fichier ZIP avec son chemin complet
' Overwrite : On l'écrase s'il existe déjà ?
Dim l As Long
Dim Fh As Long
Dim I As Long
' Si le Zip existe déjà, on le détruit (si Overwrite est à True)
If FichierExiste(FilePath, False) Then
If OverWrite Then
Kill FilePath
Else
RaiseEvent FileZipErr(FilePath, 11, "Création -No Overwrite- du Zip abandonnée car le fichier existe déjà")
Erase tabFiles
cptTab = 0
WriteZip = False
Exit Function
End If
End If
' Ouvre le Zip et enregistre chacune des structures des fichiers du tableau
Fh = FreeFile
Open FilePath For Binary As #Fh
For I = 1 To UBound(tabFiles)
WriteLocalFileHeader Fh, I
Next
l = Seek(Fh)
For I = 1 To UBound(tabFiles)
WriteCentralFileHeader Fh, I
Next
With colCentralDirEnd
.EndOFCentralDirSignature = &H6054B50
.EntriesInTheCentralDirThisOnDisk = UBound(tabFiles)
.EntriesInTheCentralDir = .EntriesInTheCentralDirThisOnDisk
.SizeOfCentralDir = Seek(Fh) - l
.OffSetOfCentralDir = l - 1
End With
Put #Fh, , colCentralDirEnd ' Ajoute la description de structure
Put #Fh, , ZipFileComment ' Ajoute le commentaire général
Close #Fh
Erase tabFiles
cptTab = 0
' Signale que la création c'est bien passée
WriteZip = True
End Function
Public Function ZipOpen(ByVal ZipPath As String) As Boolean
Dim Cancel As Boolean
RaiseEvent Status("Ouverture du Zip")
ZipClose
If FichierExiste(ZipPath) = False Then
RaiseEvent ZipError(zeFileNotFound, "Le fichier " & ZipPath & " n'existe pas", False)
Exit Function
End If
' Ouverture du fichier Zip en binaire pour lecture indexée
Fh = FreeFile
Open ZipPath For Binary As #Fh
DoEvents
' Récupère l'offset de la structure descriptive du Zip
''' CentralDirEndPos = zGetCentralDirEndPos(fh) 'cette opération peut être longue selon la taille
CentralDirEndPos = ybGetCentralDirEndPos(ZipPath)
'j'y ai ajouté renvoi de la progression 100%=95% de ZipOpen
If CentralDirEndPos > 0 Then
ZipOpen = True
RaiseEvent Status("Zip ouvert")
ElseIf CentralDirEndPos < 0 Then 'teste qu'on a annulé le chargement lors de zGetCentralDirEndPos
RaiseEvent Status("Chargement annulé par l'utilisateur")
Exit Function
Else
RaiseEvent ZipError(zeNotZipFile, "Le fichier " & ZipPath & " n'est pas un fichier Zip", False)
Exit Function
End If
'---------- Récupère les infos concernant les fichiers inclus dans le Zip
' NB : Quand on interroge le fichier ZIP, il renvoie un nombre de fichiers
' Or, parmi ces fichiers, il y a une ligne pour chaque sous répertoire créé
' et ne faut pas les comptabiliser dans le nombre (UncompressedSize = 0).
' L'appel de zReadCentralDirEnd va renvoyer un nombre erroné que nous allons
' corriger en scrutant tout le contenu du zip.
' --> Le maintient de cette partie de code est donc primordiale pour garder
' un chiffre correct !
' Vérifie que la DLL est bien là (et répond)
If Len(ZLibVersion) = 0 Then
RaiseEvent ZipError(zeZLibNotInstalled, "La librairie Zlib n'est pas installée", False)
Exit Function
End If
Dim r As Long, Temp As String, Ret As Boolean
' Récupère l'emplacement de la structure descriptive du Zip
' (dont le nombre de fichiers et le commentaire du Zip)
Call zReadCentralDirEnd(CentralDirEndPos)
' Prépare le tableau d'accueil des données
ReDim mFileInfos(mFileCountTemp) As typFileInfos
' Se positionne au début de la structure d'infos du contenu
Seek #Fh, CentralDirEnd.OffSetOfCentralDir + 1
' Va querir les données (y cause bien, hein ?)
r = 1
Do While r <= mFileCountTemp
' Cherche les infos les une après les autres (important)
Ret = zReadCentralFileHeader(Temp)
' On ne tient pas compte des sous-répertoires identifiés par taille à 0
''' Do While Ret And (varCommunZF.UncompressedSize = 0) ' FAUX ==> un fichier peut être à 0
Do While Ret And (CentralFileHeaderC.InternalFileAttributes = FILE_ATTRIBUTE_DIRECTORY)
' Si on vient de tomber sur un sous-répertoire, on
' recommence la lecture
mFileCountTemp = mFileCountTemp - 1
Ret = zReadCentralFileHeader(Temp)
DoEvents
Loop
If Ret Then ' si on n'est pas arrivé à la fin des données
' et les mémorise
mFileInfos(r).FileName = Temp
mFileInfos(r).CompressedSize = varCommunZF.CompressedSize
mFileInfos(r).UncompressedSize = varCommunZF.UncompressedSize
mFileInfos(r).LastModFileDate = varCommunZF.LastModFileDate
mFileInfos(r).LastModFileTime = varCommunZF.LastModFileTime
End If
r = r + 1
DoEvents
Loop
' Rafraichit le nombre réel de fichiers
mFileCount = mFileCountTemp
'renvoie l'évènement
RaiseEvent ProgressLoad(100, Cancel) 'ici cancel n'est pas géré car il ne sert + !
DoEvents
End Function
Public Sub ZipClose()
If Fh <> 0 Then
Close #Fh
Fh = 0
RaiseEvent Status("Zip fermé")
End If
CentralDirEndPos = 0
End Sub
Public Function ExtractSingleFile(ByVal FileNumber As Long, _
ByVal FolderPath As String, _
Optional ByVal PreservePath As Boolean, _
Optional ByVal OverWrite As Boolean, _
Optional ByVal KeepModDate As Boolean) As Boolean
Dim l As Long, Ret As Boolean
Dim sFileName As String
Dim FilePos As Long
Dim Cancel As Boolean
ExtractSingleFile = False 'par défaut placé à faux, car si sortie prématurée => erreur, sinon placé à true à la fin
If Len(ZLibVersion) = 0 Then
Exit Function
End If
RaiseEvent Status("Début d'extraction")
If CentralDirEndPos = 0 Then
RaiseEvent ZipError(zeNoZipOpenFile, "Il n'y a pas de fichier Zip ouvert", False)
Exit Function
End If
If FolderExists(FolderPath) = False Then
If Not zCreateFolder(FolderPath) Then
RaiseEvent ZipError(zeCantCreateFolder, "Impossible de créer le répertoire " & FolderPath, False)
Exit Function
End If
End If
' Pour lire un fichier en particulier, il faut relire le fichier dans l'ordre.
' Il faut donc lire les entêtes de chaque fichier avant de trouver le bon
If zReadCentralDirEnd(CentralDirEndPos) Then
Seek #Fh, CentralDirEnd.OffSetOfCentralDir + 1
For l = 1 To mFileCount
Ret = zReadCentralFileHeader(sFileName)
' Les sous-répertoires inclus dans le Zip ont une taille compressée
' et décompressée de zéro octets. On recherche l'entrée suivante
''' Do While Ret And (varCommunZF.UncompressedSize = 0) ' FAUX ==> un fichier peut être à 0
Do While Ret And (CentralFileHeaderC.InternalFileAttributes = FILE_ATTRIBUTE_DIRECTORY)
Ret = zReadCentralFileHeader(sFileName)
DoEvents
Loop
If Ret Then ' si on n'est pas arrivé à la fin des données
' Précaution : Quand le chemin comporte le nom du disque, on a un ':'
sFileName = Replace(sFileName, ":", "_") ' ???? si lettre non gérée lors du zip
If l = FileNumber Then
If PreservePath Then
' Ajoute le répertoire du Zip au répertoire courant
zCheckFolder FolderPath, zGetFilePath(sFileName)
Else
' Ou alors ne garde que le nom du fichier
sFileName = zGetFileName(sFileName)
End If
' Mémo position dans le fichier car l'extraction déplace l'offset
FilePos = Seek(Fh)
RaiseEvent Status("Extraction ...\" & sFileName)
If FichierExiste(FolderPath & "\" & sFileName) Then
If OverWrite Then
If zRemoveFile(FolderPath & "\" & sFileName) Then
If zExtractFile(FolderPath & "\" & sFileName) = False Then
' Repositionne l'offset
Seek Fh, FilePos
Exit Function
End If
Else
RaiseEvent ZipError(zeCantRemoveFile, "Ne peut pas supprimer le fichier " & FolderPath & "\" & sFileName, False)
Exit Function
End If
Else
RaiseEvent ZipError(zeFileAlreadyExists, "Le fichier " & FolderPath & "\" & sFileName & " existe déjà", False)
Exit Function
End If
Else
If zExtractFile(FolderPath & "\" & sFileName) = False Then
' Repositionne l'offset
Seek Fh, FilePos
Exit Function