Community Pick: Many members of our community have endorsed this article.
Editor's Choice: This article has been selected by our editors as an exceptional contribution.

Placing a high performance slideshow on an MS Access Form

Nick67
CERTIFIED EXPERT
Published:
Updated:
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
5,797 Views
Nick67
CERTIFIED EXPERT

Comments (1)

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

Have a question about something in this article? You can receive help directly from the article author. Sign up for a free trial to get started.