---

Выбор темы Это МЕНЮ можно потаскать Моя почта

• Базы данных

  ---

Быстрый поиск в базе данных

Быстрый способ определения полей нулевой длины в базе данных

Вариант решения проблемы NULL (1)

Как вводить данные через MSFlexGrid

Как взять информацию из базы данных VB и поместить её в таблицу Excel

Как добавить новую таблицу в Access

Как закрыть все открытые рекордсеты

Как переименовать таблицу в Access

Как получать и обновлять текстовые поля в SQL Server при помощи ADO

Как при помощи ADO загрузить данные в FlexGrid

Как создавать и удалять DSN в Visual Basic

Как создать базу данных MsAccess

Как создать пустую базу данных

Как удалить все записи в таблице

Как установить пароль на базу данных

Как установить пароль на базу данных Access

Копируем данные из таблицы Excel в базу данных Access

Пример создания базы данных кодом

Программное сжатие базы данных

Получаем список установленных DSN / Драйверов

Создание базы данных (*.mdb)

Сохранение файла в БД и получение его обратно из БД

Поиск в DBCombo по первым введенным буквам

Как получить значения поля "автономер" поcле апдейта записи

Как избавится от Null при получении оного из базы данных (2)

• Быстрый поиск в базе данных

Visual Basic не имеет процедуры наподобие функции DLookUp в Access. Следующую функцию можно использовать в VB для получения имени (Name) объекта по ID:

Public Function MyDLookUp(Column As _
String, TableName As String, _
Condition As String) As Variant
Dim Rec As Recordset
On Error GoTo MyDlookUp_Err

' gCurBase это глобальная переменная, хранящая
' текущую открытую базу данных
Set Rec = gCurBase.OpenRecordset_
("Select * From " & TableName)
Rec.FindFirst Condition
If Not Rec.NoMatch Then
' возвращает запрошенное поле, удовлетворяющее запросу
MyDLookUp = Rec(Column)
Exit Function
End If

' если нет совпадений, то возвращает -1, либо другую ошибку
MyDlookUp_Err:
MyDLookUp = -1
End Function

• Быстрый способ определения полей нулевой длины в базе данных

Приведённый здесь синтакс работает быстрее, чем конструкция If.Then.Else. Для строк:

Dim sVar As String
.
sVar = "" & ds!sField

Для чисел:

Dim nVar As Integer
.
nVar = 0 & ds!nField

В этих двух примерах sField и nField это два поля.

• Вариант решения проблемы NULL (1)

Для этих целей пользуюйтесь маленькой функцией, помещенной где-нибудь в модуле:

Public Function CheckNull(sCheck as String) as String
If IsNul(sCheck) Then
CheckNull = Empty
Else
CheckNull=Trim$(sCheck)
End If
End Function

• Как вводить данные через MSFlexGrid

MSFlexGrid можно использовать для ввода данных не прибегая к использованию
дополнительных элементов управления ActiveX.
Для этого используются события KeyPress и KeyUp.
Чтобы использовать MSFlexGrid для ввода данных,
добавьте на форму грид с именем FlxGrdDemo и следующий код:

Private Sub FlxGrdDemo_KeyPress(KeyAscii As Integer)
Select Case KeyAscii
Case vbKeyReturn
' Когда пользователь нажимает Enter
' то курсор перепрыгивает на следующую
' ячейку или строку.
With FlxGrdDemo
If .Col + 1 <= .Cols - 1 Then
.Col = .Col + 1
ElseIf .Row + 1 <= .Rows - 1 Then
.Row = .Row + 1
.Col = 0
Else
.Row = 1
.Col = 0
End If
End With
Case vbKeyBack
' Удаляем предыдущий символ при
' нажатии клавиши backspace.
With FlxGrdDemo
If Trim(.Text) <> "" Then _
.Text = Mid(.Text, 1, Len(.Text) - 1)
End With
Case Is < 32
' Избегаем непечатаемых символов.
Case Else 'Иначе печатаем всё остальное
With FlxGrdDemo
.Text = .Text & Chr(KeyAscii)
End With
End Select
End Sub
Private Sub FlxGrdDemo_KeyUp(KeyCode As _
Integer, Shift As Integer)
Select Case KeyCode
' Copy
Case vbKeyC And Shift = 2 ' Control + C
Clipboard.Clear
Clipboard.SetText FlxGrdDemo.Text
KeyCode = 0
' Paste
Case vbKeyV And Shift = 2 'Control + V
FlxGrdDemo.Text = Clipboard.GetText
KeyCode = 0
' Cut
Case vbKeyX And Shift = 2 'Control + X
Clipboard.Clear
Clipboard.SetText FlxGrdDemo.Text
FlxGrdDemo.Text = ""
KeyCode = 0
' Delete
Case vbKeyDelete
FlxGrdDemo.Text = ""
End Select
End Sub

Вы можете установить свойство FillStyle в FlexFillRepeat,
которое позволяет применять изменеия для всех выделенных ячеек.

• Как взять информацию из базы данных VB и поместить её в таблицу Excel

Private Sub Excel_Spreadsheet(rst As Recordset)

'Declare all Excel objects

Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlWS As Excel.Worksheet

Set xlApp = New Excel.Application
Set XLWB = xlApp.Workbooks.Add
Set xlWS = xlWB.Worksheets.Add

'Fill cells using recordset
xlWS.Cells(1,1).Value = rst("Field1")
xlWS.Cells(2,1).Value = rst("Field2")

' save spreadsheet
xlWS.SaveAS "mysheet.xls"
xlApp.Quit

' Free memory
Set xlWS = Nothing
Set xlWB = Nothing
Set xlApp = Nothing

End Sub

• Как добавить новую таблицу в Access

Public Function CreateTable(DatabaseName As String, ByVal TableName As String) As Boolean

'DataBaseName - имя и путь файла базы
'TableName имя таблицы, которую Вы хотите создать
'В случае успеха, возвращает true, иначе false

'Проект должен иметь ссылку на DAO

On Error GoTo errorhandler
Dim oDB As DAO.Database
Dim td As DAO.TableDef
Dim f As DAO.Field

Set oDB = Workspaces(0).OpenDatabase(DatabaseName)
On Error GoTo errorhandler
If TableExists(oDB, TableName) Then GoTo errorhandler
'Создаём объект таблицы
Set td = oDB.CreateTableDef(TableName)

'Необходимо добавить поле
'Добавляем поле ID

Set f = td.CreateField("ID", dbLong)
f.Attributes = dbAutoIncrField

'Присоединяем поле к таблице
td.Fields.Append f

'Добавляем таблицу к базе данных
oDB.TableDefs.Append td

oDB.Close
CreateTable = True
Exit Function
errorhandler:
If Not oDB Is Nothing Then oDB.Close
Set td = Nothing
Set f = Nothing

End Function

Private Function TableExists(oDB As Database, TableName As String) As Boolean

Dim td As DAO.TableDef
On Error Resume Next

Set td = oDB.TableDefs(TableName)
TableExists = Err.Number = 0

End Function

• Как закрыть все открытые рекордсеты

Если вы используете базу данных в ваше приложении (базы DAO, RDO, или ADO),
вы должны быть уверены, что закроете все открытые рекордсеты, базы перед тем,
как выйдете из программы. Иначе память может не освободиться.

Вот небольшой код, который вы можете добавить в событие Form_Unload,
который закроет все базы, рекордсеты и освободит занимаемую ими память.
Этот код будет работать, даже если у вас 1, 100 или вообще нет соединений,
когда вы попытаетесь выйти из программы.

Private Sub Form_Unload(Cancel As Integer)

On Error Resume Next

Dim ws As Workspace
Dim db As Database
Dim rs As Recordset
'
For Each ws In Workspaces
For Each db In ws.Databases
For Each rs In db.Recordsets
rs.Close
Set rs = Nothing
Next
db.Close
Set db = Nothing
Next
ws.Close
Set ws = Nothing
Next

• Как переименовать таблицу в Access

Public Function RenameTable(DatabaseName As String, _
ByVal OldTableName As String, _
ByVal NewTableName As String) As Boolean

'DataBaseName имя и путь файла базы данных
'OldTableName имя таблицы, которую Вы хотите переименовать
'NewTableName новое имя таблицы
'В случае успеха, возвращает true, иначе false

'Проект должен иметь ссылку на DAO

On Error GoTo errorhandler
Dim oDB As DAO.Database
Dim td As DAO.TableDef

Set oDB = Workspaces(0).OpenDatabase(DatabaseName)
On Error GoTo errorhandler
If Not TableExists(oDB, OldTableName) Then GoTo errorhandler
If TableExists(oDB, NewTableName) Then GoTo errorhandler
'Создаём объект таблицы
Set td = oDB.TableDefs(OldTableName)
td.Name = NewTableName
oDB.TableDefs.Refresh
oDB.Close
RenameTable = True
Exit Function

errorhandler:
If Not oDB Is Nothing Then oDB.Close
Set td = Nothing

End Function

• Как получать и обновлять текстовые поля в SQL Server при помощи ADO

В этой статье описывается механизм получения и изменения больших текстовых полей (Binary Large Objects/BLOBS) с использованием ActiveX Data Objects (ADO). Делается это с участием методов GetChunk и AppendChunk в поле RecordSet объекта ADODB.

Пошаговое создание приложения

1) Открываем новый проект. Form1 создаётся автоматически.

2) В меню Project кликните References, и выберите Microsoft ActiveX Data Objects Library.

3) Добавьте новый стандартный модуль в Ваш проект, и поместите в него следующий код:

Global cn As ADODB.Connection
Global cmd1 As ADODB.Command
Global rsset As ADODB.Recordset

Const BLOCKSIZE As Long = 4096

Public Sub ColumnToFile(Col As ADODB.Field, DiskFile As String)
'Получаем данные из базы данных и помещаем их во временный файл
'на жёстком диске.
'Размер блока определён в переменной BLOCKSIZE (4096).

Dim NumBlocks As Long 'Количество блоков.
Dim LeftOver As Long '# символов оставшихся после последнего целого блока.
Dim strData As String
Dim DestFileNum As Long
Dim I As Long
Dim ColSize As Long

'Убеждаемся, что мы не в пустой записи (recordset).
If Not rsset.EOF And Not rsset.BOF Then
ColSize = Col.ActualSize

'Если filelength > 0, то файл существует.
' Очищаем его содержимое.
If Len(Dir$(DiskFile)) > 0 Then
Kill DiskFile
End If

DestFileNum = FreeFile
Open DiskFile For Binary As DestFileNum
NumBlocks = ColSize \ BLOCKSIZE
LeftOver = ColSize Mod BLOCKSIZE

'Теперь записываем данные в файл блоками.
For I = 1 To NumBlocks
strData = String(BLOCKSIZE, 0)
strData = Col.GetChunk(BLOCKSIZE)
Put DestFileNum, , strData
Next I
strData = String(LeftOver, 0)
strData = Col.GetChunk(LeftOver)
Put DestFileNum, , strData

Close DestFileNum
End If
End Sub

Sub FileToColumn(Col As ADODB.Field, DiskFile As String)
'Берём данные из временного файла и записываем их в базу данных.

Dim strData As String
Dim NumBlocks As Long
Dim FileLength As Long
Dim LeftOver As Long
Dim SourceFile As Long
Dim I As Long

SourceFile = FreeFile
Open DiskFile For Binary Access Read As SourceFile
FileLength = LOF(SourceFile)
If FileLength = 0 Then
Close SourceFile
MsgBox DiskFile & " Empty or Not Found."
Else
NumBlocks = FileLength \ BLOCKSIZE
LeftOver = FileLength Mod BLOCKSIZE
Col.AppendChunk Null
strData = String(BLOCKSIZE, 0)
For I = 1 To NumBlocks
Get SourceFile, , strData
Col.AppendChunk strData
Next I
strData = String(LeftOver, 0)
Get SourceFile, , strData
Col.AppendChunk strData
rsset.Update
Close SourceFile
End If
End Sub

Public Sub FileToForm(DiskFile As String, SomeControl As Control)
'Получаем данные из временного файла и помещаем их в контрол.

Dim SourceFile As Long
Dim FileLength As Long
Dim strData As String

SourceFile = FreeFile
Open DiskFile For Binary Access Read As SourceFile
FileLength = LOF(SourceFile)
If FileLength = 0 Then
Close SourceFile
MsgBox DiskFile & " Empty or Not Found."
Else
strData = String(FileLength, 0)
Get SourceFile, , strData
SomeControl.Text = strData
Close SourceFile
End If
End Sub

Sub FormToFile(DiskFile As String, SomeControl As Control)
'Сохраняем данные из формы во временный файл на диске.

Dim DestinationFile As Long
Dim FileLength As Long
Dim strData As String

If Len(Dir$(DiskFile)) > 0 Then
Kill DiskFile
End If
DestinationFile = FreeFile
Open DiskFile For Binary As DestinationFile
strData = SomeControl.Text
Put DestinationFile, , strData
Close DestinationFile
End Sub

4) Подготовим форму Form1:

• Добавьте элемент управления RichTextBox, и установите его свойство Name в "rtbText."
• Добавьте элемент управления CommandButton, и установите его свойство Name в "cmdPrev", а свойство Caption в "Prev."
• Добавьте элемент управления CommandButton, и установите его свойство Name в "cmdNext", а свойство Caption в "Next."
• Добавьте элемент управления CommandButton, и установите его свойство Name в "cmdSave", а свойство Caption в "Update."

5) Вставьте следующий код в форму:

Option Explicit

Dim DiskFile As String

Private Sub cmdNext_Click()
If (rsset.RecordCount > 0) And (Not rsset.EOF) Then
rsset.MoveNext
If Not rsset.EOF Then
rtbText.Text = ""
ColumnToFile rsset.Fields("pr_info"), DiskFile
FileToForm DiskFile, rtbText
Else
rsset.MoveLast
End If
End If
End Sub

Private Sub cmdPrev_Click()
If (rsset.RecordCount > 0) And (Not rsset.BOF) Then
rsset.MovePrevious
If Not rsset.BOF Then
rtbText.Text = ""
ColumnToFile rsset.Fields("pr_info"), DiskFile
FileToForm DiskFile, rtbText
Else
rsset.MoveFirst
End If
End If
End Sub

Private Sub cmdSave_Click()
FormToFile DiskFile, rtbText
FileToColumn rsset.Fields("pr_info"), DiskFile
End Sub

Private Sub Form_Activate()
rtbText.Text = ""
If rsset.RecordCount > 0 Then
rsset.MoveFirst
ColumnToFile rsset.Fields("pr_info"), DiskFile
FileToForm DiskFile, rtbText
End If
End Sub

Private Sub Form_Load()

Dim ConnectString As String
Dim anerror As ADODB.Error
Dim Sql As String

On Error GoTo handler

DiskFile = App.Path & "\BLOB.txt"

'Устанавите строку коннекта на Ваш SQL server.
ConnectString = _
"Driver={SQL SERVER};Server=<yourserver>;Database=pubs;UID=sa;pwd=;"
Sql = "SELECT pr_info FROM pub_info;"
Set cn = New ADODB.Connection
cn.ConnectionString = ConnectString
cn.Open
Set rsset = New ADODB.Recordset
rsset.Open Sql, cn, adOpenKeyset, adLockOptimistic, adCmdText
Exit Sub

handler:
For Each anerror In cn.Errors
Debug.Print anerror.Number & ": " & anerror.Description & _
" - " & anerror.SQLState
Next anerror
End Sub

6) Измените ServerName в connectstring на имя Вашего сервера.

7) Запустите проект. RichTextBox будет содержать первую запись из базы данных.

8) Кликните Next . В RichTextBox появится следующая запись. Кнопка Next вызывает метод MoveNext, а затем методы ColumnToFile и FileToForm.

9) Кликните Prev . В RichTextBox появится предыдущая запись. Кнопка Prev вызывает метод MovePrevious, а затем методы ColumnToFile и FileToForm.

10) Наберите какой-нибудь текст в текстовом поле и нажмите Update - содержимое текстового поля запишется в текущую запись. Кнопка Update вызывает методы FormToFile и FileToColumn, который в свою очередь вызывают метод Update.

• Как при помощи ADO загрузить данные в FlexGrid

Private Sub Form_Load()
Dim db_file As String
Dim statement As String
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim c As Integer
Dim r As Integer
Dim col_wid() As Single
Dim field_wid As Single

' Получаем данные.
db_file = App.Path
If Right$(db_file, 1) <> "\" Then db_file = db_file & _
"\"
db_file = db_file & "books.mdb"

' Открываем соединение.
Set conn = New ADODB.Connection
conn.ConnectionString = _
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & db_file & ";" & _
"Persist Security Info=False"
conn.Open

' Выбираем данные.
statement = "SELECT * FROM Books ORDER BY Title"

' Получаем записи.
Set rs = conn.Execute(statement, , adCmdText)

' Фиксируем одну строку и не фиксируем колонки.
MSFlexGrid1.Rows = 2
MSFlexGrid1.FixedRows = 1
MSFlexGrid1.FixedCols = 0

' Отображаем заголовки колонок.
MSFlexGrid1.Rows = 1
MSFlexGrid1.Cols = rs.Fields.Count
ReDim col_wid(0 To rs.Fields.Count - 1)
For c = 0 To rs.Fields.Count - 1
MSFlexGrid1.TextMatrix(0, c) = rs.Fields(c).Name
col_wid(c) = TextWidth(rs.Fields(c).Name)
Next c

' Отображаем значения для каждой строки.
r = 1
Do While Not rs.EOF
MSFlexGrid1.Rows = MSFlexGrid1.Rows + 1
For c = 0 To rs.Fields.Count - 1
MSFlexGrid1.TextMatrix(r, c) = _
rs.Fields(c).Value

' Смотрим, насколько велико значение.
field_wid = TextWidth(rs.Fields(c).Value)
If col_wid(c) < field_wid Then col_wid(c) = _
field_wid
Next c

rs.MoveNext
r = r + 1
Loop

' Закрываем записи и соединение.
rs.Close
conn.Close

' Устанавливаем ширину колонок.
For c = 0 To MSFlexGrid1.Cols - 1
MSFlexGrid1.ColWidth(c) = col_wid(c) + 240
Next c
End Sub

• Как создавать и удалять DSN в Visual Basic

В данной статье демонстрируется динамическое создание и удаление Data Source Name (DSN) на лету, при помощи API функции SQLConfigDataSource.

Пример создания приложения

1) Создайте новый проект.

2) В закладке Advanced диалогового окошка Options в меню Tools установите Conditional Compilation Argument с именем WIN32 в 1 если Вы используете Visual Basic 4.0 32-bit, либо в 0 если Visual Basic 4.0 16-bit.

3) Добавьте две кнопки на форму.

4) Добавьте следующий код в General Declarations:

Option Explicit

'Объявление констант
Private Const ODBC_ADD_DSN = 1 ' Добавляем источник данных
Private Const ODBC_CONFIG_DSN = 2 ' Настраиваем источник данных
Private Const ODBC_REMOVE_DSN = 3 ' Удаляем источник данных
Private Const vbAPINull As Long = 0&amp; ' NULL указатель

'Объявление функции
#If WIN32 Then

Private Declare Function SQLConfigDataSource Lib "ODBCCP32.DLL" _
(ByVal hwndParent As Long, ByVal fRequest As Long, _
ByVal lpszDriver As String, ByVal lpszAttributes As String) _
As Long
#Else
Private Declare Function SQLConfigDataSource Lib "ODBCINST.DLL" _
(ByVal hwndParent As Integer, ByVal fRequest As Integer, ByVal _
lpszDriver As String, ByVal lpszAttributes As String) As Integer
#End If

5) Добавьте следующий код в событие Click кнопки Command1:

#If WIN32 Then
Dim intRet As Long
#Else
Dim intRet As Integer
#End If
Dim strDriver As String
Dim strAttributes As String

'Устанавливаем драйвер на SQL Server.
strDriver = "SQL Server"
'Устанавливаем атрибуты, разделённые нулями (null).
strAttributes = "SERVER=SomeServer" & Chr$(0)
strAttributes = strAttributes & "DESCRIPTION=Temp DSN" & Chr$(0)
strAttributes = strAttributes & "DSN=DSN_TEMP" & Chr$(0)
strAttributes = strAttributes & "DATABASE=pubs" & Chr$(0)
'Чтобы показать диалог, используем Form1.Hwnd вместо vbAPINull.
intRet = SQLConfigDataSource(vbAPINull, ODBC_ADD_DSN, _
strDriver, strAttributes)
If intRet Then
MsgBox "DSN Created"
Else
MsgBox "Create Failed"
End If

6) Добавьте следующий код в событие Click кнопки Command2:

#If WIN32 Then
Dim intRet As Long
#Else
Dim intRet As Integer
#End If
Dim strDriver As String
Dim strAttributes As String

'Устанавливаем драйвер на SQL Server.
strDriver = "SQL Server"
'Устанавливаем атрибуты, разделённые нулями (null).
strAttributes = "DSN=DSN_TEMP" & Chr$(0)
'Чтобы показать диалог, используем Form1.Hwnd вместо vbAPINull.
intRet = SQLConfigDataSource(vbAPINull, ODBC_REMOVE_DSN, _
strDriver, strAttributes)
If intRet Then
MsgBox "DSN Deleted"
Else
MsgBox "Delete Failed"
End If

7) Запустите проект.

8) Если кликнуть на Command1, то добавится DSN с именем DSN_TEMP.

9) Если кликнуть на Command2, то удалится DSN с именем DSN_TEMP.

• Как создать базу данных MsAccess

Для этого добавьте ссылку в библиотеку Microsoft DAO _._ Object Library
(я использую версию 3.6 для нижеприведённого кода), и добавьте следующий код.

Public Sub CreateDB(ByVal pDatabaseUNC As String)
Dim ws As Workspace
Dim db As Database

On Error GoTo Routine_Error

' Создать базу данных с указанным именем
Set ws = DBEngine.Workspaces(0) 'Default Workspace
Set db = ws.CreateDatabase(pDatabaseUNC, dbLangGeneral)

' Добавить новую таблицу во вновь созданную базу
CreateTable db, “Some Table”

Routine_Error:
Set db = Nothing
Set ws = Nothing
If Err.Number <> 0 Then Err.Raise Err.Number, Err.Source, Err.Description
End Sub

Public Sub CreateTable(ByRef pDB As Database, ByVal pTableName As String)
Dim tbl As TableDef
Dim fld As Field

On Error GoTo Routine_Error

' Создаём таблицу с указанным именем в базе
Set tbl = pDB.CreateTableDef(pTableName)

With tbl
' Добавляем поля
Set fld = .CreateField(“Some Field”, dbText, 10)
.Fields.Append fld
Set fld = .CreateField(“Some Other Field”, dbText, 20)
.Fields.Append fld
End With

' Добавляем таблицу к базе данных
pDB.TableDefs.Append tbl

Routine_Error:
Set fld = Nothing
Set tbl = Nothing
If Err.Number <> 0 Then Err.Raise Err.Number, Err.Source, Err.Description
End Sub

• Как создать пустую базу данных

Sub CreateDB(sDBPath As String)
Dim tdExample As TableDef
Dim fldForeName As Field
Dim fldSurname As Field
Dim fldDOB As Field
Dim fldFurtherDetails As Field
Dim dbDatabase As Database
Dim sNewDBPathAndName As String

sNewDBPathAndName = sDBPath
Set dbDatabase = CreateDatabase(sNewDBPathAndName, dbLangGeneral, dbEncrypt)

Set tdExample = dbDatabase.CreateTableDef("Example")

Set fldForeName = tdExample.CreateField("Fore_Name", dbText, 20)
Set fldSurname = tdExample.CreateField("Surname", dbText, 20)
Set fldDOB = tdExample.CreateField("DOB", dbDate)
Set fldFurtherDetails = tdExample.CreateField("Further_Details", dbMemo)

tdExample.Fields.Append fldForeName
tdExample.Fields.Append fldSurname
tdExample.Fields.Append fldDOB
tdExample.Fields.Append fldFurtherDetails

dbDatabase.TableDefs.Append tdExample
MsgBox "New .MDB Created - '" & sNewDBPathAndName & "'", vbInformation
End Sub

• Как удалить все записи в таблице

Если у Вас уже есть глобальная переменная, связанная с открытой базой данных,
то можно воспользоваться следующей функцией для удаления всех записей в
таблице ( DB это объект базы данных ):

Function ZapTable(sTable As String, _
Optional sWhere As String = "") As Integer
Dim sSQL As String
On Error GoTo Err_ZapRecs
' For Access Apps only:
' docmd.SetWarnings False
sSQL = "DELETE * FROM " & sTable & " "
If sWhere <> "" Then
sSQL = sSQL & "WHERE " & sWhere
End If
DB.Execute sSQL, dbFailOnError
'docmd.SetWarnings True
ZapTable = True
Exit_ZapRecs:
Exit Function
Err_ZapRecs:
ZapTable = False
''ERROR HANDLING IF DESIRED
Resume Exit_ZapRecs
End Function

А вот так эта функция вызывается:

If Not ZapTable("locLookup") Then
MsgBox "Cannot delete Table."
End If

Или:

If Not ZapTable("locCities", "STATE = 'NY'") Then
MsgBox "Cannot delete Table."
End If

• Как установить пароль на базу данных

Jet 3.0 (в 32-битном VB4) включает в себя новую систему безопасности,
основанную на паролях базы данных. Эта система позволяет устанавливать единственный,
многопользовательский пароль для открытия базы данных.

Установка пароля в VB делается при помощи метода NewPassword объекта базы данных.
Ниже представлен пример того, как это делается:

Dim wrk As Workspace
Dim dbPwd As Database

Set wrk = DBEngine.Workspaces(0)

' Необходимо открыть базу данных в эксклюзивном режиме (второй параметр).
Set dbPwd = _
wrk.OpenDatabase_
("MyData.MDB", True)

' Устанавливаем текущий пустой пароль в "NewPass".
dbPwd.NewPassword "","NewPass"

• Как установить пароль на базу данных Access

Public Function SetDatabasePassword(DBPath As String, _
newPassword As String) As Boolean

'Применение: Защищает базу данных паролем, если она до этого
'не имела пароля

'Параметры: sDBPath: Полный путь к базе данных Access
'newPassword: пароль
'В случае успеха, возвращает true, иначе false

If Dir(DBPath) = "" Then Exit Function

Dim db As DAO.Database

On Error Resume Next
Set db = OpenDatabase(DBPath, True)
If Err.Number <> 0 Then Exit Function
db.newPassword "", newPassword
SetDatabasePassword = Err.Number = 0
db.Close

End Function

• Копируем данные из таблицы Excel в базу данных Access

Используем Excel как сервер, открываем таблицу.
Следующий код используется для поиска количества используемых строк и колонок.

max_row = excel_sheet.UsedRange.Rows.Count
max_col = excel_sheet.UsedRange.Columns.Count

Для открытия базы данных используем ADO.

Для каждой строки таблицы Excel в цикле составляем инструкцию SQL INSERT.
Для выполнения инструкции и создания записи используем объект ADO Connection.

Private Sub cmdLoad_Click()
Dim excel_app As Object
Dim excel_sheet As Object
Dim max_row As Integer
Dim max_col As Integer
Dim row As Integer
Dim col As Integer
Dim conn As ADODB.Connection
Dim statement As String
Dim new_value As String

Screen.MousePointer = vbHourglass
DoEvents

' Создаём приложение Excel.
Set excel_app = CreateObject("Excel.Application")

' Если хотите, чтобы Excel был видимым, то раскомментируйте следующую строку.
' excel_app.Visible = True

' Открываем таблицу Excel.
excel_app.Workbooks.Open FileName:=txtExcelFile.Text

' Проверяем версию.
If Val(excel_app.Application.Version) >= 8 Then
Set excel_sheet = excel_app.ActiveSheet
Else
Set excel_sheet = excel_app
End If

' Узнаём строку и колонку, которые использовались последний раз.
max_row = excel_sheet.UsedRange.Rows.Count
max_col = excel_sheet.UsedRange.Columns.Count

' Открываем базу данных Access.
Set conn = New ADODB.Connection
conn.ConnectionString = _
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & txtAccessFile.Text & ";" & _
"Persist Security Info=False"
conn.Open

' Делаем цикл по строкам таблицы Excel,
' пропуская первую строку, которая содержит
' заголовки колонок.
For row = 2 To max_row
' Составляем инструкцию INSERT.
statement = "INSERT INTO Books VALUES ("
For col = 1 To max_col
If col > 1 Then statement = statement & ","
new_value = Trim$(excel_sheet.Cells(row, _
col).Value)
If IsNumeric(new_value) Then
statement = statement & _
new_value
Else
statement = statement & _
"'" & _
new_value & _
"'"
End If
Next col
statement = statement & ")"

' Выполняем инструкцию INSERT.
conn.Execute statement, , adCmdText
Next row

' Закрываем базу данных.
conn.Close
Set conn = Nothing

' Если хотите, чтобы Excel остался запущенным, закомментируйте строки
' Close и Quit.

' Закрываем Книгу, сохраняя изменения.
excel_app.ActiveWorkbook.Close True
excel_app.Quit

Set excel_sheet = Nothing
Set excel_app = Nothing

Screen.MousePointer = vbDefault
MsgBox "Copied " & Format$(max_row - 1) & " values."
End Sub

• Пример создания базы данных кодом

Для начала вам необходимо подключить (меню Project->References) Microsoft DAO 2.5/3.51 Compatibility Library

Вставьте следующий код, запустите проект. Если вы еще не сохранили проект, то база создаться в папке, куда вы проинсталировали VB (по умолчанию - C:\Program Files\Microsoft Visual Studio\VB98).

Private Sub Form_Load()
Dim dbFile As String
' Проверяет наличие файла, имеющего имя, которое будет присвоено новой базе данных. Если есть такая база, то новая база не создается, если нет то вызывается функция и база создается.
If Dir(App.Path & "\kadrs.Mdb") <> "" Then
dbFile = App.Path & "\kadrs.Mdb"
Else:
dbFile = dbgreit()
End If
End Sub
Public Function dbgreit()
Dim dbkadr As Database, NewWs As Workspace 'Описание БД и рабочей области
Dim dbOpts As Long, dbName As String, tbWorker As TableDef
Dim tbFam As TableDef, Rel1 As Relation ' Описание таблицы и отношения
Dim Ind1, Ind2, Ind3, Ind4, Ind5 As Index'Описание индексов
Dim Fin, Fr, Fin2, Fin3, Fr2, Fin4, Fr3, Fin5, Fr4 As Field
Dim Fin6, Fr5, Fin7, Fr6, Fin8, Fr7, Frel As Field
Dim Ind9 As Index, Fs1, Fs2 As Field
ReDim F(1 To 54) As Field ' Описание полей табл. Worker
ReDim P(1 To 10) As Field ' Описание полей табл. Family
' Строковая переменная, указывающая на файл БД находящийся по тому же пути, что и файл программы.
dbName = App.Path & "\kadrs.Mdb"
Set NewWs = DBEngine.Workspaces(0)' Создание рабочей области
dbOpts = dbVersion35 + dnEncrypt ' Параметры БД - версия Jet-машины 3,5 и кодирование.
Set dbkadr = NewWs.CreateDatabase(dbName, dbLangCyrillic, dbOpts) ' Создание рускоязычной БД
' добавление таблицы с именем Worker в БД
Set tbWorker = dbkadr.CreateTableDef("Worker")
' добавление таблицы с именем Family в БД
Set tbFam = dbkadr.CreateTableDef("Family")
' Создание и описание счетчика с именем Код (табл. Worker)
Set Fin = tbWorker.CreateField("Код", dbLong) ' Создание поля в таблице с именем Код
Set Frel = tbWorker.CreateField("Number", dbLong) ' Создаем в таблице поле связи
Fin.Attributes = dbAutoIncrField ' Атрибуты поля - автоинкремент
tbWorker.Fields.Append Fin ' Добавляем поля в таблицу
tbWorker.Fields.Append Frel
' Первичный ключ таблицы Worker (индекс по полю Number)
Set Ind1 = tbWorker.CreateIndex("Number")
Ind1.Primary = True ' Устанавливаем свойство ключа - первичный ключ
Set Frel = Ind1.CreateField("Number", dbLong) ' Создаем индексное поле аналогичное полю связи из таблицы
Ind1.Fields.Append Frel ' Добавляем его к индексу
tbWorker.Indexes.Append Ind1 ' Добавляем индекс к таблице

' Описание остальных полей (табл. Worker)
Set F(1) = tbWorker.CreateField("Фамилия", dbText, 50) ' Создание текстового поля размером 50 символов
Set F(2) = tbWorker.CreateField("Имя", dbText, 50)
Set F(3) = tbWorker.CreateField("Отчество", dbText, 50)
Set F(4) = tbWorker.CreateField("Дата рождения", dbDate) ' Создание поля даты
Set F(5) = tbWorker.CreateField("Национальность", dbText, 50)
Set F(6) = tbWorker.CreateField("Должность", dbText, 150)
Set F(7) = tbWorker.CreateField("СемПоложение", dbText, 20)
Set F(8) = tbWorker.CreateField("Телефон", dbText, 15)
Set F(9) = tbWorker.CreateField("ДатаЗап", dbDate)
Set F(10) = tbWorker.CreateField("Образование", dbText, 90)
Set F(11) = tbWorker.CreateField("Телефон2", dbText, 15)
Set F(12) = tbWorker.CreateField("Профессия", dbText, 200)
Set F(13) = tbWorker.CreateField("Серия", dbText, 10)
Set F(14) = tbWorker.CreateField("Номер", dbText, 10)
Set F(15) = tbWorker.CreateField("Кем выдан", dbText, 200)
Set F(16) = tbWorker.CreateField("ДатаВыдачи", dbDate)
Set F(17) = tbWorker.CreateField("Место рождения", dbText, 250)
Set F(18) = tbWorker.CreateField("Индекс", dbText, 10)
Set F(19) = tbWorker.CreateField("Улица", dbText, 100)
Set F(20) = tbWorker.CreateField("Город", dbText, 100)
Set F(21) = tbWorker.CreateField("Область", dbText, 100)
Set F(22) = tbWorker.CreateField("Район", dbText, 100)
Set F(23) = tbWorker.CreateField("УчЗав", dbText, 200)
Set F(24) = tbWorker.CreateField("ДатаОк1", dbDate)
Set F(25) = tbWorker.CreateField("УчЗав2", dbText, 200)
Set F(26) = tbWorker.CreateField("ДатаОк2", dbDate)
Set F(27) = tbWorker.CreateField("СпецПоД", dbText, 200)
Set F(28) = tbWorker.CreateField("Квалификация", dbText, 200)
Set F(29) = tbWorker.CreateField("НомД", dbText, 50)
Set F(30) = tbWorker.CreateField("УчЗван", dbText, 200)
Set F(31) = tbWorker.CreateField("ОКОДТ", dbText, 10)
Set F(32) = tbWorker.CreateField("ОКСО", dbText, 10)
Set F(33) = tbWorker.CreateField("ГрУч", dbText, 30)
Set F(34) = tbWorker.CreateField("КатУч", dbText, 30)
Set F(35) = tbWorker.CreateField("Состав", dbText, 150)
Set F(36) = tbWorker.CreateField("Звание", dbText, 200)
Set F(37) = tbWorker.CreateField("ВУС", dbText, 50)
Set F(38) = tbWorker.CreateField("Годность", dbText, 100)
Set F(39) = tbWorker.CreateField("Военкомат", dbText, 200)
Set F(40) = tbWorker.CreateField("СпецУч", dbText, 50)
Set F(41) = tbWorker.CreateField("НомСтрах", dbText, 40)
Set F(42) = tbWorker.CreateField("Date1", dbDate)
Set F(43) = tbWorker.CreateField("Date2", dbDate)
Set F(44) = tbWorker.CreateField("Date3", dbDate)
Set F(45) = tbWorker.CreateField("Date4", dbDate)
Set F(46) = tbWorker.CreateField("Date5", dbDate)
Set F(47) = tbWorker.CreateField("Date6", dbDate)
Set F(48) = tbWorker.CreateField("Date7", dbDate)
Set F(49) = tbWorker.CreateField("Date8", dbDate)
Set F(50) = tbWorker.CreateField("Date9", dbDate)
Set F(51) = tbWorker.CreateField("Date10", dbDate)
Set F(52) = tbWorker.CreateField("Причина", dbText, 200)
Set F(53) = tbWorker.CreateField("Date11", dbDate)
Set F(54) = tbWorker.CreateField("Стат", dbText, 200)

' Создание индекса для сортировки по фамилиям и именам (по алфавиту)
Set Ind9 = tbWorker.CreateIndex("Name") ' Создание индекса с именем Name
Ind9.Unique = False ' Индекс не уникальный - значения могут повторяться
Set Fs1 = Ind9.CreateField("Фамилия")
Set Fs2 = Ind9.CreateField("Имя")
Ind9.Fields.Append Fs1
Ind9.Fields.Append Fs2
tbWorker.Indexes.Append Ind9

' Создание и описание счетчика с именем Код (табл. Family) аналогично таблице Worker
Set Fin2 = tbFam.CreateField("Код", dbLong)
Fin2.Attributes = dbAutoIncrField
tbFam.Fields.Append Fin2

' Первичный ключ таблицы Family
Set Ind2 = tbFam.CreateIndex("Код")
Ind2.Primary = True
Set Fin2 = Ind2.CreateField("Код", dbLong)
Ind2.Fields.Append Fin2
tbFam.Indexes.Append Ind2

' Описание остальных полей (табл. Family)
Set P(1) = tbFam.CreateField("Номер", dbLong)
Set P(2) = tbFam.CreateField("Кто", dbText, 20)
Set P(3) = tbFam.CreateField("Фамилия", dbText, 50)
Set P(4) = tbFam.CreateField("Имя", dbText, 50)
Set P(5) = tbFam.CreateField("Отчество", dbText, 50)
Set P(6) = tbFam.CreateField("Год рождения", dbText)

' Добавление полей в таблиу Worker
For i = 1 To 54
tbWorker.Fields.Append F(i)
Next i

' Добавление полей в таблиу Family
For i = 1 To 6
tbFam.Fields.Append P(i)
Next i

' Добавление таблицы Worker в БД
dbkadr.TableDefs.Append tbWorker

' Добавление таблицы Family в БД
dbkadr.TableDefs.Append tbFam

' Создание объекта Relation (связь, отношение) с именем first
Set Rel1 = dbkadr.CreateRelation("first")
' Установка свойств отношения
Rel1.Table = "Worker" ' Первичная (мастер) таблица отношения
Rel1.ForeignTable = "Family" ' Подчиненная таблица
Rel1.Attributes = dbRelationDeleteCascade ' Разрешить каскадное удаление данных из второй таблицы, когда удаляются связанные данные из первой
' Создание поля отношения и установка свойств
Set Fr = Rel1.CreateField("Number") ' Создание поля отношения с именем Number, в первой таблице должно быть поле с таким же именем.
Fr.ForeignName = "Номер" ' Поле отношения во второй таблице Номер.
' Добавление поля к объекту "отношение" и сам объект "отношение" к БД
Rel1.Fields.Append Fr
dbkadr.Relations.Append Rel1
' Закрытие БД
dbkadr.Close
MsgBox "Поздравляем! Вы впервые запустили программу. На Вашем диске была создана БД. Нажмите кнопку Выход, затем запустите программу снова и приступайте к работе."
End Function

• Программное сжатие базы данных

При работе с Базой Данных вы записываете, удаляете,
редактируете свои данные и объем вашей БД постепенно растет.
Остается он неизменным, даже если вы удалите все данные,
т.к. удаленные записи машина Jet превращает в пробелы (грубо говоря).
Для удаления этих пробелов время от времени проводят ''сжатие'' БД и
она принемает оптимальный объем. Код приводится на примере БД Biblio.mdb

'Закрываем БД
Data1.Database.Close
'Вызываем метод CompactDatabase объекта DBEngine
'для сжатия, и сжимаем БД переименовывая ее
DBEngine.CompactDatabase "c:\biblio.mdb", "c:\new.mdb"
'Уничтоваем старую БД
Kill "c:\biblio.mdb"
'Присваиваем полученной, 'сжатой' БД
'ее прежнее имя
Dim OldDB
Dim NewDB
OldDB = "c:\new.mdb"
NewDB = "c:\biblio.mdb"
Name OldDB As NewDB

Источник: http://www.relib.com/code.asp?id=402

• Получаем список установленных DSN / Драйверов

Данный пример работает через API функцию SQLDataSources из ODBC32.DLL.

private Declare Function SQLDataSources Lib "ODBC32.DLL" _
(byval henv&, byval fDirection%, byval szDSN$, byval cbDSNMax%, _
pcbDSN%, byval szDescription$, byval cbDescriptionMax%, _
pcbDescription%) as Integer
'
private Declare Function SQLAllocEnv% Lib "ODBC32.DLL" (env&)
'
Const SQL_SUCCESS as Long = 0
Const SQL_FETCH_NEXT as Long = 1
'
Sub GetDSNsAndDrivers()
Dim i as Integer
Dim sDSNItem as string * 1024
Dim sDRVItem as string * 1024
Dim sDSN as string
Dim sDRV as string
Dim iDSNLen as Integer
Dim iDRVLen as Integer
Dim lHenv as Long 'handle to the environment

on error resume next
cboDSNList.AddItem "(None)"

'получаем DSNы
If SQLAllocEnv(lHenv) <> -1 then
Do Until i <> SQL_SUCCESS
sDSNItem = Space$(1024)
sDRVItem = Space$(1024)
i = SQLDataSources(lHenv, SQL_FETCH_NEXT, sDSNItem, 1024, _
iDSNLen, sDRVItem, 1024, iDRVLen)
sDSN = Left$(sDSNItem, iDSNLen)
sDRV = Left$(sDRVItem, iDRVLen)

If sDSN <> Space(iDSNLen) then
cboDSNList.AddItem sDSN
cboDrivers.AddItem sDRV '---optional - driver value returned
End If
Loop
End If
'удаляем повторяющиеся
If cboDSNList.ListCount > 0 then
With cboDrivers
If .ListCount > 1 then
i = 0
While i < .ListCount
If .List(i) = .List(i + 1) then
.RemoveItem (i)
else
i = i + 1
End If
Wend
End If
End With
End If
cboDSNList.ListIndex = 0
End Sub

• Создание базы данных (*.mdb)

Прежде всего установите ссылку на Microsoft DAO 2.5/3.51 Compatibility Library через меню Project | References.
Расположите на форме элемент Microsoft Common Dialog Control 6.0 через меню Project | Components.
Расположите на форме элемент CommandButton.

Данный код всего лишь создаст базу в формате mdb с указанным вами именем базы.

Private Sub Command1_Click()
On Error GoTo procerror
Screen.MousePointer = 11
Dim dbname As String
dbname = GetDBName()
If Len(dbname) > 0 Then
CreateDB dbname
End If
procexit:
Screen.MousePointer = 0
Exit Sub
procerror:
MsgBox Err.Description
Resume procexit
End Sub
Public Function GetDBName() As String
On Error GoTo procerror
Dim filename As String
cd.DefaultExt = "mdb"
cd.DialogTitle = "Create Database"
cd.Filter = "VB Databases (*.mdb)|*.mdb"
cd.FilterIndex = 1
cd.Flags = cdlOFNHideReadOnly Or cdlOFNOverwritePrompt Or cdlOFNPathMustExist
cd.CancelError = True
cd.ShowSave
filename = cd.filename
On Error Resume Next
Kill filename
procexit:
GetDBName = filename
Exit Function
procerror:
filename = ""
Resume procexit
End Function
Public Sub CreateDB(dbname As String)
Dim db As Database
Set db = DBEngine(0).CreateDatabase(dbname, dbLangGeneral)
End Sub

• Сохранение файла в БД и получение его обратно из БД

Данный пример показывает как можно сохранить двоичный файл
(*.EXE, Документ MS Word и т.п.) в БД и, затем, загрузить его обратно из БД.
В примере используется ADO, поэтому для работы примеру потребуется
указать Reference на Microsoft Active Data Objects. Тип поля БД, в которое будет
сохраняться файл, должен быть BINARY (в MS Access - OLE OBJECT).

Public Function SaveFileToDB(ByVal FileName As String, RS As Object, FieldName As String) As Boolean
Dim iFileNum As Integer
Dim lFileLength As Long
Dim abBytes() As Byte
Dim iCtr As Integer
On Error GoTo ErrorHandler
If Dir(FileName) = "" Then Exit Function
If Not TypeOf RS Is ADODB.Recordset Then Exit Function
'считать файл в массив
iFileNum = FreeFile
Open FileName For Binary Access Read As #iFileNum
lFileLength = LOF(iFileNum)
ReDim abBytes(lFileLength)
Get #iFileNum, , abBytes()
'поместить содержимое массива в БД
RS.Fields(FieldName).AppendChunk abBytes()
Close #iFileNum
SaveFileToDB = True
ErrorHandler:
End Function
Public Function LoadFileFromDB(FileName As String, _
RS As Object, FieldName As String) As Boolean
Dim iFileNum As Integer
Dim lFileLength As Long
Dim abBytes() As Byte
Dim iCtr As Integer
On Error GoTo ErrorHandler
If Not TypeOf RS Is ADODB.Recordset Then Exit Function
iFileNum = FreeFile
Open FileName For Binary As #iFileNum
lFileLength = LenB(RS(FieldName))
abBytes = RS(FieldName).GetChunk(lFileLength)
Put #iFileNum, , abBytes()
Close #iFileNum
LoadFileFromDB = True
ErrorHandler:
End Function
'-----------------------
'Пример использования #1
'-----------------------
Dim sConn As String
Dim oConn As New ADODB.Connection
Dim oRs As New ADODB.Recordset
sConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\MyDb.MDB;Persist Security Info=False"
oConn.Open sConn
oRs.Open "SELECT * FROM MYTABLE", oConn, adOpenKeyset, adLockOptimistic
oRs.AddNew
SaveFileToDB "C:\MyDocuments\MyDoc.Doc", oRs, "MyFieldName"
oRs.Update
oRs.Close
'-----------------------
'Пример использования #2
'-----------------------
Dim sConn As String
Dim oConn As New ADODB.Connection
Dim oRs As New ADODB.Recordset
sConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\MyDb.MDB;Persist Security Info=False"
oConn.Open sConn
oRs.Open "SELECT * FROM MyTable", oConn, adOpenKeyset, adLockOptimistic
LoadFileFromDB "C:\MyDocuments\MyDoc.Doc", oRs, "MyFieldName"
oRs.Close

Источник: http://www.relib.com/code.asp?id=444

• Поиск в DBCombo по первым введенным буквам

Теперь корректно обрабатывает BackSpace и Del, чего раньше, к сожалению, не было. Ну и работает с ADO-DataCombo.

Dim n%

Select Case KeyCode
Case Is >= 48
DataCombo1.SelStart = Len(DataCombo1.Text) - DataCombo1.SelLength + 1
n = DataCombo1.SelStart
Adodc1.Recordset.Find "[Фамилия] LIKE '" & DataCombo1.Text & "*'"
If Adodc1.Recordset.EOF Then
MsgBox "Записи не найдены", vbExclamation + vbOKOnly, "ОШИБКА" ' По желанию
Adodc1.Recordset.MoveFirst
End If
DataCombo1.SelStart = n
DataCombo1.SelLength = Len(DataCombo1.Text) - n
End Select

• Как получить значения поля "автономер" поcле апдейта записи

Просто - после rs.Update в ADO указатель текущей записи остается на обновленной записи.
Достаточно просто получить ее значение: rs!UserId

• Как избавится от Null при получении оного из базы данных (2)

text1 = rs!Phone & ""

Этот совет хорош только при работе с MDB базой. При работе с DBF, NULL может встречаться не только в текстовых, но и в числовых полях.
При этом Ваш совет не работает.
Я пишу следующее:

text1=vbNullString
If Not IsNull(rs!Phone) Then text1 = rs!Phone

alex-scratch@yandex.ru - Дизайн и составление: Огнев Алексей