Visual Basic - Mover mouse con punto de luz

Life is soft - evento anual de software empresarial
 
Vista:

Mover mouse con punto de luz

Publicado por berck (1 intervención) el 29/09/2010 01:10:44
Hola, estoy programando en Visual Basic 6 un software el cual mediante una webcam y un punto de luz hace mover el mouse por la pantalla.
Mi problema es que necesito transformar las coordenadas de un PictureBox a las coordenadas de la pantalla y ademas hacer que me capture ese punto de luz mas rapido...

Os dejo el codigo a ver si me hechais una mano...

' MODULO
' ########

Option Explicit
' declaraciones Api, constantes, variables
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Const ws_child = &H40000000
Public Const ws_visible = &H10000000
Public Const WM_USER = 1024
Public Const wm_cap_driver_connect = WM_USER + 10
Public Const wm_cap_set_preview = WM_USER + 50
Public Const WM_CAP_SET_PREVIEWRATE = WM_USER + 52
Public Const WM_CAP_DRIVER_DISCONNECT = WM_USER + 11
Public Const WM_CAP_DLG_VIDEOFORMAT = WM_USER + 41
Public Const WM_CAP_DLG_VIDEOCONFIG = WM_USER + 42
Public Const WM_CAP_SET_SCALE = WM_USER + 53
Public Const WM_CAP_EDIT_COPY = WM_USER + 30

'Api para crear la ventana de captura
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, _
lParam As Any) As Long

Public Declare Function DestroyWindow Lib "user32" (ByVal hndw As Long) As Boolean
'Solo 16 Bits (vb2, vb3 y vb4 de 16)
'Declare Function SendMessage Lib "User" ( _
ByVal hWnd As Integer, _
ByVal wMsg As Integer, _
ByVal wParam As Integer, _
lParam As Any) As Long
'Api para crear la ventana de captura
'Declare Function capCreateCaptureWindow Lib "avicap.dll" ( _
ByVal lpszWindowName As String, _
ByVal dwStyle As Long, _
ByVal x As Integer, _
ByVal y As Integer, _
ByVal nWidth As Integer, _
ByVal nHeight As Integer, _
ByVal hwndParent As Integer, _
ByVal nID As Integer) As Long
'Declare Function DestroyWindow Lib "User" (ByVal hndw As Integer) As Integer
Public hwdc As Long
Public startcap As Integer

' FORM
' ######

Option Explicit

Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Private Declare Function GetPixel Lib "gdi32" ( _
ByVal hdc As Long, _
ByVal x As Long, _
ByVal y As Long) As Long


' Declaración de funciones Api
Private Declare Function StretchBlt _
Lib "gdi32" ( _
ByVal hdc As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal hSrcDC As Long, _
ByVal xSrc As Long, _
ByVal ySrc As Long, _
ByVal nSrcWidth As Long, _
ByVal nSrcHeight As Long, _
ByVal dwRop As Long) As Long

Private Declare Function SetStretchBltMode _
Lib "gdi32" ( _
ByVal hdc As Long, _
ByVal nStretchMode As Long) As Long

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject _
Lib "gdi32" ( _
ByVal hdc As Long, _
ByVal hObject As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

Dim Color As Long
Dim temp As Long

Private Sub Form_Load()
Dim temp As Long

Text4.Text = 16579066
Label1.BackColor = Text4.Text

hwdc = capCreateCaptureWindow("CapWindow", ws_child Or ws_visible, _
0, 0, 320, 240, Picture1.hwnd, 0)
If (hwdc <> 0) Then
temp = SendMessage(hwdc, wm_cap_driver_connect, 0, 0)
temp = SendMessage(hwdc, wm_cap_set_preview, 1, 0)
temp = SendMessage(hwdc, WM_CAP_SET_PREVIEWRATE, 30, 0)
temp = SendMessage(hwdc, WM_CAP_SET_SCALE, True, 0)
'esto hace que la imagen recibida por el dispositivo se ajuste
'al tamaño de la ventana de captura (justo lo que yo buscaba)
DoEvents
startcap = True
Else
MsgBox "No hay Camara Web", 48, "Error"
End If

End Sub

Private Sub Picture2_Click()
Text4.Text = Text3.Text
End Sub

Private Sub Timer1_Timer()
Dim x, y As Integer

temp = SendMessage(hwdc, WM_CAP_EDIT_COPY, 1, 0)
ScaleImage Clipboard.GetData, Picture2

' Ponemos el modo de escala en Pixeles
Picture2.ScaleMode = vbPixels
Picture2.DrawWidth = 3

For x = 0 To (Picture2.ScaleWidth) Step 5
For y = 0 To (Picture2.ScaleHeight) Step 5
Color = GetPixel(Picture2.hdc, x, y)
If Color = Text4.Text Then
Call SetCursorPos((x * 2) * 2, (y * 2) * 2)
Text2.Text = x
Text1.Text = y
Exit Sub
End If
Next
Next

End Sub

Private Sub Picture2_MouseMove(Button As Integer, _
Shift As Integer, _
x As Single, y As Single)

'Asinamos el color a la variable Color pasandole _
el Hdc de la ventana que queremos recuperar el color del _
pixel. Luego le indicamos que pixel mediante las coordenadas x e y
Color = GetPixel(Picture2.hdc, x, y)

'Establecemos en el Picture2 el color
Text3.Text = Color
Label1.BackColor = Color

End Sub


'Función que dibuja el archivo grafico seleccionado, en el control Picture1
Public Function ScaleImage(Img As StdPicture, Pic As Object)

Dim PLeft As Long, PTop As Long
Dim ReqWidth As Long, ReqHeight As Long
Dim HScale As Double, VScale As Double
Dim MyScale As Double
Dim ImgWidth As Long
Dim ImgHeight As Long
Dim SourceHDC As Long

'Escala en pixles y Autoredraw para el Picturebox
Pic.ScaleMode = vbPixels
Pic.AutoRedraw = True

'Limpia la imagen
Pic.Cls

' Convierte el valor de Himetric a pixeles
ImgWidth = Me.ScaleX(Img.Width, vbHimetric, vbPixels)
ImgHeight = Me.ScaleY(Img.Height, vbHimetric, vbPixels)

' Escala horizontal y vertical
HScale = Pic.ScaleWidth / ImgWidth
VScale = Pic.ScaleHeight / ImgHeight

MyScale = IIf(VScale >= HScale, HScale, VScale)

ReqWidth = ImgWidth * MyScale
ReqHeight = ImgHeight * MyScale

'Posición izquierda y Arriba, para centra el gráfico: valores x y
PLeft = (Pic.ScaleWidth - ReqWidth) / 2
PTop = (Pic.ScaleHeight - ReqHeight) / 2

SourceHDC = CreateCompatibleDC(0)
DeleteObject SelectObject(SourceHDC, Img.Handle)

SetStretchBltMode Pic.hdc, vbPaletteModeNone

' Si es un ícono usa PaintPicture, si no StretchBlt
If Img.Type = 3 Then
Pic.PaintPicture Img, PLeft, PTop, ReqWidth, ReqHeight
Else
'Copia el gráfico en el PictureBox
StretchBlt Pic.hdc, PLeft, PTop, ReqWidth, ReqHeight, _
SourceHDC, 0, 0, ImgWidth, ImgHeight, vbSrcCopy

'Libera el dispositivo
DeleteDC SourceHDC

End If

End Function


Gracias.
Valora esta pregunta
Me gusta: Está pregunta es útil y esta claraNo me gusta: Está pregunta no esta clara o no es útil
0
Responder