WIA driving me a little crazy. Can only transfer one file from common dialog box with Access/VBA

avirocks12345 used Ask the Experts™
Lately I've been looking for a good solution for integrating Camera Stills into an Access 2007 database. Right now I'm settling on taking pictures with a Digital Camera and grabbing them with WIA. The problem I'm having is that I can only get the WIA generated common dialog box to give my one picture at a time, rather than allowing me to grab multiple pictures at once.

This is the common dialog box that I'm looking for, note that it says to grab more than one image hold shift or ctrl:
 WIA Commmon dialog multiple files
This is what mine looks like, it only allows one picture at a time:
 WIA common dialog box single file
I'm using windows 7 64 bit and access 2007, but tested the code on windows XP 32bit just to make sure. Also same result with 2 different cameras

I've tried this code:
    Dim Commondialog1 As WIA.CommonDialog
    Dim wiadevice As Object
    Dim wiadevice1 As Object
    Set Commondialog1 = New CommonDialog
    Set wiadevice = Commondialog1.ShowSelectDevice
    Set wiadevice1 = Commondialog1.ShowSelectItems(wiadevice)

Open in new window

And this code:
    Dim imfile As WIA.ImageFile
    Dim Commondialog1 As WIA.CommonDialog    
    Set Commondialog1 = New CommonDialog
    Set imfile = Commondialog1.ShowAcquireImage

Open in new window

Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Most Valuable Expert 2014
Your syntax isn't complete

object.ShowSelectItems( _
    Device As Device, _
    [Intent As WiaImageIntent,] _
    [Bias As WiaImageBias,] _
    [SingleSelect As Boolean,] _
    [UseCommonUI As Boolean,] _
    [CancelError As Boolean]) As Items

See singleselect?

In my useage, the syntax is
Set itms = CD.ShowSelectItems(dev, ColorIntent, MaximizeQuality, False, True, False)
and I get MultiSelect.

Here's my whole function for snagging pictures off a camera, jamming them into a folder, and then setting pointers in a db table.
It also creates a copy of 1600 x 1200 if large pictures are being selected
Assumes WIA (duh)
DAO 3.6
Windows Scripting Host Object Model.

Adapt it as you see fit
Private Function GetFromCameraDevice()
'ok I want to get a camera and select some images from it

Dim I As Integer
Dim dev As WIA.Device
Dim itms As WIA.Items
Dim itm As WIA.Item
Dim img As WIA.ImageFile
Dim s As String
Dim BuiltPath As String
Dim x As Integer
Dim wait As Double
Dim Success As Boolean
Dim ConfirmString As String
Dim myJobID As Long

Dim DM As DeviceManager
Set DM = CreateObject("WIA.DeviceManager")

Dim CD As CommonDialog
Set CD = CreateObject("WIA.CommonDialog")

Dim IP As ImageProcess
Set IP = CreateObject("WIA.ImageProcess")
IP.Filters.Add IP.FilterInfos("Scale").FilterID
IP.Filters(1).Properties("MaximumWidth") = 1600
IP.Filters(1).Properties("MaximumHeight") = 1200
Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")

'variables for a recordet in tblPictures
Dim db As Database
Dim rs As Recordset

Set db = CurrentDb
Set rs = db.OpenRecordset("SELECT * FROM [tblPictures] WHERE 1=2;", dbOpenDynaset, dbSeeChanges)
myJobID = Me.JobID

For I = 1 To DM.DeviceInfos.count 'run through the devices in a loop
    Set dev = DM.DeviceInfos(I).Connect ' connect to it
    If dev.Type = CameraDeviceType And dev.Properties("Name").Value Like "canon*" Then ' if its a canon camera
        'MsgBox DM.DeviceInfos(i).Properties("Name").Value
    Set itms = CD.ShowSelectItems(dev, ColorIntent, MaximizeQuality, False, True, False)
    BuiltPath = CreateBuildPath()
    For Each itm In itms
        Set img = itm.Transfer 'transfers the picture from the camera to an object that can be processed or saved
        'now check if it's wider than 1600 pixels
        s = BuiltPath & itm.Properties("Item Name").Value & ".jpg"
        If img.Width < 1601 Then 'small enough, just save
            img.SaveFile (s) ' saves the raw image to a fully qualified filename, some parts I may need to pass into this function
            ' deal with stupidly large pictures
            If fs.FolderExists(BuiltPath & "large\") = False Then
                fs.CreateFolder BuiltPath & "large\"
            End If
            s = BuiltPath & "large\" & itm.Properties("Item Name").Value & ".jpg"
            img.SaveFile (s)

            Set img = IP.Apply(img)
            s = BuiltPath & itm.Properties("Item Name").Value & ".jpg"
            img.SaveFile (s)
        End If
        'image saved
        With rs
                ![JobID] = myJobID
                ![Path] = BuiltPath
                ![Filename] = itm.Properties("Item Name").Value & ".jpg"
        End With
        x = 1
        Do Until Success = True
            Success = fs.FileExists(s) Or x = 3
            If Success = False Then
                wait = Timer
                While Timer < wait + 1
                   DoEvents  'do nothing
                Success = fs.FileExists(s)
                x = x + 1
            End If
        If Success = True Then
            If Nz(ConfirmString, "") = "" Then
                ConfirmString = itm.Properties("Item Name").Value & ".jpg"
                ConfirmString = ConfirmString & vbCrLf & itm.Properties("Item Name").Value & ".jpg"
            End If
            'MsgBox PicFileName & " transferred successfully!"
            MsgBox "The transfer of " & itm.Properties("Item Name").Value & ".jpg" & " failed"
        End If

    Set rs = Nothing
    Set db = Nothing
    MsgBox ConfirmString & vbCrLf & "transferred successfully!"
    Dim test2 As Boolean
    test2 = Nz(DLookup("[jobid]", "tblPictures", "[jobid]=" & Me.JobID), 0)
    If test2 = 0 Then
        Forms!frmFieldReport!cmdOpenFolder.Visible = False
        Forms!frmFieldReport!cmdRemovePictures.Visible = False
        Forms!frmFieldReport!cmdOpenFolder.Visible = True
        Forms!frmFieldReport!cmdRemovePictures.Visible = True
    End If

    End If

End Function

Open in new window


Oh! That was sooo simple, Thank you very much Nick, I can't believe I missed that!

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial