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
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
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
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
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
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.
Comments (1)
Commented:
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