צילום תמונה לאקסס

[OdedDvir]

@ארי תבדוק בהגדרות הפרטיות של המצלמה ב-Windows. כנראה חסמת גישה של אפליקציות למצלמה.

[ארי]

@OdedDvir כל ההגדרות מופעלות.

[איש ימיני]

@ארי
נראה שזה בעיה אצלך.
גם הקובץ דוגמה שלך עובד אצלי.
זה מדליק את המצלמה ומראה את זה באקסס.

[ארי]

@איש-ימיני איזה אופיס יש לך? וכמה סיביות?
אולי זה קשור

[איש ימיני]

@ארי אופיס 2019 64 סיביות.

[ארי]

@איש-ימיני לי יש 2021 32 סיביות.
אולי זה קשור לסיביות?
אבל לכאורה אם כן הוא היה אמור לעשות באג איפשהו, לא?

[איש ימיני]

@ארי
יש שינויים בין 64 ל 32.
נסה עם קובץ זה:-צילום-תמונה-לאקסס.accdb
אמור לעבוד גם על 64 וגם על 32
אני מקווה שאין עוד שינויים שצריך לעשות
זה מה שעשיתי:

#If Win64 And VBA7 Then

Private Declare PtrSafe 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 LongPtr _
        , ByVal nID As Long) As Long

Private Declare PtrSafe Function SendMessage Lib "user32" _
    Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long _
        , ByVal wParam As Long, ByRef lParam As Any) As Long
        
Dim hCap As LongPtr

#Else

Private 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

Private Declare Function SendMessage Lib "user32" _
    Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long _
        , ByVal wParam As Long, ByRef lParam As Any) As Long
        
Dim hCap As Long

#End If

[ארי]

@איש-ימיני לא עובד
ככה זה נראה:

בדקתי גם על מחשב עם אופיס 2016 32 סיביות ואותה תוצאה.

אתה משתמש במצלמת רשת או במצלמה המובנית של המחשב?
אני מנסה לחפש הבדלים....
תודה.

[איש ימיני]

@ארי
אני משתמש במצלמה מובנית.
תנסה לשנות את הקוד של @OdedDvir
להלן השינויים בחלק הראשון של הקוד:

'UX_WebCam : A WebCam API Class. By OdedDvir

Option Compare Database
Option Explicit

Const WS_CHILD As Long = &H40000000
Const WS_VISIBLE As Long = &H10000000

Const WM_USER As Long = &H400
Const WM_CAP_START As Long = WM_USER

Const WM_CAP_DRIVER_CONNECT As Long = WM_CAP_START + 10
Const WM_CAP_DRIVER_DISCONNECT As Long = WM_CAP_START + 11
Const WM_CAP_EDIT_COPY As Long = WM_CAP_START + 30
Const WM_CAP_SET_PREVIEW As Long = WM_CAP_START + 50
Const WM_CAP_SET_PREVIEWRATE As Long = WM_CAP_START + 52
Const WM_CAP_DLG_VIDEOFORMAT As Long = WM_CAP_START + 41
Const WM_CAP_FILE_SAVEDIB As Long = WM_CAP_START + 25
Const WM_CAP_GRAB_FRAME As Long = WM_CAP_START + 60

Private Declare Function apiCapCreateCaptureWindow 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

Private Declare Function apiSendMessage Lib "user32" Alias "SendMessageA" _
                                (ByVal hWnd As Long, ByVal wMsg As Long, _
                                 ByVal wParam As Long, ByRef lParam As Any) As Long

Private Declare Function apiGetFocus Lib "user32" Alias "GetFocus" () As Long

Private hCap As Long

Public Sub OpenWebCam(targethWnd As Long, Optional width = 640, Optional height = 480)
    hCap = apiCapCreateCaptureWindow("Capture Window", WS_CHILD Or WS_VISIBLE, 0, 0, width, height, targethWnd, 0)
    If hCap = 0 Then Exit Sub
    apiSendMessage hCap, WM_CAP_DRIVER_CONNECT, 0, 0
    apiSendMessage hCap, WM_CAP_SET_PREVIEWRATE, 66, 0&
    apiSendMessage hCap, WM_CAP_SET_PREVIEW, CLng(True), 0&
End Sub

Public Sub TakeSnapshotToFile(fileName As String)
    apiSendMessage hCap, WM_CAP_GRAB_FRAME, 0, 0
    apiSendMessage hCap, WM_CAP_SET_PREVIEW, CLng(False), 0&
    apiSendMessage hCap, WM_CAP_FILE_SAVEDIB, 0&, ByVal CStr(fileName)
    apiSendMessage hCap, WM_CAP_SET_PREVIEW, CLng(True), 0&
End Sub

Public Sub OpenVideoFormatDialog()
    apiSendMessage hCap, WM_CAP_DLG_VIDEOFORMAT, 0&, 0&
End Sub

Public Sub CaptureToClipboard()
    apiSendMessage hCap, WM_CAP_GRAB_FRAME, 0, 0
    apiSendMessage hCap, WM_CAP_SET_PREVIEW, CLng(False), 0&
    apiSendMessage hCap, WM_CAP_EDIT_COPY, 0, 0
    apiSendMessage hCap, WM_CAP_SET_PREVIEW, CLng(True), 0&
End Sub

Public Sub CloseWebCam()
    apiSendMessage hCap, WM_CAP_DRIVER_DISCONNECT, 0&, 0&
End Sub

אני מקווה שזה כל השינויים.
אם עדיין לא עובד נצטרך להמתין ל @OdedDvir עצמו.

[OdedDvir]

@איש-ימיני החל מאקסס 2013 אין צורך לשנות את הקוד כדי להתאים אחורה ל-32 ביט. הקוד של 64 ביט עובר ללא שגיאות.
@ארי תבדוק אם הדריבר בכלל מופעל.
בקוד שצירפתי, תשנה את השורה

apiSendMessage hCap, WM_CAP_DRIVER_CONNECT, 0, 0

לשורה הבאה:

Debug.Print CBool(apiSendMessage(hCap, WM_CAP_DRIVER_CONNECT, 0, 0))

ותראה מה מודפס בקונסול (Immediate window). צריך להיות True.

[ארי]

@OdedDvir אמר בצילום תמונה לאקסס:

צריך להיות True

הוא אכן מדפיס True.

[ארי]

@OdedDvir אמר בצילום תמונה לאקסס:

תבדוק אם הדריבר בכלל מופעל

זה?