KP said:
Is it possible to write a macro that can create a logfile with the
following information:
Whew! This was a pain in the ass to write.
The date and time the file was opened
By whom it was opened (network)
Handled in Workbook_Open below.
Data entered with reference to cells
Data deleted with reference to cells
Handled in Workbook_SheetChange below.
The date and time the file was saved
Handled in Workbook_BeforeSave below.
I prefer if the log file can be written to a sheet in the same file
There may be better ways of doing this (probably are) but this works...
mostly.
As I said, this was a PITA, and while I'm pretty sure I've got it working
correctly, I had some problem with multi-column selections. *Had*. (I've
marked the block where it was, in case it somehow comes back.) And there is
a problem capturing the data in multi-cell selections; see the sample log
below the code. Hopefully someone else can fix that problem.
Where the multi-column selection problems were, I've marked in the code in
case they crop up again.
Everything between "'''''begin'''''" and "'''''end'''''" goes in the
workbook's ThisWorkbook class.
'''''begin'''''
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
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, _
Cancel As Boolean)
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 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
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:
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
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
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
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 'PROBLEMS BEGAN HERE
If (VarType(oldContents) And vbArray) = vbArray Then
ub = UBound(oldContents, 2)
e = Err.Number
Select Case e
Case 0 'No error; multi-col aray.
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 aray.
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 'PROBLEMS ENDED HERE
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
'''''end'''''
Note that the log sheet is hidden. To leave the log sheet visible, delete
the line "LogSheet.Visible = xlSheetHidden" in Workbook_Open.
Here's a sample log sheet:
Time Item
Time Item
2/29/2012 6:57 File opened by Auric
2/29/2012 6:58 Changed Sheet1!$A$1:$B$1 from 'foo,1' to ','
2/29/2012 6:59 Changed Sheet1!$A$1 from '' to 'foo'
2/29/2012 6:59 Changed Sheet1!$B$1 from 'foo' to '1'
2/29/2012 6:59 Changed Sheet1!$A$1:$B$1 from 'foo' to ','
2/29/2012 6:59 Changed Sheet1!$A$1 from '' to 'foo'
2/29/2012 6:59 Changed Sheet1!$B$1 from 'foo' to '1'
2/29/2012 6:59 Changed Sheet1!$A$1:$B$2 from 'foo,1,bar,2' to ',,,'
2/29/2012 6:59 Changed Sheet1!$A$1 from '' to 'foo'
2/29/2012 6:59 Changed Sheet1!$A$2 from 'foo' to 'bar'
2/29/2012 6:59 Changed Sheet1!$B$1 from 'bar' to '1'
2/29/2012 6:59 Changed Sheet1!$B$2 from '1' to '2'
2/29/2012 6:59 Saved
Note that some entries show what happens with multi-cell changes. Also note
that entries that show "Changed Sheet1!$B$1 from 'foo' to '1'" are where
the "capturing the data in multi-cell selections" problem crops up.
(Should've instead said "from '' to '1'". Sigh.)
Also note that wherever you see '' or a comma without data before it, it
means "blank cell" (so "'' to 'foo'" means the cell was empty before, while
"'foo' to ''" means the contents were deleted).
Christ, I need a drink now.
