none
vba excel, capture d'image à l'aide de avicap32.dll RRS feed

  • Question

  • Bonjour,

    dans le cadre professionnel (prise en charge d'installations techniques), nous utilisons une macro Excel permettant de faire une capture d'image par l'intermédiaire de la librairie "avicap32.dll". Cette capture d'image est intégrée sur une fiche correspondant au matériel technique visité.

    La récupération des images de la webcam est effectuée sur un formulaire à la façon d'un appareil photo par copier/coller sur un cadre image, puis lorsque la photo affichée correspond à notre besoin, un bouton permet de l'enregistrer et l'insérer sur la fiche concernée.

    Cette macro fonctionne correctement sous Windows XP avec Excel 2003. Egalement sous Windows 7 avec Excel 2010.

    Le problème actuel est que par la suite nous voudrions utiliser cette macro sur tablette Windows 8 avec Excel 2010.

    Des tests ayant été effectués sur pc avec Windows 8 et Excel 2010, il apparait que la capture d'image n'est plus fonctionnelle. Le cadre image reste vide, et lorsque on teste un enregistrement, aucun fichier n'est créé. Pourtant la webcam est bien activée.

    Y-a-t'il une incompatibilité entre Windows 8 et la librairie avicap32.dll sous VBA Excel 2010 ?

    En vous remerciant par avance de votre réponse.

    Cordialement
    jeudi 16 mai 2013 07:10

Réponses

  • En fait, ma suggestion d'adapter le code VB.Net à VBA, n'était pas pertinente. En effet ce projet utilise une librairie DirectShowLib-2005 qui n'est pas un composant COM, donc difficilement utilisable sous VBA.

    J'ai trouvé sur ce site, un projet VB6, qui utilise DirectShow, projet téléchargeable ICI.

    C'est tout de même plus simple pour adapter à VBA.

    Je dépose sur CJoint un classeur WebcamDS (.xls = format 2003, .xlsm = format 2010) qui utilise donc DirectShow, via \Windows\System32\Quartz.dll qui est le module d’exécution de DirectShow (il faut y ajouter une référence) . Il fonctionne sous Windows 7, Windows 8 et Windows XP (testé sous Windows XP Mode, je n'ai pas de matériel sous XP avec une Webcam).

    NB : Pour ceux qui essaierait le projet VB6, il nécessite un petite modification. Dans la définition des filtres, il faut remplacer "Capture" par "Capturer" :

    Private Const FILTERLIST As String = _
            "~Capturer|" _
          & "AVI Decompressor|" _
          & "Color Space Converter|" _
          & "Video Renderer"
    Private Const CONNECTIONLIST As String = _
            "Capturer~XForm In|" _
          & "XForm Out~Input|" _
          & "XForm Out~VMR Input0"
    Sinon aucune caméra valide n'est détectée.


    Cordialement, Jacques

    • Marqué comme réponse pmcj mercredi 22 mai 2013 06:27
    lundi 20 mai 2013 17:26
  • Pour les paramètres de la webcam et le réglage des couleurs, je ne suis pas sûr, mais je pense que c'est plutôt avec un utilitaire livré par le constructeur que ça devrait se faire. Comme pour une carte graphique, ou une imprimante.

    Pour le format d'enregistrement des images, bien que le code que tu as posté ajoute une extension .jpg, le format de l'image est en .bmp : SavePicture de VBA/VB6 ne connait que ce format.

    Mais il est possible d'obtenir ce format en utilisant une librairie tierce, par exemple Bmp2Jpg.dll (mais il en existe d'autres)

    Tu la copie dans \Windows\System32 (Système 32 bits) ou \Windows\SysWOW64 (Système 64 bits), et tu modifie le code de cmdSnap ainsi :

        hBitmap = LongDIB2HBitmap(DIB)
        If hBitmap <> 0 Then
            Set Pic = HBitmap2Picture(hBitmap, 0)
            If Not Pic Is Nothing Then
                Dim picName As String
                With picSnapshot
                    Set .Picture = Pic
                    picName = ThisWorkbook.Path & "\Image " & Format(Date, "YYYY-MM-DD") & " " & Format(Time, "HH-MM-SS")
                    SavePicture .Picture, picName & ".bmp"
                    If BmpToJpeg(picName & ".bmp", picName & ".jpg", 100) = 0 Then
                        MsgBox "Impossible d'enregistrer le fichier JPG." & vbCrLf & Err.Description, vbCritical
                    Else
                        MsgBox "Capure " & picName & ".jpg" & vbCrLf & "enregistrée.", vbInformation
                        Kill picName & ".bmp"
                    End If
                    DeleteObject hBitmap
                End With
            End If
        End If

    Le 3ème paramètre de la fonction Bmp2Jpeg correspond au niveau Qualité image / Compression



    Cordialement, Jacques



    • Modifié Jacques93 mardi 21 mai 2013 10:08
    • Marqué comme réponse pmcj mercredi 22 mai 2013 06:27
    mardi 21 mai 2013 10:05
  • Sur les réponses tu devrais avoir les choix :

    • Proposer comme réponse
    • Marquer comme réponse

    ce dernier choix n'est visible que par l'auteur de la question, ou un modérateur (Aurel Bera). Si tu considères qu'une réponse a résolu le problème ...

    En principe la petite bulle devrait passer de orange avec un ? à vert avec un coche.


    Cordialement, Jacques



    • Modifié Jacques93 mardi 21 mai 2013 14:20
    • Marqué comme réponse pmcj mercredi 22 mai 2013 06:26
    mardi 21 mai 2013 14:18

Toutes les réponses

  • Bonjour pmcj,

    Peut être voir ce fil :

      Webcam VB6

    où il fut question de remplacer l'utilisation de la dll avicap32.dll par DirectShow (c'est un projet VB.Net 2010, qui serait donc à adapter à VBA)


    Cordialement, Jacques

    jeudi 16 mai 2013 13:54
  • Bonjour Jacques93,

    merci de votre réponse et désolé de ce retour tardif mais j'ai été occupé toute la journée.

    Etant simple amateur, je ne connais pas assez les objets impliquant un matériel particulier tel qu'une webcam, leur dll, ...

    Le module capture d'image que j'utilise pour l'application vient d'un code récupéré sur internet que je n'ai pas eu à modifier excepté pour l'intégration au reste du projet :

    Le fonctionnement général passe par du copier/coller, mais la façon dont cela se passe est un peu trop complexe pour mes connaissances actuelles du sujet.

    Ci-dessous, code du module en VBA (désolé pour les couleurs, mais je n'ai pas trouvé VBA dans les languages proposés pour l'insertion de code)

    Formulaire : FormCapture

    Option Explicit
    
    Private Sub CommandButton2_Click()
    'boite de dialogue parametres de la WebCam
    SendMessage mCapHwnd, WM_CAP_DLG_VIDEOSOURCE, 0, 0
    End Sub
    
    Private Sub CommandButton3_Click()
    Dim iPic As StdPicture
    Set iPic = Me.Image1.Picture
    
    If iPic Is Nothing Then Exit Sub
    
    ' => Sauvegarde de la photo du matériel à référencer
    'UserForm1.TextBox5 = UserForm1.TextBox8 & " " & Format(Date, "YYYY-MM-DD") & " " & Format(Time, "HH-MM-SS") & ".jpg"
    'SavePicture iPic, strCheminImage & "\" & UserForm1.TextBox5
    'UserForm1.ImgPhoto.Picture = LoadPicture(strCheminImage & "\" & UserForm1.TextBox5)
    SavePicture iPic, ThisWorkbook.Path & "\Image " & Format(Date, "YYYY-MM-DD") & " " & Format(Time, "HH-MM-SS") & ".jpg"
    
    DestroyIcon iPic.Handle
    Set iPic = Nothing
    End Sub
    
    Private Sub CommandButton4_Click()
    
    If Cible = True Then
    Cible = False
    CommandButton4.Caption = "Arrêt Vidéo"
    Call Demarrer
    Else
    CommandButton4.Caption = "Départ Vidéo"
    Cible = True
    End If
    
    End Sub
    
    Private Sub UserForm_Activate()
    'recuperer le Handle de l'Usf : Daniel Klann, mpep
    If Val(Application.Version) < 9 Then 'Excel 2000
    strFormClassName = "ThunderXFrame"
    Else
    strFormClassName = "ThunderDFrame" 'Excel 2000/2002
    End If
    
    Valeur = FindWindow(strFormClassName, "FormCapture") 'le Handle de la fenetre
    
        'on definie la variable necessaire au bon fonctionnement de la capture video
    mCapHwnd = capCreateCaptureWindow("My Own Capture Window", 0, 0, 0, 320, 240, Valeur, 0)
        'on dit au prog que la camera est branchée
    SendMessage mCapHwnd, WM_CAP_DRIVER_CONNECT, 0, 0   ' WM_CAP_DRIVER_CONNECT & WM_CAP_DRIVER_DISCONNECT => 1er paramètre = n° driver webcam
    
    If SendMessage(mCapHwnd, WM_CAP_DRIVER_CONNECT, 0, 0) = 0 Then
        MsgBox ("La camera n'est pas connectée")
        retvale = SendMessage(mCapHwnd, WM_CAP_DRIVER_DISCONNECT, 0, 0)
        DestroyWindow (mCapHwnd)
        
        Unload Me
        Exit Sub
    End If
    
    Cible = False
    Demarrer
    End Sub
    
    Private Sub UserForm_Terminate()
    Dim oDataObject As DataObject
    
    'Etape Importante avant de quitter sinon ca peut bloquer !
    retvale = SendMessage(mCapHwnd, WM_CAP_DRIVER_DISCONNECT, 0, 0)
    DestroyWindow (mCapHwnd)
    
    Set oDataObject = New DataObject 'vider le presse papier
    oDataObject.SetText ""
    oDataObject.PutInClipboard
    
    Cible = True
    Finir
    
    Set oDataObject = Nothing
    
    Unload Me
    
    End Sub
    

    Module : ModPastePicture

    '***************************************************************************
    '*
    '* MODULE NAME:     Paste Picture
    '* AUTHOR & DATE:   STEPHEN BULLEN, Business Modelling Solutions Ltd.
    '*                  15 November 1998
    '*
    '* CONTACT:         Stephen@BMSLtd.co.uk
    '* WEB SITE:        http://www.BMSLtd.co.uk
    '*
    '* DESCRIPTION:     Creates a standard Picture object from whatever is on the clipboard.
    '*                  This object can then be assigned to (for example) and Image control
    '*                  on a userform.  The PastePicture function takes an optional argument of
    '*                  the picture type - xlBitmap or xlPicture.
    '*
    '*                  The code requires a reference to the "OLE Automation" type library
    '*
    '*                  The code in this module has been derived from a number of sources
    '*                  discovered on MSDN.
    '*
    '*                  To use it, just copy this module into your project, then you can use:
    '*                      Set Image1.Picture = PastePicture(xlPicture)
    '*                  to paste a picture of whatever is on the clipboard into a standard image control.
    '*
    '* PROCEDURES:
    '*   PastePicture   The entry point for the routine
    '*   CreatePicture  Private function to convert a bitmap or metafile handle to an OLE reference
    '*   fnOLEError     Get the error text for an OLE error code
    '***************************************************************************
    Option Explicit
    Option Compare Text
    
    ''' User-Defined Types for API Calls
    
    'Declare a UDT to store a GUID for the IPicture OLE Interface
    Private Type GUID
        Data1 As Long
        Data2 As Integer
        Data3 As Integer
        Data4(0 To 7) As Byte
    End Type
    
    'Declare a UDT to store the bitmap information
    Private Type uPicDesc
        Size As Long
        Type As Long
        hPic As Long
        hPal As Long
    End Type
    
    '''Windows API Function Declarations
    
    'Does the clipboard contain a bitmap/metafile?
    Private Declare Function IsClipboardFormatAvailable Lib "User32" (ByVal wFormat As Integer) As Long
    
    'Open the clipboard to read
    Private Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
    
    'Get a pointer to the bitmap/metafile
    Private Declare Function GetClipboardData Lib "User32" (ByVal wFormat As Integer) As Long
    
    'Close the clipboard
    Private Declare Function CloseClipboard Lib "User32" () As Long
    
    'Convert the handle into an OLE IPicture interface.
    Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    
    'Create our own copy of the metafile, so it doesn't get wiped out by subsequent clipboard updates.
    Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
    
    'Create our own copy of the bitmap, so it doesn't get wiped out by subsequent clipboard updates.
    Declare Function CopyImage Lib "User32" (ByVal Handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
    
    'The API format types we're interested in
    Const CF_BITMAP = 2
    Const CF_PALETTE = 9
    Const CF_ENHMETAFILE = 14
    Const IMAGE_BITMAP = 0
    Const LR_COPYRETURNORG = &H4
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''' Subroutine: PastePicture
    '''
    ''' Purpose:    Get a Picture object showing whatever's on the clipboard.
    '''
    ''' Arguments:  lXlPicType - The type of picture to create.  Can be one of:
    '''                          xlPicture to create a metafile (default)
    '''                          xlBitmap to create a bitmap
    '''
    ''' Date        Developer           Action
    ''' --------------------------------------------------------------------------
    ''' 30 Oct 98   Stephen Bullen      Created
    ''' 15 Nov 98   Stephen Bullen      Updated to create our own copies of the clipboard images
    '''
    
    Function PastePicture(Optional lXlPicType As Long) As IPicture
    
    'Some pointers
    Dim h As Long, hPicAvail As Long, hPtr As Long, hPal As Long, lPicType As Long, hCopy As Long
    
    'Convert the type of picture requested from the xl constant to the API constant
    lPicType = IIf(lXlPicType, CF_BITMAP, CF_ENHMETAFILE)
    
    'Check if the clipboard contains the required format
    hPicAvail = IsClipboardFormatAvailable(lPicType)
    
    If hPicAvail <> 0 Then
        'Get access to the clipboard
        h = OpenClipboard(0&)
    
        If h > 0 Then
            'Get a handle to the image data
            hPtr = GetClipboardData(lPicType)
    
            'Create our own copy of the image on the clipboard, in the appropriate format.
            If lPicType = CF_BITMAP Then
                hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
            Else
                hCopy = CopyEnhMetaFile(hPtr, vbNullString)
            End If
    
            'Release the clipboard to other programs
            h = CloseClipboard
    
            'If we got a handle to the image, convert it into a Picture object and return it
            If hPtr <> 0 Then Set PastePicture = CreatePicture(hCopy, 0, lPicType)
        End If
    End If
    
    End Function
    
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''' Subroutine: CreatePicture
    '''
    ''' Purpose:    Converts a image (and palette) handle into a Picture object.
    '''
    '''             Requires a reference to the "OLE Automation" type library
    '''
    ''' Arguments:  None
    '''
    ''' Date        Developer           Action
    ''' --------------------------------------------------------------------------
    ''' 30 Oct 98  Stephen Bullen      Created
    '''
    
    Private Function CreatePicture(ByVal hPic As Long, ByVal hPal As Long, ByVal lPicType) As IPicture
    
    ' IPicture requires a reference to "OLE Automation"
    Dim R As Long, uPicInfo As uPicDesc, IID_IDispatch As GUID, iPic As IPicture
    
    'OLE Picture types
    Const PICTYPE_BITMAP = 1
    Const PICTYPE_ENHMETAFILE = 4
    
    ' Create the Interface GUID (for the IPicture interface)
    With IID_IDispatch
        .Data1 = &H7BF80980
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With
    
    ' Fill uPicInfo with necessary parts.
    With uPicInfo
        .Size = Len(uPicInfo)                                                   ' Length of structure.
        .Type = IIf(lPicType = CF_BITMAP, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE)  ' Type of Picture
        .hPic = hPic                                                            ' Handle to image.
        .hPal = IIf(lPicType = CF_BITMAP, hPal, 0)                              ' Handle to palette (if bitmap).
    End With
    
    ' Create the Picture object.
    R = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, iPic)
    
    ' If an error occured, show the description
    If R <> 0 Then Debug.Print "Create Picture: " & fnOLEError(R)
    
    ' Return the new Picture object.
    Set CreatePicture = iPic
    
    End Function
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''' Subroutine: fnOLEError
    '''
    ''' Purpose:    Gets the message text for standard OLE errors
    '''
    ''' Arguments:  None
    '''
    ''' Date        Developer           Action
    ''' --------------------------------------------------------------------------
    ''' 30 Oct 98   Stephen Bullen      Created
    '''
    
    Private Function fnOLEError(lErrNum As Long) As String
    
    'OLECreatePictureIndirect return values
    Const E_ABORT = &H80004004
    Const E_ACCESSDENIED = &H80070005
    Const E_FAIL = &H80004005
    Const E_HANDLE = &H80070006
    Const E_INVALIDARG = &H80070057
    Const E_NOINTERFACE = &H80004002
    Const E_NOTIMPL = &H80004001
    Const E_OUTOFMEMORY = &H8007000E
    Const E_POINTER = &H80004003
    Const E_UNEXPECTED = &H8000FFFF
    Const S_OK = &H0
    
    Select Case lErrNum
    Case E_ABORT
        fnOLEError = " Aborted"
    Case E_ACCESSDENIED
        fnOLEError = " Access Denied"
    Case E_FAIL
        fnOLEError = " General Failure"
    Case E_HANDLE
        fnOLEError = " Bad/Missing Handle"
    Case E_INVALIDARG
        fnOLEError = " Invalid Argument"
    Case E_NOINTERFACE
        fnOLEError = " No Interface"
    Case E_NOTIMPL
        fnOLEError = " Not Implemented"
    Case E_OUTOFMEMORY
        fnOLEError = " Out of Memory"
    Case E_POINTER
        fnOLEError = " Invalid Pointer"
    Case E_UNEXPECTED
        fnOLEError = " Unknown Error"
    Case S_OK
        fnOLEError = " Success!"
    End Select
    
    End Function
    

    2nd Module

    Option Explicit
    
    '***************************************************
    '
    'source http://www.vbfrance.com/code.aspx?ID=30202
    'TheHacker & Sylvain298
    '
    '***************************************************
    'adapté par michelxld le 26.03.2005
    'pour le forum http://www.excel-downloads.com
    
    Public mCapHwnd As Long
    Public retvale As Long
    Public CapParms As TCAPTUREPARMS
    Public Bitmap As Variant 'on declare une variable qui sera le chemin d'acces pour les photos
    Public Valeur As Long
    Public strFormClassName As String
    Public Cible As Boolean
    
    Public Type TCAPTUREPARMS
     dwRequestMicroSecPerFrame As Long
     fLimitEnabled  As Boolean
     fCaptureAudio  As Boolean
     fMCIControl  As Boolean
     fYield  As Boolean
     vKeyAbort As Byte
     fAbortLeftMouse  As Boolean
     fAbortRightMouse As Boolean
    End Type
    
    Public Type tagInitCommonControlsEx 'pour l'effet windows XP
       lngSize As Long
       lngICC As Long
    End Type
    
    Public Declare Function FindWindow Lib "User32" Alias "FindWindowA" _
        (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    
    Public Declare Function DestroyIcon& Lib "User32" (ByVal hIcon&)
    
    Public Declare Function InitCommonControlsEx Lib "comctl32.dll" (iccex As tagInitCommonControlsEx) As Boolean
    Public Const ICC_USEREX_CLASSES = &H200
    
    'la constante de depart est 1024
    'video capture calls
    Public Const WM_CAP_DRIVER_CONNECT As Long = 1034          'pour savoir si la webcam est connecté
    Public Const WM_CAP_GRAB_FRAME As Long = 1084              'pour pouvoir previsualiser la webcam
    Public Const WM_CAP_EDIT_COPY As Long = 1054               'pour copier l'image de la webcam, mais ici ca ne marche pas car on affiche un prwiev de la webcam grace a un copier coller (si vous trouvez autre chose pour le preview ca marche super)
    Public Const WM_CAP_DRIVER_DISCONNECT = 1035               'pour savoir si la webcam est pas connectée
    Public Const WM_CAP_SEQUENCE = 1086                        'pour la capture AVI
    Public Const WM_CAP_GET_SEQUENCE_SETUP = 1089              'sais pas
    Public Const WM_CAP_SET_SEQUENCE_SETUP = 1088              'sais pas
    Public Const WM_CAP_FILE_SET_CAPTURE_FILE = 1044           'pour changer le chemin de destination du fichier AVI
    Public Const WM_CAP_DLG_VIDEOSOURCE = 1066                 'pour afficher les parametre
    Public Const WM_CAP_FILE_SAVEAS = 1047                     'pour enregistrer dans un fichier specifier
    Public Const WM_CAP_STOP = 1092                            'pour arreter la capture
    
    Public Declare Function DestroyWindow Lib "User32" (ByVal hwnd As Long) As Long
    Public Declare Function capCreateCaptureWindow Lib "avicap32.dll" Alias "capCreateCaptureWindowA" (ByVal lpszWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hwndParent As Long, ByVal nID As Long) As Long
    Public Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Public Declare Function Sauvegarde Lib "User32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As String) As Long
    
    Sub Demarrer()
    Application.OnTime Now + TimeValue("00:00:01") / 2.3, "Visionneuse"
    End Sub
    
    Sub Visionneuse()
    
    On Error Resume Next
    
    If Cible = True Then Exit Sub
    
    SendMessage mCapHwnd, WM_CAP_GRAB_FRAME, 0, 0 'on rafraichit l'image "webcam"
    SendMessage mCapHwnd, WM_CAP_EDIT_COPY, 0, 0
    DoEvents
    '*****************************************************************************
    '
    'attention module ModPastePicture adapté pour transformer les images d'une WebCam
    'par michelxld le 26.03.2005
    'pour le forum http://www.excel-downloads.com
    '
    '*****************************************************************************
    Set FormCapture.Image1.Picture = PastePicture(WM_CAP_EDIT_COPY)
    
    Demarrer
    End Sub
    
    Sub Finir()
    On Error Resume Next
    Application.OnTime EarliestTime:=Now + TimeValue("00:00:01"), Procedure:="Visionneuse", Schedule:=False
    End Sub
    


    Y-as-t'il moyen de modifier ce code afin qu'il fonctionne sous Windows 8 ?

    Ou pourrais-je trouvé des éléments concernant la différence entre les languages VBA et VB.Net afin d'essayer d'adapter le code transmis.

    En vous remerciant par avance de votre réponse.

    Cordialement

    vendredi 17 mai 2013 08:44
  • Bonjour

    Vous avez On Error Resume Next
    C'est presque sûr que vous cachez une erreur.

    Enlevez cette ligne pour afficher les erreurs et comme ça on aura plus de détails.

    Cordialement,


    Aurel BERA, Microsoft
    Microsoft propose ce service gratuitement, dans le but d'aider les utilisateurs et d'élargir les connaissances générales liées aux produits et technologies Microsoft. Ce contenu est fourni "tel quel" et il n'implique aucune responsabilité de la part de Microsoft.

    vendredi 17 mai 2013 10:07
  • Bonjour Aurel Bera,

    en retirant les lignes "On Error Resume Next" des procédures "Visionneuse" & "Finir", une erreur 1004 apparait à la fermeture du formulaire de capture d'image sur la ligne :

    Application.OnTime EarliestTime:=Now + TimeValue("00:00:01"), Procedure:="Visionneuse", Schedule:=False

    présente dans la procédure "Finir".

    Durant l'étape capture d'image, rien ne se passe excepté que le cadre image du formulaire devant récupérer l'image reste blanc.

    Cordialement

    vendredi 17 mai 2013 11:21
  • Je viens de faire l'essai avec le code que tu as indiqué. J'obtiens un comportement "étrange", identique sous Windows 7 et Windows 8 :

    Lorsque le classeur est enregistré au format "Classeur Excel 97 - 2003 (.xls)", j'ai le message "La camera n'est pas connectée", se trouvant dans UserForm_Activate

    Si j'enregistre le classeur au format "Classeur Excel (prenant en charge les macros) (*.xlsm), cela fonctionne, avec une fenêtre de sélection de la Webcam, comme évoqué dans le fil VB6. Mais la Webcam, ainsi que la capture, fonctionnent.

    Quel format de classeur utilises tu ?

    NB: je n'ai aucune idée du pourquoi ...

    Sous Windows 8 j'ai une dll avicap32.dll version 6.2.9200.16384 du 26/07/2012


    Cordialement, Jacques

    samedi 18 mai 2013 07:57
  • En fait, ma suggestion d'adapter le code VB.Net à VBA, n'était pas pertinente. En effet ce projet utilise une librairie DirectShowLib-2005 qui n'est pas un composant COM, donc difficilement utilisable sous VBA.

    J'ai trouvé sur ce site, un projet VB6, qui utilise DirectShow, projet téléchargeable ICI.

    C'est tout de même plus simple pour adapter à VBA.

    Je dépose sur CJoint un classeur WebcamDS (.xls = format 2003, .xlsm = format 2010) qui utilise donc DirectShow, via \Windows\System32\Quartz.dll qui est le module d’exécution de DirectShow (il faut y ajouter une référence) . Il fonctionne sous Windows 7, Windows 8 et Windows XP (testé sous Windows XP Mode, je n'ai pas de matériel sous XP avec une Webcam).

    NB : Pour ceux qui essaierait le projet VB6, il nécessite un petite modification. Dans la définition des filtres, il faut remplacer "Capture" par "Capturer" :

    Private Const FILTERLIST As String = _
            "~Capturer|" _
          & "AVI Decompressor|" _
          & "Color Space Converter|" _
          & "Video Renderer"
    Private Const CONNECTIONLIST As String = _
            "Capturer~XForm In|" _
          & "XForm Out~Input|" _
          & "XForm Out~VMR Input0"
    Sinon aucune caméra valide n'est détectée.


    Cordialement, Jacques

    • Marqué comme réponse pmcj mercredi 22 mai 2013 06:27
    lundi 20 mai 2013 17:26
  • Bonjour Jacques93,

    je reviens après ce weekend pluvieux et vous remercie de votre retour.

    Je vais essayer d'adapter ce module à notre application en lieu et place du précédent.

    Y-a-t'il moyen d'accéder aux paramètres de la webcam ? Le rendu de cette dernière est tourné vers le vert.

    Y-a-t'il moyen d'enregistrer l'image directement en jpg plutôt que bmp ?

    En vous remerciant de l'aide que vous m'apportez,

    Cordialement,

    pmcj

    mardi 21 mai 2013 08:05
  • Pour les paramètres de la webcam et le réglage des couleurs, je ne suis pas sûr, mais je pense que c'est plutôt avec un utilitaire livré par le constructeur que ça devrait se faire. Comme pour une carte graphique, ou une imprimante.

    Pour le format d'enregistrement des images, bien que le code que tu as posté ajoute une extension .jpg, le format de l'image est en .bmp : SavePicture de VBA/VB6 ne connait que ce format.

    Mais il est possible d'obtenir ce format en utilisant une librairie tierce, par exemple Bmp2Jpg.dll (mais il en existe d'autres)

    Tu la copie dans \Windows\System32 (Système 32 bits) ou \Windows\SysWOW64 (Système 64 bits), et tu modifie le code de cmdSnap ainsi :

        hBitmap = LongDIB2HBitmap(DIB)
        If hBitmap <> 0 Then
            Set Pic = HBitmap2Picture(hBitmap, 0)
            If Not Pic Is Nothing Then
                Dim picName As String
                With picSnapshot
                    Set .Picture = Pic
                    picName = ThisWorkbook.Path & "\Image " & Format(Date, "YYYY-MM-DD") & " " & Format(Time, "HH-MM-SS")
                    SavePicture .Picture, picName & ".bmp"
                    If BmpToJpeg(picName & ".bmp", picName & ".jpg", 100) = 0 Then
                        MsgBox "Impossible d'enregistrer le fichier JPG." & vbCrLf & Err.Description, vbCritical
                    Else
                        MsgBox "Capure " & picName & ".jpg" & vbCrLf & "enregistrée.", vbInformation
                        Kill picName & ".bmp"
                    End If
                    DeleteObject hBitmap
                End With
            End If
        End If

    Le 3ème paramètre de la fonction Bmp2Jpeg correspond au niveau Qualité image / Compression



    Cordialement, Jacques



    • Modifié Jacques93 mardi 21 mai 2013 10:08
    • Marqué comme réponse pmcj mercredi 22 mai 2013 06:27
    mardi 21 mai 2013 10:05
  • Bonjour Jacques,

    Merci pour ces informations complémentaires.

    J'adapte les éléments que tu m'as transmis à notre application métier.

    Que doit on faire quand le problème posé peut être considéré comme résolu ?

    Cordialement,

    pmcj

    mardi 21 mai 2013 12:08
  • Sur les réponses tu devrais avoir les choix :

    • Proposer comme réponse
    • Marquer comme réponse

    ce dernier choix n'est visible que par l'auteur de la question, ou un modérateur (Aurel Bera). Si tu considères qu'une réponse a résolu le problème ...

    En principe la petite bulle devrait passer de orange avec un ? à vert avec un coche.


    Cordialement, Jacques



    • Modifié Jacques93 mardi 21 mai 2013 14:20
    • Marqué comme réponse pmcj mercredi 22 mai 2013 06:26
    mardi 21 mai 2013 14:18
  • Bonjour,

    j'espère  que vous allez bien, je me permet de revenir vers vous tout en ne sachant si il n'est pas préférable d'ouvrir une nouvelle discussion en liaison avec celle-ci.

    Après adaptation du code reprenant DirectShow sur notre application métier, celle fonctionne très bien sur un appareil type PC portable convertible tel que "Dell Inspiron Duo" : une seule caméra, en façade reconnue comme "Integrated Webcam" : en utilisation dans les locaux techniques ou nous sommes susceptibles de nous rendre, cela oblige à garder l'ordinateur ouvert pour pouvoir faire une photo de tel ou tel équipement.

    D'où préférence pour l'utilisation d'une tablette. En notre possession nous avons 2 tablettes Samsung 500T Notebook modèle XE500T1C : caméra en façade et frontale. Lors du lancement du module, on peut trouver les deux éléments suivant : OV2720, OV8830 qui je pense correspondent aux deux objectifs. Ceux-ci ne sont néanmoins pas reconnus comme une caméra valide.

    Avez vous une idée sur le problème rencontré ? Est-ce due à ce double objectif ? Si oui, est il possible d'adapter un module d'acquisition d'image sur une tablette tactile avec deux objectifs.

    Pour information :

    * système d'exploitation de la tablette : Windows 8 Professionnel

    * Microsoft Office 2010 Professionnel

    En espérant que vous ayez une solution et vous remerciant par avance

    Cordialement,

    pmcj

    lundi 10 juin 2013 06:53
  • Bonjour à tous,

    Je reviens sur le dernier post de pmcj

    Avez vous trouvé la solution pour faire fonctionner la macro avec la caméra de la tablette ?

    Je suis exactement dans le même cas que vous, lorsque je lance la macro sur ma tablette ASUS ME400C 1B006P, je ne trouve pas de caméra valide dans la liste proposée.

    Bonne journée

    JDN

    mercredi 16 octobre 2013 15:33