Compression de fichier en ZIP (VBA)

Question

Bonjour à tous: Voici mon problème, au cours de mon programme, je souhaite compresser un fichier en .ZIP. Mon applis se bloque au moment où WINZIP s'ouvre et le message suivant suivant apparait ===> voir PJ Voici ma macro, en rouge figure l'endroit du bug Merci pour votre aide Bonne journée à tous Dim p, d, groupe(0 To 50) As String Dim i, j, t, t1, ok, maxlig As Integer Declare Function WaitForSingleObject Lib "Kernel32" _ (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long Declare Function OpenProcess Lib "Kernel32" _ (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, _ ByVal dwProcessId As Long) As Long Public Const INFINITE = &HFFFF Sub compilation_bp04() 'supprime temporairement les messages d'alerte et la mise à jour de l'écran Application.DisplayAlerts = False Workbooks("data.xls").Sheets(1).Cells(16, 6) = "Ouverture des fichiers BP04 en cours ..." Application.ScreenUpdating = False p = ActiveWorkbook.Path maxlig = 300 'Enregistrement sous databis.xls Workbooks("data.xls").Activate Workbooks("data.xls").Sheets(1).Cells(16, 6) = "Copie de data.xls (S-1) en databis.xls" 'Workbooks("data.xls").Sheets(1).Cells(18, 6) = Workbooks("data.xls").Sheets(2).Cells(4, 10).Text Application.ScreenUpdating = True Application.ScreenUpdating = False ActiveWorkbook.SaveAs Filename:=p + "\databis.xls" 'ouverture des fichiers t = 0 While Cells(t + 2, 1) <> "" groupe(t) = Cells(t + 2, 1).Value Workbooks.Open Filename:=p + "" + groupe(t) + ".xls" Workbooks("databis.xls").Activate Sheets("Index").Select t = t + 1 Wend 'Copie des feuilles BDDF,DRBP, GROUPES t = 0 While groupe(t) <> "" Windows(groupe(t) & ".xls").Activate Sheets(1).Select 'Sheets(1).Copy after:=Workbooks("databis.xls").Sheets(t + 1) Range("A1:I" & maxlig).Select Selection.Copy Workbooks("databis.xls").Activate Sheets(t + 2).Select Sheets(t + 2).Name = groupe(t) 'BDDF,DR,GROUPES Range("B1").Select ActiveSheet.PasteSpecial Format:=3, Link:=1, DisplayAsIcon:=False, _ IconFileName:=False Windows(groupe(t) & ".xls").Activate ActiveWorkbook.Close t = t + 1 Wend 'Tri des feuilles Workbooks("databis.xls").Sheets(1).Cells(16, 6) = " Tri des zones de données en cours ..." Application.ScreenUpdating = True Application.ScreenUpdating = False For j = 2 To Sheets.Count: Sheets(j).Select: Range("A7:J" & maxlig).Select Selection.Sort Key1:=Range("A7"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom Next j 'ajout d'une colonne a gauche avec le code et Nb ou Cx 'For t = 2 To Sheets.Count ' Sheets(t).Activate ' 'Range("A1:I" &maxlig).Select ' 'Selection.Copy ' 'Range("B1").Select ' 'ActiveSheet.PasteSpecial Format:=3, Link:=1, DisplayAsIcon:=False, _ ' ' IconFileName:=False ' Range("A7").Select ' ActiveCell.FormulaR1C1 = "=RC[1] &""_"" &RC[3]" ' Range("A7").Select ' Selection.Copy ' Range("A8:A" & maxlig).Select ' ActiveSheet.Paste ' Range("A1").Select 'Next t 'test si le contrôle des fichiers est valide Sheets("Index").Select If Range("F6").Text = "Erreur" Then MsgBox "Anomalie dans les fichiers! Refermer sans enregistrer.", vbExclamation, "Attention" GoTo fin End If 'Enregistrement sous date de cumul Sheets(1).Select Sheets(1).Cells(16, 6) = "Archivage du Data.xls ..." Application.ScreenUpdating = True 'pour afficher le message Application.ScreenUpdating = False Sheets(1).Cells(16, 6) = "" Sheets(groupe(0)).Select d = Mid(Range("J4").Value, 10) 'cumul au jj mois année Sheets(1).Select Range("F18").Value = d 'd1 = "Data_" & Right(d, 2) & Right("0" & Month(d), 2) & Left(d, 2) d1 = "Data_" & "S" & Right("0" & Cells(19, 6).Text, 2) ActiveWorkbook.SaveAs Filename:=p & "" & d1 & ".xls" 'Enregistrement sous data.xls Cells(16, 6) = "Enregistrement data.xls ..." Application.ScreenUpdating = True Application.ScreenUpdating = False Sheets(1).Cells(16, 6) = "" ActiveWorkbook.SaveAs Filename:=p & "\data.xls" 'archivage du data en zip 'Répertoire ou est installé WinZip '===> CheminWinZip = "C:\Program Files\WinZip\Winzip8.1_FR" 'Nom du fichier Zip a créér '===> NomArchive = p & "\Data" & d1 & ".zip" 'Nom du dossier à compresser '===> QuelFichier = p & "" & d1 & ".xls" '===> chemin = CheminWinZip & "winzip32.exe -a """ & NomArchive & """ """ & QuelFichier & """" '===> While LanceEtAttendLaFin(chemin) <> 0: Wend 'teste si le zip est terminé '===> Kill p & "" & d1 & ".xls" fin: Application.ScreenUpdating = True MsgBox "Traitement terminé!", vbExclamation, "Fusion des feuilles" ActiveWorkbook.Close savechanges = True Application.DisplayAlerts = True End Sub Function LanceEtAttendLaFin(ByVal CheminComplet As String) As Long Dim ProcessHandle As Long Dim ProcessId As Long, ret& ProcessId = Shell(CheminComplet, vbNormalFocus) ProcessHandle = OpenProcess(&H1F0000, 0, ProcessId) LanceEtAttendLaFin = WaitForSingleObject(ProcessHandle, INFINITE) End Function

Doc VB · Answer

Salut,

Quelle est cette PJ dont tu parles ? Quel est le contenu du message de winzip ? S'il s'agit de la fenêtre relative à l'enregistrement du programme, tu peux essayer de simuler le clic sur le bon bouton... Si c'est ça tu peux aussi utiliser un autre outil que WINZIP pour compresser au format ZIP sans avoir de message à l'écran. Regarde par exemple du côté de 7zip (http://www.7-zip.org/fr/).

NHenry · Answer

Bonjour

Tu est sûr que c'est du .NET, ça reseemble vachement à du VBA.
Qu'est-ce PJ ?
Color ton code, c'est quasiement illisible :
http://charles.racaud.free.fr/code-syntaxing/

Balèse la personne qui a pensé au pansement à penser (ou à panser, pensée).
VB (6, .NET1&2), C++, C#.Net1

cavo789 · Answer

Bonjour

As-tu déjà essayé la fonction que j'ai développée et déposée sur ce site ?  Elle permet d'utiliser la fonction ZIP de Windows et donc de se passer de WinZip.  

Christophe

Compression de fichier en ZIP (VBA)

3 réponses

Votre réponse

Discussions similaires