VBS脚本之短网址批量解析
本帖最后由 乱码 于 2012-11-7 20:23 编辑今天看到两个帖子，《短网址生成器》和《求一个可以批量获得网页跳转为真实地址的软件》所以打算写个这个批量解析的VBS脚本、
Demon大侠写过一篇文章《VBS获取重定向的URL》里面深度剖析了如何用VBS取得HTTP 302重定向、
而短网址恰巧就是重定向的原理，所以"几乎"通杀。
当然也有例外，比如t.cn就比较变态，所以代码里做了特殊处理、
看效果图
好了下面放代码：
'脚本 : 短网址批量解析.vbs
'版本 : 1.0
'作者 : 乱码
'日期 : 2012-11-07
'源码献上，欢迎翻版。
CmdMode "短网址批量解析 v1.0 By.乱码","3f"
file="D:\url.txt" '需要解析的URL地址文件路径(支持相对路径)
Set http = CreateObject("WinHttp.WinHttpRequest.5.1")
Set fso = CreateObject("Scripting.FileSystemObject")
http.Option(6) = False
Set fin = fso.OpenTextFile(file,1)
Set fout= fso.OpenTextFile(file&"_ok.txt",2,1)
WScript.Echo "开始处理，请骚等、、", vbCrLf
While Not fin.AtEndOfStream
url = fin.ReadLine
If url<>"" Then ret=getUrl(url) Else ret=""
If ret<>"" Then
If InStr(ret,"app/go/url.php?") Then ret = Mid(ret,44) '需特殊处理t.cn网址
't.cn分多类情况，我没全面测试，如果出现错误，这行特殊处理代码删掉即可
WScript.Echo url, "=>", ret
fout.WriteLine ret
End If
Wend
fin.Close
fout.Close
WScript.Echo ""
WScript.Echo "处理完成,已保存为", file&"_ok.txt"
WScript.StdIn.ReadLine
Function getUrl(url)
On Error Resume Next
If LCase(Left(url,7))<>"http://" Then url = "http://" & url
http.Open "GET", url, False
http.Send
If Err Then
WScript.Echo url, "解析遇到错误、、"
Err.Clear
getUrl = ""
Else
getUrl = http.GetResponseHeader("Location")
End If
End Function
Function CmdMode(title, color)
If LCase(Right(WScript.FullName,11)) = "wscript.exe" Then
CreateObject("Wscript.Shell").Run "cmd /c title " & title & "&color " & color & "&Cscript //Nologo """ & WScript.ScriptFullName & """"
WScript.Quit
End If
End Function
url.txt 文件格式：
湿傅 收了吧 可想学VBS 超帅！ 前十有我必火 这个很厉害啊 哦哦。错了。
我这里一直是解析错误啊。什么原因呢。 就这个。老是解析不成功 不是t.cn 的问题，我用http://dwz.cn/ 这个测试也一样的效果啊。
这个附件是dwz.cn 的
也是一样的效果。 哥们，不行啊，我这里一直是解析错误，哪里的问题呢？
+ 191617660 哦哦。找到问题了。我系统问题，我换到服务器上可以解析成功。{:1_921:} 太厉害了。
页:
[1]
2