Generating Thumbnails in VB?

Posted on 2004-09-03
Last Modified: 2008-01-09
How do you make a thumbnail of a jpg file in vb and then save it to disk.  the thumnail would be very small about 10% of original image size.
I need a fast way to do it if one exists.
Question by:gerrymcd
  • 5
  • 3
  • 3
  • +1
LVL 85

Expert Comment

by:Mike Tomlinson
ID: 11978189
VB has the ability to read in JPG, GIF and BMP formats...but can only save imges in the BMP format.

If you need to save your thumbnails in JPG format, you will need to use a third party DLL or control.


Author Comment

ID: 11978255
it doest matter the format bmp is fine but how do i resize the images to be small and be fast while generating the thumnails.
LVL 19

Expert Comment

ID: 11978479
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long

Public Sub ResizePictureContents(pBox As PictureBox, destPBox As PictureBox, width As Long, height As Long)
'destPBox.width = width * Screen.TwipsPerPixelX
'destPBox.height = height * Screen.TwipsPerPixelY
StretchBlt destPBox.hdc, 0, 0, width, height, pBox.hdc, 0, 0, pBox.ScaleWidth, pBox.ScaleHeight, vbSrcCopy
End Sub

Call ResizePictureContents(Form1.Picture1, Form1.Picture2, 128, 128)

this will resize the contents of Picture1 to (128x128) and store the resized result in Picture2.

Good Luck.
Free Tool: ZipGrep

ZipGrep is a utility that can list and search zip (.war, .ear, .jar, etc) archives for text patterns, without the need to extract the archive's contents.

One of a set of tools we're offering as a way to say thank you for being a part of the community.

LVL 22

Accepted Solution

danaseaman earned 65 total points
ID: 11978571
You can easily create thumbnails in Vb with GDI+ usiung function GdipGetImageThumbnail. If GDIplus.DLL is not installed on your system(XP & 2000SP3 are OK)you can get it free at

You can save the thumbnails in a variety of formats: Bmp/Jpg/Png/Gif.

You can use declares in your code to access GDI+ functions as shown here:

Another option is to use my GdiPlus.TLB here:

Sample code:

Other Links for making/viewing thumbnails:

Author Comment

ID: 11980194
i cant get that to work all i see is a tiny image (size of an icon) of the orginal in a picture box?
LVL 85

Assisted Solution

by:Mike Tomlinson
Mike Tomlinson earned 60 total points
ID: 11980391
Create a new project and add a CommandButton, Label, two PictureBoxes and a Module.

The thumbnail filenames will be in the same folder preceded by "thmb_".

Just run the app and click the button to select the source image folder.



' -----------------------------------------------------
' Form1
' -----------------------------------------------------
Option Explicit

Private Sub Form_Load()
    Me.ScaleMode = vbPixels
    Picture1.ScaleMode = vbPixels
    Picture2.ScaleMode = vbPixels
    Picture2.AutoSize = True
    Picture1.AutoRedraw = True
    Picture1.BorderStyle = 0 ' None
    Picture2.BorderStyle = 0 ' None
    Picture1.Appearance = 0 ' Flat
    Picture2.Appearance = 0 ' Flat
    Picture2.Visible = False ' original  image does not need to be visible
    Picture1.Width = 50  ' <---------------------------------------------------  Set the Width & Height in Pixels
    Picture1.Height = 50 ' <---------------------------------------------------  of your desired Thumbnail Size
End Sub

Private Sub Command1_Click()
    Dim pathName As String
    pathName = BrowseFolder("Select an Image folder")
    If pathName <> "" Then
        Dim curFile As String
        Dim ext As String
        If Right(pathName, 1) <> "\" Then
            pathName = pathName & "\"
        End If
        curFile = Dir(pathName)
        While curFile <> ""
            If UCase(Left(curFile, 5)) <> "THMB_" Then
                ext = UCase(Right(curFile, 4))
                Select Case ext
                    Case ".JPG", ".BMP", ".GIF"
                        ' Load image
                        Label1.Caption = curFile
                        Picture2.Picture = LoadPicture(pathName & curFile)
                        ' Make thumbnail
                        Picture1.PaintPicture Picture2.Picture, 0, 0, Picture1.Width, Picture1.Height
                        ' Save thumbnail
                        SavePicture Picture1.Image, pathName & "thmb_" & curFile
                End Select
            End If
            curFile = Dir()
        MsgBox "Done"
    End If
End Sub

' -----------------------------------------------------
' Module1
' -----------------------------------------------------
Option Explicit

  hOwner As Long
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpfn As Long
  lParam As Long
  iImage As Long
End Type

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
            "SHGetPathFromIDListA" (ByVal pidl As Long, _
            ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
            "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
            As Long
Private Const BIF_USENEWUI = &H40

Public Function BrowseFolder(szDialogTitle As String) As String
  Dim x As Long, bi As BROWSEINFO, dwIList As Long
  Dim szPath As String, wPos As Integer
    With bi
        .hOwner = 0
        .lpszTitle = szDialogTitle
    End With
    dwIList = SHBrowseForFolder(bi)
    szPath = Space$(512)
    x = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)
    If x Then
        wPos = InStr(szPath, Chr(0))
        BrowseFolder = Left$(szPath, wPos - 1)
        BrowseFolder = ""
    End If
End Function
LVL 22

Expert Comment

ID: 11982986
If Thumbnail quality is an issue you will need to use GDI+ or Shell32. Both yield high quality Thumbnails:


   IVBExtractImageLib.tlb required for above demo. Register the TLB via Project/Refrerences:

Complete GDI+ demo. Saves as Png but you can easily change this to Bmp/Gif/Jpg:

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
   sFile = InputBox("Image File", , "D:\_UnicodeScreenShots\UniGrid3.bmp")
   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
   ' 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

Author Comment

ID: 11988634
Thanks everyone for the great help.  Ill probably split the points later as there are some great solutions there.

Just 1 quick question, if i use the GDI API code will my program run on a wiindows 98 PC?
LVL 22

Expert Comment

ID: 11988698
Yes, GDI API will run on Win98 but you have to install it. It is a free download here:

Author Comment

ID: 11991454
Ah thanks for that.
LVL 85

Expert Comment

by:Mike Tomlinson
ID: 11997038

I just wanted to point out that in my solution, the generated thumbnails keep the existing extension, but are actually in BMP format.

I forgot to strip the extension off the filename before resaving them again.

Sorry about that,


Author Comment

ID: 11997156
No bother thanks for your help.  Still tweaking my code.  Ill grade the question later.

Featured Post

Free Tool: IP Lookup

Get more info about an IP address or domain name, such as organization, abuse contacts and geolocation.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

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

Suggested Solutions

If you have ever used Microsoft Word then you know that it has a good spell checker and it may have occurred to you that the ability to check spelling might be a nice piece of functionality to add to certain applications of yours. Well the code that…
You can of course define an array to hold data that is of a particular type like an array of Strings to hold customer names or an array of Doubles to hold customer sales, but what do you do if you want to coordinate that data? This article describes…
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…

820 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