save contents of unbound object as image file

I have a situation where the user has an image in the clipboard which he wants to save as a jpg file using a particular naming convention to map it to a particular patient, In my Access app, that patient's details are showing on the screen, so I have all the information needed to construct the file name. My problem is how do I save the contents of the clipboard to a file? I can get the user to paste the contents to an unbound object control, but I still can't figure out how to save this as a file.
Who is Participating?
ComTechConnect With a Mentor Commented:
This question will be placed in PAQ and points refunded.

Best regards,
Community Support
Administrator @ EE
Ryan ChongCommented:
After you pasting the image to an unboud object control, try use the SavePicture function to save the file.

kmuntzAuthor Commented:
I can't find SavePicture in the VB help. How exactly would I do this. I presume the code would go in the OnUpdated event of the object control.
Never miss a deadline with

The revolutionary project management tool is here!   Plan visually with a single glance and make sure your projects get done.

Ryan ChongCommented:
The SavePicture function should be include in Access VBA as it's a general VB function.


* If not still not working please let me know, thanks.
kmuntzAuthor Commented:
I'm using Access 2000 and there is definitely no SavePicture command. Searching the help for both Access and VB within Access does not find anything. I think this applies only to a Visual Basic picture box, which does not seem to be available in Access.
Ryan ChongCommented:
Sorry about that, will try manage it with APIs..
Ryan ChongCommented:
For faster result, you can do a quick search on the website below as well:
Ryan ChongCommented:
Hi kmuntz,

Have you got a solution?

* The example below only works if VB installed.

Example: Save an image from the Image Control to a specify directory:

Option Compare Database

Private Sub Command1_Click()
    Dim ip As New PictureClip
    Set ip.Picture = LoadPicture(Image1.Picture)
    SavePicture ip.Picture, "C:\test.bmp"
End Sub

* Code tested on my system: VB6, M$ Access 2000, Win2k Advanced Server.

The reason why you can't use the SavePicture function is because the function itself only available in 'VB' Library (Visual Basic Objects and Procedures Library?). You're correct, so that's why you can't find this function where VB is Not installed.

By the way, You need to get the VBRuntimes in order to make the code works. Download the runtimes at:

For the moment, will try find another workaround. Actually now review some materials on create a jpg file without using SavePicture function. May give a feedback on this Friday.

kmuntzAuthor Commented:
I don't have VB installed, so I really need a solution using Access alone.
Ryan ChongCommented:
Hi kmuntz,

1. This example needs 1 module, 1 class module (named as cDIBSection) and a dll (ijl15.dll) to enable it to work properly.

2. Try download and register the ijl15.dll which required to your system, you can get it at:

3. Or Try find an example from named: OneClickGrab which content the Intel's ijl15.dll.

First, create a Class Module and name it as cDIBSection in Your Access Visual Basic Editor (Module):

The code is like this:

Option Explicit
' ==================================================================================
' Requires:    mIJLmod.cls
'              ijl15.dll (Intel)
' ==================================================================================

Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type
Private Type BITMAPINFOHEADER '40 bytes
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type
    bmiColors As RGBQUAD
End Type
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function CreateDIBSection Lib "gdi32" _
    (ByVal hdc As Long, _
    pBitmapInfo As BITMAPINFO, _
    ByVal un As Long, _
    lplpVoid As Long, _
    ByVal handle As Long, _
    ByVal dw As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Const BI_RGB = 0&
Private Const BI_RLE4 = 2&
Private Const BI_RLE8 = 1&
Private Const DIB_RGB_COLORS = 0 '  color table in RGBs
Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long

' Handle to the current DIBSection:
Private m_hDIb As Long
' Handle to the old bitmap in the DC, for clear up:
Private m_hBmpOld As Long
' Handle to the Device context holding the DIBSection:
Private m_hDC As Long
' Address of memory pointing to the DIBSection's bits:
Private m_lPtr As Long
' Type containing the Bitmap information:
Public Property Get BytesPerScanLine() As Long
    ' Scans must align on dword boundaries:
    BytesPerScanLine = (m_tBI.bmiHeader.biWidth * 3 + 3) And &HFFFFFFFC
End Property
Public Property Get Width() As Long
    Width = m_tBI.bmiHeader.biWidth
End Property
Public Property Get Height() As Long
    Height = m_tBI.bmiHeader.biHeight
End Property
Public Sub LoadPictureBlt( _
        ByVal lhDC As Long, _
        Optional ByVal lSrcLeft As Long = 0, _
        Optional ByVal lSrcTop As Long = 0, _
        Optional ByVal lSrcWidth As Long = -1, _
        Optional ByVal lSrcHeight As Long = -1, _
        Optional ByVal eRop As RasterOpConstants = vbSrcCopy _
    If lSrcWidth < 0 Then lSrcWidth = m_tBI.bmiHeader.biWidth
    If lSrcHeight < 0 Then lSrcHeight = m_tBI.bmiHeader.biHeight
    BitBlt m_hDC, 0, 0, lSrcWidth, lSrcHeight, lhDC, lSrcLeft, lSrcTop, eRop
End Sub
Public Property Get DIBSectionBitsPtr() As Long
    DIBSectionBitsPtr = m_lPtr
End Property
Public Sub ClearUp()
    If (m_hDC <> 0) Then
        If (m_hDIb <> 0) Then
            SelectObject m_hDC, m_hBmpOld
            DeleteObject m_hDIb
        End If
        DeleteObject m_hDC
    End If
    m_hDC = 0: m_hDIb = 0: m_hBmpOld = 0: m_lPtr = 0
End Sub
Public Function CreateFromPicture( _
        ByRef picThis As StdPicture _
Dim lhDC As Long
Dim lhDCDesktop As Long
Dim lhBmpOld As Long
    GetObjectAPI picThis.handle, Len(tBMP), tBMP
    If (Create(tBMP.bmWidth, tBMP.bmHeight)) Then
        lhDCDesktop = GetDC(GetDesktopWindow())
        If (lhDCDesktop <> 0) Then
            lhDC = CreateCompatibleDC(lhDCDesktop)
            DeleteDC lhDCDesktop
            If (lhDC <> 0) Then
                lhBmpOld = SelectObject(lhDC, picThis.handle)
                LoadPictureBlt lhDC
                SelectObject lhDC, lhBmpOld
                DeleteObject lhDC
            End If
        End If
    End If
End Function
Public Function CreateDIB( _
        ByVal lhDC As Long, _
        ByVal lWidth As Long, _
        ByVal lHeight As Long, _
        ByRef hDib As Long _
    ) As Boolean
    With m_tBI.bmiHeader
        .biSize = Len(m_tBI.bmiHeader)
        .biWidth = lWidth
        .biHeight = lHeight
        .biPlanes = 1
        .biBitCount = 24
        .biCompression = BI_RGB
        .biSizeImage = BytesPerScanLine * .biHeight
    End With
    hDib = CreateDIBSection( _
            lhDC, _
            m_tBI, _
            DIB_RGB_COLORS, _
            m_lPtr, _
            0, 0)
    CreateDIB = (hDib <> 0)
End Function
Public Function Create( _
        ByVal lWidth As Long, _
        ByVal lHeight As Long _
    ) As Boolean
    m_hDC = CreateCompatibleDC(0)
    If (m_hDC <> 0) Then
        If (CreateDIB(m_hDC, lWidth, lHeight, m_hDIb)) Then
            m_hBmpOld = SelectObject(m_hDC, m_hDIb)
            Create = True
            DeleteObject m_hDC
            m_hDC = 0
        End If
    End If
End Function

Ryan ChongCommented:
Then, add a module in your Visual Basic Editor as below:

Option Explicit
' ==================================================================================
' Requires:    cDIBSectionmod.cls
'              ijl15.dll (Intel)
' An interface to Intel's IJL (Intel JPG Library) for use in VB.
' ==================================================================================

Private Enum IJLERR
  IJL_OK = 0
End Enum

Private Enum IJLIOTYPE
    ''// Write an entire JFIF bit stream.
End Enum
  UseJPEGPROPERTIES As Long                      '// default = 0

  '// DIB specific I/O data specifiers.
  DIBBytes As Long ';                  '// default = NULL 4
  DIBWidth As Long ';                  '// default = 0 8
  DIBHeight As Long ';                 '// default = 0 12
  DIBPadBytes As Long ';               '// default = 0 16
  DIBChannels As Long ';               '// default = 3 20
  DIBColor As Long ';                  '// default = IJL_BGR 24
  DIBSubsampling As Long  ';            '// default = IJL_NONE 28

  '// JPEG specific I/O data specifiers.
  JPGFile As Long 'LPTSTR              JPGFile;                32   '// default = NULL
  JPGBytes As Long ';                  '// default = NULL 36
  JPGSizeBytes As Long ';              '// default = 0 40
  JPGWidth As Long ';                  '// default = 0 44
  JPGHeight As Long ';                 '// default = 0 48
  JPGChannels As Long ';               '// default = 3
  JPGColor As Long           ';                  '// default = IJL_YCBCR
  JPGSubsampling As Long  ';            '// default = IJL_411
  JPGThumbWidth As Long ' ;             '// default = 0
  JPGThumbHeight As Long ';            '// default = 0

  '// JPEG conversion properties.
  cconversion_reqd As Long ';          '// default = TRUE
  upsampling_reqd As Long ';           '// default = TRUE
  jquality As Long ';                  '// default = 75.  90 is my preferred quality setting.

  '// Low-level properties - 20,000 bytes.  If the whole structure
  ' is written out then VB fails with an obscure error message
  ' "Too Many Local Variables" !
  ' These all default if they are not otherwise specified so there
  ' is no trouble.
  jprops(0 To 19999) As Byte

End Type

Private Declare Function ijlInit Lib "ijl15.dll" (jcprops As Any) As Long
Private Declare Function ijlFree Lib "ijl15.dll" (jcprops As Any) As Long
Private Declare Function ijlWrite Lib "ijl15.dll" (jcprops As Any, ByVal ioType As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)

Public Function SaveJPG(ByRef cDib As cDIBSection, ByVal sFile As String, Optional ByVal lQuality As Long = 90) As Boolean
    Dim bFile() As Byte
    Dim lPtr As Long
    Dim lR As Long
    lR = ijlInit(tJ)
    If lR = IJL_OK Then
        ' Set up the DIB information:
        ' Store DIBWidth:
        tJ.DIBWidth = cDib.Width
        ' Store DIBHeight:
        tJ.DIBHeight = -cDib.Height
        ' Store DIBBytes (pointer to uncompressed JPG data):
        tJ.DIBBytes = cDib.DIBSectionBitsPtr
        ' Very important: tell IJL how many bytes extra there
        ' are on each DIB scan line to pad to 32 bit boundaries:
        tJ.DIBPadBytes = cDib.BytesPerScanLine - cDib.Width * 3
        ' Set up the JPEG information:
        ' Store JPGFile:
        bFile = StrConv(sFile, vbFromUnicode)
        ReDim Preserve bFile(0 To UBound(bFile) + 1) As Byte
        bFile(UBound(bFile)) = 0
        lPtr = VarPtr(bFile(0))
        CopyMemory tJ.JPGFile, lPtr, 4
        ' Store JPGWidth:
        tJ.JPGWidth = cDib.Width
        ' .. & JPGHeight member values:
        tJ.JPGHeight = cDib.Height
        ' Set the quality/compression to save:
        tJ.jquality = lQuality
        ' Write the image:
        lR = ijlWrite(tJ, IJL_JFILE_WRITEWHOLEIMAGE)
        If lR = IJL_OK Then
            SaveJPG = True
            ' Throw error
            MsgBox "Failed to save to JPG", vbExclamation
        End If
        ' Ensure we have freed memory:
        ijlFree tJ
        ' Throw error:
        MsgBox "Failed to initialise the IJL library: " & lR, vbExclamation
    End If
 End Function


Then add this to your Form's Module:

Private Sub SaveItAsPicture(ByRef picSource As PictureBox, ByVal fileName As String)
    Dim fname As String
    Dim c As New cDIBSection
    c.CreateFromPicture picSource.Picture
    If SaveJPG(c, fileName, 90) Then
        MsgBox "Success!"
        MsgBox "Failed!"
    End If
    Set c = Nothing
End Sub

Use it like: SaveItAsPicture picSource, fileToSave

This may not be the best solution as a dll is required to make the code above working, but at least we can totally remove the SavePicture function from code.


No comment has been added lately, so it's time to clean up this TA.
I will leave a recommendation in the Cleanup topic area that this question is:
 - PAQ'd and pts removed
Please leave any comments here within the
next seven days.


All Courses

From novice to tech pro — start learning today.