orlith | Ca y est j'ai trouvé !
Avec du vbs c'est possible !
Voic imon script, y'a surement des améliorations a faire mais bon ca fonctionne bien comme ca !
Il lit le contenu d'un répertoire et de ses sous dossiers, transforme tout les fichier xls en txt puis supprime les répertoires.
Code :
- Option Explicit
- Dim a ' WB
- Dim n: n = 0 ' WB
- Dim Recursivity ' WB
- On error resume Next
- Main
- Sub Main
- Dim Path,count
- Dim Chaine, longueur, fName
- Dim i ,fs
- Dim FileName, Filepath
- Dim xlApp, xlWB, vPath, FSO, f, fl, fpath,oShell
- Set xlApp = CreateObject("excel.application" )
- vPath = "Chemins initial des xls\"
- fPath = "Chemin de dépose des txt"
- Set FSO = CreateObject("scripting.filesystemobject" )
- xlApp.DisplayAlerts = False
- 'Select Case WScript.Arguments.Count
- ' Case 0: Path = "*.*" ' list current directory
- ' Case 1: Path = WScript.Arguments(0) ' WB
- ' Case 2: Path = WScript.Arguments(0) : Recursivity = WScript.Arguments(1) ' WB
- ' Case Else: WScript.Echo "Invalid number of arguments.": Exit Sub
- 'End Select
- Select Case Recursivity ' WB
- Case "" : Recursivity=True ' WB
- Case Else : Recursivity=False ' WB
- End Select ' WB
- Path ="*.xls"
- ReDim a(1,10) ' WB
- 'wscript.echo "ubound 1 : "&ubound(a,2)
- a = ListDir(vPath & Path)
- 'wscript.echo "ubound 2 : "&ubound(a,2)
- If UBound(a) = -1 then
- WScript.Echo "No files found."
- Exit Sub
- End If
- n=1
- Do While n+1 <= UBound(a,2)
- 'wscript.echo ubound(a)
- 'wscript.echo n
- Filepath=a(0,n-1)
- Filename=a(1,n-1)
- 'wscript.echo filepath
- 'wscript.echo filename
- Longueur=len(filePath)-66
- If Longueur >0 then
- FilePath = Right(FilePath,longueur) 'supprime la chaine d:\temp\ du path
- Chaine = Split(FilePath, "\" ) 'splitte la chaine en morceaux en fonction de \ afin d'avoir les noms de répertoires
- 'For i = 0 To UBound(Chaine)
- ' wscript.echo "chaine: " & Chaine(i)
- 'Next
- 'Put here what you want to be done
- xlApp.DisplayAlerts = False
- Set xlWB = xlApp.Workbooks.Open(vPath&filepath)
- fName = Chaine(1) & "_Daily_" & Left(Filename, len(filename)-4)
- xlWB.SaveAs fPath & fname &".csv", 6 '6=xlcsv
- xlWB.Close False
- fs=FSO.deletefolder(vPath&Chaine(0)&"\"&chaine(1), True)
- End If
- n=n+1
- Loop
- xlApp.DisplayAlerts = True
- Set xlWB = Nothing
- xlApp.Quit
- Set xlApp = Nothing
- Set vPath = Nothing
- End Sub
- ' Returns an array with the file names that match Path.
- ' The Path string may contain the wildcard characters "*"
- ' and "?" in the file name component. The same rules apply as with the MSDOS DIR command.
- ' If Path is a directory, the contents of this directory is listed.
- ' If Path is empty, the current directory is listed.
- ' Author: Christian d'Heureuse (www.source-code.biz)
- ' Modified by Wilfrid Burel on the 22nd November 2005 in order to be recursive : modification commented and signed
- Public Function ListDir (ByVal Path)
- Dim fso: Set fso = CreateObject("Scripting.FileSystemObject" )
- If Path = "" then Path = "*.*"
- Dim Parent, Filter
- if fso.FolderExists(Path) then ' Path is a directory
- Parent = Path
- Filter = "*"
- Else
- Parent = fso.GetParentFolderName(Path)
- If Parent = "" Then If Right(Path,1) = ":" Then Parent = Path: Else Parent = "."
- Filter = fso.GetFileName(Path)
- If Filter = "" Then Filter = "*"
- End If
- 'ReDim a(10) quote by WB
- Dim Folder: Set Folder = fso.GetFolder(Parent)
- Dim Files: Set Files = Folder.Files
- Dim File
- 'Implementation of recursivity WB
- If Recursivity then
- Dim SubFolder ' WB
- If Folder.SubFolders.Count <> 0 Then 'WB
- For Each SubFolder In Folder.SubFolders ' WB
- ListDir(SubFolder&"\" & Filter) ' WB
- Next ' WB
- End If ' WB
- End If
- Set Files = Folder.Files
- For Each File In Files
- If CompareFileName(File.Name,Filter) Then
- 'wscript.echo "ubound : "&ubound(a,2) & " - "&n
- If n > UBound(a,2) Then ReDim Preserve a(1,n*2)
- a(0,n) = File.Path
- a(1,n) = File.Name
- n = n + 1
- End If
- Next
- ReDim Preserve a(1,n+2)
- ListDir = a
- End Function
- Private Function CompareFileName (ByVal Name, ByVal Filter) ' (recursive)
- CompareFileName = False
- Dim np, fp: np = 1: fp = 1
- Do
- If fp > Len(Filter) Then CompareFileName = np > len(name): Exit Function
- If Mid(Filter,fp) = ".*" Then ' special case: ".*" at end of filter
- If np > Len(Name) Then CompareFileName = True: Exit Function
- End If
- Dim fc: fc = Mid(Filter,fp,1): fp = fp + 1
- Select Case fc
- Case "*"
- CompareFileName = CompareFileName2(name,np,filter,fp)
- Exit Function
- Case "?"
- If np <= Len(Name) And Mid(Name,np,1) <> "." Then np = np + 1
- Case Else
- If np > Len(Name) Then Exit Function
- Dim nc: nc = Mid(Name,np,1): np = np + 1
- If Strcomp(fc,nc,vbTextCompare)<>0 Then Exit Function
- End Select
- Loop
- End Function
- Private Function CompareFileName2 (ByVal Name, ByVal np0, ByVal Filter, ByVal fp0)
- Dim fp: fp = fp0
- Dim fc2
- Do
- If fp > Len(Filter) Then CompareFileName2 = True: Exit Function
- If Mid(Filter,fp) = ".*" Then ' special case: ".*" at end of filter
- CompareFileName2 = True: Exit Function
- End If
- fc2 = Mid(Filter,fp,1): fp = fp + 1
- If fc2 <> "*" And fc2 <> "?" Then Exit Do
- Loop
- Dim np
- For np = np0 To Len(Name)
- Dim nc: nc = Mid(Name,np,1)
- If StrComp(fc2,nc,vbTextCompare)=0 Then
- If CompareFileName(Mid(Name,np+1),Mid(Filter,fp)) Then
- CompareFileName2 = True: Exit Function
- End If
- End If
|
|
![[:ddr555]](https://forum-images.hardware.fr/images/perso/ddr555.gif "[:ddr555]")