Access VBA摄像头捕获库使用及两个技术问题求助

一、解决摄像头预览黑屏，默认设置YUY2格式 #

你的代码中直接传递&H32595559（YUY2的FourCC值）给WM_CAP_SET_VIDEOFORMAT是错误的，该消息需要传递完整的BITMAPINFO结构而非单纯的格式标识。以下是修正后的完整代码：

替换原有常量与API声明 #

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 YUY2_FOURCC As Long = &H32595559 ' YUY2格式标识

' API声明
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 LongPtr

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 Type BITMAPINFOHEADER
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type

Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As String * 4 ' 占位用，无需调色板
End Type

Dim hCap As LongPtr

修改摄像头初始化事件 #

Private Sub Cmd1_Click()
    Dim bmi As BITMAPINFO
    Dim previewWidth As Long, previewHeight As Long
    
    previewWidth = 640
    previewHeight = 480
    
    hCap = capCreateCaptureWindow("Take a Camera Shot", WS_CHILD Or WS_VISIBLE, 0, 0, PicWebCam.Width, PicWebCam.Height, PicWebCam.hWnd, 0)
    If hCap <> 0 Then
        ' 确认驱动连接成功后再设置格式
        If SendMessage(hCap, WM_CAP_DRIVER_CONNECT, 0, 0) <> 0 Then
            ' 填充YUY2格式的BITMAPINFO结构
            With bmi.bmiHeader
                .biSize = Len(bmi.bmiHeader)
                .biWidth = previewWidth
                .biHeight = -previewHeight ' 负数值表示从上到下的位图格式
                .biPlanes = 1
                .biBitCount = 16 ' YUY2为16位每像素
                .biCompression = YUY2_FOURCC
                .biSizeImage = ((previewWidth * 16 + 31) \ 32) * 4 * previewHeight ' 计算图像字节数
                .biXPelsPerMeter = 0
                .biYPelsPerMeter = 0
                .biClrUsed = 0
                .biClrImportant = 0
            End With
            
            ' 发送格式设置消息
            SendMessage hCap, WM_CAP_SET_VIDEOFORMAT, Len(bmi), bmi
            
            ' 开启预览并设置帧率
            SendMessage hCap, WM_CAP_SET_PREVIEWRATE, 66, 0&
            SendMessage hCap, WM_CAP_SET_PREVIEW, CLng(True), 0&
        End If
    End If
End Sub

关键修正点

• 使用完整的BITMAPINFO结构传递格式参数，符合驱动要求
• 先确认驱动连接成功，再执行格式设置与预览操作
• 正确计算YUY2格式的图像字节数，避免驱动识别失败

二、实现捕获照片的方形裁剪 #

通过GDI+ API实现图片裁剪，取照片中心区域生成方形图片，适配徽章需求：

添加GDI+相关声明（放在模块顶部） #

' GDI+ 操作API
Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus" (ByRef token As LongPtr, ByRef inputbuf As GdiplusStartupInput, ByVal outputbuf As LongPtr) As Long
Private Declare PtrSafe Function GdiplusShutdown Lib "gdiplus" (ByVal token As LongPtr) As Long
Private Declare PtrSafe Function GdipCreateBitmapFromFile Lib "gdiplus" (ByVal filename As LongPtr, ByRef bitmap As LongPtr) As Long
Private Declare PtrSafe Function GdipCloneBitmapArea Lib "gdiplus" (ByVal x As Single, ByVal y As Single, ByVal width As Single, ByVal height As Single, ByVal srcBitmap As LongPtr, ByRef dstBitmap As LongPtr) As Long
Private Declare PtrSafe Function GdipSaveImageToFile Lib "gdiplus" (ByVal image As LongPtr, ByVal filename As LongPtr, ByRef clsidEncoder As GUID, ByVal encoderParams As LongPtr) As Long
Private Declare PtrSafe Function GdipDisposeImage Lib "gdiplus" (ByVal image As LongPtr) As Long
Private Declare PtrSafe Function CLSIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByRef pclsid As GUID) As Long

' GDI+ 初始化结构
Private Type GdiplusStartupInput
    GdiplusVersion As Long
    DebugEventCallback As LongPtr
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End Type

' GUID结构
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

添加裁剪函数与修改拍照事件 #

' 获取JPEG编码器的CLSID
Private Function GetEncoderClsid(ByVal format As String, ByRef clsid As GUID) As Long
    CLSIDFromString StrPtr(format), clsid
End Function

' 裁剪图片为中心方形区域
Private Sub CropToSquare(ByVal srcPath As String, ByVal destPath As String)
    Dim gdiToken As LongPtr
    Dim gdiInput As GdiplusStartupInput
    Dim srcBitmap As LongPtr, dstBitmap As LongPtr
    Dim jpegClsid As GUID
    Dim imgWidth As Long, imgHeight As Long
    Dim cropSize As Long, cropX As Long, cropY As Long
    
    ' 初始化GDI+
    gdiInput.GdiplusVersion = 1
    GdiplusStartup gdiToken, gdiInput, 0
    
    ' 加载源图片
    If GdipCreateBitmapFromFile(StrPtr(srcPath), srcBitmap) = 0 Then
        ' 获取图片尺寸
        imgWidth = SendMessage(srcBitmap, &H100, 0, 0) ' GdipGetImageWidth
        imgHeight = SendMessage(srcBitmap, &H101, 0, 0) ' GdipGetImageHeight
        
        ' 计算中心裁剪区域
        cropSize = IIf(imgWidth < imgHeight, imgWidth, imgHeight)
        cropX = (imgWidth - cropSize) \ 2
        cropY = (imgHeight - cropSize) \ 2
        
        ' 执行裁剪
        If GdipCloneBitmapArea(cropX, cropY, cropSize, cropSize, srcBitmap, dstBitmap) = 0 Then
            ' 获取JPEG编码器并保存
            GetEncoderClsid("{557CF401-1A04-11D3-9A73-0000F81EF32E}", jpegClsid)
            GdipSaveImageToFile(dstBitmap, StrPtr(destPath), jpegClsid, 0)
            GdipDisposeImage dstBitmap
        End If
        GdipDisposeImage srcBitmap
    End If
    
    ' 关闭GDI+
    GdiplusShutdown gdiToken
End Sub

' 修改拍照按钮事件，加入裁剪逻辑
Private Sub cmd4_Click()
    Dim tempPath As String, finalPath As String
    
    ' 保存临时BMP文件
    tempPath = Environ("TEMP") & "\temp_capture.bmp"
    SendMessage hCap, WM_CAP_SET_PREVIEW, CLng(False), 0&
    SendMessage hCap, WM_CAP_FILE_SAVEDIB, 0&, ByVal tempPath
    
    ' 获取最终保存路径并确保为JPG格式
    finalPath = GetSavePath()
    If Right(finalPath, 4) <> ".jpg" And Right(finalPath, 5) <> ".jpeg" Then
        finalPath = finalPath & ".jpg"
    End If
    
    ' 裁剪为方形并保存
    CropToSquare tempPath, finalPath
    
    ' 清理临时文件
    Kill tempPath
    
DoFinally:
    SendMessage hCap, WM_CAP_SET_PREVIEW, CLng(True), 0&
    ' 将最终路径赋值给控件
    Me.PhotoFilePath.Value = finalPath
End Sub

关键说明

• 先保存临时BMP文件，裁剪后转为JPG格式，平衡画质与文件体积
• 自动取图片中心区域裁剪，保证人物主体在方形内
• 兼容不同分辨率的摄像头输出

内容的提问来源于stack exchange，提问作者mijd