Question

我正在制作一个Excel文件，我可以在其中进行照片调查。

我使用了发布在以下位置的标准脚本： string concatenation problem 无法访问常用对话框。

VBA / VB6没有PictureBox控件，所以我用ImageComboBox替换它，所以我有一个.hWnd属性。

所以我在Skype的视频设备设置菜单（可以看到清晰的图像）上打开网络摄像头的同时运行所有这些，但保存的图像是640x480绿色方块。

您对可能导致此问题的原因有任何疑问吗？

提前致谢，

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

- 以下部分适用于包含4个命令按钮和1个InkPicture的UserForm1 -

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

Excel VBA：从网络摄像头捕获的快照为绿色

0 个答案: