Solved

How to save and retrieve a SQL Server 7.0 BOLOB photo field.

Posted on 2001-06-21
3
307 Views
Last Modified: 2013-11-19
I read Microsoft advices in saving and retrieving photo fields in VB using appendchunck and getchunck functions but I failed to make it work, a typical guranteed-working example would be useful. I don't wanna use data control, all are unbounded controls and the receiving control is a standard picture box.
0
Comment
Question by:profya
3 Comments
 
LVL 6

Expert Comment

by:sharmon
Comment Utility
I just answered this for someone else, you can use the chunk method, but I like the stream object better.  As long as you can use ADO 2.5 or higher this is how you can do it.

This will read a steam from the database and store it as a file...replace d:\tmp.pic with whatever suits
you.

If IsNull(rs.Fields("Photo").Value) Then
   Picture1.Picture = LoadPicture()
Else
   Dim adoStream As New ADODB.Stream
   adoStream.Type = adTypeBinary
   adoStream.Open
   adoStream.Write rs.Fields("Photo").Value
   adoStream.SaveToFile "d:\tmp.pic", adSaveCreateOverWrite
   Picture1.Picture = LoadPicture("d:\tmp.pic")
   adoStream.Close
   Set adoStream = Nothing
End If

If you want to write an image to the database you can use this...if you need to save your picturebox
to a file first you can, but it will save as a bitmap and it will be alot bigger than a jpg or gif,
so I would recommend grabbing the jpg or gif from the file instead of writing out the bitmap to the
disk.

Dim adoStream As New ADODB.Stream

adoStream.Type = adTypeBinary
adoStream.Open
adoStream.LoadFromFile "d:\4.jpg"  'replace with your file

rs.AddNew
rs.Fields("Photo").Value = adoStream.Read
rs.Update

adoStream.Close
Set adoStream = Nothing
0
 
LVL 18

Accepted Solution

by:
deighton earned 20 total points
Comment Utility
Private Sub Command2_Click()

    'save the picture specified in text 1 to the database
   
    Dim sTemp As String

    Dim rs As New ADODB.Recordset
    Dim b() As Byte
    Dim lmax As Long

    rs.Open "select max(lindex) as zz from tblobject", gADOconn, adOpenStatic, adLockReadOnly
    If rs.EOF Then
        lmax = 1
    Else
        lmax = rs!zz + 1
    End If
    rs.Close
   
    rs.Open "tblObject", gADOconn, adOpenKeyset, adLockOptimistic

    Open Text1 For Binary As #1
    sTemp = String(LOF(1), 0)
    ReDim b(0 To LOF(1) - 1)
    Get #1, , b()
    Close #1
   
    rs.AddNew
    rs("obj").AppendChunk b
    Print rs("obj").ActualSize
    rs("lindex") = lmax
    rs.Update
   
    rs.Close


End Sub


'how to retrieve & display a picture from a database

Option Explicit

Private Sub Command1_Click()

    Dim rs As New ADODB.Recordset
    Dim b() As Byte
    Dim bb() As Byte
    Dim c As Long
   
    Dim sTemp As String
    'gADOconn
    rs.Open "Select obj from tblObject Where lindex = 999", gADOconn, adOpenForwardOnly, adLockOptimistic
   
    If Not rs.EOF Then
   
        b = rs!obj
       
        Picture1 = DerivePicture(b)
       
    End If
   
    rs.Close



End Sub

Option Explicit

Public gADOconn As ADODB.Connection

Sub main()

    Set gADOconn = New ADODB.Connection

    gADOconn.Provider = "Microsoft.Jet.Oledb.4.0"
    gADOconn.Open ("e:\vbexperimental\db1.mdb")

    frmView.Show
   
   
End Sub

Option Explicit
'
' Copyright ? 1997-1999 Brad Martinez, http://www.mvps.org
'
' ============================================================================
' VB (and COM) recognize the following graphic files: BMP, DIB, GIF, JPG, WMF, EMF, ICO, CUR
' each containing the following propietary image file format signatures:
' (all IMGSIG_* and IMGTERM_* constants are user-defined)

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' BMP, DIB (bitmap):

'typedef struct tagBITMAPFILEHEADER {
'    WORD      bfType;   // "BM"
'    DWORD   bfSize;    // size of file, should match FRXITEMHDR*.dwSizeImage
'    WORD      bfReserved1;
'    WORD      bfReserved2;
'    DWORD   bfOffBits;
'} BITMAPFILEHEADER;

Public Const IMGSIG_BMPDIB = &H4D42   ' "BM" ('424D') WORD @ image offset 0

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' GIF:

' First 3 bytes is "GIF", next 3 bytes is version, '87a', '89a', etc.

Public Const IMGSIG_GIF = &H464947   ' "GIF" ('4749 | 46') masked DWORD @ image offset 0
Public Const IMGTERM_GIF = &H3B      ' ";" (semicolon), WORD @ offset Len(image) - 1

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' JPG:

' SOI = Start Of Image = 'FFD8'
'   This marker must be present in any JPG file *once* at the beginning of the file.
'    (Any JPG file starts with the sequence FFD8.)
' EOI = End Of Image = 'FFD9'
'    Similar to EOI: any JPG file ends with FFD9.
' APP0 = it's the marker used to identify a JPG file which uses the JFIF specification = FFE0

' integers
Public Const IMGSIG_JPG = &HD8FF       ' ('FFD8') WORD @ offset image 0, may have APP0
Public Const IMGTERM_JPG = &HD9FF   ' ('FFD9') WORD @ offset Len(image) - 2

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' WMF, EMF:

' first try to read the DWORD enhanced metafile signature @ image offset 40 (&H28)
' (ENHMETAHEADER.dSignature member)

Public Const ENHMETA_SIGNATURE = &H464D4520   ' ('2045 | 4D46') " EMF" (in wingdi.h)

' If that fails, try to read the DWORD METAHEADER.mtSize member @ image offset 6
' (it should equal FRXITEMHDR*.dwSizeImage), and check mtHeaderSize too.

Public Type METAHEADER   ' mh
  mtType As Integer
  mtHeaderSize As Integer   ' Len(mh)
  mtVersion As Integer
  mtSize As Long   ' size of image
  mtNoObjects As Integer
  mtMaxRecord As Long
  mtNoParameters As Integer
End Type

' If that fails, read the 16bit Aldus Placeable metafile header key:

' "Q129658 SAMPLE: Reading and Writing Aldus Placeable Metafiles" or
' "Q66949: INFO: Windows Metafile Functions & Aldus Placeable Metafiles"
'typedef struct {
'    DWORD           dwKey;   // 0x9AC6CDD7
'    WORD              hmf;
'    SMALL_RECT  bbox;
'    WORD              wInch;
'    DWORD           dwReserved;
'    WORD              wCheckSum;
'} APMHEADER, *PAPMHEADER;  // APMFILEHEADER

Public Const IMGSIG_WMF_APM = &H9AC6CDD7   ' ('D7CD | C69A') DWORD @ image offset 0

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ICO, CUR:

' First check NEWHEADER.ResType, then, since there may be a discrepency in
' the cursor's CURSORDIRENTRY and CURSORDIR structs, read the NEWHEADER
' ResCount member, multiply that by Len(ICONDIRENTRY) (or 16 bytes) to find
' the BITMAPINFOHEADER, then read it's biSize member, which should be
' Len(BITMAPINFOHEADER) (or 40 bytes)

Public Const RES_ICON = 1
Public Const RES_CURSOR = 2

Public Type NEWHEADER   ' was ICONDIR (ICONHEADER?)
  Reserved As Integer   ' must be 0
  ResType As Integer    ' RES_ICON or RES_CURSOR
  ResCount As Integer   ' number of images (ICONDIRENTRYs) in the file (group)
End Type

'Public Type ICONDIRENTRY
'  bWidth As Byte                ' Width, in pixels, of the image
'  bHeight As Byte               ' Height, in pixels, of the image
'  bColorCount As Byte        ' Number of colors in image (0 if >=8bpp)
'  bReserved As Byte          ' Reserved ( must be 0)
'  wPlanes As Integer           ' Color Planes
'  wBitCount As Integer        ' Bits per pixel
'  dwBytesInRes As Long    ' How many bytes in this resource?
'  dwImageOffset As Long   ' Where in the file is this image?
'End Type
'
'Public Type CURSORDIRENTRY
'  ' The new CURSORDIR struct defines the first 4 Byte members instead as: (!!??)
''  wWidth As Integer
''  wHeight As Integer
'  bWidth As Byte                ' Width, in pixels, of the image
'  bHeight As Byte               ' Height, in pixels, of the image
'  bColorCount As Byte        ' Number of colors in image (0 if >=8bpp)
'  bReserved As Byte          ' Reserved ( must be 0)
'  wXHotspot As Integer      ' x-coordinate, in pixels, of the cursor hot spot.
'  wYHotspot As Integer      ' y-coordinate, in pixels, of the cursor hot spot.
'  dwBytesInRes As Long    ' How many bytes in this resource?
'  dwImageOffset As Long   ' Where in the file is this image?
'End Type

' user-defined struct sizes
Public Const SIZEOFDIRENTRY = 16
Public Const SIZEOFBITMAPINFOHEADER = 40

' assumes that NEWHEADER.Reserved is 0 (which it's supposed to be)
Public Const IMGSIG_ICO = &H10000      ' see above, DWORD @ image offset 0
Public Const IMGSIG_CUR = &H20000    ' see above, DWORD @ image offset 0

' ============================================================================
' VB FRX/CTX/DSX/DOX/PGX binary file item header formats:

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' TexBox.Text when Multiline = True has WORD text size value

Public Type FRXITEMHDRW   ' fihw
  dwSizeText As Integer   ' size of text
End Type

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Label.Caption and VB3 frx has DWORD image/text size value

Public Type FRXITEMHDRDW   ' fihdw
  dwSizeImage As Long   ' size of image/text
End Type

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' VB intrinsic control StdPictures (other blobs?) use FRXITEMHDR

Public Type FRXITEMHDR   ' fih
  dwSizeImageEx As Long   ' = dwSizeImage + 8
  dwKey As Long                 ' &H746C "lt" ( | 6C74 | )
  dwSizeImage As Long       ' size of image (= dwSizeImageEx - 8)
End Type

' frx binary when Form.Icon is deleted in designtime:
'   0800 0000 6C74 0000 0000 0000   ....lt......  (just the FRXITEMHDR, no data)

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Comctl32.ocx, Mscomctl.ocx StdPictures (other blobs?) use FRXITEMHDREX

Public Type GUID    ' 16 bytes (128 bits)
  dwData1 As Long      ' 4 bytes
  wData2 As Integer     ' 2 bytes
  wData3 As Integer     ' 2 bytes
  abData4(7) As Byte   ' 8 bytes, zero based
End Type

Public Type FRXITEMHDREX   ' fihex, 28 bytes
  dwSizeImageEx As Long   ' = dwSizeImage + 24
  clsid As GUID                    ' CLSID_StdPicture, CLSID_?
  dwKey As Long                 ' &H746C "lt" ( | 6C74 | )
  dwSizeImage As Long       ' size of image (= dwSizeImageEx - 24)
End Type

Public Const FIH_Key = &H746C

' ============================================================================

Public Enum CBoolean   ' enum members are Long data types
  CFalse = 0
  CTrue = 1
End Enum

Public Const S_OK = 0    ' indicates successful HRESULT

'WINOLEAPI CreateStreamOnHGlobal(
'    HGLOBAL hGlobal,            // Memory handle for the stream object
'    BOOL fDeleteOnRelease,  // Whether to free memory when the object is released
'    LPSTREAM * ppstm           // Indirect pointer to the new stream object
');
Declare Function CreateStreamOnHGlobal Lib "ole32" _
                              (ByVal hGlobal As Long, _
                              ByVal fDeleteOnRelease As CBoolean, _
                              ppstm As Any) As Long

'STDAPI OleLoadPicture(
'    IStream * pStream,  // Pointer to the stream that contains picture's data
'    LONG lSize,            // Number of bytes read from the stream
'    BOOL fRunmode,   // The opposite of the initial value of the picture's property
'    REFIID riid,             // interface identifier describing the type of interface pointer to return
'    VOID ppvObj          // Indirect pointer to the object, not AddRef'd!!
');
Declare Function OleLoadPicture Lib "olepro32" _
                              (pStream As Any, _
                              ByVal lSize As Long, _
                              ByVal fRunmode As CBoolean, _
                              riid As GUID, _
                              ppvObj As Any) As Long

Declare Function CLSIDFromString Lib "ole32" (ByVal lpsz As Any, pclsid As GUID) As Long
Declare Function IsEqualGUID Lib "ole32" (rguid1 As GUID, rguid2 As GUID) As Boolean

Public Const sCLSID_StdPicture = "{0BE35204-8F91-11CE-9DE3-00AA004BB851}"
Public Const sIID_IPicture = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"

Public Const GMEM_MOVEABLE = &H2
Declare Function GlobalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal dwBytes As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long

Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)

' ============================================================================
' GetOpen/SaveFileName

Public Const MAX_PATH = 260

Public Type OPENFILENAME  '  ofn
  lStructSize As Long
  hWndOwner As Long
  hInstance As Long
  lpstrFilter As String
  lpstrCustomFilter As String
  nMaxCustFilter As Long
  nFilterIndex As Long
  lpstrFile As String
  nMaxFile As Long
  lpstrFileTitle As String
  nMaxFileTitle As Long
  lpstrInitialDir As String
  lpstrTitle As String
  Flags As OFN_Flags
  nFileOffset As Integer
  nFileExtension As Integer
  lpstrDefExt As String
  lCustData As Long
  lpfnHook As Long
  lpTemplateName As String
End Type

' File Open/Save Dialog Flags
Public Enum OFN_Flags
  OFN_READONLY = &H1
  OFN_OVERWRITEPROMPT = &H2
  OFN_HIDEREADONLY = &H4
  OFN_NOCHANGEDIR = &H8
  OFN_SHOWHELP = &H10
  OFN_ENABLEHOOK = &H20
  OFN_ENABLETEMPLATE = &H40
  OFN_ENABLETEMPLATEHANDLE = &H80
  OFN_NOVALIDATE = &H100
  OFN_ALLOWMULTISELECT = &H200
  OFN_EXTENSIONDIFFERENT = &H400
  OFN_PATHMUSTEXIST = &H800
  OFN_FILEMUSTEXIST = &H1000
  OFN_CREATEPROMPT = &H2000
  OFN_SHAREAWARE = &H4000
  OFN_NOREADONLYRETURN = &H8000&
  OFN_NOTESTFILECREATE = &H10000
  OFN_NONETWORKBUTTON = &H20000
  OFN_NOLONGNAMES = &H40000               ' force no long names for 4.x modules
  OFN_EXPLORER = &H80000                       ' new look commdlg
  OFN_NODEREFERENCELINKS = &H100000
  OFN_LONGNAMES = &H200000                 ' force long names for 3.x modules
  ' ===============================
  ' Win98/NT5 only...
  OFN_ENABLEINCLUDENOTIFY = &H400000           ' send include message to callback
  OFN_ENABLESIZING = &H800000
  ' ===============================
End Enum

Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
'

Public Function GetOpenFilePath(hWnd As Long, _
                                                      sFilter As String, _
                                                      iFilter As Integer, _
                                                      sFile As String, _
                                                      sInitDir As String, _
                                                      sTitle As String, _
                                                      sRtnPath As String) As Boolean
  Dim ofn As OPENFILENAME
 
  With ofn
    .lStructSize = Len(ofn)
    .hWndOwner = hWnd
    .lpstrFilter = sFilter & vbNullChar & vbNullChar
    .nFilterIndex = iFilter
    .lpstrFile = sFile & String$(MAX_PATH - Len(sFile), 0)
    .nMaxFile = MAX_PATH
    .lpstrInitialDir = sInitDir
    .lpstrTitle = sTitle & vbNullChar
    .Flags = OFN_HIDEREADONLY Or OFN_FILEMUSTEXIST Or OFN_EXPLORER
  End With
 
  If GetOpenFileName(ofn) Then
    iFilter = ofn.nFilterIndex
    sFile = Mid$(ofn.lpstrFile, ofn.nFileOffset + 1, InStr(ofn.lpstrFile, vbNullChar) - (ofn.nFileOffset + 1))
    sRtnPath = GetStrFromBufferA(ofn.lpstrFile)
    GetOpenFilePath = True
  End If

End Function

Public Function GetSaveFilePath(hWnd As Long, _
                                                      sFilter As String, _
                                                      iFilter As Integer, _
                                                      sDefExt As String, _
                                                      sFile As String, _
                                                      sInitDir As String, _
                                                      sTitle As String, _
                                                      sRtnPath As String) As Boolean
  Dim ofn As OPENFILENAME
  With ofn
    .lStructSize = Len(ofn)
    .hWndOwner = hWnd
    .lpstrFilter = sFilter & vbNullChar & vbNullChar
    .lpstrFile = sFile & String$(MAX_PATH - Len(sFile), 0)
    .lpstrDefExt = sDefExt
    .nMaxFile = MAX_PATH
    .lpstrInitialDir = sInitDir
    .lpstrTitle = sTitle & vbNullChar
    .Flags = OFN_HIDEREADONLY Or OFN_OVERWRITEPROMPT
  End With
 
  If GetSaveFileName(ofn) Then
    iFilter = ofn.nFilterIndex
    sFile = Mid$(ofn.lpstrFile, ofn.nFileOffset + 1, InStr(ofn.lpstrFile, vbNullChar) - (ofn.nFileOffset + 1))
    sRtnPath = GetStrFromBufferA(ofn.lpstrFile)
    GetSaveFilePath = True
  End If

End Function

' Returns the string before first null char (if any) in an ANSII string.

Public Function GetStrFromBufferA(szA As String) As String
  If InStr(szA, vbNullChar) Then
    GetStrFromBufferA = Left$(szA, InStr(szA, vbNullChar) - 1)
  Else
    ' If sz had no null char, the Left$ function
    ' above would rtn a zero length string ("").
    GetStrFromBufferA = szA
  End If
End Function

' Returns the low-order word from the given 32-bit value.

Public Function DerivePicture(b() As Byte) As StdPicture

   
    Set DerivePicture = PictureFromBits(b)
 
 
End Function

Public Function LOWORD(dwValue As Long) As Integer
  MoveMemory LOWORD, dwValue, 2
End Function

Public Function PictureFromBits(abPic() As Byte) As IPicture  ' not a StdPicture!!
  Dim nLow As Long
  Dim cbMem  As Long
  Dim hMem  As Long
  Dim lpMem  As Long
  Dim IID_IPicture As GUID
  Dim istm As stdole.IUnknown '  IStream
  Dim ipic As IPicture
 
  ' Get the size of the picture's bits
  On Error GoTo Out
  nLow = LBound(abPic)
  On Error GoTo 0
  cbMem = (UBound(abPic) - nLow) + 1
 
  ' Allocate a global memory object
  hMem = GlobalAlloc(GMEM_MOVEABLE, cbMem)
  If hMem Then
   
    ' Lock the memory object and get a pointer to it.
    lpMem = GlobalLock(hMem)
    If lpMem Then
     
      ' Copy the picture bits to the memory pointer and unlock the handle.
      MoveMemory ByVal lpMem, abPic(nLow), cbMem
      Call GlobalUnlock(hMem)
     
      ' Create an ISteam from the pictures bits (we can explicitly free hMem
      ' below, but we'll have the call do it here...)
      If (CreateStreamOnHGlobal(hMem, CTrue, istm) = S_OK) Then
        If (CLSIDFromString(StrPtr(sIID_IPicture), IID_IPicture) = S_OK) Then
         
          ' Create an IPicture from the IStream (the docs say the call does not
          ' AddRef its last param, but it looks like the reference counts are correct..)
          Call OleLoadPicture(ByVal ObjPtr(istm), cbMem, CFalse, IID_IPicture, PictureFromBits)
         
        End If   ' CLSIDFromString
      End If   ' CreateStreamOnHGlobal
    End If   ' lpMem
   
'    Call GlobalFree(hMem)
  End If   ' hMem
     
Out:
End Function
0
 
LVL 14

Author Comment

by:profya
Comment Utility
A lot of lines, but good.
0

Featured Post

What Is Threat Intelligence?

Threat intelligence is often discussed, but rarely understood. Starting with a precise definition, along with clear business goals, is essential.

Join & Write a Comment

Introduction While answering a recent question about filtering a custom class collection, I realized that this could be accomplished with very little code by using the ScriptControl (SC) library.  This article will introduce you to the SC library a…
Keep your audience engaged and get the most out of your next presentation with these quick Prezi tips.
Learn how to download your full Prezi presentation for offline presenting. Prezi doesn’t have to be viewed and shared in a web browser, even with a free account you can download your full presentation to share with others. Be sure to download any vi…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

743 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

16 Experts available now in Live!

Get 1:1 Help Now