Solved

VBA copy delete files based on creation date

Posted on 2015-02-19
11
188 Views
Last Modified: 2016-02-10
Hello,

I have the following vbscripts


1-Delete old files based on number days / old files

 
DossierSauvegarde = "C:\"
 
intFirstNumber = InputBox("Please enter the files preservertion number of days days /nombre de jours de conservation des fichiers:")
AgeMaximalFichiers = intFirstNumber
 
'Comptage des fichiers effaces
NbFichiersEffaces = 0
 
'Initialisation des objets
Set fso = CreateObject("Scripting.FileSystemObject" )
 
If (myName = Winrep = fso.FolderExists(DossierSauvegarde)) = False Then
    Erreur = MsgBox("Folder doesn't not exist !" )
    Wscript.Quit
End If
 
'On recupere la date système
DateSysteme = Date
 
'Suppression des fichiers trop anciens
 
Set Folder = fso.Getfolder(DossierSauvegarde)
For Each File In Folder.Files
        If (DateDiff("d", File.DateLastModified, DateSysteme) > CInt(AgeMaximalFichiers)) Then
            'On verifie qu'ils ne sont pas en lecture seule
            If File.Attributes And 1 Then File.Attributes = File.Attributes - 1
            File.Delete()
            NbFichiersEffaces = NbFichiersEffaces + 1
        End If
Next
 
MsgBox (Cstr(NbFichiersEffaces) + " files have been removed" )


2-Copy files based on old number of days / last date modified


option explicit

dim fileSystem, folder, file,AgeMaximalFichiers
dim path



path = "Y:\log\"
AgeMaximalFichiers = InputBox("Please enter the old number of days based on last date modified")
Set fileSystem = CreateObject("Scripting.FileSystemObject")
Set folder = fileSystem.GetFolder(path)




for each file in folder.Files    


           If (DateDiff("d", file.DateLastModified, Now) < CInt(AgeMaximalFichiers)) Then


  filesystem.CopyFile file, "C:\test\"

        'WScript.Echo file.Name & " last modified at " & file.DateLastModified

    end if
      
      
next

MsgBox "Process have been completed successfully"



I would like to merge all those vbscripts into a single VBA
0
Comment
Question by:LD16
  • 6
  • 5
11 Comments
 
LVL 20

Expert Comment

by:ltlbearand3
Comment Utility
Are you wanting the two scripts to use the same date selection?  Try something like this:

option explicit

dim fso, folder, file, AgeMaximalFichiers, DateSysteme
dim strLogPath, DossierSauvegarde, NbFichiersEffaces


strLogPath = "Y:\log\"
DossierSauvegarde = "C:\"

'Initialisation des objets
Set fso = CreateObject("Scripting.FileSystemObject")

AgeMaximalFichiers = InputBox("Please enter the files preservertion number of days days /nombre de jours de conservation des fichiers:")
 
'Comptage des fichiers effaces
NbFichiersEffaces = 0
 
 
If Not fso.FolderExists(DossierSauvegarde) Then
    MsgBox("Folder doesn't not exist !" )
    Wscript.Quit
End If
 
'On recupere la date système
DateSysteme = Date
 
'Suppression des fichiers trop anciens
 
Set Folder = fso.Getfolder(DossierSauvegarde)
For Each File In Folder.Files
        If (DateDiff("d", File.DateLastModified, DateSysteme) > CInt(AgeMaximalFichiers)) Then
            'On verifie qu'ils ne sont pas en lecture seule
            If File.Attributes And 1 Then File.Attributes = File.Attributes - 1
            File.Delete()
            NbFichiersEffaces = NbFichiersEffaces + 1
        End If
Next
 
MsgBox (Cstr(NbFichiersEffaces) + " files have been removed" ) 

Set folder = fso.GetFolder(strLogPath)

for each file in folder.Files    
	If (DateDiff("d", file.DateLastModified, Now) < CInt(AgeMaximalFichiers)) Then
		filesystem.CopyFile file, "C:\test\"
		'WScript.Echo file.Name & " last modified at " & file.DateLastModified
	end if
next

MsgBox "Process have been completed successfully"

Open in new window

0
 

Author Comment

by:LD16
Comment Utility
Hello, the date selection can be different. Aditionnally I would like to launch those scripts with Excel Vba and review the entire code to make it suitable with Excel VBA.
0
 
LVL 20

Expert Comment

by:ltlbearand3
Comment Utility
Give this a shot in VBA.  You will need to make sure you add a reference to the project for Microsoft Scripting Runtime.

Option Explicit

Public Sub FileManage()
    ' Required References
    '  MICROSOFT SCRIPTING RUNTIME
    
    Dim objFSO As Scripting.FileSystemObject
    Dim objFolder As Scripting.folder
    Dim objFile As Scripting.file
    Dim AgeMaximalFichiers As Integer
    Dim NbFichiersEffaces As Integer
    Dim strLogPath As String
    Dim DossierSauvegarde As String
    
    strLogPath = "Y:\log\"
    DossierSauvegarde = "C:\"

    'Initialisation des objets
    Set objFSO = New Scripting.FileSystemObject

    AgeMaximalFichiers = InputBox("Please enter the files preservertion number of days days /nombre de jours de conservation des fichiers:")
 
    'Comptage des fichiers effaces
    NbFichiersEffaces = 0
 
    If objFSO.FolderExists(DossierSauvegarde) Then
        Set objFolder = objFSO.GetFolder(DossierSauvegarde)
        For Each objFile In objFolder.Files
                If (DateDiff("d", objFile.DateLastModified, Date) > CInt(AgeMaximalFichiers)) Then
                    'On verifie qu'ils ne sont pas en lecture seule
                    If objFile.Attributes And 1 Then objFile.Attributes = objFile.Attributes - 1
                    objFile.Delete (True)
                    NbFichiersEffaces = NbFichiersEffaces + 1
                End If
        Next
         
        MsgBox (CStr(NbFichiersEffaces) + " files have been removed")
    Else
        MsgBox (DossierSauvegarde & " does not exist !")
    End If
 
    AgeMaximalFichiers = InputBox("Please enter the old number of days based on last date modified")
    
    'Suppression des fichiers trop anciens
    Set objFolder = objFSO.GetFolder(strLogPath)

    For Each objFile In objFolder.Files
        If (DateDiff("d", objFile.DateLastModified, Date) < CInt(AgeMaximalFichiers)) Then
            objFSO.CopyFile objFile.Name, "C:\test\"
            'WScript.Echo file.Name & " last modified at " & file.DateLastModified
        End If
    Next

    MsgBox "Process have been completed successfully"
                                          
End Sub

Open in new window

0
 

Author Comment

by:LD16
Comment Utility
Hello,

How can I add the Microsoft Scripting runtime, Do I need to download a library or just make the set up in Excel?
I have a Excel 2007 Version.

Thank  you.
0
 

Author Comment

by:LD16
Comment Utility
I found the following code which works in VBA:

Sub Copy_Files_Dates()
'This example copy all files between certain dates from FromPath to ToPath.
'You can also use this to copy the files from the last ? days
'If Fdate >= Date - 30 Then
'Note: If the files in ToPath already exist it will overwrite
'existing files in this folder
    Dim FSO As Object
    Dim FromPath As String
    Dim ToPath As String
    Dim Fdate As Date
    Dim FileInFromFolder As Object

    FromPath = "C:\Users\Ron\Data"  '<< Change
    ToPath = "C:\Users\Ron\Test"    '<< Change

    If Right(FromPath, 1) <> "\" Then
        FromPath = FromPath & "\"
    End If

    If Right(ToPath, 1) <> "\" Then
        ToPath = ToPath & "\"
    End If

    Set FSO = CreateObject("scripting.filesystemobject")

    If FSO.FolderExists(FromPath) = False Then
        MsgBox FromPath & " doesn't exist"
        Exit Sub
    End If

    If FSO.FolderExists(ToPath) = False Then
        MsgBox ToPath & " doesn't exist"
        Exit Sub
    End If

    For Each FileInFromFolder In FSO.getfolder(FromPath).Files
        Fdate = Int(FileInFromFolder.DateLastModified)
        'Copy files from 1-Oct-2006 to 1-Nov-2006
        If Fdate >= DateSerial(2006, 10, 1) And Fdate <= DateSerial(2006, 11, 1) Then
            FileInFromFolder.Copy ToPath
        End If
    Next FileInFromFolder

    MsgBox "You can find the files from " & FromPath & " in " & ToPath

End Sub
0
How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

 
LVL 20

Expert Comment

by:ltlbearand3
Comment Utility
That uses late binding, but in VBA it is better to add the reference.  To add a reference, in the VBA editor select tools >> references and then select Microsoft Scripting Runtime.

The second script will not prompt for the date, the first one does.  It just depends on what you want the script to actually accomplish.
0
 

Author Comment

by:LD16
Comment Utility
Hello Itibearnd,

I tried to prompt the date with the second script and is not working properly even if I don't have an error message. could please tell me wh

Here is what I use :

Sub Copy_Files_Dates()
'This example copy all files between certain dates from FromPath to ToPath.
'You can also use this to copy the files from the last ? days
'If Fdate >= Date - 30 Then
'Note: If the files in ToPath already exist it will overwrite
'existing files in this folder
    Dim FSO As Object
    Dim FromPath, olddate  As String
    Dim ToPath As String
    Dim Fdate As Date
    Dim FileInFromFolder As Object



    FromPath = "C:\Users\Ron\Data"  '<< Change
    ToPath = "C:\Users\Ron\Test"    '<< Change
   olddate = InputBox("Enter the number of days",,1)


    If Right(FromPath, 1) <> "\" Then
        FromPath = FromPath & "\"
    End If

    If Right(ToPath, 1) <> "\" Then
        ToPath = ToPath & "\"
    End If

    Set FSO = CreateObject("scripting.filesystemobject")

    If FSO.FolderExists(FromPath) = False Then
        MsgBox FromPath & " doesn't exist"
        Exit Sub
    End If

    If FSO.FolderExists(ToPath) = False Then
        MsgBox ToPath & " doesn't exist"
        Exit Sub
    End If

    For Each FileInFromFolder In FSO.getfolder(FromPath).Files
        Fdate = Int(FileInFromFolder.DateLastModified)
        'Copy files from 1-Oct-2006 to 1-Nov-2006
      If Fdate >= Date & " -  "  & olddate  Then
            FileInFromFolder.Copy ToPath
        End If
    Next FileInFromFolder

    MsgBox "You can find the files from " & FromPath & " in " & ToPath

End Sub
0
 
LVL 20

Expert Comment

by:ltlbearand3
Comment Utility
LD16,

When you post code, please use the "Code" button on the Comment toolbar.  It makes code much easier to read.  Also, could you please tell me what you want.  I answered the original question to combine the scripts, but that does not seem to be what you want.  I can help you out much better if you tell me what you want.

Now in your last posted script, you try to get the new date buy subtracting dates.  That will not work.  You need to use the DateDiff function like this:
    For Each FileInFromFolder In FSO.getfolder(FromPath).Files
        Fdate = Int(FileInFromFolder.DateLastModified)
        'Copy files from 1-Oct-2006 to 1-Nov-2006
      If (DateDiff("d", FileInFromFolder.DateLastModified, Date) > CInt(olddate)) Then
            FileInFromFolder.Copy ToPath
        End If
    Next FileInFromFolder

Open in new window



However, note that making that change will not result in the same thing as the combination of your two original scripts.
0
 

Author Comment

by:LD16
Comment Utility
@Itiberands,

My mystakes, I haven't specify properly what I want.
This is the revised specs.

1-Delete the various files from the last ? days, I suppose that your following loop can perform this requirement:

 For Each FileInFromFolder In FSO.getfolder(FromPath).Files
        Fdate = Int(FileInFromFolder.DateLastModified)
        'Copy files from 1-Oct-2006 to 1-Nov-2006
      If (DateDiff("d", FileInFromFolder.DateLastModified, Date) > CInt(olddate)) Then
            FileInFromFolder.Delete
        End If
    Next FileInFromFolder

Open in new window


2-Copy files from the last ? days:

 
  For Each FileInFromFolder In FSO.getfolder(FromPath).Files
        Fdate = Int(FileInFromFolder.DateLastModified)
        'Copy files from 1-Oct-2006 to 1-Nov-2006
      If (DateDiff("d", FileInFromFolder.DateLastModified, Date) > CInt(olddate2)) Then
            FileInFromFolder.Copy ToPath
        End If
    Next FileInFromFolder

Open in new window


This script will need two inputbox, the one for olddate and the other for olddate2.

Is it clearer for you?
0
 
LVL 20

Accepted Solution

by:
ltlbearand3 earned 500 total points
Comment Utility
Yes.  That helps out.  I think the VBA version I posted earlier for you would have gotten you very close.  However, I went through and redid the code some to make it more clear.  The first example uses the reference and is the recommended method:

Option Explicit

Public Sub FileManage()
    ' Required References (From VBA Editor Select Tools >  References
    '  MICROSOFT SCRIPTING RUNTIME
    
    Dim objFSO As Scripting.FileSystemObject
    Dim objFolder As Scripting.folder
    Dim objFile As Scripting.file
    Dim intNumOfDays As Integer
    
    ' ************************************
    ' Set the Correct File Paths Here
    ' ************************************
    Const FILEDELETEPATH As String = "W:\EE Test\1\"
    Const FILECOPYFROMPATH As String = "W:\EE Test\3\"
    Const FILECOPYTOPATH As String = "W:\EE Test\1\"

    ' Instantiate File System Object
    Set objFSO = New Scripting.FileSystemObject
    
    intNumOfDays = InputBox("Enter the Number of Days for Keeping Files" & vbCrLf & "Anything older than this will be Deleted")

    If objFSO.FolderExists(FILEDELETEPATH) Then
        Set objFolder = objFSO.GetFolder(FILEDELETEPATH)
        For Each objFile In objFolder.Files
            If (DateDiff("d", objFile.DateLastModified, Date) > CInt(intNumOfDays)) Then
                objFile.Delete (True)
            End If
        Next
        MsgBox ("Files from " & FILEDELETEPATH & " have been removed")
    Else
        MsgBox (FILEDELETEPATH & " does not exist !")
    End If
 
    intNumOfDays = InputBox("Enter the Number of Days for Moving Files" & vbCrLf & "Anything with this range this will be copied to " & FILECOPYTOPATH)
    
    Set objFolder = objFSO.GetFolder(FILECOPYFROMPATH)

    If objFSO.FolderExists(FILECOPYFROMPATH) And objFSO.FolderExists(FILECOPYTOPATH) Then
        For Each objFile In objFolder.Files
            If (DateDiff("d", objFile.DateLastModified, Date) <= CInt(intNumOfDays)) Then
                objFile.Copy FILECOPYTOPATH, True
            End If
        Next
        MsgBox (" Files modified with then last " & intNumOfDays & " have been copied from " & vbCrLf & FILECOPYFROMPATH & " to " & FILECOPYTOPATH)
    Else
        MsgBox "Missing File Path.  Either " & FILECOPYTOPATH & " or " & FILECOPYFROMPATH & " is missing"
    End If

    MsgBox "Process have been completed successfully"
                                          
End Sub
                                          
Option Explicit

Open in new window


This second one uses late binding and does not require the reference:
Public Sub FileManageLateBine()
    ' Required References (From VBA Editor Select Tools >  References
    '  MICROSOFT SCRIPTING RUNTIME
    
    Dim objFSO As Object
    Dim objFolder As Object
    Dim objFile As Object
    Dim intNumOfDays As Integer
    
    ' ************************************
    ' Set the Correct File Paths Here
    ' ************************************
    Const FILEDELETEPATH As String = "W:\EE Test\1\"
    Const FILECOPYFROMPATH As String = "W:\EE Test\3\"
    Const FILECOPYTOPATH As String = "W:\EE Test\1\"

    ' Instantiate File System Object
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    
    intNumOfDays = InputBox("Enter the Number of Days for Keeping Files" & vbCrLf & "Anything older than this will be Deleted")

    If objFSO.FolderExists(FILEDELETEPATH) Then
        Set objFolder = objFSO.GetFolder(FILEDELETEPATH)
        For Each objFile In objFolder.Files
            If (DateDiff("d", objFile.DateLastModified, Date) > CInt(intNumOfDays)) Then
                objFile.Delete (True)
            End If
        Next
        MsgBox ("Files from " & FILEDELETEPATH & " have been removed")
    Else
        MsgBox (FILEDELETEPATH & " does not exist !")
    End If
 
    intNumOfDays = InputBox("Enter the Number of Days for Moving Files" & vbCrLf & "Anything with this range this will be copied to " & FILECOPYTOPATH)
    
    Set objFolder = objFSO.GetFolder(FILECOPYFROMPATH)

    If objFSO.FolderExists(FILECOPYFROMPATH) And objFSO.FolderExists(FILECOPYTOPATH) Then
        For Each objFile In objFolder.Files
            If (DateDiff("d", objFile.DateLastModified, Date) <= CInt(intNumOfDays)) Then
                objFile.Copy FILECOPYTOPATH, True
            End If
        Next
        MsgBox (" Files modified with then last " & intNumOfDays & " have been copied from " & vbCrLf & FILECOPYFROMPATH & " to " & FILECOPYTOPATH)
    Else
        MsgBox "Missing File Path.  Either " & FILECOPYTOPATH & " or " & FILECOPYFROMPATH & " is missing"
    End If

    MsgBox "Process have been completed successfully"
                                          
End Sub

Open in new window

0
 

Author Comment

by:LD16
Comment Utility
Great! I have tested and both solutions work perfectly
0

Featured Post

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

You can of course define an array to hold data that is of a particular type like an array of Strings to hold customer names or an array of Doubles to hold customer sales, but what do you do if you want to coordinate that data? This article describes…
Describes a method of obtaining an object variable to an already running instance of Microsoft Access so that it can be controlled via automation.
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

743 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

8 Experts available now in Live!

Get 1:1 Help Now