After consulting How to use webcam capture on a Microsoft Access form, I have a program where the user presses a button on an Excel form to open an Access form and take before & after photos using built-in webcam then save them to a predetermined folder. This works fine on several laptops including mine but when I try to run it on a tablet with front and back camera, it prompts me to choose between UNICAM Rear and UNICAM Front, which I presume means the code works fine and is connecting to the driver. However, the chosen camera doesn't connect; WM_CAP_DRIVER_CONNECT returns False and I get a black screen in the picture frame.
The tablet is an Acer One 10 running Win10 Home 32-bit and Access 365 Runtime. The I've tested the program using Access Runtime through Command Prompt on my laptop and it worked fine, I've checked that other apps are allowed to access the camera, nothing else is using the camera, tested 0 to 9 for WM_CAP_CONNECT parameters, changed LongPtr back to Long (which by the way still makes it work on win10 Pro 64-bit) and it still doesn't work.
I suspect it's an issue with the tablet and not the code since it's a company tablet and there are two cameras, perhaps I may be missing some permissions to connect to the camera via Access or the code doesn't work with two cameras, but I have no idea where to begin checking these.
I'm currently trying to find a laptop with two cameras to test the program on and in the meantime I'm totally lost and would appreciate suggestions for anything I could try to fix this problem, whether related to the code or not - though I would like to avoid running executables like CommandCam, seeing as I'm using company computers.
This is the part of my Excel code that affects opening Access:
Private Sub mainBtn_Click()
Dim LCategoryID As Long
Dim ShellCmd, LPath As String
Dim wsMain, wsRec As Worksheet
Set wsMain = Sheets("Main")
Set wsRec = Sheets("Records")
mainBtn.Enabled = False
LPath = ThisWorkbook.Path + "\Database1.accdb"
If mainBtn.Caption <> "Record" Then
If Dir(PathToAccess) <> "" And oApp Is Nothing Then
ShellCmd = """" & PathToAccess & """ """ & LPath & """"
VBA.Shell ShellCmd
If oApp Is Nothing Then Set oApp = GetObject(LPath)
' Set oApp = CreateObject("Access.Application")
End If
Application.Wait (Now + TimeValue("00:00:05"))
On Error Resume Next
oApp.OpenCurrentDatabase LPath
oApp.Visible = False
On Error GoTo 0
'passing a value through a sub on Access
oApp.Run "getName", wsMain.Range("F5").Value
End If
'before photo
If mainBtn.Caption = "Before Photo" Then
oApp.DoCmd.openform "Before Photo"
mainBtn.Caption = "After Photo"
mainBtn.Enabled = True
This is my code in Access:
Option Compare Database
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_DLG_VIDEOFORMAT As Long = WM_CAP_START + 41
Const WM_CAP_FILE_SAVEDIB As Long = WM_CAP_START + 25
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
Private Declare Sub sapiSleep Lib "kernel32" _
Alias "Sleep" _
(ByVal dwMilliseconds As Long)
Dim hCap As LongPtr
Dim i As Integer
Private Sub cmd4_click()
' take picture
Dim sFileName, sFileNameSub, dateNow, timeNow As String
i = i + 1
Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(False), 0&)
dateNow = DateValue(Now)
timeNow = TimeValue(Now)
sFileName = CurrentProject.Path + "\dbimages\Before Change " + CStr(Year(dateNow)) + "." + CStr(Month(dateNow)) + "." + CStr(Day(dateNow)) + " " + CStr(Hour(timeNow)) + "h" + CStr(Minute(timeNow)) + "m" + CStr(Second(timeNow)) + "s.jpg"
Call SendMessage(hCap, WM_CAP_FILE_SAVEDIB, 0&, ByVal CStr(sFileName))
DoFinally:
Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(True), 0&)
If i = 4 Then
MsgBox "4 pictures taken. Exiting"
DoCmd.Close
Else
MsgBox "Picture " + CStr(i) + " Taken"
End If
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()
' Dim connectAttempts As Integer
Dim i As Integer
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)
' For i = 0 To 9
If CBool(SendMessage(hCap, WM_CAP_DRIVER_CONNECT, 0, 0)) = False Then
' connectAttempts = connectAttempts + 1
MsgBox "Failed to connect Camera"
Else
' Exit For
End If
' Next i
Call SendMessage(hCap, WM_CAP_SET_PREVIEWRATE, 45, 0&)
Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(True), 0&)
End If
End Sub
Private Sub Cmd2_Click()
'back to excel
'Dim temp As Long
'temp = SendMessage(hCap, WM_CAP_DLG_VIDEOFORMAT, 0&, 0&)
DoCmd.Close
End Sub
Private Sub Form_Close()
Dim temp As Long
temp = SendMessage(hCap, WM_CAP_DRIVER_DISCONNECT, 0&, 0&)
'DoCmd.ShowToolbar "Ribbon", acToolbarYes
End Sub
Private Sub Form_Load()
'DoCmd.ShowToolbar "Ribbon", acToolbarNo
i = 0
cmd1.Caption = "Start Cam"
cmd2.Caption = "Done"
cmd3.Caption = "dummy"
cmd4.Caption = "Tak&e Picture"
DoCmd.RunCommand acCmdAppMinimize
DoCmd.Maximize
If stnName = "Head 1" Or stnName = "Head 2" Then
Pic1.Picture = CurrentProject.Path + "\images\head_s.jpeg"
ElseIf stnName = "Marriage Head" Or stnName = "Plus Clip Head" Then
Pic1.Picture = CurrentProject.Path + "\images\marriage_s.jpeg"
Else
Pic1.Picture = CurrentProject.Path + "\images\6pair_s.jpeg"
End If
cmd1_click
On Error Resume Next
CurrentProject.Application.Visible = True
End Sub
Private Sub sSleep(lngMilliSec As Long)
If lngMilliSec > 0 Then
Call sapiSleep(lngMilliSec)
End If
End Sub
EDIT: Camera app works fine on tablet but I get a black screen in picture box when trying to use it through Access.
EDIT2: Code for WM_CAP_GET_STATUS
Added the following line in main module:
Const WM_CAP_GET_STATUS = WM_CAP_START + 54
Added the following in another module:
Type CAPSTATUS
uiImageWidth As Long
uiImageHeight As Long
fLiveWindow As Long
fOverlayWindow As Long
fScale As Long
ptScroll As POINTAPI
fUsingDefaultPalette As Long
fAudioHardware As Long
fCapFileExists As Long
dwCurrentVideoFrame As Long
dwCurrentVideoFramesDropped As Long
dwCurrentWaveSamples As Long
dwCurrentTimeElapsedMS As Long
hPalCurrent As Long
fCapturingNow As Long
dwReturn As Long
wNumVideoAllocated As Long
wNumAudioAllocated As Long
End Type
New code for starting camera:
Private Sub cmd1_click()
Dim bool1, bool2, bool3 As Boolean
Dim o As Integer
Dim u As Integer
Dim s As CAPSTATUS
Open CurrentProject.Path + "\output.txt" For Output As #1
i = 0 'global variable
hCap = capCreateCaptureWindow("Take a Camera Shot", ws_child Or ws_visible, 0, 0, PicWebCam.Width, PicWebCam.Height, PicWebCam.Form.hwnd, 0)
sSleep 5000
If hCap <> 0 Then
For i = 0 To 9
Print #1, hCap
bool1 = CBool(SendMessage(hCap, WM_CAP_DRIVER_CONNECT, i, 0))
Print #1, bool1
bool3 = SendMessage(hCap, WM_CAP_GET_STATUS, LenB(s), s)
Print #1, bool3
For u = 1 To 4
If bool1 = True Then
bool1 = SendMessage(hCap, WM_CAP_DRIVER_DISCONNECT, i, 0&)
End If
o = u * 7
bool1 = CBool(SendMessage(hCap, WM_CAP_DRIVER_CONNECT, i, 0))
Print #1, Tab(o); bool1
bool3 = SendMessage(hCap, WM_CAP_GET_STATUS, LenB(s), s)
Print #1, Tab(o); bool3
Next u
Call SendMessage(hCap, WM_CAP_SET_PREVIEWRATE, 45, 0&)
Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(True), 0&)
Next i
End If
Close #1
End Sub
