refer/referral 显示反向链接原理

代码使用方法请看:
http://blog.wespoke.com/archives/000571.php

分析了“http://luliang.dhs.org/refergb.cgi”的代码,其实只是个Javascript:

function write_ref() {
   document.write(“<script language=’Javascript’ src=’http://luliang.dhs.org/cgi-bin/refergb.cgi?in=” + document.referrer + “&out=” + document.location + “‘>”);
   document.write(“</”);
   document.write(“script>”);
}
write_ref();

document.referrer:前网页从哪里链接来的
document.location:当前网页的地址

下面举个例子:
比如在我的BLOG中加入了这个脚本,即:
<script type=”text/javascript” language=”Javascript” src=”http://luliang.dhs.org/refergb.cgi”></script>
当我们从其他网页中链接到你的BLOG上时(比如从鼓浪听涛),
你的BLOG上的脚本”document.referrer”就取得了鼓浪听涛上链接到你的BLOG上的地址:
“http://210.34.0.13/xxxxxxxx”后面的xxxxx不用管它
同时”document.location”取得当前网页的地址:
“http:// selfren.xmu.edu.cn/blogs/more.asp?name=fengdongren&id=115”

接着你的BLOG会向“http://luliang.dhs.org/cgi-bin/refergb.cgi”发送请求,
请求中包含两个参数:
“in=”:来源地址,这里是“http://210.34.0.13/xxxxxxxx”
“out=”:调用脚本的页面,这里是“http:// selfren.xmu.edu.cn/blogs/more.asp?name=fengdongren&id=115”

参数传给 http://luliang.dhs.org/ 后,它就先开始分析,
获取“http://210.34.0.13/xxxxxxxx”的title后开始统计,
这里他们可能是把in和out都存入数据库了。
最后把分析出来的title和参数in传回给客户端,这时指你的BLOG。

当下次有个从另一个网页链接到相同的页面时,
http://luliang.dhs.org/ 就将客户端提交的数据分析后再和先前保存的数据一起返回给客户端。

另外,如果in参数前面包含有一些关键字,
比如“http://www.baidu.com/afdsfsafsadfdsafa”,
服务器就会自动把它识别为百度的首页,
而不用再去取得百度搜索页的页面代码,
因此显示的结果是“百度——全球最大中文搜索引擎”
而不是“百度搜索_关键字”

要不要试试?

http://luliang.dhs.org/cgi-bin/refergb.cgi?in=IN_URL&out=yoursite_url

把IN_URL改成本机的地址,看看你的WEB服务器日志,有没有发现luliang.dhs.org在连你?(我的机子不行,外面访问不到,呵呵)

大家清楚了吧,改明儿俺自已也写一个。

— EOF —

用ASP读取图片大小(长和宽)

还是闲着,又写了这个东东 ^_^

利用ADOStream分析图片的十六进制码实现。

有热心人帮我改改读JPG的那段,效率很低!!

<!– METADATA TYPE="typelib"
      UUID="00000205-0000-0010-8000-00AA006D2EA4"
     NAME="ADODB Type Library"
–>
<form method="post" action="?">
<input type="file" name="PicPath" value="">
<input type="submit" value=" 检 测 ">
</form>
<%

Function Dec(HexStr)

Dim lenS, t
  lenS = Len(HexStr)

For i = 1 To lenS

t = UCase(Mid(HexStr, i, 1))

Select Case t
    Case "A" t = 10
    Case "B" t = 11
    Case "C" t = 12
    Case "D" t = 13
    Case "E" t = 14
    Case "F" t = 15
   End Select

Dec = Dec + t * 16 ^ (lenS – i)

Next

End Function

Function BinToHex(Str)

BinToHex = Hex(AscB(Str))

If (Len(BinToHex) < 2) Then

BinToHex = "0" & BinToHex
 
  End If

End Function
Dim PicPath

PicPath = Request.Form("PicPath")
 
If (PicPath <> "") Then

Dim objStream, hH, hL, wH, wL
  Set objStream = Server.CreateObject("ADODB.Stream")
  objStream.Type = adTypeBinary
  
  objStream.Open
  objStream.LoadFromFile PicPath
 
  tp = LCase(Mid(PicPath, InstrRev(PicPath, ".")))
  If (tp = ".gif") Then ‘GIF
   objStream.Position = 6
   wL = BinToHex(objStream.Read(1))
   wH = BinToHex(objStream.Read(1))
   hL = BinToHex(objStream.Read(1))
   hH = BinToHex(objStream.Read(1))
  ElseIf (tp = ".jpg") Then ‘JPG
   Dim po, pos
   objStream.Position = 0
   While (po < objStream.Size – 9)
    If (BinToHex(objStream.Read(1)) = "FF" And BinToHex(objStream.Read(1)) = "C0" And BinToHex(objStream.Read(1)) = "00" And BinToHex(objStream.Read(1)) = "11" And BinToHex(objStream.Read(1)) = "08") Then
     pos = po
    End If
    po = po + 1
    objStream.Position = po
   Wend
   objStream.Position = pos + 5
   hH = BinToHex(objStream.Read(1))
   hL = BinToHex(objStream.Read(1))
   wH = BinToHex(objStream.Read(1))
   wL = BinToHex(objStream.Read(1))
  ElseIf (tp = ".bmp" or tp = ".png") Then ‘BMP OR PNG
   objStream.Position = 18
   wL = BinToHex(objStream.Read(1))
   wH = BinToHex(objStream.Read(1))
   objStream.Position = 22
   hL = BinToHex(objStream.Read(1))
   hH = BinToHex(objStream.Read(1))
  End If

objStream.Close

Response.Write "Width:" & Dec(wH & wL) & "<BR>Height:" & Dec(hH & hL)

End If
%>
 

写完后发现这个,也是利用FSO取得BMP,JPG,PNG,GIF的文件信息,代码如下:

<%
  ‘:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  ‘:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  ‘:::   BMP, GIF, JPG and PNG                                     :::
  ‘:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  ‘:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  ‘:::                                                             :::
  ‘:::  This function gets a specified number of bytes from any    :::
  ‘:::  file, starting at the offset (base 1)                      :::
  ‘:::                                                             :::
  ‘:::  Passed:                                                    :::
  ‘:::       flnm        => Filespec of file to read               :::
  ‘:::       offset      => Offset at which to start reading       :::
  ‘:::       bytes       => How many bytes to read                 :::
  ‘:::                                                             :::
  ‘:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  function GetBytes(flnm, offset, bytes)
     Dim objFSO
     Dim objFTemp
     Dim objTextStream
     Dim lngSize
     on error resume next
     Set objFSO = CreateObject("Scripting.FileSystemObject")
    
     ‘ First, we get the filesize
     Set objFTemp = objFSO.GetFile(flnm)
     lngSize = objFTemp.Size
     set objFTemp = nothing
     fsoForReading = 1
     Set objTextStream = objFSO.OpenTextFile(flnm, fsoForReading)
     if offset > 0 then
        strBuff = objTextStream.Read(offset – 1)
     end if
     if bytes = -1 then         ‘ Get All!
        GetBytes = objTextStream.Read(lngSize)  ‘ReadAll
     else
        GetBytes = objTextStream.Read(bytes)
     end if
     objTextStream.Close
     set objTextStream = nothing
     set objFSO = nothing
  end function

‘:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  ‘:::                                                             :::
  ‘:::  Functions to convert two bytes to a numeric value (long)   :::
  ‘:::  (both little-endian and big-endian)                        :::
  ‘:::                                                             :::
  ‘:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  function lngConvert(strTemp)
     lngConvert = clng(asc(left(strTemp, 1)) + ((asc(right(strTemp, 1)) * 256)))
  end function
  function lngConvert2(strTemp)
     lngConvert2 = clng(asc(right(strTemp, 1)) + ((asc(left(strTemp, 1)) * 256)))
  end function
 
  ‘:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  ‘:::                                                             :::
  ‘:::  This function does most of the real work. It will attempt  :::
  ‘:::  to read any file, regardless of the extension, and will    :::
  ‘:::  identify if it is a graphical image.                       :::
  ‘:::                                                             :::
  ‘:::  Passed:                                                    :::
  ‘:::       flnm        => Filespec of file to read               :::
  ‘:::       width       => width of image                         :::
  ‘:::       height      => height of image                        :::
  ‘:::       depth       => color depth (in number of colors)      :::
  ‘:::       strImageType=> type of image (e.g. GIF, BMP, etc.)    :::
  ‘:::                                                             :::
  ‘:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  function gfxSpex(flnm, width, height, depth, strImageType)
     dim strPNG
     dim strGIF
     dim strBMP
     dim strType
     strType = ""
     strImageType = "(unknown)"
     gfxSpex = False
     strPNG = chr(137) & chr(80) & chr(78)
     strGIF = "GIF"
     strBMP = chr(66) & chr(77)
     strType = GetBytes(flnm, 0, 3)
     if strType = strGIF then                           ‘ is GIF
        strImageType = "GIF"
        Width = lngConvert(GetBytes(flnm, 7, 2))
        Height = lngConvert(GetBytes(flnm, 9, 2))
        Depth = 2 ^ ((asc(GetBytes(flnm, 11, 1)) and 7) + 1)
        gfxSpex = True
     elseif left(strType, 2) = strBMP then              ‘ is BMP
        strImageType = "BMP"
        Width = lngConvert(GetBytes(flnm, 19, 2))
        Height = lngConvert(GetBytes(flnm, 23, 2))
        Depth = 2 ^ (asc(GetBytes(flnm, 29, 1)))
        gfxSpex = True
     elseif strType = strPNG then                       ‘ Is PNG
        strImageType = "PNG"
        Width = lngConvert2(GetBytes(flnm, 19, 2))
        Height = lngConvert2(GetBytes(flnm, 23, 2))
        Depth = getBytes(flnm, 25, 2)
        select case asc(right(Depth,1))
           case 0
              Depth = 2 ^ (asc(left(Depth, 1)))
              gfxSpex = True
           case 2
              Depth = 2 ^ (asc(left(Depth, 1)) * 3)
              gfxSpex = True
           case 3
              Depth = 2 ^ (asc(left(Depth, 1)))  ‘8
              gfxSpex = True
           case 4
              Depth = 2 ^ (asc(left(Depth, 1)) * 2)
              gfxSpex = True
           case 6
              Depth = 2 ^ (asc(left(Depth, 1)) * 4)
              gfxSpex = True
           case else
              Depth = -1
        end select

else
        strBuff = GetBytes(flnm, 0, -1)         ‘ Get all bytes from file
        lngSize = len(strBuff)
        flgFound = 0
        strTarget = chr(255) & chr(216) & chr(255)
        flgFound = instr(strBuff, strTarget)
        if flgFound = 0 then
           exit function
        end if
        strImageType = "JPG"
        lngPos = flgFound + 2
        ExitLoop = false
        do while ExitLoop = False and lngPos < lngSize

do while asc(mid(strBuff, lngPos, 1)) = 255 and lngPos < lngSize
              lngPos = lngPos + 1
           loop
           if asc(mid(strBuff, lngPos, 1)) < 192 or asc(mid(strBuff, lngPos, 1)) > 195 then
              lngMarkerSize = lngConvert2(mid(strBuff, lngPos + 1, 2))
              lngPos = lngPos + lngMarkerSize  + 1
           else
              ExitLoop = True
           end if
       loop
       ‘
       if ExitLoop = False then
          Width = -1
          Height = -1
          Depth = -1
       else
          Height = lngConvert2(mid(strBuff, lngPos + 4, 2))
          Width = lngConvert2(mid(strBuff, lngPos + 6, 2))
          Depth = 2 ^ (asc(mid(strBuff, lngPos + 8, 1)) * 8)
          gfxSpex = True
       end if
                  
     end if
  end function

‘:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  ‘:::     Test Harness                                              :::
  ‘:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
 
  ‘ To test, we’ll just try to show all files with a .GIF extension in the root of C:
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  Set objF = objFSO.GetFolder("c:")
  Set objFC = objF.Files
  response.write "<table border=""0"" cellpadding=""5"">"
  For Each f1 in objFC
    if instr(ucase(f1.Name), ".GIF") then
       response.write "<tr><td>" & f1.name & "</td><td>" & f1.DateCreated & "</td><td>" & f1.Size & "</td><td>"
       if gfxSpex(f1.Path, w, h, c, strType) = true then
          response.write w & " x " & h & " " & c & " colors"
       else
          response.write " "
       end if
       response.write "</td></tr>"
    end if
  Next
  response.write "</table>"
  set objFC = nothing
  set objF = nothing
  set objFSO = nothing

%>

— EOF —

用ASP实现对MP3曲目信息的操作

先简单说一下MP3的ID3 标记,因为主要是操作这个玩意。

MP3最开始的时候没有我们今天看到的那样,有歌手、年代,专集等等信息。只有一些简单的参数如yes/no来表示是不是privated或者copyrighted等信息,这样对MP3的相关工作带来了很多不便,1996年的时候有个老外提出来在每个MP3后面追加一段数据,用以存放上述的那些信息,后来就发展成为id3 v1 据我所知的现在已经到1.1了,具体的还是自己去查一下吧。

用metadata来引入DLL

<!–METADATA TYPE="typelib"
      UUID="00000205-0000-0010-8000-00AA006D2EA4"
     NAME="ADODB Type Library"
–>

<%
  Function ConvertBin(Binary)
  ‘This function converts a binary byte into an ASCII byte.
    for i = 1 to LenB(Binary)
      strChar = chr(AscB(MidB(Binary,i,1)))
      ConvertBin = ConvertBin & strChar
    Next
  End Function

dim objStream
  dim strTag, strSongName, strArtist, strAlbum, strYear, _
      strComment, strGenre, strFile

‘Specify the folder to iterate through, displaying all the MP3s
  Const folder = "C:mp3s"

‘Grab the folder information

Dim objFSO, objFolder, objFile
  Set objFSO = Server.CreateObject("Scripting.FileSYstemObject")
  Set objFolder = objFSO.GetFolder(folder)

‘Create the Stream object
  set objStream = Server.CreateObject("ADODB.Stream")
  objStream.Type = adTypeBinary

‘Loop through the files in the folder
  For Each objFile in objFolder.Files
    ‘Open the stream
    objStream.Open
    objStream.LoadFromFile objFile.Path

‘Read the last 128 bytes
    objStream.Position =  objStream.size – 128

‘Read the ID3 v1 tag info
    strTag = ConvertBin(objStream.Read(3))
    if ucase(strTag) = "TAG" then
      strSongName = ConvertBin(objStream.Read(30))
      strArtist = ConvertBin(objStream.Read(30))
      strAlbum = ConvertBin(objStream.Read(30))
      strYear = ConvertBin(objStream.Read(4))
      strComment = ConvertBin(objStream.Read(30))
    end if

‘Display the results
    response.write "<table><tr><td colspan=2><h3>" & _
                   "ID3 Tag info for:</td></tr><tr>" & _
                   "<td colspan=2>" & objFile.Name & "</td></tr>"
    response.write "<tr><td><b>Artist: </b></td>" & _
                   "<td>" & strArtist & "</td></tr>"
    response.write "<tr><td><b>Track: </b></td>" & _
                   "<td>" & strSongName  & "</td></tr>"
    response.write "<tr><td><b>Album: </b></td>" & _
                   <td>" & strAlbum & "</td></tr>"
    response.write "<tr><td><b>Year: </b></td>" & _
                   "<td>" & strYear & "</td></tr>"
    response.write "<tr><td><b>Comment: </b>" & _
                   "</td><td>" & strComment & "</td></tr>"
    response.write "</table>"

objStream.Close

Response.Write "<p><hr><p>"
  Next

Set objStream = Nothing    ‘Clean up…
%>
 

修改了一下:

<!–METADATA TYPE="typelib"
UUID="00000205-0000-0010-8000-00AA006D2EA4"
NAME="ADODB Type Library"
–>

<%
Response.Buffer = false
Function ConvertBin(Binary)
‘This function converts a binary byte into an ASCII byte.
for i = 1 to LenB(Binary)
strChar = chr(AscB(MidB(Binary,i,1)))
ConvertBin = ConvertBin & strChar
Next
End Function

dim objStream
dim strTag, strSongName, strArtist, strAlbum, strYear, _
strComment, strGenre, strFile

‘Specify the folder to iterate through, displaying all the MP3s
Const folder = "F:\MUSIC"

‘Grab the folder information

Dim objFSO, objFolder, objFile
Set objFSO = Server.CreateObject("Scripting.FileSYstemObject")
Set objFolder = objFSO.GetFolder(folder)

‘Create the Stream object
set objStream = Server.CreateObject("ADODB.Stream")
objStream.Type = adTypeBinary

‘Loop through the files in the folder
For Each objFile in objFolder.Files
if lcase(objFSO.GetExtensionName(objFile)) = "mp3" then
Response.Write objFile.Type
‘Open the stream
objStream.Open
objStream.LoadFromFile objFile.Path

‘Read the last 128 bytes
objStream.Position = objStream.Size – 128

‘Read the ID3 v1 tag info
strTag = ConvertBin(objStream.Read(3))
if ucase(strTag) = "TAG" then
strSongName = ConvertBin(objStream.Read(30))
strArtist = ConvertBin(objStream.Read(30))
strAlbum = ConvertBin(objStream.Read(30))
strYear = ConvertBin(objStream.Read(4))
strComment = ConvertBin(objStream.Read(30))
end if

‘Display the results
response.write "<table><tr><td colspan=2><h3>" & _
"ID3 Tag info for:</td></tr><tr>" & _
"<td colspan=2>" & objFile.Name & "</td></tr>"
response.write "<tr><td><b>Artist: </b></td>" & _
"<td>" & strArtist & "</td></tr>"
response.write "<tr><td><b>Track: </b></td>" & _
"<td>" & strSongName & "</td></tr>"
response.write "<tr><td><b>Album: </b></td>" & _
"<td>" & strAlbum & "</td></tr>"
response.write "<tr><td><b>Year: </b></td>" & _
"<td>" & strYear & "</td></tr>"
response.write "<tr><td><b>Comment: </b>" & _
"</td><td>" & strComment & "</td></tr>"
response.write "</table>"

objStream.Close

Response.Write "<p><hr><p>"

end if
Next

Set objStream = Nothing ‘Clean up…
%>

— EOF —

ASP+FSO实现的服务器目录名和文件名罗列脚本

闲着的时候写了这个东东:^_^

打包下载:
listpath.zip

下面是源代码:

<%
Response.Buffer = False
Server.ScriptTimeOut = 360000000
On error Resume next
%>
<html>
<head>
<title>::. 风动网目录文件罗列脚本 .::</title>
<style type="text/css">
Body {font-size: 12px; font-family: "verdana", "arial", "helvetica", "sans-serif"}
a {color: #000000; text-decoration: none}
</STYLE>
</head>
<body>
<div align="center">
<form align="center" action="?" method="post" ID="Form1">
<fieldset style="width: 350px;">
<legend align="center" onclick="showOrHide(‘syspanel’);" style="cursor: hand;" title="点击[显示/隐藏]此框"><b><big>风动网目录文件罗列脚本</big></b></legend>
<div id="syspanel">
目录: <input type="text" name="ListPath" size="40"
title="这里指服务器上的目录, 可以是盘符或路径." ID="Text1"><br>
类型: <input type="text" name="FileType" size="40"
title="你所要罗列文件的类型,
如[.exe .rar],中间可用任意字符隔开
不填即列所有类型文件." ID="Text2"><br>
层数: <input type="text" name="Depth" size="40"
title="你所要罗列目录的层数, 不填即列所有层数." ID="Text3"><br>
<span id="param1ctrl" style="display: none;">路径: <input type="text" name="LogPath" size="40"
title="目录清单文件保存的路径, 也是指服务器上的." ID="Text4"><br></span>
参数: <input type="checkbox" name="Param" value="file" checked
title="是否罗列出文件." ID="Checkbox1"> 列文件
<input type="checkbox" name="Param1" value="txtlog" onclick="display(‘param1ctrl’,’Param1′);"
title="是否生成目录清单文件." ID="Checkbox2"> 生成txt
<input type="checkbox" name="Param2" value="scrout" checked
title="是否在浏览器窗口中输出." ID="Checkbox3"> 屏幕输出<br>  
<input type="checkbox" name="Param3" value="fsout" checked
title="是否显示文件大小." ID="Checkbox2"> 显示文件大小
<input type="checkbox" name="Param4" value="fenout" checked
title="是否显示文件扩展名." ID="Checkbox2"> 显示文件扩展名<br><br>
<input type="submit" value="     开   始   罗   列     " title="罗列过程中按空格可以控制屏幕滚动" ID="Submit1" NAME="Submit1">
</div>
</fieldset>
</form>
</div>
<script language="JavaScript">
<!–
window.status = " ** 风动网目录文件罗列脚本 ** ";
function showOrHide(id) {
if (getObjectById(id).style.display=="none")
  {getObjectById(id).style.display=’block’;}
else
  {getObjectById(id).style.display=’none’;}
}
function display(id,ctrl) {
  if (getObjectById(ctrl).checked==true)
   {getObjectById(id).style.display=’block’;}
  else
   {getObjectById(id).style.display=’none’;}
}
function displayObject(id,flag) {
  if (flag==true)
   {getObjectById(id).style.display=’block’;}
  else
   {getObjectById(id).style.display=’none’;}
}
function getObjectById(id) {
     return document.getElementById(id);
}
//–>
</script>
<%
Dim ListPath, Depth, CurDepth
ListPath = Replace(Request.Form("ListPath"), "/", "\")
If Not ListPath = Empty Then
%>
<script language="JavaScript">
<!–
window.status = "服务器正在罗列,请稍候 … (按空格可以控制屏幕滚动)"
Timer = window.setInterval("window.scroll(0, document.body.scrollHeight);", 50);
var Timer;
var stopScroll;
 
function document.onkeydown() {
  if (event.keyCode == 32) {
   if (stopScroll == false) {
    winScroll();
    stopScroll = true;
   }
   else {
    window.clearInterval(Timer);
    stopScroll = false;
   }
  }
}
function winScroll(){
  Timer = window.setInterval("window.scroll(0, document.body.scrollHeight);", 100);
}
function document.onstop(){
  window.status = "罗列中断!"
  window.setTimeout("window.clearInterval(Timer);", 1000);
}
//–>
</script>
<%
  If Right(ListPath, 1) <> "\" Then ListPath = ListPath & "\"
  If Not Request.Form("Depth") = "" Then Depth = Int(Request.Form("Depth"))
  FileType = LCase(Request.Form("FileType"))
  Param = Request.Form("Param")
  Param1 = Request.Form("Param1")
  Param2 = Request.Form("Param2")
  Param3 = Request.Form("Param3")
  Param4 = Request.Form("Param4")

Set ListParentObject = Server.CreateObject("Scripting.FileSystemObject")
  If Len(ListPath) <= 4 Then
   If ListParentObject.DriveExists(ListPath) Then
    Set ListDriveObject = ListParentObject.GetDrive(ListPath)
    If ListDriveObject.IsReady = True Then
     Set ListPathObject = ListDriveObject.RootFolder
    Else
     errmsg = "<br>对不起,当前驱动器未准备就绪!"
     ErrOccur(errmsg)
     Response.End
    End If
   Else
    errmsg = "<br>对不起,当前驱动器不存在!"
    ErrOccur(errmsg)
    Response.End
   End If
  Else
   If ListParentObject.FolderExists(ListPath) Then
    Set ListPathObject = ListParentObject.GetFolder(ListPath)
   Else
   
    errmsg = "<br>对不起,当前路径不存在!"
    ErrOccur(errmsg)
    Response.End
   End If
 
  End If
  If Param1 = "txtlog" Then
   Dim LogPath
   LogPath = Replace(Request.Form("LogPath"), "/", "\")
   Set FSO = Server.CreateObject("Scripting.FileSystemObject")
   If (FSO.FolderExists(LogPath)) Then
  
    If (Right(LogPath, 1) <> "\") Then LogPath = LogPath & "\"
    Set FO = FSO.CreateTextFile(LogPath & Replace(Replace(ListPath, "\", "-"), ":", "-") & ".txt")
   Else
    Response.Write "<font color=""red"">输入路径不存在, 日志文件将被保存在与该脚本相同的目录下.</font><br><br>"
    Set FO = FSO.CreateTextFile(Server.MapPath(Replace(Replace(ListPath, "\", "-"), ":", "-") & ".txt"))
   End If
  End If
  Response.Write "<font color=""brown"">▊</font> 目录 "
  Response.Write "<font color=""green"">▊</font> 文件<br><br>"
  Response.Write "<b><font color=""red"">[" & ListPath & "]</font></b><br>"
  If Param1 = "txtlog" Then FO.Write(ListPath) & VbCrLf
  Call ListAllPath(ListPath, "0", False)
  Response.Write "<br><br><b><font color=""red"">罗列完毕!</font></b>"
%>
 
<script language="JavaScript">
<!–
window.status = "罗列完毕!"
window.setTimeout("window.clearInterval(Timer);", 1000);
//–>
</script>
<%
  If Param1 = "txtlog" Then
 
   Set FO = Nothing
   Set FSO = Nothing
  End If
End If
%>
</body>
</html>
<%

Function ListAllPath(byval CurPath, byval Symbol, byval LastFolder)

Dim CurFolderIndex
  CurFolderIndex = 0
  CurDepth = CurDepth + 1
  If LastFolder = True Then
 
   Symbol = Symbol & "1"
  Else
 
   Symbol = Symbol & "2"
  End If
 
  If Depth <> "" Then
 
   If CurDepth >= Depth + 1 Then Exit Function
  End If
  If Len(ListPath) <= 4 Then
   Set ListDriveObject = ListParentObject.GetDrive(CurPath)
   Set ListPathObject = ListDriveObject.RootFolder
  Else
   Set ListPathObject = ListParentObject.GetFolder(CurPath)
  End If
  If InStr(Param, "file") > 0 Then Call ListAllFile(CurPath, Symbol, LastFolder)
  TotalFolderNum = ListPathObject.SubFolders.Count
  For Each ListPath In ListPathObject.SubFolders
   CurFolderIndex = CurFolderIndex + 1
   If ListPath.Attributes <> 22 Then
    If ListPath.Size <= 1024 Then
     PathSize = 1
    Else
     PathSize = FormatNumber(ListPath.Size/1024,0)
    End If
    StrTemp = Nums2Symbols(Mid(Symbol, 3))
    If Param2 = "scrout" Then Response.Write StrTemp
    If Param1 = "txtlog" Then FO.Write(StrTemp)
    If CurFolderIndex = TotalFolderNum Then
     If Param2 = "scrout" Then Response.Write("└─")
     If Param1 = "txtlog" Then FO.Write("└─")
     LastFolder1 = True
    Else
   
     If Param2 = "scrout" Then Response.Write("├─")
     If Param1 = "txtlog" Then FO.Write("├─")
     LastFolder1 = False
    End If
    If Param2 = "scrout" Then
   Response.Write("<font color=""brown"">" & ListPath.Name)
   If Param3 = "fsout" Then Response.Write(" " & PathSize & "KB")
   Response.Write("</font><br>")
End If
    If Param1 = "txtlog" Then
   FO.Write(ListPath.Name)
   If Param3 = "fsout" Then FO.Write(" " & PathSize & "KB")
   FO.Write(VbCrLf)
End If
    Call ListAllPath(ListPath, Symbol, LastFolder1)
    CurDepth = CurDepth – 1
   Else
    If CurFolderIndex = TotalFolderNum Then
     If Param2 = "scrout" Then Response.Write("└─")
     If Param1 = "txtlog" Then FO.Write("└─")
     LastFolder1 = True
    Else
  
     If Param2 = "scrout" Then Response.Write("├─")
     If Param1 = "txtlog" Then FO.Write("├─")
     LastFolder1 = False
    End If
    If Param2 = "scrout" Then Response.Write("<font color=""brown"">" & ListPath.Name & " 系统文件夹</font><br>")
    If Param1 = "txtlog" Then FO.Write(ListPath.Name & " 系统文件夹" & VbCrLf)
   End If
  Next

End Function

Function ListAllFile(byval CurPath, byval Symbol, byval LastFolder)

Set ListFileObject = ListParentObject.GetFolder(CurPath)
  TotalFolderNum = ListFileObject.SubFolders.Count
 
  For Each ListFile In ListFileObject.Files
   If ListFile.Size <= 1024 Then
    FileSize = 1
   Else
    FileSize = FormatNumber(ListFile.Size/1024,0)
   End If
   If InStr(ListFile.Name, ".") Then
    FType = ListParentObject.GetExtensionName(ListFile.Name)’Mid(ListFile.Name, InstrRev(ListFile.Name, "."))
   End If
   If Instr(FileType, LCase(FType)) > 0 Or FileType = "" Then
    StrTemp = Nums2Symbols(Mid(Symbol, 3))
    If Param2 = "scrout" Then Response.Write(StrTemp)
    If Param1 = "txtlog" Then FO.Write(StrTemp)
    If TotalFolderNum = 0 Then
     If Param2 = "scrout" Then Response.Write("")
     If Param1 = "txtlog" Then FO.Write("")
    Else
     If Param2 = "scrout" Then Response.Write("│")
     If Param1 = "txtlog" Then FO.Write("│")
    End If
    If Param2 = "scrout" Then
   Response.Write("<font color=""green"">")
   If Param4 = "fenout" Then
    Response.Write(ListFile.Name)
   Else
    Response.Write(GetFileName(ListFile.Name))
   End If
   If Param3 = "fsout" Then Response.Write(" " & FileSize & "KB")
   Response.Write("</font><br>")
End If
    If Param1 = "txtlog" Then
   If Param4 = "fenout" Then
    FO.Write(ListFile.Name)
   Else
    FO.Write(GetFileName(ListFile.Name))
   End If
   If Param3 = "fsout" Then FO.Write(" " & FileSize & "KB")
   FO.Write(VbCrLf)
End If
   End If
  Next

End Function

Function GetFileName(byval FileFullName)
  GetFileName = Left(FileFullName, InstrRev(FileFullName, ".")-1)
End Function

Function Num2Symbol(byval Num)
  Select Case Num
   Case 0
    Num2Symbol = " "
   Case 1
    Num2Symbol = ""
   Case 2
    Num2Symbol = "│"
  End Select
End Function

Function Nums2Symbols(byval Num)
  i = Len(Num)
  While i > 0
   Nums2Symbols = Nums2Symbols & Num2Symbol(Left(Num, 1))
   Num = Mid(Num, 2)
   i = i – 1
  Wend
End Function

Sub ErrOccur(byval errmsg)

If Param2 = "scrout" Then Response.Write "<font color=""red"">" & errmsg & "</font>"
%>
<script language="JavaScript">
<!–
window.status = "罗列出错!"
window.setTimeout("window.clearInterval(Timer);", 1000);
//–>
</script>
</body>
</html>
<%
End Sub
%>

— EOF —

ASP中利用XMLHTTP获取并输出远程网页

代码如下:

Function URLEncoding(vstrIn)
    strReturn = ""
    For i = 1 To Len(vstrIn)
        ThisChr = Mid(vStrIn,i,1)
        If Abs(Asc(ThisChr)) < &HFF Then
            strReturn = strReturn & ThisChr
        Else
            innerCode = Asc(ThisChr)
            If innerCode < 0 Then
                innerCode = innerCode + &H10000
            End If
            Hight8 = (innerCode  And &HFF00)\ &HFF
            Low8 = innerCode And &HFF
            strReturn = strReturn & "%" & Hex(Hight8) &  "%" & Hex(Low8)
        End If
    Next
    URLEncoding = strReturn
End Function

Function bytes2BSTR(vIn)
    strReturn = ""
    For i = 1 To LenB(vIn)
        ThisCharCode = AscB(MidB(vIn,i,1))
        If ThisCharCode < &H80 Then
            strReturn = strReturn & Chr(ThisCharCode)
        Else
            NextCharCode = AscB(MidB(vIn,i+1,1))
            strReturn = strReturn & Chr(CLng(ThisCharCode) * &H100 + CInt(NextCharCode))
            i = i + 1
        End If
    Next
    bytes2BSTR = strReturn
End Function

set oReq = CreateObject("MSXML2.XMLHTTP")
oReq.open "POST","http://www.xmu.edu.cn/",false
oReq.setRequestHeader "CONTENT-TYPE","application/x-www-form-urlencoded"
oReq.send
Response.Write bytes2BSTR(oReq.responseBody) 

修改代码1:
发现把最后一句改为 Response.BinaryWrite oReq.responseBody 也是可以的。

修改代码2:
结合了ADODB.Stream,优化了B2S函数:

Function bin2str2(binstr)
Dim BytesStream,StringReturn
Set BytesStream = CreateObject("ADODB.Stream")
With BytesStream
  .Type = 2
  .Open
  .WriteText binstr
  .Position = 0
  .Charset = "GB2312"
  .Position = 2
  StringReturn = .ReadText
  .close
End With
Set BytesStream = Nothing
bin2str2 = StringReturn
End Function

— EOF —