Bonjour a tous

je me suis fait un petit userform preview de la camera je n'utilise plus le system de recuperation du bitmap avec createpicture et olecreateimgindirect de stephen bullen
je laisse le rafraichissement de la video se faire tout seul avec les constante de advicap.dll ce qui allege le moulin dans vba considerablement pour ne pas dire a zero en terme de memoire et UC puisque ca ne se fair plus par vba

j'ai cependant un petit soucis l'ors de la premiere ouverture du userform je voudrais me connecter a la camera sans passer par la boite de dialog avec l'appi sendmessage

ca se passe dans la ligne 66

si quelqu'un a une idée je suis preneur

voici mon code complet du userform

Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
'***************************************************************************************
'                      WebCam Preview and Button for  capture in Userform              *
'Version : 4.0                                                                         *
'Date version : 29/07/2018                                                             *
'Autor: patricktoulon alias chamalin2@hotmail.fr sur excel-download et developpez.com  *
'***************************************************************************************
Option Explicit
Private Const WM_CAP As Long = &H400                               'valeur base =1024 --> hex=&H400
Private Const WM_CAP_DRIVER_CONNECT As Long = 1034    'WM_CAP + 10    'connection a la camera
Private Const WM_CAP_DRIVER_DISCONNECT As Long = 1035    'WM_CAP + 11 'deconnection de la camera
Private Const WM_CAP_EDIT_COPY As Long = 1064    'WM_CAP + 30         'pour copier un cliché dans le clipboard
Private Const WM_CAP_SET_PREVIEW As Long = 1074    'WM_CAP + 50       'enclancher le previws dans la fentre
Private Const WM_CAP_SET_PREVIEWRATE = 1076    'WM_CAP + 52           'nombre d'imagepar seconde (bitrate)
Private Const WM_CAP_GRAB_FRAME_NOSTOP = 1085    'WM_CAP + 61         'rafraichissement dans la fentre de capture constant
Private Const WM_CAP_FILE_SAVEDIB = 1049                           'pour enregistrer une capture  en image su DD
Private Const WM_CAP_DLG_VIDEOSOURCE = 1066                        'pour afficher la boite de dialogue des parametres
Private Const WM_CLOSE = &H10                                      'fermer les drivers capture
Private Const WM_QUIT = &H12                                       'quitter la capture
'CONSTANTE POUR MODELISER L'AFFICHAGE DE LA FENETRE
Private Const WS_VISIBLE As Long = &H10000000
Private Const WS_NOCAPTION As Long = &H94080080
Private Const WS_FULLCAPTION As Long = &H94CF0080
Dim Hcamera As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function capCreateCaptureWindowA Lib "avicap32.dll" (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
Private Declare Function capGetDriverDescriptionA Lib "avicap32.dll" (ByVal wDriver As Long, ByVal lpszName As String, ByVal cbName As Long, ByVal lpszVer As String, ByVal cbVer As Long) As Boolean
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetParent Lib "User32.dll" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private Declare Function SWLG Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SWPOS Lib "user32" Alias "SetWindowPos" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Dim handle_Form&
Dim PtoPX As Double    'converti point to pixel
Private Sub CommandButton2_Click()
    SendMessage Hcamera, WM_CAP_DLG_VIDEOSOURCE, 0, 0    'boite de dialogue parametres de la WebCam
End Sub
Private Sub SnapShot_Click()
    Dim chemin$
    chemin = Environ("userprofile") & "\Desktop\" & IIf(nom_image <> "", nom_image, "Capture") & ".jpg"
    SendMessage Hcamera, WM_CAP_FILE_SAVEDIB, 0&, ByVal CStr(chemin)    'on prend une photo vers un fichier sur le bureau
End Sub
 
Private Sub UserForm_Activate()
    With SnapShot
        .Picture = CommandBars("Stars & Banners").FindControl(ID:=1183).Picture    'on ajoute un petit icon au bouton qui va bien
        .PicturePosition = 3
    End With
    WebCamClip    ' on demarre le bourrin
End Sub
 
Sub WebCamClip()
    PtoPX = CreateObject("WScript.Shell").RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72
    Me.Height = ((Me.Width / 4) * 3) + (70 / PtoPX)
    If Hcamera = 0 Then
        Hcamera = capCreateCaptureWindowA("Live_Preview", WS_NOCAPTION, 0, 0, 400, 300, handle_Form, 0)    'creation de la fentre de preview
        handle_Form = FindWindow(vbNullString, Me.Caption)    'capture du handle de l'userform
        If Hcamera <> 0 Then    'si il est capté
            'SWLG Hcamera, -16, &H94080080: SWLG Hcamera, -20, &H0:    ' on enleve la caption de la fenetre hcamera
            'DrawMenuBar Hcamera ' on redessine le decalage due a la suppression de la caption
            SetParent Hcamera, handle_Form    'on ' affilie le preview a son nouveau parent (le userform)
            SWPOS Hcamera, 0, 6, 60, (Me.Width * PtoPX) - 20, (((Me.Width * PtoPX) - 40) / 4) * 3, 0    'on positionne le preview correctement dans le userform
            Me.Repaint    'on repaint pour le laps de temps ou il est tout blanc pendant la charge du preview
        End If
        SendMessage Hcamera, WM_CAP_DRIVER_CONNECT, 0, 0    'on se connecte a la camera
        SendMessage Hcamera, WM_CAP_SET_PREVIEWRATE, 32, 0    ' on regle le rate (image par secondes)
        SendMessage Hcamera, WM_CAP_SET_PREVIEW, 1, 0    ' on met le preview a true
        SendMessage Hcamera, WM_CAP_GRAB_FRAME_NOSTOP, 0, 0    '  on roule le preview (non stop)
    End If
End Sub
 
'Obligatoire pour fermer la cam
Sub Fermer()
    If Hcamera <> 0 Then
        SendMessage Hcamera, WM_CAP_DRIVER_DISCONNECT, 0, 0    ' on se deconnect de la web cam
        SendMessage Hcamera, WM_CLOSE, 0, 0    ' on ferme la fenetre preview
        SendMessage Hcamera, WM_QUIT, 0, 0    ' on quitte le thread preview
        Hcamera = 0
    End If
End Sub
'on appelle la sub fermer quand on ferme le userform
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer): Fermer: End Sub
merci pour les retours