Option Explicit

Private Sub Command1_Click()
' Создание базы данных и таблицы с двумя полями - текстовым
' и для хранения рисунка
  Dim db  As DAO.Database
  Dim tbl As DAO.TableDef
  Dim fld As DAO.Field

' Создание базы
  Set db = CreateDatabase(App.Path & "\db1.mdb", _
                          dbLangCyrillic)
  
' Создание таблицы
  Set tbl = db.CreateTableDef("tblCustomers"
' Создание поля для хранения имени
  Set fld = tbl.CreateField("Family", dbText, 255)
  tbl.Fields.Append fld
' Создание поля для хранения рисунка
  Set fld = tbl.CreateField("Photo", dbLongBinary)
  tbl.Fields.Append fld
' Добавляем таблицу в базу данных
  db.TableDefs.Append tbl
  
  db.Close
  Set tbl = Nothing
  Set fld = Nothing
  Set db = Nothing
  
  MsgBox "База данных создана!  "
End Sub

Private Sub Command2_Click()
' Запись рисунка (предпологается, что на форме
' есть текстовое поле и Picture box), а база данных создана
  Dim db As DAO.Database
  Dim rs As DAO.Recordset
  ' Открываем базу данных... (в подробности с параметрами
  ' не вдаваюсь - разберешься сам)
  Set db = OpenDatabase(App.Path & "\db1.mdb", dbEncrypt, False)
  ' Открываем таблицу - с параметрами тоже сам разбирайся...
  Set rs = db.OpenRecordset("tblCustomers"
  ' Собственно запись данных
  rs.AddNew
  rs.Fields("Family".Value = Text1.Text
  
  ' С рисунком все сложнее... - можно это оформить в виде отдельной функции
  Dim tmpFileName As String
  Dim iFileNum As Integer
  Dim lFileLength As Long
  Dim abBytes() As Byte
  
  tmpFileName = Environ("TEMP" & "myTmpPic"
  If Not (Picture1.Picture Is Nothing) Then
    iFileNum = FreeFile
    SavePicture Picture1.Picture, tmpFileName
    Open tmpFileName For Binary Access Read As #iFileNum
    lFileLength = LOF(iFileNum)
    ReDim abBytes(lFileLength)
    Get #iFileNum, , abBytes()
    'поместить содержимое массива в БД
    rs.Fields("Photo".AppendChunk abBytes()
    Close #iFileNum
  End If
  rs.Update
  rs.Close
  db.Close
  Set rs = Nothing
  Set db = Nothing
  MsgBox "Запись добавлена!"
End Sub

Private Sub Command3_Click()
' Чтение из базы данных...
  Dim db As DAO.Database
  Dim rs As DAO.Recordset
  ' Открываем базу данных... (в подробности с параметрами
  ' не вдаваюсь - разберешься сам)
  Set db = OpenDatabase(App.Path & "\db1.mdb", dbEncrypt, True)
  ' Открываем таблицу - с параметрами тоже сам разбирайся...
  Set rs = db.OpenRecordset("tblCustomers"
  Text1.Text = rs.Fields("Family".Value
  Set Picture1.Picture = LoadPictureFromDB(rs.Fields("Photo")
  rs.Close
  db.Close
  Set rs = Nothing
  Set db = Nothing
End Sub

' =======================
' Этот код лучше поместить в модуль
Private Declare Function OleCreatePictureIndirect Lib "OLEPRO32.DLL" (lpPictDesc As PictDesc, ByRef riid As Byte, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
Private Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ppstm As Any) As Long
Private Declare Function OleLoadPicture Lib "olepro32" (pStream As Any, ByVal lSize As Long, ByVal fRunmode As Long, ByRef riid As Byte, ppvObj As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpsz As Any, ByRef pclsid As Byte) As Long

Private Declare Function GlobalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)

Private Type PictDesc
    cbSizeofStruct      As Long
    picType             As Long
    hImage              As Long
    xExt                As Long
    yExt                As Long
End Type

Public Function LoadPictureFromDB(ByRef btData As DAO.Field) As IPictureDisp
  If IsNull(btData) Then
    Set LoadPictureFromDB = Nothing
  Else
    Set LoadPictureFromDB = GetPictureFromByte(btData.Value)
  End If
End Function

' ++++++++++++++++++++++++
' Нижеследующий код взят у SNE - за что ему большое спасибо!
'--------------------------------------------------------------------------------
' Проект     :  OfflineClient
' Процедура  :  PictureFromMemory
' Описание   :  Получение IPicture из массива
' Кем создан :  SNE
' Дата-Время :  15.11.2004-21:45:57
'
' Параметры  :  btData()    - Данные картинки
'--------------------------------------------------------------------------------
Private Function GetPictureFromByte(ByRef btData() As Byte) As IPictureDisp
  Dim IID_IPicture(16) As Byte
  Dim pGlobal As Long, pStream As IUnknown

  Const sIID_IPicture = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"

  pGlobal = GlobalAlloc(0&, UBound(btData) + vbNull)
  Call CopyMemory(ByVal pGlobal, btData(0), UBound(btData) + vbNull)

  If CreateStreamOnHGlobal(pGlobal, True, pStream) = 0& Then
    If CLSIDFromString(StrPtr(sIID_IPicture), IID_IPicture(0)) = 0& Then
      Call OleLoadPicture(ByVal ObjPtr(pStream), UBound(btData) + vbNull, False, IID_IPicture(0), GetPictureFromByte)
    End If
  End If
  If GetPictureFromByte Is Nothing Then Call GlobalFree(pGlobal)
End Function

RichTextBox.RTFText = rs.("Text".Value

RichTextBox.RTFText = rs.Fields("Text".Value