Determine Open Workbook User

[The_Kurgan]

I have code that tells whether a particular Excel workbook is open, but would like to also incorporate the name of the user who has it open. It should mimic the default Excel message, but I can't use that default message for various reasons. Has anyone used or written such code? I've found nothing in MrExcel and the only other resource I've found is here: Who has File Open (VBA Excel 2003, Win XP) | Windows Secrets Lounge.

I tried their bit of code:

Public Sub Get_a_Name()
'// Just change the file to test here
 Const strFileToOpen As String = "X:\Mgmt\Aged Warehouse Reports\Aging Workbooks (Do Not Open)\Aged 30-45.xlsm"

 If IsFileOpen(strFileToOpen) Then
 MsgBox strFileToOpen & " is already Open" & _
 vbCrLf & "By " & LastUser(strFileToOpen), vbInformation, "File in Use"
 MsgBox ActiveWorkbook.WriteReservedBy
 Else
 MsgBox strFileToOpen & " is not open"
 MsgBox ActiveWorkbook.WriteReservedBy
 End If
 End Sub

 Function IsFileOpen(strFullPathFileName As String) As Boolean
 Dim hdlFile As Long

 '// Error is generated if you try
 '// opening a File for ReadWrite lock >> MUST BE OPEN!
 On Error GoTo FileIsOpen:
 hdlFile = FreeFile
 Open strFullPathFileName For Random Access Read Write Lock Read Write As hdlFile
 IsFileOpen = False
 Close hdlFile
 Exit Function
FileIsOpen:
 '// Someone has it open!
 IsFileOpen = True
 Close hdlFile
 End Function

 Function LastUser(strPath As String) As String
 Dim text As String
 Dim strFlag1 As String, strflag2 As String
 Dim i As Integer, j As Integer

 strFlag1 = Chr(0) & Chr(0)
 strflag2 = Chr(32) & Chr(32)

 Open strPath For Binary As #1
 text = Space(LOF(1))
 Get 1, , text
 Close #1
 j = InStr(1, text, strflag2)
 i = InStrRev(text, strFlag1, j) + Len(strFlag1)     'PUKES HERE (Invalid procedure call or argument)
 LastUser = Mid(text, i, j - i)

 End Function

but it pukes on the InStrRev (Invalid procedure call or argument). I think that even if I could get the InStrRev to work, it would produce gibberish, as that's what the "text" variable produces.

I'd be open to any other ideas. Thanks in advance!

 

[hiker95]

The_Kurgan,

Here are some old threads/links that may help you:

macro to capture who accessed the Excel file
Macro to capture who accessed the Excel file
Private Sub Worksheet_Change(ByVal Target As Range)
' VoG
' macro to capture who accessed the Excel file
Dim NR As Long
If Intersect(Target, Range("F15:F25")) Is Nothing Then Exit Sub
With Sheets("Log")
.Unprotect Password:="xyz"
NR = .Range("A" & Rows.Count).End(xlUp).Row + 1
.Range("A" & NR).Value = Target.Address(False, False)
.Range("B" & NR).Value = Now
.Range("C" & NR).Value = Environ("username")
.Protect Password:="xyz"
End With
End Sub


Log Of Users Opening File
Log Of Users Opening File
Reafidy
In the workbook open event:
VB: AutoLinked keywords will cause extra spaces before keywords. Extra spacing is NOT transferred when copy/pasting, but IS if the keyword uses "quotes".
Private Sub Workbook_Open()
With Worksheets(" Tracking"). Range("A" & Rows.Count).End(xlUp).Offset(1)
.Value = Application.UserName
.Offset(, 1).Value = Date
End With
End Sub
Requires a worksheet called tracking. You can change the code to suit.

 

[AlphaFrog]

One kludge could be to have a Workbook_Open event procedure write the user's name to a text file. Then anyone else could read that text file to find out who has it open.

Put this in the "particular" workbook's ThisWorkbook code module.

Private Sub Workbook_Open()
    
    Dim FF As Integer
    
    'Write to text file
    FF = FreeFile()
    Open "C:\Test\CurrentUser.txt" For Output As #FF    'Change the path and filename to suit
    Print #FF, Environ$("UserName")
    Close #FF
    
End Sub


Private Sub Workbook_BeforeClose(Cancel As Boolean)
    
    Dim FF As Integer
    
    'Write  to text file
    FF = FreeFile()
    Open "C:\Test\CurrentUser.txt" For Output As #FF    'Change the path and filename to suit
    Print #FF, "Closed"
    Close #FF
    
End Sub

Use something like this to read the text file.

Sub Get_Current_User()
    Dim FF As Integer
    Dim strUser As String
    Const strFile As String = "C:\Test\CurrentUser.txt"    'Change the path and filename to suit
    
    If Dir(strFile) = "" Then MsgBox strFile, , "File Not Found": Exit Sub
    
    'Read text file
    FF = FreeFile()
    Open strFile For Input As #FF
    strUser = Input$(LOF(FF), FF)
    Close #FF
    
    MsgBox strUser, , "Current User"
            
End Sub

 

[The_Kurgan]

Thank you both for your suggestions! They're great ideas and I wouldn't have thought of them! Last night, I ended up going with a routine that opens the workbook, reads the name, and then closes it unbeknownst to the user. I'm going to run that and your suggestions past my peers today and see which they prefer. I'll post my code below for anyone interested.

Thanks again!!!

Private Sub CommandButton2_Click()
If Dash.ListBox1.text = "" Then
    MsgBox "Choose a file to open."
    Exit Sub
End If
ChosenWorkbook = Dash.ListBox1.text
If Dash.OptionButton1.Value = True Then
    Workbooks.Open fileName:="X:\Mgmt\" & ChosenWorkbook & ".xlsm", ReadOnly:=True
Else
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Workbooks.Open fileName:="X:\Mgmt\" & ChosenWorkbook & ".xlsm"
    If ActiveWorkbook.ReadOnly Then
        Dim Folder As String
        Dim FName As String
        Folder = "X:\Mgmt\"
        FName = Dir(Folder & ChosenWorkbook)
        ActiveWorkbook.Close
        MsgBox ("The " & ChosenWorkbook & " workbook is in use by " & GetFileOwner(Folder, FName) & " and cannot be opened using the Input Comments option.")
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
        Exit Sub
    Else
        Windows(ChosenWorkbook & ".xlsm").Activate
    End If
End If

Unload Dash

End Sub

Function GetFileOwner(fileDir As String, fileName As String) As String
'On Error Resume Next
Dim secUtil As Object
Dim secDesc As Object
Set secUtil = CreateObject("ADsSecurityUtility")
Set secDesc = secUtil.GetSecurityDescriptor(fileDir & fileName, 1, 1)
GetFileOwner = secDesc.owner
End Function

 

[hiker95]

The_Kurgan,

Thanks for the feedback.

You are very welcome. Glad we could help.

And, come back anytime.