-Поиск по дневнику

Поиск сообщений в rss_sql_ru_access_programming

 -Подписка по e-mail

 

 -Постоянные читатели

 -Статистика

Статистика LiveInternet.ru: показано количество хитов и посетителей
Создан: 16.03.2006
Записей:
Комментариев:
Написано: 4


Помогите объединить в один модуль три модуля

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

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 

http://www.sql.ru/forum/1120605/pomogite-obedinit-v-odin-modul-tri-modulya


 

Добавить комментарий:
Текст комментария: смайлики

Проверка орфографии: (найти ошибки)

Прикрепить картинку:

 Переводить URL в ссылку
 Подписаться на комментарии
 Подписать картинку