Создать собственный класс, где будет ссылка на единственное открытое соединение.
При запуске программы создавать экземпляр этого класса и хранить в глобальной переменной.
Все действия с по извлечению и сохранению данных производить через методы этого класса.
Вот пример реализации такого класса:
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.
Option Explicit
Private cn As ADODB.Connection
Private Sub Class_Initialize()
Dim rs As ADODB.Recordset
On Error Resume Next
Set cn = New ADODB.Connection
cn.CursorLocation = adUseClient
cn.Open "driver={Microsoft access driver (*.mdb)};Extended Properties=""DBQ=" & App.Path & "\MyDB.mdb;DriverId=25;FIL=MS Access;MaxBufferSize=2048;PageTimeout=5;"""
If cn.State = adStateClosed Then cn.Open "FILE NAME=" & App.Path & "\MyDB.udl"
End Sub
Private Sub Class_Terminate()
On Error Resume Next
cn.Close
Set cn = Nothing
End Sub
Public Sub ExecCommand(cmd As String)
On Error GoTo ErrorHandler
cn.Execute cmd
Exit Sub
ErrorHandler:
MsgBox Err.Description, vbCritical, "Êðèòè÷åñêàÿ îøèáêà"
End Sub
Private Function GetRecordset(cmd As String) As ADODB.Recordset
Dim rs As ADODB.Recordset
On Error GoTo ErrorHandler
Set rs = New ADODB.Recordset
rs.Open cmd, cn, adOpenStatic, adLockBatchOptimistic
Set GetRecordset = rs
Set rs = Nothing
Exit Function
ErrorHandler:
MsgBox Err.Description, vbCritical, "Êðèòè÷åñêàÿ îøèáêà"
Debug.Print Err.Number
End Function
Public Sub UpdateRS(rs2upd As ADODB.Recordset)
Dim ap
Dim rs As ADODB.Recordset
Set rs = rs2upd.Clone
On Error Resume Next
ap = rs.AbsolutePosition
rs.MoveFirst
While Not rs.EOF
If IsNull(rs!AddEmployeeID) Then
rs!AddEmployeeID = CurEmployeeID
rs!AddTime = Now
End If
rs!UpdateEmployeeID = CurEmployeeID
rs!LastUpdate = Now
rs.MoveNext
Wend
rs.MoveFirst
On Error GoTo ErrorHandler
rs.UpdateBatch
If ap > 0 Then rs.AbsolutePosition = ap
Exit Sub
ErrorHandler:
If Err.Number = - 2147217873 Then
Err.Raise Err.Number
Else
MsgBox Err.Description, vbCritical, "Êðèòè÷åñêàÿ îøèáêà"
End If
End Sub
Public Function GetColumns4Class(ClassId As GridClassesEnum) As ADODB.Recordset
Set GetColumns4Class = GetRecordset("select * from refcolumns where ClassID= " & ClassId & " order by [Order]")
End Function
Public Sub GetOwnerCtlg(OwnerCtlgID As Long, rsOwnerCtlg As ADODB.Recordset, rsOrdersList As ADODB.Recordset, rsStudents As ADODB.Recordset)
Set rsOwnerCtlg = GetRecordset("Select OwnerCtlgID, Name_RU, Name_EN, RefID, Start, Finish, IsClosed, Flag from tblOwnerCtlg where OwnerCtlgID = " & OwnerCtlgID)
Set rsOrdersList = GetRecordset("Select * from cvGetOrdersList where OwnerCtlgID = " & OwnerCtlgID)
Set rsStudents = GetRecordset("select * from cvGroupStudents where OwnerCtlgID = " & OwnerCtlgID)
If OwnerCtlgID = 0 Then rsOwnerCtlg.AddNew
End Sub
