Option Explicit
'Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
' 'Uncomment this sub and place in the ThisWorkbook codepage of your file
' SaveDTS
'End Sub
'Remaining code goes in a standard module
Sub SaveDTS()
'This code will be called from the Workbook_BeforeSave Event
Dim sUpdatingUser As String
sUpdatingUser = "philip.bornemeier" 'Change the name in quotes to your user name so that only you saving the file will update the DTS
If Environ("USERNAME") = sUpdatingUser Then
Select Case MsgBox("Do you want to update the file DTS?", vbYesNo + vbDefaultButton1, "Update DTS")
Case vbYes
Worksheets("Sheet1").Range("A1").Value = Now() 'Change this sheet.range as desired. Must match CheckFileDTS sheet.range
'The saved time will be very close to the File Date-Time Stamp
Case Else
End Select
End If
End Sub
Sub CheckFileDTS()
'Check status of DTS of the masterfile
'Call this sub from the On Open worksheet event and/or with a "Check for Updates" button
Const sMasterFilePathNameExt As String = "[COLOR=#333333][I]\\server\path\filename.ext[/I][/COLOR]"
Dim dteThisFileDTS As Date
Dim dteMasterFileDTS As Date
Dim aryIsWorkbookOpen As Variant
aryIsWorkbookOpen = IsWorkbookOpen(sMasterFilePathNameExt)
If aryIsWorkbookOpen(0) = False Then
'Master Workbook is not open
dteMasterFileDTS = GetDate(sMasterFilePathNameExt) 'get network DTS for masterfile
dteThisFileDTS = Worksheets("Sheet1").Range("A1").Value 'Must point to same sheet.range as in Sub SaveDTS
If dteMasterFileDTS - dteThisFileDTS > 3.47222222222222E-03 Then
'This file DTS is more than 5 minutes older that the MasterFile DTS
'1 hour = 1/24 = 4.16666666666667E-02 ; 5 minutes = 1/12 hour = 4.16666666666667E-02 / 12 = 3.47222222222222E-03
MsgBox "The master file has been updated. " & vbLf & vbLf & _
"THIS WORKBOOK WILL CLOSE once this popup is acknowleged." & vbLf & vbLf & _
"Download the updated master file before continuing.", vbCritical, "Download Updated Version"
ThisWorkbook.Close 'can be bypassed by Ctrl-Break at msgbox
End If
Else
'Workbook is open
MsgBox "The masterworkbook is opened by " & aryIsWorkbookOpen(1) & ". Check later for updates."
End If
End Sub
Function GetDate(sFilePathName As String) As Date
'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)
GetDate = f.DateLastModified
Set f = Nothing
Set FSO = Nothing
End Function
Function IsWorkbookOpen(sFilePathName As String) As Variant
'IsWorkbookOpen is returned as {x,y}
'X is True if file is open or False if it is closed
'If it is a workbook and open, Y will be the username
'If it is not a workbook and open, Y will be "Not Workbook"
'If file does not exist X will be False, Y will be "Does Not Exist"
'KEYWORDS: Is File Open, Is Workbook Open
Dim FSO As Object, bFE As Boolean
Dim wbk As Workbook
Dim sExt As String
Dim iFilenum As Integer, lErrnum As Long
Dim sFileNameExt As String
Dim secAutomation As MsoAutomationSecurity
secAutomation = Application.AutomationSecurity 'Save ThisWorkbook security setting
Application.AutomationSecurity = msoAutomationSecurityForceDisable 'Disable macros when opening file
Set FSO = CreateObject("Scripting.FileSystemObject")
bFE = FSO.FileExists(sFilePathName)
sExt = FSO.GetExtensionName(sFilePathName)
sFileNameExt = FSO.GetFilename(sFilePathName)
If bFE Then
'File Exists
'Is it a workbook
If InStr(".xls..xlsm..xlsx..xlsb..xla..xlam..", sExt) = 0 Then
'Not a workbook
On Error Resume Next ' Turn error checking off.
iFilenum = FreeFile() ' Get a free file number.
' Attempt to open the file and lock it.
Open sFilePathName For Input Lock Read As #iFilenum
Close iFilenum ' Close the file.
lErrnum = Err ' Save the error number that occurred.
On Error GoTo 0 ' Turn error checking back on.
' Check to see which error occurred.
Select Case lErrnum
Case 0 ' File is NOT already open
IsWorkbookOpen = Array(False, "Not Workbook")
Case 70 'Permission Denied.
IsWorkbookOpen = Array(True, "Not Workbook")
Case Else 'Other error
'Something else, Display Error
Error lErrnum
End Select
GoTo End_Function
End If
'Is it a workbook opened in this instance of Excel?
ThisWorkbook.Activate 'if another instance of Excel is active this check may fail
For Each wbk In Application.Workbooks
If wbk.Name = sFileNameExt Then
IsWorkbookOpen = Array(True, Application.UserName) 'Workbook Open being used by ....
GoTo End_Function
End If
Next
'Check to see if workbook is already open in another instance of Excel...by trying to open it
Set wbk = Workbooks.Open(sFilePathName)
If wbk.ReadOnly Then
IsWorkbookOpen = Array(True, wbk.WriteReservedBy) 'Workbook Open being used by ....
Workbooks(sFileNameExt).Close savechanges:=False 'Close the read only copy we just opened
'MsgBox wbk.WriteReservedBy & " currently using " & wbk.Name
GoTo End_Function
Else
'Workbook was not open
IsWorkbookOpen = Array(False, True) 'Not Open, is a workbook
'Was opened by this procedure -- now close it
Workbooks(sFileNameExt).Close savechanges:=False
End If
Else
IsWorkbookOpen = Array(False, "Does Not Exist") 'File does not exist it cannot be open
End If
End_Function:
Set FSO = Nothing
Application.AutomationSecurity = secAutomation 'Restore ThisWorkbook security setting
End Function
