Странное поведение Access ADP |
Dim cidworker As Integer Private Sub Class_Initialize() On Error GoTo Class_Initialize_Error сidworker = 0 SpecificationsNet On Error GoTo 0 Exit Sub Class_Initialize_Error: MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure Class_Initialize of Class Module worker" End Sub Public Property Get idworker() As Long Dim id As Variant Dim rs As ADODB.Recordset On Error GoTo idworker_Error If Nz(cidworker, 0) <= 0 Then Set rs = New ADODB.Recordset rs.Open "SELECT dbo.idworker()", db, adOpenStatic, adLockReadOnly If rs.RecordCount > 0 Then id = rs.fields(0) If IsNumeric(id) Then cidworker = CLng(id) Else cidworker = 0 End If Else cidworker = 0 End If Set rs = nothing End If If cidworker = 0 Then MsgBox "Такого компьютера нет в базе!", vbCritical, "Ошибка доступа." Quit acQuitSaveAll Else idworker = cidworker End If On Error GoTo 0 Exit Property idworker_Error: MsgBox "Error " & err.Number & " (" & err.Description & ") in get property idworker of Class Module worker" End Property Private Sub SpecificationsNet() 'http://www.sql.ru/forum/actualthread.aspx?tid=276571 Dim strComputer As String Dim objWMIService As Object, colBIOS As Object, objBIOS As Object Dim rs As ADODB.Recordset Dim sqlworker As String On Error GoTo SpecificationsNet_Error If Not CurrentProject.IsConnected Then ChangeADPConnection "COMP-1\SQLEXPRESS", "restartf" End If If CurrentProject.IsConnected Then strComputer = "." Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2") Set colBIOS = objWMIService.ExecQuery("SELECT Name, MACAddress FROM Win32_NetworkAdapter WHERE (MACAddress is not null)") For Each objBIOS In colBIOS Set rs = New ADODB.Recordset rs.Open "SELECT SQLName FROM workers WHERE (MACaddress = '" & Replace(objBIOS.MACAddress, ":", "") & "')", db, adOpenStatic, adLockReadOnly If rs.RecordCount > 0 Then sqlworker = rs.fields(0) End If rs.Close Set rs = Nothing Next If sqlworker <> "" Then ChangeADPConnection "COMP-1\SQLEXPRESS", "restartf", sqlworker, sqlworker End If 'cworker.idworker = 0 Set objWMIService = Nothing End If On Error GoTo 0 Exit Sub SpecificationsNet_Error: MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure SpecificationsNet of Class Module worker" End Sub Function ChangeADPConnection(strServerName As String, strDBName As _ String, Optional strUN As String, Optional strPW As String) As Boolean Dim strConnect As String On Error GoTo EH: Application.CurrentProject.CloseConnection 'The Provider, Data Source, and Initial Catalog arguments are required. strConnect = "Provider=SQLOLEDB.1" & _ ";Data Source=" & strServerName & _ ";Initial Catalog=" & strDBName If strUN <> "" Then strConnect = strConnect & ";user id=" & strUN If strPW <> "" Then strConnect = strConnect & ";password=" & strPW End If Else 'Try to use integrated security if no username is supplied. strConnect = strConnect & ";integrated security=SSPI" End If Application.CurrentProject.OpenConnection strConnect ChangeADPConnection = True Exit Function EH: MsgBox err.Number & ": " & err.Description, vbCritical, "Connection Error" ChangeADPConnection = False End Function
Private wworker As worker Private cdb As ADODB.Connection Public Property Get db() As ADODB.Connection On Error GoTo db_Error If cdb Is Nothing Then Set cdb = New ADODB.Connection cdb.ConnectionString = CurrentProject.Connection.ConnectionString End If If cdb.State = 0 Then cdb.Open Set db = cdb On Error GoTo 0 Exit Property db_Error: MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure db of Module pubvar" End Property Public Property Get cworker() As worker On Error GoTo cworker_Error If wworker Is Nothing Then Set wworker = New worker End If Set cworker = wworker On Error GoTo 0 Exit Property cworker_Error: MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure cworker of Module pubvar" End Property Public Function autostart() On Error GoTo autostart_Error Set wworker = Nothing Set wworker = New worker Debug.Print cworker.idworker & " - " & cworker.wtype If cworker.idworker > 0 Then If cworker.idworker >= 1 And cworker.idworker <= 3 Then If cworker.idworker <= 2 Then SendKeys "{F11}" DoCmd.OpenForm "Вводкурса", , , , , acDialog ElseIf cworker.idworker > 3 Then SendKeys "{F11}" DoCmd.OpenForm "БоссАналитика" Else MsgBox "Проблема определения типа пользователя!", vbCritical End If If cworker.idworker = 3 Then Application.SetOption "Show Hidden Objects", True Else Application.SetOption "Show Hidden Objects", False Else MsgBox "Проблема определения пользователя!", vbCritical End If On Error GoTo 0 Exit Function autostart_Error: MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure autostart of Module pubvar" End Function
Dim aspath As String Dim pathcur As String pathcur = CurrentProject.Path aspath = SysCmd(acSysCmdAccessDir) Shell """" & aspath & "msaccess.exe""" & " " & """" & pathcur & "\Склад Клиент-ver" & ver & ".adp""", vbMaximizedFocus
http://www.sql.ru/forum/1087763/strannoe-povedenie-access-adp
| Комментировать | « Пред. запись — К дневнику — След. запись » | Страницы: [1] [Новые] |