Private Const BlockSize = 32768
Private Const ERR_INVALID_FIELD_TYPE = vbObjectError + 1000
'********************************************************************
'Funzione Ado per recuperare un oggetto blob e ricostruirlo su disco
'--------------------------------------------------------
'Per lanciare la funzione utilizzare il seguente codice
'la tabella1 contiene un campo blob rs!immagine
'--------------------------------------------------------
'Dim rs As New ADODB.Recordset
'rs.Open "Tabella1", CurrentProject.Connection, adOpenDynamic, adLockBatchOptimistic
'While Not rs.EOF
' Call getBlobAdo("c:\miaimmagine.jpg", rs!immagine)
' rs.MoveNext
'Wend
'rs.Close
'Set rs = Nothing
'********************************************************************
Function getBlobAdo(strFilename As String, fld As ADODB.Field) As Long
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 = adLongVarBinary Then _
Err.Raise ERR_INVALID_FIELD_TYPE, "GetBlob", "Il campo non è un oggetto (OLE)."
lngFileLength = fld.ActualSize
If Not lngFileLength > 0 Then GoTo Exit_Here
lngNumBlocks = Fix(lngFileLength / BlockSize)
lngLeftOver = lngFileLength Mod BlockSize
intFile = FreeFile
Open strFilename For Output As intFile
Close intFile
Open strFilename For Binary Access Write Lock Write As intFile
abytFileData() = fld.GetChunk(lngLeftOver)
Put #intFile, , abytFileData()
For lngCount = 1 To lngNumBlocks
abytFileData() = fld.GetChunk(BlockSize)
Put #intFile, , abytFileData()
Next lngCount
getBlobAdo = 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
'********************************************************************
'Funzione Ado per scrivere un oggetto blob in tabella
'--------------------------------------------------------
'Per lanciare la funzione utilizzare il seguente codice
'la tabella1 contiene un campo blob rs!immagine
'--------------------------------------------------------
'Dim rs As New ADODB.Recordset
'rs.Open "Tabella1", CurrentProject.Connection, adOpenDynamic, adLockPessimistic
'While Not rs.EOF
' rs.AddNew
' Call putBlobAdo("c:\miaimmagine.jpg", rs!immagine)
' rs.Update
' rs.MoveNext
'Wend
'rs.Close
'Set rs = Nothing
'********************************************************************
Function putBlobAdo(strFilename As String, fld As ADODB.Field) As Long
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 = adLongVarBinary Then _
Err.Raise ERR_INVALID_FIELD_TYPE, "GetBlob", "Il campo non è un oggetto (OLE)."
intFile = FreeFile
Open strFilename For Binary Access Read Lock Read Write As intFile
lngFileLength = LOF(intFile)
If Not lngFileLength > 0 Then GoTo Exit_Here
lngNumBlocks = Fix(lngFileLength / BlockSize)
lngLeftOver = lngFileLength Mod BlockSize
'String() gives a Unicode string, need to convert to ANSI
abytFileData = StrConv(String$(lngLeftOver, vbNullChar), vbFromUnicode)
Get #intFile, , abytFileData
fld.AppendChunk abytFileData
abytFileData = StrConv(String$(BlockSize, vbNullChar), vbFromUnicode)
For lngCount = 1 To lngNumBlocks
Get intFile, , abytFileData
fld.AppendChunk abytFileData
Next lngCount
putBlobAdo = 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
'********************************************************************
'Funzione Dao per recuperare un oggetto blob e ricostruirlo su disco
'--------------------------------------------------------
'Per lanciare la funzione utilizzare il seguente codice
'la tabella1 contiene un campo blob rs!immagine
'--------------------------------------------------------
'Dim rs As Recordset
'Set rs = CurrentDb.OpenRecordset("tabella1")
'While Not rs.EOF
' Call getBlobAdo("c:\miaimmagine.jpg", rs!immagine)
' rs.MoveNext
'Wend
'rs.Close
'Set rs = Nothing
'********************************************************************
Function getBlob(strFilename As String, fld As DAO.Field) As Long
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", "Il campo non è un oggetto (OLE)."
intFile = FreeFile
Open strFilename For Binary Access Read Lock Read Write As intFile
lngFileLength = LOF(intFile)
If Not lngFileLength > 0 Then GoTo Exit_Here
lngNumBlocks = Fix(lngFileLength / BlockSize)
lngLeftOver = lngFileLength Mod BlockSize
'String() gives a Unicode string, need to convert to ANSI
abytFileData = StrConv(String$(lngLeftOver, vbNullChar), vbFromUnicode)
Get #intFile, , abytFileData
fld.AppendChunk abytFileData
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
'********************************************************************
'Funzione Dao per scrivere un oggetto blob in tabella
'--------------------------------------------------------
'Per lanciare la funzione utilizzare il seguente codice
'la tabella1 contiene un campo blob rs!immagine
'--------------------------------------------------------
'Dim rs As Recordset
'Set rs = CurrentDb.OpenRecordset("tabella1")
'While Not rs.EOF
' rs.AddNew
' Call getBlobAdo("c:\miaimmagine.jpg", rs!immagine)
' rs.Update
' rs.MoveNext
'Wend
'rs.Close
'Set rs = Nothing
'********************************************************************
Function putBlob(strFilename As String, fld As DAO.Field) As Long
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", "Il campo non è un oggetto (OLE)."
lngFileLength = fld.FieldSize()
If Not lngFileLength > 0 Then GoTo Exit_Here
lngNumBlocks = Fix(lngFileLength / BlockSize)
lngLeftOver = lngFileLength Mod BlockSize
intFile = FreeFile
Open strFilename For Output As intFile
Close intFile
Open strFilename For Binary Access Write Lock Write As intFile
abytFileData() = fld.GetChunk(0, lngLeftOver)
Put #intFile, , abytFileData()
For lngCount = 1 To lngNumBlocks
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
|
