VB and VBA Users Source Code: Listing (and disconnecting) the user's sharing an Excel Workbook
[
Home
|
Contents
|
Search
|
Reply
| Previous | Next ]
VB/VBA Source Code
Listing (and disconnecting) the user's sharing an Excel Workbook
By:
Andrew Baker
Email (spam proof):
Email the originator of this post
Date:
Sunday, February 02, 2003
Hits:
2511
Category:
Office
Article:
The following code shows how to list the user's that have opened a specified shared workbook and shows how to disconnect specified users. Option Explicit 'Purpose : Lists the users logged into the specified shared workbook 'Inputs : oWkb The shared workbook to list the users on. 'Outputs : Returns a 1 based 2d array of users currently logged into the workbook 'Author : Andrew Baker 'Date : 13/11/2002 10:14 'Notes : 'Revisions : Function WorkbookListUsers(oWkb As Workbook) As Variant Dim avUsers As Variant, lThisUser As Long On Error Resume Next avUsers = oWkb.UserStatus If IsArray(avUsers) = False Then 'Not a shared workbook WorkbookListUsers = Empty Else 'Shared workbook For lThisUser = 1 To UBound(avUsers, 1) If avUsers(lThisUser, 3) = 1 Then avUsers(lThisUser, 3) = "Exclusive" Else avUsers(lThisUser, 3) = "Shared" End If Next WorkbookListUsers = avUsers End If On Error GoTo 0 End Function 'Purpose : Removes a users login for the specified shared workbook 'Inputs : oWkb The workbook to list the users. 'Outputs : Returns a 1 based 2d array of users currently logged into the workbook 'Author : Andrew Baker 'Date : 13/11/2002 10:14 'Notes : 'Revisions : Function WorkbookRemoveUser(oWkb As Workbook, lIndex As Long) As Boolean On Error GoTo ErrFailed oWkb.RemoveUser lIndex WorkbookRemoveUser = True Exit Function ErrFailed: Debug.Print "Error in WorkbookRemoveUser: " & Err.Description WorkbookRemoveUser = False Err.Clear End Function 'Demonstration code. 'List users and removes selected users Sub Test() Dim avUsers As Variant, lThisUser As Long avUsers = WorkbookListUsers(Workbooks(1)) If IsArray(avUsers) Then 'List the users For lThisUser = 1 To UBound(avUsers, 1) Debug.Print "User: " & avUsers(lThisUser, 1) If MsgBox("Remove user " & avUsers(lThisUser, 1) & "? ", vbYesNo) = vbYes Then 'Remove a user If WorkbookRemoveUser(Workbooks(1), lThisUser) = True Then MsgBox "Removed user " & avUsers(lThisUser, 1) & "...", vbInformation End If End If Next End If End Sub
Terms and Conditions
Support this site
Download a trial version of the Excel Workbook Rebuilder
