Solved

Generating Thumbnails in VB?

Posted on 2004-09-03
12
1,542 Views
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.
0
Comment
Question by:gerrymcd
  • 5
  • 3
  • 3
  • +1
12 Comments
 
LVL 85

Expert Comment

by:Mike Tomlinson
Comment Utility
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.

Idle_Mind
0
 
LVL 2

Author Comment

by:gerrymcd
Comment Utility
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.
0
 
LVL 19

Expert Comment

by:BrianGEFF719
Comment Utility
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
destPBox.Refresh
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.
-Brian
0
 
LVL 22

Accepted Solution

by:
danaseaman earned 65 total points
Comment Utility
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 http://download.microsoft.com/download/platformsdk/redist/3097/W98NT42KMeXP/EN-US/gdiplus_dnld.exe.

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:
http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=37541&lngWId=1

Another option is to use my GdiPlus.TLB here:
http://www.cyberactivex.com/freebies.htm

Sample code:
http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=55789&lngWId=1

Other Links for making/viewing thumbnails:
http://www.experts-exchange.com/Programming/Programming_Platforms/Win_Prog/Q_20822626.html
http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=6029&lngWId=1
0
 
LVL 2

Author Comment

by:gerrymcd
Comment Utility
BrianGEFF719;
i cant get that to work all i see is a tiny image (size of an icon) of the orginal in a picture box?
0
 
LVL 85

Assisted Solution

by:Mike Tomlinson
Mike Tomlinson earned 60 total points
Comment Utility
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.

Regards,

Idle_Mind

' -----------------------------------------------------
' 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)
                        DoEvents
                       
                        ' Make thumbnail
                        Picture1.PaintPicture Picture2.Picture, 0, 0, Picture1.Width, Picture1.Height
                        DoEvents
                       
                        ' Save thumbnail
                        SavePicture Picture1.Image, pathName & "thmb_" & curFile
                End Select
            End If
            curFile = Dir()
        Wend
        MsgBox "Done"
    End If
End Sub

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

Private Type BROWSEINFO
  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_RETURNONLYFSDIRS = &H1
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
        .ulFlags = BIF_RETURNONLYFSDIRS Or BIF_USENEWUI
    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)
    Else
        BrowseFolder = ""
    End If
End Function
0
Highfive Gives IT Their Time Back

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

 
LVL 22

Expert Comment

by:danaseaman
Comment Utility
If Thumbnail quality is an issue you will need to use GDI+ or Shell32. Both yield high quality Thumbnails:

Shell32:
   http://www.vbaccelerator.com/home/VB/Code/Libraries/Shell_Projects/Thumbnail_Extraction/article.asp

   IVBExtractImageLib.tlb required for above demo. Register the TLB via Project/Refrerences:
   http://www.vbaccelerator.com/home/VB/Type_Libraries/IVBExtractImage/IVBExtractImageLib_Type_Library.zip

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
   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
0
 
LVL 2

Author Comment

by:gerrymcd
Comment Utility
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?
0
 
LVL 22

Expert Comment

by:danaseaman
Comment Utility
Yes, GDI API will run on Win98 but you have to install it. It is a free download here: http://download.microsoft.com/download/platformsdk/redist/3097/W98NT42KMeXP/EN-US/gdiplus_dnld.exe
0
 
LVL 2

Author Comment

by:gerrymcd
Comment Utility
Ah thanks for that.
0
 
LVL 85

Expert Comment

by:Mike Tomlinson
Comment Utility
gerrymcd,

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,

Idle_Mind
0
 
LVL 2

Author Comment

by:gerrymcd
Comment Utility
No bother thanks for your help.  Still tweaking my code.  Ill grade the question later.
0

Featured Post

Why You Should Analyze Threat Actor TTPs

After years of analyzing threat actor behavior, it’s become clear that at any given time there are specific tactics, techniques, and procedures (TTPs) that are particularly prevalent. By analyzing and understanding these TTPs, you can dramatically enhance your security program.

Join & Write a Comment

Article by: Martin
Here are a few simple, working, games that you can use as-is or as the basis for your own games. Tic-Tac-Toe This is one of the simplest of all games.   The game allows for a choice of who goes first and keeps track of the number of wins for…
Background What I'm presenting in this article is the result of 2 conditions in my work area: We have a SQL Server production environment but no development or test environment; andWe have an MS Access front end using tables in SQL Server but we a…
Get people started with the process of using Access VBA to control Excel using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Excel. Using automation, an Access application can laun…
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…

763 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