I am looking to write a VB script to keep a folder tidy up. The rules are:
Check if any file was changed today
If at least one file was changed today move all the files last changed 2 days ago to another folder
This is what I have so far:
strFolder = "c:\testdelete"
objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strFolder)
Set colFiles = objFolder.Files
For Each objFile In colFiles
If DateDiff("N",objFile.DateLastModified,Now()) > 4320 Then
objFSO.DeleteFile(objFile),True End if Next
This however is not working.
Iterate over the files in the folder while
building a list of the files modified at least 2 days ago, and
checking if a file was modified today.
Something like this should work:
Set fso = CreateObject("Scripting.FileSystemObject")
Set oldFiles = CreateObject("System.Collections.ArrayList")
today = Date
threshold = Date - 1
fileModifiedToday = False
For Each f In fso.GetFolder("C:\some\folder").Files
If f.DateLastModified >= today Then fileModifiedToday = True
If f.DateLastModified < threshold Then oldFiles.Add f
Next
If fileModifiedToday Then
For Each f In oldFiles
f.Move "C:\other\folder\"
Next
End If
So to compare the dates of the file and the current day you can utilize the DateValue() Function which returns only the date of the DateTime variable. Then you can utilize the MoveFile command which works like objFSO.MoveFile(FileObject, DestinationFolder)
Dim strFolder, Dest
On Error Resume Next 'Move to manual error handling.
strFolder = "c:\testdelete"
Dest = "C:\testmove"
Dim objFSO, objFolder, colFiles, objFile
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strFolder)
Set colFiles = objFolder.Files
For Each objFile In colFiles
If DateValue(objFile.DateLastModified) = DateValue(Now) Then
objFSO.MoveFile(objFile, Dest)
if err.number <> 0 then msgbox "Destination does not exist"
err.clear
ElseIf DateDiff("N",objFile.DateLastModified,Now()) > 4320 Then
objFSO.DeleteFile(objFile,True)
if err.number <> 0 then msgbox "Unable to delete file"
err.clear
End if
Next
Related
I am trying to edit code that someone else wrote. I have done NO VBA and very little coding in general.
The original code is written for a 5 digit number and we now have files that are six digits. I have tried to copy the code but change it to 6 digit numbers below the current code above Next objFile at the end. This has not worked.
The main issue here is I didn't write the original code and I don't understand the logic. I have tried just changing all of the 5's to 6's and the 99999 to 999999. I have tried copying from Folder = "" down, changing them to 6 digits and pasting below Next objFile. This didn't work either.
Sub CopyPics()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim varDirectory As Variant
Dim objSubFolder As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(Application.ActiveWorkbook.Path)
Dim Dest As String
Dest = "R:\Field Assurance\FA PHOTOS AND INFORMATION\"
'Loop through each file in this folder
For Each objFile In objFolder.Files
Folder = "" 'Empty old folder name
MainFolder = "" 'Empty old folder name
For i = 1 To Len(objFile.Name)
Test = Mid(objFile.Name, i, 5)
If Test >= 10000 And Test <= 99999 Then 'For files: Find any five numbers in a row and assume it to be the file number.
Folder = "NC-" & Mid(objFile.Name, i, 5) 'If found, create new folder.
i = Len(objFile.Name) 'In other words, take the first 5 numbers, then get out.
End If
Next
For Each objSubFolder In objFolder.subfolders 'Find the main folder.
If Right(Folder, 5) >= Mid(objSubFolder.Name, 4, 5) And Right(Folder, 5) <= Mid(objSubFolder.Name, 18, 5) Then 'If my file number is within the main folder bounds...
MainFolder = objSubFolder.Name & "\" 'Use that folder.
End If
Next objSubFolder
If Len(Folder) = 8 And Len(MainFolder) = 23 Then 'If real folders are identified...
On Error Resume Next
If Dir(Dest & MainFolder & Folder) = "" Then 'Check to see if the directory/folder does not exist...
objFSO.CreateFolder (Dest & MainFolder & Folder) 'If not, make one.
End If
'Rename that file's directory to be the new one - aka cut and paste file into new folder.
Name Application.ActiveWorkbook.Path & "\" & objFile.Name As Dest & MainFolder & Folder & "\" & objFile.Name
End If
Next objFile
ActiveWorkbook.Close
End Sub
This is a bit more complex than your original code but I think it's more robust...
Lightly tested.
Option Explicit
Sub CopyPics()
'use constants for fixed values
Const DEST As String = "R:\Field Assurance\FA PHOTOS AND INFORMATION\"
Dim objFSO As Object, srcFolder As Object, objFile As Object
Dim objSubFolder As Object, destFolder As Object, fNum, folderName, picFolderName
Dim FileWasMoved As Boolean, sMsg
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set srcFolder = objFSO.GetFolder(Application.ActiveWorkbook.Path) 'ThisWorkbook.Path ?
Set destFolder = objFSO.GetFolder(DEST) 'parent destination folder
'Loop through each file in this folder
For Each objFile In srcFolder.Files
FileWasMoved = False 'reset "moved" flag
fNum = ExtractNumber(objFile.Name) 'get the file number
If Len(fNum) > 0 Then 'any number found?
folderName = "NC-" & fNum
For Each objSubFolder In destFolder.subfolders 'Find the subfolder.
If IsTheCorrectFolder(objSubFolder.Name, fNum) Then
picFolderName = objSubFolder.Path & "\" & folderName
If Not objFSO.folderexists(picFolderName) Then
objFSO.CreateFolder picFolderName
End If
'move the file
Name objFile.Path As picFolderName & "\" & objFile.Name
FileWasMoved = True 'flag file as moved
Exit For
End If
Next objSubFolder
End If 'filename contains a number
'if file was not moved then add it to the list....
If Not FileWasMoved Then sMsg = sMsg & vbLf & objFile.Name
Next objFile
'warn user if some files were not moved
If Len(sMsg) > 0 Then
MsgBox "Some files were not moved:" & vbLf & sMsg, vbExclamation
End If
End Sub
'Return true/false depending on whether this is the correct
' folder to hold the specified filenumber
Function IsTheCorrectFolder(folderName, fileNumber) As Boolean
Dim arr, num1, num2, rv As Boolean
rv = False 'default return value
arr = Split(folderName, "thru") 'split folder name on "thru"
If UBound(arr) = 1 Then 'should have two parts
'get the numbers from each part and compare against the file number
num1 = ExtractNumber(arr(0))
num2 = ExtractNumber(arr(1))
If Len(num1) > 0 And Len(num2) > 0 Then
fileNumber = CLng(fileNumber) 'convenrt to Long for comparison
rv = (fileNumber >= CLng(num1) And fileNumber <= CLng(num2))
End If
End If
IsTheCorrectFolder = rv
End Function
'Extract the first 5- or 6-digit number from a string
' Match is "greedy" so if there are six digits it will match 6 and
' not just the first 5...
Function ExtractNumber(txt)
Dim re As Object, allMatches, rv
Set re = CreateObject("VBScript.RegExp")
re.Pattern = "(\d{5,6})"
re.ignorecase = True
re.Global = True
Set allMatches = re.Execute(txt)
If allMatches.Count > 0 Then rv = allMatches(0) 'if there's a match then return the first one
ExtractNumber = rv
End Function
You need to change the lower limit in IF condition also. Like
If Test >= 10000 And Test <= 99999 Then
becomes
If Test >= 100000 And Test <= 999999 Then
Currently the loop could be exiting when it finds the first five digit number.
I am admin to my computer.
I am logged into network.
The below procedure runs and crashes
after line
'XXXXXXXXXXXXXXXXX:
stating the permission is denied, at objFile.Delete.
Why is permission denied?
I am able to delete files and folders from windows explorer.
Why can't the vba program delete it?
Any solutions?
Thanks
Sub RecursiveFolderDelete(MyPath As String)
Dim FileSys As FileSystemObject
Dim objFolder As Folder
Dim objSubFolder As Folder
Dim objFile As File
Set FileSys = CreateObject("Scripting.FileSystemObject")
Set objFolder = FileSys.GetFolder(MyPath)
For Each objFile In objFolder.Files
If Left(objFile.Name, 1) <> "~" And objFile.Name <> ThisWorkbook.Name Then
'XXXXXXXXXXXXXXXXX:
objFile.Delete
End If
Next objFile
Dim Count As Integer
Count = 0
For Each objSubFolder In objFolder.SubFolders
Count = Count + 1
RecursiveFolderDelete MyPath & "\" & objSubFolder.Name
Next objSubFolder
On Error GoTo endx:
If Count = 0 Then
RmDir MyPath
Else
If objFolder.SubFolders.Count = 0 Then
RmDir MyPath
End If
End If
endx:
On Error GoTo 0
Set FileSys = Nothing
Set objFolder = Nothing
Set objSubFolder = Nothing
Set objFile = Nothing
End Sub
Hi I am trying to open the latest file (date modified) in a folder. The code uses a loop to go through the files and find the latest modified which it does however when it comes to open the file using 'Workbooks.Open strFilename' it says the file (which it has already identified as the 'youngest' file could not be found. This doesn't make sense to me as the error message says the file 'test young' - the file name could not be found, but it clearly found it during the loop.
Sub copynewdata()
Dim FileSys As FileSystemObject
Dim objFile As File
Dim myFolder
Dim strFilename As String
Dim dteFile As Date
Dim Ref As Object, CheckRefEnabled%
CheckRefEnabled = 0
With ThisWorkbook
For Each Ref In .VBProject.References
If Ref.Name = "Scripting" Then
CheckRefEnabled = 1
Exit For
End If
Next Ref
If CheckRefEnabled = 0 Then
.VBProject.References.AddFromGUID "{420B2830-E718-11CF-893D-00A0C9054228}", 1, 0
End If
End With
'set path for files - change for your folder
Const myDir As String = "\\C:\Test"
'set up filesys objects
Set FileSys = New FileSystemObject
Set myFolder = FileSys.GetFolder(myDir)
'loop through each file and get date last modified. If largest date then store Filename
dteFile = DateSerial(1900, 1, 1)
For Each objFile In myFolder.Files
If objFile.DateLastModified > dteFile Then
dteFile = objFile.DateLastModified
strFilename = objFile.Name
End If
Next objFile
Workbooks.Open strFilename
'Set Source_Workbook = Workbooks(strFilename).Open(Target_Path)
Set FileSys = Nothing
Set myFolder = Nothing
End Sub
Can anyone help with this?
In strFilename, you have the name of the file - but without the path. Change the open-command to
Workbooks.Open myDir & "\" & strFilename
I have multiple accounts attached to Outlook 2010.
I want to move messages from a specific account, older than X days, to a .pst file for local storage.
I found scripts to move messages from the default inbox, but nothing on specifying an account.
I know you can specify an account when sending email using
Set OutMail.SendUsingAccount = Outlook.Application.Session.Accounts.Item(2)
but I can't find anything for looking into another account.
I've found the stores references for the folders (\Inbox and \Sent) and I know how to specify the days old. I have a script that works, but only in my primary account.
After some more searching and testing I came up with the following solution. This was actually from a 2009 post on stackoverflow here: Original VBA
It uses a public function to build the folder locations and a Subroutine to look for received dates older than 60 days and move those files to the specified locations.
The public function is:
Public Function GetFolder(strFolderPath As String) As MAPIFolder
Dim objNS As NameSpace
Dim colFolders As folders
Dim objFolder As MAPIFolder
Dim arrFolders() As String
Dim i As Long
On Error GoTo TrapError
strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders() = Split(strFolderPath, "\")
Set objNS = GetNamespace("MAPI")
On Error Resume Next
Set objFolder = objNS.folders.Item(arrFolders(0))
If Not objFolder Is Nothing Then
For i = 1 To UBound(arrFolders)
Set colFolders = objFolder.folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(i))
If objFolder Is Nothing Then
Exit For
End If
Next
End If
On Error GoTo TrapError
Set GetFolder = objFolder
Set colFolders = Nothing
Set objNS = Nothing
Exit_Proc:
Exit Function
TrapError:
MsgBox Err.Number & " " & Err.Description
End Function
The subroutine that does the actual work is below.
I added the Pass as Integer to allow the routine to work through two different source and destination folders. If I change the Sub name to Application_Startup it will run whenever outlook is started.
PST Folder Name\Archive-Inbox - PST folder name in Outlook with sub-folder
Email Account Name\Inbox - Account name in Outlook with sub-folder
Sub MoveOldEmail()
Dim oItem As MailItem
Dim objMoveFolder As MAPIFolder
Dim objInboxFolder As MAPIFolder
Dim i As Integer
Dim Pass As Integer
For Pass = 1 To 2
If Pass = 1 Then
Set objMoveFolder = GetFolder("PST Folder Name\Archive-Inbox")
Set objInboxFolder = GetFolder("Email Account Name\Inbox")
ElseIf Pass = 2 Then
Set objMoveFolder = GetFolder("PST Folder Name\Archive-Sent Items")
Set objInboxFolder = GetFolder("Email Account Name\Sent Items")
End If
For i = objInboxFolder.Items.Count - 1 To 0 Step -1
With objInboxFolder.Items(i)
''Error 438 is returned when .receivedtime is not supported
On Error Resume Next
If .ReceivedTime < DateAdd("d", -60, Now) Then
If Err.Number = 0 Then
.Move objMoveFolder
Else
Err.Clear
End If
End If
End With
Next
Next Pass
Set objMoveFolder = Nothing
Set objInboxFolder = Nothing
End Sub
Hope this helps someone else.
I am trying to write a vbs to copy the latest modified files to another location. The script goes like this
Option Explicit
Dim oFSO, oFolder, oFile
Dim vSourcePaths ,vDestinationPaths
vSourcePaths = "C:\xampp\htdocs\lgmsuploads"
vDestinationPaths = "S:\LGMSUPLOADS"
Set oFSO = CreateObject("Scripting.FileSystemObject")
oFolder = oFSO.GetFolder(vSourcePaths)
For Each oFile In oFolder.Files
If oFile.DateLastModified < DateAdd("h", -24, Now) Then
oFSO.CopyFile vSourcePaths & "\" & oFile.Name, vDestinationPaths & "\" & oFile.Name
End If
Next
But this gives the following error
Please help...
You should use Set statement to assign an object reference to a variable as follows:
Set oFolder = oFSO.GetFolder(vSourcePaths)
However, your script will copy files with oFile.DateLastModified 24 hours ago and before.