Newsgroup: it.comp.appl.access
Titolo: Importazione immagini in db

Partendo da Access come è possibile importare da scanner un'immagine?
Dove potrei documentarmi?
Grazie 1000.
PdA

 ha scritto nel messaggio
news:afp9jp$4hb$1...@fe1.cs.interbusiness.it...

Allego delle funzioni sia Ado che Dao che possono esserti utili.
Pietro
'********************************************************************
'Funzione Ado per recuperare un oggetto blob e ricostruirlo su disco
'********************************************************************
Option Compare Database
Option Explicit
Private Const BlockSize = 32768
Private Const ERR_INVALID_FIELD_TYPE = vbObjectError + 1000
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
'--------------------------------------------------------
'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("inserire campo o percorso file", 'inserire campo
blob')
        Call getBlobAdo("c:\miaimmagine.jpg", rs!immagine) 'esempio
        rs.MoveNext
    Wend
    rs.Close
    Set rs = Nothing
'********************************************************************
'Funzione Ado per scrivere un oggetto blob in tabella
'********************************************************************
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
abytFileData = StrConv(String$(lngLeftOver, vbNullChar), vbFromUnicode)
'String() gives a Unicode string, need to convert to ANSI
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
'--------------------------------------------------------
'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("percorso del file da caricare", "campo Blob")
        Call putBlobAdo("c:\miaimmagine.jpg", rs!immagine) 'esempio
        rs.Update
        rs.MoveNext
    Wend
    rs.Close
    Set rs = Nothing
'********************************************************************
'Funzione Dao per recuperare un oggetto blob e ricostruirlo su disco
'********************************************************************
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
abytFileData = StrConv(String$(lngLeftOver, vbNullChar), vbFromUnicode)
'String() gives a Unicode string, need to convert to ANSI
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
'--------------------------------------------------------
'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("inserire campo o percorso file", 'inserire campo
blob')
        Call getBlobAdo("c:\miaimmagine.jpg", rs!immagine) 'esempio
        rs.MoveNext
    Wend
    rs.Close
    Set rs = Nothing
'********************************************************************
'Funzione Dao per scrivere un oggetto blob in tabella
'********************************************************************
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
'--------------------------------------------------------
'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("inserire campo o percorso file", 'inserire campo
blob')
        Call getBlobAdo("c:\miaimmagine.jpg", rs!immagine) 'esempio
    rs.Update
        rs.MoveNext
    Wend
    rs.Close
    Set rs = Nothing