|
111
|
Programación / Programación Visual Basic / [Source] Funciones para marcar contornos de una imagen y marcar piel.
|
en: 6 Diciembre 2010, 14:26 pm
|
HOLA!!! EFECTO: Gracias a LEANDRO A pude armar una funcion que convierte una imagen cualquiera a una imagen en ByN puro sin escala de grises marcando solamente los contornos de las cosas. AGREGADO: funcion para pintar las zonas que son piel.Hay una variable "Tolerance" esa la regulan para que sea mas o menos estricto con la deteccion de bordes. Bueno aca el codigo (Modulo): Repito GRACIAS LEA! Option Explicit Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hDC As Long, pBitmapInfo As BITMAPINFO24, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, 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 BitBlt Lib "gdi32" (ByVal hDestDC 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 dwRop 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 Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Ptr() As Any) As Long Private Type RGBQUAD rgbBlue As Byte rgbGreen As Byte rgbRed As Byte rgbReserved As Byte End Type Private Type BITMAPINFOHEADER biSize As Long biWidth As Long biHeight As Long biPlanes As Integer 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 BITMAPINFO24 bmiHeader As BITMAPINFOHEADER bmiColors() As RGBQUAD End Type Private Type SAFEARRAYBOUND cElements As Long lLbound As Long End Type Private Type SAFEARRAY2D cDims As Integer fFeatures As Integer cbElements As Long cLocks As Long pvData As Long Bounds(0 To 1) As SAFEARRAYBOUND End Type Private Const DIB_RGB_COLORS = 0 Private Const BI_RGB = 0& Public Sub BuscarContornos(Pic As PictureBox) Dim BytesPerLine As Long Dim WinDC As Long Dim TmpDC As Long Dim hBmp As Long Dim OldBmp As Long Dim Addrs As Long Dim x As Long Dim y As Long Dim lpBits() As Byte Dim M_BitmapInfo As BITMAPINFO24 Dim SA As SAFEARRAY2D Dim R As Byte, G As Byte, B As Byte, BYN As Byte, Tolerance As Byte Dim ZERO As Integer Dim tmp1 As Integer, tmp2 As Integer, tmp3 As Integer Tolerance = 20 ZERO = 0 BytesPerLine = ScanAlign(Pic.ScaleWidth * 3) With M_BitmapInfo.bmiHeader .biSize = Len(M_BitmapInfo.bmiHeader) .biWidth = Pic.ScaleWidth .biHeight = Pic.ScaleHeight .biPlanes = 1 .biBitCount = 24 .biCompression = BI_RGB .biSizeImage = BytesPerLine * Pic.ScaleHeight End With WinDC = GetDC(0) TmpDC = CreateCompatibleDC(WinDC) hBmp = CreateDIBSection(WinDC, M_BitmapInfo, DIB_RGB_COLORS, Addrs, 0, 0) Call ReleaseDC(0, WinDC) With SA .cbElements = 1 .cDims = 2 .Bounds(0).lLbound = 0 .Bounds(0).cElements = Pic.ScaleHeight .Bounds(1).lLbound = 0 .Bounds(1).cElements = BytesPerLine .pvData = Addrs End With CopyMemory ByVal VarPtrArray(lpBits), VarPtr(SA), 4 OldBmp = SelectObject(TmpDC, hBmp) Call BitBlt(TmpDC, 0, 0, Pic.ScaleWidth, Pic.ScaleHeight, Pic.hDC, 0, 0, vbSrcCopy) For y = 0 To Pic.ScaleHeight - 1 For x = 0 To (Pic.ScaleWidth * 3) - 1 Step 3 B = lpBits(x + 2, y) G = lpBits(x + 1, y) R = lpBits(x, y) 'ZERO ES PARA QUE NO HAGA DESBORDAMIENTO BYN = Int((ZERO + R + G + B) / 3) 'DIBUJA EN BLANCO Y NEGRO lpBits(x, y) = BYN lpBits(x + 1, y) = BYN lpBits(x + 2, y) = BYN If x <> 0 And y <> 0 Then tmp1 = lpBits(x - 1, y - 1) tmp2 = lpBits(x - 1, y) tmp3 = lpBits(x, y - 1) If Abs(tmp2 - tmp1) > Tolerance Or Abs(tmp3 - tmp1) > Tolerance Then lpBits(x - 1, y - 1) = 0 lpBits(x - 2, y - 1) = 0 lpBits(x - 3, y - 1) = 0 Else 'PINTA DE NEGRO EL PIXEL POR QUE AHI HAY UN BORDE lpBits(x - 1, y - 1) = 255 lpBits(x - 2, y - 1) = 255 lpBits(x - 3, y - 1) = 255 End If End If Next x Next y CopyMemory ByVal VarPtrArray(lpBits), 0&, 4 Call BitBlt(Pic.hDC, 0, 0, Pic.ScaleWidth, Pic.ScaleHeight, TmpDC, 0, 0, vbSrcCopy) Call DeleteObject(SelectObject(TmpDC, OldBmp)) Call DeleteDC(TmpDC) End Sub Public Sub BuscarPiel(Pic As PictureBox) Dim BytesPerLine As Long Dim WinDC As Long Dim TmpDC As Long Dim hBmp As Long Dim OldBmp As Long Dim Addrs As Long Dim x As Long Dim y As Long Dim lpBits() As Byte Dim M_BitmapInfo As BITMAPINFO24 Dim SA As SAFEARRAY2D Dim R As Byte, G As Byte, B As Byte, BYN As Byte, Tolerance As Byte Dim ZERO As Integer Dim tmp1 As Integer, tmp2 As Integer, tmp3 As Integer Tolerance = 20 ZERO = 0 BytesPerLine = ScanAlign(Pic.ScaleWidth * 3) With M_BitmapInfo.bmiHeader .biSize = Len(M_BitmapInfo.bmiHeader) .biWidth = Pic.ScaleWidth .biHeight = Pic.ScaleHeight .biPlanes = 1 .biBitCount = 24 .biCompression = BI_RGB .biSizeImage = BytesPerLine * Pic.ScaleHeight End With WinDC = GetDC(0) TmpDC = CreateCompatibleDC(WinDC) hBmp = CreateDIBSection(WinDC, M_BitmapInfo, DIB_RGB_COLORS, Addrs, 0, 0) Call ReleaseDC(0, WinDC) With SA .cbElements = 1 .cDims = 2 .Bounds(0).lLbound = 0 .Bounds(0).cElements = Pic.ScaleHeight .Bounds(1).lLbound = 0 .Bounds(1).cElements = BytesPerLine .pvData = Addrs End With CopyMemory ByVal VarPtrArray(lpBits), VarPtr(SA), 4 OldBmp = SelectObject(TmpDC, hBmp) Call BitBlt(TmpDC, 0, 0, Pic.ScaleWidth, Pic.ScaleHeight, Pic.hDC, 0, 0, vbSrcCopy) For y = 0 To Pic.ScaleHeight - 1 For x = 0 To (Pic.ScaleWidth * 3) - 1 Step 3 R = lpBits(x + 2, y) G = lpBits(x + 1, y) B = lpBits(x, y) 'ZERO ES PARA QUE NO HAGA DESBORDAMIENTO BYN = Int((ZERO + R + G + B) / 3) 'DIBUJA EN BLANCO Y NEGRO If R > 168 And G > 134 And B > 94 And R < 250 And G < 235 And B < 215 Then ' LOS PROXIMOS 3 VALORES ESPECIFICAN EL COLOR CON EL QUE SE VA A PINTAR lpBits(x, y) = 0 lpBits(x + 1, y) = 255 lpBits(x + 2, y) = 255 Else lpBits(x, y) = 0 ' BYN lpBits(x + 1, y) = 0 'BYN lpBits(x + 2, y) = 0 'BYN End If Next x Next y CopyMemory ByVal VarPtrArray(lpBits), 0&, 4 Call BitBlt(Pic.hDC, 0, 0, Pic.ScaleWidth, Pic.ScaleHeight, TmpDC, 0, 0, vbSrcCopy) Call DeleteObject(SelectObject(TmpDC, OldBmp)) Call DeleteDC(TmpDC) End Sub Private Function ScanAlign(WidthBmp As Long) As Long ScanAlign = (WidthBmp + 3) And &HFFFFFFFC End Function
Para llamar la funcion: Private Sub Command1_Click() 'ESTO PARA CONTORNOS BuscarContornos PicTratamiento 'ESTO PARA PIEL BuscarPiel PicTratamiento PicTratamiento.Refresh End Sub Private Sub Form_Load() PicTratamiento.AutoRedraw = True PicTratamiento.ScaleMode = vbPixels End Sub
P.D: El de la foto soy yo asi que no puteen. GRACIAS POR LEER!!!
|
|
|
112
|
Programación / Programación Visual Basic / [Ayuda]Reconocer contornos Picturebox
|
en: 3 Diciembre 2010, 16:14 pm
|
HOLA!!! Como andan?, hoy tengo una duda, estoy intentando encontrar los contornos de los objetos de una foto(en un picturebox) logre armar algo buscando en google, pero es muy inpresiso. La imagen se trata en un Picturebox chico asi no tarda mucho, sino se come el procesador. Si encuentran algo o ven algo en mi codigo avisenme. Bueno, les dejo mi codigo para que lo vean. Esto va en un modulo y en el Form1 ponen un picturebox con una imagen (chica ) hacen un call a la funcion y listo. Public color As Long Public ElR As Byte Public ElG As Byte Public ElB As Byte Dim P12 As Integer, P21 As Integer, P22 As Integer Public Sub RGBdelPixel(x As Integer, y As Integer) color = Form1.PicTratamiento.Point(x - 1, y) ElB = (color \ 65536) And &HFF ElG = (color \ 256) And &HFF ElR = color And &HFF P12 = (70! * ElR + 150! * ElG + 29! * ElB) / 255 color = Form1.PicTratamiento.Point(x, y - 1) ElB = (color \ 65536) And &HFF ElG = (color \ 256) And &HFF ElR = color And &HFF P21 = (70! * ElR + 150! * ElG + 29! * ElB) / 255 color = Form1.PicTratamiento.Point(x, y) ElB = (color \ 65536) And &HFF ElG = (color \ 256) And &HFF ElR = color And &HFF P22 = (70! * ElR + 150! * ElG + 29! * ElB) / 255 End Sub Public Sub Contornos() Dim AltUrA As Integer, lArgO As Integer, color As Integer Dim i As Integer, j As Integer Form1.PicTratamiento.ScaleMode = 3 AltUrA = Form1.PicTratamiento.ScaleHeight lArgO = Form1.PicTratamiento.ScaleWidth tolerancia = 100 For i = 1 To lArgO - 1 For j = 1 To AltUrA - 1 RGBdelPixel i, j If Abs(P12 - P22) > tolerancia Or Abs(P21 - P22) > tolerancia Then Form1.PicTratamiento.PSet (i, j) ', RGB(P22, P22, P22) Else Form1.PicTratamiento.PSet (i, j), vbWhite End If Next Next Form1.PicTratamiento.ScaleMode = 1 End Sub
GRACIAS POR LEER!!!
|
|
|
113
|
Programación / Programación Visual Basic / [Juego] Tragamonedas.
|
en: 5 Noviembre 2010, 18:49 pm
|
HOLA!!! Hola, hoy les traigo un tragamonedas, lo programe hoy asi que puede ser que tenga algun que otro bug, digan si encuentran . Es asi: El codigo: Private tabla(15) As Byte Private DETENER As Boolean Private LINEAS As Byte Private MONEDAS As Boolean Private DINERO As Double Private DIB2(15) As Byte 'REPRESENTA LOS DIBUJOS EN CODIGO Private BASE(3) As Integer Dim CODIGO As String Dim LIN As String Dim DIN As Integer Dim RESTA As Byte Private Sub Form_Load() LINEAS = 1 DINERO = 100 MONEDAS = False Dim x As Byte For x = 1 To 5 tabla(x) = x If x >= 2 Then tabla(x + 4) = x If x >= 3 Then tabla(x + 7) = x If x >= 4 Then tabla(x + 9) = x Next tabla(15) = 5 End Sub Private Sub Go_Click() Dim AP As Byte ' apuesta AP = LINEAS If MONEDAS = True Then AP = LINEAS * 2 If AP <= DINERO Then Girar.Interval = 30 STOPTIM.Interval = 1000 Go.Enabled = False Else MsgBox "Estas apostando mas de lo que tienes", , "Atencion" End If End Sub Private Sub Girar_Timer() Randomize Dim x As Byte Dim VUELTA As Byte ' REPRESENTA LA CANTIDAD DE VECES QUE MANDO UN DIBUJO ARRIBA For x = 0 To 14 DIB1(x).Top = DIB1(x).Top + 150 If DIB1(x).Top >= 2430 Then VUELTA = VUELTA + 1 DIB1(x).Top = -1330 If DETENER = True Then Girar.Interval = 0 RAN = tabla(1 + Int(Rnd() * 14)) DIB1(x).Picture = LoadPicture(App.Path & "/Images/T (" & RAN & ").jpg") DIB2(x) = RAN BASE(VUELTA) = x - 1 If BASE(VUELTA) = -1 Then BASE(VUELTA) = 4 If BASE(VUELTA) = 4 Then BASE(VUELTA) = 9 If BASE(VUELTA) = 9 Then BASE(VUELTA) = 14 End If Next VUELTA = 0 If DETENER = True And Girar.Interval = 0 Then DETENER = False Call Calcular End If End Sub Private Sub MAS_Click() LBLLIN.Caption = Trim(Str(Val(Mid(LBLLIN.Caption, 1, 1)) + 1)) & " LINEAS" If LBLLIN.Caption = "6 LINEAS" Then LBLLIN.Caption = "5 LINEAS" LINEAS = Str(Val(Mid(LBLLIN.Caption, 1, 1))) End Sub Private Sub MENOS_Click() LBLLIN.Caption = Trim(Str(Val(Mid(LBLLIN.Caption, 1, 1)) - 1)) & " LINEAS" If LBLLIN.Caption = "0 LINEAS" Then LBLLIN.Caption = "1 LINEA" If LBLLIN.Caption = "1 LINEAS" Then LBLLIN.Caption = "1 LINEA" LINEAS = Str(Val(Mid(LBLLIN.Caption, 1, 1))) End Sub Private Sub Option1_Click(Index As Integer) MONEDAS = False If Index = 1 Then MONEDAS = True End Sub Private Sub STOPTIM_Timer() STOPTIM.Interval = 0 StopX.Enabled = True End Sub Private Sub StopX_Click() DETENER = True Go.Enabled = True StopX.Enabled = False End Sub Private Sub Calcular() CODIGO = "" DIN = 0 'HORIZONTALES For x = 0 To 2 If x = 0 Then CODIGO = CODIGO & DIB2(BASE(1) - x) & DIB2(BASE(2) - x) & DIB2(BASE(3) - x) ElseIf x = 1 Then If BASE(1) = 0 Then CODIGO = DIB2(4) & DIB2(9) & DIB2(14) & CODIGO Else CODIGO = DIB2(BASE(1) - x) & DIB2(BASE(2) - x) & DIB2(BASE(3) - x) & CODIGO End If ElseIf x = 2 Then If BASE(1) = 0 Then CODIGO = CODIGO & DIB2(3) & DIB2(8) & DIB2(13) ElseIf BASE(1) = 1 Then CODIGO = CODIGO & DIB2(4) & DIB2(9) & DIB2(14) Else CODIGO = CODIGO & DIB2(BASE(1) - x) & DIB2(BASE(2) - x) & DIB2(BASE(3) - x) End If End If Next 'DIAGONAL 1 If BASE(1) = 0 Then CODIGO = CODIGO & DIB2(3) & DIB2(9) & DIB2(10) ElseIf BASE(1) = 1 Then CODIGO = CODIGO & DIB2(4) & DIB2(5) & DIB2(11) ElseIf BASE(1) = 2 Then CODIGO = CODIGO & DIB2(0) & DIB2(6) & DIB2(12) ElseIf BASE(1) = 3 Then CODIGO = CODIGO & DIB2(1) & DIB2(7) & DIB2(13) ElseIf BASE(1) = 4 Then CODIGO = CODIGO & DIB2(2) & DIB2(8) & DIB2(14) End If 'DIAGONAL 2 If BASE(1) = 0 Then CODIGO = CODIGO & DIB2(0) & DIB2(9) & DIB2(13) ElseIf BASE(1) = 1 Then CODIGO = CODIGO & DIB2(1) & DIB2(5) & DIB2(14) ElseIf BASE(1) = 2 Then CODIGO = CODIGO & DIB2(2) & DIB2(6) & DIB2(10) ElseIf BASE(1) = 3 Then CODIGO = CODIGO & DIB2(3) & DIB2(7) & DIB2(11) ElseIf BASE(1) = 4 Then CODIGO = CODIGO & DIB2(4) & DIB2(8) & DIB2(12) End If For x = 0 To LINEAS - 1 LIN = Mid(CODIGO, x * 3 + 1, 3) If LIN = "111" Then DIN = DIN + 2000 If LIN = "222" Then DIN = DIN + 200 If LIN = "333" Then DIN = DIN + 50 If LIN = "444" Then DIN = DIN + 30 If LIN = "555" Then DIN = DIN + 10 Dim Y As Byte If Not LIN = "555" And (Mid(LIN, 1, 2) = "55" Or Mid(LIN, 2, 2) = "55") Then DIN = DIN + 5 Next If MONEDAS = True Then DIN = DIN * 2 RESTA = LINEAS If MONEDAS = True Then RESTA = LINEAS * 2 DINERO = DINERO + DIN - RESTA lbldin.Caption = "$ " & DINERO End Sub
Source con el ejecutable: Descargar URL: http://www.gigasize.com/get.php?d=mkrb3z3ylybMirror: http://hotfile.com/dl/80628928/841f839/Tragamonedas.rar.htmlGRACIAS POR LEER!!!
|
|
|
114
|
Programación / Programación Visual Basic / [Solucionado] Proyecto Reconocimiento facial. Donde Empezar.
|
en: 7 Octubre 2010, 14:27 pm
|
HOLA!!!
Hoy vengo con algo medio ambicioso para vb6, creo que el programa no da para hacer una rutina rápida y a la vez fiable de reconocimiento de Rostros.
Ni empece con el código, es solo un proyecto que quisiera hacer, pero no se ni por donde empezar.
Según lo que tengo visto tendría que hacerlo en C pelado por su velocidad pero el tema es que este lenguaje lo se leer y programar cosas muy simples, ni hablar hacer un llamado a la webcam y demás.
Si alguien quiere sumarse por favor avise y vemos como hacemos.
Lo que se me había ocurrido era un programa en VB6 que maneje las bases de datos y que cada vez que quiera hacer un reconocimiento envié un comando a un programa en C el cual analizaría el Rostro y enviaría un integer que correspondería al numero del rostro analizado al programa en VB6 que mostraría todo lindo.
En definitiva donde buscar info, lo que hay en Google es o muy complejo o muy basico; y por supuesto si alguien quiere ayudar con el tema.
Espero respuestas y opiniones.
GRACIAS POR LEER!!!
|
|
|
116
|
Programación / Programación Visual Basic / [Juego] Bah broma informatica. Lean adentro por que es larga la descripcion.
|
en: 1 Octubre 2010, 19:04 pm
|
HOLA!!! Este codigo lo hice tambien cuando era mas chico. Lo que hace el programa es: 1- minimiza todo 2- saca una foto del escritorio 3- la guarda 4- la establece como fondo de escritorio 5- oculta los iconos 6- espera el tiempo en el timer4 y muestra los iconos de nuevo. Es en definitiva para reirse un poco. timer1 con intervalo 1 timer3 con intervalo 800 timer4 con intervalo 60000 'Función Api FindWindowEx Private Declare Function FindWindowEx Lib "user32" _ Alias "FindWindowExA" (ByVal hWnd1 As Long, _ ByVal hWnd2 As Long, ByVal lpsz1 As String, _ ByVal lpsz2 As String) As Long 'Función Api ShowWindow Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, _ ByVal nCmdShow As Long) As Long 'Constantes para ocultar y mostrar los iconos del escritorio Const SW_SHOW = 5 Const SW_HIDE = 0 'Api para generar un evento de Print Screen Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, _ ByVal dwFlags As Long, ByVal dwExtraInfo As Long) Private Declare Function CAMBIOESC Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long Public X As Integer Public F As Integer Public Y As Integer 'recibe la ruta donde crear el BMP '''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub MINIMIZAR() 'Constantes Const KEYEVENTF_KEYUP = &H2 Const VK_LWIN = &H5B Call keybd_event(VK_LWIN, 0, 0, 0) Call keybd_event(77, 0, 0, 0) Call keybd_event(VK_LWIN, 0, KEYEVENTF_KEYUP, 0) End Sub Private Sub Capturar_Guardar(Path As String) ' borra el portapapeles Clipboard.Clear ' Manda la pulsación de teclas para capturar la imagen de la pantalla Call keybd_event(44, 2, 0, 0) DoEvents ' Si el formato del clipboard es un bitmap If Clipboard.GetFormat(vbCFBitmap) Then 'Guardamos la imagen en disco SavePicture Clipboard.GetData(vbCFBitmap), Path End If End Sub Private Sub CAMBIOESCRITORIO() Dim CAMBIO As Integer CAMBIO = CAMBIOESC(20, 0, "c:\pantalla.bmp", 0) End Sub Private Sub Form_Load() X = 0 F = 0 End Sub Private Sub Timer1_Timer() If X = 0 Then Call MINIMIZAR X = 1 End If End Sub Private Sub Timer3_Timer() Call Capturar_Guardar("c:\pantalla.bmp") If F = 0 Then Call CAMBIOESCRITORIO Dim Ret As Long On Error Resume Next 'Obtenemos el Hwnd del escritorio pasandole el nombre de la clase de ventana, en este caso Progman es el escritorio Ret = FindWindowEx(0&, 0&, "Progman", vbNullString) 'Ocultamos los iconos pasandole a ShowWindow el Hwnd del escritorio ShowWindow Ret, SW_HIDE F = 1 End If End Sub Private Sub Timer4_Timer() 'Para Mostrar los iconos Dim Ret As Long On Error Resume Next 'Obtenemos el Hwnd del escritorio Ret = FindWindowEx(0&, 0&, "Progman", vbNullString) 'Mostramos los iconos pasandole el Hwnd del escritorio ShowWindow Ret, SW_SHOW MsgBox "JAJAJAJA" Unload Me End Sub
Descargar URL: http://www.gigasize.com/get.php?d=qmqpdwynqzbMirror: http://hotfile.com/dl/73058161/c66defd/PSEUDO_ESCRITORIO.rar.htmlP.D: Me voy, suerte, hasta el lunes. GRACIAS POR LEER!!!
|
|
|
119
|
Programación / Programación Visual Basic / [Mini Aporte] BASICO Codigo para Cambiar Proxies del iexplore
|
en: 29 Septiembre 2010, 13:38 pm
|
HOLA!!! Bueno, aca abajo esta como cambiar los proxies del iexplore por el registro. Solamente tenes que cargar el Vector "Proxy()" y enviar la variable "NumProx" que vendria a ser el numero de proxy en la lista. Use este codigo en un programa que servia para hacer clicks automaticos en google cada un intervalo aleatorio de segundos para subir el G.Analytics. (o como se escriba). No es un codigo grande, pero me ayudo en su momento, por ahi les puede servir. Igual, obvio que este post no va dedicado a un nivel alto. Pero si quieren que corrija algo avisen. Public NumProx as integer Private Sub Form_Unload(Cancel As Integer) Dim strProxyServer ' define el proxy y el puerto si es necesario strProxyServer = "" ' ubicacion en la registry Dim strRegPath strRegPath = "HKCU\Software\Microsoft\Windows\CurrentVersion\Internet Settings\" Set oWshShell = CreateObject("WScript.Shell") ' modifica las entradas en el registro Call oWshShell.RegWrite(strRegPath & "ProxyEnable", "00000001", "REG_DWORD") Call oWshShell.RegWrite(strRegPath & "ProxyOverride", "<local>", "REG_SZ") Call oWshShell.RegWrite(strRegPath & "ProxyServer", strProxyServer, "REG_SZ") ' destroy Set oWshShell = Nothing End Sub Private Sub PROXYCHANGE() Dim strProxyServer ' define el proxy y el puerto si es necesario strProxyServer = PROXY(numProx) ' ubicacion en la registry Dim strRegPath strRegPath = "HKCU\Software\Microsoft\Windows\CurrentVersion\Internet Settings\" Set oWshShell = CreateObject("WScript.Shell") ' modifica las entradas en el registro Call oWshShell.RegWrite(strRegPath & "ProxyEnable", "00000001", "REG_DWORD") Call oWshShell.RegWrite(strRegPath & "ProxyOverride", "<local>", "REG_SZ") Call oWshShell.RegWrite(strRegPath & "ProxyServer", strProxyServer, "REG_SZ") ' destroy Set oWshShell = Nothing End Sub
GRACIAS POR LEER!!!
|
|
|
|
|
|
|