sp.frm

进销存管理系统,我是个新手,请大家多多帮助哈1

VERSION 5.00
Begin VB.Form sp 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "视频抓取"
   ClientHeight    =   3150
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   4740
   Icon            =   "sp.frx":0000
   LinkTopic       =   "Form2"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3150
   ScaleWidth      =   4740
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton isButton1 
      Caption         =   "抓取视频"
      Height          =   495
      Left            =   3360
      TabIndex        =   2
      Top             =   2640
      Width           =   1335
   End
   Begin 工程1.XPContainer XPContainer1 
      Height          =   2895
      Left            =   0
      TabIndex        =   0
      Top             =   0
      Width           =   3495
      _extentx        =   6165
      _extenty        =   5106
      caption         =   ""
      style           =   1
      Begin VB.PictureBox Picture1 
         BackColor       =   &H00FFC0C0&
         Height          =   2295
         Left            =   0
         ScaleHeight     =   2235
         ScaleWidth      =   2715
         TabIndex        =   1
         Top             =   0
         Width           =   2775
      End
      Begin VB.Timer Timer1 
         Interval        =   10
         Left            =   -120
         Top             =   -120
      End
   End
End
Attribute VB_Name = "sp"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'声明视频
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 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

Private mCapHwnd As Long

Private Const CONNECT As Long = 1034
Private Const DISCONNECT As Long = 1035
Private Const GET_FRame As Long = 1084
Private Const COPY As Long = 1054

'declarations
Dim P() As Long
Dim POn() As Boolean

Dim inten As Integer

Dim i As Integer, j As Integer

Dim Ri As Long, Wo As Long
Dim RealRi As Long

Dim c As Long, c2 As Long

Dim R As Integer, G As Integer, B As Integer
Dim R2 As Integer, G2 As Integer, B2 As Integer

Dim Tppx As Single, Tppy As Single
Dim Tolerance As Integer

Dim RealMov As Integer

Dim Counter As Integer

Private Declare Function GetTickCount Lib "kernel32" () As Long
Dim LastTime As Long

Option Explicit



Private Sub Form_Load()
'set up the visual stuff
  Picture1.Width = 320 * Screen.TwipsPerPixelX
  Picture1.Height = 300 * Screen.TwipsPerPixelY

'Inten is the measure of how many pixels are going to be recognized. I highly dont recommend
'setting it lower than this, i have a 3.0 GHz PC and it starts to lag a little. On this setting,
'every 15th pixel is checked
  inten = 15
'The tolerance of recognizing the pixel change
  Tolerance = 20

  Tppx = Screen.TwipsPerPixelX
  Tppy = Screen.TwipsPerPixelY

  ReDim POn(640 / inten, 480 / inten)
  ReDim P(640 / inten, 480 / inten)

  STARTCAM
End Sub

Private Sub isButton1_Click()

hygl.Image1.Picture = Me.Picture1.Picture
hygl.Show
Unload Me
End Sub

Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  If Button = 1 Then
    STARTCAM
  ElseIf Button = 2 Then
    STOPCAM
  End If
End Sub

Private Sub Timer1_Timer()
'Get the picture from camera.. the main part
  SendMessage mCapHwnd, GET_FRame, 0, 0
  SendMessage mCapHwnd, COPY, 0, 0
  Picture1.Picture = Clipboard.GetData
  Clipboard.Clear

  Ri = 0 'right
  Wo = 0 'wrong

  LastTime = GetTickCount

  For i = 0 To 640 / inten - 1
      For j = 0 To 480 / inten - 1
    'get a point
        c = Picture1.POINT(i * inten * Tppx, j * inten * Tppy)
    'analyze it, Red, Green, Blue
        R = c Mod 256
        G = (c \ 256) Mod 256
        B = (c \ 256 \ 256) Mod 256
        
    'recall what the point was one step before this
        c2 = P(i, j)
        'analyze it
        R2 = c2 Mod 256
        G2 = (c2 \ 256) Mod 256
        B2 = (c2 \ 256 \ 256) Mod 256
        
    'main comparison part... if each R, G and B are somewhat same, then it pixel is same still
    'in a perfect camera and software tolerance should theoretically be 1 but this isnt true...
    If Abs(R - R2) < Tolerance And Abs(G - G2) < Tolerance And Abs(B - B2) < Tolerance Then
    'pixel remained same
      Ri = Ri + 1
    'Pon stores a boolean if the pixel changed or didnt, to be used to detect REAL movement
      POn(i, j) = True
    
    Else
    'Pixel changed
      Wo = Wo + 1
    'make a red dor
      P(i, j) = Picture1.POINT(i * inten * Tppx, j * inten * Tppy)
      Picture1.PSet (i * inten * Tppx, j * inten * Tppy), vbRed
      POn(i, j) = False
    End If
    
    Next j
    
  Next i

    RealRi = 0

  For i = 1 To 640 / inten - 2
    For j = 1 To 480 / inten - 2
    If POn(i, j) = False Then
        'Real movement is simply occuring when all 4 pixels around one pixel changed
        'Simply put, If this pixel is changed and all around it changed too, then this is a real
        'movement
        If POn(i, j + 1) = False Then
            If POn(i, j - 1) = False Then
                If POn(i + 1, j) = False Then
                    If POn(i - 1, j) = False Then
                    RealRi = RealRi + 1
                    Picture1.PSet (i * inten * Tppx, j * inten * Tppy), vbGreen
                    End If
                End If
            End If
        End If
        
    End If
        
        
    Next j
  Next i

'state all statistics

End Sub

Sub STOPCAM()
  DoEvents: SendMessage mCapHwnd, DISCONNECT, 0, 0
  Timer1.Enabled = False
End Sub

Sub STARTCAM()
  mCapHwnd = capCreateCaptureWindow("WebcamCapture", 0, 0, 0, 280, 210, Me.hwnd, 0)
  DoEvents
  SendMessage mCapHwnd, CONNECT, 0, 0
  Timer1.Enabled = True
End Sub

'最初想保存输出图像写了以下代码，但它和程序没有什么关系就把它注释掉了
'i commented just so you can see how its done in case you dont know
'Private Sub Timer2_Timer()
'SavePicture Picture1.Image, "C:\pics\img" & Counter & ".bmp"
'Counter = Counter + 1
'End Sub





Private Sub XPContainer1_GotFocus()

End Sub