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

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
        Else
            ' 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
        'NOW ADD A DB POINTER
        With rs
                .AddNew
                ![JobID] = myJobID
                ![Path] = BuiltPath
                ![Filename] = itm.Properties("Item Name").Value & ".jpg"
                .Update
        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
                Wend
                Success = fs.FileExists(s)
                x = x + 1
            End If
        Loop
        If Success = True Then
            If Nz(ConfirmString, "") = "" Then
                ConfirmString = itm.Properties("Item Name").Value & ".jpg"
            Else
                ConfirmString = ConfirmString & vbCrLf & itm.Properties("Item Name").Value & ".jpg"
            End If
            'MsgBox PicFileName & " transferred successfully!"
            
        Else
            MsgBox "The transfer of " & itm.Properties("Item Name").Value & ".jpg" & " failed"
        End If

    Next
    
    rs.Close
    db.Close
    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
    Else
        Forms!frmFieldReport!cmdOpenFolder.Visible = True
        Forms!frmFieldReport!cmdRemovePictures.Visible = True
    End If

    End If
Next


End Function

Select all Open in new window