Public ctCapWin As Long, ctRec As Boolean, ctDir As String, ctF As String, ctAutoSize As Boolean
Dim ctRefresh As Boolean, ctConnect As Boolean, ctAutoHide As Boolean, IsFillScreen As Boolean

Private Declare Function GetCursorPos Lib “user32” (lpPoint As PointAPI) As Long
Private Type PointAPI
X As Long: Y As Long
End Type
Private Declare Function SetWindowPos Lib “user32” (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cX As Long, ByVal cY As Long, ByVal wFlags As Long) As Long
Const HWND_Top = 0 'hWndInsertAfter 参数：Z序列的顶部
Const HWND_TopMost = -1 '最前
Const HWND_NoTopMost = -2 '不在最前
Const HWND_Bottom = 1 '位于底层
Const SWP_NoSize = &H1 'wFlags 参数
Const SWP_NoMove = &H2
Const SWP_NoZorder = &H4
Const SWP_NoActivate = &H10
Const SWP_ShowWindow = &H40
Const SWP_HideWindow = &H80

Private Declare Function SendMessage Lib “user32” Alias “SendMessageA” (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function SendMessageLong Lib “user32” Alias “SendMessageA” (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
Private Declare Function PostMessage Lib “user32” Alias “PostMessageA” (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Const WM_Close = &H10

Private Declare Function capGetDriverDescriptionA Lib “avicap32.dll” (ByVal wDriver As Integer, ByVal lpszName As String, ByVal cbName As Long, ByVal lpszVer As String, ByVal cbVer As Long) As Boolean
Private Declare Function capCreateCaptureWindow Lib “avicap32.dll” Alias “capCreateCaptureWindowW” (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
Const WS_Child = &H40000000
Const WS_Visible = &H10000000
Const WS_Caption = &HC00000
Const WS_ThickFrame = &H40000

Const GET_Frame = 1084

Const WM_User = &H400 '用户消息开始号，偏移地址:1024
Const WM_CAP_GET_CAPSTREAMPTR = WM_User + 1 ’
Const WM_CAP_SET_CALLBACK_ERROR = WM_User + 2 '当出错回调函数
Const WM_CAP_SET_CALLBACK_STATUS = WM_User + 3 '当状态（status）改变的时回调函数
Const WM_CAP_SET_CALLBACK_YIELD = WM_User + 4 '在流捕获期间的回调函数
Const WM_CAP_SET_CALLBACK_FRAME = WM_User + 5 '帧预览回调函数
Const WM_CAP_SET_CALLBACK_VIDEOSTREAM = WM_User + 6 '在流捕获期间，当一个新的视频缓存区可用的时候就调用它
Const WM_CAP_SET_CALLBACK_WAVESTREAM = WM_User + 7 '在流捕获期间，当一个新的音频缓存区可用的时候就调用它

Const WM_CAP_GET_USER_DATA = WM_User + 8 '获取：数据关联到一个捕捉窗口
Const WM_CAP_SET_USER_DATA = WM_User + 9 '设置：数据关联到一个捕捉窗口

Const WM_CAP_DLG_VideoFormat = WM_User + 41 '对话框：视频格式
Const WM_CAP_DLG_VideoSource = WM_User + 42 '对话框：视频源，枚举视频源，控制颜色、对比度、饱和度的改变。需视频驱动程序支技
Const WM_CAP_DLG_VideoDisplay = WM_User + 43 '对话框：视频显示？控制视频捕捉过程中视频在显示器上的显示。对捕捉数据无影响，但会影响数了信号表达式
Const WM_CAP_DLG_VideoCompression = WM_User + 46 '对话框：视频压缩

Private Enum enWinSet
’ en_Copy = -1
es_Show = 0
es_Hide
es_Close
es_Move
es_Size
End Enum

'捕捉文件和缓存
Const WM_Cap_File_Set_File = WM_User + 20 '设置当前的捕捉文件
Const WM_Cap_File_Get_File = WM_User + 21 '得到当前的捕捉文件
Const WM_CAP_FILE_ALLOCATE = WM_User + 22 '为捕捉文件预分配空间,从而可以减少被漏掉的帧
Const WM_CAP_FILE_SaveAs = WM_User + 23 '将捕捉文件保存为另一个用户指定的文件。这个消息不会改变捕捉文件的名字和内容,
'由于捕捉文件保留它最初的文件名，因此必须指定个新的文件的文件名来保存
Const WM_CAP_FILE_SET_INFOCHUNK = WM_User + 24 '可以把信息块例如文本或者自定义数据插入avi文件。同样用这个消息也可以清除avi文件中的信息块
Const WM_CAP_FILE_SaveDIB = WM_User + 25 '把从帧缓存中复制出图像存为设备无关位图书馆（DIB),应用程序也可以使用这两个单帧捕捉消息来编辑帧序列，
'或者创建一个慢速摄影序列

Const WM_CAP_Edit_Copy = WM_User + 30 '1054：把缓存中图像复制到剪贴板中

Const WM_CAP_SET_AUDIOFORMAT = WM_User + 35 '设置音频格式。设置时传入一个WAVEFORMAT、WAVEFORMATEX、或PCMWAVEOFMAT结构的指针
Const WM_CAP_GET_AUDIOFORMAT = WM_User + 36 '来得到音频数据的格式和该格式结构体的大小。默认的捕捉音频格式是mono、8-bit和11kHZ PCM

Const WM_CAP_Get_VideoFormat = WM_User + 44 '给捕捉窗口来得到视频格式的结构和该结构的大小。
Const WM_CAP_SET_VideoFormat = WM_User + 45 '用来设置视频格式

Const WM_CAP_SET_PreView = WM_User + 50 '发送给捕捉窗口来使预览模式有效或者失效
Const WM_CAP_SET_Overlay = WM_User + 51 '使窗口处于叠加模式。使叠加模式有效也会自动地使预览模式失效
Const WM_CAP_SET_PreViewRate = WM_User + 52 '发送给捕捉窗口来设置在预览模式下帧的显示频率
Const WM_CAP_SET_Scale = WM_User + 53 '来使预览模式的缩放有效或者无效

Const WM_CAP_SET_SCROLL = WM_User + 55 '如果是在预览模式或者叠加模式，还可以通过本消息发送给窗口，
'在窗口里的用户区域设置视频帧的滚动条的位置
Private Type BitMapInfoHeader 'tagBitMapInfoHeader Structure
biSize As Long ’
biWidth As Long
biHeight As Long 'LONG DWORD
biPlanes As Integer 'WORD
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 Byte 'RGBQUAD
End Type

'基本视频捕获消息--------------------------------------
Const WM_CAP_Connect = WM_User + 10 '连接一个视频驱动，成功返回真(1)。连接驱动后，不一定就能显示视频，还要保证摄像头硬件连接良好、未被其他程序使用。
Const WM_CAP_DisConnect = WM_User + 11 '断开视频窗口与驱动的连接

’ wParam：视频设备序号，从 0 到 9
Const WM_CAP_Sequence = WM_User + 62 '开始录像
Const WM_CAP_Stop = WM_User + 68 '终止视频捕获
Const WM_CAP_Abort = WM_User + 69 '暂停录像捕获？，成功返回真
Const WM_CAP_Set_Sequence_Setup = WM_User + 64
Const WM_CAP_Get_Sequence_Setup = WM_User + 65

'录像参数设置和获取
'Dim nParms As CaptureParms
'SendMessage ctCapWin, WM_CAP_Get_Sequence_Setup, Len(nParms), nParms’获取参数的设置
'nParms.fAbortLeftMouse = False '关闭：单击鼠标停止录像的功能。
'SendMessage ctCapWin, WM_CAP_Set_Sequence_Setup, Len(nParms), nParms’重新设置参数
Private Type CaptureParms ’
dwRequestMicroSecPerFrame As Long 'DWORD
fMakeUserHitOKToCapture As Boolean '开始录像时，是否显示确认对话框，默认为假
wPercentDropForError As Long '每毫秒捕捉帧率，默认66667，即每秒15帧
fYield As Boolean 'BOOL:如果为TRUE，将产生一个后台线程来进行视频捕捉
dwIndexSize As Long 'DWORD:视频文件最大的索引入口数
wChunkGranularity As Long 'UINT:以字节为单位表示AVI文件的大小
fUsingDOSMemory As Boolean 'BOOL:未使用
wNumVideoRequested As Long 'UINT:分配视频缓冲区的最大数量
fCaptureAudio As Boolean '是否捕获音频流，默认值由具体的硬件设置
wNumAudioRequested As Long '分配的音频缓冲区的最大数量
vKeyAbort As Long '结束录像的按键，默认为 VK_ESCAPE（Esc键）
fAbortLeftMouse As Boolean '单击鼠标左键停止录像，默认为真
fAbortRightMouse As Boolean '单击鼠标右键停止录像，默认为假
fLimitEnabled As Boolean '是否开启捕获时间限制，默认为真
wTimeLimit As Long '捕获时间限制（秒），fLimitEnabled 为真时有效
fMCIControl As Boolean 'BOOL:为TRUE，控制MCI（媒体设备接口）兼容的视频源
fStepMCIDevice As Boolean 'BOOL
dwMCIStartTime As Long 'DWORD:以毫秒为单位标识MCI设备视频捕捉序列的起始位置，如果fMCIControl成员为FALSE，该成员被忽略
dwMCIStopTime As Long 'DWORD:以毫秒为单位标识MCI设备视频捕捉序列的停止位置，如果fMCIControl成员为FALSE，该成员被忽略
fStepCaptureAt2x As Boolean 'BOOL:为TRUE，捕捉的视频帧使用两个分辨率
wStepCaptureAverageFrames As Long ':在捕捉时每帧图像使用的时间大小
dwAudioBufferSize As Long '音频缓冲大小，默认0
fDisableWriteCache As Boolean 'Win32系统未使用
AVStreamMaster As Long '确定在写入AVI文件时，音频流是否控制时钟
End Type

'视频窗口消息--------------------------------------
'Private Declare Function capGetDriverDescriptionA Lib “avicap32.dll” ( _
'ByVal wDriver As Integer, ByVal lpszName As String, ByVal cbName As Long, ByVal lpszVer As String, ByVal cbVer As Long) As Boolean
'可利用此 API 获取所有驱动程序名称和版本信息。例子：
’ Dim S As Long
’ Dim lpszName As String * 128
’ Dim lpszVer As String * 128
’
’ Do
’ If Not capGetDriverDescriptionA(S, lpszName, 128, lpszVer, 128) Then Exit Do '获得驱动程序名称和版本信息
’ S = S + 1
’ Loop
Const WM_CAP_Get_Status = WM_User + 54 '获取捕捉窗口的当前状态
Private Type CapStatus '■■?
uiImageWidth As Long '图像宽度，像素
uiImageHeight As Long '图像高度，像素
fLiveWindow As Boolean '视频显示是否使用预览
fOverlayWindow As Boolean '视频显示是否使用硬件
fScale As Boolean '图像是否随窗口大小自动缩放
ptScroll As PointAPI 'POINT?
fUsingDefaultPalette As Boolean '是否使用默认调色板
fAudioHardware As Boolean '是否安装了音频波形硬件
fCapFileExists As Boolean '是否生成了正确的捕获文件
dwCurrentVideoFrame As Long
dwCurrentVideoFramesDropped As Long
dwCurrentWaveSamples As Long
dwCurrentTimeElapsedMS As Long '视频流已录像时间（毫秒）
hPalCurrent As Long 'HPALETTE 当前调色板句柄
fCapturingNow As Boolean '是否正在进行捕获
dwReturn As Long '错误返回值，根据这个数值可以调用一个错误回调函数
wNumVideoAllocated As Long '视频缓冲
wNumAudioAllocated As Long '音频缓冲
End Type

Private Sub CloseMouse()
Dim nParms As CaptureParms
SendMessage ctCapWin, WM_CAP_Get_Sequence_Setup, Len(nParms), nParms '获取参数的设置
'nParms.fMakeUserHitOKToCapture = True '开始录像时，是否显示确认对话框
nParms.fYield = True '用一个后台线程来进行视频捕捉
nParms.fAbortLeftMouse = False '关闭：单击鼠标左键停止录像的功能。
nParms.fAbortRightMouse = False '关闭：单击鼠标右键停止录像的功能
SendMessage ctCapWin, WM_CAP_Set_Sequence_Setup, Len(nParms), nParms '重新设置参数

'ff = SendMessageLong(ctCapWin, WM_CAP_SET_CALLBACK_STATUS, 0, AddressOf CallBackStatus) '状态回调函数
'ff = SendMessageLong(ctCapWin, WM_CAP_SET_CALLBACK_FRAME, 0, AddressOf MyFrameCallback) '帧回调函数
'ff = SendMessageLong(ctCapWin, WM_CAP_SET_CALLBACK_YIELD, 0, AddressOf CallbackYield)
End Sub

Private Sub NoRecord()
SendMessage ctCapWin, WM_CAP_Stop, 0, 0 '停止录像
ctRec = False: Call SetCaption(" ")
End Sub

Private Sub StartRecord()
Dim F As String, nDir As String, nF As String

'如果路径不存在，用默认文件名 C:\CAPTURE.AVI
nDir = Trim(ctDir)
If nDir = "" Or nDir = "<>" Or nDir = "<默认>" Then nDir = App.Path & "\videos"
If Right(nDir, 1) <> "\" Then nDir = nDir & "\"
If Not MakePath(nDir) Then
   MsgBox "在指定的位置无法建立目录：" & vbCrLf & nPath, vbInformation, "保存视频文件"
   Exit Sub
End If

nF = Trim(ctF)
If nF = "" Or nF = "<>" Or nF = "<默认>" Then nF = Format(Now, "yyyymmdd-hhmmss") & ".avi"
If InStr(nF, ".") = 0 Then nF = nF & ".avi"
F = nDir & nF
  If CheckDirFile(F) = 1 Then
   If vbNo = MsgBox("文件已存在，覆盖此文件吗？" & vbCrLf & F, vbInformation + vbYesNo, "开始录像") Then Exit Sub
   On Error GoTo Cuo
   SetAttr F, 0
   Kill F
   On Error GoTo 0
End If

ctRec = False
SetWin ctCapWin, es_Size, , , , 1
ctRec = True
Call SetCaption("正在录像：" & nF)
Call KjEnabled(True)

DoEvents
Call CloseMouse
SendMessage ctCapWin, WM_Cap_File_Set_File, 0, ByVal F '设置录像保存的文件
PostMessage ctCapWin, WM_CAP_Sequence, 0, 0            '开始录像
If ctAutoHide Then Me.Visible = False
Exit Sub

Cuo:
MsgBox “无法写文件：” & vbvrlf & vbCrLf & F, vbInformation, “录像 - 错误”
End Sub

Private Sub SetDir()
Dim nStr As String
If Trim(ctDir) = “” Then ctDir = App.Path & “\videos” '如果路径不存在，用默认文件名 C:\CAPTURE.AVI
nStr = “设置录像保存的文件夹。” & vbCrLf & “输入” <> “表示使用默认文件夹：” & vbCrLf & App.Path & “\videos”
nStr = Trim(InputBox(nStr, “录像保存的文件夹”, ctDir))
If nStr = “” Then Exit Sub
ctDir = nStr
If ctDir = “<>” Or ctDir = “<默认>” Then ctDir = “”
End Sub

Private Sub SetFile()
Dim nStr As String, nF As String

nF = String(255, " ")
SendMessage ctCapWin, WM_Cap_File_Get_File, Len(nF), ByVal nF
nF = GetStrLeft(nF, vbNullChar)

If Trim(ctF) = "" Then ctF = "<默认>" '如果路径不存在，用默认文件名 C:\CAPTURE.AVI
nStr = "设置录像保存的文件名(不带路径)。" & vbCrLf & "输入" <> "表示使用默认文件名：日期-时间.扩展名"
nStr = Trim(InputBox(nStr, "录像保存的文件名", ctF))
If nStr = "" Then Exit Sub
ctF = nStr
If ctF = "<>" Or ctF = "<默认>" Then ctF = ""

SendMessage ctCapWin, WM_Cap_File_Set_File, 0, ByVal ctF

End Sub

Private Function GetStrLeft(nStr As String, Fu As String) As String
'去掉 Fu 及后面的字符
Dim S As Long
S = InStr(nStr, Fu)
If S > 0 Then GetStrLeft = Left(nStr, S - 1) Else GetStrLeft = nStr
End Function

Private Function CheckDirFile(nDirFile) As Long
'检查目录或文件夹，返回值：0不存在，1是文件，2是目录
Dim nStr As String, nD As Boolean
nStr = Dir(nDirFile, 23)
If nStr = “” Then Exit Function
nD = GetAttr(nDirFile) And 16
If nD Then CheckDirFile = 2 Else CheckDirFile = 1
End Function

Private Sub Form_Load()
Dim W As Long, H As Long
Call SetCaption("")

Me.ScaleMode = 3: Picture1.ScaleMode = 3
Picture1.BorderStyle = 0
Set Command1(0).Container = Picture1
Set Check1(0).Container = Picture1

Call ReadSaveSet '读取用户设置
'装载数组控件
AddKj Command1, "连", "Connect", "连接摄像头"
AddKj Command1, "断", "DisConnect", "断开与摄像头的连接"
AddKj Command1, "-"
AddKj Command1, "源", "VideoSource", "选择：视频源"
AddKj Command1, "格", "VideoFormat", "设置：视频格式，分辨率"
AddKj Command1, "显", "VideoDisplay", "视频显示对话框。某些显卡不支持此功能。"
AddKj Command1, "-"
AddKj Command1, "夹", "SetDir", "设置录像文件保存的文件夹。默认为主程序所在目录下的videos文件夹"
AddKj Command1, "文", "SetFile", "录像保存的文件名，默认为：时间-编号.扩展名"
AddKj Command1, "压", "VideoCompression", "设置：视频录像文件的压缩方式"
AddKj Command1, "-"
AddKj Command1, "录", "Record", "开始录像"
AddKj Command1, "停", "NoRecord", "停止录像"
AddKj Command1, "图", "CopyImg", "将当前图像复制到剪贴板"
AddKj Command1, "-"
AddKj Command1, "全", "FillScreen", "切换：全屏/窗口"
AddKj Command1, "关", "Exit", "关闭：退出程序"

If ctAutoSize Then W = 1 Else W = 0
AddKj(Check1, "自", "AutoSize", "视频窗口是否随主窗口自动改变大小").Value = W
If ctAutoHide Then W = 1 Else W = 0
AddKj(Check1, "隐", "AutoHide", "录像时自动隐藏主窗口").Value = W

’ ctAutoSize = True '预览图像随窗口自动缩放
ListKj Command1, Command1(0).Height * 0.1 '排列数组控件
W = Command1.UBound: W = Command1(W).Left + Command1(W).Width * 2
ListKj Check1, W '排列数组控件
Picture1.Height = Command1(0).Height * 1.2

Call WinCenter '窗口居中
ctRefresh = True
Call CreateCapWin '创建视频窗口
Call KjEnabled(True)
Timer1.Enabled = True: Timer1.Interval = 500

End Sub

Private Sub Form_Resize()
Picture1.Move 0, 0, Me.ScaleWidth, Command1(0).Height * 1.3
If ctAutoSize Then SetWin ctCapWin, es_Size '视频子窗口随主窗口自动改变大小
End Sub

Private Sub Timer1_Timer()
Dim nP As PointAPI, X As Long, Y As Long, H As Long
Dim nStatus As CapStatus, nRec As Boolean

’ '我读取窗口的当前状态 nStatus 总是失败，忘高手赐教
’ X = SendMessageLong(ctCapWin, WM_CAP_Get_Status, Len(nStatus), ByVal VarPtr(nStatus))
’ X = SendMessage(ctCapWin, WM_CAP_Get_Status, Len(nStatus), nStatus)
’ nRec = nStatus.fCapturingNow '是否正在进行捕获
’ S = nStatus.uiImageWidth '图像宽度，像素
’ Me.Caption = X

GetCursorPos nP
X = nP.X - Me.Left / Screen.TwipsPerPixelX
Y = nP.Y - Me.Top / Screen.TwipsPerPixelY

If Not IsFillScreen Then Exit Sub
H = Me.Height / Screen.TwipsPerPixelY - Me.ScaleHeight '窗口标题栏高度
If Y > -1 And Y < H + Picture1.Height Then
If Picture1.Visible Then Exit Sub
Picture1.Visible = True
Else
If Not Picture1.Visible Then Exit Sub
Picture1.Visible = False
End If
SetWin ctCapWin, es_Size
End Sub

Private Sub SetCaption(Optional nCap As String)
If nCap <> “” Then Me.Tag = Trim(nCap)
If IsFillScreen Then '全屏方式
Me.Caption = “”
Else '窗口方式
If Me.Tag = “” Then Me.Caption = “摄像头控制” Else Me.Caption = "摄像头控制 - " & Me.Tag
End If
End Sub

Private Sub Check1_Click(Index As Integer)
Dim nTag As String, TF As Boolean

If Not ctRefresh Then Exit Sub
nTag = Check1(Index).Tag: TF = Check1(Index).Value = 1
Select Case LCase(nTag)
Case LCase(“AutoSize”)
ctAutoSize = TF
SendMessage ctCapWin, WM_CAP_SET_Scale, ctAutoSize, 0 '预览图像随窗口自动缩放
Call SetWin(ctCapWin, es_Size)
Case LCase(“AutoHide”)
ctAutoHide = TF
End Select
End Sub

Private Sub Command1_Click(Index As Integer)
Cmd Command1(Index).Tag
End Sub

Private Sub Cmd(nCmd As String)
Select Case LCase(nCmd)
Case LCase(“Connect”): Call CapConnect ’ 连接摄像头
Case LCase(“DisConnect”): ctConnect = False: SendMessage ctCapWin, WM_CAP_DisConnect, 0, 0 '断开摄像头连接

Case LCase(“VideoSource”): SendMessage ctCapWin, WM_CAP_DLG_VideoSource, 0, 0 '对话框：视频源
Case LCase(“VideoFormat”): SendMessage ctCapWin, WM_CAP_DLG_VideoFormat, 0, 0: Call SetWin(ctCapWin, es_Size) '显示对话框：视频格式,分辨率
Case LCase(“VideoDisplay”): SendMessage ctCapWin, WM_CAP_DLG_VideoDisplay, 0, 0 '对话框：视频显示。某些显卡不支持？

Case LCase(“SetDir”): Call SetDir
Case LCase(“SetFile”): Call SetFile
Case LCase(“VideoCompression”): SendMessage ctCapWin, WM_CAP_DLG_VideoCompression, 0, 0 '对话框：视频压缩
Case LCase(“Record”): Call StartRecord
Case LCase(“NoRecord”): Call NoRecord

Case LCase(“CopyImg”): Clipboard.Clear: SendMessage ctCapWin, WM_CAP_Edit_Copy, 0, 0 '将当前图像复制到剪贴板
Case LCase(“FillScreen”): Call FillScreen
Case LCase("")
Case LCase("")
Case LCase("")
Case LCase(“Exit”): Unload Me: Exit Sub
End Select
Call KjEnabled(True)
End Sub

Public Sub FillScreen()
'全屏切换
IsFillScreen = Not IsFillScreen
Picture1.Visible = Not IsFillScreen
If IsFillScreen Then Me.BorderStyle = 0 Else Me.BorderStyle = 2
Call SetCaption

If IsFillScreen Then '全屏方式
Me.WindowState = 2
Check1(KjIndex(Check1, “AutoSize”)).Value = 1 '切换到：视频窗口随主窗口自动改变大小
Else '窗口方式
Me.WindowState = 0
Call WinCenter '窗口居中
End If
Check1(KjIndex(Check1, “AutoSize”)).Enabled = Not IsFillScreen
End Sub

Private Sub WinCenter()
'窗口居中
Dim W As Long, H As Long
W = 650 * Screen.TwipsPerPixelX: H = 560 * Screen.TwipsPerPixelY
Me.Move (Screen.Width - W) * 0.5, (Screen.Height - H) * 0.5, W, H '窗口居中
End Sub

Private Sub VideoSize(W As Long, H As Long)
'获取视频的大小尺寸
Dim nInf As BitMapInfo
SendMessage ctCapWin, WM_CAP_Get_VideoFormat, Len(nInf), nInf
W = nInf.bmiHeader.biWidth: H = nInf.bmiHeader.biHeight
End Sub

Private Function AddKj(Kj As Object, nCap As String, Optional nTag As String, Optional nNote As String) As Control
'装载一个数组控件
Dim I As Long

I = Kj.UBound
If Kj(I).Tag <> “” Then I = I + 1: Load Kj(I)
On Error Resume Next
Kj(I).Caption = nCap
If nTag = “” Then Kj(I).Tag = Kj(I).Name & “-” & I Else Kj(I).Tag = nTag
Kj(I).ToolTipText = nNote
Set AddKj = Kj(I)
End Function

Private Sub ListKj(Kj As Object, L As Long)
'排列数组控件
Dim I As Long, H1 As Long, T As Long, W As Long

H1 = Picture1.TextHeight(“A”): T = H1 * 0.25: W = H1 * 2
For I = Kj.lBound To Kj.UBound
If Kj(I).Caption = “-” Then
L = L + H1: Kj(I).Visible = False
Else
Kj(I).Move L, T, W, W: Kj(I).Visible = True
L = L + W
End If
Next
End Sub

Private Function KjIndex(Kj As Object, nTag As String) As Long
Dim I As Long
For I = Kj.lBound To Kj.UBound
If LCase(Kj(I).Tag) = LCase(nTag) Then KjIndex = I: Exit Function
Next
KjIndex = -1
End Function

Private Sub KjEnabled(Optional nEnabled As Boolean)
Dim Kj, TF As Boolean, nType As String
On Error Resume Next
For Each Kj In Me.Controls
nType = LCase(TypeName(Kj))
If nType = “commandbutton” Or nType = “checkbox” Then
Kj.Enabled = nEnabled
End If
Next

Command1(KjIndex(Command1, “FillScreen”)).Enabled = True
Command1(KjIndex(Command1, “Exit”)).Enabled = True
Check1(KjIndex(Check1, “AutoSize”)).Enabled = Not IsFillScreen
If Not nEnabled Then Exit Sub

TF = ctConnect
If ctRec Then TF = False

Command1(KjIndex(Command1, “Connect”)).Enabled = Not TF
Command1(KjIndex(Command1, “DisConnect”)).Enabled = TF '按钮在摄像头连接状态才可用

Command1(KjIndex(Command1, “VideoSource”)).Enabled = TF
Command1(KjIndex(Command1, “VideoFormat”)).Enabled = TF
Command1(KjIndex(Command1, “VideoDisplay”)).Enabled = TF

Command1(KjIndex(Command1, “VideoCompression”)).Enabled = TF
Command1(KjIndex(Command1, “Record”)).Enabled = TF
Command1(KjIndex(Command1, “NoRecord”)).Enabled = TF
Command1(KjIndex(Command1, “CopyImg”)).Enabled = TF

If Not ctRec Then Exit Sub
Command1(KjIndex(Command1, “Record”)).Enabled = False
Command1(KjIndex(Command1, “NoRecord”)).Enabled = True
Command1(KjIndex(Command1, “SetFile”)).Enabled = False
Command1(KjIndex(Command1, “SetDir”)).Enabled = False
End Sub

Private Sub CreateCapWin()
'创建视频窗口
Dim nStyle As Long, S As Long
Dim lpszName As String * 128
Dim lpszVer As String * 128

Do
If Not capGetDriverDescriptionA(S, lpszName, 128, lpszVer, 128) Then Exit Do '获得驱动程序名称和版本信息
S = S + 1
Loop
nStyle = WS_Child + WS_Visible '+ WS_Caption + WS_ThickFrame '子窗口+可见+标题栏+边框
If ctCapWin <> 0 Then Exit Sub
ctCapWin = capCreateCaptureWindow(“我创建的视频窗口”, nStyle, 0, 0, 640, 480, Me.hwnd, 0)
If ctCapWin = 0 Then Exit Sub
SetWin ctCapWin, es_Move, 0, Command1(0).Top + Command1(0).Height * 1.2, 640, 480
End Sub

Private Sub CapConnect()
Dim D As Long
'打开摄像头
D = SendMessage(ctCapWin, WM_CAP_Connect, 0, 0) '连接一个视频驱动，成功返回真(1)

SendMessage ctCapWin, WM_CAP_SET_Scale, ctAutoSize, 0 '预览图像随窗口自动缩放
SendMessage ctCapWin, WM_CAP_SET_PreViewRate, 30, 0 '设置预览显示频率
SendMessage ctCapWin, WM_CAP_SET_PreView, 1, 0 '第三个参数：1-预览模式有效,0-预览模式无效
ctConnect = True
Call SetWin(ctCapWin, es_Size) '调整视频窗口为正确的大小
End Sub

Private Sub SetWin(hWnds As Long, nSet As enWinSet, Optional ByVal L As Long, Optional ByVal T As Long, Optional ByVal W As Long, Optional ByVal H As Long)
Dim hWndZOrder As Long, wFlags As Long

If hWnds = 0 Then Exit Sub
Select Case nSet
Case es_Close: SendMessage hWnds, WM_Close, 0, 0: Exit Sub
Case es_Hide: wFlags = SWP_NoMove + SWP_NoSize + SWP_NoZorder + SWP_HideWindow '隐藏
Case es_Show: hWndZOrder = HWND_Top: wFlags = SWP_NoSize + SWP_ShowWindow '显示
Case es_Move
hWndZOrder = HWND_Top: wFlags = SWP_NoActivate + SWP_NoSize
Case es_Size
hWndZOrder = HWND_Top: wFlags = SWP_NoActivate
'录像状态下改变视频窗口大小，有时会出现莫名其妙的错误
If ctRec Then wFlags = wFlags + SWP_NoSize
L = 0
If Picture1.Visible Then T = Picture1.Height
If ctAutoSize Then
W = Me.ScaleWidth - L
If H = 1 Then H = Me.ScaleHeight Else H = Me.ScaleHeight - T
Else
Call VideoSize(W, H) '获取视频的实际大小
End If
If W < 20 Or H < 20 Then Exit Sub
End Select

SetWindowPos hWnds, hWndZOrder, L, T, W, H, wFlags
End Sub

Private Sub ReadSaveSet(Optional IsSave As Boolean)
Dim nPath As String, nSub As String
nPath = “摄像头控制”: nSub = “UserSet”
If IsSave Then
SaveSetting nPath, nSub, “AutoSize”, ctAutoSize
SaveSetting nPath, nSub, “AutoHide”, ctAutoHide
SaveSetting nPath, nSub, “Path”, ctDir
SaveSetting nPath, nSub, “File”, ctF
Else
ctAutoSize = GetSetting(nPath, nSub, “AutoSize”, “False”)
ctAutoHide = GetSetting(nPath, nSub, “AutoHide”, “False”)
ctDir = GetSetting(nPath, nSub, “Path”, “”)
ctF = GetSetting(nPath, nSub, “File”, “”)
End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
'停止摄像头。一般情况，如果母窗体关闭，子窗体就会自动释放。下面两句代码是否可省？
If ctRec Then Call NoRecord
Cmd “DisConnect” '断开摄像头连接
SetWin ctCapWin, es_Close
Call ReadSaveSet(True) '保存用户设置
End Sub

Private Function CutPathFile(nStr As String, nPath As String, nFile As String)
'分解出文件和目录
Dim I As Long, S As Long

For I = 1 To Len(nStr)
If Mid(nStr, I, 1) = “” Then S = I '查找最后一个目录分隔符
Next
If S > 0 Then
nPath = Left(nStr, S): nFile = Mid(nStr, S + 1)
Else
nPath = “”: nFile = nStr
End If
End Function

Private Function MakePath(ByVal nPath As String) As Boolean
'逐级建立目录,成功返回 T
Dim I As Long, Path1 As String, IsPath As Boolean
nPath = Trim(nPath)
If Right(nPath, 1) <> “” Then nPath = nPath & “”
On Error GoTo Exit1
For I = 1 To Len(nPath)
If Mid(nPath, I, 1) = “” Then
Path1 = Left(nPath, I - 1)
If Dir(Path1, 23) = “” Then
MkDir Path1
Else
IsPath = GetAttr(Path1) And 16
If Not IsPath Then Exit Function '有一个同名的文件
End If
End If
Next
MakePath = True: Exit Function
Exit1:
End Function