在整理舊硬碟資料時，意外發現以前寫的小程式，這支使用VBScript(請注意是VBScript不是VB)撰寫的WSH程式『宿網守護神』，是讀二技時幫住宿同學製作，可以從宿舍流量統計網站抓取當日的累計流量，當數值超過設定的上限時，就自動關閉某些正在執行的網路程式(就是動物園暫停營業的意思啦)。雖然是個很小的Script程式，不過有用到一些regular expression、command shell、file system的技巧，對需要寫VBScript管理Windows系統的網管人員或許有些幫助，所以就貼在這邊大放送啦。其中有部份CODE不是我寫的，而是發揮程序員都應該知道的密技『C&P』得來，但時日已久，我也分不清楚哪些才是自己寫的，總之有需要的人就自己拿去修改吧。
這個版本只是在網路流量快到上限時，停止網路應用程式，避免超流被鎖卡，對網管人員來說應該是無害的，只是遵守遊戲規則下讓動物園經營成果最佳化。其實當初在撰寫第一版時，就有想到第二版需要哪些改進，舉例來說，自動搜尋同一個網段中，哪些IP address沒有人用(透過過去一段時間的統計資料確定是沒人在用)，產生成一份IP清單，然後在一個IP流量快到上限時，自動切換到下一組IP，如此一來，假設每個IP每日限流3G，那麼只要能蒐集到五組，每日就有3G*5的總流量可用。
'Option Explicit
on error resume next
' [[宿網守護神]]測試版
'========================================== [[設定區-BEGIN]]
'初始化設定(請勿修改以下變數名稱)
'請依照需求修改以下各項設定資料
'IP位址設定()
'Dim YourIP : YourIP = "140.125.xxx.xxx" '手動設定
Dim YourIP : YourIP = GetIP() '自動偵測
'傳輸量上限(單位：MBytes)
Dim LimitTrans : LimitTrans = 3072 '預設3GBytes
'流量到達上限時，將自動終止KillApp列表中的程式
Dim KillApp : KillApp = Array("emule.exe", "flashget.exe", "DSLite.exe", "BitComet.exe", "abc.exe", "Bearshare.exe", "BitLord.exe", "bitspirit.exe", "btdownloadgui.exe", "dcplusplus.exe", "edonkey2000.exe", "g3torrent.exe", "kazaa.exe", "limewire.exe", "newsLeecher.exe", "Overnet.exe", "rufus.exe", "slsk.exe", "StrongDC.exe", "utorrent.exe", "winmx.exe")
'檢查流量的時間間隔(單位：分鐘)
Dim Refresh : Refresh = 10
'========================================== [[設定區-END]]
'========================================== [[主程式由此開始]]
'程式名稱
Dim ProgName : ProgName = "宿網守護神"
'Call ActiveFirewall
Call SetSchedule
Call Main
'工作排程
Function SetSchedule()
Dim WS
Dim ExeTime, AtExeTime
Set WS = CreateObject("WScript.Shell")
ExeTime = (DateAdd("n", Refresh, Now()))
AtExeTime = Hour(ExeTime) & ":" & Minute(ExeTime)
WS.Run "at " & AtExeTime & " """ & WScript.ScriptFullName & """"
End Function
'主程式執行區段
Sub Main()
'判斷IP設定是否正確
If YourIP = vbNullString Then
MsgBox "錯誤：無法取得主機位址。", , ProgName
Exit Sub
End If
'取得流量統計網頁
Dim Http, HtmlSource, URL
Set Http = CreateObject("msxml2.xmlhttp")
URL = "http://140.125.240.168/?action=ShowIP&IP=" & YourIP
Http.Open "GET", URL, False
Http.Send
HtmlSource = Http.ResponseText
'取得網頁原始資料
HtmlArray = RegExpTest("<tr><td>[0-9.-]+</td><td>[0-9.]+</td><td>[0-9.]+</td><td>[0-9.]+</td><td>[0-9.]+</td><td>[0-9.]+</td></tr>\n", HtmlSource)
'判斷是否有讀取到統計資料的HTML原始碼
If UBound(HtmlArray) = 0 Then
MsgBox "錯誤：無法取得統計資料，請重新檢查設定。", , ProgName
Exit Sub
End If
'取得統計數據資料，由HTML碼轉換為一串陣列
DataArray = SubMatchTest("<tr><td>([0-9.-]+)</td><td>([0-9.]+)</td><td>([0-9.]+)</td><td>([0-9.]+)</td><td>([0-9.]+)</td><td>([0-9.]+)</td></tr>", HtmlArray(0))
'今天的日期與資料日期
Dim NowDate, DataDate
NowDate = Date
DataDate = CDate(DataArray(0))
'日期比對，今日的流量統計已經上線才開始進行流量防護
If NowDate = DataDate Then
Dim TotalTrans '總流量
TotalTrans = CDbl(DataArray(1)) + CDbl(DataArray(2))
'流量已達上限
If TotalTrans > LimitTrans Then
'終止清單列表的程式
For Each AppName In KillApp
KillApplication(AppName)
Next
End If
End If
End Sub
Sub ActiveFirewall()
'啟用XP防火牆(用來終止某程式網路連線)
Set objFirewall = CreateObject("HNetCfg.FwMgr")
Set objPolicy = objFirewall.LocalPolicy.CurrentProfile
objPolicy.FirewallEnabled = TRUE
End Sub
'樣式比對
Function RegExpTest(patrn, strng)
Dim regEx, Match, Matches
Set regEx = New RegExp
regEx.Pattern = patrn
regEx.IgnoreCase = True
regEx.Global = True
Set Matches = regEx.Execute(strng)
Dim MatchesArray()
Redim MatchesArray(0)
Dim Num
Num = 0
For Each Match In Matches
Redim Preserve MatchesArray(Num)
MatchesArray(Num) = Match.Value
Num = Num + 1
Next
RegExpTest = MatchesArray
End Function
'樣式比對
Function RegCount(patrn, strng)
Dim regEx, Match, Matches
Set regEx = New RegExp
regEx.Pattern = patrn
regEx.IgnoreCase = True
regEx.Global = True
Set Matches = regEx.Execute(strng)
RegExpTest = Matches.Count
End Function
'樣式比對
Function SubMatchTest(patrn, inpStr)
Dim oRe, oMatch, oMatches
Set oRe = New RegExp
oRe.Pattern = patrn
Set oMatches = oRe.Execute(inpStr)
Set oMatch = oMatches(0)
Dim retArray(5), Num
For Num = 0 To 5
retArray(Num) = oMatch.SubMatches(Num)
Next
SubMatchTest = retArray
End Function
'IP偵測
Function GetIP()
Dim ws : Set ws = CreateObject("WScript.Shell")
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim TmpFile : TmpFile = fso.GetSpecialFolder(2) & "/ip.txt"
Dim ThisLine, IP
If ws.Environment("SYSTEM")("OS") = "" Then
ws.run "winipcfg /batch " & TmpFile, 0, True
Else
ws.run "%comspec% /c ipconfig > " & TmpFile, 0, True
End If
Dim IPArray()
Dim Num
Num = 0
With fso.GetFile(TmpFile).OpenAsTextStream
Do While NOT .AtEndOfStream
ThisLine = .ReadLine
If InStr(ThisLine, "Address") <> 0 Then IP = Mid(ThisLine, InStr(ThisLine, ":") + 2)
If IP <> "" Then
If Asc(Right(IP, 1)) = 13 Then IP = Left(IP, Len(IP) - 1)
Redim Preserve IPArray(Num)
IPArray(Num) = IP
Num = Num + 1
IP = ""
End If
Loop
.Close
End With
'取得Gateway位址
Dim GW
GW = GetDefaultGateway()
GW = Left(GW, InStrRev(GW, "."))
retIP = vbNullString
For Each IP In IPArray
If (Left(IP, Len(GW)) = GW) Then
retIP = IP
Exit For
End If
Next
GetIP = retIP
fso.GetFile(TmpFile).Delete
Set fso = Nothing
Set ws = Nothing
End Function
'閘道偵測
Function GetDefaultGateway()
Dim ws : Set ws = CreateObject("WScript.Shell")
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim TmpFile : TmpFile = fso.GetSpecialFolder(2) & "/gw.txt"
Dim ThisLine, GW
ws.run "%comspec% /c route PRINT > " & TmpFile, 0, True
With fso.GetFile(TmpFile).OpenAsTextStream
Do While NOT .AtEndOfStream
ThisLine = .ReadLine
If InStr(ThisLine, "Default Gateway") <> 0 Then GW = Mid(ThisLine, InStr(ThisLine, ":") + 2)
If GW <> "" Then
If Asc(Right(GW, 1)) = 13 Then GW = Left(GW, Len(GW) - 1)
GW = RTrim(GW) : GW = LTrim(GW)
Exit Do
End If
Loop
.Close
End With
GetDefaultGateway = GW
fso.GetFile(TmpFile).Delete
Set fso = Nothing
Set ws = Nothing
End Function
'終止指定程式
Function KillApplication(ProcessName)
Dim objWMIService, objProcess, colProcess
Dim strComputer, strProcessKill
strComputer = "."
strProcessKill = "'" & ProcessName & "'"
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" _
& strComputer & "\root\cimv2")
Set colProcess = objWMIService.ExecQuery( _
"Select * from Win32_Process Where Name = " & strProcessKill )
For Each objProcess in colProcess
objProcess.Terminate()
Next
End Function
這個版本只是在網路流量快到上限時，停止網路應用程式，避免超流被鎖卡，對網管人員來說應該是無害的，只是遵守遊戲規則下讓動物園經營成果最佳化。其實當初在撰寫第一版時，就有想到第二版需要哪些改進，舉例來說，自動搜尋同一個網段中，哪些IP address沒有人用(透過過去一段時間的統計資料確定是沒人在用)，產生成一份IP清單，然後在一個IP流量快到上限時，自動切換到下一組IP，如此一來，假設每個IP每日限流3G，那麼只要能蒐集到五組，每日就有3G*5的總流量可用。
'Option Explicit
on error resume next
' [[宿網守護神]]測試版
'========================================== [[設定區-BEGIN]]
'初始化設定(請勿修改以下變數名稱)
'請依照需求修改以下各項設定資料
'IP位址設定()
'Dim YourIP : YourIP = "140.125.xxx.xxx" '手動設定
Dim YourIP : YourIP = GetIP() '自動偵測
'傳輸量上限(單位：MBytes)
Dim LimitTrans : LimitTrans = 3072 '預設3GBytes
'流量到達上限時，將自動終止KillApp列表中的程式
Dim KillApp : KillApp = Array("emule.exe", "flashget.exe", "DSLite.exe", "BitComet.exe", "abc.exe", "Bearshare.exe", "BitLord.exe", "bitspirit.exe", "btdownloadgui.exe", "dcplusplus.exe", "edonkey2000.exe", "g3torrent.exe", "kazaa.exe", "limewire.exe", "newsLeecher.exe", "Overnet.exe", "rufus.exe", "slsk.exe", "StrongDC.exe", "utorrent.exe", "winmx.exe")
'檢查流量的時間間隔(單位：分鐘)
Dim Refresh : Refresh = 10
'========================================== [[設定區-END]]
'========================================== [[主程式由此開始]]
'程式名稱
Dim ProgName : ProgName = "宿網守護神"
'Call ActiveFirewall
Call SetSchedule
Call Main
'工作排程
Function SetSchedule()
Dim WS
Dim ExeTime, AtExeTime
Set WS = CreateObject("WScript.Shell")
ExeTime = (DateAdd("n", Refresh, Now()))
AtExeTime = Hour(ExeTime) & ":" & Minute(ExeTime)
WS.Run "at " & AtExeTime & " """ & WScript.ScriptFullName & """"
End Function
'主程式執行區段
Sub Main()
'判斷IP設定是否正確
If YourIP = vbNullString Then
MsgBox "錯誤：無法取得主機位址。", , ProgName
Exit Sub
End If
'取得流量統計網頁
Dim Http, HtmlSource, URL
Set Http = CreateObject("msxml2.xmlhttp")
URL = "http://140.125.240.168/?action=ShowIP&IP=" & YourIP
Http.Open "GET", URL, False
Http.Send
HtmlSource = Http.ResponseText
'取得網頁原始資料
HtmlArray = RegExpTest("<tr><td>[0-9.-]+</td><td>[0-9.]+</td><td>[0-9.]+</td><td>[0-9.]+</td><td>[0-9.]+</td><td>[0-9.]+</td></tr>\n", HtmlSource)
'判斷是否有讀取到統計資料的HTML原始碼
If UBound(HtmlArray) = 0 Then
MsgBox "錯誤：無法取得統計資料，請重新檢查設定。", , ProgName
Exit Sub
End If
'取得統計數據資料，由HTML碼轉換為一串陣列
DataArray = SubMatchTest("<tr><td>([0-9.-]+)</td><td>([0-9.]+)</td><td>([0-9.]+)</td><td>([0-9.]+)</td><td>([0-9.]+)</td><td>([0-9.]+)</td></tr>", HtmlArray(0))
'今天的日期與資料日期
Dim NowDate, DataDate
NowDate = Date
DataDate = CDate(DataArray(0))
'日期比對，今日的流量統計已經上線才開始進行流量防護
If NowDate = DataDate Then
Dim TotalTrans '總流量
TotalTrans = CDbl(DataArray(1)) + CDbl(DataArray(2))
'流量已達上限
If TotalTrans > LimitTrans Then
'終止清單列表的程式
For Each AppName In KillApp
KillApplication(AppName)
Next
End If
End If
End Sub
Sub ActiveFirewall()
'啟用XP防火牆(用來終止某程式網路連線)
Set objFirewall = CreateObject("HNetCfg.FwMgr")
Set objPolicy = objFirewall.LocalPolicy.CurrentProfile
objPolicy.FirewallEnabled = TRUE
End Sub
'樣式比對
Function RegExpTest(patrn, strng)
Dim regEx, Match, Matches
Set regEx = New RegExp
regEx.Pattern = patrn
regEx.IgnoreCase = True
regEx.Global = True
Set Matches = regEx.Execute(strng)
Dim MatchesArray()
Redim MatchesArray(0)
Dim Num
Num = 0
For Each Match In Matches
Redim Preserve MatchesArray(Num)
MatchesArray(Num) = Match.Value
Num = Num + 1
Next
RegExpTest = MatchesArray
End Function
'樣式比對
Function RegCount(patrn, strng)
Dim regEx, Match, Matches
Set regEx = New RegExp
regEx.Pattern = patrn
regEx.IgnoreCase = True
regEx.Global = True
Set Matches = regEx.Execute(strng)
RegExpTest = Matches.Count
End Function
'樣式比對
Function SubMatchTest(patrn, inpStr)
Dim oRe, oMatch, oMatches
Set oRe = New RegExp
oRe.Pattern = patrn
Set oMatches = oRe.Execute(inpStr)
Set oMatch = oMatches(0)
Dim retArray(5), Num
For Num = 0 To 5
retArray(Num) = oMatch.SubMatches(Num)
Next
SubMatchTest = retArray
End Function
'IP偵測
Function GetIP()
Dim ws : Set ws = CreateObject("WScript.Shell")
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim TmpFile : TmpFile = fso.GetSpecialFolder(2) & "/ip.txt"
Dim ThisLine, IP
If ws.Environment("SYSTEM")("OS") = "" Then
ws.run "winipcfg /batch " & TmpFile, 0, True
Else
ws.run "%comspec% /c ipconfig > " & TmpFile, 0, True
End If
Dim IPArray()
Dim Num
Num = 0
With fso.GetFile(TmpFile).OpenAsTextStream
Do While NOT .AtEndOfStream
ThisLine = .ReadLine
If InStr(ThisLine, "Address") <> 0 Then IP = Mid(ThisLine, InStr(ThisLine, ":") + 2)
If IP <> "" Then
If Asc(Right(IP, 1)) = 13 Then IP = Left(IP, Len(IP) - 1)
Redim Preserve IPArray(Num)
IPArray(Num) = IP
Num = Num + 1
IP = ""
End If
Loop
.Close
End With
'取得Gateway位址
Dim GW
GW = GetDefaultGateway()
GW = Left(GW, InStrRev(GW, "."))
retIP = vbNullString
For Each IP In IPArray
If (Left(IP, Len(GW)) = GW) Then
retIP = IP
Exit For
End If
Next
GetIP = retIP
fso.GetFile(TmpFile).Delete
Set fso = Nothing
Set ws = Nothing
End Function
'閘道偵測
Function GetDefaultGateway()
Dim ws : Set ws = CreateObject("WScript.Shell")
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim TmpFile : TmpFile = fso.GetSpecialFolder(2) & "/gw.txt"
Dim ThisLine, GW
ws.run "%comspec% /c route PRINT > " & TmpFile, 0, True
With fso.GetFile(TmpFile).OpenAsTextStream
Do While NOT .AtEndOfStream
ThisLine = .ReadLine
If InStr(ThisLine, "Default Gateway") <> 0 Then GW = Mid(ThisLine, InStr(ThisLine, ":") + 2)
If GW <> "" Then
If Asc(Right(GW, 1)) = 13 Then GW = Left(GW, Len(GW) - 1)
GW = RTrim(GW) : GW = LTrim(GW)
Exit Do
End If
Loop
.Close
End With
GetDefaultGateway = GW
fso.GetFile(TmpFile).Delete
Set fso = Nothing
Set ws = Nothing
End Function
'終止指定程式
Function KillApplication(ProcessName)
Dim objWMIService, objProcess, colProcess
Dim strComputer, strProcessKill
strComputer = "."
strProcessKill = "'" & ProcessName & "'"
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" _
& strComputer & "\root\cimv2")
Set colProcess = objWMIService.ExecQuery( _
"Select * from Win32_Process Where Name = " & strProcessKill )
For Each objProcess in colProcess
objProcess.Terminate()
Next
End Function
大大你好剛剛使用了你的這隻誠是，可是他顯是抓不到正確的主機，是哪已錯了呢???
回覆刪除都照著大大這樣用
年久失修，取得流量資訊的部份需要依照現況去做修改喔！
回覆刪除年久失修，取得流量資訊的部份需要依照現況去做修改喔！
回覆刪除大大你好剛剛使用了你的這隻誠是，可是他顯是抓不到正確的主機，是哪已錯了呢???
回覆刪除都照著大大這樣用