Want to win a PS4? Go Premium and enter to win our High-Tech Treats giveaway. Enter to Win

x
?
Solved

JPEG Compression

Posted on 2004-10-25
9
Medium Priority
?
6,151 Views
Last Modified: 2013-11-19
Hello experts! I need again your help!

I use the following code to save the contents of a picture box onto a JPG file:

SavePicture Picture1.Image, "C:/image.jpg"

I want to know how to control the compression level (quality) of the JPG file, because the generated one is too big.

I found some examples for VB.NET, but nothing in VB6. I appreciate any help!

Thanks!
0
Comment
Question by:HyMaX_2003
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 3
  • 2
  • 2
  • +1
9 Comments
 
LVL 86

Expert Comment

by:Mike Tomlinson
ID: 12401552
Hi HyMax_2003,

I hate to bust your bubble, but the SavePicture() function doesn't save in JPG format.  What you actually have after the operation is a BMP file with a JPG extension (because that is the name you gave it).

From the remarks on SavePicture():

If a graphic was loaded from a file to the Picture property of an object, either at design time or at run time, and it’s a bitmap, icon, metafile, or enhanced metafile, it's saved using the same format as the original file. If it is a GIF or JPEG file, it is saved as a bitmap file.

Graphics in an Image property are always saved as bitmap (.bmp) files regardless of their original format.

~IM
0
 
LVL 16

Expert Comment

by:jimbobmcgee
ID: 12401557
I think the SavePicture routine only saves to BMP, despite your filename being .JPG

You could probably use GDI+ to save to .JPG...
       http://msdn.microsoft.com/library/default.asp?url=/library/en-us/gdicpp/gdiplus/gdiplus.asp
0
 
LVL 16

Expert Comment

by:jimbobmcgee
ID: 12401573
IM:

Beat me to it again...!!

:)
0
Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
LVL 86

Expert Comment

by:Mike Tomlinson
ID: 12401585
Well, at least you gave an alternative solution.

I was just the bringer of bad news...

~IM
0
 
LVL 86

Expert Comment

by:Mike Tomlinson
ID: 12401601
Here is another PAQ with lots of great links and resources on image resizing/manipulation:
http://www.experts-exchange.com/Programming/Programming_Languages/Visual_Basic/Q_21118795.html

~IM
0
 
LVL 1

Author Comment

by:HyMaX_2003
ID: 12401767
OK GDI sounds cool!
(I'm still laughing with the 'I was just the bringer of bad news...') :)

This code looks good, but the image is TOO smooth, and the size of the file is still too big:



'-----
Form frmMain
'-----
Option Explicit

Dim token As Long ' Needed to close GDI+

Private Sub Form_Load()
   Dim sFile As String
   ' Load the GDI+ Dll
   Dim GpInput As GdiplusStartupInput
   GpInput.GdiplusVersion = 1
   If GdiplusStartup(token, GpInput) <> Ok Then
      MsgBox "Error loading GDI+!", vbCritical
      Unload Me
   End If
   Me.Show
   sFile = InputBox("Image File", , "D:\_UnicodeScreenShots\UniGrid3.bmp")
   Me.Refresh
   DrawThumbnail sFile, 128, 128 '(BrowseFolder("Select image file"))
End Sub

Private Sub Form_Unload(Cancel As Integer)
   ' Unload the GDI+ Dll
   Call GdiplusShutdown(token)
End Sub


Private Sub DrawThumbnail(ByVal sFile As String, ByVal lngThumbWidth As Long, ByVal lngThumbHeight As Long)
   
   Dim graphics As Long
   Dim img As Long
   Dim imgThumb As Long
   Dim encoderCLSID As CLSID

   ' Initializations
   GdipCreateFromHDC Me.hdc, graphics  ' Initialize the graphics class - required for all drawing
   GdipLoadImageFromFile StrConv(sFile, vbUnicode), img     ' Load the image
   
   ' Create the thumbnail
   GdipGetImageThumbnail img, lngThumbWidth, lngThumbHeight, imgThumb

   ' Draw the thumbnail image unaltered
   GdipDrawImageRectI graphics, imgThumb, 10, 10, lngThumbWidth, lngThumbHeight
   
   ' Get the CLSID of the PNG encoder
   GetEncoderClsid "image/png", encoderCLSID

   ' Save as a PNG file. There are no encoder parameters for PNG images, so we pass a NULL.
   GdipSaveImageToFile imgThumb, StrConv(App.Path & "\Thumb.png", vbUnicode), encoderCLSID, ByVal 0

   ' Cleanup
   GdipDisposeImage img   ' Delete the image
   GdipDisposeImage imgThumb   ' Delete the thumbnail image
   GdipDeleteGraphics graphics
End Sub

'-----
Module modGDIPlusAPI
'-----
Option Explicit

Public Declare Function CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Src As Any, ByVal cb As Long) As Long
Private Declare Function lstrlenW Lib "kernel32" (ByVal psString As Any) As Long

Public Type GdiplusStartupInput
   GdiplusVersion As Long              ' Must be 1 for GDI+ v1.0, the current version as of this writing.
   DebugEventCallback As Long          ' Ignored on free builds
   SuppressBackgroundThread As Long    ' FALSE unless you're prepared to call
                                       ' the hook/unhook functions properly
   SuppressExternalCodecs As Long      ' FALSE unless you want GDI+ only to use
                                       ' its internal image codecs.
End Type

Public Type CLSID
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(0 To 7) As Byte
End Type

Public Type ImageCodecInfo
   ClassID As CLSID
   FormatID As CLSID
   CodecName As Long      ' String Pointer; const WCHAR*
   DllName As Long        ' String Pointer; const WCHAR*
   FormatDescription As Long ' String Pointer; const WCHAR*
   FilenameExtension As Long ' String Pointer; const WCHAR*
   MimeType As Long       ' String Pointer; const WCHAR*
   flags As ImageCodecFlags   ' Should be a Long equivalent
   Version As Long
   SigCount As Long
   SigSize As Long
   SigPattern As Long      ' Byte Array Pointer; BYTE*
   SigMask As Long         ' Byte Array Pointer; BYTE*
End Type

Public Enum GpStatus   ' aka Status
   Ok = 0
   GenericError = 1
   InvalidParameter = 2
   OutOfMemory = 3
   ObjectBusy = 4
   InsufficientBuffer = 5
   NotImplemented = 6
   Win32Error = 7
   WrongState = 8
   Aborted = 9
   FileNotFound = 10
   ValueOverflow = 11
   AccessDenied = 12
   UnknownImageFormat = 13
   FontFamilyNotFound = 14
   FontStyleNotFound = 15
   NotTrueTypeFont = 16
   UnsupportedGdiplusVersion = 17
   GdiplusNotInitialized = 18
   PropertyNotFound = 19
   PropertyNotSupported = 20
End Enum

' Information flags about image codecs
Public Enum ImageCodecFlags
   ImageCodecFlagsEncoder = &H1
   ImageCodecFlagsDecoder = &H2
   ImageCodecFlagsSupportBitmap = &H4
   ImageCodecFlagsSupportVector = &H8
   ImageCodecFlagsSeekableEncode = &H10
   ImageCodecFlagsBlockingDecode = &H20

   ImageCodecFlagsBuiltin = &H10000
   ImageCodecFlagsSystem = &H20000
   ImageCodecFlagsUser = &H40000
End Enum

Public Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As GpStatus
Public Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal token As Long)
Public Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As Long, graphics As Long) As GpStatus
Public Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As Long) As GpStatus
Public Declare Function GdipDrawImageRectI Lib "gdiplus" (ByVal graphics As Long, ByVal image As Long, ByVal x As Long, ByVal y As Long, ByVal Width As Long, ByVal Height As Long) As GpStatus
Public Declare Function GdipGetImageEncodersSize Lib "gdiplus" (numEncoders As Long, size As Long) As GpStatus
Public Declare Function GdipGetImageEncoders Lib "gdiplus" (ByVal numEncoders As Long, ByVal size As Long, encoders As Any) As GpStatus
Public Declare Function GdipLoadImageFromFile Lib "gdiplus" (ByVal filename As String, image As Long) As GpStatus
Public Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As GpStatus
Public Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal image As Long, ByVal filename As String, clsidEncoder As CLSID, encoderParams As Any) As GpStatus
Public Declare Function GdipGetImageThumbnail Lib "gdiplus" (ByVal image As Long, ByVal thumbWidth As Long, ByVal thumbHeight As Long, thumbImage As Long, Optional ByVal callback As Long = 0, Optional ByVal callbackData As Long = 0) As GpStatus

Public Sub GetEncoderClsid(strMimeType As String, ClassID As CLSID)

   Dim num As Long, size As Long, I As Long
   Dim ICI() As ImageCodecInfo
   Dim buffer() As Byte
   
   ' Get the encoder array size
   GdipGetImageEncodersSize num, size
   If size = 0 Then Exit Sub      ' Failed!

   ' Allocate room for the arrays dynamically
   ReDim ICI(1 To num) As ImageCodecInfo
   ReDim buffer(1 To size) As Byte

   ' Get the array and string data
   GdipGetImageEncoders num, size, buffer(1)
   ' Copy the class headers
   CopyMemory ICI(1), buffer(1), (Len(ICI(1)) * num)

   ' Loop through all the codecs
   For I = 1 To num
      ' Must convert the pointer into a usable string
      If StrComp(PtrToStrW(ICI(I).MimeType), strMimeType, vbTextCompare) = 0 Then
         ClassID = ICI(I).ClassID   ' Save the class id
         Exit For
      End If
   Next
   ' Free the memory
   Erase ICI
   Erase buffer
End Sub

'Dereference Unicode string pointer
Public Function PtrToStrW(ByVal lpsz As Long) As String
    Dim sOut As String
    Dim lLen As Long

    lLen = lstrlenW(lpsz)

    If (lLen > 0) Then
        sOut = StrConv(String$(lLen, vbNullChar), vbUnicode)
        Call CopyMemory(ByVal sOut, ByVal lpsz, lLen * 2)
        PtrToStrW = StrConv(sOut, vbFromUnicode)
    End If
End Function



How can I make a smaller file and not so smooth? Thx!
0
 
LVL 32

Accepted Solution

by:
Erick37 earned 500 total points
ID: 12402347
Smaller...

Add the following to a module in your project:

'==MODULE CODE==
'GDI+ Declares and types used in saving an image to JPEG in VB6
''' Translated by Avery P. - 7/29/2002
''' From the module GDIPLUS API.BAS
''' Available at psc.com
''' Edited by Erick37 October, 2004
''' experts-exchange.com

Option Explicit

' NOTE: Enums evaluate to a Long
Public Enum GpStatus   ' aka Status
   Ok = 0
   GenericError = 1
   InvalidParameter = 2
   OutOfMemory = 3
   ObjectBusy = 4
   InsufficientBuffer = 5
   NotImplemented = 6
   Win32Error = 7
   WrongState = 8
   Aborted = 9
   FileNotFound = 10
   ValueOverflow = 11
   AccessDenied = 12
   UnknownImageFormat = 13
   FontFamilyNotFound = 14
   FontStyleNotFound = 15
   NotTrueTypeFont = 16
   UnsupportedGdiplusVersion = 17
   GdiplusNotInitialized = 18
   PropertyNotFound = 19
   PropertyNotSupported = 20
End Enum

Public Type GdiplusStartupInput
   GdiplusVersion As Long              ' Must be 1 for GDI+ v1.0, the current version as of this writing.
   DebugEventCallback As Long          ' Ignored on free builds
   SuppressBackgroundThread As Long    ' FALSE unless you're prepared to call
                                       ' the hook/unhook functions properly
   SuppressExternalCodecs As Long      ' FALSE unless you want GDI+ only to use
                                       ' its internal image codecs.
End Type

Public Type CLSID
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(0 To 7) As Byte
End Type

' Information flags about image codecs
Public Enum ImageCodecFlags
   ImageCodecFlagsEncoder = &H1
   ImageCodecFlagsDecoder = &H2
   ImageCodecFlagsSupportBitmap = &H4
   ImageCodecFlagsSupportVector = &H8
   ImageCodecFlagsSeekableEncode = &H10
   ImageCodecFlagsBlockingDecode = &H20

   ImageCodecFlagsBuiltin = &H10000
   ImageCodecFlagsSystem = &H20000
   ImageCodecFlagsUser = &H40000
End Enum

Public Type ImageCodecInfo
   ClassID As CLSID
   FormatID As CLSID
   CodecName As Long      ' String Pointer; const WCHAR*
   DllName As Long        ' String Pointer; const WCHAR*
   FormatDescription As Long ' String Pointer; const WCHAR*
   FilenameExtension As Long ' String Pointer; const WCHAR*
   MimeType As Long       ' String Pointer; const WCHAR*
   flags As ImageCodecFlags   ' Should be a Long equivalent
   Version As Long
   SigCount As Long
   SigSize As Long
   SigPattern As Long      ' Byte Array Pointer; BYTE*
   SigMask As Long         ' Byte Array Pointer; BYTE*
End Type


' Image encoder parameter related types
Public Enum EncoderParameterValueType
   EncoderParameterValueTypeByte = 1              ' 8-bit unsigned int
   EncoderParameterValueTypeASCII = 2             ' 8-bit byte containing one 7-bit ASCII
                                                   ' code. NULL terminated.
   EncoderParameterValueTypeShort = 3             ' 16-bit unsigned int
   EncoderParameterValueTypeLong = 4              ' 32-bit unsigned int
   EncoderParameterValueTypeRational = 5          ' Two Longs. The first Long is the
                                                   ' numerator the second Long expresses the
                                                   ' denomintor.
   EncoderParameterValueTypeLongRange = 6         ' Two longs which specify a range of
                                                   ' integer values. The first Long specifies
                                                   ' the lower end and the second one
                                                   ' specifies the higher end. All values
                                                   ' are inclusive at both ends
   EncoderParameterValueTypeUndefined = 7         ' 8-bit byte that can take any value
                                                   ' depending on field definition
   EncoderParameterValueTypeRationalRange = 8      ' Two Rationals. The first Rational
                                                   ' specifies the lower end and the second
                                                   ' specifies the higher end. All values
                                                   ' are inclusive at both ends
End Enum

' Encoder Parameter structure
Public Type EncoderParameter
   GUID As CLSID                          ' GUID of the parameter
   NumberOfValues As Long                 ' Number of the parameter values; usually 1
   type As EncoderParameterValueType      ' Value type, like ValueTypeLONG  etc.
   value As Long                          ' A pointer to the parameter values
End Type

' Encoder Parameters structure
Public Type EncoderParameters
   count As Long                          ' Number of parameters in this structure; Should be 1
   Parameter As EncoderParameter          ' Parameter values; this CAN be an array!!!! (Use CopyMemory and a string or byte array as workaround)
End Type

Public Const EncoderQuality           As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"

Public Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As GpStatus
Public Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal token As Long)
Public Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long, ByVal hpal As Long, bitmap As Long) As GpStatus
Public Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal image As Long, ByVal filename As String, clsidEncoder As CLSID, encoderParams As Any) As GpStatus
Public Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As GpStatus
Public Declare Function GdipGetImageEncodersSize Lib "gdiplus" (numEncoders As Long, size As Long) As GpStatus
Public Declare Function GdipGetImageEncoders Lib "gdiplus" (ByVal numEncoders As Long, ByVal size As Long, encoders As Any) As GpStatus
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function lstrlenW Lib "kernel32" (ByVal psString As Any) As Long
Private Declare Function lstrlenA Lib "kernel32" (ByVal psString As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32.dll" (ByVal lpszProgID As Long, pCLSID As CLSID) As Long
'
'
'Needed for GDI+
Private token As Long

'
'
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'By Erick37
Public Function SaveAsJPEG(pb As PictureBox, ByVal filename As String, Optional ByVal Quality As Long = 80) As Long
    '
    'Saves picturebox image as JPEG using GDI+
    '
    Dim stat As GpStatus
    Dim bm As Long
    Dim encoderCLSID As CLSID
    Dim encoderParams As EncoderParameters
    Dim lQuality As Long
   
    'get the picture into a GDI+ image
    stat = GdipCreateBitmapFromHBITMAP(pb.Picture.Handle, pb.Picture.hpal, bm)
   
    ' Get the CLSID of the JPEG encoder
    Call GetEncoderClsid("image/jpeg", encoderCLSID)
   
    ' Setup the encoder paramters for JPEG quality
    If (stat = Ok) Then
        lQuality = Quality
        encoderParams.count = 1    ' Only one element in this Parameter array
        With encoderParams.Parameter
            .NumberOfValues = 1     ' Should be one
            .type = EncoderParameterValueTypeLong
            ' Set the GUID to EncoderQuality
            .GUID = DEFINE_GUID(EncoderQuality)
            .value = VarPtr(lQuality)  ' Remember: The value expects only pointers!
        End With

        ' Now save the bitmap as JPEG
        stat = GdipSaveImageToFile(bm, StrConv(filename, vbUnicode), encoderCLSID, encoderParams)
       
    End If
   
    SaveAsJPEG = stat
   
    ' Cleanup
    Call GdipDisposeImage(bm)
End Function

Public Function gdipLoad() As Boolean
   
    ' Load the GDI+ Dll
    '
    'Return True for success, False for failure
    '
    Dim GpInput As GdiplusStartupInput
   
    gdipLoad = False
    GpInput.GdiplusVersion = 1
    If GdiplusStartup(token, GpInput) = Ok Then
        gdipLoad = True
    End If
   
End Function

Public Sub gdipUnLoad()
    ' Unload the GDI+ Dll
    Call GdiplusShutdown(token)
End Sub

Public Function GetEncoderClsid(strMimeType As String, ClassID As CLSID)
   Dim num As Long, size As Long, I As Long
   Dim ICI() As ImageCodecInfo
   Dim buffer() As Byte
   
   GetEncoderClsid = -1 'Failure flag

   ' Get the encoder array size
   Call GdipGetImageEncodersSize(num, size)
   If size = 0 Then Exit Function ' Failed!

   ' Allocate room for the arrays dynamically
   ReDim ICI(1 To num) As ImageCodecInfo
   ReDim buffer(1 To size) As Byte

   ' Get the array and string data
   Call GdipGetImageEncoders(num, size, buffer(1))
   ' Copy the class headers
   Call CopyMemory(ICI(1), buffer(1), (Len(ICI(1)) * num))

   ' Loop through all the codecs
   For I = 1 To num
      ' Must convert the pointer into a usable string
      If StrComp(PtrToStrW(ICI(I).MimeType), strMimeType, vbTextCompare) = 0 Then
         ClassID = ICI(I).ClassID   ' Save the class id
         GetEncoderClsid = I        ' return the index number for success
         Exit For
      End If
   Next
   ' Free the memory
   Erase ICI
   Erase buffer
End Function

' Courtesy of: Dana Seaman
' Helper routine to convert a CLSID(aka GUID) string to a structure
Public Function DEFINE_GUID(ByVal sGuid As String) As CLSID
   ' Example ImageFormatBMP = {B96B3CAB-0728-11D3-9D7B-0000F81EF32E}
   Call CLSIDFromString(StrPtr(sGuid), DEFINE_GUID)
End Function

' From www.mvps.org/vbnet...i think
'   Dereferences an ANSI or Unicode string pointer
'   and returns a normal VB BSTR
Public Function PtrToStrW(ByVal lpsz As Long) As String
    Dim sOut As String
    Dim lLen As Long

    lLen = lstrlenW(lpsz)

    If (lLen > 0) Then
        sOut = StrConv(String$(lLen, vbNullChar), vbUnicode)
        Call CopyMemory(ByVal sOut, ByVal lpsz, lLen * 2)
        PtrToStrW = StrConv(sOut, vbFromUnicode)
    End If
End Function

0
 
LVL 32

Expert Comment

by:Erick37
ID: 12402363
And here's how to use it from your form:

'==FORM CODE==
'Calls SaveAsJPEG to save the picture in Picture1 as Jpeg
'Don't forget the Form_Load and Form_Unload GDIP functions!

Option Explicit

Private Sub Command1_Click()
    '//Save the picture
    Dim ret As Long
    ret = SaveAsJPEG(Picture1, "c:\aaa.jpg", 75)
    Debug.Print "done", ret
   
End Sub

Private Sub Form_Load()
    'It is required to initialize GDI+ before use
    If Not gdipLoad() Then
        'Could notinitialize the GDI+ Library
        MsgBox "Error loading GDI+ Library"
        Unload Me
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    'Free the GDI+ Library
    Call gdipUnLoad
End Sub
0
 
LVL 1

Author Comment

by:HyMaX_2003
ID: 12402664
Oh my god! I can't believe how simple and PERFECT this is! Thanks a lot Erick, best code!
0

Featured Post

Tech or Treat! - Giveaway

Submit an article about your scariest tech experience—and the solution—and you’ll be automatically entered to win one of 4 fantastic tech gadgets.

Question has a verified solution.

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

When trying to find the cause of a problem in VBA or VB6 it's often valuable to know what procedures were executed prior to the error. You can use the Call Stack for that but it is often inadequate because it may show procedures you aren't intereste…
When designing a form there are several BorderStyles to choose from, all of which can be classified as either 'Fixed' or 'Sizable' and I'd guess that 'Fixed Single' or one of the other fixed types is the most popular choice. I assume it's the most p…
Get people started with the utilization of class modules. Class modules can be a powerful tool in Microsoft Access. They allow you to create self-contained objects that encapsulate functionality. They can easily hide the complexity of a process from…
Illustrator's Shape Builder tool will let you combine shapes visually and interactively. This video shows the Mac version, but the tool works the same way in Windows. To follow along with this video, you can draw your own shapes or download the file…
Suggested Courses

598 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