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

[ארי]

צהריים טובים.
האם יש קוד VBA לצילום תמונה דרך המצלמה של המחשב (הנייד) ושמירה שלה במחשב?
בחיפוש בגוגל מצאתי כל מיני קודים שלא עובדים, או שצריך להתקין תוסף (כמו AccessImagine.ocx) ואני מעדיף משהו בלי זה.
תודה רבה!

[ארי]

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

צהריים טובים.
האם יש קוד VBA לצילום תמונה דרך המצלמה של המחשב (הנייד) ושמירה שלה במחשב?
בחיפוש בגוגל מצאתי כל מיני קודים שלא עובדים, או שצריך להתקין תוסף (כמו AccessImagine.ocx) ואני מעדיף משהו בלי זה.
תודה רבה!

מה, אף אחד לא עשה משהו כזה אף פעם?
תודה!

[dovid]

@ארי אתה העידות בנו לא להזכיר שם אחר מאשר אקסס,
אז פינו מלא מים.

[ארי]

@dovid עד כדי כך?
מצטער, לא התכוונתי
חייבים תוספים בשביל זה?
תודה בכל אופן!!!

[ארי]

מצאתי כאן קוד לצילום תמונה, אבל הוא מציג לי רק מסך שחור ולא מצלם כלום.
מצורף קובץ דוגמא לפי מה שמסובר שם, אשמח אם מישהו יוכל לבדוק לי מה הבעיה.
תודה!

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

[OdedDvir]

@ארי למעשה זה אפשרי באקסס, על ידי קריאות ל-API של Windows. אכן הקודים המפוזרים ברחבי העולם סובלים מהזנחה.

הנה מחלקה שיצרתי לטיפול במצלמת רשת. צור Class Module ותדביק את הקוד הבא:

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

Private Declare PtrSafe Function apiSendMessage Lib "user32" Alias "SendMessageA" _
                                (ByVal hWnd As LongPtr, 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 LongPtr

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

דוגמא ליישום:

א. צור טופס עם 6 לחצנים בשמות התואמים למופיע בקוד הבא, דהיינו:
cmdCloseWebCam, cmdOpenSettings cmdOpenWebCam וכו', ועם פקד תמונה אחד בשם SavedPicture.
ב. במודול של הטופס תדביק את הקוד הבא:

Option Compare Database
Option Explicit

Private WebCam As New UX_WebCam
Private snapshotCount As Integer

Private Function GenerateFileName() As String
    GenerateFileName = "d:\Temp\Picture" & snapshotCount & ".bmp"
End Function

Private Sub cmdOpenWebCam_Click()
    snapshotCount = 0
    WebCam.OpenWebCam Me.hWnd, 640, 480
End Sub

Private Sub cmdOpenSettings_Click()
    WebCam.OpenVideoFormatDialog
End Sub

Private Sub cmdCloseWebCam_Click()
    WebCam.CloseWebCam
End Sub

Private Sub cmdCopySnapshot_Click()
    WebCam.CaptureToClipboard
    MsgBox "An image was copied to the clipboard!"
End Sub

Private Sub cmdLoadPictureToControl_Click()
    Me.SavedPicture.Picture = GenerateFileName
End Sub

Private Sub cmdSaveSnapshotToFile_Click()
    snapshotCount = snapshotCount + 1
    
    Dim fileName As String
    fileName = GenerateFileName
    
    WebCam.TakeSnapshotToFile fileName
    MsgBox "File " & fileName & " was created!"
End Sub

Private Sub Form_Close()
    WebCam.CloseWebCam
End Sub

[ארי]

@OdedDvir תודה!
הוא מציג לי רק מסך שחור...
אמנם לא עושה שום דיבאג אבל גם לא מראה לי את המצלמה.
ברגע שאני לוחץ על פתח מצלמה כל הטופס נהיה שחור.

[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 אמר בצילום תמונה לאקסס:

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

זה?