Public dbPP As DataBase
Public selectedCustomer As String
Public Sub SelectFromBase_Click()
'Эта процедура открывает базу данных Access "db1"
'Из таблицы "Заказчики" выбирается набор записей с названиями организаций
'и заполняется список в окне формы. Пользователь может выбрать нужную организацию
'и данные о ней будут перенесены в поля бланка "Заказ".
'MsgBox ("реакция на выбор кнопки Выбрать")
'Определить местоположение базы данных.
'Предполагается, что она находится в том же каталоге, что и приложение.
Dim strPathDb As String
Const NameDb = "db1"
strPathDb = LocateDb(NameDb)
'Открыть базу данных и создать набор записей с названиями организаций
Dim rstCustomer As Recordset
Dim qdfOrder As QueryDef
Set dbPP = OpenDatabase(strPathDb)
Set qdfOrder = dbPP.QueryDefs("Список заказчиков")
Set rstCustomer = qdfOrder.OpenRecordset
'Открыть форму со списком заказчиков
'Заполнить список заказчиков
Do While Not rstCustomer.EOF
'Добавить организацию в список
frmCustomers.lstCustomers.AddItem rstCustomer!Название
rstCustomer.MoveNext
Loop
frmCustomers.Show
End Sub
Private Function LocateDb(ByVal NameDb As String) As String
Dim strPath As String
strPath = Application.Workbooks(1).Path
LocateDb = strPath & "\" & NameDb
End Function
Public Sub SaveToBase_Click()
'Определить местоположение базы данных.
'Предполагается, что она находится в том же каталоге, что и приложение.
Dim strPathDb As String
Const NameDb = "db1"
strPathDb = LocateDb(NameDb)
'Открыть базу данных и создать набор записей с названиями организаций
Dim rstCustomer As Recordset
Set dbPP = OpenDatabase(strPathDb)
Set rstCustomer = dbPP.OpenRecordset("Заказчики")
'Добавление новой записи
With rstCustomer
.AddNew
.Bookmark = .LastModified
!Название = Range("data2")
!Адрес = Range("data3")
!Город = Range("data4")
!Телефон = Range("data5")
!Прочее = Range("data6")
.Update
End With
End Sub
Public Sub Books_Click()
'Эта процедура открывает базу данных Access "dbPP"
'Из таблицы "Книги" выбирается набор записей
'с названиями выпущенных редакцией книг и фамилиями их авторов.
'Пользователь может выбрать нужные ему книги
'и данные о них будут перенесены в таблицу бланка "Заказ".
'Определить местоположение базы данных.
'Предполагается, что она находится в том же каталоге, что и приложение.
Dim strPathDb As String
Dim intRow As Single
Dim MyArray() As String, MyArray1() As String
Const NameDb = "db1"
strPathDb = LocateDb(NameDb)
'Открыть базу данных и создать набор записей с названиями книг
Dim rstBook As Recordset
'Временный запрос
Dim qdfOrder As QueryDef
Set dbPP = OpenDatabase(strPathDb)
Set qdfOrder = dbPP.QueryDefs("Список книг")
Set rstBook = qdfOrder.OpenRecordset
'Открыть форму со списком книг
'Заполнить список книг
'ReDim MyArray(1, 0)
'MyArray(0, 0) = "Автор"
'MyArray(1, 0) = "Название"
intRow = 1
Do While Not rstBook.EOF
'Добавить книгу в список
ReDim Preserve MyArray(2, intRow)
MyArray(0, intRow - 1) = rstBook!Автор
MyArray(1, intRow - 1) = rstBook!Название
intRow = intRow + 1
rstBook.MoveNext
Loop
frmBooks.lstBooks.Column() = MyArray
frmBooks.Show
End Sub
Private Sub ВыбериНас_Click()
Dim intLoop As Integer, intSelect As Integer
Dim ВыборСделан As Boolean
Dim KeyAuthor As String, KeyName As String
Dim strSelect As String
Dim strAdr As String, strAddress As String
Dim rstBookInfo As Recordset
Dim curField As Range
ВыборСделан = False
intLoop = 0
intSelect = 0
Do
If frmBooks.lstBooks.Selected(intLoop) Then
ВыборСделан = True
intSelect = intSelect + 1
strAdr = LTrim(Str(30 + intSelect))
KeyAuthor = frmBooks.lstBooks.Column(0, intLoop)
KeyName = frmBooks.lstBooks.Column(1, intLoop)
strSelect = "Select * FROM [Книги] WHERE [Название] =""" & KeyName & """"
Set rstBookInfo = dbPP.OpenRecordset(strSelect)
strAddress = "G" & strAdr
Set curField = Range(strAddress)
curField = rstBookInfo!Название
strAddress = "E" & strAdr
Set curField = Range(strAddress)
curField = rstBookInfo!Автор
strAddress = "K" & strAdr
Set curField = Range(strAddress)
curField = rstBookInfo![Единица измерения]
strAddress = "L" & strAdr
Set curField = Range(strAddress)
curField = rstBookInfo!Цена
strAddress = "D" & strAdr
Set curField = Range(strAddress)
curField = intSelect
End If
intLoop = intLoop + 1
Loop Until intLoop = frmBooks.lstBooks.ListCount
If ВыборСделан Then
Unload Me
Else
MsgBox ("Выберите книги")
End If
End Sub
Private Sub ВыбериМеня_Click()
Dim intLoop As Integer
Dim ВыборСделан As Boolean
Dim Key As String, strSelect As String
Dim rstCustInfo As Recordset
Dim curField As Range
ВыборСделан = False
intLoop = 0
Do
If frmCustomers.lstCustomers.Selected(intLoop) Then
ВыборСделан = True
Exit Do
End If
intLoop = intLoop + 1
Loop Until intLoop = frmCustomers.lstCustomers.ListCount
If ВыборСделан Then
Key = frmCustomers.lstCustomers.List(intLoop)
strSelect = "Select * FROM [Заказчики] WHERE [Название] =""" & Key & """"
Set rstCustInfo = dbPP.OpenRecordset(strSelect)
'rstCustInfo.MoveFirst
'rstCustInfo.FindFirst "[Название]=Key"
'WHERE Заказчики!Организация = Key")
Set curField = Range("data2")
curField = rstCustInfo!Название
Set curField = Range("data3")
curField = rstCustInfo!Адрес
Set curField = Range("data4")
curField = rstCustInfo!Город
Set curField = Range("data5")
curField = rstCustInfo!Телефон
Set curField = Range("data6")
curField = rstCustInfo!Прочее
Unload Me
Else
MsgBox ("Выберите Заказчика")
End If
End Sub
Уважаемый посетитель!
Чтобы распечатать файл, скачайте его (в формате Word).
Ссылка на скачивание - внизу страницы.