Sub Cracker()
Dim fso As Object
Dim zipPath As String
Dim xlsmPath As String
Dim xlsmCopyPath As String
Dim extractFolder As String
Dim ApplicationArchivage As Object
Dim FichierArchive As Variant
Dim DossierDestination As Variant
Dim cheminFichier As String
Dim fichier As Integer
Dim contenuFichier() As Byte
Dim chaineRecherchee As String
Dim nouvelleChaine As String
Dim i As Long
Dim j As Long
Dim trouve As Boolean
Dim FichierASupprimer As String
Dim Wbk As Workbook
Dim dossier As Object
Dim fichierr As Object
Set Wbk = ActiveWorkbook
'convertion en zip
xlsmPath = "D:\Users\Nicolas\Desktop\" & Wbk.Name
zipPath = "D:\Users\Nicolas\Desktop\Temp.zip"
' Dossier où le contenu du .zip sera extrait
Set fso = CreateObject("Scripting.FileSystemObject")
fso.CopyFile xlsmPath, zipPath
'extraction dans dossier
FichierArchive = zipPath 'l'archive à décompresser
DossierDestination = "D:\Users\Nicolas\Desktop\TestZip" 'le dossier dans lequel les fichiers seront décompressés
'vérification du format du chemin du dossier de destination
If Right(DossierDestination, 1) <> "\" Then DossierDestination = DossierDestination & "\"
'Décompression
Set ApplicationArchivage = CreateObject("Shell.Application")
ApplicationArchivage.Namespace(DossierDestination).CopyHere ApplicationArchivage.Namespace(FichierArchive).Items
Set ApplicationArchivage = Nothing
'""""""""""""""""""""""""""""""""""""""""""""""""""""""""
' Spécifiez le chemin du fichier
cheminFichier = "D:\Users\Nicolas\Desktop\TestZip\xl\vbaProject.bin"
' Spécifiez la chaîne à rechercher et la nouvelle chaîne
chaineRecherchee = "..." 'pas mis exprès pour le forum
nouvelleChaine = "..." 'pas mis exprès pour le forum
' Ouvrir le fichier en mode binaire
fichier = FreeFile
Open cheminFichier For Binary Access Read Write As #fichier
' Lire tout le fichier dans un tableau de bytes
ReDim contenuFichier(LOF(fichier) - 1)
Get #fichier, , contenuFichier
' Recherche de la chaîne
For i = 0 To UBound(contenuFichier) - Len(chaineRecherchee)
trouve = True
For j = 0 To Len(chaineRecherchee) - 1
If contenuFichier(i + j) <> Asc(Mid(chaineRecherchee, j + 1, 1)) Then
trouve = False
Exit For
End If
Next j
If trouve Then
' Remplacer la chaîne
For j = 0 To Len(nouvelleChaine) - 1
contenuFichier(i + j) = Asc(Mid(nouvelleChaine, j + 1, 1))
Next j
Exit For
End If
Next i
' Réécrire le fichier avec les modifications
Put #fichier, , contenuFichier
' Fermer le fichier
Close #fichier
'""""""""""""""""""""""""""""""""""""""""""""""""""""""""
FichierASupprimer = zipPath '<- le nom du fichier à supprimer
If Len(Dir(FichierASupprimer)) > 0 Then Kill FichierASupprimer
'""""""""""""""""""""""""""""""""""""""""""""""""""""""""
ZipRepertoire
'""""""""""""""""""""""""""""""""""""""""""""""""""""""""
'RenommerZipEnXlsm
Dim cheminDossier As String
Dim nomFichierZip As String
Dim nomFichierXlsm As String
Dim cheminCompletZip As String
Dim cheminCompletXlsm As String
' Spécifiez le chemin du dossier contenant le fichier zip
cheminDossier = "D:\Users\Nicolas\Desktop\" ' Modifier le chemin selon votre configuration
' Spécifiez le nom du fichier zip
nomFichierZip = "MaSauvegarde.zip" ' Modifier le nom du fichier zip
' Spécifiez le nom du fichier xlsm
nomFichierXlsm = "MaSauvegarde.xlsm" ' Modifier le nom du fichier xlsm
' Construire les chemins complets des fichiers
cheminCompletZip = cheminDossier & nomFichierZip
cheminCompletXlsm = cheminDossier & nomFichierXlsm
' Vérifiez si le fichier zip existe
If Dir(cheminCompletZip) <> "" Then
' Renommer le fichier zip en fichier xlsm
Name cheminCompletZip As cheminCompletXlsm
MsgBox "Le fichier a été renommé avec succès.", vbInformation
Else
MsgBox "Le fichier zip spécifié n'existe pas.", vbExclamation
End If
'""""""""""""""""""""""""""""""""""""""""""""""""""""""""
'Chemin du dossier dont vous voulez supprimer le contenu
cheminDossier = "D:\Users\Nicolas\Desktop\TestZip"
' Créer une instance de FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")
' Obtenir le dossier
Set dossier = fso.GetFolder(cheminDossier)
' Supprimer tous les fichiers dans le dossier
For Each fichierr In dossier.Files
fichierr.Delete
Next fichierr
' Supprimer tous les sous-dossiers dans le dossier
Dim sousDossier As Object
For Each sousDossier In dossier.SubFolders
sousDossier.Delete True
Next sousDossier
'""""""""""""""""""""""""""""""""""""""""""""""""""""""""
'Spécifiez le chemin complet du fichier ( ZIP ) à supprimer
nomFichierZip = "D:\Users\Nicolas\Desktop\MaSauvegarde.zip"
' Vérifiez si le fichier existe avant de tenter de le supprimer
If Dir(nomFichierZip) <> "" Then
' Supprimez le fichier
'Kill nomFichierZip
MsgBox "Le fichier a été supprimé avec succès.", vbInformation
Else
MsgBox "Le fichier spécifié n'existe pas.", vbExclamation
End If
'""""""""""""""""""""""""""""""""""""""""""""""""""""""""
' Libérer les objets
Set fichierr = Nothing
Set dossier = Nothing
Set fso = Nothing
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub ZipRepertoire()
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim Source, Destination, MyHex, MyBinary, i
Dim oShell, oApP, oFolder, oCTF, oFile
Dim oFileSys
'Spécifiez le répertoire
Source = "D:\Users\Nicolas\Desktop\TestZip"
Destination = "D:\Users\Nicolas\Desktop\MaSauvegarde.zip"
MyHex = _
Array(80, 75, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
For i = 0 To UBound(MyHex)
MyBinary = MyBinary & Chr(MyHex(i))
Next
Set oShell = CreateObject("WScript.Shell")
Set oFileSys = CreateObject("Scripting.FileSystemObject")
'Création de la base du fichier zip.
Set oCTF = oFileSys.CreateTextFile(Destination, True)
oCTF.Write MyBinary
oCTF.Close
Set oCTF = Nothing
Set oApP = CreateObject("Shell.Application")
Set oFolder = oApP.Namespace(Source)
If Not oFolder Is Nothing Then _
oApP.Namespace(Destination).CopyHere oFolder.Items
Set oFile = Nothing
On Error Resume Next
Do While (oFile Is Nothing)
'Attention: provoque une erreur 70 si un des fichiers à zipper
'est toujours ouvert.
Set oFile = oFileSys.OpenTextFile(Destination, ForAppending, False)
If Err.Number <> 0 Then
Err.Clear
End If
Loop
Set oFile = Nothing
Set oFileSys = Nothing
End Sub
