Option Compare Database
Option Explicit

Private Sub btnLoad_Click()
Dim strPicFile As String
Dim strFilter As String
Dim rs As Recordset
    'Зададим параметры и вызовем диалог открытия файла
    strFilter = ahtAddFilterItem(strFilter, "Картинки GIF и JPEG", "*.GIF; *.JPG")
    strPicFile = ahtCommonFileOpenSave(Filter:=strFilter, OpenFile:=True, _
                    DialogTitle:="Выберите картинку...", _
                    flags:=ahtOFN_HIDEREADONLY)
    If strPicFile = "" Then Exit Sub 'Если файл не выбран - выходим из процедуры
    Me.txtPictureType = GetExt(strPicFile) 'Расширение файла картинки запомним в поле PictureType
    DoCmd.RunCommand acCmdSaveRecord 'Сохраним запись, что важно, если она новая
    Set rs = Me.RecordsetClone 'Для дальнейшей работы нужен набор записей
    rs.Bookmark = Me.Bookmark 'Встаём на текущую запись формы
    rs.Edit
      Call ReadBLOB(strPicFile, rs, "Picture") 'Пишем картинку из файла в поле Picture
    rs.Update
    'Пишем картинку обратно из поля Picture во временный файл в текущем каталоге базы
    Call WriteBLOB(rs, "Picture", GetPath(CurrentDb.Name) & "temp" & GetExt(strPicFile))
    'Выводим картинку из этого временного файла в форму
    Me.imgPicture.Picture = GetPath(CurrentDb.Name) & "temp" & GetExt(strPicFile)

End Sub

Private Sub Form_Current()
Dim strPicFile As String
Dim rs As Recordset
  Set rs = Me.RecordsetClone 'Для дальнейшей работы нужен набор записей
  If IsNull(Me!ID) Then 'Если запись новая, то очищаем картинку на форме
    Me.imgPicture.Picture = ""
  Else
    rs.Bookmark = Me.Bookmark 'Встаём на текущую запись формы
    strPicFile = GetPath(CurrentDb.Name) & "temp" & Me!PictureType 'Получаем координаты временного файла
    Call WriteBLOB(rs, "Picture", strPicFile) 'Пишем картинку из поля Picture во временный файл
    Me.imgPicture.Picture = strPicFile 'Выводим картинку из этого временного файла в форму
  End If
End Sub

Option Explicit
Public Declare Function GetTempPath Lib "KERNEL32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Public Declare Function GetTempFileName Lib "KERNEL32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Const BlockSize = 32768
      Function ReadBLOB(Source As String, T As Recordset, sField As String)
          Dim NumBlocks As Integer, SourceFile As Integer, i As Integer
          Dim FileLength As Long, LeftOver As Long
          Dim lngMeter As Long
          Dim FileData As String
          Dim byteData() As Byte
          Dim RetVal As Variant
          On Error GoTo Err_ReadBLOB
          SourceFile = FreeFile
          Open Source For Binary Access Read As SourceFile
          FileLength = LOF(SourceFile)
          If FileLength = 0 Then
              ReadBLOB = 0
              Exit Function
          End If
          NumBlocks = FileLength \ BlockSize
          LeftOver = FileLength Mod BlockSize
          lngMeter = FileLength \ 1000
          RetVal = SysCmd(acSysCmdInitMeter, "Reading BLOB", lngMeter)
          If LeftOver > 0 Then
            ReDim byteData(0 To LeftOver - 1)
            Get SourceFile, , byteData
            T(sField).AppendChunk (byteData)
          End If
          lngMeter = LeftOver \ 1000
          RetVal = SysCmd(acSysCmdUpdateMeter, lngMeter)
          ReDim byteData(0 To BlockSize - 1)
          For i = 1 To NumBlocks
              Get SourceFile, , byteData
              T(sField).AppendChunk (byteData)
              lngMeter = BlockSize * i \ 1000
              RetVal = SysCmd(acSysCmdUpdateMeter, lngMeter)
          Next i
          RetVal = SysCmd(acSysCmdRemoveMeter)
          Close SourceFile
          ReadBLOB = FileLength
          Exit Function
Err_ReadBLOB:
          ReadBLOB = -Err
          Exit Function
      End Function
      Function WriteBLOB(T As Recordset, sField As String, Destination As String)
          Dim NumBlocks As Integer, DestFile As Integer, i As Integer
          Dim FileLength As Long, LeftOver As Long
          Dim lngMeter As Long
          Dim byteData() As Byte
          Dim RetVal As Variant
          On Error GoTo Err_WriteBLOB
          FileLength = T(sField).FieldSize()
          If FileLength = 0 Then
              WriteBLOB = 0
              Exit Function
          End If
          NumBlocks = FileLength \ BlockSize
          LeftOver = FileLength Mod BlockSize
          DestFile = FreeFile
          Open Destination For Output As DestFile
          Close DestFile
          Open Destination For Binary As DestFile
          lngMeter = FileLength \ 1000
          RetVal = SysCmd(acSysCmdInitMeter, "Writing BLOB", lngMeter)
          If LeftOver > 0 Then
            byteData() = T(sField).GetChunk(0, LeftOver)
            Put DestFile, , byteData
          End If
          lngMeter = LeftOver \ 1000
          RetVal = SysCmd(acSysCmdUpdateMeter, lngMeter)
          For i = 1 To NumBlocks
              byteData() = T(sField).GetChunk((i - 1) * BlockSize _
                 + LeftOver, BlockSize)
              Put DestFile, , byteData
              lngMeter = (i * BlockSize + LeftOver) \ 1000
              RetVal = SysCmd(acSysCmdUpdateMeter, lngMeter)
          Next i
          RetVal = SysCmd(acSysCmdRemoveMeter)
          Close DestFile
          WriteBLOB = FileLength
          Exit Function
Err_WriteBLOB:
          WriteBLOB = -Err
          Exit Function
      End Function

Option Compare Database
Option Explicit
Type tagOPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    strFilter As String
    strCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    strFile As String
    nMaxFile As Long
    strFileTitle As String
    nMaxFileTitle As Long
    strInitialDir As String
    strTitle As String
    flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    strDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type
Declare Function aht_apiGetOpenFileName Lib "comdlg32.dll" _
    Alias "GetOpenFileNameA" (OFN As tagOPENFILENAME) As Boolean
Declare Function aht_apiGetSaveFileName Lib "comdlg32.dll" _
    Alias "GetSaveFileNameA" (OFN As tagOPENFILENAME) As Boolean
Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long
Global Const ahtOFN_READONLY = &H1
Global Const ahtOFN_OVERWRITEPROMPT = &H2
Global Const ahtOFN_HIDEREADONLY = &H4
Global Const ahtOFN_NOCHANGEDIR = &H8
Global Const ahtOFN_SHOWHELP = &H10
Global Const ahtOFN_NOVALIDATE = &H100
Global Const ahtOFN_ALLOWMULTISELECT = &H200
Global Const ahtOFN_EXTENSIONDIFFERENT = &H400
Global Const ahtOFN_PATHMUSTEXIST = &H800
Global Const ahtOFN_FILEMUSTEXIST = &H1000
Global Const ahtOFN_CREATEPROMPT = &H2000
Global Const ahtOFN_SHAREAWARE = &H4000
Global Const ahtOFN_NOREADONLYRETURN = &H8000
Global Const ahtOFN_NOTESTFILECREATE = &H10000
Global Const ahtOFN_NONETWORKBUTTON = &H20000
Global Const ahtOFN_NOLONGNAMES = &H40000
Global Const ahtOFN_EXPLORER = &H80000
Global Const ahtOFN_NODEREFERENCELINKS = &H100000
Global Const ahtOFN_LONGNAMES = &H200000
Function TestIt()
    Dim strFilter As String
    Dim lngFlags As Long
    strFilter = ahtAddFilterItem(strFilter, "Access Files (*.mda, *.mdb)", _
                    "*.MDA;*.MDB")
    strFilter = ahtAddFilterItem(strFilter, "dBASE Files (*.dbf)", "*.DBF")
    strFilter = ahtAddFilterItem(strFilter, "Text Files (*.txt)", "*.TXT")
    strFilter = ahtAddFilterItem(strFilter, "All Files (*.*)", "*.*")
    MsgBox "You selected: " & ahtCommonFileOpenSave(InitialDir:="C:\", _
        Filter:=strFilter, FilterIndex:=3, flags:=lngFlags, _
        DialogTitle:="Hello! Open Me!")
    Debug.Print Hex(lngFlags)
End Function
Function GetOpenFile(Optional varDirectory As Variant, _
    Optional varTitleForDialog As Variant) As Variant
Dim strFilter As String
Dim lngFlags As Long
Dim varFileName As Variant
    lngFlags = ahtOFN_FILEMUSTEXIST Or _
                ahtOFN_HIDEREADONLY Or ahtOFN_NOCHANGEDIR
    If IsMissing(varDirectory) Then
        varDirectory = ""
    End If
    If IsMissing(varTitleForDialog) Then
        varTitleForDialog = ""
    End If
    strFilter = ahtAddFilterItem(strFilter, _
                "Access (*.mdb)", "*.MDB;*.MDA")
    varFileName = ahtCommonFileOpenSave( _
                    OpenFile:=True, _
                    InitialDir:=varDirectory, _
                    Filter:=strFilter, _
                    flags:=lngFlags, _
                    DialogTitle:=varTitleForDialog)
    If Not IsNull(varFileName) Then
        varFileName = TrimNull(varFileName)
    End If
    GetOpenFile = varFileName
End Function
Function ahtCommonFileOpenSave( _
            Optional ByRef flags As Variant, _
            Optional ByVal InitialDir As Variant, _
            Optional ByVal Filter As Variant, _
            Optional ByVal FilterIndex As Variant, _
            Optional ByVal DefaultExt As Variant, _
            Optional ByVal FileName As Variant, _
            Optional ByVal DialogTitle As Variant, _
            Optional ByVal hWnd As Variant, _
            Optional ByVal OpenFile As Variant) As Variant
Dim OFN As tagOPENFILENAME
Dim strFileName As String
Dim strFileTitle As String
Dim fResult As Boolean
    If IsMissing(InitialDir) Then InitialDir = CurDir
    If IsMissing(Filter) Then Filter = ""
    If IsMissing(FilterIndex) Then FilterIndex = 1
    If IsMissing(flags) Then flags = 0&
    If IsMissing(DefaultExt) Then DefaultExt = ""
    If IsMissing(FileName) Then FileName = ""
    If IsMissing(DialogTitle) Then DialogTitle = ""
    If IsMissing(hWnd) Then hWnd = Application.hWndAccessApp
    If IsMissing(OpenFile) Then OpenFile = True
    strFileName = Left(FileName & String(256, 0), 256)
    strFileTitle = String(256, 0)
    With OFN
        .lStructSize = Len(OFN)
        .hwndOwner = hWnd
        .strFilter = Filter
        .nFilterIndex = FilterIndex
        .strFile = strFileName
        .nMaxFile = Len(strFileName)
        .strFileTitle = strFileTitle
        .nMaxFileTitle = Len(strFileTitle)
        .strTitle = DialogTitle
        .flags = flags
        .strDefExt = DefaultExt
        .strInitialDir = InitialDir
        .hInstance = 0
        .strCustomFilter = ""
        .nMaxCustFilter = 0
        .lpfnHook = 0
        .strCustomFilter = String(255, 0)
        .nMaxCustFilter = 255
    End With
    If OpenFile Then
        fResult = aht_apiGetOpenFileName(OFN)
    Else
        fResult = aht_apiGetSaveFileName(OFN)
    End If
    If fResult Then
        If Not IsMissing(flags) Then flags = OFN.flags
        ahtCommonFileOpenSave = TrimNull(OFN.strFile)
    Else
        ahtCommonFileOpenSave = vbNullString
    End If
End Function
Function ahtAddFilterItem(strFilter As String, _
    strDescription As String, Optional varItem As Variant) As String
    If IsMissing(varItem) Then varItem = "*.*"
    ahtAddFilterItem = strFilter & _
                strDescription & vbNullChar & _
                varItem & vbNullChar
End Function
Private Function TrimNull(ByVal strItem As String) As String
Dim intPos As Integer
    intPos = InStr(strItem, vbNullChar)
    If intPos > 0 Then
        TrimNull = Left(strItem, intPos - 1)
    Else
        TrimNull = strItem
    End If
End Function

Sub test()
Dim strFilter As String
Dim strInputFileName As String

strFilter = ahtAddFilterItem(strFilter, "Excel Files (*.XLS)", "*.XLS")
strInputFileName = ahtCommonFileOpenSave(Filter:=strFilter, OpenFile:=True, _
                DialogTitle:="Please select an input file...", _
                flags:=ahtOFN_HIDEREADONLY)
End Sub

Option Compare Database
Option Explicit

Public Function GetPath(FullPath As String) As String
  Dim lngCurrPos, lngLastPos As Long
  Do
    lngLastPos = lngCurrPos
    lngCurrPos = InStr(lngLastPos + 1, FullPath, "\")
  Loop Until lngCurrPos = 0
  If lngLastPos <> 0 Then GetPath = Left(FullPath, lngLastPos)
End Function

Public Function GetFile(FullPath As String) As String
  Dim lngCurrPos, lngLastPos As Long
  Do
    lngLastPos = lngCurrPos
    lngCurrPos = InStr(lngLastPos + 1, FullPath, "\")
  Loop Until lngCurrPos = 0
  If lngLastPos <> 0 Then GetFile = Right$(FullPath, Len(FullPath) - lngLastPos)
End Function

Public Function GetExt(FullPath As String) As String
  Dim lngCurrPos, lngLastPos As Long
  Do
    lngLastPos = lngCurrPos
    lngCurrPos = InStr(lngLastPos + 1, FullPath, ".")
  Loop Until lngCurrPos = 0
  If lngLastPos <> 0 Then GetExt = Right$(FullPath, Len(FullPath) - lngLastPos + 1)
End Function