IIS 6.0 Add Host Headers in Bulk

To add host headers in bulk (IIS 6.0) you will need these two scripts in C:\Inetpub\AdminScripts:

• AppendHostHeaders.vbs

• chglist.vbs

Additionally you will need an input csv called “c:\sites.csv” that follows this format (id, sitename must be first line):

id, sitename
1, www.test.com
2042610413, www2.two.testing.com
2042610413, www2.two.www.test.com
1, www.testing.com

Script: AppendHostHeaders.vbs

' AppendHostHeaders.vbs

' VBScript program to read a comma delimited file with a header line.
' Host headers will be added to all website identifiers listed in csv file
' If host header alredy exists no action will be taken for that line
'
' Script must be placed in C:\Inetpub\AdminScripts
' chglist.vbs must also exist in C:\Inetpub\AdminScripts
'
' Example Input file:
'id, sitename
'1, www.test.com
'2042610413, www2.two.testing.com
'2042610413, www2.two.www.test.com
'1, www.testing.com
'
' If your csv files does not live at c:\sites.csv please modify
' file to the correct path of your websites
'

Option Explicit

Dim adoCSVConnection, adoCSVRecordSet, strPathToTextfile
Dim strCSVFile, k
Dim id, sitename, commandToRun
Dim objShell, returnVal

' Specify path to CSV file.
strPathToTextFile = "c:\"

' Specify CSV file name.
strCSVFile = "sites.csv"

''''' This function will determine if the host header already exists for a site
''''  
''''  usage:    
''''  Dim returnVal
''''  returnVal = doesHostExist (1, "Host.domain.com")
''''
''''  if host exists a 1 will return
''''  
''''  otherwise a 0 or nothing will return

Function doesHostExist ( objID, objSite )

Dim commandToRun, objFSO, objTextFile, strText

Set objShell = CreateObject("WScript.Shell")

commandToRun= "cmd /c adsutil.vbs GET W3SVC/" & objID & "/ServerBindings | find /C "  & chr(34) & objSite  & chr(34) &  " > c:\temp\1.txt"
objShell.run commandToRun, 0, true

Const ForReading = 1

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO.OpenTextFile _
    ("c:\temp\1.txt", ForReading)

strText = objTextFile.ReadAll
objTextFile.Close
doesHostExist=strText
End Function
''''''

' Open connection to the CSV file.
'Microsoft.ACE.OLEDB.12.0
Set adoCSVConnection = CreateObject("ADODB.Connection")
Set adoCSVRecordSet = CreateObject("ADODB.Recordset")

' Open CSV file with header line.
adoCSVConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
    "Data Source=" & strPathtoTextFile & ";" & _
    "Extended Properties=""text;HDR=YES;FMT=Delimited"""

adoCSVRecordset.Open "SELECT * FROM " & strCSVFile, adoCSVConnection

' Read the CSV file.
Do Until adoCSVRecordset.EOF
    ' Display all fields by name.
    For k = 0 To adoCSVRecordset.Fields.Count - 1
        'Wscript.Echo adoCSVRecordset.Fields(k).Name _
        '    & " = " & adoCSVRecordset.Fields(k).Value
        If adoCSVRecordset.Fields(k).Name = "id" Then id = adoCSVRecordset.Fields(k).Value
        If adoCSVRecordset.Fields(k).Name = "sitename" Then sitename = adoCSVRecordset.Fields(k).Value
    Next
    returnVal = ""
    returnVal = doesHostExist (id, sitename)
	if len(sitename) > 5 then
		If CBool(returnVal) = false Then
			commandToRun= "cscript chglist.vbs W3SVC/" & id & "/ServerBindings FIRST " & chr(34) & ":80:" & sitename & chr(34) & " /INSERT /COMMIT"
			Set objShell = CreateObject("WScript.Shell")
			objShell.run commandToRun, 0, true
			Wscript.Echo "site: " & id & "  -- Added " & sitename
		Else
			Wscript.Echo "site: " & id & "  -- Already Exists " & sitename
		End If
    else
		Wscript.Echo "sitename: " & sitename & "is too short"

	end if
    id = ""
    sitename = ""
    commandToRun = ""
    adoCSVRecordset.MoveNext
Loop

' Clean up.
adoCSVRecordset.Close
adoCSVConnection.Close

Script chglist.vbs

' Allows append/insert/remove of specific elements from an IIS "List" type node
' i.e. ScriptMap, HttpError, ServerBindings
'
' Origin : http://blogs.msdn.com/David.Wang/archive/2004/12/02/273681.aspx
' Version: December 1 2004
'
Option Explicit
On Error Resume Next

const ERROR_SUCCESS             = 0
const ERROR_PATH_NOT_FOUND      = 3
const ERROR_INVALID_PARAMETER   = 87
const LIST_OP_FIRST             = "FIRST"
const LIST_OP_LAST              = "LAST"
const LIST_OPTION_REPLACE       = 0
const LIST_OPTION_INSERT        = 1
const LIST_OPTION_REMOVE        = 2
const LIST_OPTION_ALL           = 4
const LIST_OPTION_RECURSE       = 8

Dim CRLF
CRLF = CHR(13) & CHR(10)
Dim strHelp
strHelp = "Edit/Replace IIS metabase LIST properties" & CRLF &_
          CRLF &_
          WScript.ScriptName & " PropertyPath ExistValue NewValue [Options]" & CRLF &_
          CRLF &_
          "Where:" & CRLF &_
          "    PropertyPath IIS metabase property path whose data type is LIST." & CRLF &_
          "                 i.e. W3SVC/ScriptMaps, W3SVC/HttpErrors" & CRLF &_
          "    ExistValue   Value to case-insensitive literal match against existing" & CRLF &_
          "                 LIST elements." & CRLF &_
          "        FIRST    - matches the first LIST element." & CRLF &_
          "        LAST     - matches the last LIST element." & CRLF &_
          "    NewValue     New value that replaces the matched the LIST element." & CRLF &_
          "Options:" & CRLF &_
          "    /INSERT      Insert  before LIST element matching ." & CRLF &_
          "    /REMOVE      Remove LIST element matching ." & CRLF &_
          "    /ALL         Operate on ALL matching . Default is first match." & CRLF &_
          "    /REGEXP      Use  as RegExp to match. Default is literal." & CRLF &_
          "    /RECURSE     Recursively perform the operation underneath ." & CRLF &_
          "    /VERBOSE     Give more status/output." & CRLF &_
          "    /COMMIT      Actually perform changes. Default only shows." & CRLF &_
          ""

dim Debug
Debug = true
dim Verbose
Verbose = false
dim reMatch
reMatch = false

Dim strServer
Dim strNamespace
Dim strSchemaNamespace
Dim strNodeSyntax
Dim objNode

Dim nOperationType
Dim strNormalizedPath
Dim strPropertyPath
Dim strPropertyName
Dim strPropertyExistValue
Dim strPropertyNewValue

Dim i,j

'
' Start of script
'
strServer = "localhost"
strNamespace = "IIS://" & strServer
strSchemaNamespace = strNamespace & "/" & "Schema"

'
' Parse the commandline
'
If WScript.Arguments.Count < 3 Then
    Err.Number = ERROR_INVALID_PARAMETER
    HandleError "Insufficient number of arguments." & CRLF &_
                CRLF &_
                strHelp &_
                ""
End If

nOperationType = LIST_OPTION_REPLACE

For i = 0 To WScript.Arguments.Count - 1
    Select Case UCase( WScript.Arguments( i ) )
        Case "/INSERT"
            nOperationType = nOperationType Or LIST_OPTION_INSERT
        Case "/REMOVE"
            nOperationType = nOperationType Or LIST_OPTION_REMOVE
        Case "/ALL"
            nOperationType = nOperationType Or LIST_OPTION_ALL
        Case "/RECURSE"
            nOperationType = nOperationType Or LIST_OPTION_RECURSE
        Case "/COMMIT"
            Debug = false
        Case "/VERBOSE"
            Verbose = true
        Case "/REGEXP"
            reMatch = true
        Case Else
            If ( i = 0 ) Then
                '
                ' Split out PropertyName and its ParentPath from PropertyPath
                '
                Err.Clear
                strNormalizedPath = NormalizePath( WScript.Arguments( 0 ) )
                HandleError "Failed to normalize PropertyPath."

                j = InstrRev( strNormalizedPath, "/", -1, 0 )

                If ( j = 0 Or j = 1 ) Then
                    Err.Number = ERROR_PATH_NOT_FOUND
                    HandleError "Invalid PropertyPath."
                End If

                Err.Clear
                strPropertyPath = NormalizePath( Mid( strNormalizedPath, 1, j - 1 ) )
                HandleError "Failed to retrieve/normalize PropertyPath."

                Err.Clear
                strPropertyName = NormalizePath( Mid( strNormalizedPath, j + 1 ) )
                HandleError "Failed to retrieve/normalize PropertyName."
            ElseIf ( i = 1 ) Then
                '
                ' The existing match value
                '
                strPropertyExistValue = Replace( UCase( WScript.Arguments( 1 ) ), "``", """" )
            ElseIf ( i = 2 ) Then
                '
                ' The new replace value
                '
                strPropertyNewValue = Replace( WScript.Arguments( 2 ), "``", """" )
            Else
                Err.Number = ERROR_INVALID_PARAMETER
                HandleError "Unknown parameter " & WScript.Arguments( i ) & CRLF &_
                            CRLF &_
                            strHelp &_
                            ""
            End If
    End Select
Next

LogVerbose "OpType       = " & nOperationType
LogVerbose "PropertyPath = " & strPropertyPath
LogVerbose "PropertyName = " & strPropertyName
LogVerbose "ExistValue   = " & strPropertyExistValue
LogVerbose "NewValue     = " & strPropertyNewValue

'
' Check the data type for the given property
' If it is not LIST, do not process any further
'
Err.Clear
Set objNode = GetObject( strSchemaNamespace & "/" & strPropertyName )
HandleError "Cannot read schema for property " & strPropertyName
strNodeSyntax = UCase( objNode.Syntax )

LogVerbose "Syntax       = " & strNodeSyntax
LogVerbose ""

Select Case strNodeSyntax
    Case "LIST"
        '
        ' Finally, we are ready to do some real work
        '
        Err.Clear
        Err.Number = HandleListOps( nOperationType, strPropertyPath, strPropertyName, strPropertyExistValue, strPropertyNewValue, ( nOperationType And LIST_OPTION_RECURSE ) <> 0 )
        HandleError ""
    Case Else
        Err.Clear
        Err.Number = ERROR_PATH_NOT_FOUND
        HandleError "Cannot handle " & strPropertyPath & "/" & strPropertyName & " with type " & strNodeSyntax
End Select

'
' End of script
'

'
' Sub routines and functions
'
Sub HandleError( errorDescription )
    If ( Err.Number <> 0 ) Then
        If ( IsEmpty( errorDescription ) ) Then
            LogEcho Err.Description
        Else
            LogEcho errorDescription
        End If

        WScript.Quit Err.Number
    End If
End Sub

Function NormalizePath( strInput )
    '
    ' Replace all \ with /
    '
    strInput = Replace( strInput, "\", "/", 1, -1 )

    '
    ' Replace all // with /
    '
    Do
        strInput = Replace( strInput, "//", "/", 1, -1 )
    Loop While ( Instr( strInput, "//" ) <> 0 )

    '
    ' Removing leading and trailing /
    '
    If ( Left( strInput, 1 ) = "/" ) Then
        strInput = Right( strInput, Len( strInput ) - 1 )
    End If

    If ( Right( strInput, 1 ) = "/" ) Then
        strInput = Left( strInput, Len( strInput ) - 1 )
    End If

    NormalizePath = strInput
End Function

Function HandleListOps( OpType, strPropertyPath, strPropertyName, strPropertyExistValue, strPropertyNewValue, bRecurse )
    On Error Resume Next
    Dim objNode, objNodeAttribute
    Dim objList
    Dim objElement
    Dim objNewArray
    Dim PerformedOperation
    Dim Operation
    Dim re
    Dim reMatched
    Dim i, j

    Err.Clear
    Set objNode = GetObject( strNamespace & "/" & strPropertyPath )
    objList = objNode.Get( strPropertyName )

    If ( Err.Number <> 0 Or IsEmpty( objList ) ) Then
        LogEcho "Failed to retrieve " & strPropertyPath & "/" & strPropertyName
        HandleListOps = Err.Number
        Exit Function
    End If


    Err.Clear
    Set objNodeAttribute = objNode.GetPropertyAttribObj(strPropertyName)
    HandleError "Failed to retrieve Attributes for " & strPropertyPath & "/" & strPropertyName

    If ( objNodeAttribute.IsInherit = true ) Then
        LogEcho strPropertyPath & "/" & strPropertyName & " (Inherited)"

        If ( bRecurse = true ) Then
            LogEcho( "Ignoring inherited property for Recursive Modification" )
            Exit Function
        End If
    Else
        LogEcho strPropertyPath & "/" & strPropertyName
    End If


    '
    ' j is the count of elements in objNewArray
    ' So that we can resize it to the right size in the end
    '
    j = 0

    '
    ' Size objNewArray to maximum possible size up-front, later shrink it
    '
    Redim objNewArray( UBound( objList ) + UBound( objList ) + 1 )

    '
    ' PerformedOperation indicates whether something has matched and already
    ' operated upon, in this session.  Start with 'not yet' = 0
    '
    PerformedOperation = 0

    '
    ' Setup the RegExp match based on the existing value to search for
    '
    Set re = new RegExp
    re.Pattern = strPropertyExistValue
    re.IgnoreCase = true
    re.Global = true

    '
    ' Do this test outside of IF conditional because on error resume next
    ' turns off failures due to incorrect Pattern
    '
    Err.Clear
    reMatched = re.Test( objElement )
    If ( Err.Number <> 0 Or reMatch = false ) Then
        reMatched = false
    End If

    LogVerbose "Original:"

    For i = LBound( objList ) To UBound( objList )
        objElement = objList( i )
        'LogVerbose i & "(" & j & ")" & ": " & objElement

        If ( ( ( ( strPropertyExistValue = LIST_OP_FIRST ) And ( i = LBound( objList ) ) ) Or _
               ( ( strPropertyExistValue = LIST_OP_LAST  ) And ( i = UBound( objList ) ) ) Or _
               ( ( reMatch = false ) And ( Instr( UCase( objElement ), strPropertyExistValue ) > 0 ) ) Or _
               ( reMatched = true ) _
             ) _
             And _
             ( ( ( OpType And LIST_OPTION_ALL ) <> 0 ) Or ( PerformedOperation = 0 ) ) _
           ) Then
            Operation = "Replace "

            If ( ( OpType And LIST_OPTION_REMOVE ) <> 0 ) Then
                'Don't copy this element for deletion
                Operation = "Remove "
            Else
                objNewArray( j ) = strPropertyNewValue
                j = j + 1

                If ( ( OpType And LIST_OPTION_INSERT ) <> 0 ) Then
                    Operation = "Insert "
                    objNewArray( j ) = objElement
                    j = j + 1
                End If
            End If

            PerformedOperation = 1
        Else
            Operation = ""
            objNewArray( j ) = objElement
            j = j + 1
        End If

        LogVerbose Operation & objElement
    Next

    '
    ' Resize the final array to the correct size prior to SetInfo
    '
    ReDim Preserve objNewArray( j - 1 )

    LogVerbose "New:"

    For i = LBound( objNewArray ) To UBound( objNewArray )
        LogDebug i & ": " & objNewArray( i )
    Next

    If ( Debug = false ) Then
        If ( PerformedOperation = 1 ) Then
            Err.Clear
            objNode.Put strPropertyName, objNewArray
            objNode.SetInfo
            HandleError "Failed to SetInfo " & strPropertyPath & "/" & strPropertyName
            LogEcho "SUCCESS: Updated " & strPropertyPath & "/" & strPropertyName
        Else
            LogEcho "SUCCESS: Nothing to update"
        End If
    Else
        If ( PerformedOperation = 1 ) Then
            LogEcho "DEBUG: Matched. Did not SetInfo"
        Else
            LogEcho "SUCCESS: No Match. Did not SetInfo"
        End If
    End If

    If ( bRecurse = true ) Then
        For Each objElement In objNode
            LogEcho ""
            HandleListOps = HandleListOps( OpType, NormalizePath( Mid( objElement.AdsPath, Len( strNamespace ) + 1 ) ), strPropertyName, strPropertyExistValue, strPropertyNewValue, bRecurse )
        Next
    End If

    HandleListOps = 0
End Function

Sub LogEcho( str )
    WScript.Echo str
End Sub

Sub LogDebug( str )
    If ( Debug = true ) Then
        LogEcho str
    End If
End Sub

Sub LogVerbose( str )
    If ( Verbose = true ) Then
        LogEcho str
    End If
End Sub