Source code for Issue Number 121

Copyright 1997-2000 by C&D Programming Corp. All Rights Reserved. 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

Code of the Week Home


Source Code

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