' 查找所有的对象
ies = GetInternetExplorerObjects()

' 随便取一个窗口，演示手工录入脚本进行调试
Set d = ies(0).document
MsgBox "在弹出的命令行窗口中录入一些ＶＢＳ脚本（可多行），在此页面执行：" & vbCrLf & vbCrLf & d.title & vbCrLf & d.location.href
AppendScript d, 0, 0, InputScript()
MsgBox "现在重新录入一些ＪＳ脚本，在此页面执行：" & vbCrLf & vbCrLf & d.title & vbCrLf & d.location.href
AppendScript d, 1, 0, InputScript()

' 演示IE浏览内容监控，此实例为监控“批处理之家”网站
vbs = "MsgBox ""禁止访问“批处理之家”网站！此页面即将倒置："" & document.title, 16, ""网警提示"""
js = "document.body.style.filter = 'progid:DXImageTransform.Microsoft.BasicImage(grayscale=0,xray=0,mirror=1,invert=0,opacity=1,rotation=2)';"
MsgBox "下面即将开始监控，要停止请在任务管理器结束进程 wscript.exe 。", 32
ON ERROR RESUME NEXT
Do
	ies = GetInternetExplorerObjects()
    ' 遍历
    For i = 0 To ubound(ies)
        If isObject(ies(i)) Then
            Set objIE = ies(i)
            Set document = objIE.Document
            ' 判断此页面的域名
            If UCase(document.domain) = "BATHOME.NET" Then
                ' 改变标题
                objIE.ExecWB 28, 0, "禁止访问", 0
                ' 插入VBSCRIPT脚本并执行
                AppendScript document, 0, 0, vbs
                ' 插入JAVASCRIPT脚本并执行
                AppendScript document, 1, 0, js
            End If
        End If
    Next
    ' 10秒钟检查一次
    WScript.Sleep 10000
Loop


'===============================================================================


'*** 获取所有包含网页文档的窗口
'*-----------------------------------
Function GetInternetExplorerObjects()
    Dim ie()
    ReDim ie(0)
    Dim sa, windows, window
    Set sa = CreateObject("Shell.Application")
    Set windows = sa.Windows
    For Each window In windows
        If UCase(TypeName(window.document)) = "HTMLDOCUMENT" Then
            Dim obj
            Set obj = window
            If isObject(ie(UBound(ie))) Then ReDim Preserve ie(UBound(ie) + 1)
            Set ie(UBound(ie)) = obj        
        End If
    Next
    GetInternetExplorerObjects = ie    
End Function


'*** 添加一段脚本到网页并且立即执行
'* document        :  一个 document 对象实例
'* scriptType      :  0 = VBScript, 1 = JavaScript
'* isTextOrSource  :  0 = 脚本, 1 = 脚本文件
'* content         :  源代码 / 脚本文件路径或者远程URL
'*------------------------------------------------------------------
Function AppendScript(document, scriptType, isTextOrSource, content)
    Dim sType
    Select Case scriptType
        Case 0        sType = "text/vbscript"
        Case 1        sType = "text/javascript"
        Case Else    sType = ""
    End Select
    Set script = document.createElement("script")
    script.setAttribute "type", sType
    If isTextOrSource = 1 Then
        script.src  = content
    Else
        script.text = content
    End If
    Set AppendScript = document.appendChild(script)
End Function


'*** 打开一个命令行界面获取输入内容
'*---------------------------------
Function InputScript()
    Dim s, ws, exe
    s = "TITLE 输完几行代码回车后，按Ctrl+Z回车，或者直接关闭本窗口。& TYPE CON"
    Set ws = CreateObject("WScript.Shell")
    Set exe = ws.Exec("CMD /C " & s)
    InputScript = exe.StdOut.ReadAll()
End Function
复制代码

'防止Google对搜索结果重定向

On Error Resume Next
Set sh = CreateObject("Shell.Application")
do
    RemoveGoogleRedirect
    WScript.sleep 1000*3
loop

function RemoveGoogleRedirect()
  Dim wnds, wnd, document, el, sc
  Set wnds = sh.Windows()
  For Each wnd In wnds
    if InStr(1,wnd.LocationURL,"http://www.google.com.hk",1) then
        set document = wnd.document
        if document.readyState="complete" then
            set el = Nothing
            set el = document.getElementById("RemoveGoogleRedirect")
            if el Is Nothing then
                set sc = document.createElement("script")
                sc.id = "RemoveGoogleRedirect"
                sc.text = "function rwt(){return true;}"
                document.body.appendChild(sc)
            end if
        end if
    End If
  Next
end function
复制代码