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 |
Partager