INSERIR IMAGEM

Private Sub GravaFoto()

    'INICIALIZA

    Dim Qd As rdoQuery
    Dim Rs As rdoResultset
    Dim FileName As String
    Dim DataFile As Integer, Fl As Long, Chunks As Integer
    Dim Fragment As Integer, Chunk() As Byte, i As Integer
    Dim sSql As String
                
    sSql = ""
    sSql = sSql & "SELECT "
    sSql = sSql & "       CLIENTE,  "
    sSql = sSql & "       FOTO       "
    sSql = sSql & "FROM   "
    sSql = sSql & "       FOTOSCLIENTE "
    sSql = sSql & "WHERE  "
    sSql = sSql & "       CLIENTE =  " & txtCliente.Text
    
    Set Qd = Banco.CreateQuery("FotosCliente", sSql)

    'GRAVA FOTO

    Set Rs = Qd.OpenResultset(rdOpenKeyset, _
        rdConcurRowVer)
    If Rs Is Nothing Or Rs.Updatable = False Then
        ResetAmpulheta
        Rs.Close
        Set Qd = Nothing
        MsgBox "Nao foi possivel gravar a foto do cliente!", vbCritical
        Exit Sub
    End If
    If Rs.EOF Then
        Rs.AddNew
        Rs!Cliente = txtCliente.Text
    Else
        Rs.Edit
    End If
    DataFile = 1
    Open FileName For Binary Access Read As DataFile
    Fl = lOF(DataFile)    ' Tamanho dos dados dentro do arquivo
    If Fl = 0 Then Close DataFile: Exit Sub
    Chunks = Fl  ChunkSize
    Fragment = Fl Mod ChunkSize
    Rs!FOTO.AppendChunk Null
    ReDim Chunk(Fragment)
    Get DataFile, , Chunk()
    Rs!FOTO.AppendChunk Chunk()
    ReDim Chunk(ChunkSize)
    For i = 1 To Chunks
        Get DataFile, , Chunk()
        Rs!FOTO.AppendChunk Chunk()
    Next i
    Close DataFile
    Rs.Update
    Rs.Close
    Rem MsgBox "Foto gravada com sucesso!", vbExclamation
    Set Qd = Nothing

end Sub

private sub CarregaFoto()

    'INICIALIZA

    Dim Qd As rdoQuery
    Dim Rs As rdoResultset
    Dim FileName As String
    Dim DataFile As Integer, Fl As Long, Chunks As Integer
    Dim Fragment As Integer, Chunk() As Byte, i As Integer
    Dim sSql As String

    Set Rs = Qd.OpenResultset(rdOpenKeyset, rdConcurRowVer)
    If Rs Is Nothing Or Rs.Updatable = False Then
        ResetAmpulheta
        MsgBox "Nao foi possivel exibir a foto do cliente!", vbCritical
        Rs.Close: Qd.Close
        Set Qd = Nothing
        Exit Sub
    End If
    If Rs.EOF Then
        ResetAmpulheta
        cmdLimparFoto_Click
        Rem MsgBox "Nao existe nenhuma foto armazenada!", vbExclamation
        Rs.Close: Qd.Close
        Set Qd = Nothing
        Exit Sub
    End If
    DataFile = 1
    Kill App.Path & "\pictemp.tif" 'Deleta arquivo temporario de foto
    Open App.Path & "\pictemp.tif" For Binary Access Write As DataFile
    Fl = Rs!FOTO.ColumnSize
    Chunks = Fl  ChunkSize
    Fragment = Fl Mod ChunkSize
    ReDim Chunk(Fragment)
    Chunk() = Rs!FOTO.GetChunk(Fragment)
    Put DataFile, , Chunk()
    For i = 1 To Chunks
        ReDim Buffer(ChunkSize)
        Chunk() = Rs!FOTO.GetChunk(ChunkSize)
        Put DataFile, , Chunk()
    Next i
    Close DataFile
    Rs.Close: Qd.Close
    Set Qd = Nothing
    
    FileName = App.Path & "\pictemp.tif"

    If FileName = "" Then Exit Sub
    
    Dim P As Single
    Dim F As IPictureDisp
    
    Set F = LoadPicture(FileName)
    
    P = picFoto.Width / F.Width
    If Int(F.Width * P) > picFoto.Width Then
        P = picFoto.Height / F.Height
    End If
    If Int(F.Height * P) > picFoto.Height Then
        P = picFoto.Height / F.Height
    End If
    
    picFoto.Cls
    picFoto.PaintPicture F, 0, 0, F.Width * P, F.Height * P

end Sub