Create a new module and paste this code into it. Call the module basImage.
If you have any questions, email us at help@codeoftheweek.com
'----------------------------------------------------------------------
'
' Module Name: basImage
' Written By: C&D Programming Corp.
' Create Date: 1/2000
' Copyright: Copyright 2000 by C&D Programming Corp. Source
' code may not be reproduced except for use in a
' compiled executable. All rights reserved. If
' you would like to reprint any or all of this
' code please email us at info@codeoftheweek.com
'
'----------------------------------------------------------------------
Option Explicit
'
' The resulting thumbnail graphic will be the same size as the picture box that is passed
' as the parameter picbox.
'
Public Sub CreateThumbnail(Picbox As PictureBox, sImageFile As String, sThumbnailFile As String)
Dim x As Long, y As Long
Dim pic As Picture
On Error GoTo Handler
Screen.MousePointer = vbHourglass
' this is pretty slow, but it is free. There are many third party
' packages out there that provide VERY fast image loading.
Set pic = LoadPicture(sImageFile)
' Default Picture dimensions are in vbHiMetric Units so let's convert to
' pixels for later use in PaintPicture.
x = Picbox.ScaleX(pic.Width, vbHimetric, vbPixels)
y = Picbox.ScaleY(pic.Height, vbHimetric, vbPixels)
Picbox.ScaleMode = vbPixels
Picbox.PaintPicture pic, _
0, 0, Picbox.ScaleWidth, Picbox.ScaleHeight, _
0, 0, x, y, _
vbSrcCopy
' sync image with picture object
Picbox.Picture = Picbox.Image
' save it to a file. Unfortunately the SavePicture method only supports
' writing bitmap images.
SavePicture Picbox.Picture, sThumbnailFile
Set pic = Nothing
Screen.MousePointer = vbDefault
Exit Sub
Handler:
Err.Raise Err.Number, "CreateThumbnail", Err.Description
End Sub