Option Explicit
Private Declare Function WNetGetUser Lib "mpr.dll" Alias "WNetGetUserA" (ByVal lpName As String, ByVal lpUserName As String, lpnLength As Long) As Long
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Const ERROR_MORE_DATA = 234
Const ERROR_INSUFFICIENT_BUFFER = 122
Public CurrentSheet As Worksheet, LogSheet As Worksheet
Private oldContents As Variant, autosave As Boolean
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If Not autosave Then
If LogSheet Is Nothing Then Exit Sub
Dim r As Long
r = LogSheet.Cells.SpecialCells(xlCellTypeLastCell).Row + 1
LogSheet.Cells(r, 1).Value = Now
LogSheet.Cells(r, 2).Value = "Saved"
LogSheet.Cells.Columns.AutoFit
End If
End Sub
Private Sub Workbook_Open()
'First, let's get the username -- network username if possible,
'local username otherwise:
Dim username As String, namelen As Long
namelen = 2
Do
username = String$(namelen, vbNull)
Select Case WNetGetUser("", username, namelen)
Case 0 'success
username = Left$(username, namelen - 1)
Exit Do
Case ERROR_MORE_DATA 'username needs to be longer
'Nothing to do: dll error sets namelen to length needed,
'and username gets reset on next interation.
Case Else 'other error; assume unable to retreive network name
Do
username = String$(namelen, vbNull)
Select Case GetUserName(username, namelen)
Case 0 'failure
If Err.LastDllError = ERROR_INSUFFICIENT_BUFFER Then
'username needs to be longer, as with
'case ERROR_MORE_DATA above
Else 'other (unknown) error
username = "[error retreiving username]"
Exit Do
End If
Case Else 'success
username = Left$(username, namelen - 1)
Exit Do
End Select
Loop
Exit Do
End Select
Loop
'Time to create the new log sheet:
'/ If a log sheet exists then leave Exit Sub as is
'/ Else remove to creat a log sheet then Exit Sub
'/***********************************************
' Exit Sub
'/***********************************************
Dim wkBack As Worksheet
Set wkBack = ActiveCell.Parent
Worksheets.Add After:=Worksheets(Worksheets.Count)
Set LogSheet = Worksheets(Worksheets.Count)
LogSheet.Visible = xlSheetHidden
LogSheet.Name = "Log (" & Replace$(Date$, "/", "-") & " " & Replace$(Time$, ":", ".") & ")"
LogSheet.Cells(1, 1).EntireRow.Font.Bold = True
LogSheet.Cells(1, 1).Value = "Time"
LogSheet.Cells(1, 2).Value = "Item"
LogSheet.Cells(2, 1).Value = Now
LogSheet.Cells(2, 2).Value = "File opened by " & username
LogSheet.Cells.Columns.AutoFit
wkBack.Activate
Set wkBack = Nothing
oldContents = Selection.Value
autosave = True
'Delete the next line if you don't want the "autosave on open" thing to happen.
ActiveWorkbook.Save
autosave = False
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If LogSheet Is Nothing Then Exit Sub
If LogSheet Is Sh Then Exit Sub
Set CurrentSheet = Sh
'Not sure the correct way to do this; below works okay enough...
oldContents = ActiveCell.Value
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If LogSheet Is Nothing Then Exit Sub
'***DO NOT REMOVE THE NEXT LINE OR EXCEL WILL HATE YOU.***
If LogSheet Is Sh Then Exit Sub
Dim r As Long, tmp1 As String, L0 As Long, L1 As Long, tgt As Variant, tmp2
Dim ub As Long, e As Long
tgt = Target
r = LogSheet.Cells.SpecialCells(xlCellTypeLastCell).Row + 1
LogSheet.Cells(r, 1).Value = Now
On Error Resume Next
If (VarType(oldContents) And vbArray) = vbArray Then
ub = UBound(oldContents, 2)
e = Err.Number
Select Case e
Case 0 'no error; multi-col array
For L0 = LBound(oldContents, 1) To UBound(oldContents, 1)
For L1 = LBound(oldContents, 2) To ub
tmp1 = tmp1 & CStr(oldContents(L0, L1))
If (L0 <> UBound(oldContents, 1)) Or (L1 <> ub) Then
tmp1 = tmp1 & ","
End If
Next
Next
Case 9 'Ubound subscript too high; single-col array
ub = UBound(oldContents)
tmp1 = oldContents(LBound(oldContents))
For L0 = LBound(oldContents) + 1 To ub
tmp1 = tmp1 & "," & CStr(oldContents(L0))
Next
Case Else
Err.Raise e
End Select
Else
tmp1 = CStr(oldContents)
End If
If (VarType(tgt) And vbArray) = vbArray Then
ub = UBound(tgt, 2)
e = Err.Number
Select Case e
Case 0 'no error; multi-col array
For L0 = LBound(tgt, 1) To UBound(tgt, 1)
For L1 = LBound(tgt, 2) To ub
tmp2 = tmp2 & CStr(tgt(L0, L1))
If (L0 <> UBound(tgt, 1)) Or (L1 <> ub) Then
tmp2 = tmp2 & ","
End If
Next
Next
Case 9 'Ubound subscript too high; single-col array
ub = UBound(tgt)
tmp2 = tgt(LBound(tgt))
For L0 = LBound(tgt) + 1 To ub
tmp2 = tmp2 & "," & CStr(tgt(L0))
Next
Case Else
Err.Raise e
End Select
Else
tmp2 = CStr(Target.Value)
End If
On Error GoTo 0
LogSheet.Cells(r, 2).Value = "Changed " & Sh.Name & "!" & Target.Address & " from '" & tmp1 & "' to '" & tmp2 & "'"
LogSheet.Cells.Columns.AutoFit
oldContents = Target.Value
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If LogSheet Is Sh Then Exit Sub
oldContents = Target.Value
End Sub
