Option Compare Database
Option Explicit
Private Const BlockSize = 32768
Private Const ERR_INVALID_FIELD_TYPE = vbObjectError + 1000
Function GetBlob(strFilename As String, fld As DAO.Field) As Long
'gets a file from disk (strFilename) into an OLE field (fld)
'the record with fld has to be in Edit or Append mode and needs to be Updated after
'returns the number of bytes read
'modified from MSKB Q210486
On Error GoTo Err_Handler
Dim intFile As Integer
Dim lngNumBlocks As Long, lngFileLength As Long
Dim lngLeftOver As Long, lngCount As Long
Dim abytFileData() As Byte
If Not Len(Dir$(strFilename)) > 0 Then GoTo Exit_Here
If Not fld.Type = dbLongBinary Then _
Err.Raise ERR_INVALID_FIELD_TYPE, "GetBlob", "Field type has to be Long Binary (OLE)."
' Open the source file.
intFile = FreeFile
Open strFilename For Binary Access Read Lock Read Write As intFile
' Get the length of the file.
lngFileLength = LOF(intFile)
If Not lngFileLength > 0 Then GoTo Exit_Here
' Calculate the number of blocks to read and leftover bytes.
lngNumBlocks = Fix(lngFileLength / BlockSize)
lngLeftOver = lngFileLength Mod BlockSize
' Read the leftover data, writing it to the field.
abytFileData = StrConv(String$(lngLeftOver, vbNullChar), vbFromUnicode) 'String() gives a Unicode string, need to convert to ANSI
Get #intFile, , abytFileData
fld.AppendChunk abytFileData
' Read the remaining blocks of data, writing them to the table.
abytFileData = StrConv(String$(BlockSize, vbNullChar), vbFromUnicode)
For lngCount = 1 To lngNumBlocks
Get intFile, , abytFileData
fld.AppendChunk abytFileData
Next lngCount
GetBlob = lngFileLength
Exit_Here:
On Error Resume Next
Close intFile
Exit Function
Err_Handler:
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical
Resume Exit_Here
End Function
Function PutBlob(strFilename As String, fld As DAO.Field) As Long
'writes the contents of an OLE field (fld) to a file on disk (strFilename)
'will silently overwrite existing file
'returns the number of bytes written
'modified from MSKB Q210486
On Error GoTo Err_Handler
Dim intFile As Integer, lngCount As Long
Dim lngFileLength As Long, lngLeftOver As Long, lngNumBlocks As Long
Dim abytFileData() As Byte
If Not fld.Type = dbLongBinary Then _
Err.Raise ERR_INVALID_FIELD_TYPE, "GetBlob", "Field type has to be Long Binary (OLE)."
' Get the size of the field.
lngFileLength = fld.FieldSize()
If Not lngFileLength > 0 Then GoTo Exit_Here
' Calculate number of blocks to write and leftover bytes.
lngNumBlocks = Fix(lngFileLength / BlockSize)
lngLeftOver = lngFileLength Mod BlockSize
' Remove any existing destination file.
intFile = FreeFile
Open strFilename For Output As intFile
Close intFile
' Open the destination file.
Open strFilename For Binary Access Write Lock Write As intFile
' Write the leftover data to the output file.
abytFileData() = fld.GetChunk(0, lngLeftOver)
Put #intFile, , abytFileData()
' Write the remaining blocks of data to the output file.
For lngCount = 1 To lngNumBlocks
' Reads a chunk and writes it to output file.
abytFileData() = fld.GetChunk((lngCount - 1) * BlockSize + lngLeftOver, BlockSize)
Put #intFile, , abytFileData()
Next lngCount
PutBlob = lngFileLength
Exit_Here:
On Error Resume Next
Close intFile
Exit Function
Err_Handler:
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical
Resume Exit_Here
End Function
Public Sub runit()
Dim filename As String
Dim rs As Recordset
Dim lngFilePtr As Long
filename = apiSaveFile("*.*")
Set rs = CurrentDb.OpenRecordset("SELECT * FROM t")
rs.AddNew
GetBlob filename, rs.Fields("blob")
rs!Txt = "runit"
rs.Update
rs.Close
End Sub
Public Sub run2()
Dim rs As Recordset
Set rs = CurrentDb.OpenRecordset("SELECT * FROM t")
Do While Not rs.EOF
PutBlob apiSaveFile("*.*"), rs.Fields("blob")
rs.MoveNext
Loop
rs.Close
End Sub