<

Placing a high performance slideshow on an MS Access Form

Published on
14,720 Points
3,720 Views
5 Endorsements
Last Modified:
Awarded
I've detailed how to get many large images to print on an Access report in an article here, but what about the scenario where you'd like to preview the images, on a form, as a slideshow?

As it turns out, that can be done natively in Access, with good performance.  No need for any API code, or embedding something PowerPoint-ish, or any third party controls.  Just straight up MS Access, running on Windows Vista or later, using VBA code and referencing the built-in MS Windows Image Acquisition 2.0 Library (WIA).  If it was me -- and it is -- I'd like to be able to link to existing images and save the path to the files in the database (saving images to OLE fields or attachments is just evil and should be avoided in most cases.)  I wouldn't mind to be able to associate any number of images with a given record, and I wouldn't mind to be able to specify how many pixels wide and high the preview images should be.  So, I've done that.

When you open the sample, frmSelectImages opens.  It's got a textbox for the path to a folder, a multi-select list box to allow you to select some files from the folder for association and some textboxes for width, height and what job to associate those images with.  Here's the code
Option Compare Database
Option Explicit

Private Sub cmdAddSelected_Click()
Dim db As Database
Dim rs As Recordset
Dim MyItem As Variant
Dim varitem As Variant
Dim response As String
loopback:
response = InputBox("Enter a valid Job ID to associate these images with.  Click cancel to assume that the value in 'Job ID' is valid and you want to use it", "Select Job ID")
If response = "" And IsNumeric(Me.JobID) = True Then
    GoTo done
Else
    If IsNumeric(response) = False Then
        MsgBox "Only positive integers are valid for Job IDs"
        GoTo loopback
    End If
    Me.JobID = response
End If
done:
Set db = CurrentDb
For Each MyItem In Me.lstFileNames.ItemsSelected
    Set rs = db.OpenRecordset("Select * from tblPictures where 1=2;", dbOpenDynaset, dbSeeChanges)
    With rs
        .AddNew
        !JobID = Me.JobID
        !Path = Me.txtFolderPath & "\"
        !FileName = Me.lstFileNames.Column(0, MyItem)
        !DesiredHeight = Nz(Me.txtHeight, 1200)
        !DesiredWidth = Nz(Me.txtWidth, 1600)
        .Update
    End With
Next MyItem
MsgBox "Done!"
End Sub

Private Sub cmdPickFolder_Click()
'Declare a variable as a FileDialog object.
Dim fd As FileDialog
Dim fs As Object
Dim myfile As Object
Dim db As Database
Dim rs As Recordset

Set db = CurrentDb

'Create a FileDialog object as a Folder Picker dialog box.
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
    .InitialView = msoFileDialogViewDetails
    .Title = "Folde Selector"
    .InitialFileName = Nz(Me.txtFolderPath, Application.CurrentProject.Path)
    .ButtonName = "Select"
    .AllowMultiSelect = False
    If .Show = True Then
        Me.txtFolderPath = .SelectedItems(1)
    End If
End With

DoCmd.SetWarnings False
db.Execute "DELETE tempFileNames.* FROM tempFileNames;", dbSeeChanges
DoCmd.SetWarnings True

Set rs = db.OpenRecordset("Select * from tempFileNames where 1=2;", dbOpenDynaset, dbSeeChanges)
Set fs = CreateObject("Scripting.FileSystemObject")
With rs
    For Each myfile In fs.GetFolder(Me.txtFolderPath).Files
        Select Case True
            Case myfile.Name Like "*.jpg"
            Case myfile.Name Like "*.png"
            Case myfile.Name Like "*.bmp"
            Case Else
                GoTo skip
        End Select
        .AddNew
        !FileName = myfile.Name
        .Update
skip:
    Next myfile
End With

'unselect everything in the listbox
Dim MyItem As Variant
Dim varitem As Variant
For Each MyItem In Me.lstFileNames.ItemsSelected
    Me.lstFileNames.Selected(varitem) = False
Next
Me.lstFileNames.Requery

End Sub

Private Sub Form_Load()
Me.txtWidth = 1600
Me.txtHeight = 1200
End Sub

Private Sub Form_Unload(Cancel As Integer)
Dim db As Database
Set db = CurrentDb
DoCmd.SetWarnings False
db.Execute "DELETE tempFileNames.* FROM tempFileNames;", dbSeeChanges
DoCmd.SetWarnings True
End Sub

Open in new window


Nothing too earth-shattering.  A FileDialog FolderPicker to let you select a folder. Next is a bit of legerdemain with a Listbox, a FileSystemObject, and a table to hold some temporary values. You may be asking yourself 'Hey, why didn't he just use Dir() to build up the listbox?" Well, I wanted to order the selections presented in the listbox, I wanted to filter them down to strictly image type files, and if you build a nice big string for a listbox's rowsource, you are limited to just 1024 characters. By using the FileSystemObject and a loop, I can filter out any unsuitable file types. By using a table, I can overcome the 1024 character limit and populate the listbox via a query -- and the query can look after the sorting. No messing with arrays and concatenation, which is nice. And since I really don't care about the records in tempFileNames (hence my naming prefix 'temp')  I kill them off with aplomb, good and silently gone.
DoCmd.SetWarnings False
db.Execute "DELETE tempFileNames.* FROM tempFileNames;", dbSeeChanges
DoCmd.SetWarnings True

Relatively elegant.

So, once we have some files, we'd like to preview/slideshow them. And if it was me -- and it is -- I'd like to be able to stop and start the slideshow, and configure how fast the images are going to display. The OnTimer event does most of the heavy lifting. We've got a couple of buttons to toggle the TimerInterval between 0 and some number of millseconds.

Now, I've built two demonstration forms. One is a single form and the other is a continuous form. They are basically identical. You CANNOT use an unbound control in the detail section of a continuous form. I have an article here about why that doesn't work and what you can do to overcome that limitation is some cases. This is NOT one of those cases.

As a result, the slideshow on the continuous form is in the form header and is driven by the record that is current in the detail section of the form. On the single form, there is only one record current and viewable at a time by design, so the slideshow is in the detail section. Here's the code for the single form.
Option Compare Database
Option Explicit
Public db As Database
Public rsPics As Recordset
Public fs As Object
Public Img As WIA.ImageFile
Public IP As ImageProcess

Private Sub cmdStart_Click()
Me.TimerInterval = Me.txtTimerValue
End Sub

Private Sub cmdStop_Click()
Me.TimerInterval = 0
End Sub

Private Sub Form_Current()
Set rsPics = db.OpenRecordset("Select * from tblPictures where jobid = " & Me.JobID & ";", dbOpenDynaset, dbSeeChanges)
Me.imgPreview.Visible = False
Me.ImageID.Visible = False
Me.Path.Visible = False
Me.FileName.Visible = False
End Sub

Private Sub Form_Load()
Set db = CurrentDb
Set fs = CreateObject("Scripting.FileSystemObject")
Set IP = CreateObject("WIA.ImageProcess")
Set Img = CreateObject("WIA.ImageFile")
IP.Filters.Add IP.FilterInfos("Scale").FilterID
Me.TimerInterval = 0
End Sub

Private Sub Form_Timer()

If db Is Nothing Then
    Set db = CurrentDb
End If

If rsPics Is Nothing Then
    Set rsPics = db.OpenRecordset("Select * from tblPictures where jobid = " & Me.JobID & ";", dbOpenDynaset, dbSeeChanges)
End If

If fs Is Nothing Then
    Set fs = CreateObject("Scripting.FileSystemObject")
End If

If IP Is Nothing Then
    Set IP = CreateObject("WIA.ImageProcess")
    IP.Filters.Add IP.FilterInfos("Scale").FilterID
End If

If Img Is Nothing Then
    Set Img = CreateObject("WIA.ImageFile")
End If

With rsPics
    If .RecordCount = 0 Then
        Me.imgPreview.Visible = False
        Me.ImageID.Visible = False
        Me.Path.Visible = False
        Me.FileName.Visible = False
        Exit Sub
    End If
    
    If .EOF = True Then .MoveFirst 'it's a continuous loop!
    Me.imgPreview.Visible = True
    Me.ImageID.Visible = True
    Me.Path.Visible = True
    Me.FileName.Visible = True
    Img.LoadFile (!Path & !FileName) 'WIA code, load up the image
    If Img.Width > !DesiredWidth + 1 Then 'is it bigger than desired?
        If fs.FileExists(Application.CurrentProject.Path & "\small\" & !FileName) = False Then 'it hasn't already been shrunk in a previous loop
            IP.Filters(1).Properties("MaximumWidth") = !DesiredWidth
            IP.Filters(1).Properties("MaximumHeight") = !DesiredHeight
            Set Img = IP.Apply(Img) 'shrink it
            If fs.FolderExists(Application.CurrentProject.Path & "\small") = False Then 'find a place to save it
                fs.CreateFolder (Application.CurrentProject.Path & "\small")
            End If
            Img.SaveFile (Application.CurrentProject.Path & "\small\" & !FileName) ' save it
            Me.imgPreview.Picture = Application.CurrentProject.Path & "\small\" & !FileName 'display it
        Else
            Me.imgPreview.Picture = Application.CurrentProject.Path & "\small\" & !FileName 'it already existed, just display it
        End If
    Else
        Me.imgPreview.Picture = !Path & !FileName 'it was small enough

    End If
    'show some detail about the image
    Me.ImageID.Value = !ImageID
    Me.Path.Value = !Path
    Me.FileName.Value = !FileName
    .MoveNext
End With
End Sub

Private Sub Form_Unload(Cancel As Integer)
'clean up, clean up,everybody everywhere
If fs.FolderExists(Application.CurrentProject.Path & "\small") = True Then
    fs.DeleteFolder Application.CurrentProject.Path & "\small", True
End If
End Sub

Open in new window


Not much too it. We've got the button events to stop and start the slideshow by toggling TimerInterval. The form Load() event initializes a lot of the objects in use, which are public to the module. That improves performance. One problem is that, if an error is thrown, all those public variables get trashed down to nothing, so the start of the Timer event is filled with code to ensure those variable exist and are valid:
If db Is Nothing Then
    Set db = CurrentDb
End If

If rsPics Is Nothing Then
    Set rsPics = db.OpenRecordset("Select * from tblPictures where jobid = " & Me.JobID & ";", dbOpenDynaset, dbSeeChanges)
End If

If fs Is Nothing Then
    Set fs = CreateObject("Scripting.FileSystemObject")
End If

If IP Is Nothing Then
    Set IP = CreateObject("WIA.ImageProcess")
    IP.Filters.Add IP.FilterInfos("Scale").FilterID
End If

If Img Is Nothing Then
    Set Img = CreateObject("WIA.ImageFile")
End If

Open in new window

Then we have a bit of code to deal with the possibility of no images associated with a job and the heavy lifting
With rsPics
    If .RecordCount = 0 Then
        Me.imgPreview.Visible = False
        Me.ImageID.Visible = False
        Me.Path.Visible = False
        Me.FileName.Visible = False
        Exit Sub
    End If
    
    If .EOF = True Then .MoveFirst 'it's a continuous loop!
    Me.imgPreview.Visible = True
    Me.ImageID.Visible = True
    Me.Path.Visible = True
    Me.FileName.Visible = True
    Img.LoadFile (!Path & !FileName) 'WIA code, load up the image
    If Img.Width > !DesiredWidth + 1 Then 'is it bigger than desired?
        If fs.FileExists(Application.CurrentProject.Path & "\small\" & !FileName) = False Then 'it hasn't already been shrunk in a previous loop
            IP.Filters(1).Properties("MaximumWidth") = !DesiredWidth
            IP.Filters(1).Properties("MaximumHeight") = !DesiredHeight
            Set Img = IP.Apply(Img) 'shrink it
            If fs.FolderExists(Application.CurrentProject.Path & "\small") = False Then 'find a place to save it
                fs.CreateFolder (Application.CurrentProject.Path & "\small")
            End If
            Img.SaveFile (Application.CurrentProject.Path & "\small\" & !FileName) ' save it
            Me.imgPreview.Picture = Application.CurrentProject.Path & "\small\" & !FileName 'display it
        Else
            Me.imgPreview.Picture = Application.CurrentProject.Path & "\small\" & !FileName 'it already existed, just display it
        End If
    Else
        Me.imgPreview.Picture = !Path & !FileName 'it was small enough

    End If
    'show some detail about the image
    Me.ImageID.Value = !ImageID
    Me.Path.Value = !Path
    Me.FileName.Value = !FileName
    .MoveNext
End With
End Sub

Open in new window


And since this was dynamic, and we don't want to keep those small images for later
Private Sub Form_Unload(Cancel As Integer)
'clean up, clean up,everybody everywhere
If fs.FolderExists(Application.CurrentProject.Path & "\small") = True Then
    fs.DeleteFolder Application.CurrentProject.Path & "\small", True
End If
End Sub

Open in new window


And the performance of this code is very good. A slideshow running for times longer than 1 second shows no hesitations. At 3/4 of second, the first run is hard to distinguish from any other. At a 1/2 second, you notice the pace pick up after the loop completes the first time. All-in-all, a very handy tool if you have images in your database that you want to present to the users in a timely fashion. In fact, it's better-performing than opening Windows Explorer in Extra Large Icons view and waiting for the thumbnails to generate in some cases.

Now, the caveats:
While this is a little closer to production code than some of my samples, there's still no validation or error-handling code in it, beyond what's needed to ensure that an intelligent user has a good experience playing with it
The sample is built in Access 2003 on Windows 7. It should run on anything that is Windows Vista+ and Access 2003+. If you can find the WIAAutSDK.zip file from a reputable source and install it on XP, it will run on XP as well. It may run on versions of Access prior to 2003 if you have the correct WIA library installed and fix the references
I expect that you were intelligent about ensuring that your height and width made for a good looking image. No, I did not build in any 'keep aspect ratio' code
I expect that you know that millseconds should be a sane, long integer value

Enjoy!
Nick67
Slideshow.mdb
5
Comment
Author:Nick67
2 Comments
 
 

Administrative Comment

by:Eric AKA Netminder
Nick67,

Congratulations; your article has been published, and has been awarded EE-Approved status as well.

I'm really beginning to like your narrative style...

ericpete
Page Editor
0
 

Expert Comment

by:James Boomer
Nick67,

I have downloaded your "Placing a high performance slideshow on an MS Access Form" database, and it performs the functions I am looking for very well. The only issue that I have had is that when I save the database, it prompts me to save in Access 2007. Once that happens, the VBA code stalls. I get the following message:

Run-time error '13':

Type mismatch

When I debug, the code stalls on

Set rs = db.OpenRecordset("Select * from tempFileNames where 1=2;", dbOpenDynaset, dbSeeChanges)

I have been looking for fixes, but have not been able to find any. I would appreciate any help you could provide. Please keep in mind I am a VERY novice VBA programmer.

Thank you,

Boomer
0

Featured Post

Ultimate Tool Kit for Technology Solution Provider

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy now.

Join & Write a Comment

With Microsoft Access, learn how to start a database in different ways and produce different start-up actions allowing you to use a single database to perform multiple tasks. Specify a start-up form through options: Specify an Autoexec macro: Us…
Visualize your data even better in Access queries. Given a date and a value, this lesson shows how to compare that value with the previous value, calculate the difference, and display a circle if the value is the same, an up triangle if it increased…

Keep in touch with Experts Exchange

Tech news and trends delivered to your inbox every month