Link to home
Start Free TrialLog in
Avatar of FamousMortimer
FamousMortimerFlag for United States of America

asked on

VBS Compare Folder to Itself last time script was run

Hi Experts,

I am looking to create a script that will take a source folder and recursively compare the current contents of that folder to the contents last time this script ran.  It can store the folder/file contents in a text file, then compare the contents, then rewrite the text file with the new contents.

I need the output to be a list of all the recently added or modified files in a format like so:

C:\test\doc1.txt
C:\test\temp\doc5.txt

Any help is greatly appreciated.  Let me know if you have any question or need me to clarify
Avatar of FamousMortimer
FamousMortimer
Flag of United States of America image

ASKER

I found this script that might be of some help.  I am unclear on how to store the directory contents into a text file and retrieve them later to compare against the current directory contents.

Dim objFSO, objNetwork

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objNetwork = wscript.CreateObject("wscript.network")

SOURCE_FOLDER = "C:\temp\"
DESTINATION_FOLDER = "C:\temp2\"

ReplicateFolders objFSO, SOURCE_FOLDER, DESTINATION_FOLDER

Set objFSO = Nothing
Set objNetwork = Nothing


Sub ReplicateFolders (objFSO, strSourceFolderPath, strDestinationFolderPath)
	Dim aFolderArraySource, aFolderArrayDestination, FolderListSource 
	Dim FolderListDestination, oFolderSource, oFolderDestination
	Dim bSourceExists, bDestinationExists

	On Error Resume Next

	Set aFolderArraySource = objFSO.GetFolder(strSourcefolderpath)
	Set aFolderArrayDestination = objFSO.GetFolder(strDestinationfolderpath)
	Set FolderListSource = aFolderArraySource.SubFolders
	Set FolderListDestination = aFolderArrayDestination.SubFolders
	
	ReplicateFiles objFSO, strSourcefolderpath, strDestinationfolderpath

	For Each oFolderDestination in FolderListDestination
		bSourceExists = 0
		For each oFolderSource in FolderListSource
			If oFolderDestination.Name = oFolderSource.Name then
				bSourceExists = 1
				Exit For
			End If
		Next
		
		If bSourceExists = 0 then
			objFSO.DeleteFolder strDestinationfolderpath & "\" & _
			oFolderDestination.Name, true
		End if
	Next

End Sub


Sub ReplicateFiles (objFSO, strSourcefolderpath, strDestinationfolderpath)

	Dim aFileArraySource, aFileArrayDestination, FileListSource
	Dim FileListDestination, oFileSource, oFileDestination
	Dim bSourceExists, bDestinationExists

	On Error Resume Next

	Set aFileArraySource = objFSO.GetFolder(strSourcefolderpath)
	Set aFileArrayDestination = objFSO.GetFolder(strDestinationfolderpath)
	Set FileListSource = aFileArraySource.files
	Set FileListDestination = aFileArrayDestination.files

	For each oFileDestination in FileListDestination
		bSourceExists = 0
		For each oFileSource in FileListSource
			If oFileDestination.Name = oFileSource.Name then
				If oFileDestination.DateLastModified = oFileSource.DateLastModified then
					bSourceExists = 1
					Exit For
				End If
			End If
		Next

		If bSourceExists = 0 then
			MsgBox strDestinationfolderpath & "\" & oFileDestination.Name
			objFSO.DeleteFile strDestinationfolderpath & "\" & _
			oFileDestination.Name,true
		End If
	Next

End Sub

Open in new window

Avatar of RobSampson
Hi, check out this script.  I think it will suit better.

https://www.experts-exchange.com/questions/26609153/Help-needed-with-VBScript-edit.html

The only thing it's not recursive so it won't do subfolders just yet, but I can modify for you if you would like me to.

Regards,

Rob.
Thanks for the reply, I am going to check it out now.  I'll let you know.
First off, I gotta say this is a sweet script!  Whether I needed this or not atm, this is one to add to the archives.
I do need it to recurse through the sub folder though.  If you can help me with that, I would be eternally grateful :)

Also, I changed lines 33, 63 to refer to the full file path... (i.e. replaced objFile.Name with objFile.Path)

Thanks,

Jeremy
OK, I'll get on it at some stage tonight.

Rob.
ASKER CERTIFIED SOLUTION
Avatar of RobSampson
RobSampson
Flag of Australia image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
EXCELLENT!

I modified it a bit to suit my application in case anyone needs the same as I.

Basically I gave the option to choose what to monitor (Created, Deleted, etc.).  Instead of creating a report, it will send an HTML email to recipients with the changes and will use a UNC path instead of a local path if it is on a remote server.  In the case of an error i will send an email to yourself with the error details.

Keep in mind that on Windows 7/2008 you will have to enable Last Access date

Option Explicit

Dim strFolder
Dim strList
Dim strName
Dim strHTMLName
Dim strLocalDir
Dim strUNCPath

Dim strEmailTo
Dim strEmailFrom
Dim strEmailSubj
Dim strEmailBody
Dim strSMTPServer

Dim objList
Dim objOldFiles
Dim objFSO
Dim objFile
Dim objFolder
Dim objSubFolder

Dim dtmCreated
Dim dtmModified
Dim dtmAccessed
Dim dtmPrevCreated
Dim dtmPrevModified
Dim dtmPrevAccessed

Dim bMonitorCreated
Dim bMonitorOverwritten
Dim bMonitorModified
Dim bMonitorAccessed
Dim bMonitorDeleted
Dim bHeaderAdded

Dim arrLine
Dim MailErr

On Error Resume Next

Const ForReading = 1
Const ForWriting = 2
Const ForAppending = 8

'----------------------------------------------------------
'-------------------EDIT VARIABLES HERE--------------------
'----------------------------------------------------------
bMonitorCreated = True                                    '||
bMonitorOverwritten = True                                '||
bMonitorModified = True                                    '||
bMonitorAccessed = False                                '||
bMonitorDeleted = True                                    '||
                                                        '||
strEmailSubj = "New FTP Files"                            '||
strEmailTo = "me@company.com"                            '||
strEmailFrom = "FTPServer@cclind.com"                    '||
strSMTPServer = "ip.add.re.ss"                            '||
strUNCPath = "\\UNC\Path\To\Files"                        '||
strFolder = "C:\test\"                                    '||
strList = "all_files.txt"                                '||
'----------------------------------------------------------
'----------------------------------------------------------

If Right(strFolder, 1) <> "\" Then strFolder = strFolder & "\"
If Right(strUNCPath, 1) <> "\" Then strUNCPath = strUNCPath & "\"

Set objOldFiles = CreateObject("Scripting.Dictionary")
objOldFiles.CompareMode = VbTextCompare

Set objFSO = CreateObject("Scripting.FileSystemObject")

If objFSO.FileExists(strList) Then
    Set objList = objFSO.OpenTextFile(strList, ForReading)

    Do Until objList.AtEndOfStream
        arrLine = Split(objList.ReadLine, vbTab)
        objOldFiles.Add LCase(arrLine(0)), arrLine(1)
    Loop

    objList.Close
End If

Set objList = objFSO.CreateTextFile(strList, True)
Set objFolder = objFSO.GetFolder(strFolder)

RecurseFolder strFolder

'check for deleted files
For Each strName In objOldFiles
    If bMonitorDeleted And objFSO.FileExists(strName) = False Then _
        strEmailBody = strEmailBody & "<dd><b>Deleted:</b> <a href=" & Chr(34) &  strHTMLName & Chr(34) & _
                        ">" & Replace(strHTMLName, "File:///", "") & "</a>  on  " & dtmCreated & "</dd><br>"
Next

If strEmailBody <> vbNullString Then
    strEmailBody = "The following change(s) have been made:" & strEmailBody
    MailErr = SendEmail(strEmailTo, strEmailFrom, strEmailSubj, strEmailBody, strSMTPServer)
End If

objList.Close

If Err.Number <> 0 or MailErr <> 0 Then
    SendEmail "me@company.com; you@company.com", _
              "FTPScriptError@cclind.com", _
              "FTP Monitor Scripting Error", _
              "<b>Error Num.: </b>" & Err.Number & "<br>" & _
                "<b>Error Desc.: </b>" & Err.Description & "<br>" & _
                "<b>Error Src.: </b>" & Err.Source, _
              strSMTPServer
    Err.Clear
End If

Set objList = Nothing
Set objOldFiles = Nothing
Set objFSO = Nothing
Set objFile = Nothing
Set objFolder = Nothing
Set objSubFolder = Nothing


Sub RecurseFolder(strFolderPath)
    For Each objFile In objFSO.GetFolder(strFolderPath).Files
        strName = objFile.Path
        strHTMLName = "File:///" & Replace(strName, strFolder, strUNCPath, 1, -1, 1)
        dtmCreated = objFile.DateCreated
        dtmModified = objFile.DateLastModified
        dtmAccessed = objFile.DateLastAccessed
        objList.WriteLine strName & vbTab & dtmCreated & ";" & dtmModified & ";" & dtmAccessed

        'check for new files
        If bMonitorCreated And objOldFiles.Exists(LCase(strName)) = False Then
            If bHeaderAdded = False Then
                Call AddSubFolderHeader(objSubFolder.Name)
                bHeaderAdded = True
            End If
            strEmailBody = strEmailBody & "<dd><b>Created:</b> <a href=" & Chr(34) &  strHTMLName & Chr(34) & _
                            ">" & Replace(strHTMLName, "File:///", "") & "</a>  on  " & dtmCreated & "</dd><br>"
        Else
            dtmPrevCreated = Split(objOldFiles(LCase(strName)), ";")(0)
            dtmPrevModified = Split(objOldFiles(LCase(strName)), ";")(1)
            dtmPrevAccessed = Split(objOldFiles(LCase(strName)), ";")(2)
            'check for changes to files
            If bMonitorOverwritten And CDate(dtmCreated) > CDate(dtmPrevCreated) Then
                If bHeaderAdded = False Then
                    Call AddSubFolderHeader(objSubFolder.Name)
                    bHeaderAdded = True
                End If
                StrEmailBody = strEmailBody & "<dd><b>Overwritten:</b> <a href=" & Chr(34) &  strHTMLName & Chr(34) & _
                            ">" & Replace(strHTMLName, "File:///", "") & "</a>  on  " & dtmCreated & "</dd><br>"
            ElseIf bMonitorModified And CDate(dtmModified) > CDate(dtmPrevModified) Then
                If bHeaderAdded = False Then
                    Call AddSubFolderHeader(objSubFolder.Name)
                    bHeaderAdded = True
                End If
                StrEmailBody = strEmailBody & "<dd><b>Modified:</b> <a href=" & Chr(34) &  strHTMLName & Chr(34) & _
                            ">" & Replace(strHTMLName, "File:///", "") & "</a>  on  " & dtmCreated & "</dd><br>"
            ElseIf bMonitorAccessed And CDate(dtmAccessed) > CDate(dtmPrevAccessed) Then
                If bHeaderAdded = False Then
                    Call AddSubFolderHeader(objSubFolder.Name)
                    bHeaderAdded = True
                End If
                StrEmailBody = strEmailBody & "<dd><b>Accessed:</b> <a href=" & Chr(34) &  strHTMLName & Chr(34) & _
                            ">" & Replace(strHTMLName, "File:///", "") & "</a>  on  " & dtmCreated & "</dd><br>"
            End If
        End If
    Next
    
    For Each objSubFolder In objFSO.GetFolder(strFolderPath).SubFolders
        bHeaderAdded = False
        RecurseFolder objSubFolder.Path
    Next
End Sub


Sub AddSubFolderHeader(strSubFolderName)
    strEmailBody = strEmailBody & "<br><br><b>-----" & strSubFolderName & "-----</b><br>"
End Sub


Function SendEmail(sTo, sFrom, sSubj, sBody, sSMTPServer)

    Dim objMessage

    Const cdoSendUsingPort = 2
    Const cdoAnonymous = 0

    Set objMessage = CreateObject("CDO.Message")

    With objMessage
        .From = sFrom
        .To = sTo
        .Subject = sSubj
        .HTMLBody = sBody

        .Configuration.Fields.Item _
        ("http://schemas.microsoft.com/cdo/configuration/sendusing") = cdoSendUsingPort
        .Configuration.Fields.Item _
        ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strSMTPServer
        .Configuration.Fields.Item _
        ("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = cdoAnonymous
        .Configuration.Fields.Item _
        ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
        .Configuration.Fields.Item _
        ("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = False
        .Configuration.Fields.Item _
        ("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
        .Configuration.Fields.Update
        .Send
    End With

    SendEmail = Err.Number

    Set objMessage = Nothing

End Function

Open in new window

This is why I love this site!
Wow, that's more than a slight modification.  Nice work.

Thanks for the grade.

Regards,

Rob.