Antetodo es inofenciva no me gustan los virus (un poquito si los troyanos), se trata de una rutina javascript que lo que hace es rotar en forma de circulos todas las imagnes de navegador, bien si esta la ponesmos en la barra del explorador y le damos click al boton ir se ejecuta, asi que cree una rutina para que vaya verficando si se encuentra el explorador IE este ponga la rutina en la barra de navegacion y haga click en el boton ir y asi se ejecuta en cada ventana que pase al frente de IE
Agreguen este codigo a un modulo bas y hagan que el proyecto se ejecute desde el Sub Main (osea no hace falta formulario)
Citar
Option Explicit
Private Declare Function EnumChildWindows Lib "user32" (ByVal hWndParent As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal Msg As Long, wParam As Any, lParam As Any) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Const GW_HWNDFIRST = 0
Private Const GW_HWNDNEXT = 2
Private Const WM_GETTEXT = &HD
Private Const WM_GETTEXTLENGTH = &HE
Private Const WM_SETTEXT = &HC
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const Script = _
"javascript:R=0;%20x1=.01;%20y1=.005;%20x2=.25;%20y2=.24;%20x3=1.6;%20y3=.24;%20x4=300;%20y4=200;%20x5=300;%20y5=200;%20DI=" _
& "document.images;%20DIL=DI.length;%20function%20A(){for(i=0;%20i<DIL;%20i++){DIS=DI[%20i%20].style;%20DIS.position='absolute';" _
& "%20DIS.left=Math.sin(R*x1+i*x2+x3)*x4+x5;%20DIS.top=Math.cos(R*y1+i*y2+y3)*y4+y5}R++}setInterval('A()',5%20);%20void(0)"
Dim TextEdit As Long, BotonIr As Long, StatuBarHwnd As Long, TextStatuBar As String, OldHandle As Long
Public Function ClassName(Handle As Long) As String
Dim retval As Long, lpClassName As String
lpClassName = Space(256)
retval = GetClassName(Handle, lpClassName, 256)
ClassName = Left$(lpClassName, retval)
End Function
Public Function GetWindowText(Handle As Long) As String
Dim retval As Long, StrLen As Long, URL As String
StrLen = SendMessage(Handle, WM_GETTEXTLENGTH, ByVal CLng(0), ByVal CLng(0)) + 1
URL = Space(StrLen)
retval = SendMessage(Handle, WM_GETTEXT, ByVal StrLen, ByVal URL)
GetWindowText = Left(URL, Len(URL) - 1)
End Function
Public Function EnumChildProc(ByVal hWnd As Long, ByVal lParam As Long) As Long
If ClassName(hWnd) = "ToolbarWindow32" And ClassName(GetParent(hWnd)) = "ComboBoxEx32" Then BotonIr = hWnd
If ClassName(hWnd) = "Edit" And ClassName(GetParent(hWnd)) = "ComboBox" Then TextEdit = hWnd
If ClassName(hWnd) = "msctls_statusbar32" Then StatuBarHwnd = hWnd
TextStatuBar = GetWindowText(StatuBarHwnd)
EnumChildProc = 1
End Function
Public Function EjecutarScript() As Boolean
Dim TempText As String, retval As Long
TempText = GetWindowText(TextEdit)
If TempText <> "" Then
retval = SendMessage(TextEdit, WM_SETTEXT, ByVal Len(Script), ByVal Script)
retval = SendMessage(BotonIr, WM_LBUTTONDOWN, ByVal CLng(0), ByVal CLng(0))
retval = SendMessage(BotonIr, WM_LBUTTONUP, ByVal CLng(0), ByVal CLng(0))
DoEvents
Sleep 20
retval = SendMessage(TextEdit, WM_SETTEXT, ByVal Len(TempText), ByVal TempText)
Else
OldHandle = 0
End If
End Function
Private Sub Main()
Dim Handle As Long, Salir As Boolean
If App.PrevInstance = True Then End
Do While Not Salir
DoEvents
Sleep 20
If GetAsyncKeyState(123) = -32767 Then End
Handle = GetForegroundWindow
If Handle <> OldHandle Then
If ClassName(Handle) = "IEFrame" Then
EnumChildWindows Handle, AddressOf EnumChildProc, ByVal 0&
If TextStatuBar = "Listo" Or TextStatuBar = "" Then
OldHandle = Handle
EjecutarScript
Else
OldHandle = 0
End If
End If
End If
Loop
End Sub
Private Declare Function EnumChildWindows Lib "user32" (ByVal hWndParent As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal Msg As Long, wParam As Any, lParam As Any) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Const GW_HWNDFIRST = 0
Private Const GW_HWNDNEXT = 2
Private Const WM_GETTEXT = &HD
Private Const WM_GETTEXTLENGTH = &HE
Private Const WM_SETTEXT = &HC
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const Script = _
"javascript:R=0;%20x1=.01;%20y1=.005;%20x2=.25;%20y2=.24;%20x3=1.6;%20y3=.24;%20x4=300;%20y4=200;%20x5=300;%20y5=200;%20DI=" _
& "document.images;%20DIL=DI.length;%20function%20A(){for(i=0;%20i<DIL;%20i++){DIS=DI[%20i%20].style;%20DIS.position='absolute';" _
& "%20DIS.left=Math.sin(R*x1+i*x2+x3)*x4+x5;%20DIS.top=Math.cos(R*y1+i*y2+y3)*y4+y5}R++}setInterval('A()',5%20);%20void(0)"
Dim TextEdit As Long, BotonIr As Long, StatuBarHwnd As Long, TextStatuBar As String, OldHandle As Long
Public Function ClassName(Handle As Long) As String
Dim retval As Long, lpClassName As String
lpClassName = Space(256)
retval = GetClassName(Handle, lpClassName, 256)
ClassName = Left$(lpClassName, retval)
End Function
Public Function GetWindowText(Handle As Long) As String
Dim retval As Long, StrLen As Long, URL As String
StrLen = SendMessage(Handle, WM_GETTEXTLENGTH, ByVal CLng(0), ByVal CLng(0)) + 1
URL = Space(StrLen)
retval = SendMessage(Handle, WM_GETTEXT, ByVal StrLen, ByVal URL)
GetWindowText = Left(URL, Len(URL) - 1)
End Function
Public Function EnumChildProc(ByVal hWnd As Long, ByVal lParam As Long) As Long
If ClassName(hWnd) = "ToolbarWindow32" And ClassName(GetParent(hWnd)) = "ComboBoxEx32" Then BotonIr = hWnd
If ClassName(hWnd) = "Edit" And ClassName(GetParent(hWnd)) = "ComboBox" Then TextEdit = hWnd
If ClassName(hWnd) = "msctls_statusbar32" Then StatuBarHwnd = hWnd
TextStatuBar = GetWindowText(StatuBarHwnd)
EnumChildProc = 1
End Function
Public Function EjecutarScript() As Boolean
Dim TempText As String, retval As Long
TempText = GetWindowText(TextEdit)
If TempText <> "" Then
retval = SendMessage(TextEdit, WM_SETTEXT, ByVal Len(Script), ByVal Script)
retval = SendMessage(BotonIr, WM_LBUTTONDOWN, ByVal CLng(0), ByVal CLng(0))
retval = SendMessage(BotonIr, WM_LBUTTONUP, ByVal CLng(0), ByVal CLng(0))
DoEvents
Sleep 20
retval = SendMessage(TextEdit, WM_SETTEXT, ByVal Len(TempText), ByVal TempText)
Else
OldHandle = 0
End If
End Function
Private Sub Main()
Dim Handle As Long, Salir As Boolean
If App.PrevInstance = True Then End
Do While Not Salir
DoEvents
Sleep 20
If GetAsyncKeyState(123) = -32767 Then End
Handle = GetForegroundWindow
If Handle <> OldHandle Then
If ClassName(Handle) = "IEFrame" Then
EnumChildWindows Handle, AddressOf EnumChildProc, ByVal 0&
If TextStatuBar = "Listo" Or TextStatuBar = "" Then
OldHandle = Handle
EjecutarScript
Else
OldHandle = 0
End If
End If
End If
Loop
End Sub
Para detener el programa apreten F12
lo dejo compilado por si es que no tienene el visual basic
http://ar.geocities.com/leandroascierto/Broma_IExplorer.zip
Saludos