JPEG Compression

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

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

IM:

Beat me to it again...!!

:)

Well, at least you gave an alternative solution.

I was just the bringer of bad news...

~IM

Here is another PAQ with lots of great links and resources on image resizing/manipulation:
https://www.experts-exchange.com/questions/21118795/Generating-Thumbnails-in-VB.html

~IM

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!

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

Oh my god! I can't believe how simple and PERFECT this is! Thanks a lot Erick, best code!