Create a new class module and paste this code into it. Call the module cThumbnailViewer.
If you have any questions, email us at help@codeoftheweek.com
'----------------------------------------------------------------------
'
' Module Name: cThumbnailViewer
' 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
'
' Sample Usage:
'
' Dim thumb As New cThumbnailViewer
'
' Private Sub Form_Load()
' Set thumb.Scroller = vsScroll
' Set thumb.ParentForm = Me
' Set thumb.ImageControl = pic
' thumb.ThumbnailSize = ethSmall
' thumb.PictureFolder = "c:\windows"
' thumb.DrawForm
' End Sub
'
' Private Sub Form_Resize()
' thumb.UpdateForm
' End Sub
'
'----------------------------------------------------------------------
Option Explicit
Public ParentForm As Form
Public PictureFolder As String
Public ThumbnailSize As eThumbSize
Public WithEvents Scroller As VScrollBar
Private mimgControl As Object
Private mcolImageNames As New Collection
Private mContainer As Object
Public Enum eThumbSize
ethSmall
ethMedium
ethLarge
End Enum
'
' Assumes the img is a control array of picture boxes with the index of the first item
' of zero.
'
Public Property Set ImageControl(img As Object)
Set mimgControl = img
Set mContainer = mimgControl(0).Container
End Property
Public Sub UpdateForm(Optional bLoadImageControls As Boolean = False)
Dim lWidth As Long
Dim lHeight As Long
Dim lCount As Long
Dim lAcross As Long
Dim lDown As Long
Dim lImage As Long
Dim x As Long
Dim Y As Long
Static bUpdating As Boolean
If ParentForm Is Nothing Then
Exit Sub
End If
' avoid recursive calls of this routine since we have some DoEvents in here.
If bUpdating Then
Exit Sub
End If
bUpdating = True
Screen.MousePointer = vbHourglass
' make sure any previously loaded image controls are removed before redrawing them.
If bLoadImageControls Then
For x = mimgControl.ubound To 1 Step -1
Unload mimgControl(x)
Next
End If
CalcThumbnailPositions lCount, lAcross, lDown, lWidth, lHeight
' setup the scroller positioning
Scroller.Top = 0
Scroller.Left = ParentForm.ScaleWidth - Scroller.Width
Scroller.Height = ParentForm.ScaleHeight
Scroller.Min = 1
Scroller.Max = lDown - 1
Scroller.Value = 1
' setup the container positioning
mContainer.Top = 0
mContainer.Width = ParentForm.ScaleWidth - Scroller.Width
mContainer.Left = 0
' set the height of the container control
mContainer.Height = lDown * lHeight
lImage = 1
For x = 0 To lDown - 1
For Y = 0 To lAcross - 1
' skip over the last couple of images if the counts to not match
' the number of lDown * lAcross
If lImage <= lCount Then
' if we are supposed to load the picture control then do it.
If bLoadImageControls Then
Load mimgControl(lImage)
End If
' set the picture control with the right parameters and then draw the thumbnail
With mimgControl(lImage)
.Top = x * lHeight
.Left = Y * lWidth
.Height = lHeight
.Width = lWidth
.Visible = True
.AutoRedraw = True
' only draw the picture if we are loading the controls the first time.
If bLoadImageControls Then
DrawThumbnail mimgControl(lImage), PictureFolder & "\" & mcolImageNames(lImage)
End If
' give other tasks some CPU time
DoEvents
End With
End If
' move to the next image.
lImage = lImage + 1
Next
Next
bUpdating = False
Screen.MousePointer = vbDefault
Exit Sub
Handler:
bUpdating = False
Screen.MousePointer = vbDefault
Err.Raise Err.Number, "cThumbnails.UpdateForm", Err.Description
End Sub
'
' This is the method that should be called the first time you are
' planning to display a group of photos.
'
Public Sub DrawForm()
DoEvents
LoadImageNames
UpdateForm True
End Sub
Private Sub CalcThumbnailPositions(lCount As Long, _
lAcross As Long, lDown As Long, _
lWidth As Long, lHeight As Long)
' if we haven't defined the parent form yet we can not determine the info
' necessary to calculate the positions
If ParentForm Is Nothing Then
Exit Sub
End If
lWidth = ThumbWidth + ThumbSpacing
lHeight = ThumbHeight + ThumbSpacing
lCount = mcolImageNames.Count
' figure out how many images will fit across and then down. It is optimized to
' avoid horizontal scrolling.
lAcross = ParentForm.ScaleWidth \ lWidth
lDown = lCount \ lAcross + 1
End Sub
'
' Used to force a thumbnail size picture into the picbox.
'
Private Sub DrawThumbnail(Picbox As PictureBox, sFile As String)
Dim X As Long, Y As Long
Dim pic As Picture
On Error GoTo Handler
Set pic = LoadPicture(sFile)
'Default Picture dimensions are in vbHiMetric Units
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
' syncs the image in the picture box with the picture object
Picbox.Picture = Picbox.Image
Set pic = Nothing
Exit Sub
Handler:
Err.Raise Err.Number, "DrawThumbnail", Err.Description
End Sub
'
' Gather the images in the folder specified by PictureFolder. It will load
' any GIF, JPG or BMP files.
'
Private Function LoadImageNames() As Long
Dim sFile As String
Dim lCount As Long
Dim sExt As String
Dim x As Long
On Error Goto Handler
' clear collection
For x = 1 To mcolImageNames.Count
mcolImageNames.Remove 1
Next
If Dir(PictureFolder, vbDirectory) = "" Then
LoadImageNames = 0
Exit Function
End If
sFile = LCase$(Dir(PictureFolder & "\*.*", vbNormal))
While sFile <> ""
sExt = Right(sFile, 3)
If sExt = "gif" Or sExt = "jpg" Or sExt = "bmp" Then
mcolImageNames.Add sFile, sFile
End If
sFile = LCase$(Dir)
Wend
LoadImageNames = mcolImageNames.Count
Exit Function
Handler:
Err.Raise Err.Number, "LoadImageNames", Err.Description
End Function
'
' The next three properties are used to determine the information
' necessary to display different size thumbnails. You can add
' additional sizes or modify the values we chose.
'
Private Property Get ThumbWidth() As Long
Select Case ThumbnailSize
Case ethSmall
ThumbWidth = 500
Case ethMedium
ThumbWidth = 1000
Case ethLarge
ThumbWidth = 1500
End Select
End Property
Private Property Get ThumbSpacing() As Long
Select Case ThumbnailSize
Case ethSmall
ThumbSpacing = 200
Case ethMedium
ThumbSpacing = 200
Case ethLarge
ThumbSpacing = 200
End Select
End Property
Private Property Get ThumbHeight() As Long
Select Case ThumbnailSize
Case ethSmall
ThumbHeight = 500
Case ethMedium
ThumbHeight = 1000
Case ethLarge
ThumbHeight = 1500
End Select
End Property
Private Sub ParentForm_Resize()
' for some reason we can not get this to fire on our systems. If
' anyone knows why, please let us know since this would be a
' much cleaner way to implement this class.
'UpdateForm
End Sub
Private Sub Scroller_Change()
' automatically slide the container control around to simulate the scrolling
' operation. This is a VERY fast way to accomplish scrolling of controls.
mimgControl(0).Container.Top = -(Scroller.Value - 1) * (ThumbWidth + ThumbSpacing)
End Sub