Views

VBA Excel - Acompanhando a utilização massiva de planilha.

excel-header.jpg
No nosso dia-a-dia existem planilhas que são massivamente usadas por vários usuários, por vezes simultaneamente, noutras ocorre um entra e sai extenuante de diversos usuários diferentes.

Em Thisworkbook, coloque:
Private Sub Workbook_Open()
    If ThisWorkbook.ReadOnly Then        DisplayCurrentUser
    Else        LogCurrentUser ' log the last user information
        ' or add the last user information to the log history
        LogThisUserAction "Opened"    End If
End Sub

Sub Workbook_BeforeClose (Cancel As Boolean)
    If Not ThisWorkbook.ReadOnly Then        KillCurrentUserLog ' delete the last user information
    End If
    ' or add the last user information to the log history
    LogThisUserAction "Closed"
End Sub

Crie um módulo com o nome de mdl_LogUserHistory, cole o código abaixo:
' Author: Ole P. Erlandsen

Option Explicit

' API declarations
Declare Function GetComputerName Lib "kernel32" _
    Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Declare Function GetUserName Lib "advapi32.dll" _
    Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Sub LogCurrentUser()
' writes information to the logfile, you can call this from the Workbook_Open procedure
Dim f As Integer, LogFile As String
    LogFile = ThisWorkbookLogFileName
    If Len(LogFile) = 0 Then Exit Sub ' workbook not saved yet...
    f = FreeFile
    On Error Resume Next ' ignores any logging errors
    Open LogFile For Output As #f
    Write #f, Format(Now, "yyyy-mm-dd hh:mm:ss"), Application.UserName, _
        ReturnUserName, ReturnComputerName
    Close #f
    On Error GoTo 0
End Sub

Sub KillCurrentUserLog()
' deletes the logfile, you can call this from the Workbook_BeforeClose procedure
Dim LogFile As String
    LogFile = ThisWorkbookLogFileName
    On Error Resume Next
    Kill LogFile
    On Error GoTo 0
End Sub

Sub DisplayCurrentUser()
' displays the information in the log file
Dim f As Integer, LogFile As String
Dim strDateTime As String, strAppUserName As String
Dim strUserID As String, strComputerName As String
    LogFile = ThisWorkbookLogFileName
    If Len(LogFile) = 0 Then Exit Sub ' workbook not saved yet...
    f = FreeFile
    On Error Resume Next ' ignores any logging errors
    Open LogFile For Input Access Read Shared As #f
    Input #f, strDateTime, strAppUserName, strUserID, strComputerName
    Close #f
    On Error GoTo 0

    MsgBox "User name: " & strAppUserName & Chr(13) & _
        "UserID: " & strUserID & Chr(13) & _
        "Computer name: " & strComputerName & Chr(13) & _
        "Date/time: " & strDateTime & Chr(13), _
        vbInformation, ThisWorkbook.Name & " is in use by:"
End Sub

Function ThisWorkbookLogFileName() As String
' returns the filename used for logging information
    ThisWorkbookLogFileName = ""
    If Len(ThisWorkbook.Path) = 0 Then Exit Function
    ThisWorkbookLogFileName = Left(ThisWorkbook.FullName, Len(ThisWorkbook.FullName) - 3) & "log"
End Function

Function ReturnComputerName() As String
' returns the computer name
Dim rString As String * 255, sLen As Long, tString As String
    tString = ""
    On Error Resume Next
    sLen = GetComputerName(rString, 255)
    sLen = InStr(1, rString, Chr(0))
    If sLen > 0 Then
        tString = Left(rString, sLen - 1)
    Else
        tString = rString
    End If
    On Error GoTo 0
    ReturnComputerName = UCase(Trim(tString))
End Function

Function ReturnUserName() As String
' returns the Domain User Name
Dim rString As String * 255, sLen As Long, tString As String
    tString = ""
    On Error Resume Next
    sLen = GetUserName(rString, 255)
    sLen = InStr(1, rString, Chr(0))
    If sLen > 0 Then
        tString = Left(rString, sLen - 1)
    Else
        tString = rString
    End If

    On Error GoTo 0
    ReturnUserName = UCase(Trim(tString))
End Function

Crie outro módulo com o nome de mdl_LogCurrentUser, cole o código abaixo:
' Author: Ole P. Erlandsen

Option Explicit

' API declarations
Declare Function GetComputerName Lib "kernel32" _
    Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
    
Declare Function GetUserName Lib "advapi32.dll" _
    Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Sub LogThisUserAction(Action As String)
' writes information to the logfile, you can call this from the Workbook_Open procedure
Dim f As Integer, LogFile As String
    LogFile = ThisWorkbookLogFileName
    If Len(LogFile) = 0 Then Exit Sub ' workbook not saved yet...
    f = FreeFile
    On Error Resume Next ' ignores any logging errors
    Open LogFile For Append As #f
    Write #f, Format(Now, "yyyy-mm-dd hh:mm:ss"), Application.UserName, _
        ReturnUserName, ReturnComputerName, Action
    Close #f
    On Error GoTo 0
End Sub

Sub DisplayLastUserAction()
' displays the last line of information in the log file
Dim f As Integer, LogFile As String
Dim strDateTime As String, strAppUserName As String
Dim strUserID As String, strComputerName As String
    LogFile = ThisWorkbookLogFileName
    If Len(LogFile) = 0 Then Exit Sub ' workbook not saved yet...
    f = FreeFile
    On Error Resume Next ' ignores any logging errors
    Open LogFile For Input Access Read Shared As #f
    Do While Not EOF(f)
        Input #f, strDateTime, strAppUserName, strUserID, strComputerName
    Loop ' until the last line is read
    Close #f
    On Error GoTo 0

    MsgBox "User name: " & strAppUserName & Chr(13) & _
        "UserID: " & strUserID & Chr(13) & _
        "Computer name: " & strComputerName & Chr(13) & _
        "Date/time: " & strDateTime & Chr(13), _
        vbInformation, "Last User Action:"
End Sub

Function ThisWorkbookLogFileName () As String
' returns the filename used for logging information
    ThisWorkbookLogFileName = ""
    If Len(ThisWorkbook.Path) = 0 Then Exit Function
    ThisWorkbookLogFileName = Left(ThisWorkbook.FullName, Len(ThisWorkbook.FullName) - 3) & "txt"
End Function

Function ReturnComputerName() As String
' returns the computer name
Dim rString As String * 255, sLen As Long, tString As String
    tString = ""
    On Error Resume Next
    sLen = GetComputerName(rString, 255)
    sLen = InStr(1, rString, Chr(0))

    If sLen > 0 Then
        tString = Left(rString, sLen - 1)
    Else
        tString = rString
    End If
    On Error GoTo 0
    ReturnComputerName = UCase(Trim(tString))
End Function

Function ReturnUserName() As String
' returns the Domain User Name
Dim rString As String * 255, sLen As Long, tString As String
    tString = ""
    On Error Resume Next
    sLen = GetUserName(rString, 255)
    sLen = InStr(1, rString, Chr(0))

    If sLen > 0 Then
        tString = Left(rString, sLen - 1)
    Else
        tString = rString
    End If
    On Error GoTo 0
    ReturnUserName = UCase(Trim(tString))
End Function

Function AC (Row As Boolean) As Long
    ' returns the row- or columnnumber for the active cell
    
    Let AC = 0
    
    On Error Resume Next
    
    If Row Then
        Let AC = ActiveCell.Row
    Else
        Let AC = ActiveCell.Column
    End If
End Function

Tags: Excel, udf, doc, documentation, log, security, API, dll


André Luiz Bernardes
A&A® - In Any Place.




  
   

Tags: , , , , , , ,

Nenhum comentário:

Postar um comentário

Assinar: Postar comentários (Atom)
diHITT - Notícias