XL 2016 Affichage dynamique webcam

ahart68

XLDnaute Nouveau
Bonjour à tous et toutes,

Je voudrais avoir en temps réel dans un userform, le retour image de la webcam.
Puis prendre une photo et l'enregistrer.
J'ai réussi à prendre une photo instantanée via le programme CommandCam, mais sans affichage dynamique.
Une idée ?
Merci d'avance.
 

patricktoulon

XLDnaute Barbatruc
heu c'est quoi userformIP???
cette variable est instanciée nulle part???????
sans parler des variable non déclarées dans le click snapshot???????
ou est la fonction de création "RépertoireExisteCreation"
etc... etc...
quand j'ai dis anonymisé j'ai pas dit la moitié :rolleyes:
bref toujours est il que quand je le lance j'ai bien la cam

c'est assez pénible
on vous donne un truc sain et vous en faite une purée de quoic quoic

bref fait des efforts avec les fichiers que tu livre avec tout les fonctions(présentes) et variables déclarées dans le code sinon on ira pas loin
sincèrement tu en fait un ramdam pour concaténer un nom pour l'enregistrement

dis moi c'est sérieux çà
VB:
Private Sub SnapShot_Click()
jour = Day(Date)
mois_lettre = WorksheetFunction.Text(Date, "[$-409]mmm")
mois = Month(Date)
annee = Right(Year(Date), 2)
heure = TimeValue(Now)
datejour = jour & mois_lettre & annee
heure_mod = Replace(heure, ":", "")
If userformIP = 1 Then
   tag = Identification_form.TextBox_Tag.Value
Else
    tag = ActiveSheet.Name
End If

folder = "Audit_" & datejour
Call RépertoireExisteCreation(Environ("userprofile") & "\Desktop" & "\" & folder)
Chemin_save = Environ("userprofile") & "\Desktop\" & folder & "\" & tag & "_" & heure_mod & ".jpg"
SendMessage Hcamera, WM_CAP_FILE_SAVEDIB, 0&, ByVal CStr(Chemin_save)    'prend une photo

End Sub
à la fin je sais même plus quelle heure il est moi :p:p:p;)
 

ahart68

XLDnaute Nouveau
Dsl de ne pas être un maître VBA comme certainement vous tous sur ce forum :-(
...méa culpa....le fichier envoyé n'est pas complet...mais finalement peu importe... => Ton fichier de base fonctionnait, mais du jour au lendemain plus avec les erreurs reportées dans mes derniers msgs !!
Pourquoi aujourd'hui je ne serais plus en mesure de l’exécuter ?
Telle est la question....
Et vu que tu m'avais fourni ce fichier je pensais que cette erreur t'était compréhensible...
 

ahart68

XLDnaute Nouveau
J'ai essayé une multitudes de chose, comme réparer Office, vérifier présence de certains fichiers DLL, visiter des forums etc...sans succès...
Un paramétrage ou des fichiers système ont été corrompus ?
 

Pièces jointes

  • new version live cam 2018 Patricktoulon v auto (2).xls
    80.5 KB · Affichages: 16

patricktoulon

XLDnaute Barbatruc
bien sur que je sais pourquoi
avant toi ça fonctionne
après toi ça ne fonctionne plus
tu a changé quoi
tu a ajouté quoi
tu a modifié quoi

c'est la qu'il faut que tu cherche
en tout cas chez moi ça fonctionne très bien sur w7 et 10 office 2007 et 2013 et 2016
sauf bien sur le click snapshot qui est une vrai poubelle maintenant
 

ahart68

XLDnaute Nouveau
@patricktoulon
Pour info, le bug veanit du fait qu'un logiciel de sécurité installé sur tous les postes de l'entreprise ( CylanceProtect ), bloquait le script car jugé dangereux.
J'ai résolu le problème (qui ne venait donc pas de la poubelle que j'ai créée ;))

J'en profite...j'abuse je sais...
D'autres PC devront utiliser ce fichier mais sont en 64bits.
La caméra démarre mais affiche un écran noir, sans plantage du code néanmoins.
Peux-tu m'aider pour adapter les api du code de base que tu m'avais envoyé en 64 bits ?
Merci d'avance.
 

patricktoulon

XLDnaute Barbatruc
re
je viens de verifier tu ne les avais pas
l’entête de module
VB:
'***************************************************************************************
'                      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

#If VBA7 Then
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&
#Else
Dim Hcamera As LongPtr
Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare PtrSafe 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 PtrSafe 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 PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function SetParent Lib "User32.dll" (ByVal hWndChild As LongPtr, ByVal hWndNewParent As LongPtr) As Long
Private Declare PtrSafe Function SWLG Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function SWPOS Lib "user32" Alias "SetWindowPos" (ByVal hwnd As LongPtr, 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 As LongPtr
#End If
Dim PtoPX As Double    'converti point to pixel
Dim ok
Public cheminVBS As String
 

Discussions similaires

Réponses
13
Affichages
474
Réponses
34
Affichages
858
Réponses
11
Affichages
444

Membres actuellement en ligne

Statistiques des forums

Discussions
311 725
Messages
2 081 943
Membres
101 849
dernier inscrit
florentMIG