Браузер таблиц и запросов базы данных
В данном разделе мы хотим привести пример браузера таблиц и запросов базы данных. В данном браузере можно так же написать самому запрос на языке SQL в объекте TextBox1. Объекты ComboBox1 и ComboBox2 предназначены для выбора имен таблиц, и выбора текста запроса по его имени. Кнопка с надписью “OK SQL” предназначена для выполнения запроса, который записан в TextBox1. Объект флажок (CheckBox1) предназначен для скрытия и показа объекта ListBox1 в котором отображается копия таблицы базы данных, загруженная в активный лист приложения Excel. Через метод RowSource объекта ListBox1 производится загрузка данных с активного листа.
Форма браузера запускается из макроса проекта, через меню приложения Excel. Браузер выводит результат запроса в активный лист приложения Excel, и, в объект ListBox1.
Рис. 28 Окно браузера базы данных
‘Модуль формы проекта
Option Explicit
Dim j As Long
Dim db As Database
Dim tbl As TableDef
Dim qry As QueryDef
Dim r As Recordset
Const ИмяКниги = "Браузер базы данных.xls"
Const ИмяБазы = "C:\Мои документы\Курсовая2\Отделы.mdb"
Private Sub CheckBox1_Click()
ListBox1.Visible = CheckBox1.Value
If CheckBox1.Value = True Then
Me.Height = Me.Height + ListBox1.Height
Else
Me.Height = Me.Height - ListBox1.Height
End If
End Sub
Private Sub ComboBox1_Click()
TextBox1.Text = ComboBox1.Text
End Sub
Private Sub ComboBox2_Change()
Dim s As String
For Each qry In db.QueryDefs
If ComboBox2.Text = qry.Name Then
TextBox1.Text = qry.Sql
Exit Sub
End If
Next
End Sub
' Ok SQL
Private Sub CommandButton1_Click()
On Error GoTo Ошибка
Set r = db.OpenRecordset(TextBox1.Text)
db.Recordsets.Refresh
Cells.Clear
'загружаем записи таблицы базы данных в активный лист Excel начиная со 2 строки
Cells(2, 1).CopyFromRecordset r
'выводим имена полей базы данных в первую строку активного листа Excel
For j = 0 To r.Fields.Count - 1
Cells(1, j + 1).Value = r.Fields(j).Name
Next j
ListBox1.ColumnCount = r.Fields.Count
ListBox1.RowSource = "A1:" + _
Cells(r.RecordCount, r.Fields.Count).Address
Exit Sub
Ошибка:
MsgBox "Ошибка выполнения запроса"
End Sub
Private Sub UserForm_Initialize()
ActiveSheet.Cells.Clear
'Устанавливаем указатель на базу данных
Set db = OpenDatabase(ИмяБазы)
'Загружаем имена таблиц и запросов
ComboBox1.Clear
For Each tbl In db.TableDefs
If Left(tbl.Name, 4) <> "MSys" And _
Left(tbl.Name, 4) <> "USys" Then
ComboBox1.AddItem tbl.Name
End If
Next
ComboBox2.Clear
For Each qry In db.QueryDefs
If InStr(qry.Name, "~") = 0 Then
ComboBox2.AddItem qry.Name
End If
Next
ListBox1.Clear
TextBox1.Text = ""
ComboBox1.Value = ""
ComboBox2.Value = ""
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Unload Me
End Sub
Private Sub UserForm_Terminate()
On Error Resume Next
r.Close
db.Close
End Sub
‘Модуль макросов проекта
Sub ЗапускБраузера()
UserForm1.Show
End Sub