Option Explicit
Sub ChedkForNewFile()
'Assumes the filenames all end with versioning info something like": "_v1.77.txt"
'Assumes there is a "File History" worksheet with
' Column A that contains the basic filename (name without versioning info)
' Column B that contains the versioning info
Dim sFolder As String
Dim sFileNameWithoutVersion As String
Dim sFileNameExt As String
Dim lUSPos As Long
Dim lDotPos As Long
Dim sFileVersionInfo As String
Dim sSavedVersionInfo As String
Dim lFileCount As Long
Dim sFileNameWithoutVersioningInfo As String
Dim sFoundFile As String
Dim oFound As Object
Dim lLastHistoryRow As Long
Dim lUpdateRow As Long
Dim wksHist As Worksheet
'Update next line with name of your File History worksheet
Const sFileHistoryWorksheet As String = "File History"
'Update next line with path to file
sFolder = Environ("userprofile") & "\Documents\"
'Make sure it ends with a \
If Right(sFolder, 1) <> "\" Then sFolder = sFolder & "\"
'Update next line with the basic file name (e.g., "SomeFile" if the actual name was "SomeFile_v1.77.txt"
sFileNameWithoutVersioningInfo = "SomeFile"
Set wksHist = Worksheets(sFileHistoryWorksheet)
'Search the folder for the basic name
sFileNameExt = UCase(Dir(sFolder & sFileNameWithoutVersioningInfo & "*.txt"))
Do While sFileNameExt <> vbNullString
sFoundFile = sFileNameExt
lFileCount = lFileCount + 1
sFileNameExt = Dir
Loop
'More than one?
If lFileCount > 1 Then
MsgBox lFileCount & " files with a name like " & sFileNameWithoutVersioningInfo & _
" were found in " & sFolder & vbLf & vbLf & _
"Remove the older files and run code again.", , "Multiple Files Found"
GoTo End_Sub
End If
If sFoundFile <> vbNullString Then
'File Found, get version info
lUSPos = InStrRev(sFoundFile, "_")
lDotPos = InStrRev(sFoundFile, ".")
sFileVersionInfo = Mid(sFoundFile, lUSPos, lDotPos - lUSPos)
Else
MsgBox "A file like " & sFoundFile & " was not found in " & sFolder, , "File Not Found"
GoTo End_Sub
End If
With wksHist
.AutoFilterMode = False
lLastHistoryRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
'Is there an entry in File History
Set oFound = wksHist.Columns("A:A").Find( _
What:=sFileNameWithoutVersioningInfo, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not oFound Is Nothing Then
'match found
lUpdateRow = oFound.Row
sSavedVersionInfo = oFound.Offset(0, 1).Value
If sSavedVersionInfo <> sFileVersionInfo Then
'Versions differ, Enable label
MsgBox "New version for file found" & vbLf & vbLf & _
" " & sFileNameWithoutVersioningInfo & vbLf & vbLf & _
" Previous:" & vbTab & sSavedVersionInfo & vbLf & _
" Current:" & vbTab & sFileVersionInfo
'label7.enable
End If
wksHist.Cells(lUpdateRow, 2).Value = sFileVersionInfo
Else
'Not Found, add to history
lUpdateRow = lLastHistoryRow + 1
wksHist.Cells(lUpdateRow, 1).Value = sFileNameWithoutVersioningInfo
wksHist.Cells(lUpdateRow, 2).Value = sFileVersionInfo
End If
End_Sub:
End Sub
Function GetModDate(sFilePathName As String) As Date
'This function will return the date/time of the last file modification
'Late binding requires no reference to MS Script Runtime !!
Dim fso As Object, f As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFile(sFilePathName)
GetModDate = f.DateLastModified
Set f = Nothing
Set fso = Nothing
End Function
