0

I'm developing a little project of an Access database for my hometown nonprofit health mutual. I'm new in database and VBA programming. What I do is I search on Internet, learning and adapting the solutions I find online to my database and still now I'm progressing step by step and I'm very satisfied with that approach.

In my database I have a table that records the members with First Name, Phone Number, Address etc. But there is also a field to store the photo of the member. I managed to create an "Import Photo" button associated with the following code:

Private Sub BtnImportPhoto_Click()
    
    Dim fd As FileDialog
    
    Set fd = Application.FileDialog(msoFileDialogOpen)

    With fd
        .AllowMultiSelect = False
        
        .Filters.Clear
        .Filters.Add "Tous les fichiers", "*.*", 1
        .Filters.Add "Fichiers images", "*.jpg; *.jpeg; *.png", 2
        .Title = "Sélectionnez une photo Adhérent"
        .FilterIndex = 2
        
        If .Show Then
            Me.PhotoFilePath.Value = .SelectedItems.Item(1)
        End If
    
    End With

End Sub

The BtnImportPhoto_Click() event allows end users to browse and select a picture file and store the selected filepath to the control "PhotoFilePath".

I wanted to add a button to capture a photo directly from the attached webcam. I found on this site someone that was asking the same question here:

text

That question was answered thanks to @Erik-A who adapted a VB6 code to VBA Access.

I have 2 problems. if I click the button to initialize the webcam, the device is on but the visualization window remains black until I click the format button to choose YUY2. Is there a way to add to the code a function to set it on YUY2 by default?

I want to make it more simple for the end users so if I can avoid that setting window it would be great.

I modified the following code to remove the "Format webcam" button and merge its associated code to the "cmd1" button to initialize the webcam and choose the settings.

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_SET_PREVIEW As Long = WM_CAP_START + 50
Const WM_CAP_SET_PREVIEWRATE As Long = WM_CAP_START + 52
Const WM_CAP_FILE_SAVEDIB As Long = WM_CAP_START + 25
Const WM_CAP_DLG_VIDEOFORMAT As Long = WM_CAP_START + 41

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

Private Sub cmd4_Click()
    Dim sFileName As String
    Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(False), 0&)
    sFileName = GetSavePath
    Call SendMessage(hCap, WM_CAP_FILE_SAVEDIB, 0&, ByVal CStr(sFileName))
DoFinally:
    Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(True), 0&)
End Sub

Private Sub Cmd3_Click()
    Dim temp As Long
    temp = SendMessage(hCap, WM_CAP_DRIVER_DISCONNECT, 0&, 0&)
End Sub

Private Sub Cmd1_Click()
    hCap = capCreateCaptureWindow("Take a Camera Shot", WS_CHILD Or WS_VISIBLE, 0, 0, PicWebCam.Width, PicWebCam.Height, PicWebCam.Form.hWnd, 0)
    If hCap <> 0 Then
        Call SendMessage(hCap, WM_CAP_DRIVER_CONNECT, 0, 0)
        Call SendMessage(hCap, WM_CAP_SET_PREVIEWRATE, 66, 0&)
        
        ' Appel de la fenêtre de paramétrage de la webcam
        Call SendMessage(hCap, WM_CAP_DLG_VIDEOFORMAT, 0&, 0&)
        
        Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(True), 0&)
    End If
End Sub

Private Sub Form_Load()
    cmd1.Caption = "&Allumer Webcam"
    cmd3.Caption = "&Eteindre Webcam"
    cmd4.Caption = "&Capurer Image"
End Sub

Function GetSavePath() As String
    Dim f As Object 'FileDialog
    Set f = Application.FileDialog(2) 'msoFileDialogSaveAs
    If f.Show <> 0 Then GetSavePath = f.SelectedItems(1)
End Function

My second question: Is there a way to crop the photo to square shape to match the needs of the badge we deliver?

I tried with ChatGPT to help me to add to the code to make the YUY2 setting default so the end user will not need to call the setting windows to choose the right format. But the solution provided is not working. the visualization window remains black. Here is the modified code that supposed to solve the problem:

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_SET_PREVIEW As Long = WM_CAP_START + 50
Const WM_CAP_SET_PREVIEWRATE As Long = WM_CAP_START + 52
Const WM_CAP_FILE_SAVEDIB As Long = WM_CAP_START + 25
Const WM_CAP_SET_VIDEOFORMAT As Long = WM_CAP_START + 45
Const WM_CAP_SET_VIDEOFORMAT_SIZE As Long = WM_CAP_START + 49

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

Private Sub cmd4_Click()
    Dim sFileName As String
    Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(False), 0&)
    sFileName = GetSavePath
    Call SendMessage(hCap, WM_CAP_FILE_SAVEDIB, 0&, ByVal CStr(sFileName))
DoFinally:
    Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(True), 0&)
End Sub

Private Sub Cmd3_Click()
    Dim temp As Long
    temp = SendMessage(hCap, WM_CAP_DRIVER_DISCONNECT, 0&, 0&)
End Sub

Private Sub Cmd1_Click()
    hCap = capCreateCaptureWindow("Take a Camera Shot", WS_CHILD Or WS_VISIBLE, 0, 0, PicWebCam.Width, PicWebCam.Height, PicWebCam.Form.hWnd, 0)
    If hCap <> 0 Then
        Call SendMessage(hCap, WM_CAP_DRIVER_CONNECT, 0, 0)
        Call SendMessage(hCap, WM_CAP_SET_PREVIEWRATE, 66, 0&)
        Call SendMessage(hCap, WM_CAP_SET_VIDEOFORMAT_SIZE, 0, 640 + (480 * &H10000))
        Call SendMessage(hCap, WM_CAP_SET_VIDEOFORMAT, 0, &H32595559)
        Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(True), 0&)
    End If
End Sub

Private Sub Form_Load()
    cmd1.Caption = "&Allumer Webcam"
    cmd2.Caption = "&Format Webcam"
    cmd3.Caption = "&Eteindre Webcam"
    cmd4.Caption = "&Capurer Image"
End Sub

Function GetSavePath() As String
    Dim f As Object 'FileDialog
    Set f = Application.FileDialog(2) 'msoFileDialogSaveAs
    If f.Show <> 0 Then GetSavePath = f.SelectedItems(1)
End Function

Thanks in advance.

June7
  • 19,874
  • 8
  • 24
  • 34
mijd
  • 1
  • 1
  • 1
    A question should have only one issue. Yours has 2. I have no problem with code using SET_VIDEOFORMAT and SET_VIDEOFORMAT_SIZE in same button that connects and previews. Works just fine for me. As for your other issue, does this answer your question? [How to rotate, crop, scale, flip an image?](https://stackoverflow.com/questions/50215950/how-to-rotate-crop-scale-flip-an-image) – June7 Jul 09 '23 at 16:31
  • Where is `&H32595559` coming from? This should be a pointer to a tagBitmapInfo, these random constants are a bit strange. Also, `WM_CAP_SET_VIDEOFORMAT_SIZE` appears to be entirely made up, I can't find anything on that online. If you focus on a single issue, I might be able to help – Erik A Jul 10 '23 at 10:11
  • @June7 I suspect that `SET_VIDEOFORMAT_SIZE` silently throws an error which you ignore (and the `WM_CAP_SET_VIDEOFORMAT` too), since these calls appear to be invalid. If they'd actually work for you, I'd be very surprised – Erik A Jul 10 '23 at 10:16
  • Whether or not those constants do anything, I get image from camera and can save it to file. – June7 Jul 10 '23 at 15:08
  • That's what I'd expect, since the code also works without this and invalid `SendMessage` calls return an error and are ignored, they don't invalidate anything. But the preview probably isn't in the resolution and compression "specified" (if you can call passing a seemingly randomly integer generated by ChatGPT specifying something) – Erik A Jul 10 '23 at 17:37
  • Honestly, I'm new in VBA programming. I'm developing my Access database since about 4 months ago with many functions made with VBA Access. I'm progressing by learning each time the specific feature I need to add. I was looking since the beginning a way to capture a photo from the webcam directly from a form of the database. Luckily I found this post I linked above. It's working but I always need to click the format webcam button and chose YUY2 to make the preview working. I have no clue about instructions and arguments to initialize the device directly once we clic on "start webcam" – mijd Jul 12 '23 at 03:50
  • @ErikA I guess all the issue is in this block: `hCap = capCreateCaptureWindow("Take a Camera Shot", WS_CHILD Or WS_VISIBLE, 0, 0, PicWebCam.Width, PicWebCam.Height, PicWebCam.Form.hWnd, 0) If hCap <> 0 Then Call SendMessage(hCap, WM_CAP_DRIVER_CONNECT, 0, 0) Call SendMessage(hCap, WM_CAP_SET_PREVIEWRATE, 66, 0&) Call SendMessage(hCap, WM_CAP_SET_VIDEOFORMAT_SIZE, 0, 640 + (480 * &H10000)) Call SendMessage(hCap, WM_CAP_SET_VIDEOFORMAT, 0, &H32595559) Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(True), 0&) End If` – mijd Jul 12 '23 at 03:58
  • As June7 said, one question at a time, so I can actually provide a full answer. If you only post one, I can see if I can make time to provide an answer to it. This is not beginner code, unfortunately, nor something ChatGPT can help you with – Erik A Jul 12 '23 at 08:35

0 Answers0