Помогите объединить в один модуль три модуля |
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
Комментировать | « Пред. запись — К дневнику — След. запись » | Страницы: [1] [Новые] |