IIS 6.0 Add Host Headers in Bulk

February 23, 2012

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  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