Объединить 4 модуля в один

@intersk · Регистрация: 07.09.2014

Студворк — интернет-сервис помощи студентам

Есть 4 модуля. По отдельности все они работают.
Нужны для того, чтобы определить кто открыл файл, лежащий на сервере.
Помогите их объединить в один чтобы в итоге получился вывод сообщения.
Дополнительное пожелание: присвоение переменной текста этого сообщения, чтобы можно было передать в другую процедуру)

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
Option Compare Database
 
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
 
Sub reportToExcel()
 
Dim strPathExcel As String
Dim xlWbk As Object
Dim ns
Dim L As String
Dim xlApp As Object
 
Set xlApp = CreateObject("Excel.Application") 'создаем объект Excel, чтобы можно было работать с его методами и свойствами
Const MyFile = "P:\Судебные дела\СУДЕБНЫЕ ДЕЛА 2014г.xls"
L = "Сводная таблица_2014г"
 
Again:
'проверка на открытие файла
If IsOpen(MyFile) Then
    MsgBox "Файл " & MyFile & " УЖЕ кем-то ИСПОЛЬЗУЕТСЯ. Останавливаемся.", vbExclamation
    Call Get_UserStatus_Info
Exit Sub
 
Else
    MsgBox "Файл " & MyFile & " никем не используется. Продолжаем...", vbInformation
End If
 
End Sub
======================================================
Option Compare Database
Option Explicit
Dim app As Object
Dim Workbooks As Object
 
Sub Get_UserStatus_Info()
 
Call Get_ComputerName
Call Get_LogonUser
 
Dim asUsers, sUserName As String, sDateTime As String, sStatus As String
Dim li As Long
 
Dim app As Object
Set app = GetObject(, "Excel.Application")
 
asUsers = app.Workbooks("СУДЕБНЫЕ ДЕЛА 2014г.xls").UserStatus
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 = "Общий"
End Select
Next
 
 
 
MsgBox "Пользователи файла:" & vbNewLine & "Office зарегистрирован на: " & sUserName & vbNewLine & "Доступ к файлу - " & sStatus & vbNewLine & "Имя компьютера: " & CompName
 
Set sUserName = Nothing
Set sStatus = Nothing
Set cn = Nothing
 
End Sub
================================
Option Compare Database
 
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 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
Private 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
==========================
Option Compare Database
 
Public CompName As String 'объявляем переменную доступную для всего проекта
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
 
Sub Get_ComputerName()
Dim scomp As String
 
scomp = Space(255)
h = GetComputerName(scomp, 255)
'MsgBox Trim(scomp)
CompName = Trim(scomp)
MsgBox "Имя компьютера, с которого открыт файл:  " & CompName
End Sub

mobile · 13.10.2014, 11:53

Достаточно сложная задача со многими неопределенностями. К тому же немалый текст...

Если файл один и тот же, то как мне кажется, намного проще создать лог-файл открытий этой книги екселя. При открытии книги, записывать в лог имена юзера и ПК. При необходимости считывать эти записи лога и анализировать их.
Для создания лога в книге екселя, в отдельном модуле надо записать макрос auto_open(). Например, такого содержания

Visual Basic
1
2
3
4
5
6
7
8
9
Sub auto_open()
    Dim ff, i, pathXL
    ff = FreeFile
    pathXL = "c:\temp\openxl.txt"  'Путь к текстовому файлу лога
    Open pathXL For Append As ff   'открытие лог-файла
    'Запись в лог файл имен юзера и компа
    Print #ff, Environ("username") & ", " & Environ("computername") & ", " & Now
    Close #ff
End Sub

А для чтения лога можно использовать процедуру

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
Sub readopenxl()
    Dim ff, txt, pathXL, p
    ff = FreeFile
    pathXL = "c:\temp\openxl.txt"
    Open pathXL For Input As ff
    Do Until EOF(ff)                   'Цикл до конца файла.
        Line Input #1, txt             'Читаем строку
        p = Split(txt, ",")            'Разбиваем текст по запятым
        Debug.Print p(0), p(1), p(2)   'Печать в область отладки частей прочитанной строки
    Loop
    Close #ff
End Sub

Пример файла екселя, в котором уже пеомещены эти процедуры

@intersk · 13.10.2014, 14:11 **[ТС]**

mobile, понимаю что текста много. Почему обратился - потому что каждая из этих процедур работает. Но только одна из них (Get_UserStatus_Info) использует для выполнения сетевой "файл". Остальные просто отображают данные текущего компьютера. Мне надо распространить их действие не на мой компьютер, а на компьютер того, кто открыл "файл".

Собрал их все в один модуль, всё отображает. Но опять же часть относительно сетевого файла, а часть показывает данные моего компьютера.

Как понимаю нужно эти процедуры подключить к объекту GetObject(, "Excel.Application") , но мне знаний не хватает. Запуск работы модулей начинается с (reportToExcel())

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
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
Public CompName As String 'объявляем переменную доступную для всего проекта
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
 
Dim app As Object
Dim Workbooks As Object
 
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
 
Sub reportToExcel()
 
Dim strPathExcel As String
Dim xlWbk As Object
Dim ns
Dim L As String
Dim xlApp As Object
Dim Rowss As Integer, Rowss2 As Integer
 
Set xlApp = CreateObject("Excel.Application") 'создаем объект Excel, чтобы можно было работать с его методами и свойствами
Const MyFile = "P:\Судебные дела\СУДЕБНЫЕ ДЕЛА 2014г.xls"
L = "Сводная таблица_2014г"
 
Again:
'проверка на открытие файла
If IsOpen(MyFile) Then
    MsgBox "Файл " & MyFile & " УЖЕ кем-то ИСПОЛЬЗУЕТСЯ. Останавливаемся.", vbExclamation
    Call Get_UserStatus_Info
Exit Sub
 
Else
    MsgBox "Файл " & MyFile & " никем не используется. Продолжаем...", vbInformation
End If
End Sub
 
 
Sub Get_UserStatus_Info()
 
Call Get_ComputerName
Call Get_LogonUser
 
Dim asUsers, sUserName As String, sDateTime As String, sStatus As String
Dim li As Long
 
Dim app As Object
Set app = GetObject(, "Excel.Application")
 
asUsers = app.Workbooks("СУДЕБНЫЕ ДЕЛА 2014г.xls").UserStatus
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 = "Общий"
End Select
Next
 
MsgBox "Пользователи файла:" & vbNewLine & "Office зарегистрирован на: " & sUserName & vbNewLine & "Доступ к файлу - " & sStatus & vbNewLine & "Имя компьютера: " & CompName
 
'Set sUserName = Nothing
'Set sStatus = Nothing
'Set cn = Nothing
 
End Sub
 
Private 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
Private 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
 
Sub Get_ComputerName()
Dim scomp As String, h As String
 
scomp = Space(255)
h = GetComputerName(scomp, 255)
'MsgBox Trim(scomp)
CompName = Trim(scomp)
MsgBox "Имя компьютера, с которого открыт файл:  " & CompName
End Sub

Добавлено через 1 час 49 минут

Сообщение от mobile

как мне кажется, намного проще создать лог-файл открытий этой книги екселя

а можно это вывести не в лог файл, а сразу в окно сообщения?

Новые блоги и статьи Все статьи Все блоги /
Ритм жизни kumehtar 27.02.2026 Иногда приходится жить в ритме, где дел становится всё больше, а вовлечения в происходящее — всё меньше. Плотный график не даёт вниманию закрепиться ни на одном событии. Утро начинается с быстрых,. . .	SDL3 для Web (WebAssembly): Сборка библиотек SDL3 и Box2D из исходников с помощью CMake и Emscripten 8Observer8 27.02.2026 Недавно вышла версия SDL 3. 4. 2 библиотеки SDL3. На странице официальной релиза доступны исходники, готовые DLL (для x86, x64, arm64), а также библиотеки для разработки под Android, MinGW и Visual. . .	SDL3 для Web (WebAssembly): Реализация движения на Box2D v3 - трение и коллизии с повёрнутыми стенами 8Observer8 20.02.2026 Содержание блога Box2D позволяет легко создать главного героя, который не проходит сквозь стены и перемещается с заданным трением о препятствия, которые можно располагать под углом, как верхнее. . .	Конвертировать закладки radiotray-ng в m3u-плейлист damix 19.02.2026 Это можно сделать скриптом для PowerShell. Использование . \СonvertRadiotrayToM3U. ps1 <path_to_bookmarks. json> Рядом с файлом bookmarks. json появится файл bookmarks. m3u с результатом. # Check if. . .
Семь CDC на одном интерфейсе: 5 U[S]ARTов, 1 CAN и 1 SSI Eddy_Em 18.02.2026 Постепенно допиливаю свою "многоинтерфейсную плату". Выглядит вот так: https:/ / www. cyberforum. ru/ blog_attachment. php?attachmentid=11617&stc=1&d=1771445347 Основана на STM32F303RBT6. На борту пять. . .	Камера Toupcam IUA500KMA Eddy_Em 12.02.2026 Т. к. у всяких "хикроботов" слишком уж мелкий пиксель, для подсмотра в ESPriF они вообще плохо годятся: уже 14 величину можно рассмотреть еле-еле лишь на экспозициях под 3 секунды (а то и больше),. . .	И ясному Солнцу zbw 12.02.2026 И ясному Солнцу, и светлой Луне. В мире покоя нет и люди не могут жить в тишине. А жить им немного лет.	«Знание-Сила» zbw 12.02.2026 «Знание-Сила» «Время-Деньги» «Деньги -Пуля»