em um módulo
Public Sub IBlob(file As String, QueryBlob As String, FieldBlob As String)
Dim RsBlob As ADODB.Recordset
Dim DataFile As Integer
Dim Fl As Long
Dim Chunks As Integer
Dim Fragment As Integer
Dim Chunk() As Byte
Dim I As Integer
Const ChunkSize As Integer = 16384
On Error GoTo erros
Screen.MousePointer = vbHourglass
Set RsBlob = New ADODB.Recordset
RsBlob.Open QueryBlob, gConexao, adOpenDynamic, adLockPessimistic
While Not RsBlob.EOF
DataFile = 1
Open file For Binary Access Read As DataFile
Fl = LOF(DataFile)
If Fl = 0 Then Close DataFile: Exit Sub
Chunks = Fl ChunkSize
Fragment = Fl Mod ChunkSize
RsBlob(FieldBlob).AppendChunk Null
ReDim Chunk(Fragment)
Get DataFile, , Chunk()
RsBlob(FieldBlob).AppendChunk Chunk()
ReDim Chunk(ChunkSize)
For I = 1 To Chunks
Get DataFile, , Chunk()
RsBlob(FieldBlob).AppendChunk Chunk()
Next I
Close DataFile
RsBlob.Update
RsBlob.MoveNext
Wend
erros:
Set RsBlob = Nothing
Screen.MousePointer = vbDefault
If Err.Number <> 0 Then
MsgBox Err.Number & Chr(13) & Err.Description
End If
End Sub
'------------------------------------RETIRA IMAGEM DO BANCO------------------------------------
Public Sub RBlob(file As String, QueryBlob As String, FieldBlob As String)
Dim RsBlob As ADODB.Recordset
Dim DataFile As Integer
Dim Fl As Long
Dim Chunks As Long
Dim Fragment As Integer
Dim Chunk() As Byte
Dim I As Integer
Const ChunkSize As Integer = 16384
On Error GoTo erros
Screen.MousePointer = vbHourglass
Set RsBlob = New ADODB.Recordset
RsBlob.Open QueryBlob, gConexao, adOpenDynamic, adLockPessimistic
While Not RsBlob.EOF
DataFile = 1
If RsBlob(FieldBlob).ActualSize <> 0 Then
Open file For Binary Access Write As DataFile
Fl = RsBlob(FieldBlob).ActualSize
Chunks = Fl ChunkSize
Fragment = Fl Mod ChunkSize
ReDim Chunk(Fragment)
Chunk() = RsBlob(FieldBlob).GetChunk(Fragment)
Put DataFile, , Chunk()
For I = 1 To Chunks
ReDim Buffer(ChunkSize)
Chunk() = "" & RsBlob(FieldBlob).GetChunk(ChunkSize)
Put DataFile, , Chunk()
Next I
Close DataFile
End If
RsBlob.MoveNext
Wend
erros:
Set RsBlob = Nothing
Screen.MousePointer = vbDefault
If Err.Number <> 0 Then
MsgBox Err.Number & Chr(13) & Err.Description
End If
End Sub
