Script pour archiver les fichiers les plus récents de mon ordinateur.

Version imprimable

Voir 40 message(s) de cette discussion en une page

comment faire un script pour compressé des fichiers dans un dossier d’archivage de sauvegarde. La condition à respecter : les fichiers dans un dossier doivent être les plus récent, on n’archive pas les vieux fichiers mais leur date de création ou de modification doit être supérieur à une date d’un fichier x donné. Par exemple : mon fichier donnée se trouve dans le C:\\sauvegarde et il a comme date le 20/05/2014 alors je dois archiver les fichiers du 14/05/2014 au 20/05/2014. Je pense il faut faire un script VBS comme je l’ai fait pour la suppression des vieux fichiers (remplacer clean par copy mais je n’y parviens pas)
Voici le script pour la suppression des fichiers :

Code:

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
 'Initialisation du nom du fichier
   sFileName = "T:\PRO\Sauvegarde\testFichierEfface\Verification\Verification_Sauvegarde.txt"
 
 ' Récupérer l'instance du fichier.
   Set fso = CreateObject("Scripting.FileSystemObject")
 
 ' On récupére la date de modification du fichier .txt ou la date de la dernière sauvegarde est inscrite
If fso.FileExists("T:\PRO\Sauvegarde\testFichierEfface\Verification\Verification_Sauvegarde.txt" ) = True Then 
 Set oFile = fso.GetFile("T:\PRO\Sauvegarde\testFichierEfface\Verification\Verification_Sauvegarde.txt" ) 
 dtmDateModifie = oFile.DateLastModified
 Set oFolder = Nothing 
Else 
 dtmDateModifie = "Unknown" 
End if 
 
‘Repertoire ou sont stockés les fichiers 
DossierSauvegarde = "T:\PRO\Sauvegarde\testFichierEfface" 
 
'Nombre de jours de conservation des Fichiers  (28 jours)
AgeMaximalFichiers = "28" 
 
'Comptage des fichiers effaces 
NbFichiersEffaces = 0 
NbDossiersEffaces = 0
 
'Nom du Fichier  Log  suivant  La Date  systeme
LogFile_Date = "FichierLog_" & Day(Now) & "_" & Month(Now) & "_" & Year(Now)
 
'Initialisation des objets 
Set fso = CreateObject("Scripting.FileSystemObject" )
if not fso.fileExists("T:\PRO\Sauvegarde\testFichierEfface\logs\" & LogFile_Date & ".txt") Then
Set OutPut = fso.CreateTextFile("T:\PRO\Sauvegarde\testFichierEfface\logs\" & LogFile_Date & ".txt",8)
OutPut.WriteLine "*************************************************************************************************"
OutPut.WriteLine "Nous sommes Le " &  Day(Now) & "/" & Month(Now) & "/" & Year(Now)& " La liste des Fichiers Supprimés a cette heure " & Time & " est :"  
OutPut.WriteLine "*************************************************************************************************"
else
Set OutPut = fso.OpenTextFile("T:\ PRO\Sauvegarde\testFichierEfface\logs\" & LogFile_Date & ".txt",8)
OutPut.WriteLine "*************************************************************************************************"
OutPut.WriteLine "Nous sommes Le " &  Day(Now) & "/" & Month(Now) & "/" & Year(Now)& " La liste des Fichiers Supprimés a cette heure " & Time & " est :" 
OutPut.WriteLine "*************************************************************************************************"
end if
'On verifie que le repertoire de sauvegarde existe 
If (myName = Winrep = fso.FolderExists(DossierSauvegarde)) = False Then 
    Erreur = MsgBox("Le dossier de sauvegarde est introuvable !" ) 
    Wscript.Quit 
End If 
 
 'On apelle la fonction d'effacement 
Clean(DossierSauvegarde) 
 
'Fonction d'effacement des fichiers 
Sub Clean(FolderPath) 
 Set Folder = fso.Getfolder(FolderPath) 
 
'On appelle récursivement la fonction s'il y a des sous dossiers 
 Set SubFolder = Folder.SubFolders 
   For Each CurrentFolder in SubFolder 
    If CurrentFolder.Size = 0 Then
     OutPut.WriteLine CurrentFolder.Path & " (Dossier vide)"
     NbDossiersEffaces = NbDossiersEffaces + 1
      If Err.Number = 70 Then ' Si permission refusée
         OutPut.WriteLine CurrentFolder.Path & " (Permission de suppression refusee)"
     End If
   End If
      Clean CurrentFolder.Path 
   Next 
 
'On efface les fichiers dans le dossier courant 
For Each File In Folder.Files 
 If (DateDiff("d", File.DateLastModified, dtmDateModifie) > CInt(AgeMaximalFichiers)) Then 
      'On verifie qu'ils ne sont pas en lecture seule 
      If File.Attributes And 1 Then File.Attributes = File.Attributes - 1 
	OutPut.WriteLine File.Path 
            File.Delete() 
            NbFichiersEffaces = NbFichiersEffaces + 1 
        End If 
Next 
End Sub
 
 'On efface les dossiers et sous-dossiers vides
 Const pfad = ("T:\ PRO\Sauvegarde\testFichierEfface")
 
Dim Text, Title, index, Txt()
Dim fso, wsh, i
index = 1
Set wsh = WScript.CreateObject ("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject") 
RecFolder index, wsh.ExpandEnvironmentStrings(pfad) 
Function RecFolder (idx, pfad) 
Dim fo, fc, i, colFiles, file 
 
Set fo = fso.GetFolder(pfad) 
Set fc = fo.SubFolders
Set colFiles = fo.Files
 
For Each i in fc 
Call RecFolder (idx+1, pfad + "\" + i.name) 
 
If i.Files.Count = 0 And i.SubFolders.Count = 0 Then 
fso.DeleteFolder(pfad + "\" + i.name)
End if
Next
End function
 
OutPut.WriteLine Cstr(NbFichiersEffaces) + " Fichiers ont ete Supprimes !" + " et " + Cstr(NbDossiersEffaces) + " Dossiers ont ete Supprimes !" 
OutPut.WriteLine "*************************************************************************************************"
MsgBox (Cstr(NbFichiersEffaces) + " fichiers ont ete effaces" + " et " + Cstr(NbDossiersEffaces) + " Dossiers ont ete Supprimes !" )

J’ai réussi seulement à faire un copier coller d’un fichier et de le mettre en zip sauf que lorsque je veux l’ouvrir, il s’ouvre pas :

Code:

1
2
3
4
5
6
7
dim filesys
set filesys=CreateObject("Scripting.FileSystemObject") 
 
 
If filesys.FileExists("T:\PRO\Sauvegarde\testFichierEfface\LEVEL.txt") Then 
filesys.CopyFile "T:\PRO\Sauvegarde\testFichierEfface\LEVEL.txt", "T: \PRO\Sauvegarde\testFichierEfface\archive\LEVEL.zip" 
End If

:salut:
Peut-être une piste en utilisant la commande XCopy.exe avec le commutateur /D:j-m-a

Citation:

/D:j-m-a ===> Copie les fichiers modifiés à partir de la date spécifiée. Si aucune date n'est donnée, copie uniquement les fichiers dont l'heure source est plus récente que l'heure de destination. Utile pour les sauvegardes.

Vous pouvez facilement modifier ce script au niveau de la variable Param :king:

Code:

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
Option Explicit
Dim sSrc,sDest,MyCmd,Temp,Titre,MsgTitre,MsgAttente,Copyright,oExec,ws,LogTmpFile,LogFile,MyExcludeFile,Param
Copyright = "[ XcopyScript © Hackoo Crackoo © 2014 ]"
Set ws = CreateObject("WScript.Shell")
Temp = ws.ExpandEnvironmentStrings("%Temp%")
sSrc = "C:\Downloads"
sDest = "E:\XCopytest"
LogTmpFile = "MyTmpXCopyLog.txt"
LogFile = "MyXCopyLog.txt"
Param = " /D /Y /E /F"
MyCmd = "XCopy" & " " & DblQuote(sSrc) & " " & DblQuote(sDest) & " " & Param &" > " & LogTmpFile &_
" & cmd /U /C Type " & LogTmpFile & " > " & LogFile & " & Del " & LogTmpFile & ""
Titre = "Copie de Sauvegarde " & Copyright
MsgAttente = "Copie de Sauvegarde : <font color=Yellow>" & DblQuote(sSrc) & " vers " & DblQuote(sDest) & " </font>  . . . ."
Call CreateProgressBar(Titre,MsgAttente)
Call LancerProgressBar()
Call Pause(2)
Call Executer(MyCmd,0)
Call FermerProgressBar()
ws.run LogFile
'****************************************************************************************************
 Function Executer(StrCmd,Console)
    Dim ws,MyCmd,Resultat
    Set ws = CreateObject("wscript.Shell")
'La valeur 0 pour cacher la console MS-DOS
    If Console = 0 Then
        MyCmd = "CMD /C " & StrCmd & " "
        Resultat = ws.run(MyCmd,Console,True)
        If Resultat = 0 Then
        Else
            MsgBox "Une erreur inconnue est survenue !",16,"Une erreur inconnue est survenue !"
        End If
    End If
'La valeur 1 pour montrer la console MS-DOS
    If Console = 1 Then
        MyCmd = "CMD /K " & StrCmd & " "
        Resultat = ws.run(MyCmd,Console,False)
        If Resultat = 0 Then
        Else
            MsgBox "Une erreur inconnue est survenue !",16,"Une erreur inconnue est survenue !"
        End If
    End If
    Executer = Resultat
End Function
'****************************************************************************************************
Sub CreateProgressBar(Titre,MsgAttente)
    Dim ws,fso,f,f2,ts,ts2,Ligne,i,fread,LireTout,NbLigneTotal,Temp,PathOutPutHTML,fhta,oExec
    Set ws = CreateObject("wscript.Shell")
    Set fso = CreateObject("Scripting.FileSystemObject")
    Temp = WS.ExpandEnvironmentStrings("%Temp%")
    PathOutPutHTML = Temp & "\Barre.hta"
    Set fhta = fso.OpenTextFile(PathOutPutHTML,2,True)
    fhta.WriteLine "<HTML>"
    fhta.WriteLine "<HEAD>"
    fhta.WriteLine "<Title>  " & Titre & "</Title>"
    fhta.WriteLine "<HTA:APPLICATION"
    fhta.WriteLine "ICON = ""magnify.exe"" "
    fhta.WriteLine "BORDER=""THIN"" "
    fhta.WriteLine "INNERBORDER=""NO"" "
    fhta.WriteLine "MAXIMIZEBUTTON=""NO"" "
    fhta.WriteLine "MINIMIZEBUTTON=""NO"" "
    fhta.WriteLine "SCROLL=""NO"" "
    fhta.WriteLine "SYSMENU=""NO"" "
    fhta.WriteLine "SELECTION=""NO"" "
    fhta.WriteLine "SINGLEINSTANCE=""YES"">"
    fhta.WriteLine "</HEAD>"
    fhta.WriteLine "<BODY text=""white""><CENTER><DIV><SPAN ID=""ProgressBar""></SPAN>"
    fhta.WriteLine "<span><marquee DIRECTION=""LEFT"" SCROLLAMOUNT=""3"" BEHAVIOR=ALTERNATE><font face=""Comic sans MS"">" & MsgAttente &"</font></marquee></span></DIV></CENTER></BODY></HTML>"
    fhta.WriteLine "<SCRIPT LANGUAGE=""VBScript""> "
    fhta.WriteLine "Set ws = CreateObject(""wscript.Shell"")"
    fhta.WriteLine "Temp = WS.ExpandEnvironmentStrings(""%Temp%"")"
    fhta.WriteLine "Sub window_onload()"
    fhta.WriteLine "    CenterWindow 500,90"
    fhta.WriteLine "    Self.document.bgColor = ""DarkOrange"" "
    fhta.WriteLine " End Sub"
    fhta.WriteLine " Sub CenterWindow(x,y)"
    fhta.WriteLine "    Dim iLeft,itop"
    fhta.WriteLine "    window.resizeTo x,y"
    fhta.WriteLine "    iLeft = window.screen.availWidth/2 - x/2"
    fhta.WriteLine "    itop = window.screen.availHeight/2 - y/2"
    fhta.WriteLine "    window.moveTo ileft,itop"
    fhta.WriteLine "End Sub"
    fhta.WriteLine "</script>"
    fhta.close
End Sub
'**********************************************************************************************
Sub LancerProgressBar()
    Set oExec = Ws.Exec("mshta.exe " & Temp & "\Barre.hta")
End Sub
'**********************************************************************************************
Sub FermerProgressBar()
    oExec.Terminate
End Sub
'**********************************************************************************************
Sub Pause(NSeconds)
    Wscript.Sleep(NSeconds*1000)
End Sub  
'**********************************************************************************************
Function DblQuote(Str)
    DblQuote = Chr(34) & Str & Chr(34)
End Function
'**********************************************************************************************

30/05/2014, 10h45
01Please

:D WAW merciiiii beaucoup :) ça fonctionne mais il reste quelques petits détails à rajouter, surement un if pour sélectionner les fichiers les plus récents, il faudrait également parcourir les sous dossiers et pour finir ça sera bien de compresser les fichiers copiés (je n'ai aucune idée de comment faire) pour gagner plus d'espace sur le disque dur :)
30/05/2014, 11h05
hackoofr

Citation:

Envoyé par 01Please

ça sera bien de compresser les fichiers copiés (je n'ai aucune idée de comment faire) pour gagner plus d'espace sur le disque dur :)

Vous pouvez utiliser Compression(Source,Destination,Password) :king:
30/05/2014, 11h26
hackoofr

:salut:
Si vous combiner les deux scripts ensemble ça va résoudre votre problème, alors il faut faire des tests :mouarf:
Par contre si vous trouviez un petit problème, alors poster le code combiné et modifié et :tagcode:
@+
30/05/2014, 11h35
01Please

1 pièce(s) jointe(s)

Erreur code

Pièce jointe 147350
30/05/2014, 11h38
01Please

je n'ai pas changé grand choses pour l'instant c'est pourquoi je n'ai pas inséré mon code modifié au post ;) Mais j'aurais voulut savoir comment résoudre l'erreur de mon post précédente: comme définir cette variable? :)
30/05/2014, 11h46
hackoofr

Citation:

Envoyé par 01Please

je n'ai pas changé grand choses pour l'instant c'est pourquoi je n'ai pas inséré mon code modifié au post ;) Mais j'aurais voulut savoir comment résoudre l'erreur de mon post précédente: comme définir cette variable? :)

Bon, premièrement, ce n'est pas pratique de poster une image pour montrer le code ;)
il faut le poster en cliquant sur le bouton # de l'éditeur en haut et à droite il va vous insérer le tagcode comme celui là
[code] Coller votre source ici[ /code]

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
 
Option Explicit
Dim sSrc,sDest,MyCmd,Temp,Titre,MsgTitre,MsgAttente,Copyright,oExec,ws,LogTmpFile,LogFile,MyExcludeFile,Param
Copyright = "[ XcopyScript © Hackoo Crackoo © 2014 ]"
Set ws = CreateObject("WScript.Shell")
Temp = ws.ExpandEnvironmentStrings("%Temp%")
sSrc = "T:\PRO\Sauvegarde\testFichierEfface"
sDest = "T:\PRO\Sauvegarde\testFichierEfface\archive"
LogTmpFile = "MyTmpXCopyLog.txt"
LogFile = "MyXCopyLog.txt"
Param = " /D /Y /E /F"
MyCmd = "XCopy" & " " & DblQuote(sSrc) & " " & DblQuote(sDest) & " " & Param &" > " & LogTmpFile &_
" & cmd /U /C Type " & LogTmpFile & " > " & LogFile & " & Del " & LogTmpFile & ""
Titre = "Copie de Sauvegarde " & Copyright
MsgAttente = "Copie de Sauvegarde : <font color=Yellow>" & DblQuote(sSrc) & " vers " & DblQuote(sDest) & " </font>  . . . ."
Call Compression(sSrc,sDest,"")'Sans Mot de passe
Call CreateProgressBar(Titre,MsgAttente)
Call LancerProgressBar()
Call Pause(2)
Call Executer(MyCmd,0)
Call FermerProgressBar()
ws.run LogFile
 
...

Quand j'appelle la fonction Call Compression (...) Il me dit qu'elle n'est pas définit

Code:

1
2
3
4
5
6
7
8
9
10
11
12
 
Destination = "T:\PRO\Sauvegarde\testFichierEfface\archive" & "\" & ExtensionType & ".zip" 'Nom de l'archive normale sans protection par mot de passe
'Protected_Destination = MyDoc & "\" & ExtensionType & "_Protected.zip" 'Nom de l'archive protégé par mot de passe
'Password = "123456" 'Changer juste cette variable pour choisir un autre mot de passe pour l'archive
Call CreateFolder(ExtensionType)
Set dc  = fso.Drives
For Each d in dc
	If d.IsReady Then
		racine = d.Driveletter & ":"
		GetResults racine,ExtensionType
	End If
Next

Dans ce code que je devrais rajouter, j'ai remplacé .rar par .zip car il me disait "Erreur: Impossible de trouver Winrar.EXE

Est ce possible de le modifier par .zip car j'ai testé mais cela ne fonctionne pas

Code:

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
Option Explicit
Dim fso,ws,d,bf,dc,racine,ExtensionType,Password,Destination, MyDoc
'Protected_Destination, 
Dim arrResult,sDrv,sFName,sFile,Source,Destination
Set fso = CreateObject("Scripting.FileSystemObject")
Set ws = CreateObject("Wscript.Shell")
MyDoc=ws.SpecialFolders("MyDocuments")'Dossier Mes Documents
Set bf = fso.GetFolder(MyDoc)
ExtensionType  = "JPG"
Source = "T:\PRO\Sauvegarde\testFichierEfface"
Destination = "T:\PRO\Sauvegarde\testFichierEfface\archive" & "\" & ExtensionType & ".zip" 'Nom de l'archive normale sans protection par mot de passe
'Protected_Destination = MyDoc & "\" & ExtensionType & "_Protected.zip" 'Nom de l'archive protégé par mot de passe
'Password = "123456" 'Changer juste cette variable pour choisir un autre mot de passe pour l'archive
Call CreateFolder(ExtensionType)
Set dc  = fso.Drives
For Each d in dc
	If d.IsReady Then
		racine = d.Driveletter & ":"
		GetResults racine,ExtensionType
	End If
Next
Call Compression(Source,Destination,"")'Sans Mot de passe
'Call Compression(Source,Protected_Destination,Password)'L'archive est protégé par un mot de passe
'**********************************************************************************
Sub GetResults(drv,fname)
	On Error Resume Next
	Dim sWQL,oFile,Results
	sWQL     = "select * from cim_datafile where Drive='" & _
	drv & "' AND Extension = '" & fname & "'"
	For Each oFile In GetObject("winmgmts:").execquery(sWQL)
		sFile   = oFile.Name
		CopyFile sFile,ExtensionType
	Next
End Sub
'**********************************************************************************
Sub CreateFolder(name)
	Set fso    = CreateObject("Scripting.FileSystemObject")
	If Not FSO.FolderExists(bf & "\" & name) Then
		bf.subFolders.Add(name)
		Else : Exit Sub
	End If
End Sub
'**********************************************************************************
Function CopyFile(sFile,name)
	Dim  fso,ws,bf
	'MyDoc
	Set FSO = CreateObject("Scripting.FileSystemObject")
	Set ws = CreateObject("Wscript.Shell")
	'MyDoc = ws.SpecialFolders("MyDocuments")'Dossier Mes Documents
	'Set bf = fso.GetFolder(MyDoc)
	If FSO.FolderExists(bf & "\" & name) Then
		FSO.GetFile(sFile).Copy bf & "\" & name & "\" & FSO.GetFileName(sFile),True
	Else
		MsgBox "erreur du chemin",16,"erreur du chemin"
	End If
End Function
'**********************************************************************************
Function Compression(Source,Destination,Password)
	Dim oFSO,oShell,aScriptFilename,sScriptFilename
	Dim sWorkingDirectory,ProgramFiles,sWinZipLocation
	Set oFSO = WScript.CreateObject("Scripting.FileSystemObject")
	Set oShell = WScript.CreateObject("Wscript.Shell")
'--------Trouver le répertoire de travail--------
	aScriptFilename = Split(Wscript.ScriptFullName, "\")
	sScriptFilename = aScriptFileName(Ubound(aScriptFilename))
	sWorkingDirectory = Replace(Wscript.ScriptFullName, sScriptFilename, "")
'--------------------------------------
	ProgramFiles = oShell.ExpandEnvironmentStrings("%ProgramFiles%")
'-------S'assurer que nous pouvons trouver WinRAR.exe------
	If oFSO.FileExists(sWorkingDirectory & " " & "Winrar.EXE") Then
		sWinZipLocation = ""
	ElseIf oFSO.FileExists(ProgramFiles &"\Winrar\Winrar.EXE") Then
		sWinZipLocation = ProgramFiles &"\Winrar\"
	Else
		Compression = "Erreur: Impossible de trouver Winrar.EXE"
		MsgBox Compression,16,Compression
		Exit Function
	End If
'--------------------------------------
'La Commande A : Signifie ==> ajouter à une archive
'Le Commutateur -IBCK ==> Signifie : Lancer WinRAR en arrière-plan
	If Password = "" Then
		oShell.Run """" & sWinZipLocation & "winrar.exe"" A -IBCK """ & _
		Destination & """ """ & Source & """",0,True 
	Else
'Le Commutateur -P<mot_de_passe> : Pour utiliser un mot de passe
		oShell.Run """" & sWinZipLocation & "winrar.exe"" A -IBCK -p"&Password&" """ & _
		Destination & """ """ & Source & """",0,True 
	End If
	If oFSO.FileExists(Destination) Then
		Compression = 1
	Else
		Compression = "Erreur : Création d'archives a échoué !"
		MsgBox Compression,16,Compression
	End If
End Function

L'erreur ligne 4 : redéfinition du nom... :/

Salut

Citation:

erreur ligne 4 : redéfinition du nom.
Code:

1 2 3 4 Option Explicit Dim fso,ws,d,bf,dc,racine,ExtensionType,Password,Destination, MyDoc 'Protected_Destination, Dim arrResult,sDrv,sFName,sFile,Source,Destination
Destination est déclaré 2 fois, ligne 2 et ligne 4

30/05/2014, 13h04
01Please

Ah oui XD c'est bien vrai ça :/ Merci ^^

Les liens m'ont été utile mais j'ai toujours des problèmes ...

dans ce code pour la compression des fichiers ->

Code:

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
Option Explicit
Dim source,Dest,MyCmd,Temp,Titre,MsgTitre,MsgAttente,Copyright,oExec,ws,LogTmpFile,LogFile,MyExcludeFile,Param
Dim ExtensionType, fso
Copyright = "[ XcopyScript © Hackoo Crackoo © 2014 ]"
Set fso = CreateObject("Scripting.FileSystemObject")
Set ws = CreateObject("WScript.Shell")
Set bf = fso.GetFolder(MyDoc)
Temp = ws.ExpandEnvironmentStrings("%Temp%")
ExtensionType  = "JPG"
source = "T:\PRO\Sauvegarde\testCompress"
Dest = "T:\PRO\Sauvegarde\testCompress\archive"
LogTmpFile = "TmpXCopyLog.txt"
LogFile = "MyXCopyLog.txt"
Param = " /D "
MyCmd = "XCopy" & " " & DblQuote(source) & " " & DblQuote(Dest) & " " & Param &" > " & LogTmpFile &_
" & cmd /U /C Type " & LogTmpFile & " > " & LogFile & " & Del " & LogTmpFile & ""
Titre = "Copie de Sauvegarde " & Copyright
MsgAttente = "Copie de Sauvegarde : <font color=Yellow>" & DblQuote(source) & " vers " & DblQuote(Dest) & " </font>  . . . ."
Call CreateProgressBar(Titre,MsgAttente)
Call LancerProgressBar()
Call Pause(2)
Call Executer(MyCmd,0)
Call FermerProgressBar()
Call CreateFolder(ExtensionType)
Set dc  = fso.Drives
For Each d in dc
	If d.IsReady Then
		racine = d.Driveletter & ":"
		GetResults racine,ExtensionType
	End If
Next
Call Compression(source,Dest,"")'Sans Mot de passe
ws.run LogFile
'****************************************************************************************************
 Function Executer(StrCmd,Console)
    Dim ws,MyCmd,Resultat
    Set ws = CreateObject("wscript.Shell")
'La valeur 0 pour cacher la console MS-DOS
    If Console = 0 Then
        MyCmd = "CMD /C " & StrCmd & " "
        Resultat = ws.run(MyCmd,Console,True)
        If Resultat = 0 Then
        Else
            MsgBox "Une erreur inconnue est survenue !",16,"Une erreur inconnue est survenue !"
        End If
    End If
'La valeur 1 pour montrer la console MS-DOS
    If Console = 1 Then
        MyCmd = "CMD /K " & StrCmd & " "
        Resultat = ws.run(MyCmd,Console,False)
        If Resultat = 0 Then
        Else
            MsgBox "Une erreur inconnue est survenue !",16,"Une erreur inconnue est survenue !"
        End If
    End If
    Executer = Resultat
End Function
'****************************************************************************************************
Sub CreateProgressBar(Titre,MsgAttente)
    Dim ws,fso,f,f2,ts,ts2,Ligne,i,fread,LireTout,NbLigneTotal,Temp,PathOutPutHTML,fhta,oExec
    Set ws = CreateObject("wscript.Shell")
    Set fso = CreateObject("Scripting.FileSystemObject")
    Temp = WS.ExpandEnvironmentStrings("%Temp%")
    PathOutPutHTML = Temp & "\Barre.hta"
    Set fhta = fso.OpenTextFile(PathOutPutHTML,2,True)
    fhta.WriteLine "<HTML>"
    fhta.WriteLine "<HEAD>"
    fhta.WriteLine "<Title>  " & Titre & "</Title>"
    fhta.WriteLine "<HTA:APPLICATION"
    fhta.WriteLine "ICON = ""magnify.exe"" "
    fhta.WriteLine "BORDER=""THIN"" "
    fhta.WriteLine "INNERBORDER=""NO"" "
    fhta.WriteLine "MAXIMIZEBUTTON=""NO"" "
    fhta.WriteLine "MINIMIZEBUTTON=""NO"" "
    fhta.WriteLine "SCROLL=""NO"" "
    fhta.WriteLine "SYSMENU=""NO"" "
    fhta.WriteLine "SELECTION=""NO"" "
    fhta.WriteLine "SINGLEINSTANCE=""YES"">"
    fhta.WriteLine "</HEAD>"
    fhta.WriteLine "<BODY text=""white""><CENTER><DIV><SPAN ID=""ProgressBar""></SPAN>"
    fhta.WriteLine "<span><marquee DIRECTION=""LEFT"" SCROLLAMOUNT=""3"" BEHAVIOR=ALTERNATE><font face=""Comic sans MS"">" & MsgAttente &"</font></marquee></span></DIV></CENTER></BODY></HTML>"
    fhta.WriteLine "<SCRIPT LANGUAGE=""VBScript""> "
    fhta.WriteLine "Set ws = CreateObject(""wscript.Shell"")"
    fhta.WriteLine "Temp = WS.ExpandEnvironmentStrings(""%Temp%"")"
    fhta.WriteLine "Sub window_onload()"
    fhta.WriteLine "    CenterWindow 500,90"
    fhta.WriteLine "    Self.document.bgColor = ""DarkOrange"" "
    fhta.WriteLine " End Sub"
    fhta.WriteLine " Sub CenterWindow(x,y)"
    fhta.WriteLine "    Dim iLeft,itop"
    fhta.WriteLine "    window.resizeTo x,y"
    fhta.WriteLine "    iLeft = window.screen.availWidth/2 - x/2"
    fhta.WriteLine "    itop = window.screen.availHeight/2 - y/2"
    fhta.WriteLine "    window.moveTo ileft,itop"
    fhta.WriteLine "End Sub"
    fhta.WriteLine "</script>"
    fhta.close
End Sub
'**********************************************************************************************
Sub LancerProgressBar()
    Set oExec = Ws.Exec("mshta.exe " & Temp & "\Barre.hta")
End Sub
'**********************************************************************************************
Sub FermerProgressBar()
    oExec.Terminate
End Sub
'**********************************************************************************************
Sub Pause(NSeconds)
    Wscript.Sleep(NSeconds*1000)
End Sub  
'**********************************************************************************************
Function DblQuote(Str)
    DblQuote = Chr(34) & Str & Chr(34)
End Function
'**********************************************************************************************
'**********************************************************************************
Sub GetResults(drv,fname)
	On Error Resume Next 
	Dim sWQL,oFile,Results
	sWQL     = "select * from cim_datafile where Drive='" & _
	drv & "' AND Extension = '" & fname & "'"
	For Each oFile In GetObject("winmgmts:").execquery(sWQL)
		sFile   = oFile.Name
		CopyFile sFile,ExtensionType
	Next
End Sub
'**********************************************************************************
Sub CreateFolder(name)
	Set fso    = CreateObject("Scripting.FileSystemObject")
	If Not FSO.FolderExists(bf & "\" & name) Then
		bf.subFolders.Add(name)
		Else : Exit Sub
	End If
End Sub
'**********************************************************************************
Function CopyFile(sFile,name)
	Dim  fso,ws,bf, MyDoc
	Set FSO = CreateObject("Scripting.FileSystemObject")
	Set ws = CreateObject("Wscript.Shell")
	MyDoc = "T:\PRO\Sauvegarde\testFichierEfface"
	Set bf = fso.GetFolder(MyDoc)
	If FSO.FolderExists(bf & "\" & name) Then
		FSO.GetFile(sFile).Copy bf & "\" & name & "\" & FSO.GetFileName(sFile),True
	Else
		MsgBox "erreur du chemin",16,"erreur du chemin"
	End If
End Function
'**********************************************************************************
Function Compression(source,Dest,Password)
	Dim oFSO,oShell,aScriptFilename,sScriptFilename
	Dim sWorkingDirectory,ProgramFiles,sWinZipLocation
	Set oFSO = WScript.CreateObject("Scripting.FileSystemObject")
	Set oShell = WScript.CreateObject("Wscript.Shell")
'--------Trouver le répertoire de travail--------
	aScriptFilename = Split(Wscript.ScriptFullName, "\")
	sScriptFilename = aScriptFileName(Ubound(aScriptFilename))
	sWorkingDirectory = Replace(Wscript.ScriptFullName, sScriptFilename, "")
'--------------------------------------
	ProgramFiles = oShell.ExpandEnvironmentStrings("%ProgramFiles%")
'-------S'assurer que nous pouvons trouver WinRAR.exe------
	If oFSO.FileExists(sWorkingDirectory & " " & "7zFM.exe") Then
		sWinZipLocation = ""
	ElseIf oFSO.FileExists(ProgramFiles &"\7-Zip\7zFM.exe") Then
		sWinZipLocation = ProgramFiles &"\7-Zip\"
	Else
		Compression = "Erreur: Impossible de trouver 7zFM.exe"
		MsgBox Compression,16,Compression
		Exit Function
	End If
'--------------------------------------
'La Commande A : Signifie ==> ajouter à une archive
'Le Commutateur -IBCK ==> Signifie : Lancer WinRAR en arrière-plan
	If Password = "" Then
		oShell.Run """" & sWinZipLocation & "7zFM.exe"" A -IBCK """ & _
		Dest & """ """ & source & """",0,True 
	Else
'Le Commutateur -P<mot_de_passe> : Pour utiliser un mot de passe
		oShell.Run """" & sWinZipLocation & "7zFM.exe"" A -IBCK -p"&Password&" """ & _
		Dest & """ """ & source & """",0,True 
	End If
	If oFSO.FileExists(Dest) Then
		Compression = 1
	Else
		Compression = "Erreur : Création d'archives a échoué !"
		MsgBox Compression,16,Compression
	End If
End Function

J'aurais voulu savoir à quoi correspond ces lignes :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
MyDoc=ws.SpecialFolders("MyDocuments")'Dossier Mes Documents
Set bf = fso.GetFolder(MyDoc)
ExtensionType  = "JPG"
'...
Set dc  = fso.Drives
For Each d in dc
	If d.IsReady Then
		racine = d.Driveletter & ":"
		GetResults racine,ExtensionType
	End If
Next
'...

:salut:
Voici un script modifié et testé chez moi qui marche 5/5 :mouarf: :king:
Remarque : vous deviez choisir le dossier "E:\archive" et non pas "E:\Pro\Sauvegarde\testFichierEfface\archive" sinon vous tombiez dans l'erreur de copie cyclique.
et aussi il faut que Winrar soit installé sur votre machine

Code:

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
Option Explicit
Dim sSrc,sDest,MyCmd,Temp,Titre,MsgTitre,MsgAttente,Source,Destination
Dim Copyright,oExec,ws,LogTmpFile,LogFile,MyExcludeFile,Param
Copyright = "[ XcopyScript © Hackoo Crackoo © 2014 ]"
Set ws = CreateObject("WScript.Shell")
Temp = ws.ExpandEnvironmentStrings("%Temp%")
sSrc = "E:\Pro\Sauvegarde\testFichierEfface"
sDest = "E:\archive"
LogTmpFile = "MyTmpXCopyLog.txt"
LogFile = "MyXCopyLog.txt"
Param = " /D /Y /E /F"
MyCmd = "XCopy" & " " & DblQuote(sSrc) & " " & DblQuote(sDest) & " " & Param &" > " & LogTmpFile &_
" & cmd /U /C Type " & LogTmpFile & " > " & LogFile & " & Del " & LogTmpFile & ""
Titre = "Copie de Sauvegarde " & Copyright
MsgAttente = "Copie de Sauvegarde : <font color=Yellow>" & DblQuote(sSrc) & " vers " & DblQuote(sDest) & " </font>  . . . ."
Call CreateProgressBar(Titre,MsgAttente)
Call LancerProgressBar()
Call Pause(2)
Call Executer(MyCmd,0,True)
'Maintenant on définie les varaiables Source et Destination pour archiver la source avec Winrar vers la destination
Source = sSrc
Destination = sDest &".rar"
Call Compression(Source,Destination,"")' Compression sans mot de passe
Call FermerProgressBar()
ws.run LogFile
'**************************************************************************************************************
Function Executer(StrCmd,Console,bWaitOnReturn)
   Dim ws,MyCmd,Resultat
   Set ws = CreateObject("wscript.Shell")
'La valeur 0 pour cacher la console MS-DOS
   If Console = 0 Then
      MyCmd = "CMD /C " & StrCmd & ""
      Resultat = ws.run(MyCmd,Console,bWaitOnReturn)
      If Resultat = 0 Then
      Else
         MsgBox "Une erreur inconnue est survenue !",16,"Une erreur inconnue est survenue !"
      End If
   End If
'La valeur 1 pour montrer la console MS-DOS
   If Console = 1 Then
      MyCmd = "CMD /K " & StrCmd & " "
      Resultat = ws.run(MyCmd,Console,bWaitOnReturn)
      If Resultat = 0 Then
      Else
         MsgBox "Une erreur inconnue est survenue !",16,"Une erreur inconnue est survenue !"
      End If
   End If
   Executer = Resultat
End Function
'***********************************************************************************************************
Function Compression(Source,Destination,Password)
    Dim oFSO,oShell,aScriptFilename,sScriptFilename
    Dim sWorkingDirectory,ProgramFiles,sWinZipLocation
    Set oFSO = WScript.CreateObject("Scripting.FileSystemObject")
    Set oShell = WScript.CreateObject("Wscript.Shell")
'--------Trouver le répertoire de travail--------
    aScriptFilename = Split(Wscript.ScriptFullName, "\")
    sScriptFilename = aScriptFileName(Ubound(aScriptFilename))
    sWorkingDirectory = Replace(Wscript.ScriptFullName, sScriptFilename, "")
'--------------------------------------
    ProgramFiles = oShell.ExpandEnvironmentStrings("%ProgramFiles%")
'-------S'assurer que nous pouvons trouver WinRAR.exe------
    If oFSO.FileExists(sWorkingDirectory & " " & "Winrar.EXE") Then
        sWinZipLocation = ""
    ElseIf oFSO.FileExists(ProgramFiles &"\Winrar\Winrar.EXE") Then
        sWinZipLocation = ProgramFiles &"\Winrar\"
    Else
        Compression = "Erreur: Impossible de trouver Winrar.EXE"
        MsgBox Compression,16,Compression
        Exit Function
    End If
'--------------------------------------
'La Commande A : Signifie ==> ajouter à une archive
'Le Commutateur -IBCK ==> Signifie : Lancer WinRAR en arrière-plan
    If Password = "" Then
        oShell.Run """" & sWinZipLocation & "winrar.exe"" A -IBCK """ & _
        Destination & """ """ & Source & """",0,True 
    Else
'Le Commutateur -P<mot_de_passe> : Pour utiliser un mot de passe
        oShell.Run """" & sWinZipLocation & "winrar.exe"" A -IBCK -p"&Password&" """ & _
        Destination & """ """ & Source & """",0,True 
    End If
    If oFSO.FileExists(Destination) Then
        Compression = 1
    Else
        Compression = "Erreur : Création d'archives a échoué !"
        MsgBox Compression,16,Compression
    End If
End Function
'***********************************************************************************************************
'Fonction pour ajouter les doubles quotes dans une variable
Function DblQuote(strIn)
   DblQuote = Chr(34) & strIn & Chr(34)
End Function
'***********************************************************************************************************
Sub CreateProgressBar(Titre,MsgAttente)
    Dim ws,fso,f,f2,ts,ts2,Ligne,i,fread,LireTout,NbLigneTotal,Temp,PathOutPutHTML,fhta,oExec
    Set ws = CreateObject("wscript.Shell")
    Set fso = CreateObject("Scripting.FileSystemObject")
    Temp = WS.ExpandEnvironmentStrings("%Temp%")
    PathOutPutHTML = Temp & "\Barre.hta"
    Set fhta = fso.OpenTextFile(PathOutPutHTML,2,True)
    fhta.WriteLine "<HTML>"
    fhta.WriteLine "<HEAD>"
    fhta.WriteLine "<Title>  " & Titre & "</Title>"
    fhta.WriteLine "<HTA:APPLICATION"
    fhta.WriteLine "ICON = ""magnify.exe"" "
    fhta.WriteLine "BORDER=""THIN"" "
    fhta.WriteLine "INNERBORDER=""NO"" "
    fhta.WriteLine "MAXIMIZEBUTTON=""NO"" "
    fhta.WriteLine "MINIMIZEBUTTON=""NO"" "
    fhta.WriteLine "SCROLL=""NO"" "
    fhta.WriteLine "SYSMENU=""NO"" "
    fhta.WriteLine "SELECTION=""NO"" "
    fhta.WriteLine "SINGLEINSTANCE=""YES"">"
    fhta.WriteLine "</HEAD>"
    fhta.WriteLine "<BODY text=""white""><CENTER><DIV><SPAN ID=""ProgressBar""></SPAN>"
    fhta.WriteLine "<span><marquee DIRECTION=""LEFT"" SCROLLAMOUNT=""3"" BEHAVIOR=ALTERNATE><font face=""Comic sans MS"">" & MsgAttente &"</font></marquee></span></DIV></CENTER></BODY></HTML>"
    fhta.WriteLine "<SCRIPT LANGUAGE=""VBScript""> "
    fhta.WriteLine "Set ws = CreateObject(""wscript.Shell"")"
    fhta.WriteLine "Temp = WS.ExpandEnvironmentStrings(""%Temp%"")"
    fhta.WriteLine "Sub window_onload()"
    fhta.WriteLine "    CenterWindow 500,90"
    fhta.WriteLine "    Self.document.bgColor = ""DarkOrange"" "
    fhta.WriteLine " End Sub"
    fhta.WriteLine " Sub CenterWindow(x,y)"
    fhta.WriteLine "    Dim iLeft,itop"
    fhta.WriteLine "    window.resizeTo x,y"
    fhta.WriteLine "    iLeft = window.screen.availWidth/2 - x/2"
    fhta.WriteLine "    itop = window.screen.availHeight/2 - y/2"
    fhta.WriteLine "    window.moveTo ileft,itop"
    fhta.WriteLine "End Sub"
    fhta.WriteLine "</script>"
    fhta.close
End Sub
'**********************************************************************************************
Sub LancerProgressBar()
    Set oExec = Ws.Exec("mshta.exe " & Temp & "\Barre.hta")
End Sub
'**********************************************************************************************
Sub FermerProgressBar()
    oExec.Terminate
End Sub
'**********************************************************************************************
Sub Pause(NSeconds)
    Wscript.Sleep(NSeconds*1000)
End Sub  
'**********************************************************************************************
Function DblQuote(Str)
    DblQuote = Chr(34) & Str & Chr(34)
End Function
'**********************************************************************************************

31/05/2014, 20h21
01Please

Fichier MyTmpXCopyLog

Merci encore pour votre aide si précieuse ^^, je m'excuse encore de vous poser encore d'autres questions ^^ (l'archive n'a pas fonctionné); pourquoi quand je lance le même programme il m'indique dans le fichier MyTmpXCopyLog :
Est-ce que C:\archive désigne un nom de fichier
ou un nom de répertoire de la destination
(F = fichier, R = répertoire)?
31/05/2014, 20h37
hackoofr

Citation:

Envoyé par 01Please

Merci encore pour votre aide si précieuse ^^, je m'excuse encore de vous poser encore d'autres questions ^^ (l'archive n'a pas fonctionné); pourquoi quand je lance le même programme il m'indique dans le fichier MyTmpXCopyLog :
Est-ce que C:\archive d‚signe un nom de fichier
ou un nom de r‚pertoire de la destination
(F = fichier, R = répertoire)?

:salut:
Postez votre modification et :tagcode:
31/05/2014, 20h51
01Please
J'ai changé de chemin, vu que j'ai changé de PC mais le chemin est juste.
Code:

1 2 3 sSrc = "C:\Users\falun_000\Documents\TEST" sDest = "C:\ARCHIVE"
Pour les paramètres, j'ai gardé seulement l'option D

Code:

Param = " /D "

De plus j'ai un problème, quand j’exécute le programme en plus du fichier texte qui apparait dans le log. J'ai une fenêtre de Winrar qui me dit Impossible de créer C:\ARCHIVE.rar cela vient-il de cette ligne :

Code:

Destination = sDest &".rar"
31/05/2014, 21h20
hackoofr

Le dossier C:\ARCHIVE existe ou non :koi:
01/06/2014, 11h07
01Please

Le vrai chemin est "C:\Users\falun_000\Documents\TEST\ARCHIVE"

Mais vous m'avez dit de mettre C:\ARCHIVE pour éviter l'erreur de copie cyclique. ... n'est ce pas ?

:salut:
Voici un script plus général qui vous permet de parcourir un dossier à copier dans un dossier qui se crée automatiquement via le script avec un nom générique avec la date du jour, comme par exemple "Archive_1_6_2014" puis il se compresse sous le nom de Archive_1_6_2014.rar et ceci dans votre dossier documents
Donc à tester et sans changer aucune ligne dans le code car celui-ci va prendre tout en charge :king:

Code:

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
Option Explicit
Dim sSrc,sDest,MyCmd,Temp,Titre,MsgTitre,MsgAttente,Source,Destination,bf
Dim Copyright,oExec,ws,LogTmpFile,LogFile,Param,Archive,MyDoc,fso
Copyright = "[ XcopyScript © Hackoo Crackoo © 2014 ]"
Set ws = CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
Temp = ws.ExpandEnvironmentStrings("%Temp%")
sSrc = Parcourir_Dossier()
MyDoc = ws.SpecialFolders("MyDocuments")'Dossier Mes Documents
Set bf = fso.GetFolder(MyDoc)
Archive  = "Archive_"& Day(Now) & "_" & Month(Now) & "_" & Year(Now)
sDest = MyDoc & "\" & Archive
Call CreateFolder(bf,Archive)
LogTmpFile = "MyTmpXCopyLog.txt"
LogFile = "MyXCopyLog.txt"
Param = " /D"
MyCmd = "XCopy" & " " & DblQuote(sSrc) & " " & DblQuote(sDest) & " " & Param &" > " & LogTmpFile &_
" & cmd /U /C Type " & LogTmpFile & " > " & LogFile & " & Del " & LogTmpFile & ""
Titre = "Copie de Sauvegarde " & Copyright
MsgAttente = "Copie de Sauvegarde : <font color=Yellow>" & DblQuote(sSrc) & " vers " & DblQuote(sDest) & " </font>  . . . ."
Call CreateProgressBar(Titre,MsgAttente)
Call LancerProgressBar()
Call Pause(2)
Call Executer(MyCmd,0,True)
'Maintenant on définie les varaiables Source et Destination pour archiver la source avec Winrar vers la destination
Source = sDest
Destination = sDest &".rar"
Call Compression(Source,Destination,"")' Compression sans mot de passe
Call FermerProgressBar()
ws.run LogFile
'****************************************************************************************************
Function Parcourir_Dossier()
    Dim objShell,objFolder
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, "Veuillez choisir un dossier pour la Sauvegarde " & Copyright,1,"c:\Programs")
    If objFolder Is Nothing Then
        Wscript.Quit
    End If
    Parcourir_Dossier = objFolder.self.path
end Function
'**************************************************************************************************************
Sub CreateFolder(bf,name)
    Set fso  = CreateObject("Scripting.FileSystemObject")
    If Not FSO.FolderExists(bf & "\" & name) Then
        bf.subFolders.Add(name)
        Else : Exit Sub
    End If
End Sub
'**************************************************************************************************************
Function Executer(StrCmd,Console,bWaitOnReturn)
   Dim ws,MyCmd,Resultat
   Set ws = CreateObject("wscript.Shell")
'La valeur 0 pour cacher la console MS-DOS
   If Console = 0 Then
      MyCmd = "CMD /C " & StrCmd & ""
      Resultat = ws.run(MyCmd,Console,bWaitOnReturn)
      If Resultat = 0 Then
      Else
         MsgBox "Une erreur inconnue est survenue !",16,"Une erreur inconnue est survenue !"
      End If
   End If
'La valeur 1 pour montrer la console MS-DOS
   If Console = 1 Then
      MyCmd = "CMD /K " & StrCmd & " "
      Resultat = ws.run(MyCmd,Console,bWaitOnReturn)
      If Resultat = 0 Then
      Else
         MsgBox "Une erreur inconnue est survenue !",16,"Une erreur inconnue est survenue !"
      End If
   End If
   Executer = Resultat
End Function
'***********************************************************************************************************
Function Compression(Source,Destination,Password)
    Dim oFSO,oShell,aScriptFilename,sScriptFilename
    Dim sWorkingDirectory,ProgramFiles,sWinZipLocation
    Set oFSO = WScript.CreateObject("Scripting.FileSystemObject")
    Set oShell = WScript.CreateObject("Wscript.Shell")
'--------Trouver le répertoire de travail--------
    aScriptFilename = Split(Wscript.ScriptFullName, "\")
    sScriptFilename = aScriptFileName(Ubound(aScriptFilename))
    sWorkingDirectory = Replace(Wscript.ScriptFullName, sScriptFilename, "")
'--------------------------------------
    ProgramFiles = oShell.ExpandEnvironmentStrings("%ProgramFiles%")
'-------S'assurer que nous pouvons trouver WinRAR.exe------
    If oFSO.FileExists(sWorkingDirectory & " " & "Winrar.EXE") Then
        sWinZipLocation = ""
    ElseIf oFSO.FileExists(ProgramFiles &"\Winrar\Winrar.EXE") Then
        sWinZipLocation = ProgramFiles &"\Winrar\"
    Else
        Compression = "Erreur: Impossible de trouver Winrar.EXE"
        MsgBox Compression,16,Compression
        Exit Function
    End If
'--------------------------------------
'La Commande A : Signifie ==> ajouter à une archive
'Le Commutateur -IBCK ==> Signifie : Lancer WinRAR en arrière-plan
    If Password = "" Then
        oShell.Run """" & sWinZipLocation & "winrar.exe"" A -IBCK """ & _
        Destination & """ """ & Source & """",0,True 
    Else
'Le Commutateur -P<mot_de_passe> : Pour utiliser un mot de passe
        oShell.Run """" & sWinZipLocation & "winrar.exe"" A -IBCK -p"&Password&" """ & _
        Destination & """ """ & Source & """",0,True 
    End If
    If oFSO.FileExists(Destination) Then
        Compression = 1
    Else
        Compression = "Erreur : Création d'archives a échoué !"
        MsgBox Compression,16,Compression
    End If
End Function
'***********************************************************************************************************
'Fonction pour ajouter les doubles quotes dans une variable
Function DblQuote(strIn)
   DblQuote = Chr(34) & strIn & Chr(34)
End Function
'***********************************************************************************************************
Sub CreateProgressBar(Titre,MsgAttente)
    Dim ws,fso,f,f2,ts,ts2,Ligne,i,fread,LireTout,NbLigneTotal,Temp,PathOutPutHTML,fhta,oExec
    Set ws = CreateObject("wscript.Shell")
    Set fso = CreateObject("Scripting.FileSystemObject")
    Temp = WS.ExpandEnvironmentStrings("%Temp%")
    PathOutPutHTML = Temp & "\Barre.hta"
    Set fhta = fso.OpenTextFile(PathOutPutHTML,2,True)
    fhta.WriteLine "<HTML>"
    fhta.WriteLine "<HEAD>"
    fhta.WriteLine "<Title>  " & Titre & "</Title>"
    fhta.WriteLine "<HTA:APPLICATION"
    fhta.WriteLine "ICON = ""magnify.exe"" "
    fhta.WriteLine "BORDER=""THIN"" "
    fhta.WriteLine "INNERBORDER=""NO"" "
    fhta.WriteLine "MAXIMIZEBUTTON=""NO"" "
    fhta.WriteLine "MINIMIZEBUTTON=""NO"" "
    fhta.WriteLine "SCROLL=""NO"" "
    fhta.WriteLine "SYSMENU=""NO"" "
    fhta.WriteLine "SELECTION=""NO"" "
    fhta.WriteLine "SINGLEINSTANCE=""YES"">"
    fhta.WriteLine "</HEAD>"
    fhta.WriteLine "<BODY text=""white""><CENTER><DIV><SPAN ID=""ProgressBar""></SPAN>"
    fhta.WriteLine "<span><marquee DIRECTION=""LEFT"" SCROLLAMOUNT=""3"" BEHAVIOR=ALTERNATE><font face=""Comic sans MS"">" & MsgAttente &"</font></marquee></span></DIV></CENTER></BODY></HTML>"
    fhta.WriteLine "<SCRIPT LANGUAGE=""VBScript""> "
    fhta.WriteLine "Set ws = CreateObject(""wscript.Shell"")"
    fhta.WriteLine "Temp = WS.ExpandEnvironmentStrings(""%Temp%"")"
    fhta.WriteLine "Sub window_onload()"
    fhta.WriteLine "    CenterWindow 500,90"
    fhta.WriteLine "    Self.document.bgColor = ""DarkOrange"" "
    fhta.WriteLine " End Sub"
    fhta.WriteLine " Sub CenterWindow(x,y)"
    fhta.WriteLine "    Dim iLeft,itop"
    fhta.WriteLine "    window.resizeTo x,y"
    fhta.WriteLine "    iLeft = window.screen.availWidth/2 - x/2"
    fhta.WriteLine "    itop = window.screen.availHeight/2 - y/2"
    fhta.WriteLine "    window.moveTo ileft,itop"
    fhta.WriteLine "End Sub"
    fhta.WriteLine "</script>"
    fhta.close
End Sub
'**********************************************************************************************
Sub LancerProgressBar()
    Set oExec = Ws.Exec("mshta.exe " & Temp & "\Barre.hta")
End Sub
'**********************************************************************************************
Sub FermerProgressBar()
    oExec.Terminate
End Sub
'**********************************************************************************************
Sub Pause(NSeconds)
    Wscript.Sleep(NSeconds*1000)
End Sub  
'**********************************************************************************************
Function DblQuote(Str)
    DblQuote = Chr(34) & Str & Chr(34)
End Function
'**********************************************************************************************

:king: Merciiiiiiiii beaucoup :D , votre code fonctionne à merveille le seul petit détail qui manque c'est qui ne permet pas la copie des sous dossiers du dossier sélectionné, j'ai plusieurs sous dossiers (beaucoup trop pour faire la manipulation pour tous les sous-dossiers, j'ai donc voulu rajouter du code :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
'Parcourir les sous-dossier
Dim index, wsh, i, objFolder
index = 1
Set wsh = WScript.CreateObject ("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject") 
RecFolder index, wsh.ExpandEnvironmentStrings(objFolder) 
Function RecFolder (idx, objFolder) 
Dim fo, fc, i, colFiles, file 
Set fo = fso.GetFolder(objFolder) 'Argument ou appel de procédure incorrect
'Set objFolder = fso.GetFolder(objFolder)
    If objFolder Is Nothing Then
        Wscript.Quit
    End If
    Parcourir_Dossier = objFolder.self.path
Set fc = fo.SubFolders
Set colFiles = fo.Files
For Each i in fc 
Call RecFolder (idx+1, objFolder + "\" + i.name) 
 
If i.Files.Count = 0 And i.SubFolders.Count = 0 Then 
fso.CopyFolder(objFolder + "\" + i.name) 'Commande fausse 
End if
Next
End function

J'ai essayé mais je tourne en rond :?

Voir 40 message(s) de cette discussion en une page