[nocode]
'////////////////////////////////////////////////////////////////////////////
'
' ISA Server Ad blocking import / export script
'
' Author: Jim Harrison
'
' Contact: jim@isatools.org
' www.ISAtools.org
'
' Created: 4/15/02
'
' Purpose: Creates a destination set and a site & content rule to block advertisements in
' web pages
'
' Usage: Either dbl-click it from Windows explorer or as "cscript ISA_Ads.vbs" from a
' command line
'
' History: 4/15/02 - First working version
' 4/20/02 - Fixed bug in SCR creation that would cause "conf can't be read"
' event log errors
' 12/17/02- Added HF65/SP1 fix (Q297324) to the script if file version is correct
'
' ToDo: Lots - see each section for small details
' Make it Enterprise-policy aware
' Make it merge-smart
'
'////////////////////////////////////////////////////////////////////////////
'so we don't lie to ourselves about our variables
Option Explicit
'global class for general use
Dim Tools
'Let's do this
Set Tools = New ISATools
Main
'Let's undo this
Set Tools = Nothing
'////////////////////////////////////////////////////////////////////////////
'
' Sub Main
'
' Purpose: Handles the inital ISA and XML object creation and chains off to other routines
' depending on the options chosen
'
' Input: None
'
' Output: XMLDocument and ISA objects for other routines
'
' ToDo: nothing?
'
'////////////////////////////////////////////////////////////////////////////
Sub Main
'ISA variables
Dim FPC
Dim ISA
'XML variables
Dim XMLDoc
'Create the ISA Server admin object
Set FPC = CreateObject ( "FPC.Root" )
FPC.Refresh
Set ISA = FPC.Enterprise
'create the XML document object
Set XMLDoc = CreateObject ( "Microsoft.XMLDom" )
XMLDoc.Async = False
'Let's get someone to make a decision
Select Case ImpExp
Case "import":
Import XMLDoc, ISA
FixAuth ISA
Case "export": Export XMLDoc, ISA
End Select
End Sub
'////////////////////////////////////////////////////////////////////////////
'
' Function ImpExp
'
' Purpose: Prompts the user for their choice of "Import" or "Export" and handles
' incorrect input
'
' Input: from the user via Tools class input routine
'
' Output: returns one of two valid options to caller
'
' ToDo: nothing?
'
'////////////////////////////////////////////////////////////////////////////
Function ImpExp ( )
Dim Answer
Answer = LCase ( Tools.GetAns ( Tools.ImpExp, "Import" ) )
Select Case Answer
Case "import", "export": ImpExp = Answer
Case Else:
Tools.ShowErr ( Tools.OptsErr )
ImpExp
End Select
End Function
'////////////////////////////////////////////////////////////////////////////
'
' Sub Import
'
' Purpose: Reads the input file and creates the destination set based on the data found
' there
'
' Input: XMLDoc and ISA objects from sub Main
' from the user via Tools class input routine
' from the xml file
'
' Output: creates a destination set in ISA with data from source XML
'
' ToDo: add capability to read CSV, TSV as well as XML
'
'////////////////////////////////////////////////////////////////////////////
Sub Import ( XMLDoc, ISA )
On Error Resume Next
Dim Ads
Dim DestinationSet
Dim Destination
Dim OldDest
Dim DType
Dim Ans
Dim InVal1
Dim InVal2
Dim InVal3
Const DestExist = &h80070002
Const Domain = 0
Const SingleIP = 1
Const IPRange = 2
Ans = Tools.GetAns ( Tools.SrcFileMsg, Tools.FileIn )
If Tools.FindFile ( Ans ) Then
Tools.FileIn = Ans
XMLDoc.Load ( Tools.FileIn )
Else
Tools.ShowErr ( Tools.FNFMsg )
Import XMLDoc, ISA
End If
Set Ads = XMLDoc.SelectSingleNode ( "Ads" )
'try to create the DS, and ask] for merge if fails
Set DestinationSet = MakeDs ( ISA )
'came back to do it; let's see what there is to do
For Each Destination in Ads.SelectNodes ( "Destination" )
DType = CInt ( Destination.GetAttribute ( "Type" ) )
Select Case DType
Case Domain
InVal1 = Destination.GetAttribute ( "DomainName" )
InVal2 = ""
Case SingleIP
InVal1 = Destination.GetAttribute ( "IP_From" )
InVal2 = ""
Case IPRange
InVal1 = Destination.GetAttribute ( "IP_From" )
InVal2 = Destination.GetAttribute ( "IP_To" )
End Select
InVal3 = Destination.GetAttribute ( "Path" )
DestinationSet.Add InVal1, InVal2, InVal3
Err.Clear
Next
DestinationSet.Save
MakeScr ISA
End Sub
'////////////////////////////////////////////////////////////////////////////
'
' Function MakeDs
'
' Purpose: creates a destination set named according to user input
'
' Input: ISA object from Sub Import
' from the user via Tools class input routine
'
' Output: returns a destination set object to sub Import
'
' ToDo: Ds Merge support
'
'////////////////////////////////////////////////////////////////////////////
Function MakeDs ( ISA )
On Error Resume Next
Dim Rtn
Dim Ans
Const DupDs = &h800700b7
Err.Clear
Rtn = Tools.GetAns ( Tools.DsQuery, Tools.DsName )
Set MakeDs = ISA.PolicyElements.DestinationSets.Add ( Rtn )
Select Case Err.Number
Case 0
Tools.DsName = Rtn
MakeDs.Description = Tools.DsDescr
Exit Function
Case DupDs
If Not Tools.AskYN ( Tools.DsDup ) Then
If Not Tools.AskYN ( Tools.QuitMsg ) Then Set MakeDs = MakeDs ( ISA )
End If
Err.Clear
Case Else
If Not Tools.AskYN ( Tools.DsErr ) Then WScript.Quit
End Select
Set MakeDs = MakeDs ( ISA )
Err.Clear
End Function
'////////////////////////////////////////////////////////////////////////////
'
' Function MakeScr
'
' Purpose: creates a Site and Content Rule associated with the chosen destination set
'
' Input: XMLDoc and ISA objects from Import subroutine
' from the user via Tools class input routine
'
' Output: creates a new S&C rule
'
' ToDo: option to change data in existing S&C Rule
' ability to import this as well
'
'////////////////////////////////////////////////////////////////////////////
Function MakeScr ( ISA )
On Error Resume Next
Dim Rtn
Dim TempScr
Const DupScr = &h800700b7
Const fpcArrayScope = 0
Const fpcEnterpriseScope = 0
Err.Clear
Rtn = Tools.GetAns ( Tools.ScrQuery, Tools.ScrName )
Set MakeScr = ISA.EnterprisePolicies.Item(0).SiteAndContentRules.Add ( Rtn )
' Wscript.Echo "MakeScr ( " & Rtn & " ) = 0x" & Hex ( Err.Number )
Select Case Err.Number
Case 0
Tools.ScrName = Rtn
Case Else
If Not Tools.AskYN ( Tools.ScrDup ) Then
WScript.Quit
Else
Set MakeScr = MakeScr ( ISA )
End If
End Select
MakeScr.Description = Tools.ScrDescr
MakeScr.Enabled = "True"
MakeScr.Action = "1"
MakeScr.AppliesToContentMethod = "0"
MakeScr.SetDestination "3", Tools.DsName
MakeScr.SetSchedule ( "Always" ), fpcEnterpriseScope
MakeScr.AppliesToMethod = "0"
MakeScr.Save
End Function
'////////////////////////////////////////////////////////////////////////////
'
' Sub Export
'
' Purpose: Creates an xml file containing the data in the chosen destination set
'
' Input: from the user via Tools class input routines
' properties of the specified destination set
'
' Output: creates an xml file according to user input
'
' ToDo: option to merge data in existing XML, CSV, TSV file
'
'////////////////////////////////////////////////////////////////////////////
Sub Export ( XMLDoc, ISA )
Dim Ads
Dim DestinationSet
Dim Destination
Dim Dest
Dim DType
Dim NewDest
Dim Rtn
'Destination set info
Const Domain = 0
Const SingleIP = 1
Const IPRange = 2
AskDestFile
Set DestinationSet = GetDs ( ISA )
XMLDoc.LoadXML ( "<Ads/>" )
Set Ads = XMLDoc.SelectSingleNode ( "Ads" )
Ads.AppendChild ( XMLDoc.CreateComment ( Tools.XMLComm ) )
For Each Destination in DestinationSet
Set Dest = XMLDoc.CreateNode ( 1, "Destination", "" )
Set NewDest = Ads.AppendChild ( Dest )
DType = Destination.Type
NewDest.SetAttribute "Type", DType
Select Case DType
Case Domain
NewDest.SetAttribute "DomainName", Destination.DomainName
Case SingleIP
NewDest.SetAttribute "IP_From", Destination.IP_From
Case IPRange
NewDest.SetAttribute "IP_From", Destination.IP_From
NewDest.SetAttribute "IP_To", Destination.IP_To
End Select
NewDest.SetAttribute "Path", Destination.Path
Next
XMLDoc.Save Tools.FileOut
Tools.Showinfo "Done with the Export thingy.." & vbCrLf & "Saved it as: " & Tools.FileOut
End Sub
'////////////////////////////////////////////////////////////////////////////
'
' Function AskDestFile
'
' Purpose: Prompts the user for a place to save the output file
' Verifies the existence of the file
'
' Input: from the user via Tools class input routines
'
' Output: returns a verified file location
'
' ToDo: error checking and file merge support
'
'////////////////////////////////////////////////////////////////////////////
Function AskDestFile
Dim Rtn
'find out where to save the exported data
AskDestFile = Tools.GetAns ( Tools.DestFileMsg, Tools.FileOut )
If Tools.FindFile ( AskDestFile ) Then
Tools.ShowErr ( Tools.FileExistsMsg )
AskDestFile
Else
Tools.FileOut = AskDestFile
End If
End Function
'////////////////////////////////////////////////////////////////////////////
'
' Function GetDs
'
' Purpose: Prompts the user for the Destination Set of choice
'
' Input: ISA object from Export function
' from the user via Tools class input routines
' verifies the specified destination set
'
' Output: returns a DestinationSet object
'
' ToDo: error checking
'
'////////////////////////////////////////////////////////////////////////////
Function GetDs ( ISA )
On Error Resume Next
Dim Rtn
'find out what Ds to export
Rtn = Tools.GetAns ( Tools.DsQuery, Tools.DsName )
Set GetDs = ISA.PolicyElements.DestinationSets.Item ( Rtn )
If Err Then
Tools.ShowErr ( Tools.DsErrMsg )
Set GetDs = GetDs ( ISA )
End If
On Error Goto 0
End Function
'////////////////////////////////////////////////////////////////////////////
'
' Sub FixAuth
'
' Purpose: Fixes auth popups if hp65 or SP1 is installed
'
' Input: ISA object from Main sub
'
' Output: Registry entry supporting ReturnDeniedIfAuthenticated
' Some msgboxes
'
' ToDo: ??
'
'////////////////////////////////////////////////////////////////////////////
Sub FixAuth ( ISA )
On Error Resume Next
Dim VerArray
Dim RealVer
Dim FileVer: FileVer = Array( 3, 0, 1200, 65 )
Dim BadVer: BadVer = False
Dim WshShell
Dim FSO
Dim InstlFolder
Dim Rtn
Dim i 'counter
Const W3Proxy = "W3Proxy.exe"
Const RegRoot = "HKLM\System\CurrentControlSet\Services\W3proxy\Parameters\"
Const RegEntry = "ReturnDeniedIfAuthenticated"
Const RegVal = &h00000001
Const RegType = "REG_DWORD"
Set FSO = CreateObject( "Scripting.FileSystemObject" )
Set WshShell = CreateObject( "WScript.Shell" )
InstlFolder = ISA.Servers.GetContainingServer.InstallationDirectory & "\"
'Find the interesting file version
RealVer = FSO.GetFileVersion( InstlFolder & W3Proxy )
If Err.Number <> 0 Then
Wscript.Echo "Error 0x" & Hex( Err.Number ) & _
" while trying to read the version of " & InstlFolder
Err.Clear
Exit Sub
End If
'make an array out of it
VerArray = Split( RealVer, "." )
If Err.Number <> 0 Then
Wscript.Echo "Error 0x" & Hex( Err.Number ) & _
" while trying to split " & RealVer
Err.Clear
Exit Sub
End If
'Compare the two arrays
If UBound( VerArray ) = UBound( FileVer ) Then
For i = 0 to UBound ( FileVer )
If CLng( FileVer( i ) ) > CLng( VerArray( i ) ) Then
BadVer = True
End If
If Err.Number <> 0 Then
Wscript.Echo "Error 0x" & Hex( Err.Number ) & _
" while trying evaluate FileVer and VerArray"
BadVer = True
End If
If BadVer Then Exit For
Next
Else
BadVer = True
End If
If Not BadVer Then
Rtn = WshShell.RegRead( RegRoot & RegEntry )
If ( Err.Number <> 0 ) Or ( Rtn = 0 ) Then
If MsgBox( Tools.AuthOkMsg, vbYesNo, Tools.ScriptTitle ) = vbYes Then
Err.Clear
WshShell.RegWrite RegRoot & RegEntry, RegVal, RegType
If Err.Number = 0 Then
If MsgBox( Tools.RstW3msg, vbYesNo, Tools.ScriptTitle ) = vbYes Then _
WshShell.Run "%ComSpec% /C net stop w3proxy && net start w3proxy", 10, False
Else
Wscript.Echo "Error 0x" & Hex( Err.Number ) & _
" while trying to update the registry with" & RegRoot & RegEntry & _
" = " & RegVal & "; " & RegType
Err.Clear
Exit Sub
End If
End If
End If
Else
Wscript.Echo InstlFolder & W3Proxy & " is not updated; file version = '" & RealVer & "'." & _
vbCrLf & "You need to install ISA SP1 (http://support.microsoft.com/?id=313139)"
Exit Sub
End If
On Error Goto 0
End Sub
'////////////////////////////////////////////////////////////////////////////
'
' Class ISATools
'
' Purpose: the heart and soul of this beastie
' contains all the common methods and properties needed by various subs
' and functions
'
' Input: from subs and functions
'
' Output: returns properties and method results to calling routines
'
' ToDo: depends on functionality added to main Script
'
'////////////////////////////////////////////////////////////////////////////
Class ISATools
'Script-specific text
Private Version
Public ScriptTitle
'general mesages
Private ImpExpMsg
Private OptsErrMsg
Private QuitMsg
'File option Msgs
Private CurrPath
Private OutFileMsg1
Private OutFileMsg2
Private InFileMsg
Private FileNotFound
'file option variables
Private OutFile
Private InFile
'destination set information
Private DsQueryMsg
Private DsDupMsg
Private DsErrMsg
Private Ds_Name
Private Ds_Descr
Private NoDsMsg
'Site & Content Rule info
Private ScrQueryMsg
Private ScrDupMsg
Private ScrErrMsg
Private Scr_Name
Private Scr_Descr
Private NoScrMsg
'Export XML data
Private XMLComment
' Auth-fix specific messages
Public AuthOkMsg
Public RstW3Msg
'Some useful objects
Private WshShell
Private FSO
'////////////////////////////////////////////////////////////////////////////
'
' Sub Class_Initialize
'
' Purpose: defines the default state for class properties
'
' Input: called by the "set Tools = New ISATools" command
'
' Output: Err.Success or Err.Failure to caller ( intrinsic )
'
' ToDo: depends on changes in class
'
'////////////////////////////////////////////////////////////////////////////
Private Sub Class_Initialize ( )
'Create those useful objects
Set WshShell = CreateObject ( "WScript.Shell" )
Set FSO = CreateObject ( "Scripting.FileSystemObject" )
'Script-specific text
Version = "2.1"
ScriptTitle = "ISA Server Ad import / export tool ver. " & Version
'General mesages
ImpExpMsg = "Do you want to Import or Export ad filter settings?"
OptsErrMsg = "Sorry; that's not a valid option"
QuitMsg = "Do you want to quit?"
'Export XML data
XMLComment = "You can hand edit this file, but please do not change the format" & _
vbCrLf & "as the script depends on the present schema." & _
vbCrLf & vbCrLf & "This is a list of ad sites that I've compiled over time." & _
vbCrLf & "Feel free to add to it as you please." & _
vbCrLf & "So that we can keep things current, please email your additions back to" & _
vbCrLf & "jim@isatools.org for posting to my scripting site." & _
vbCrLf & vbCrLf & "If you want to hand-edit this, feel free to grab XMLNotepad from" &_
vbCrLf & "http://msdn.microsoft.com/library/en-us/dnxml/html/xpsetup.exe"
'File variable defaults
CurrPath = Left ( WScript.ScriptFullName, Len ( WScript.ScriptFullName )-Len ( WScript.ScriptName ) )
OutFile = CurrPath & "ISA_Ads.xml"
InFile = OutFile
'File option Msgs
OutFileMsg1 = "Where do you want to put the export file?"
OutFileMsg2 = "That file already exists; please choose another file name or path"
InFileMsg = "Where is the source file?"
FileNotFound = "I can't locate that file; please check the path and re-enter"
'Ds messages
DsDupMsg = "That Destination Set already exists; would you like to create a new one?"
DsErrMsg = "Error 0x" & Hex ( Err.Number ) & " was encountered while trying to create the DS." & _
vbCrLf & "Would you like to try again?"
DsQuerymsg = "What Destination Set would you like to use?"
NoDsMsg = "The specified Destination Set was not found; please check your entry."
Ds_Name = "NoAds"
Ds_Descr = "Ad Blocking Destination Set"
'Scr messages
ScrDupMsg = "That Site & content Rule already exists; would you like to create another?"
ScrErrMsg = "Error 0x" & Hex ( Err.Number ) & " was encountered while trying to create the SCR." & _
vbCrLf & "Would you like to try again?"
ScrQuerymsg = "What would you like to name the new Site & Content Rule?"
NoScrMsg = "The specified Site & Content Rule was not found; please check your entry."
Scr_Name = Ds_Name
Scr_Descr = "Ad Blocking Site & Content Rule"
AuthOkMsg = "I need to make a change to the Web Proxy service " & _
"to avoid auth popups (http://support.microsoft.com/?id=297324)" & _
vbCrLf & "Would you like me to do that for you?"
RstW3msg = "You'll need to restart the Web Proxy service to pick up the changes made.. " & _
vbCrLf & "Would you like me to do that for you?"
End Sub
'////////////////////////////////////////////////////////////////////////////
'
' Sub Class_Terminate
'
' Purpose: destroys the class and its data
'
' Input: called by the "set Tools = Nothing" command
'
' Output: Err.Success or Err.Failure to caller ( intrinsic )
'
' ToDo: depends on changes in class
'
'////////////////////////////////////////////////////////////////////////////
Private Sub Class_Terminate ( )
Set WshShell = Nothing
Set FSO = Nothing
End Sub
'////////////////////////////////////////////////////////////////////////////
'
' Class properties
'
' Purpose: provide access to global data via class
'
' Input: only for "property Let" actions
'
' Output: only for "property Get" actions
'
' ToDo: depends on changes in class
'
'////////////////////////////////////////////////////////////////////////////
'Returns text held in ImpExpMsg variable
Public Property Get ImpExp
ImpExp = ImpExpMsg
End Property
'Returns text held in OutFile variable
Public Property Get FileOut
FileOut = OutFile
End Property
'Modifies text held in OutFile variable
Public Property Let FileOut ( InVal )
OutFile = InVal
End Property
'Returns text held in InFile variable
Public Property Get FileIn
FileIn = InFile
End property
'Modifies text held in InFile variable
Public Property Let FileIn ( InVal )
InFile = InVal
End Property
'Returns text held in OutFileMsg1 variable
Public Property Get DestFileMsg
DestFileMsg = OutFileMsg1
End Property
'Returns text held in OutFileMsg2 variable
Public Property Get FileExistsMsg
FileExistsMsg = OutFileMsg2
End Property
'Returns text held in InFileMsg variable
Public Property Get SrcFileMsg
SrcFileMsg = InFileMsg
End property
'Returns text held in FilenotFound variable
Public Property Get FNFMsg
FNFMsg = FileNotFound
End Property
'Returns text held in OptsErrMsg variable
Public Property Get OptsErr
OptsErr = OptsErrMsg
End Property
'Returns text held in DsQueryMsg variable
Public Property Get DsQuery
DsQuery = DsQueryMsg
End property
'Returns text held in NoDsmsg variable
Public Property Get DsNFMsg
DsNFMsg = NoDsMsg
End property
'Returns text held in DsDupMsg variable
Public Property Get DsDup
DsDup = DsDupMsg
End Property
'Returns text held in DsErrMsg variable
Public Property Get DsErr
DsErr = DsErrMsg
End Property
'Returns text held in Ds_Name variable
Public Property Get DsName
DsName = Ds_Name
End Property
'Modifies text held in Ds_Name variable
Public Property Let DsName ( InVal )
Ds_Name = InVal
End Property
'Returns text held in Ds_Descr variable
Public Property Get DsDescr
DsDescr = Ds_Descr
End property
'Returns text held in SrcQueryMsg variable
Public Property Get ScrQuery
ScrQuery = ScrQueryMsg
End property
'Returns text held in ScrDupMsg variable
Public Property Get ScrDup
ScrDup = ScrDupMsg
End Property
'Returns text held in ScrErrMsg variable
Public Property Get ScrErr
ScrErr = ScrErrMsg
End Property
'Returns text held in Scr_Name variable
Public Property Get ScrName
ScrName = Scr_Name
End Property
'Modifies text held in Scr_Name variable
Public Property Let ScrName ( InVal )
Scr_Name = InVal
End Property
'Returns text held in Scr_Descr variable
Public Property Get ScrDescr
ScrDescr = Scr_Descr
End property
'Returns text held in XMLComment variable
Public Property Get XMLComm
XMLComm = XMLComment
End property
'////////////////////////////////////////////////////////////////////////////
'
' Class Methods
'
' Purpose: provide common actions via the class
'
' Input: only as required by each function
'
' Output: depends on the function
'
' ToDo: depends on changes in class
'
'////////////////////////////////////////////////////////////////////////////
'Returns status of file existence ( True/False )
Public Function FindFile ( InVal )
On Error Resume Next
FindFile = FSO.GetFile ( InVal )
If Err Then
FindFile = False
Else
FindFile = True
End If
On Error Goto 0
End Function
'Returns status of user action when prompted with informational "Msg"
Public Function ShowInfo ( Msg )
ShowInfo = WshShell.Popup ( Msg, 2, ScriptTitle, vbInformation + vbOk )
End Function
'Returns status of user action when prompted with Error "Msg"
Public Function ShowErr ( Msg )
ShowErr = WshShell.Popup ( Msg, 2, ScriptTitle, vbExclamation + vbOk )
End Function
'Returns user input when prompted with "Msg" and provided with "Default" answer
Public Function GetAns ( Msg, Default )
Dim Answer
Answer = InputBox ( Msg, ScriptTitle, Default )
If Answer = "" Then
If AskYN ( QuitMsg ) Then WScript.Quit
GetAns Msg, Default
Else
GetAns = Answer
End If
End Function
'Returns status of user action ( Yes=True, No=False ) when prompted with "Msg"
Public Function AskYN ( Msg )
Select Case WshShell.Popup ( Msg, , ScriptTitle, vbQuestion + vbYesNo )
Case vbYes: AskYN = TRUE
Case vbNo: AskYN = FALSE
Case Else: AskYN = AskYN ( Msg )
End Select
End Function
End Class
[/nocode] |
