Aggiungi BMP o JPG dentro campo OLE da ACCESS

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

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 e' 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 e' 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 e' 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 e' 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