This is probably pretty basic, but I'm hitting a brick wall. I have several subfolders within a directory that have multiple Microsoft Access Runtime Application (.accdr) files in each subfolder. I need to make a copy of each .accdr, change the extension to .accdb, and drop each into the same existing subfolder.
The command I have working if I cd to each subfolder is:
copy *.accdr *.accdb
I was hoping I could recursively go through the whole directory and execute this command so I wouldn't have to cd to each folder. However what I've written is not working. From the output, it seems to cycle through each folder, but it doesn't make any .accdb copies. The error just says "The system cannot find the file specified."
FOR /R "c:\directory\" %F IN (.) DO (
copy *.accdr *.accdb
)
What am I missing? Thanks in advance.
Ok, you can do it with this routine:
Sub dirTest()
Dim dlist As New Collection
Dim startDir As String
Dim i As Integer
startDir = "C:\foxpro2\"
Call FillDir(startDir, "*.dbf", dlist)
MsgBox "there are " & dlist.Count & " in the dir"
'lets printout the stuff into debug window for a test
For i = 1 To dlist.Count
Debug.Print dlist(i)
Next i
End Sub
Sub FillDir(startDir As String, strFil As String, dlist As Collection)
Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant
strTemp = Dir(startDir & strFil)
Do While strTemp <> ""
dlist.Add startDir & strTemp
strTemp = Dir()
Loop
strTemp = Dir(startDir & "*.*", vbDirectory)
Do While strTemp <> ""
If (GetAttr(startDir & strTemp) And vbDirectory) = vbDirectory Then
If (strTemp <> ".") And (strTemp <> "..") Then
colFolders.Add strTemp
End If
End If
strTemp = Dir()
Loop
For Each vFolderName In colFolders
Call FillDir(startDir & vFolderName & "\", strFil, dlist)
Next vFolderName
End Sub
Related
I'm organizing my photos so I would like a VBscript that can Write all TAGs from my photos in a Txt file. The Script Will read the Tags from the photos that are saved on different subfolders and Write all the Tags without repetions, so I can have a list of unique Tags on this file.
The txtFile will be saved on same directory of the Vbs file.
My folder has subfolders.
The following code was developed to be used on Excel (VBA). I tried to translate it to VBS but without success. Credits to MVP Rick Rothstein.
I guess it is a start if we can modify the code to VBS.
Sub UniqueTextFileItems()
Dim R As Long, FileNum As Long, TotalFile As String, Data As Variant
FileNum = FreeFile
Open "c:\temp\test.txt" For Binary As #FileNum
TotalFile = Space(LOF(FileNum))
Get #FileNum , , TotalFile
Close #FileNum
Data = Split(Join(Split(TotalFile, vbCrLf), ","), ",")
With CreateObject("Scripting.Dictionary")
For R = 0 To UBound(Data)
If Len(Data(R)) Then .Item(Data(R)) = 1
Next
Data = .Keys
End With
With CreateObject("System.Collections.ArrayList")
For R = 0 To UBound(Data)
.Add Data(R)
Next
.Sort
Range("A1").Resize(.Count) = Application.Transpose(.ToArray)
End With
End Sub
Searching in this forum I found the amazing code below for getting the unique values from arrays.
Getting Unique Values from Arrays
Now I need to know how to solve the problem on line code inside the loop:
Set objDirectory = objShell.Namespace(vFile)
Dim myArr As Variant
Sub TestFunction()
Dim colFiles As New Collection
Dim MyPath As String
MyPath = "C:\Photos"
ReDim Preserve myArr(0)
RecursiveDir colFiles, MyPath, "*.jpg", True
Dim objShell: Set objShell = CreateObject("Shell.Application")
Dim objDirectory
Dim vFile As Variant
For Each vFile In colFiles
'I'm getting Error here - I cannot dynamically refer the namespace
Set objDirectory = objShell.Namespace(vFile)
ReDim Preserve myArr(UBound(myArr) + 1)
If Len(Trim(objDirectory.GetDetailsOf(vrFile, 18))) > 0 Then
myArr(UBound(myArr)) = objDirectory.GetDetailsOf(vrFile, 18)
Else
End If
Next vFile
End Sub
Public Function RecursiveDir(colFiles As Collection, _
strFolder As String, _
strFileSpec As String, _
bIncludeSubfolders As Boolean)
Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant
'Add files in strFolder matching strFileSpec to colFiles
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
colFiles.Add strFolder & strTemp
strTemp = Dir
Loop
If bIncludeSubfolders Then
'Fill colFolders with list of subdirectories of strFolder
strTemp = Dir(strFolder, vbDirectory)
Do While strTemp <> vbNullString
If (strTemp <> ".") And (strTemp <> "..") Then
If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
colFolders.Add strTemp
End If
End If
strTemp = Dir
Loop
'Call RecursiveDir for each subfolder in colFolders
For Each vFolderName In colFolders
Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
Next vFolderName
End If
End Function
Public Function TrailingSlash(strFolder As String) As String
If Len(strFolder) > 0 Then
If Right(strFolder, 1) = "\" Then
TrailingSlash = strFolder
Else
TrailingSlash = strFolder & "\"
End If
End If
End Function
I am using this code to zip all files in a folder into a newly created .zip file:
Dim FileNameZip, FolderName
Dim filename As String, DefPath As String
Dim oApp As Object
(defining all paths needed)
'Create empty Zip File
NewZip (FileNameZip)
Set oApp = CreateObject("Shell.Application")
'Copy the files to the compressed folder
oApp.Namespace(FileNameZip).CopyHere oApp.Namespace(FolderName).items
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(FileNameZip).items.Count = oApp.Namespace(FolderName).items.Count
Application.Wait (Now + TimeValue("0:00:01"))
Loop
This works without problems as long as my target folder is different from the folder where my files are.
But I have a problem when I try to take all files from a folder, put them into .zip and have the archive generated in the same folder - it creates the archive and then tries to put it into itself, which of course fails.
I am looking for a way to zip all files from a folder except this one newly created.
I looked here: https://msdn.microsoft.com/en-us/library/office/ff869597.aspx but this looks very Outlook-specific and I have no idea how to apply this to a Windows folder.
Rather than add all files at once, which will include the zip file you create, loop through the files with the FileSystemObject and compare their names against the zip file name before adding to the zip:
Sub AddFilesToZip()
Dim fso As Object, zipFile As Object, objShell As Object
Dim fsoFolder As Object, fsoFile As Object
Dim timerStart As Single
Dim folderPath As String, zipName As String
folderPath = "C:\Users\darre\Desktop\New folder\" ' folder to zip
zipName = "myzipfile.zip" ' name of the zip file
Set fso = CreateObject("Scripting.FileSystemObject") ' create an fso to loop through the files
Set zipFile = fso.CreateTextFile(folderPath & zipName) ' create the zip file
zipFile.WriteLine Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(18, 0)
zipFile.Close
Set objShell = CreateObject("Shell.Application")
Set fsoFolder = fso.GetFolder(folderPath)
For Each fsoFile In fsoFolder.Files ' loop through the files...
Debug.Print fsoFile.name
If fsoFile.name <> zipName Then ' and check it's not the zip file before adding them
objShell.Namespace("" & folderPath & zipName).CopyHere fsoFile.Path
timerStart = Timer
Do While Timer < timerStart + 2
Application.StatusBar = "Zipping, please wait..."
DoEvents
Loop
End If
Next
' clean up
Application.StatusBar = ""
Set fsoFile = Nothing
Set fsoFolder = Nothing
Set objShell = Nothing
Set zipFile = Nothing
Set fso = Nothing
MsgBox "Zipped", vbInformation
End Sub
I would create the zip file in the temporary folder and finally move it to the destination folder. Two notes worth mentioning:
1- The approach of looping until the Item counts are the same in the folder and the zip file is risky, because if the zipping fails for an individual item, it results in an infinite loop. For this reason it's preferable to loop as long as the zip file is locked by the shell.
2- I will use early binding with the Shell because late-binding the Shell32.Application seems to have issues on some installations. Add a reference to Microsoft Shell Controls and Automation
Sub compressFolder(folderToCompress As String, targetZip As String)
If Len(Dir(targetZip)) > 0 Then Kill targetZip
' Create a temporary zip file in the temp folder
Dim tempZip As String: tempZip = Environ$("temp") & "\" & "tempzip1234.zip"
CreateObject("Scripting.FileSystemObject").CreateTextFile(tempZip, True).Write _
Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
' compress the folder into the temporary zip file
With New Shell ' For late binding: With CreateObject("Shell32.Application")
.Namespace(tempZip).CopyHere .Namespace(folderToCompress).Items
End With
' Move the temp zip to target. Loop until the move succeeds. It won't
' succeed until the zip completes because zip file is locked by the shell
On Error Resume Next
Do Until Len(Dir(targetZip)) > 0
Application.Wait Now + TimeSerial(0, 0, 1)
Name tempZip As targetZip
Loop
End Sub
Sub someTest()
compressFolder "C:\SO\SOZip", "C:\SO\SOZip\Test.zip"
End Sub
I found zipping via VBA to be hard to control without third party tools, the below may not be a direct answer but may aid as a solution. The below is an excerpt of the code I used to generate epubs which are not much more than zip files with a different extension. This zipping section never failed in hundreds of runs.
Public Function Zip_Create(ByVal StrFilePath As String) As Boolean
Dim FSO As New FileSystemObject
Dim LngCounter As Long
If Not FSO.FileExists(StrFilePath) Then
'This makes the zip file, note the FilePath also caused issues
'it should be a local file, suggest root of a drive and then use FSO
'to open it
LngCounter = FreeFile
Open StrFilePath For Output As #LngCounter
Print #LngCounter, "PK" & Chr(5) & Chr(6) & String(18, vbNullChar)
Close #LngCounter
End If
Zip_Create = True
End Function
Public Function Zip_Insert(ByVal StrZipFilePath As String, ByVal StrObject As String) As Boolean
Dim BlnYesNo As Boolean
Dim LngCounter As Long
Dim LngCounter2 As Long
Dim ObjApp As Object
Dim ObjFldrItm As Object
Dim ObjFldrItms As Object
Dim StrContainer As String
Dim StrContainer2 As String
If Procs.Global_IsAPC Then
'Create the zip if needed
If Not FSA.File_Exists(StrZipFilePath) Then
If Not Zip_Create(StrZipFilePath) Then
Exit Function
End If
End If
'Connect to the OS Shell
Set ObjApp = CreateObject("Shell.Application")
'Pause, if it has just been created the next piece of
'code may not see it yet
LngCounter2 = Round(Timer) + 1
Do Until CLng(Timer) > LngCounter2
DoEvents
Loop
'Divide the path and file
StrContainer = Right(StrObject, Len(StrObject) - InStrRev(StrObject, "\"))
StrObject = Left(StrObject, Len(StrObject) - Len(StrContainer))
'Connect to the file (via the path)
Set ObjFldrItm = ObjApp.NameSpace(CVar(StrObject)).Items.Item(CVar(StrContainer))
'Pauses needed to avoid all crashes
LngCounter2 = CLng(Timer) + 1
Do Until CLng(Timer) > LngCounter2
DoEvents
Loop
'If it is a folder then check there are items to copy (so as to not cause and error message
BlnYesNo = True
If ObjFldrItm.IsFolder Then
If ObjFldrItm.GetFolder.Items.Count = 0 Then BlnYesNo = False
End If
If BlnYesNo Then
'Take note of how many items are in the Zip file
'Place item into the Zip file
ObjApp.NameSpace(CVar(StrZipFilePath)).CopyHere ObjFldrItm
'Pause to stop crashes
LngCounter2 = CLng(Timer) + 1
Do Until CLng(Timer) > LngCounter2
DoEvents
Loop
'Be Happy
Zip_Insert = True
End If
Set ObjFldrItm = Nothing
Set ObjApp = Nothing
End If
End Function
I'm using this code to get the subfolders of a directory:
Dim fo As Scripting.Folder
Set fo = fso.GetFolder(m_sFolder)
Dim nSubfolder As Scripting.Folder
For Each nSubfolder In fo.SubFolders
Debug.Print "Folder " & fo.Path & " has subfolder " & nSubfolder
Next
Now when m_sFolder is "C:\Users\MyUser\Documents", one subfolder is "C:\Users\MyUser\Documents\Eigene Bilder".
"Eigene Bilder" is what Windows calls the folder "My Pictures" in German language.
However, the folder "C:\Users\MyUser\Documents" doesn't contain either "My Pictures", "Pictures" or "Eigene Bilder".
The folder "My Pictures" is to be found here:
C:\Users\MyUser\Pictures
Can anybody tell me why FSO might want to tell me that this directory "C:\Users\MyUser\Documents\Eigene Bilder" exists?
I'm completely baffled.
It's not a Directory it's a Junction (or Reparse) Point which is like a redirection to another location at the filesystem level.
dir "C:\Users\MyUser\Documents\" /ad
From the command line will list these with a <JUNCTION> tag (as opposed to <DIR>).
There is no need to use the FSO, the built in filesystem functions will not include these:
Dim path As String: path = "C:\Users\MyUser\Documents\"
Dim dirn As String
dirn = Dir$(path, vbDirectory)
Do While dirn <> ""
If (GetAttr(path & dirn) And vbDirectory) = vbDirectory And dirn <> "." And dirn <> ".." Then
Debug.Print path & dirn
End If
dirn = Dir$()
Loop
If you insist on using the FSO you need to be aware of these things. This example makes an attempt to be aware, and should give you the information you need to deal with this:
Const ssfPERSONAL = 5
Const FILE_ATTRIBUTE_REPARSE_POINT = &H400&
Dim TargetFolderPath As String
Dim SubFolder As Scripting.Folder
Dim SubFile As Scripting.File
'Don't early-bind to Shell32 objects, Microsoft has failed
'to maintain binary compatibility across Windows versions:
TargetFolderPath = CreateObject("Shell.Application").NameSpace(ssfPERSONAL).Self.Path
Debug.Print TargetFolderPath
With New Scripting.FileSystemObject
With .GetFolder(TargetFolderPath)
For Each SubFolder In .SubFolders
With SubFolder
Debug.Print .Name;
Debug.Print " ["; .Type;
If .Attributes And FILE_ATTRIBUTE_REPARSE_POINT Then
Debug.Print ", reparse point";
End If
Debug.Print "]"
End With
Next
For Each SubFile In .Files
With SubFile
Debug.Print .Name; " ["; .Type; "]"
End With
Next
End With
End With
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
Ive been searching for this for like decades with no success.
I need to find out if a subdfolder that i ve given the name is exist..
For i = 0 To 3 'got 4 different loc to check sub folders
Set f = fso.GetFolder(backupdir(i))
Set sf = f.SubFolders
For Each fr In sf 'for each folder in sub folder
Do Until fr = "" Or fr = Null
If fso.FolderExists(fr.SubFolders) Then
'if more sub folders exist i wanna make sure
'that i can get their subfolders too
'till there is no sub folder left..
sf = fr
End If
Loop
Next fr
Next i
Actions like traversing the folders-of-a-folder-of-a-folder... is called recursing.
The FindFirstFile: Recursive Search for Folders Using a Folder Mask (minimal code) example here shows how to do this quickly with the windows API.
Check this code.
Dim FolderList As String
Private Sub SubCheck1(folderToCheck As String)
Dim fso, f, f1, s, sf
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFolder(folderToCheck)
Set sf = f.SubFolders
For Each f1 In sf
FolderList = FolderList & "|" & f1.Name
Call SubCheck1(f1.Path)
Next
End Sub
Private Sub Form_Load()
Call SubCheck1("c:\folderToSearch")
Debug.Print FolderList
End Sub
This code gets all the subfolders in the specified directory(c:\folderToSearch in this case) and writes them into the string FolderList with a "|" seperator.
You can also use an array instead of separating folder names with a "|".
Or you can add the code below after the Debug.Print FolderList line in Form_Load to get an array:
myArray = split(FolderList, "|")
You can "recurse" subfolders with a collection and standard Dir function in 20 lines of code like this
Private Sub Command1_Click()
Dim vElem As Variant
For Each vElem In pvGetFolders("C:\TEMP")
Debug.Print vElem
Next
End Sub
Private Function pvGetFolders(ByVal sRoot As String) As Collection
Dim lIdx As Long
Dim sFile As String
Set pvGetFolders = New Collection
pvGetFolders.Add sRoot
Do While lIdx < pvGetFolders.Count
lIdx = lIdx + 1
sFile = Dir(pvGetFolders.Item(lIdx) & "\*.*", vbDirectory)
Do While LenB(sFile) <> 0
If sFile <> "." And sFile <> ".." Then
sFile = pvGetFolders.Item(lIdx) & "\" & sFile
If (GetAttr(sFile) And vbDirectory) <> 0 Then
pvGetFolders.Add sFile
End If
End If
sFile = Dir
Loop
Loop
pvGetFolders.Remove 1
End Function
You could use WMI. You could search in CIM_Directory, I believe the field name is "name",
and if it contains the folder or partially the foldername you are looking for, return the full name.