classrodney.cls

vb做的摄像头程序

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "ClassRodney"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Const image_Width = 40
Const image_height = 30

'types of move
Const MOVE_LINEAR = 0

Dim cameraID As Integer

Dim StereoDisparity  As New classImageProcessing
Dim axisPosition(16) As Byte

Dim MoveBufferSize(16) As Integer
Dim MoveBufferStartTick(16) As Integer
Dim MoveBufferStartPosition(16) As Integer
Dim MoveBuffer(16, 20, 3) As Long

Dim hwndc As Long




Private Function Vision_vote(n As Long) As Integer
'Counts the bits in long integer n
  Dim Value As Integer
  Dim power As Long
  Dim i As Integer

  Value = 0
  power = 1
  For i = 0 To 23
    If (n And power) Then
      Value = Value + 1
    End If
    power = power * 2
  Next i
  Vision_vote = Value
End Function



Public Sub Motion_Init(comCtrl As Object, ComPort As Integer)
  comCtrl.Settings = "9600,N,8,1"
  comCtrl.CommPort = ComPort
  comCtrl.PortOpen = True
End Sub

Public Sub Motion_setTargetPos(comCtrl As Object, axis As Integer, Position As Integer)
'position must be between 0 and 254
  If (Position > -1) And (Position < 256) Then
    comCtrl.Output = Chr$(255)
    comCtrl.Output = Chr$(axis)
    comCtrl.Output = Chr$(Position)
    axisPosition(axis) = CByte(Position)
  End If
End Sub

Public Function Motion_getAxisPosition(axis As Integer) As Integer
  Motion_getAxisPosition = axisPosition(axis)
End Function


Public Sub Motion_MoveLinear(comCtrl As Object, frm As Form, axis As Integer, TargetPosition As Integer, TargetTime As Long)
  Call Motion_addMove(axis, TargetPosition, TargetTime, MOVE_LINEAR)
End Sub


Private Sub Motion_addMove(axis As Integer, TargetPosition As Integer, TargetTime As Long, MoveType As Integer)
'adds an item to the move buffer
  If (MoveBufferSize(axis) < 20) Then
    MoveBuffer(axis, MoveBufferSize(axis), 0) = TargetPosition
    MoveBuffer(axis, MoveBufferSize(axis), 1) = TargetTime
    MoveBuffer(axis, MoveBufferSize(axis), 2) = MoveType
    If (MoveBufferSize(axis) = 0) Then
      MoveBufferStartTick(axis) = -1
    End If
    MoveBufferSize(axis) = MoveBufferSize(axis) + 1
    Else
    MsgBox "Move buffer overflow"
  End If
End Sub

Private Sub Motion_moveComplete(axis As Integer)
'a move has been completed - update the buffer
  Dim i As Integer
  
  If (MoveBufferSize(axis) > 0) Then
    For i = 1 To 19
      MoveBuffer(axis, i - 1, 0) = MoveBuffer(axis, i, 0)
      MoveBuffer(axis, i - 1, 1) = MoveBuffer(axis, i, 1)
      MoveBuffer(axis, i - 1, 2) = MoveBuffer(axis, i, 2)
    Next
    MoveBufferStartTick(axis) = -1
    MoveBufferSize(axis) = MoveBufferSize(axis) - 1
  End If
End Sub



Public Sub Motion_Update(comCtrl As Object)
'run this within a timer control
  Dim maxTick As Long
  Dim axis As Integer
  Dim TicksElapsed As Integer
  Dim pos As Integer
  Static Tick As Integer
  Const timer_interval = 40
  
  For axis = 0 To 15
    If (MoveBufferSize(axis) > 0) Then
      If (MoveBufferStartTick(axis) = -1) Then
        MoveBufferStartTick(axis) = Tick
        MoveBufferStartPosition(axis) = axisPosition(axis)
      End If
      maxTick = MoveBuffer(axis, 0, 1) / timer_interval
      If (maxTick > 0) Then
        TicksElapsed = Tick - MoveBufferStartTick(axis)
        If (Tick < MoveBufferStartTick(axis)) Then
          TicksElapsed = ((60000 / timer_interval) - MoveBufferStartTick(axis)) + Tick
        End If
        pos = (((MoveBuffer(axis, 0, 0) - MoveBufferStartPosition(axis)) * (TicksElapsed / maxTick))) + MoveBufferStartPosition(axis)
        Call Motion_setTargetPos(comCtrl, axis, pos)
      End If
      If (TicksElapsed >= maxTick) Then
        'the move is complete
        Call Motion_moveComplete(axis)
      End If
    End If
  Next
  
  Tick = Tick + 1
  If (Tick > 60000 / timer_interval) Then
    Tick = 0
  End If
End Sub


Public Sub Motion_ClearBuffer()
  Dim axis As Integer
  
  For axis = 0 To 15
    MoveBufferSize(axis) = 0
  Next

End Sub


Public Sub Vision_VFWstart(canvas As PictureBox)
'starts VFW
  Dim temp As Long

  hwndc = capCreateCaptureWindow("Rodney Vision", ws_child Or ws_visible, 0, 0, 160, 120, canvas.hWnd, 0)
  If (hwndc <> 0) Then
    temp = SendMessage(hwndc, wm_cap_driver_connect, 0, 0)
    temp = SendMessage(hwndc, wm_cap_set_preview, 1, 0)
    temp = SendMessage(hwndc, WM_CAP_SET_PREVIEWRATE, 30, 0)
    Else
    MsgBox ("Can't open capture window")
  End If
End Sub


Public Sub Vision_VFWFormatDialog()
  Dim temp As Long
  temp = SendMessage(hwndc, WM_CAP_DLG_VIDEOFORMAT, 0&, 0&)
End Sub


Public Sub Vision_VFWgrab(destination As PictureBox)
'grabs a frame to the given picturebox
  Dim temp As Long
  
  temp = SendMessageAsLong(hwndc, WM_CAP_GRAB_FRAME, 0&, 0&)
  temp = SendMessage(hwndc, WM_CAP_EDIT_COPY, 1, 0)
  destination.Picture = Clipboard.GetData
End Sub


Public Sub Vision_CentreOfMotion(canvas As PictureBox, ByRef cx As Integer, ByRef cy As Integer, ByRef motionLevel As Single)
'returns the centre of motion
  Const steps = 40
  Dim X As Integer
  Dim Y As Integer
  Dim sx As Integer
  Dim sy As Integer
  Dim p As Long
  Dim p2 As Long
  Dim xx As Double
  Dim yy As Double
  Dim tot As Double
  Dim rgbsource As RGBthingy
  Dim rgbdest As RGBpoint
  Dim r As Single
  Dim pixels As Long
  
  pixels = steps * steps
  motionLevel = 0
  xx = 0
  yy = 0
  tot = 0
  sx = canvas.ScaleWidth / steps
  sy = canvas.ScaleHeight / steps
  For X = sx To canvas.ScaleWidth - 1 Step sx
    For Y = sy To canvas.ScaleHeight - 1 Step sy
      p = canvas.Point(X - sx, Y - sy)
      rgbsource.Value = p
      Call CopyMemory(rgbdest, rgbsource, 3)
      r = rgbdest.Red
      p = canvas.Point(X, Y)
      rgbsource.Value = p
      Call CopyMemory(rgbdest, rgbsource, 3)
      r = r + rgbdest.Red
      If (r > 200) Then
        motionLevel = motionLevel + r
        'r = r * r
        tot = tot + r
        xx = xx + (X * r)
        yy = yy + (Y * r)
      End If
    Next
  Next
  If (tot > 0) Then
    xx = xx / tot
    yy = yy / tot
    Else
    xx = canvas.ScaleWidth / 2
    yy = canvas.ScaleHeight / 2
  End If
  cx = xx
  cy = yy
  motionLevel = motionLevel / pixels
    
  canvas.FillColor = RGB(255, 0, 0)
  canvas.FillStyle = 0
  canvas.Circle (cx, cy), sx
End Sub


Public Sub Vision_VFWstop()
  Dim temp As Long
  
  temp = SendMessageAsLong(hwndc, WM_CAP_DRIVER_DISCONNECT, 0&, 0&)
End Sub




Public Sub Vision_Motion(inputImage As PictureBox, backgroundImage As PictureBox, motionImage As PictureBox)
'BitBlit motion compare
  Const SRCCOPY = &HCC0020
  Const SRCINVERT = &H660046
  Dim rc As Long
    
  Call Vision_VFWgrab(inputImage)
  rc = BitBlt(motionImage.hDC, 0, 0, inputImage.ScaleWidth, inputImage.ScaleHeight, backgroundImage.hDC, 0, 0, SRCCOPY)
  rc = BitBlt(motionImage.hDC, 0, 0, inputImage.ScaleWidth, inputImage.ScaleHeight, inputImage.hDC, 0, 0, SRCINVERT)

End Sub