Solved

save contents of unbound object as image file

Posted on 2002-07-18
13
295 Views
Last Modified: 2007-12-19
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.
0
Comment
Question by:kmuntz
13 Comments
 
LVL 49

Expert Comment

by:Ryan Chong
Comment Utility
After you pasting the image to an unboud object control, try use the SavePicture function to save the file.

regards
0
 

Author Comment

by:kmuntz
Comment Utility
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.
0
 
LVL 49

Expert Comment

by:Ryan Chong
Comment Utility
The SavePicture function should be include in Access VBA as it's a general VB function.

Example:
http://www.vbtt.com/tips/working_with_the_savepicture_function.html

* If not still not working please let me know, thanks.
0
 

Author Comment

by:kmuntz
Comment Utility
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.
0
 
LVL 49

Expert Comment

by:Ryan Chong
Comment Utility
Sorry about that, will try manage it with APIs..
0
 
LVL 49

Expert Comment

by:Ryan Chong
Comment Utility
For faster result, you can do a quick search on the website below as well:

planetsourcecode.com
vbcode.com
freevbcode.com
0
Complete Microsoft Windows PC® & Mac Backup

Backup and recovery solutions to protect all your PCs & Mac– on-premises or in remote locations. Acronis backs up entire PC or Mac with patented reliable disk imaging technology and you will be able to restore workstations to a new, dissimilar hardware in minutes.

 
LVL 49

Expert Comment

by:Ryan Chong
Comment Utility
0
 
LVL 49

Expert Comment

by:Ryan Chong
Comment Utility
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:
http://msdn.microsoft.com/vbasic/downloads/updates.asp

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.


regards,
ryancys
0
 

Author Comment

by:kmuntz
Comment Utility
I don't have VB installed, so I really need a solution using Access alone.
0
 
LVL 49

Expert Comment

by:Ryan Chong
Comment Utility
Hi kmuntz,

<Note>:
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:
http://developer.intel.com/software/products/perflib/ijl/index.htm

3. Or Try find an example from freevbcode.com named: OneClickGrab which content the Intel's ijl15.dll.
</Note>

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
Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    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:
Private m_tBI As BITMAPINFO
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
Dim tBMP As BITMAP
   
    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
    ClearUp
    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
        Else
            DeleteObject m_hDC
            m_hDC = 0
        End If
    End If
End Function

'----------------------------------------------------
0
 
LVL 49

Expert Comment

by:Ryan Chong
Comment Utility
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.
' http://developer.intel.com/software/products/perflib/ijl/index.htm
'
' ==================================================================================

Private Enum IJLERR
  IJL_OK = 0
End Enum

Private Enum IJLIOTYPE
    ''// Write an entire JFIF bit stream.
  IJL_JFILE_WRITEWHOLEIMAGE = 8&
End Enum
Private Type JPEG_CORE_PROPERTIES_VB
  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 tJ As JPEG_CORE_PROPERTIES_VB
    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
        Else
            ' Throw error
            MsgBox "Failed to save to JPG", vbExclamation
        End If
        ' Ensure we have freed memory:
        ijlFree tJ
        Else
        ' 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!"
    Else
        MsgBox "Failed!"
    End If
   
    DoEvents
   
    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.

regards,
ryancys
0
 
LVL 54

Expert Comment

by:nico5038
Comment Utility

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.

PLEASE DO NOT ACCEPT THIS COMMENT AS AN ANSWER !

Nic;o)
0
 

Accepted Solution

by:
ComTech earned 0 total points
Comment Utility
This question will be placed in PAQ and points refunded.

Best regards,
ComTech
Community Support
Administrator @ EE
0

Featured Post

6 Surprising Benefits of Threat Intelligence

All sorts of threat intelligence is available on the web. Intelligence you can learn from, and use to anticipate and prepare for future attacks.

Join & Write a Comment

In Debugging – Part 1, you learned the basics of the debugging process. You learned how to avoid bugs, as well as how to utilize the Immediate window in the debugging process. This article takes things to the next level by showing you how you can us…
In a multiple monitor setup, if you don't want to use AutoCenter to position your popup forms, you have a problem: where will they appear?  Sometimes you may have an additional problem: where the devil did they go?  If you last had a popup form open…
What’s inside an Access Desktop Database. Will look at the basic interface, Navigation Pane (Database Container), Tables, Queries, Forms, Report, Macro’s, and VBA code.
In Microsoft Access, learn different ways of passing a string value within a string argument. Also learn what a “Type Mis-match” error is about.

762 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

11 Experts available now in Live!

Get 1:1 Help Now