Home
dbPix
Download
Order
Testimonials
Support
Tutorials
Samples
KnowledgeBase
Links
Revision History
Documentation
Search
Contact
Site Map

Graph: dbPix image storage vs OLE Embedding and Linking in Microsoft Access


DBPix Sample Source Code: frmCapture
Back to sample
Option Compare Database
Option Explicit

' API Sleep function - we need to wait briefly when a camera is first connected before attempting communication
Private Declare Sub sapiSleep Lib "kernel32" Alias "Sleep" (ByVal dwMilliseconds As Long)


Private Sub Form_Open(Cancel As Integer)
    ' Register for WIA Device Manager events, so we know when a camera is connected or disconnected
    WIA_DeviceMgr.RegisterEvent wiaEventDeviceConnected, wiaAnyDeviceID
    WIA_DeviceMgr.RegisterEvent wiaEventDeviceDisconnected, wiaAnyDeviceID
    
    ' Update the list of cameras in the camera combo
    UpdateCameraCombo
End Sub

' WIA Device Manager Event Occured
Private Sub WIA_DeviceMgr_OnEvent(ByVal EventID As String, ByVal DeviceID As String, ByVal ItemId As String)
    ' A device has been connected or disconnected - update the camera combo
    If EventID = wiaEventDeviceDisconnected Then
        UpdateCameraCombo
    ElseIf EventID = wiaEventDeviceConnected Then
        sSleep (3000)   ' Wait before trying to get device info, otherwise get Device Not Ready error
        UpdateCameraCombo
    End If
End Sub

' Camera Combo changed - Update buttons according to camera capabilities
Private Sub cboCameras_Change()
    ' Column 2 in the combo stores a value indicating whether the camera supports the 'Take Picture' command.
    If cboCameras.Column(2) = 1 Then
        btnTakePicture.Enabled = True
    Else
        btnTakePicture.Enabled = False
    End If
End Sub


Private Sub btnTakePicture_Click()

    Dim WIA_Device As Object ' WIA.Device
    Dim WIA_Item As Object ' WIA.item
    Dim DeviceID As String
        
    DeviceID = cboCameras ' Get the selected Device Id from the Combo-Box (column 0)

    On Error GoTo Err_Handler
    
    Set WIA_Device = WIA_DeviceMgr.DeviceInfos(DeviceID).Connect ' Try to connect to the device
    If (WIA_Device Is Nothing) Then GoTo Exit_Here

    Set WIA_Item = WIA_Device.ExecuteCommand(wiaCommandTakePicture) ' Send the 'Take Picture' command
    RetrieveItem WIA_Device, WIA_Item

Exit_Here:
    Set WIA_Device = Nothing
    Set WIA_Item = Nothing
    Exit Sub

Err_Handler:
    MsgBox Err.Description, vbOKOnly + vbCritical, "Error Taking Picture"
    Resume Exit_Here

End Sub


Private Sub btnRetrievePhoto_Click()
    Dim WIA_Device As Object ' WIA.Device
    Dim WIA_Items As Object 'WIA.Items
    Dim WIA_Item As Object ' WIA.Item
    Dim DeviceID As String

    DeviceID = cboCameras

    On Error GoTo Err_Handler

    Set WIA_Device = WIA_DeviceMgr.DeviceInfos(DeviceID).Connect
    If (WIA_Device Is Nothing) Then GoTo Exit_Here

    Set WIA_Items = WIA_CommonDialog.ShowSelectItems(WIA_Device, UnspecifiedIntent, MaximizeQuality, True)
    If (WIA_Items Is Nothing) Then GoTo Exit_Here
    
    If WIA_Items.Count = 1 Then
        Set WIA_Item = WIA_Items(1)
        RetrieveItem WIA_Device, WIA_Item
    End If

Exit_Here:
    Set WIA_Device = Nothing
    Set WIA_Items = Nothing
    Set WIA_Item = Nothing
    Exit Sub

Err_Handler:
    MsgBox Err.Description, vbOKOnly + vbCritical, "Error Retrieving Picture"
    Resume Exit_Here

End Sub


Private Sub btnRetrieveAllPhotos_Click()
    Dim WIA_Device As Object ' WIA.Device
    Dim DeviceID As String
    Dim colRetrievedItemIdList As New Collection ' List of retrieved item Id's for deletion
    Dim ListItem As Variant
    Dim strListItem As String

    DeviceID = cboCameras

    On Error GoTo Err_Handler

    Set WIA_Device = WIA_DeviceMgr.DeviceInfos(DeviceID).Connect ' Connect to device
    If (WIA_Device Is Nothing) Then GoTo Exit_Here

    RetrieveAllItems WIA_Device.items, colRetrievedItemIdList ' Retrieve all items and store Id's

    If chkDeleteFromCamera Then ' Delete checkbox checked - try to delete the images from the camera
        For Each ListItem In colRetrievedItemIdList
            strListItem = ListItem
            DeleteItem WIA_Device.items, strListItem
        Next
    End If

Exit_Here:
    Set WIA_Device = Nothing
    Set colRetrievedItemIdList = Nothing
    Exit Sub

Err_Handler:
    MsgBox Err.Description, vbOKOnly + vbCritical, "Error Retrieving Pictures"
    Resume Exit_Here

End Sub


Private Function RetrieveAllItems(ByRef WIA_Items As Object, ByRef ItemIdCollection As Collection) As Boolean
    Dim WIA_ImageFile As Object ' WIA.Imagefile
    Dim i As Integer

    On Error GoTo Err_Handler

    If Not (WIA_Items Is Nothing) Then
        For i = 1 To WIA_Items.Count
            Dim f
            f = WIA_Items.item(i).Properties("Item Flags")
            If (f And ImageItemFlag) = ImageItemFlag Then
            
                Dim format As Variant
                For Each format In WIA_Items.item(i).Formats ' Search for JPEG in available formats
                    If (format = wiaFormatJPEG) Then
                        Set WIA_ImageFile = WIA_CommonDialog.ShowTransfer(WIA_Items.item(i), format) ' Retrieve the image, showing the progress dialog
            
                        ' Load the image data into the DBPix control (which stores image in the bound field in the table)
                        DoCmd.GoToRecord , , acNewRec
                        If DBPixCtrl.ImageLoadBlob(WIA_ImageFile.FileData.BinaryData) Then
                            ' Image was Retrieved OK - Add Id to list for deletion
                            ItemIdCollection.Add (WIA_Items.item(i).ItemId)

                            SaveImageInfo WIA_Items.item(i), WIA_ImageFile
                        End If
                        Exit For
                    End If
                Next
            Else
                ' Not an image - may be a directory, recurse through child items
                RetrieveAllItems WIA_Items.item(i).items, ItemIdCollection
            End If
        Next
    End If

Exit_Here:
    Set WIA_ImageFile = Nothing
    Exit Function

Err_Handler:
    MsgBox Err.Description, vbOKOnly + vbCritical, "Error Retrieving Picture"
    Resume Exit_Here

End Function



Private Sub RetrieveItem(ByRef WIA_Device As Object, ByRef WIA_Item As Object)
    Dim WIA_ImageFile As Object ' WIA.Imagefile
    
    On Error GoTo Err_Handler
    
    If Not (WIA_Item Is Nothing) Then
        Dim format As Variant
        For Each format In WIA_Item.Formats ' Search for JPEG in available formats
            If (format = wiaFormatJPEG) Then
                Set WIA_ImageFile = WIA_CommonDialog.ShowTransfer(WIA_Item, format) ' Retrieve the image, showing the progress dialog

                ' Load the image data into the DBPix control (which stores image in the bound field in the table)
                If DBPixCtrl.ImageLoadBlob(WIA_ImageFile.FileData.BinaryData) Then

                    SaveImageInfo WIA_Item, WIA_ImageFile

                    ' Image was Retrieved OK
                    If chkDeleteFromCamera Then ' Delete checkbox checked - try to delete the image from the camera
                        DeleteItem WIA_Device.items, WIA_Item.ItemId
                    End If
                End If
                Exit For
            End If
        Next
    End If
    
Exit_Here:
    Set WIA_ImageFile = Nothing
    Exit Sub

Err_Handler:
    MsgBox Err.Description, vbOKOnly + vbCritical, "Error Retrieving Picture"
    Resume Exit_Here

End Sub


Private Function DeleteItem(ByRef WIA_Items As Object, ItemId As String) As Boolean
    'Note: Some Cameras don't support deleting pictures
    On Error GoTo Err_Handler
    Dim i As Integer
    DeleteItem = False

    For i = 1 To WIA_Items.Count ' Find the item with matching ItemId
        If WIA_Items(i).ItemId = ItemId Then ' Found item
            DeleteItem = True
            WIA_Items.Remove i
            Exit Function
        Else ' Not found, recurse (may be a directory)
            If (DeleteItem(WIA_Items(i).items, ItemId) = True) Then
                DeleteItem = True
                Exit Function
            End If
        End If
    Next
    
Exit_Here:
    Exit Function

Err_Handler:
    MsgBox Err.Description, vbOKOnly + vbCritical, "Error Deleting Picture From Camera"
    Resume Exit_Here

End Function

Private Function SaveImageInfo(ByRef WIA_Item As Object, ByRef WIA_ImageFile As Object)
    ' If the image has a 'DateTime' property store it in the table
    If WIA_ImageFile.Properties.Exists("DateTime") Then
        [DateTaken] = WIA_ImageFile.Properties.item("DateTime")
    End If

    ' If the image has a filename and extension properties store it in the table
    If WIA_Item.Properties.Exists("Item Name") And WIA_Item.Properties.Exists("Filename extension") Then
        [OriginalFilename] = WIA_Item.Properties.item("Item Name") & "." & WIA_Item.Properties.item("Filename extension")
    End If

    ' Disable the following line to see what other properties are available
    Exit Function

    ' Dump remaining properties
    Dim p 'As Property
    Dim s 'As String

    Debug.Print "***** ImageFile Properties ***** "
    For Each p In WIA_ImageFile.Properties
        s = p.Name & "(" & p.PropertyID & ") = "
        If p.IsVector Then
            s = s & "[vector data not emitted]"
        ElseIf p.Type = RationalImagePropertyType Then
            s = s & p.Value.Numerator & "/" & p.Value.Denominator
        ElseIf p.Type = StringImagePropertyType Then
            s = s & """" & p.Value & """"
        Else
            s = s & p.Value
        End If
        Debug.Print s
    Next

    Debug.Print "***** ImageFile Properties ***** "
    For Each p In WIA_Item.Properties
        s = p.Name & "(" & p.PropertyID & ") = "
        If p.IsVector Then
            s = s & "[vector data not emitted]"
        ElseIf p.Type = RationalImagePropertyType Then
            s = s & p.Value.Numerator & "/" & p.Value.Denominator
        ElseIf p.Type = StringImagePropertyType Then
            s = s & """" & p.Value & """"
        Else
            s = s & p.Value
        End If
        Debug.Print s
    Next
End Function

Private Sub UpdateCameraCombo()
    ' Populate Camera combo-box with a list of available cameras
    ' Column 0 contains the Device Id
    ' Column 1 contains the device name
    ' Column 2 indicates whether the camera supports the 'Take Picture' command
    Dim i As Integer
    Dim ComboText As String
    Dim DeviceString As String
    Dim WIA_Device As Object ' WIA.Device
    Dim WIA_DeviceCommand As Object ' WIA.DeviceCommand

    On Error GoTo Err_Handler

    cboCameras = ""
    ComboText = ""

    For i = 1 To WIA_DeviceMgr.DeviceInfos.Count
        If WIA_DeviceMgr.DeviceInfos(i).Type = CameraDeviceType Then
            ' Found a Camera device - check if it supports 'Take Picture' command
            Set WIA_Device = WIA_DeviceMgr.DeviceInfos(i).Connect
            If Not (WIA_Device Is Nothing) Then
                DeviceString = WIA_DeviceMgr.DeviceInfos(i).DeviceID & ";""" & WIA_DeviceMgr.DeviceInfos(i).Properties("Name").Value & """;" & 0 & ";"
                For Each WIA_DeviceCommand In WIA_Device.Commands
                    If WIA_DeviceCommand.CommandID = wiaCommandTakePicture Then
                        ' Camera supports 'Take Picture' command - set column 3 value to 1
                        DeviceString = WIA_DeviceMgr.DeviceInfos(i).DeviceID & ";""" & WIA_DeviceMgr.DeviceInfos(i).Properties("Name").Value & """;" & 1 & ";"
                        Exit For
                    End If
                Next
                ComboText = ComboText & DeviceString
                Set WIA_Device = Nothing
            End If
        End If
    Next

    cboCameras.RowSource = ComboText

    If cboCameras.ListCount > 0 Then
        ' At least one camera is available - select first camera and enable 'Retrieve' button
        cboCameras.SetFocus
        cboCameras.ListIndex = 0
        btnRetrievePhoto.Enabled = True
        btnRetrieveAllPhotos.Enabled = True
    Else
        ' No cameras available - disable buttons
        DBPixCtrl.SetFocus
        btnTakePicture.Enabled = False
        btnRetrievePhoto.Enabled = False
        btnRetrieveAllPhotos.Enabled = False
    End If

Exit_Here:
    Set WIA_Device = Nothing
    Set WIA_DeviceCommand = Nothing
Exit Sub

Err_Handler:
    MsgBox Err.Description, vbOKOnly + vbCritical, "Error Retrieving Camera Info"
    Resume Exit_Here

End Sub


' Pause execution
Sub sSleep(lngMilliSec As Long)
    If lngMilliSec > 0 Then
        Call sapiSleep(lngMilliSec)
    End If
End Sub
Back to sample