VBA codes showing the list of users who open the shared workbook

VBA codes showing the list of users who open the shared workbook:

ThisWorkbook:
Private Sub Workbook_Open()
    Application.OnKey "{F2}", "UsersInfo"
    UsersInfo
End Sub

Module1:
Public Sub UsersInfo()
    Users = ActiveWorkbook.UserStatus
   
    Dim sMsg As String
   
    Dim nLen1 As Integer
Dim nLen2 As Integer
    nLen1 = 0
nLen2 = 0
    For Row = 1 To UBound(Users, 1)
        If Len(Users(Row, 1)) > nLen1 Then
            nLen1 = Len(Users(Row, 1))
        End If
        If Len(Users(Row, 2)) > nLen2 Then
            nLen2 = Len(Users(Row, 2))
        End If
    Next
   
    Dim sSpaces1 As String
    Dim sSpaces2 As String
    If Len("Users") < nLen1 Then
        sSpaces1 = Space(nLen1 - Len("Users"))
    Else
        sSpaces1 = ""
    End If
    If Len("Opened at") < nLen2 Then
        sSpaces2 = Space(nLen2 - Len("Opened at"))
    Else
        sSpaces2= ""
    End If
    sMsg = "Users" & sSpaces1 & Chr(9) & Chr(9) & "Opened at" & sSpaces2 & Chr(9) & Chr(9) & "Open Mode" & Chr(13) & Chr(10)
   
    For Row = 1 To UBound(Users, 1)
        If Len(Users(Row, 1)) < nLen1 Then
            sSpaces1 = Space(nLen1 - Len(Users(Row, 1)))
        Else
            sSpaces1 = ""
        End If
        If Len(Users(Row, 2)) < nLen2 Then
            sSpaces2 = Space(nLen2 - Len(Users(Row, 2)))
        Else
            sSpaces2 = ""
        End If
        sMsg = sMsg & Users(Row, 1) & sSpaces1 & Chr(9) & Chr(9)
        sMsg = sMsg & Users(Row, 2) & sSpaces2 & Chr(9) & Chr(9)
        Select Case Users(Row, 3)
            Case 1
                sMsg = sMsg & " Exclusive"
            Case 2
                sMsg = sMsg & " Shared"
        End Select
        sMsg = sMsg & Chr(13) & Chr(10)
    Next
sMsg = sMsg & Chr(13) & Chr(10)
    sMsg = sMsg & "Press F2 to show this information again!"
    MsgBox sMsg, , "Current Users who open this workbook"
End Sub



Comments

Popular posts from this blog

Error - vbe6ext.olb could not be loaded

Visual Studio $(TargetDir) macro is empty