Picture controls, Access Image controls, DIBS and BLOBs

[kentgorrell]

I had a wonderful time working out how to read and write BLOBs using GetChunk until I found the new streaming object in ADO 2.6 very easy.
Now I am confronted with DIBs
The code I have is VB6 but only partial so I can't actually run it. Anyhow I need to get it to work in Access but there are a couple of properties and methods of the picture control in VB6 that don't have corresponding ones in Access. Like TwipsPerPixel which I can just estimate at 15 but I have no idea what Picture.hDC is - can anyone tell me please.
Or if anyone has any working code for viewing DIBs that will work in VBA then that would be even better.

[fplesco]

I had a wonderful time working out how to read and write BLOBs using GetChunk until I found the new streaming object in ADO 2.6 very easy.
Now I am confronted with DIBs
The code I have is VB6 but only partial so I can't actually run it. Anyhow I need to get it to work in Access but there are a couple of properties and methods of the picture control in VB6 that don't have corresponding ones in Access. Like TwipsPerPixel which I can just estimate at 15 but I have no idea what Picture.hDC is - can anyone tell me please.
Or if anyone has any working code for viewing DIBs that will work in VBA then that would be even better.

Hi kentgorrell -

Can you try this VBA code?

Make an MS Access table called "EmpTable" or any name you want
And make this fields

EmpID Text
FullName Text
EmpPicture OLE Object

Dim Con As Connection
Dim Rs As Recordset
 
Private Sub cmdBrowse_Click()
    txtPath = BrowsePicture
        If txtPath <> "" Then
        Image1.PictureSizeMode = fmPictureSizeModeStretch
        Image1.Picture = LoadPicture("")
        Image1.Picture = LoadPicture(txtPath)
    Else
        Image1.Picture = LoadPicture("")
    End If
End Sub
 
Public Function BrowsePicture() As String
Dim FileLocation As String
    Excel.Application.Dialogs.Application.FileDialog(msoFileDialogOpen).Title = "Select Employee Picture"
    Excel.Application.Dialogs.Application.FileDialog(msoFileDialogOpen).Show
    FileLocation = Excel.Application.Dialogs.Application.FileDialog(msoFileDialogOpen).InitialFileName
 
    FileLocation = Excel.Application.Dialogs.Application.FileDialog(msoFileDialogOpen).SelectedItems.Item(1)
    'Set FS = CreateObject("Scripting.FileSystemObject")
    'Set A = FS.OpenTextFile(FileLocation, 1, False) '"c:\COMFILE.txt"
    If LCase(Right(FileLocation, 4)) <> ".jpg" And _
       LCase(Right(FileLocation, 4)) <> ".bmp" And _
       LCase(Right(FileLocation, 4)) <> ".gif" Then
        MsgBox "Invalid picture selection.", vbCritical, "Saving BLOB"
        Exit Function
    End If
    BrowsePicture = FileLocation
End Function
 
Private Sub cmdSave_Click()
If cmdSave.Caption = "New Record" Then
    cmdSave.Caption = "Save Record"
    txtPath.Enabled = True
    ClearText
Else
    SavePic
    txtPath.Enabled = False
    ClearText
    cmdSave.Caption = "New Record"
End If
End Sub
 
Public Sub ClearText()
    txtFullname = ""
    txtID = ""
End Sub
Private Sub cmdShow_Click()
Dim ProvSSN As String
Dim SavePath As String
Dim PicEdit As Picture
Dim strtmpFilename As String
On Error GoTo ErrHandler
    txtPath = ""
    strtmpFilename = IIf(txtPath <> "", txtPath, "C:\tmpPic.jpg")
    Set Con = New Connection
    Con.Open "SavePicture"
    Set Rs = New Recordset
    Rs.ActiveConnection = Con
    Rs.Open "Select * from EmpTable where EmpID = '" & txtID & "'", Con, adOpenKeyset, adLockOptimistic
    If Rs.EOF Then
        Image1.Picture = LoadPicture("")
        Me.Caption = "Saving and Retrieving BLOB"
        MsgBox "No record found.", vbInformation, "Saving BLOB"
        Exit Sub
    End If
    Rs.MoveFirst
    Me.Caption = Rs!FullName
    txtFullname = Me.Caption
    Image1.Picture = LoadPicture("")
    Call BintoFile(strtmpFilename, Rs.Fields("EmpPicture"))
    'If Rs.Fields("EmpPicture").Type = adLongVarBinary Then
     Image1.Picture = LoadPicture(strtmpFilename)
    'Else
        'Me.Caption = "Saving and Retrieving BLOB"
    'End If
    Image1.PictureSizeMode = fmPictureSizeModeStretch
    'Remove any existing destination file
    If Len(Dir$(strtmpFilename)) > 0 Then
       Kill strtmpFilename
    End If
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbCritical, "Saving BLOB"
End Sub
 
Private Sub BintoFile(sFileName As String, fld As Field)
Dim bBuffer() As Byte
Dim ChunkSize As Long
Dim Chunks As Long
Dim Fl As Long
Dim Fragment As Long
Dim Chunk() As Byte
 
    'Recreate a new file
    Open sFileName For Binary As #1
    'Use a 32K initial chuck size
    ChunkSize = 16384
    Fl = fld.ActualSize
    Chunks = Fl \ ChunkSize
    Fragment = Fl Mod ChunkSize
   ' Resize the byte array Chunk to the size of the fraction of a chunk calced above
    ReDim Chunk(Fragment)
   ' Get this fraction first and output it to the binary file
    Chunk() = fld.GetChunk(Fragment)
    Put #1, , Chunk()
    For i = 1 To Chunks
       ReDim Buffer(ChunkSize)
       Chunk() = fld.GetChunk(ChunkSize)
       Put #1, , Chunk()
    Next i
    Close #1
End Sub
 
Public Function SavePic()
Dim b() As Byte, f As Long, fn As String
On Error GoTo ErrHandler
    Set Con = New Connection
    Con.Open "SavePicture"
    f = FreeFile()
    fn = txtPath
    Open fn For Binary Access Read As #f
    ReDim b(FileLen(fn) - 1)
    Get #f, , b()
    Set Rs = New Recordset
    Set Rs.ActiveConnection = Con
    Rs.Open "Select * from EmpTable", Con, adOpenDynamic, adLockOptimistic
    Rs.AddNew
    Rs("EmpID") = txtID
    Rs("Fullname") = txtFullname
    Rs("EmpPicture") = b()
    Rs.Update
    Close #f
    txtPath = ""
    MsgBox "Record has been saved.", vbInformation, "Saving BLOB"
    Exit Function
ErrHandler:
    MsgBox Err.Description, vbCritical, "Saving BLOB"
End Function
 
Private Sub txtPath_Change()
 
End Sub
 
Private Sub UserForm_Activate()
    Me.Caption = "Saving and Retrieving BLOB"
End Sub
 
 

Note: SavePicture is the name of my ODBC, if you want... replace it with a connection string.

I apologize if I can't give a detail on this but, i will attach, snapshots for a better understanding of this program and a bit of a clue.

Oh, sorry, can I insert images here? I think, there's no way for me to do that.

If you cant get the codes running, just give me your email and i will send you the snapshots.

Godspeed.

[kentgorrell]

Thanks for that - it helped to clarify what was happening with the reading in and out of the BLOB using GetChunk but it didn't help with the DIB specific display, specifically this line -
DrawDibDraw(hDibOpen, Picture1.hDC, 0, 0, xSize, ySize, BInfoHeader, ByVal pMem, 0, 0, BInfoHeader.biWidth, BInfoHeader.biHeight, 0)
That uses the picture.hDC that is in VB6 but not in Access VBA
Do you know what this is, or if there is an Access equivalent?