0

I am making an Excel file within which I can perform a photo survey.

I have used the standard script that is posted at: MS Access VBA code to capture image from camera and save it Without access to common dialog.

VBA/VB6 does not have the PictureBox control, so I have replaced it with an ImageComboBox so I have a .hWnd attribute.

So I run all this whilst having my webcam open on Skype's video device settings menu (for which a clear image is visible), but the image that gets saved is a 640x480 green square.

Have you got any thoughts on what might be causing the issue?

Thanks in advance,

Aeonat

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


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


Public Const WM_CAP_DRIVER_CONNECT As Long = WM_CAP_START + 10
Public Const WM_CAP_DRIVER_DISCONNECT As Long = WM_CAP_START + 11
Public Const WM_CAP_SET_PREVIEW As Long = WM_CAP_START + 50
Public Const WM_CAP_SET_PREVIEWRATE As Long = WM_CAP_START + 52
Public Const WM_CAP_DLG_VIDEOFORMAT As Long = WM_CAP_START + 41
Public Const WM_CAP_FILE_SAVEDIB As Long = WM_CAP_START + 25

Public 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

Public 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

Sub edit_shape()

Dim shp As Shape
Dim sht As Worksheet
Dim a As String
Dim b As String

a = ""
b = ""

For Each shp In Worksheets(1).Shapes
    If shp.Type <> 6 Then
        a = shp.Name
    End If
Next

Worksheets(1).Shapes(a).Select
Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadTriangle
With Selection.ShapeRange.Line
    .Visible = msoTrue
    .ForeColor.RGB = RGB(255, 0, 0)
    .Transparency = 0
End With
With Selection.ShapeRange.Line
    .Visible = msoTrue
    .Weight = 3
End With

Sheets.Add.Name = "Photo" & CStr(Worksheets.Count)
ActiveSheet.Move After:=Worksheets(Worksheets.Count)
Worksheets(1).Hyperlinks.Add Anchor:=Worksheets(1).Shapes(a), Address:="", _
        SubAddress:="Photo" & CStr(Worksheets.Count - 1) & "!A1:A1", ScreenTip:="Photo" & CStr(Worksheets.Count - 1)

UserForm1.Show

End Sub

--the following part is for the UserForm1 which contains 4 commandbuttons and 1 InkPicture--

Dim hCap As Long
Private Sub cmd4_Click()
Dim sFileName As String
    Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(False), 0&)
    sFileName = "C:\Users\Path\Photo survey\Photo" & Worksheets.Count - 1 & ".bmp"
    Call SendMessage(hCap, WM_CAP_FILE_SAVEDIB, 0&, ByVal CStr(sFileName))
DoFinally:
    Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(True), 0&)
Sheets(Worksheets.Count).Pictures.Insert ("C:\Users\Path\Photo survey\Photo" & Worksheets.Count - 1 & ".bmp")
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.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_PREVIEW, CLng(True), 0&)
    End If
End Sub

Private Sub Cmd2_Click()
Dim temp As Long
temp = SendMessage(hCap, WM_CAP_DLG_VIDEOFORMAT, 0&, 0&)
End Sub

Private Sub Userform_initialize()
cmd1.Caption = "Start &Cam"
cmd2.Caption = "&Format Cam"
cmd3.Caption = "&Close Cam"
cmd4.Caption = "&Save Image"
End Sub
Bob77
  • 13,167
  • 1
  • 29
  • 37
Aeonat
  • 1
  • 2

0 Answers0