Export all charts from multiple Excel files in one folder - image

I want to create a macro for exporting all Excel charts from several workbooks in one folder.
I'm a beginner in VBA and I need your help with the following code:
P.S. The code seems to work (I don't have errors) but does not export any graph to the selected folder.
Could you, please, help me with some hints? I don`t know where is the problem.
Thank you in advance! :)
Sub LoopAllExcelFilesInFolder()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them (export all charts in one folder)
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim objChart As Excel.Chart
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
'myExtension = "*.xls*"
myExtension = "*.xlsx"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
For Each objChart In wb.Charts
objChart.Export myPath & Left(wb.Name, Len(wb.Name) - 5) & "_" & objChart.Name & ".png"
Next objChart
For Each objSheet In wb.Worksheets
For Each objChartObject In objSheet.ChartObjects
With objChartObject.Chart
.Export myPath & Left(wb.Name, Len(wb.Name) - 4) & "_" & .Name & "png" '/export graphs with WorkbookName + _worksheet name
End With
Next
Next
'Save and Close Workbook
wb.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
'Open the windows folder
Shell "Explorer.exe" & " " & myPath, vbNormalFocus
End Sub
Maybe is useful to mention that I wanted to adapt one of my oldest macro (this one export all the charts from a workbook in one folder. Now I need to export all the charts from multiple workbooks in one folder).
Sub ExportAllCharts()
'
' '
' This macro extracts all the graphs from an Excel document and imports them into the selected folder as .PNG images. '
'
' '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim objShell As Object
Dim objWindowsFolder As Object
Dim strWindowsFolder As String
Dim objSheet As Excel.Worksheet
Dim objChartObject As Excel.ChartObject
Dim objChart As Excel.Chart
'Sheets.Select
'ActiveSheet.Select
'Select a Windows folder
Set objShell = CreateObject("Shell.Application")
Set objWindowsFolder = objShell.BrowseForFolder(0, "Select a Windows folder:", 0, "")
If Not objWindowsFolder Is Nothing Then
strWindowsFolder = objWindowsFolder.self.Path & "\"
''''''''''''''''''''''''''
' charts on chart sheets '
''''''''''''''''''''''''''
'For Each objChart In ThisWorkbook.Charts
For Each objChart In ActiveWorkbook.Charts
objChart.Export strWindowsFolder & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5) & "_" & objChart.Name & ".png" '/export graphs with workbook name prefix + _ + worksheet name ( ex: WorkbookName_WorksheetName.png ---> OK)
Next objChart
'Open the windows folder
Shell "Explorer.exe" & " " & strWindowsFolder, vbNormalFocus
End If
End Sub

Related

Running excel vba code on multiple files on Macintosh

I have the following code I wrote in Excel:
Sub Multiple()
MyDir = ActiveWorkbook.Path
strPath = MyDir & ":"
strFile = Dir(strPath, MacID("TEXT"))
'Loop through each file in the folder
Do While Len(strFile) > 0
If Right(strFile, 3) = "csv" Then
Debug.Print strFile
DoWork (strFile)
End If
strFile = Dir
Loop
End Sub
Sub DoWork(wb As Workbook)
With wb
Range("E:E,K:K").Select
Range("K1").Activate
Selection.Delete Shift:=xlToLeft
ActiveSheet.Range("b1").End(xlDown).Select
ActiveCell.FormulaR1C1 = "=AVERAGE(R[-3]C:R[-1]C)/1000"
ActiveSheet.Range("b1").End(xlDown).Select
Selection.AutoFill Destination:=Range(ActiveCell, ActiveCell.Offset(0, 2)), Type:=xlFillDefault
ActiveSheet.Range("e1").End(xlDown).Select
ActiveCell.FormulaR1C1 = "=AVERAGE(R[-3]C:R[-1]C)"
ActiveSheet.Range("e1").End(xlDown).Select
Selection.AutoFill Destination:=Range(ActiveCell, ActiveCell.Offset(0, 4)), Type:=xlFillDefault
End With
End Sub
What I am trying to do is run the bottom Sub DoWork() which does some basic editing on an excel file on my macintosh on multiple files.
For that I wrote the uper Sub Multiple() which should eventually run the bottom Sub on multiple files.
The files type are CSV files.
The bottom code works perfect when running it individually on each Excel file.
However, the top code does not do the trick of running on all multiple files.
Anyone have an idea why?
In your Multiple code, you are passing a string parameter (the filename) to DoWork, but DoWork is expecting you to pass a Workbook object.
You will need to join strPath and strFile together (in Windows that would be strPath & "\" & strFile - I assume it will be something similar on a Mac) and then open the Workbook. I would suggest the following code should be used where you currently are just doing DoWork (strFile):
Set wb = Workbooks.Open(strPath & "\" & strFile) ' Adjust to suit for Mac filename syntax
DoWork wb
wb.Save
wb.Close False
Ok. Figured it out :-)
Sub Multiple()
Dim SecDir As String
Dim MyDir As String
Dim wbk As Workbook
MyDir = "tlv-mpzyw:Users:lcohen:Google Drive:SQA:Projects:vbaBotRegression:"
SecDir = "files:"
strPath = MyDir & SecDir
Debug.Print strPath
strFile = Dir(strPath)
'Loop through each file in the folder
Do While Len(strPath) > 0
If Right(strFile, 3) = "csv" Then
Debug.Print strFile
Set wbk = Workbooks.Open(Filename:=strPath & strFile)
Range("E:E,K:K").Select
Range("K1").Activate
Selection.Delete Shift:=xlToLeft
ActiveSheet.Range("b1").End(xlDown).Select
ActiveCell.FormulaR1C1 = "=AVERAGE(R[-3]C:R[-1]C)/1000"
ActiveSheet.Range("b1").End(xlDown).Select
Selection.AutoFill Destination:=Range(ActiveCell, ActiveCell.Offset(0, 2)), Type:=xlFillDefault
ActiveSheet.Range("e1").End(xlDown).Select
ActiveCell.FormulaR1C1 = "=AVERAGE(R[-3]C:R[-1]C)"
ActiveSheet.Range("e1").End(xlDown).Select
Selection.AutoFill Destination:=Range(ActiveCell, ActiveCell.Offset(0, 4)), Type:=xlFillDefault
wbk.Close SaveChanges:=False
End If
strFile = Dir
Loop
End Sub
Now I have another issue,
Am getting the following error message:
Run-time error '1004':
'TLV-MPZYW:USERS:LCOHEN:GOOGLE
DRIVE:SQA:PROJECTS:VBABOTREGRESSION:FILES:SAMPLES_MULTIPLE_FILTERS_QUERIES-STATISTICS.CSV'
could not be found.Check the spelling of the file name, and verify
that the file location is correct.
If you are trying to open the file from your list of most recently
used files on the File menu, make sure that the file has not been
renamed, moved, or deleted.
I am clueless at this point on what might be causing this issue.
As you can see in my code, I am printing the file name to verify that it indeed reads it correctly.
Anyone?????

VB Script referencing a Variable which is defined from a macro

I need some help with this VB script (edit: it is being used in QlikView)- it is copying a file to a different location (checks if the file already exists in the destination folder).
It works when the source filename and location is hardcoded but this is going to be a variable which is defined in a different macro.
So the source filename and location will be defined by varFileOpen.
Basically in the code, instead of:
SourceFile = "C:\file_path\file_name.txt"
to be like this:
SourceFile = varFileOpen
where varFileOpen has been defined from a different SUB (it is the full file path).... I can't get it to work?
Sub that creates the varFileOpen:
'Sub to get open file dialog
SUB ShowOpen
OpenSave "varFileOpen", 0, "Text file (*.txt)|*.txt|All files (*.*)|*.*", "h:\", "Select a file to open"
END SUB
' Sub to show browse folder dialog
SUB Folder (objVariable)
ON ERROR RESUME NEXT
SET objShell = CREATEOBJECT("Shell.Application")
SET objFolder = objShell.BrowseForFolder (WINDOW_HANDLE, TITLE, OPTIONS, ROOT)
SET objFolderItem = objFolder.Self
strPathAndFile = objFolderItem.Path
SET objSavePath = ActiveDocument.Variables(objVariable)
objSavePath.SetContent strPathAndFile, TRUE
ON ERROR GOTO 0
END SUB
' Sub to show open/save dialog
SUB OpenSave (objVariable, intType, strFilter, strInitialDirectory, strDialogText)
' Create objects
SET objShell = CREATEOBJECT("WScript.Shell")
SET objFSO = CREATEOBJECT("Scripting.FileSystemObject")
strTempDir = objShell.ExpandEnvironmentStrings("%TEMP%")
strTempFile = strTempDir & "\" & objFSO.GetTempName
' Temporary powershell script file to be invoked
strPSFile = tempFile & ".ps1"
' Temporary file to store standard output from command
strPSOutFile = tempFile & ".txt"
' Create script to run
strPSScript = strPSScript & "[System.Reflection.Assembly]::LoadWithPartialName(""System.windows.forms"") | Out-Null" & vbCRLF
' Check type (Open (0) or Save (1))
IF intType = 1 THEN
strPSScript = strPSScript & "$dlg = New-Object System.Windows.Forms.SaveFileDialog" & vbCRLF
ELSE
strPSScript = strPSScript & "$dlg = New-Object System.Windows.Forms.OpenFileDialog" & vbCRLF
END IF
' Set initial directory
strPSScript = strPSScript & "$dlg.initialDirectory = " & CHR(34) & strInitialDirectory & CHR(34) & vbCRLF
' Set file filter/s
strPSScript = strPSScript & "$dlg.filter = " & CHR(34) & strFilter & CHR(34) & vbCRLF
strPSScript = strPSScript & "$dlg.FilterIndex = 1" & vbCRLF
' Set dialog text
strPSScript = strPSScript & "$dlg.Title = " & CHR(34) & strDialogText & CHR(34) & vbCRLF
' Show help (seems it must be set to true)
strPSScript = strPSScript & "$dlg.ShowHelp = $True" & vbCRLF
' Show the dialog
strPSScript = strPSScript & "$dlg.ShowDialog() | Out-Null" & vbCRLF
strPSScript = strPSScript & "Set-Content """ &strPSOutFile & """ $dlg.FileName" & vbCRLF
' Write result
SET objResultFile = objFSO.CreateTextFile(strPSFile, TRUE)
objResultFile.WriteLine(strPSScript)
objResultFile.Close
SET objResultFile = NOTHING
' Run command in PowerShell
strPSCMD = "powershell -ExecutionPolicy unrestricted &'" & strPSFile & "'"
objShell.Run strPSCMD, 0, TRUE
' Open result file and read result
SET objResultFile = objFSO.OpenTextFile(strPSOutFile, 1, 0, -2)
strPathAndFile = objResultFile.ReadLine
objResultFile.Close
SET objResultFile = NOTHING
' Add to result to variable
SET objSavePath = ActiveDocument.Variables(objVariable)
objSavePath.SetContent strPathAndFile, TRUE
' Delete temp-files
objFSO.DeleteFile(strPSFile)
objFSO.DeleteFile(strPSOutFile)
END SUB
The above code opens explorer & you are able to select a file and the path is copied - varFileOpen.
The following SUB moves the file:
SUB movefile
Const DestinationFile = "c:\destfolder\anyfile.txt"
Const SourceFile = "C:\file_path\file_name.txt"
Set fso = CreateObject("Scripting.FileSystemObject")
'Check to see if the file already exists in the destination folder
If fso.FileExists(DestinationFile) Then
'Check to see if the file is read-only
If Not fso.GetFile(DestinationFile).Attributes And 1 Then
'The file exists and is not read-only. Safe to replace the file.
fso.CopyFile SourceFile, "C:\destfolder\", True
Else
'The file exists and is read-only.
'Remove the read-only attribute
fso.GetFile(DestinationFile).Attributes = fso.GetFile(DestinationFile).Attributes - 1
'Replace the file
fso.CopyFile SourceFile, "C:\destfolder\", True
'Reapply the read-only attribute
fso.GetFile(DestinationFile).Attributes = fso.GetFile(DestinationFile).Attributes + 1
End If
Else
'The file does not exist in the destination folder. Safe to copy file to this folder.
fso.CopyFile SourceFile, "C:\destfolder\", True
End If
Set fso = Nothing
END SUB
You will need to pass the value into the Sub for it to have scope, which means you will need to define the sub like this so that it accepts a parameter
Public Sub MySub(byVal SourceFile)
ByVal just means you pass the Value of the variable rather than the actual variable itself.
And you would call it from the other sub with
MySub varFileOpen
EDIT: Based on the code displayed above, you would need to change Sub movefile to Sub movefile(byVal SourceFile) and remove the Const delaration of SourceFile. Once that was done, all you would have to do is change whatever is calling movefile (I can't see anything in the code you've posted doing this?) to call it with movefile varToOpen instead
Try my CustomFileDialog.
Usage:
Dim fDialog
Set fDialog = New CustomFileDialog
fDialog.FilterString = "Text Files (*.txt)|*.txt"
fDialog.InitialDirectory = "C:\"
fDialog.DialogText = "Select a file to open"
fDialog.Show
fDialog.MoveFile "C:\stackoverflow\temp\New File Name.TXT"
CustomFileDialog
Class CustomFileDialog
Public SourceFile
Public FilterString
Public InitialDirectory
Public DialogText
Public Sub Show
Set toolkit = CreateObject("Vbsedit.toolkit")
Files = toolkit.OpenFileDialog(InitialDirectory, FilterString, False, DialogText)
If UBound(Files) >= 0 Then
SourceFile = Files(0)
Else
SourceFile = ""
End If
End Sub
Public Sub MoveFile(DestinationFile)
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(DestinationFile) Then fso.DeleteFile DestinationFile, True
fso.CopyFile SourceFile, DestinationFile, True
End Sub
End Class

VBAScript to delete items from folder

I'm new to VBScripting and have completely no knowledge on how to code but however i understand the basics of VBScripting.
I tried using the search function to find similar cases to mine but it doesn't have what i need.
I would really appreciate any help as my project is due soon.
Scenario:
I need to delete jpeg files that are more than 3months old that is in a directory with lots and lots of subfolders within each other. Furthermore there are 4 folders in the directory that i must not delete or modify.
How i manually did it was to navigate to the mapped drive, to the folder, use the "Search 'Folder'" from the window and type in this "datemodified:‎2006-‎01-‎01 .. ‎2013-‎08-‎31".
It will then show all the folders and subfolders and excel sheets within that folder, i'll then filter the shown list by ticking jpeg only from Type.
Code:
'**** Start of Code **********
Option Explicit
On Error Resume Next
Dim oFSO, oFolder, sDirectoryPath
Dim oFileCollection, oFile, sDir
Dim iDaysOld
' Specify Directory Path From Where You want to clear the old files
sDirectoryPath = "C:\MyFolder"
' Specify Number of Days Old File to Delete
iDaysOld = 15
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(sDirectoryPath)
Set oFileCollection = oFolder.Files
For each oFile in oFileCollection
'This section will filter the log file as I have used for for test case
'Specify the Extension of file that you want to delete
'and the number with Number of character in the file extension
If LCase(Right(Cstr(oFile.Name), 4)) = "jpeg" Then
If oFile.DateLastModified < (Date() - iDaysOld) Then
oFile.Delete(True)
End If
End If
Next
Set oFSO = Nothing
enter code here`Set oFolder = Nothing
enter code here`Set oFileCollection = Nothing
enter code here`Set oFile = Nothing
'******* End of Code **********
I need to set an path that must be excluded + go through sub folders.
I'd like to thank you in advance for helping me out.
Thanks,
Working solution (Jobbo almost got it to work in generic form):
UPDATE: includes log file writing with number of folders skipped and files deleted.
Option Explicit
'set these constants to your requirements
Const DIR = "C:\Test"
Const LOGFILE = "C:\Log.txt" ' Location of Log file
Const MAX_AGE = 3 ' Unit: Months
Const FILEEXT = "jpeg"
Dim oFSO
Dim oLogFile
Dim aExclude
Dim lngDeletes, lngSkips
'add to this array to exclude paths
aExclude = Array("c:\Test\test 1", "c:\Test\test 2\test")
Set oFSO = CreateObject("Scripting.FilesystemObject")
Set oLogFile = oFSO.createtextfile(LOGFILE)
lngDeletes = 0
lngSkips = 0
LOGG "Script Start time: " & Now
LOGG "Root Folder: " & DIR
LOGG String(50, "-")
deleteFiles oFSO.GetFolder(DIR)
LOGG String(50, "-")
LOGG lngDeletes & " files are deleted"
LOGG lngSkips & " folders skipped"
LOGG "Script End time: " & Now
oLogFile.Close
Set oLogFile = Nothing
Set oFSO = Nothing
MsgBox "Logfile: """ & LOGFILE & """", vbInformation, wscript.scriptName & " Completed at " & Now
wscript.Quit
'=================================
Sub LOGG(sText)
oLogFile.writeline sText
End Sub
'=================================
Function isExclude(sPath)
Dim s, bAns
bAns = False
For Each s In aExclude
If InStr(1, sPath, s, vbTextCompare) = 1 Then
bAns = True
Exit For
End If
Next
isExclude = bAns
End Function
'=================================
Function isOldFile(fFile)
' Old file if "MAX_AGE" months before today is greater than the file modification time
isOldFile = (DateAdd("m", -MAX_AGE, Date) > fFile.DateLastModified)
End Function
'==================================
Function isFileJPEG(fFile)
Dim sFileName
sFileName = fFile.Name
' Mid(sFileName, InStrRev(sFileName, ".")) gives you the extension with the "."
isFileJPEG = (LCase(Mid(sFileName, InStrRev(sFileName, ".") + 1)) = FILEEXT)
End Function
'==================================
Sub deleteFiles(fFolder)
Dim fFile, fSubFolder
If Not isExclude(fFolder.Path) Then
'WScript.echo "==>> """ & fFolder.Path & """" ' Comment for no output
For Each fFile In fFolder.Files
If isFileJPEG(fFile) And isOldFile(fFile) Then
lngDeletes = lngDeletes + 1
LOGG lngDeletes & vbTab & fFile.Path
'WScript.echo vbTab & "DELETE: """ & fFile.Path & """" ' Comment for no output
fFile.Delete True ' Uncomment to really delete the file
End If
Next
' Only Process sub folders if current folder is not excluded
For Each fSubFolder In fFolder.SubFolders
deleteFiles fSubFolder
Next
Else
lngSkips = lngSkips + 1
'WScript.echo "<<-- """ & fFolder.Path & """" ' Comment for no output
End If
End Sub
Never ever use On Error Resume Next unless it absolutely cannot be avoided.
This problem needs a recursive function. Here's how I would do it:
Option Explicit
'set these constants to your requirements
Const DIR = "C:\MyFolder"
Const AGE = 15
Dim oFSO
Dim aExclude
'add to this array to exclude paths
aExclude = Array("c:\folder\exclude1", "c:\folder\another\exclude2")
Set oFSO = CreateObject("Scripting.FilesystemObject")
Call deleteFiles(oFSO.GetFolder(DIR))
Set oFSO = Nothing
WScript.Quit
'=================================
Function isExclude(sPath)
Dim s
For Each s in aExclude
If LCase(s) = LCase(sPath) Then
isExclude = True
Exit Function
End If
Next
isExclude = False
End Function
'==================================
Sub deleteFiles(fFolder)
Dim fFile, fSubFolder
If Not isExclude(fFolder.Path) Then
For Each fFile in fFolder.Files
If (LCase(Right(Cstr(fFile.Name),4)) = "jpeg") And (fFile.DateLastModified < (Date() - AGE)) Then
'WScript.echo fFile.Path 'I put this in for testing, uncomment to do the same
Call fFile.Delete(true)
End If
Next
End If
For Each fSubFolder in fFolder.SubFolders
Call deleteFiles(fSubFolder)
Next
End Sub
I'm not really able to fully test it out because I don't have an example data set, but really all you need to do is set DIR and change the aExclude array. Make sure you know what its going to delete before you run it though...
Also, it will only delete jpeg extensions, not jpg but I imagine you already know that

VB.Net - List files & subfolders from a specified Directory and save to a text document, and sort results

I am working on a project that requires me to search and list all files in a folder that could have multiple sub folders and write it to text documents.
Primarily the file extension i will be searching for is a .Doc, but I will need to list the other files found in said directory as well.
To make things slightly more difficult I want the text documents to be sorted by File type and another by Directory.
I do not know how possible this is, but I have search for methods online, but have as of yet found correct syntax.
Any help will be greatly appreciated.
I write this in the past, should server as a base for your version. I know it's not .NET, still I hope it helps something. It prompts the user for a path to scan, recurses into folders, and writes the file name, path, and owner into a CSV file. Probably really inefficient and slow, but does the job.
Main() ' trickster yo
Dim rootFolder 'As String
Dim FSO 'As Object
Dim ObjOutFile
Dim objWMIService 'As Object
Sub Main()
StartTime = Timer()
If Wscript.Arguments.Count = 1 Then ' if path provided with the argument, use it.
rootFolder = Wscript.Arguments.Item(0)
Else
rootFolder = InputBox("Give me the search path : ") ' if not, ask for it
End If
Set FSO = CreateObject("Scripting.FileSystemObject")
Set ObjOutFile = FSO.CreateTextFile("OutputFiles.csv")
Set objWMIService = GetObject("winmgmts:")
ObjOutFile.WriteLine ("Path, Owner") ' set headers
Gather (rootFolder)
ObjOutFile.Close ' close the stream
EndTime = Timer()
MsgBox ("Done. (ran for " & FormatNumber(EndTime - StartTime, 2) & "s.)")
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function Gather(FolderName)
On Error Resume Next
Dim ObjFolder
Dim ObjSubFolders
Dim ObjSubFolder
Dim ObjFiles
Dim ObjFile
Set ObjFolder = FSO.GetFolder(FolderName)
Set ObjFiles = ObjFolder.Files
For Each ObjFile In ObjFiles 'Write all files to output files
Set objFileSecuritySettings = _
objWMIService.Get("Win32_LogicalFileSecuritySetting='" & ObjFile.Path & "'")
intRetVal = objFileSecuritySettings.GetSecurityDescriptor(objSD)
If intRetVal = 0 Then
owner = objSD.owner.Domain & "\" & objSD.owner.Name
ObjOutFile.WriteLine (ObjFile.Path & ";" & owner) ' write in CSV format
End If
Next
Set ObjSubFolders = ObjFolder.SubFolders 'Getting all subfolders
For Each ObjFolder In ObjSubFolders
Set objFolderSecuritySettings = _
objWMIService.Get("Win32_LogicalFileSecuritySetting='" & ObjFile.Path & "'")
intRetVal = objFolderSecuritySettings.GetSecurityDescriptor(objSD)
If intRetVal = 0 Then
owner = objSD.owner.Domain & "\" & objSD.owner.Name
ObjOutFile.WriteLine (ObjFolder.Path & ";" & owner) ' write in CSV format
End If
Gather (ObjFolder.Path)
Next
End Function

VBScript to Move files with particular extension

I currently have a VBscript that scans a folder for files and moves the files to particular folders depending on key words in the file name.
I need currently the script only scans the one level (ie. doesn't scan recursively) and I need to to search all sub folders too.
Can someone give me a hand with this?
EDIT: Since writing this script I have realized that I need to have this only move files with particular extensions from a particular folder and sub folders to other directories based on the file name.
For example I need only .mp4 and .avi files to be moved.
Can someone help me with this please? I have tried multiple things but still can't get the recursive scanning and moving or the extension specific moving working.
Below is my current script.
'========================================================
' Script to Move Downloaded TV Shows and Movies to
' correct folders based on wildcards in File Name
'========================================================
On Error Resume Next
Dim sTorrents, sTV, sMovie, sFile, oFSO
' create the filesystem object
Set oFSO = WScript.CreateObject("Scripting.FileSystemObject")
' Create Log File
Set objLog = oFSO.OpenTextFile("c:\temp\log.txt", 8, True)
' Set Variables
sTorrents = "C:\Temp\torrents\"
sTV = "C:\Temp\TV Shows\"
sMovie = "C:\Temp\Movies\"
' Scan each file in the folder
For Each sFile In oFSO.GetFolder(sTorrents).Files
' check if the file name contains TV Show Parameters
If InStr(1, sFile.Name, "hdtv", 1) OR InStr(1, sFile.Name, "s0", 1) <> 0 Then
' TV Show Detected - Move File
objLog.WriteLine Now() & " - " & sFile.Name & " Detected as TV Show - Moving to " & sTV
oFSO.MoveFile sTorrents & sFile.Name, sTV & sFile.Name
' Move all other Files to Movies Directory
Else objLog.WriteLine Now() & " - " & sFile.Name & " Detected as Movie - Moving to " & sMovie
oFSO.MoveFile sTorrents & sFile.Name, sMovie & sFile.Name
End If
Next
If sTorrents.File.Count = 0 And sTorrents.SubFolders.Count = 0 Then
objLog.WriteLine Now() & " - There is nothing left to Process..."
objLog.Close
End If
Some notes:
Sub listfolders(startfolder)
Dim fs
Dim fl1
Dim fl2
Set fs = CreateObject("Scripting.FileSystemObject")
Set fl1 = fs.GetFolder(startfolder)
For Each fl2 In fl1.SubFolders
Debug.Print fl2.Path
''process the files
ProcessFiles fl2.Path
'Recursion: lists folders for each subfolder
listfolders fl2.Path
Next
End Sub
''Code copied from question
Sub ProcessFiles(sPath)
' Scan each file in the folder
For Each sFile In oFSO.GetFolder(sPath).Files
' check if the file name contains TV Show Parameters
If InStr(1, sFile.Name, "hdtv", 1) OR InStr(1, sFile.Name, "s0", 1) <> 0 Then
' TV Show Detected - Move File
objLog.WriteLine Now() & " - " _
& sFile.Name & " Detected as TV Show - Moving to " & sTV
oFSO.MoveFile sTorrents & sFile.Name, sTV & sFile.Name
' Move all other Files to Movies Directory
Else
objLog.WriteLine Now() & " - " _
& sFile.Name & " Detected as Movie - Moving to " & sMovie
oFSO.MoveFile sTorrents & sFile.Name, sMovie & sFile.Name
End If
Next
End Sub
before the extension put a * that will find all files with that externsion.
Example: oFSO.MoveFile (PATH\*.EXTERNSION)
here is a recusive function to list files in folders and sub folders
it's tested and working, but you'll probably need some adaptation to your own forkflow. And it's not the most optimized, but it's simple to read
Sub test()
aFiles = F_ListFilesInDirAndSubDir("C:\foo\folder")
'then, add some code to parse the array:
For i = 0 to UBound(aFiles)
'Move or not to move, that is what your code should tell
Next
End Sub
Public Function F_ListFilesInDirAndSubDir(ByVal sDir)
'===============================================================================
'Get the list of files in a directory and in all its sub directories With the full path
'===============================================================================
Dim sChild As String
Dim aFolders As Variant
Dim aFiles As Variant
Dim aChildFiles As Variant
Dim i As Long
Dim j As Long
F_ListFilesInDirAndSubDir = aFiles
Set fs = CreateObject("Scripting.FileSystemObject")
If Not fs.FolderExists(sDir) Then Exit Function
'Get the files in the directory
aFiles = F_ListFilesInDir(sDir)
'Add the fullpath
For i = 0 To UBound(aFiles)
If aFiles(i) <> "" Then
aFiles(i) = sDir & "\" & CStr(aFiles(i))
End If
Next
'get the folders
aFolders = F_ListFoldersInDir(sDir)
'for each folders, push the files in the file list
For i = 0 To UBound(aFolders)
If aFolders(i) <> "" Then
sChild = sDir & "\" & CStr(aFolders(i))
'Recursive call on each folders
aChildFiles = F_ListFilesInDirAndSubDir(sChild)
'Push new items
For j = 0 To UBound(aChildFiles)
If aChildFiles(j) <> "" Then
ReDim Preserve aFiles(UBound(aFiles) + 1)
aFiles(UBound(aFiles)) = aChildFiles(j)
End If
Next
End If
Next
F_ListFilesInDirAndSubDir = aFiles
End Function
Public Function F_ListFilesInDir(ByVal sDir)
'===============================================================================
'Get the list of files in a directory
'===============================================================================
Dim aList As Variant
Dim i As Long
Dim iChild As Long
Dim oFile
Dim oFolder
Dim oChildren
ReDim aList(0)
F_ListFilesInDir = aList
Set fs = CreateObject("Scripting.FileSystemObject")
If Not fs.FolderExists(sDir) Then Exit Function
Set oFolder = fs.GetFolder(sDir)
Set oChildren = oFolder.Files
iChild = CDbl(oChildren.Count) - 1
If iChild = -1 Then Exit Function
ReDim aList(iChild)
i = 0
For Each oFile In oChildren
aList(i) = oFile.Name
i = i + 1
Next
F_ListFilesInDir = aList
End Function
Public Function F_ListFoldersInDir(ByVal sDir As String) As Variant
'===============================================================================
'Get the list of folders in a directory
'===============================================================================
Dim aList As Variant
Dim i As Long
Dim oDir
Dim oFolder
Dim oChildren
ReDim aList(0)
F_ListFoldersInDir = aList
Set fs = CreateObject("Scripting.FileSystemObject")
If Not fs.FolderExists(sDir) Then Exit Function
Set oFolder = fs.GetFolder(sDir)
Set oChildren = oFolder.SubFolders
If oChildren.Count = 0 Then Exit Function
ReDim aList(oChildren.Count - 1)
i = 0
For Each oDir In oChildren
aList(i) = oDir.Name
i = i + 1
Next
F_ListFoldersInDir = aList
End Function

Resources