Solved

save contents of unbound object as image file

Posted on 2002-07-18
13
329 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 50

Expert Comment

by:Ryan Chong
ID: 7164228
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
ID: 7166057
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 50

Expert Comment

by:Ryan Chong
ID: 7168674
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
Ransomware: The New Cyber Threat & How to Stop It

This infographic explains ransomware, type of malware that blocks access to your files or your systems and holds them hostage until a ransom is paid. It also examines the different types of ransomware and explains what you can do to thwart this sinister online threat.  

 

Author Comment

by:kmuntz
ID: 7168706
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 50

Expert Comment

by:Ryan Chong
ID: 7168713
Sorry about that, will try manage it with APIs..
0
 
LVL 50

Expert Comment

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

planetsourcecode.com
vbcode.com
freevbcode.com
0
 
LVL 50

Expert Comment

by:Ryan Chong
ID: 7168724
0
 
LVL 50

Expert Comment

by:Ryan Chong
ID: 7173662
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
ID: 7174126
I don't have VB installed, so I really need a solution using Access alone.
0
 
LVL 50

Expert Comment

by:Ryan Chong
ID: 7179594
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 50

Expert Comment

by:Ryan Chong
ID: 7179595
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
ID: 7281507

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
ID: 7315396
This question will be placed in PAQ and points refunded.

Best regards,
ComTech
Community Support
Administrator @ EE
0

Featured Post

Complete VMware vSphere® ESX(i) & Hyper-V Backup

Capture your entire system, including the host, with patented disk imaging integrated with VMware VADP / Microsoft VSS and RCT. RTOs is as low as 15 seconds with Acronis Active Restore™. You can enjoy unlimited P2V/V2V migrations from any source (even from a different hypervisor)

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

QuickBooks® has a great invoice interface that we were happy with for a while but that changed in 2001 through no fault of Intuit®. Our industry's unit names are dictated by RUS: the Rural Utilities Services division of USDA. Contracts contain un…
Overview: This article:       (a) explains one principle method to cross-reference invoice items in Quickbooks®       (b) explores the reasons one might need to cross-reference invoice items       (c) provides a sample process for creating a M…
Familiarize people with the process of utilizing SQL Server views from within Microsoft Access. Microsoft Access is a very powerful client/server development tool. One of the SQL Server objects that you can interact with from within Microsoft Access…
In Microsoft Access, learn how to “cascade” or have the displayed data of one combo control depend upon what’s entered in another. Base the dependent combo on a query for its row source: Add a reference to the first combo on the form as criteria i…

809 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