frmmain.frm

canon 相机SDK,非常难得

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "Comdlg32.ocx"
Begin VB.Form frmMain 
   BorderStyle     =   1  '屌掕(幚慄)
   Caption         =   "GetPicture"
   ClientHeight    =   3840
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   4425
   Icon            =   "frmMain.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3840
   ScaleWidth      =   4425
   StartUpPosition =   3  'Windows 偺婛掕抣
   Begin VB.Timer Timer1 
      Enabled         =   0   'False
      Interval        =   1
      Left            =   1680
      Top             =   1560
   End
   Begin MSComDlg.CommonDialog dlgSaveImage 
      Left            =   2160
      Top             =   1560
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.ListBox lstItemList 
      Height          =   1140
      ItemData        =   "frmMain.frx":0442
      Left            =   240
      List            =   "frmMain.frx":0444
      TabIndex        =   3
      Top             =   2520
      Width           =   3975
   End
   Begin VB.CommandButton cmdGetPicture 
      Caption         =   "GetPicture"
      Height          =   420
      Left            =   2880
      TabIndex        =   1
      Top             =   960
      Width           =   1335
   End
   Begin VB.CommandButton cmdGetThumbnail 
      Caption         =   "GetThumbnail"
      Height          =   420
      Left            =   2880
      TabIndex        =   2
      Top             =   1440
      Width           =   1335
   End
   Begin VB.CommandButton cmdCamera 
      Caption         =   "Connect"
      Height          =   420
      Left            =   2880
      TabIndex        =   0
      Top             =   240
      Width           =   1335
   End
   Begin VB.Label Label1 
      Caption         =   "Files:"
      Height          =   255
      Left            =   240
      TabIndex        =   4
      Top             =   2280
      Width           =   855
   End
   Begin VB.Image imgDispImage 
      BorderStyle     =   1  '幚慄
      Height          =   1800
      Left            =   240
      Stretch         =   -1  'True
      Top             =   240
      Width           =   2400
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private m_hSource        As Long     'Handle of the source
Private m_hFunc          As Long     'Handle of the callback function
Private m_bCamConnect    As Boolean  'If camera is connected or not

Private Sub lstItemList_Click()
    imgDispImage.Picture = LoadPicture
End Sub

Private Sub cmdCamera_Click()
    Dim err As Long

    lstItemList.Clear
    imgDispImage.Picture = LoadPicture
    
    If m_bCamConnect = False Then
        err = doCamConnect()
        If err <> cdOK Then
            Exit Sub
        End If

        err = GetImageItem()
        If err = cdOK Then
            cmdCamera.Caption = "Disconnect"
            cmdGetPicture.Enabled = True
            cmdGetThumbnail.Enabled = True
            Timer1.Enabled = True
        Else
            Call doCamDisconnect
        End If
    Else
        err = doCamDisconnect()
        If err = cdOK Then
            cmdCamera.Caption = "Connect"
            cmdGetPicture.Enabled = False
            cmdGetThumbnail.Enabled = False
            Timer1.Enabled = False
        End If
    End If
            
End Sub

Private Sub cmdGetPicture_Click()
    Call GetImageData(GET_DATA_TYPE_PICTURE)
End Sub

Private Sub cmdGetThumbnail_Click()
    Call GetImageData(GET_DATA_TYPE_THUMBNAIL)
End Sub

Private Sub Form_Load()
    Dim err As Long
    Dim ver As cdVersionInfo
    
    ver.MajorVersion = 6
    ver.MinorVersion = 1
    ver.Size = Len(ver)
    
    err = CDStartSDK(ver, 0)
    If err <> cdOK Then
        GoTo ErrHandler
    End If

    m_hSource = 0
    m_hFunc = 0
    m_bCamConnect = False

    cmdGetPicture.Enabled = False
    cmdGetThumbnail.Enabled = False
    
    Exit Sub
    
ErrHandler:
    MsgBox "ErrorCode = 0x" & Hex(err), vbCritical, "Error"
    Unload Me

End Sub

Private Sub Form_Unload(Cancel As Integer)
    Dim err As Long
    
    If m_bCamConnect = True Then
        Call doCamDisconnect
    End If
    
    err = CDFinishSDK()
    If err <> cdOK Then
        MsgBox "ErrorCode = 0x" & Hex(err), vbCritical, "Error"
    End If
    
End Sub

Private Function doCamConnect()

    Dim err As Long

    frmCamSelect.Show 1
    
    If m_SourceInfo.SurceType <> cdSRC_TYPE_CAMERA Then
        doCamConnect = DEVICE_NOT_CHOICE
        Exit Function
    End If

    err = CDOpenSource(m_SourceInfo, m_hSource)
    If err <> cdOK Then
        GoTo ErrHandler
    End If

    err = CDRegisterEventCallbackFunction(m_hSource, AddressOf EventCallbackFunc, 0, m_hFunc)
    If err <> cdOK Then
        GoTo ErrHandler
    End If

    m_bCamConnect = True
    doCamConnect = cdOK
    Exit Function

ErrHandler:
    MsgBox "ErrorCode = 0x" & Hex(err), vbCritical, "Error"
    doCamConnect = err

End Function

Private Function GetImageItem()
    Dim err As Long

    Dim hEnumVol As Long
    Dim hVol As Long
    Dim hItem As Long
    Dim hEnumImage As Long
    Dim hImage As Long

    Dim VolInfo As cdVolumeInfo
    Dim iteminfo As cdItemInfo
    Dim ImageNum As Long

    err = CDLockUI(m_hSource)
    If err <> cdOK Then
        GoTo ErrHandler
    End If

    'Make a search for DCIM forder
    hItem = 0
    err = CDEnumVolumeReset(m_hSource, hEnumVol)
    If err <> cdOK Then
        GoTo ErrHandler
    End If

    Do While CDEnumVolumeNext(hEnumVol, hVol) = cdOK
        err = CDGetVolumeInfo(hVol, VolInfo)
        If err <> cdOK Then
            GoTo ErrHandler
        End If

        If VolInfo.TotalSpace <> 0 Then
            err = FindDCIMFolder(hVol, hItem)
            If err <> cdOK Then
                GoTo ErrHandler
            End If
        End If

        If hItem <> 0 Then
            Exit Do
        End If
    Loop

    err = CDEnumVolumeRelease(hEnumVol)
    hEnumVol = 0
    If err <> cdOK Then
        GoTo ErrHandler
    End If

    'In case of no memory card or no DCIM forder
    If VolInfo.TotalSpace = 0 Or hItem = 0 Then
        err = IMAGE_FIND_ERROR
        GoTo ErrHandler
    End If

    'Get image item from DCIM folder
    err = CDEnumImageItemReset(hItem, 2, cdENUM_HAS_THUMBNAIL, hEnumImage)
    If err <> cdOK Then
        GoTo ErrHandler
    End If
    
    err = CDGetImageItemCount(hEnumImage, ImageNum)
    If err <> cdOK Then
        GoTo ErrHandler
    ElseIf ImageNum = 0 Then
        err = IMAGE_FIND_ERROR
        GoTo ErrHandler
    End If

    While CDEnumImageItemNext(hEnumImage, hImage) = cdOK

        err = CDGetItemInfo(hImage, iteminfo)
        If err <> cdOK Then
            GoTo ErrHandler
        End If

        If iteminfo.Type = cdITEM_TYPE_IMAGE_ITEM Then
            lstItemList.AddItem (iteminfo.Name)
            lstItemList.ItemData(lstItemList.NewIndex) = hImage
        End If
    Wend
    lstItemList.ListIndex = 0
        
    err = CDEnumImageItemRelease(hEnumImage)
    hEnumImage = 0
    If err <> cdOK Then
        GoTo ErrHandler
    End If

    err = CDUnlockUI(m_hSource)
    If err <> cdOK Then
        GoTo ErrHandler
    End If

    GetImageItem = cdOK
    Exit Function

ErrHandler:
    If hEnumImage <> 0 Then
        CDEnumImageItemRelease (hEnumImage)
    End If

    If hEnumVol <> 0 Then
        CDEnumVolumeRelease (hEnumVol)
    End If

    CDUnlockUI (m_hSource)

    If err = IMAGE_FIND_ERROR Then
        lstItemList.AddItem ("There are no images in the camera")
    Else
        MsgBox "ErrorCode = 0x" & Hex(err), vbCritical, "Error"
    End If

    GetImageItem = err

End Function

Private Function doCamDisconnect()
    Dim err As Long

    err = cdOK

    If m_bCamConnect = False Then
        Exit Function
    End If

    If m_hFunc <> 0 Then
        err = CDUnregisterEventCallbackFunction(m_hSource, m_hFunc)
        m_hFunc = 0
    End If

    If m_hSource <> 0 Then
        CDCloseSource (m_hSource)
        m_hSource = 0
    End If

    If err <> cdOK Then
        MsgBox "ErrorCode = 0x" & Hex(err), vbCritical, "Error"
    End If

    m_bCamConnect = False
    m_SourceInfo.SurceType = cdSRC_TYPE_INVALID
    doCamDisconnect = err

End Function

Private Function FindDCIMFolder(hVolume As Long, hRetItem As Long)
    Dim err As Long
    Dim hEnumItem As Long
    Dim hItem As Long
    Dim iteminfo As cdItemInfo

    hRetItem = 0
    err = CDEnumItemReset(hVolume, cdENUM_HAS_THUMBNAIL, hEnumItem)
    If err <> cdOK Then
        GoTo ErrHandler
    End If

    Do While CDEnumItemNext(hEnumItem, hItem) = cdOK
        err = CDGetItemInfo(hItem, iteminfo)
        If err <> cdOK Then
            GoTo ErrHandler
        End If

        If StrComp(Left(iteminfo.Name, Len("DCIM")), "DCIM") = 0 Then
            hRetItem = hItem
            Exit Do
        End If
    Loop

    err = CDEnumItemRelease(hEnumItem)
    hEnumItem = 0
    If err <> cdOK Then
        GoTo ErrHandler
    End If

    FindDCIMFolder = cdOK
    Exit Function

ErrHandler:
    If hEnumItem <> 0 Then
        CDEnumItemRelease (hEnumItem)
    End If
    FindDCIMFolder = err

End Function

Private Sub GetImageData(GetType As Integer)
    
    Dim err As Long
    Dim hImgItem As Long
    Dim hImgData As Long
    Dim myMedium As cdStgMedium
    Dim iteminfo As cdItemInfo
        
    If lstItemList.ListIndex = -1 Then
        Exit Sub
    End If
    hImgItem = lstItemList.ItemData(lstItemList.ListIndex)
    
    err = CDLockUI(m_hSource)
    If err <> cdOK Then
        GoTo ErrHandler
    End If

    err = CDOpenImage(hImgItem)
    If err <> cdOK Then
        GoTo ErrHandler
    End If
    
    If GetType = GET_DATA_TYPE_PICTURE Then
        err = CDGetPicture(hImgItem, hImgData)
    ElseIf GetType = GET_DATA_TYPE_THUMBNAIL Then
        err = CDGetThumbnail(hImgItem, hImgData)
    End If
    
    If err <> cdOK Then
        GoTo ErrHandler
    End If
    
    err = CDGetItemInfo(hImgItem, iteminfo)
    If err <> cdOK Then
        GoTo ErrHandler
    End If
    
    'CommonDialog
    dlgSaveImage.CancelError = True
    On Error GoTo ErrHandler
    dlgSaveImage.Flags = cdlOFNOverwritePrompt
    dlgSaveImage.FileName = iteminfo.Name
    dlgSaveImage.Filter = "All Files (*.*)|*.*|" & _
                          "JPEG Files (*.jpg)|*.jpg|" & _
                          "RAW Files (*.crw)|*.crw"
    dlgSaveImage.FilterIndex = 1
    dlgSaveImage.ShowSave
    
    'Get Image Data
    myMedium.Type = cdMEMTYPE_FILE
    myMedium.u.lpszFileName = dlgSaveImage.FileName
    
    err = CDGetImageData(hImgData, myMedium, 0, 0, 0)
    If err <> cdOK Then
        GoTo ErrHandler
    End If
        
    imgDispImage.Picture = LoadPicture(myMedium.u.lpszFileName)
        
    err = CDCloseImage(hImgItem)
    hImgItem = 0
    If err <> cdOK Then
        GoTo ErrHandler
    End If
    
    err = CDUnlockUI(m_hSource)
    If err <> cdOK Then
        GoTo ErrHandler
    End If

    Exit Sub
    
ErrHandler:
    If hImgItem <> 0 Then
        CDCloseImage (hImgItem)
        hImgItem = 0
    End If
    
    CDUnlockUI (m_hSource)
    
    If err <> cdOK Then
        MsgBox "ErrorCode = 0x" & Hex(err), vbCritical, "Error"
    End If

End Sub

Private Sub Timer1_Timer()
    
    Select Case cdEVENT_SEVERITY(m_EventID)
        Case cdEVENT_SEVERITY_SHUTDOWN:
            Call cmdCamera_Click
            MsgBox "Camera is no longer available.", vbCritical
        Case cdEVENT_SEVERITY_NONE:
        Case cdEVENT_SEVERITY_WARNING:
    End Select
    m_EventID = 0

End Sub