Option Compare Database
Option Explicit
'need a reference to the MS Office Objects XX.0 (11.0 12.0, 14.0 whichever) library
'need a reference to MS Windows Image Acquisition 2.0 library
Private Sub cmdSelect_Click()
'Declare a variable as a FileDialog object.
Dim fd As FileDialog
'Create a FileDialog object as a File Picker dialog box.
Set fd = Application.FileDialog(msoFileDialogFilePicker)
'Declare a variable to contain the path
'of the selected item. Even though the path is a String,
'the variable must be a Variant because the For Each...Next
'routines only work with Variants and Objects.
Dim vrtSelectedItem As Variant
Dim EXIFProperties As String
Dim p As WIA.Property
Dim Img As WIA.ImageFile
Dim IP As WIA.ImageProcess
Dim v As WIA.Vector
Set Img = CreateObject("WIA.ImageFile")
Set IP = CreateObject("WIA.ImageProcess")
Set v = CreateObject("WIA.Vector")
'Use a With...End With block to reference the FileDialog object.
With fd
.InitialView = msoFileDialogViewThumbnail 'nice for images, for files use msoFileDialogViewDetails
.Title = "Image Selector"
.InitialFileName = Application.CurrentProject.Path 'let's point at the folder we're in to start
.ButtonName = "Select"
.AllowMultiSelect = False ' uh uh, only one at a time buckwheat
'Use the Show method to display the File Picker dialog box and return the user's action.
'The user pressed the action button.
If .Show = True Then
'check that only one file was picked
If .SelectedItems.Count > 1 Then
MsgBox "You may only select one item. Try again!"
Exit Sub
Else
vrtSelectedItem = .SelectedItems(1)
End If
'Now what? We've got a file selected
'Let's stuff its path into the textbox
Me.txtPath = vrtSelectedItem
'Let's load the image in WIA and get some properties
Img.LoadFile vrtSelectedItem
For Each p In Img.Properties
Select Case p.PropertyID
Case 271 'camera maker
Case 272 'camera model
Case 274 'orientation 1 normal, 3 flip, 6 clockwise 90º, 8 clockwise 270º
Case 306 'datetime
Case Else
'the rest may interest you, but I am skipping them
'comment out the GoTo to see all the properties EXIF has about a file
GoTo skip
End Select
EXIFProperties = EXIFProperties & p.Name & "(" & p.PropertyID & ") = "
If p.IsVector Then
EXIFProperties = EXIFProperties & "[vector data not emitted]" & vbCrLf
ElseIf p.Type = RationalImagePropertyType Then
EXIFProperties = EXIFProperties & p.Value.Numerator & "/" & p.Value.Denominator & vbCrLf
ElseIf p.Type = StringImagePropertyType Then
EXIFProperties = EXIFProperties & """" & p.Value & """" & vbCrLf
Else
EXIFProperties = EXIFProperties & p.Value & vbCrLf
End If
skip:
Next
EXIFProperties = EXIFProperties & "Width: " & Img.Width & vbCrLf
EXIFProperties = EXIFProperties & "Height: " & Img.Height
End If
End With
Me.txtEXIF = EXIFProperties
End Sub
Ok, so we have some code to select the big images and tell us something about them. Now what? Well, if it was me -- and it is -- I'd like to decide how many fragments I'd like to split the original into (1,2,4,9), how much overlap each fragment should have with its neighbor, what target DPI I'd like all the fragments to have, and how big an image control I intend to display the fragments in. And if you look on frmSelectImages, you'll see all those options. Now, look at the code behind cmdCommit. You may be saying 'hold the phone, there's nothing going on there, you're just writing a record to the database.' Exactly! Here's the code behind cmdCommit
Private Sub cmdCommit_Click()
Dim db As Database
Dim rs As Recordset
Set db = CurrentDb
Set rs = db.OpenRecordset("select * from tblPictures where 1=2;", dbOpenDynaset, dbSeeChanges)
With rs
.AddNew
!picpath = Me.txtPath.Value
!fragments = Me.txtFragments.Value
!Overlap = Me.txtOverlap.Value
!desireddpi = Me.txtDPI.Value
!DesiredWidth = Me.txtWidth.Value
!comment = Me.txtComment.Value
.Update
End With
MsgBox "Done!"
End Sub
After all, I said we wanted to do things dynamically. If I'd have put the code behind the cmdCommit, then it would have been one-off. The split-down files would have been created and need saving. And that's not the idea. The idea is to have the report do the heavy lifting. So, what do we need?
Option Compare Database
Option Explicit
'reference to Microsoft Windows Image Acqusitiion Library 2.0 is required
'***use the code as desired
'***please maintain a reference to Nick67 of Experts Exchange as the author
Private Sub Report_Open(Cancel As Integer)
Dim myfolder As Object
Dim myfile As Object
Dim success As Boolean
Dim fs As Object 'our friend the filesystemobject
Set fs = CreateObject("Scripting.FileSystemObject")
Dim TempPath As String
TempPath = CurrentProject.Path & "\Resized\" ' a place to store dynamically generated images
If fs.folderexists(TempPath) = False Then
fs.createfolder (TempPath)
Else
'clean out resized folder
Set myfolder = fs.getfolder(TempPath)
For Each myfile In myfolder.Files
fs.DeleteFile myfile.Path, True 'whack the file, force it to die
Next myfile
End If
'let's empty tblTempPics
Application.SetOption "Confirm Action Queries", False
DoCmd.RunSQL ("delete * from tblTempPics;")
Application.SetOption "Confirm Action Queries", True
'variables for a recordset in tblPictures which stores the path to the images
Dim db As Database
Dim rs As Recordset
Set db = CurrentDb
Set rs = db.OpenRecordset("SELECT * FROM [tblPictures]", dbOpenDynaset, dbSeeChanges)
'there's only one at the moment, in production, you'll need to pare that down
'completely with the recordset so there's no oddities
rs.MoveLast
rs.MoveFirst
Do Until rs.EOF 'walk it through
success = SplitEm(rs!PicPath, rs!PictureID)
'splitem, and it calls shrinkem
rs.MoveNext
Loop
End Sub
Private Function SplitEm(PicPath As String, PictureID As Long)
'yes you could combine spliting and shrinking into one operation
'but what if you only want to split in certain circumstances?
'so I built a separate sub
Dim s As String
Dim BuiltPath As String
Dim TempPath As String
Dim x As Integer
Dim Img As WIA.ImageFile
Dim myfolder As Object
Dim myfile As Object
Dim db As Database
Dim rs As Recordset
Dim IP As ImageProcess
Set IP = CreateObject("WIA.ImageProcess")
IP.Filters.Add IP.FilterInfos("Crop").FilterID
BuiltPath = PicPath 'rs!Path 'where the original is
TempPath = CurrentProject.Path & "\Resized\" ' a place to store dynamically generated images
Set db = CurrentDb
Set rs = db.OpenRecordset("SELECT * FROM [tblPictures] where PictureID = " & PictureID, dbOpenDynaset, dbSeeChanges)
Dim DesiredDPI As Integer
Dim DesiredWidth As Single
Dim Fragments As Integer
Dim Overlap As Single
DesiredDPI = rs!DesiredDPI ' from the table
DesiredWidth = rs!DesiredWidth
Fragments = rs!Fragments
Overlap = rs!Overlap
Select Case Fragments
Case 1
'don't need to split, just need to scale
Set Img = CreateObject("WIA.ImageFile")
Img.LoadFile (BuiltPath) 'load the stored jpg in WIA
s = TempPath & PictureID & "-" & x & "-crop.jpg"
Img.SaveFile (s)
Set Img = Nothing
Call ShrinkEm(s, PictureID) 'original path
Case 2
'ok, I'm going to create 4 images
'each of them will be 50% + overlap of the originals, oriented on the top corners
'crop works by specifying how many pixels in from the location of the four corners you want to the crop points to be
For x = 1 To 2
Set Img = CreateObject("WIA.ImageFile")
Img.LoadFile (BuiltPath) 'load the stored jpg in WIA
Select Case x
Case 1 'top left
IP.Filters(1).Properties("Left") = 0
IP.Filters(1).Properties("Top") = 0
IP.Filters(1).Properties("Right") = Img.Width * (0.5 - Overlap)
IP.Filters(1).Properties("Bottom") = 0 'Img.Height
Case 2 'top right
IP.Filters(1).Properties("Left") = Img.Width * (0.5 - Overlap)
IP.Filters(1).Properties("Top") = 0
IP.Filters(1).Properties("Right") = 0
IP.Filters(1).Properties("Bottom") = 0 'Img.Height
End Select
Set Img = IP.Apply(Img)
s = TempPath & PictureID & "-" & x & "-crop.jpg"
Img.SaveFile (s)
Set Img = Nothing
Call ShrinkEm(s, PictureID)
Next x
Case 4
'ok, I'm going to create 4 images
'each of them will be 65% of the originals, oriented on each of the four corners
For x = 1 To 4
Set Img = CreateObject("WIA.ImageFile")
Img.LoadFile (BuiltPath) 'load the stored jpg in WIA
Select Case x
Case 1 'top left
IP.Filters(1).Properties("Left") = 0
IP.Filters(1).Properties("Top") = 0
IP.Filters(1).Properties("Right") = Img.Width * (0.5 - Overlap)
IP.Filters(1).Properties("Bottom") = Img.Height * (0.5 - Overlap)
Case 2 'top right
IP.Filters(1).Properties("Left") = Img.Width * (0.5 - Overlap)
IP.Filters(1).Properties("Top") = 0
IP.Filters(1).Properties("Right") = 0
IP.Filters(1).Properties("Bottom") = Img.Height * (0.5 - Overlap)
Case 3 'bottom left
IP.Filters(1).Properties("Left") = 0
IP.Filters(1).Properties("Top") = Img.Height * (0.5 - Overlap)
IP.Filters(1).Properties("Right") = Img.Width * (0.5 - Overlap)
IP.Filters(1).Properties("Bottom") = 0
Case 4 'bottom right
IP.Filters(1).Properties("Left") = Img.Width * (0.5 - Overlap)
IP.Filters(1).Properties("Top") = Img.Height * (0.5 - Overlap)
IP.Filters(1).Properties("Right") = 0
IP.Filters(1).Properties("Bottom") = 0
End Select
Set Img = IP.Apply(Img)
s = TempPath & PictureID & "-" & x & "-crop.jpg"
Img.SaveFile (s)
Set Img = Nothing
Call ShrinkEm(s, PictureID)
Next x
Case 9
For x = 1 To 9
Set Img = CreateObject("WIA.ImageFile")
Img.LoadFile (BuiltPath) 'load the stored jpg in WIA
Select Case x
Case 1 'top left
IP.Filters(1).Properties("Left") = 0 'left edge
IP.Filters(1).Properties("Top") = 0 'top edge
IP.Filters(1).Properties("Right") = Img.Width * (0.66 - Overlap)
IP.Filters(1).Properties("Bottom") = Img.Height * (0.66 - Overlap)
Case 2 'middle right
IP.Filters(1).Properties("Left") = Img.Width * (0.33 - Overlap / 2) 'go right one third of the width and left half the overlap
IP.Filters(1).Properties("Top") = 0 'top edge
IP.Filters(1).Properties("Right") = Img.Width * (0.33 - Overlap / 2) 'go left one third of the width and right half the overlap
IP.Filters(1).Properties("Bottom") = Img.Height * (0.66 - Overlap) 'come up two thirds of the way and down the overlap
Case 3 'top right
IP.Filters(1).Properties("Left") = Img.Width * (0.66 - Overlap)
IP.Filters(1).Properties("Top") = 0
IP.Filters(1).Properties("Right") = 0
IP.Filters(1).Properties("Bottom") = Img.Height * (0.66 - Overlap)
Case 4
IP.Filters(1).Properties("Left") = 0 'left edge
IP.Filters(1).Properties("Top") = Img.Height * (0.33 - Overlap) 'come down one thirds of the way and up half the overlap
IP.Filters(1).Properties("Right") = Img.Width * (0.66 - Overlap)
IP.Filters(1).Properties("Bottom") = Img.Height * (0.33 - Overlap) 'come down one thirds of the way and up half the overlap
Case 5
IP.Filters(1).Properties("Left") = Img.Width * (0.33 - Overlap / 2) 'go right one third of the width and left half the overlap
IP.Filters(1).Properties("Top") = Img.Height * (0.33 - Overlap) 'come down one thirds of the way and up half the overlap
IP.Filters(1).Properties("Right") = Img.Width * (0.33 - Overlap / 2) 'go left one third of the width and right half the overlap
IP.Filters(1).Properties("Bottom") = Img.Height * (0.33 - Overlap) 'come down one thirds of the way and up half the overlap
Case 6
IP.Filters(1).Properties("Left") = Img.Width * (0.66 - Overlap)
IP.Filters(1).Properties("Top") = Img.Height * (0.33 - Overlap) 'come down one thirds of the way and up half the overlap
IP.Filters(1).Properties("Right") = 0
IP.Filters(1).Properties("Bottom") = Img.Height * (0.33 - Overlap) 'come down one thirds of the way and up half the overlap
Case 7 'bottom left
IP.Filters(1).Properties("Left") = 0
IP.Filters(1).Properties("Top") = Img.Height * (0.66 - Overlap)
IP.Filters(1).Properties("Right") = Img.Width * (0.33 - Overlap)
IP.Filters(1).Properties("Bottom") = 0
Case 8 'bottom middle
IP.Filters(1).Properties("Left") = Img.Width * (0.33 - Overlap / 2) 'go right one third of the width and left half the overlap
IP.Filters(1).Properties("Top") = Img.Height * (0.66 - Overlap)
IP.Filters(1).Properties("Right") = Img.Width * (0.33 - Overlap / 2) 'go left one third of the width and right half the overlap
IP.Filters(1).Properties("Bottom") = 0
Case 9 'bottom right
IP.Filters(1).Properties("Left") = Img.Width * (0.66 - Overlap)
IP.Filters(1).Properties("Top") = Img.Height * (0.66 - Overlap)
IP.Filters(1).Properties("Right") = 0
IP.Filters(1).Properties("Bottom") = 0
End Select
Set Img = IP.Apply(Img)
s = TempPath & PictureID & "-" & x & "-crop.jpg"
Img.SaveFile (s)
Set Img = Nothing
Call ShrinkEm(s, PictureID)
Next x
End Select
End Function
Private Sub ShrinkEm(PicPath As String, PictureID As Long)
Dim s As String
Dim BuiltPath As String
Dim TempPath As String
Dim x As Integer
Dim Img As WIA.ImageFile
Dim DesiredDPI As Integer
Dim DesiredWidth As Single
Dim Fragments As Integer
Dim Overlap As Single
Dim IP As ImageProcess
Set IP = CreateObject("WIA.ImageProcess")
Dim fs As Object 'our friend the filesystemobject
Set fs = CreateObject("Scripting.FileSystemObject")
IP.Filters.Add IP.FilterInfos("Scale").FilterID
'IP.Filters(1).Properties("MaximumWidth") = 1600 'you can hand code an exact size
'IP.Filters(1).Properties("MaximumHeight") = 1200 'you can hand code an exact size
'variables for a recordset in tblTempPictures which stores the path to the new images
Dim db As Database
Dim rs As Recordset
Dim rs1 As Recordset
Set db = CurrentDb
Set rs = db.OpenRecordset("SELECT * FROM [tbltempPics]", dbOpenDynaset, dbSeeChanges)
BuiltPath = PicPath 'rs!Path 'where the original is
TempPath = CurrentProject.Path & "\Resized\" ' a place to store dynamically generated images
'no longer needed, set as public variable in SplitEm
'DesiredDPI = Nz(Forms!frmOpenReports!txtDesiredDPI, 96) ' from the form
Set Img = CreateObject("WIA.ImageFile")
Img.LoadFile (BuiltPath) 'load the stored jpg in WIA
Set rs1 = db.OpenRecordset("SELECT * FROM [tblPictures] where PictureID = " & PictureID, dbOpenDynaset, dbSeeChanges)
DesiredDPI = rs1!DesiredDPI ' from the table
DesiredWidth = rs1!DesiredWidth
Fragments = rs1!Fragments
Overlap = rs1!Overlap
IP.Filters(1).Properties("MaximumWidth") = DesiredWidth * DesiredDPI '96 or whatever dpi * control width / twips per inch
IP.Filters(1).Properties("MaximumHeight") = DesiredWidth * DesiredDPI '96 or whatever dpi * control height /twips per inch
'Dim up a WIA.property
Dim prpty As WIA.Property
'Add the second filter
IP.Filters.Add IP.FilterInfos("RotateFlip").FilterID
'and then set the rotation according to what it finds
For Each prpty In Img.Properties
If prpty.PropertyID = 274 Then
Select Case prpty.Value
Case 1
IP.Filters(2).Properties("RotationAngle") = 0 'do nothing
Case 3
IP.Filters(2).Properties("RotationAngle") = 180 'flip
Case 6
IP.Filters(2).Properties("RotationAngle") = 90 'twist 90
Case 8
IP.Filters(2).Properties("RotationAngle") = 270 'twist 270
End Select
End If
Next
Set Img = IP.Apply(Img)
s = Left(PicPath, Len(PicPath) - 4) & "-small.jpg"
If fs.FileExists(s) = False Then
Img.SaveFile (s)
End If
With rs
.AddNew
!OriginalPicID = PictureID
!Path = s
.Update
End With
Set Img = Nothing
End Sub
Option Compare Database
Option Explicit
Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer)
If FormatCount > 1 Then Exit Sub
Dim theHeight As Single
'ok, maybe we've got a non-standard shaped image
Dim IP As ImageProcess
Set IP = CreateObject("WIA.ImageProcess")
Set Img = CreateObject("WIA.ImageFile")
Img.LoadFile (Me.Path) 'load the stored jpg in WIA
'now, we now the desired width
Me.ImageFrame.Width = Me.DesiredWidth * 1440
'the desired height should be the existing width/height ratio of the image
'scaled to our desired control size
theHeight = Img.Height / Img.Width * Me.DesiredWidth * 1440
'make the detail section big enough to hold it
'and the existing control
Me.Detail.Height = theHeight + 100
Me.ImageFrame.Height = theHeight
Me.ImageFrame.Picture = Me.Path.Value
'suck any whitespace out
'note that trying for Me.Detail.Height = 0 will explode anything later than A2003
'That bug was report 7 years ago, and is still not fixed in Access 2013
Me.Detail.Height = 7
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: