by Henri (1 Submission)
Category: Databases/Data Access/DAO/ADO
Compatability: Visual Basic 3.0
Difficulty: Intermediate
Date Added: Wed 3rd February 2021
Rating: 
(6 Votes)
Here are two functions that will allow you to
read and write a Large Binary Object
(BLOB) to and from a database. This could be used
to store and retrieve images, documents, etc
inside the database it self. This is great for
those of use that have a lot of Binary files
around that we want to keep in a central place
that can be backed up and protected with the same
security that a database offers.
This code will work with *ANY* database that ADO can connect to.
Assumes
The code needs a referance to the ADO library.
VBcoders'***************************************************************
' Abstract: Writes a BLOB datafield to a file. If the Data Field is
' big I would recommend that you set bUseStream = False.
'
' Input: strFullPath: Full path to the destination file
' objField: Field object that contains the BLOB data.
' bUseStream: (Optional) True = Use Stream methode, False = Use GetChunk
' lngChunkSize: (Optional) Specifies the Chunk size to fetch with each GetChunk
'
' Output: True on success, False on failure
'***************************************************************
Public Function BLOBToFile(ByVal strFullPath As String, ByRef objField As ADODB.Field, Optional ByVal bUseStream As Boolean = True, Optional ByVal lngChunkSize As Long = 8192) As Boolean
On Error Resume Next
Dim objStream As ADODB.Stream
Dim intFreeFile As Integer
Dim lngBytesLeft As Long
Dim lngReadBytes As Long
Dim byBuffer() As Byte
If bUseStream Then
Set objStream = New ADODB.Stream
With objStream
.Type = adTypeBinary
.Open
.Write objField.Value
.SaveToFile strFullPath, adSaveCreateOverWrite
End With
DoEvents
Else
If Dir(strFullPath) <> "" Then
Kill strFullPath
End If
lngBytesLeft = objField.ActualSize
intFreeFile = FreeFile
Open strFullPath For Binary As #intFreeFile
Do Until lngBytesLeft <= 0
lngReadBytes = lngBytesLeft
If lngReadBytes > lngChunkSize Then
lngReadBytes = lngChunkSize
End If
byBuffer = objField.GetChunk(lngReadBytes)
Put #intFreeFile, , byBuffer
lngBytesLeft = lngBytesLeft - lngReadBytes
DoEvents
Loop
Close #intFreeFile
End If
If Err.Number <> 0 Or Err.LastDllError <> 0 Then
BLOBToFile = False
Else
BLOBToFile = True
End If
End Function
'***************************************************************
' Abstract: Writes a binary file to a BLOB datafield. If the file
' is big I would recommend that you set bUseStream = False.
'
' Input: strFullPath: Full path to the source file
' objField: Field object that will contain the BLOB data.
' bUseStream: (Optional) True = Use Stream methode, False = Use GetChunk
' lngChunkSize: (Optional) Specifies the Chunk size to fetch with each GetChunk
'
' Output: True on success, False on failure
'***************************************************************
Public Function FileToBLOB(ByVal strFullPath As String, ByRef objField As ADODB.Field, Optional ByVal bUseStream As Boolean = True, Optional ByVal lngChunkSize As Long = 8192) As Boolean
On Error Resume Next
Dim objStream As ADODB.Stream
Dim intFreeFile As Integer
Dim lngBytesLeft As Long
Dim lngReadBytes As Long
Dim byBuffer() As Byte
Dim varChunk As Variant
If bUseStream Then
Set objStream = New ADODB.Stream
With objStream
.Type = adTypeBinary
.Open
.LoadFromFile strFullPath
objField.Value = .Read(adReadAll)
End With
Else
With objField
'<<--If the field does not support Long Binary data'-->>
'<<--then we cannot load the data into the field.-->>
If (.Attributes And adFldLong) <> 0 Then
intFreeFile = FreeFile
Open strFullPath For Binary Access Read As #intFreeFile
lngBytesLeft = LOF(intFreeFile)
Do Until lngBytesLeft <= 0
If lngBytesLeft > lngChunkSize Then
lngReadBytes = lngChunkSize
Else
lngReadBytes = lngBytesLeft
End If
ReDim byBuffer(lngReadBytes)
Get #intFreeFile, , byBuffer()
objField.AppendChunk byBuffer()
lngBytesLeft = lngBytesLeft - lngReadBytes
DoEvents
Loop
Close #intFreeFile
Else
Err.Raise -10000, "FileToBLOB", "The Database Field does not support Long Binary Data."
End If
End With
End If
If Err.Number <> 0 Or Err.LastDllError <> 0 Then
FileToBLOB = False
Else
FileToBLOB = True
End If
End Function
