Узнать имя пользователя, открывшего файл (в локальной сети) - VBA

Sub bb()
Dim FS, Res, ServerName
ServerName = "имя_сервера" '<<<
On Error Resume Next
Set FS = GetObject("WinNT://" & ServerName & "/lanmanserver, fileservice")
For Each Res In FS.Resources
    Debug.Print Res.Get("User"), Res.Get("Path")
Next
End Sub

Option Compare Database
Option Explicit
 
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function LookupAccountName Lib "advapi32.dll" Alias "LookupAccountNameA" (lpSystemName As String, ByVal lpAccountName As String, sid As Any, cbSid As Long, ByVal ReferencedDomainName As String, cbReferencedDomainName As Long, peUse As Long) As Long
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Public CompName As String 'объявляем переменную доступную для всего проекта
 
Dim Workbooks As Object
Dim xlWbkEx As Object
Dim xlAppEx As Object
 
Public Rowss1 As Variant
Public Rowss2 As Integer
 
'Const MyFile = "P:\Судебные дела\СУДЕБНЫЕ ДЕЛА 2015 ОПОСД.xls"
Const MyFile = "c:\iSKi_X\ДЕЛА 2015 ОПОСД.xls"
Const l = "Сводная таблица_2015г"
 
Public rng As Object
 
Sub reportToExcel_Isk()
 
Call StatusBarYes
 
Set xlAppEx = CreateObject("Excel.Application.14") 'создаем объект Excel, чтобы можно было работать с его методами и свойствами
 
Again:
'проверка на открытие файла
If IsOpen(MyFile) Then
    MsgBox "Файл " & MyFile & " УЖЕ кем-то ИСПОЛЬЗУЕТСЯ. Останавливаемся.", vbExclamation
    DoCmd.HourGlass False
    Call Get_UserStatus_Info
    Exit Sub
 
Else
    DoCmd.HourGlass False
    MsgBox "Файл " & MyFile & " никем не используется. Продолжаем...", vbInformation
End If
 
'запрос значения Rowss - указать номер строки под которой надо вставить
Rowss1 = InputBox("Введите номер строки, ПОД которой надо вставить новую строку", "Ввод числа")
 
Dim myReply
 
If Not IsNumeric(Rowss1) Then
        myReply = MsgBox("Номер строки был указан не цифрой. Повторить процедуру?", vbYesNo + vbQuestion + vbApplicationModal, "Ввод номера строки")
        If myReply = vbNo Then
        Exit Sub
        End If
        If myReply = vbYes Then
        MsgBox "Повторяем..."
        GoTo Again
        End If
       
Else: GoTo 1
 
If Rowss1 = "" Then
        myReply = MsgBox("Номер строки не указан. Остановить процедуру?", vbYesNo + vbQuestion + vbApplicationModal, "Ввод номера строки")
        If myReply = vbYes Then
        Exit Sub
        End If
        If myReply = vbNo Then
        MsgBox "Повторяем..."
        GoTo Again
        End If
       
Else: GoTo 1
End If
    
1:
    Dim Msg, Style, Title, Response
    Msg = "Вы правильно указали номер строки ПОД которой вставить? " & " ---> " & Rowss1 & vbCr & "Будет вставлена строка:  ---> " & Rowss1 + 1 & vbCr & "Продолжаем?" 'ns
    Style = vbYesNo + vbQuestion + vbApplicationModal
    Title = "Ввод номера строки"
    
    Response = MsgBox(Msg, Style, Title)
        If Response = vbNo Then    ' User chose No.
            MsgBox "Исправьте значение и продолжайте", vbApplicationModal, "Ввод номера строки"
            GoTo Again
        Else    ' User chose Yes.
            MsgBox "Продолжаем!", vbApplicationModal
        End If
  
End If
 
DoCmd.HourGlass (-1) 'True
    
'Rowss1 = ns
Rowss2 = Rowss1 + 1
 
'strPathExcel = MyFile
Set xlWbkEx = xlAppEx.Workbooks.Open(MyFile)
 
'то добавляем строку
xlWbkEx.Worksheets(l).Rows(Rowss2).Insert
 
'Запомним нашу строку
'Set newrow = xlWbk.Worksheets(L).Rows(Rowss2)
 
With xlWbkEx.Worksheets(l)
    .Rows(Rowss1).Copy
    .Rows(Rowss2).PasteSpecial Paste:=-4122
    .Rows(Rowss2).Select
    
    'динамически формируем адрес нужной ячейки и задаем ей значение
    .Range("A" & Rowss2).Value = "МКП ""Воронежтеплосеть"" "
    .Range("B" & Rowss2).Value = Forms![Данные]![Краткое_наименование] '.Value 'если поле
    .Range("D" & Rowss2).Value = "№ " & Forms![Данные]![Номер_платежки] & " от " & Forms![Данные]![Дата_платежки] '.Value 'если поле
    .Range("E" & Rowss2).Value = Date   '.Value 'если поле
    .Range("F" & Rowss2).Value = "взыскание задолженности за тепловую энергию"
    .Range("G" & Rowss2).Value = Forms![Данные]![Начало_периода] & "-" & Forms![Данные]![Конец_периода]
    .Range("J" & Rowss2).Value = Nz(Forms![Данные]![Сумма_долга], 0) + Nz(Forms![Данные]![Сумма_процентов], 0)
    .Range("X" & Rowss2).Value = "С.А.Калинин"
    
     '  .Range("B10").Value = "B10-наше значение"
     '  .[D5] = Forms![Данные]![Краткое_наименование]
    
    ' задаем диапазон выбора ячеек и задаем им форматирование границ
    'Set rng = .Range("A" & Rowss2, "X" & Rowss2)
    'Call make_border_2
 
End With
 
xlAppEx.CutCopyMode = False
xlAppEx.Visible = True 'запускаем приложение Excel, можно сдвинуть вниз
 
'Set appEx = Nothing 'уничтожаем переменную с объектом
Set xlAppEx = Nothing
Set xlWbkEx = Nothing
'Set ns = Nothing
Set Rowss1 = Nothing
 
Call StatusBarNo
 
End Sub
 
Public Function IsOpen(File$) As Boolean
Dim fn%
fn = FreeFile
On Error Resume Next
Open File For Random Access Read Write Lock Read Write As #fn
Close #fn
IsOpen = Err
End Function
Public Sub Get_UserStatus_Info()
Dim asUsers, sUserName As String, sDateTime As String, sStatus As String
Dim li As Long
 
Dim xlAppExGet As Object
Set xlAppExGet = GetObject(MyFile)

    On Error Resume Next
 
asUsers = xlAppExGet.Workbooks(MyFile).UserStatus
    
    Select Case Err.number
    Case 9:
        MsgBox "Файл отсутствует? " & vbNewLine & "Номер ошибки: " & Err.number & vbNewLine & "Описание ошибки: " & Err.Description
        'Resume Next
        Err.Clear
        Exit Sub
    End Select

For li = 1 To UBound(asUsers, 1)
sUserName = sUserName & vbNewLine & asUsers(li, 1) & "; время изменения файла: " & Format(asUsers(li, 2), "dd.mm.yyyy hh:mm")
sDateTime = asUsers(li, 2)
    Select Case asUsers(li, 3)
        Case 1
        sStatus = "Монопольный"
        Case 2
        sStatus = "Общий"
        Case Else
        sStatus = "Не определен"
    End Select
Next
 
MsgBox "Пользователи файла:" & vbNewLine & sUserName & vbNewLine & "Доступ к файлу - " & sStatus
 
Call Get_LogonUser
Call Get_ComputerName
 
Debug.Print IIf(xlAppExGet.Workbooks("c:\iSKi_X\ДЕЛА 2015 ОПОСД.xls").UserStatus(1, 3) = 1, "Exclusive", "Shared")
 
Set xlAppExGet = Nothing
 
End Sub
 
Public Sub Get_LogonUser()
MsgBox "LogonDomain: " & GetLogonDomainuser & " / " & "LogonUser: " & GetLogonUser
End Sub
 
Public Function GetLogonDomainuser() As String
Dim lResult As Long
Dim i As Integer
Dim bUserSid(255) As Byte
Dim sUserName As String
Dim sDomainName As String * 255
Dim lDomainNameLength As Long
Dim lSIDType As Long
sUserName = GetLogonUser
lResult = LookupAccountName(vbNullString, sUserName, bUserSid(0), 255, sDomainName, lDomainNameLength, lSIDType)
sDomainName = Space(lDomainNameLength)
lResult = LookupAccountName(vbNullString, sUserName, bUserSid(0), 255, sDomainName, lDomainNameLength, lSIDType)
If (lResult = 0) Then
MsgBox "Ошибка: невозможно найти имя домена для юзера: " & sUserName
Exit Function
End If
sDomainName = Left$(sDomainName, InStr(sDomainName, Chr$(0)) - 1)
GetLogonDomainuser = Trim(sDomainName)
End Function
Public Function GetLogonUser() As String
Dim strTemp As String, strUserName As String
strTemp = String(100, Chr$(0))
strTemp = Left$(strTemp, InStr(strTemp, Chr$(0)) - 1)
strUserName = String(100, Chr$(0))
GetUserName strUserName, 100
strUserName = Left$(strUserName, InStr(strUserName, Chr$(0)) - 1)
GetLogonUser = strUserName
End Function
 
Public Function UserName() As String
Dim cn As String
Dim ls As Long
Dim Res As Long
cn = String(1024, 0)
ls = 1024
Res = GetUserName(cn, ls)
If Res <> 0 Then
UserName = Mid(cn, 1, InStr(cn, Chr(0)) - 1)
Else
UserName = ""
End If
End Function
 
Public Sub Get_ComputerName()
Dim scomp As String, h As String
 
scomp = Space(255)
h = GetComputerName(scomp, 255)
CompName = Trim(scomp)
MsgBox "Имя компьютера, с которого открыт файл:  " & CompName
End Sub