Log a file - print, save, change, close!

Logs seems a popular topic to be. In the following example is logged open, close, save and print of a file. In addition changes on all worksheets are logged. However with multiple choice only up to a certain limit. Can be amended however in the code. If no limit is given here, perhaps then the macro runs itself to death - e.g. with mark a whole column, or evenly several columns. The files received depending upon event other names and are stored in determining temp directory. With "CTRL+ALT+F12" can ALL LOGS - which are stored in determined TEMP directory - be deleted. Possibly the file could with reaching a certain size or a certain number of lines to be deleted and/or a new file begin - that is your part. The files at the end of the article are Excelfiles of the version 2003 and 2007. The following code belonged in "ThisWorkbook".



Option Explicit
Dim varOldValue As Variant
Private Declare Function GetTempPath Lib "kernel32" Alias _
"GetTempPathA" (ByVal nBufferLength As Long, ByVal _
lpBuffer As String) As Long
Private Sub Workbook_Deactivate()
Application.OnKey "^%{F12}"
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, _
ByVal Target As Range)
Dim lngColumn As Long
Dim lngCount As Long
Dim lngRow As Long
lngRow = Target.Cells.Row
lngColumn = Target.Cells.Column
If Target.Cells.Count > 1 And Target.Cells.Count <= 20 Then
varOldValue = ""
For lngCount = 1 To Target.Cells.Count
If lngCount = Target.Cells.Count Then
varOldValue = varOldValue & _
Cells(lngRow, lngColumn).Value
lngRow = lngRow + 1
Else
varOldValue = varOldValue & _
Cells(lngRow, lngColumn).Value & vbLf
lngRow = lngRow + 1
End If
Next lngCount
Else
varOldValue = ActiveCell.Value
End If
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, _
ByVal Target As Range)
Dim intFreeFile As Integer
Dim strFileName As String
Dim strAddress As String
Dim strValue As String
Dim strPath As String
Dim strUser As String
Dim strDate As String
Dim strTime As String
Application.ScreenUpdating = False
strPath = GetTempDir & "WBook_Change.log"
intFreeFile = FreeFile
Reset
strUser = Environ("UserName")
strDate = Format(Now, "dd.mm.yyyy")
strTime = Format(Now, "hh:mm")
strFileName = ThisWorkbook.FullName
strAddress = Target.Address(False, False)
strValue = Target.Resize(1, 1).Text
Open strPath For Append As #1
Print #1, strUser & vbTab & strDate & vbTab & strTime
Print #1, strFileName
Print #1, Sh.Name
Print #1, strAddress
If strValue = "" Then
Print #1, "Eingegebner Wert" & vbTab & "0"
Else
Print #1, "Eingegebner Wert" & vbTab & strValue
End If
If varOldValue = "" Then
Print #1, "Alter Wert" & vbTab & vbTab & "0"
Else
Print #1, "Alter Wert" & vbTab & vbTab & varOldValue
End If
Print #1, "-----------------------------"
Close #1
Application.ScreenUpdating = True
End Sub
Private Sub Workbook_Open()
Dim strPath As String
Application.OnKey "^%{F12}", "DieseArbeitsmappe.Loeschen"
strPath = GetTempDir & "WBook_Open.log"
Call LOG(strPath)
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim strPath As String
strPath = GetTempDir & "WBook_Close.log"
Call LOG(strPath)
End Sub
Private Sub Workbook_BeforePrint(Cancel As Boolean)
Dim strPath As String
strPath = GetTempDir & "WBook_Print.log"
Call LOG(strPath)
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, _
Cancel As Boolean)
Dim strPath As String
strPath = GetTempDir & "WBook_Save.log"
Call LOG(strPath)
End Sub
Private Sub LOG(ByVal strPathDatei As String)
Dim intFreeFile As Integer
Dim strFileName As String
Dim strPath As String
Dim strUser As String
Dim strDate As String
Dim strTime As String
strPath = strPathDatei
intFreeFile = FreeFile
Reset
strUser = Environ("UserName")
strDate = Format(Now, "dd.mm.yyyy")
strTime = Format(Now, "hh:mm")
strFileName = ThisWorkbook.FullName
Open strPath For Append As #1
Print #1, strUser & vbTab & strDate & vbTab & strTime
Print #1, strFileName
Print #1, "-----------------------------"
Close #1
End Sub
Private Sub Loeschen()
On Error Resume Next
Kill (GetTempDir & "WBook_*.log")
On Error GoTo 0
End Sub
Private Function GetTempDir() As String
Dim strTemp As String
Dim strPath As String
Dim lngCount As Long
strTemp = Space(255)
lngCount = GetTempPath(255, strTemp)
If lngCount > 0 Then
strPath = Left$(strTemp, lngCount)
If Right$(strPath, 1) <> "\" Then strPath = strPath & "\"
End If
GetTempDir = strPath
End Function


Sample 2003

Sample 2007

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...