CreateWeb. vbs code

'================================================ ========================================================
'
'The. NET PetShop Blueprint Application WebSite Setup
'
'File: CreateWeb. vbs
'Date: November 10,200 1
'
'Creates a new vdir for this project. Set vName to name of folder on disk
'That holds the files.
'
'================================================ ========================================================
'
& Apos; Copyright (C) 2001 Microsoft Corporation
'
'================================================ ========================================================
Option Explicit

Dim vPath
Dim scriptPath
Dim vName

VName = "PetShop" 'name of web to create

'*************************************** **************************************
'
'1. Create the IIS Virtual Directory
'
'*************************************** **************************************
'Get current path to folder and add web name to it
ScriptPath = left (Wscript. ScriptFullName, len (Wscript. ScriptFullName)-len (Wscript. ScriptName ))
VPath = scriptPath & "Web"

'Call to create vDir
CreateVDir (vPath)

'----------------------------------------------------------------------------
'
'Helper Functions
'
'-----------------------------------------------------------------------------

'''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''
'Creates a single Virtual Directory (code taken from mkwebdir. vbs and
'Changed for single vDir creation ).
'''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''
Sub CreateVDir (vPath)

Dim vRoot, vDir, webSite
On Error Resume Next

'Get the local host default web
Set webSite = findWeb ("localhost", "Default Web Site ")
If IsObject (webSite) = False then
Display "Unable to locate the Default Web Site"
Exit sub
Else
'Display webSite. name
End if

'Get the root
Set vRoot = webSite. GetObject ("IIsWebVirtualDir", "Root ")
If (Err <> 0) Then
Display "Unable to access root for" & webSite. ADsPath
Exit sub
Else
'Display vRoot. name
End IF

'Delete existing web if needed
VRoot. Delete "IIsWebVirtualDir", vName
VRoot. SetInfo
Err = 0' reset error

'Create the new web
Set vDir = vRoot. Create ("IIsWebVirtualDir", vName)
If (Err <> 0) Then
Display "Unable to create" & vRoot. ADsPath & "/" & vName &"."
Exit sub
Else
'Display vdir. name
End if

'Set properties on the new web
VDir. AccessRead = true
VDir. Path = vPath
VDir. Accessflags = 529
VDir. AppCreate False
If (Err <> 0) Then
Display "Unable to bind path" & vPath & "to" & vRoot. Name & "/" & vName & ". Path may be invalid ."
Exit sub
End If

'Commit changes
VDir. SetInfo
If (Err <> 0) Then
Display "Unable to save changes for" & vRoot. Name & "/" & vName &"."
Exit sub
End if

'Report all OK
WScript. Echo Now & "" & vName & "virtual directory" & vRoot. Name & "/" & vname & "created successfully ."
End Sub

'''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''
'Finds the specified web.
'''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''
Function findWeb (computer, webname)
On Error Resume Next

Dim websvc, site
Dim webinfo
Dim aBinding, binding

Set websvc = GetObject ("IIS: //" & computer & "/W3svc ")
If (Err <> 0) then
Exit function
End if
'First try to open the webname.
Set site = websvc. GetObject ("IIsWebServer", webname)
If (Err = 0) and (not isNull (site) then
If (site. class = "IIsWebServer") then
'Here we found a site that is a web server.
Set findWeb = site
Exit function
End if
End if
Err. clear
For each site in websvc
If site. class = "IIsWebServer" then
'
'First, check to see if the ServerComment
'Matches
'
If site. ServerComment = webname Then
Set findWeb = site
Exit function
End If
ABinding = site. ServerBindings
If (IsArray (aBinding) then
If aBinding (0) = "" then
Binding = Null
Else
Binding = getBinding (aBinding (0 ))
End if
Else
If aBinding = "" then
Binding = Null
Else
Binding = getBinding (aBinding)
End if
End if
If IsArray (binding) then
If (binding (2) = webname) or (binding (0) = webname) then
Set findWeb = site
Exit function
End If
End if
End if
Next
End Function

'''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''
'Gets binding info.
'''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''
Function getBinding (bindstr)

Dim one, two, ia, ip, hn

One = Instr (bindstr ,":")
Two = Instr (one + 1), bindstr ,":")

Ia = Mid (bindstr, 1, (one-1 ))
Ip = Mid (bindstr, (one + 1), (two-one)-1 ))
Hn = Mid (bindstr, (two + 1 ))

GetBinding = Array (ia, ip, hn)
End function

'''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''
'Displays error message.
'''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''
Sub Display (Msg)
WScript. Echo Now & ". Error Code:" & Hex (Err) & "-" & Msg
End Sub

'''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''
'Display progress/trace message.
'''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''
Sub Trace (Msg)
WScript. Echo Now & ":" & Msg
End Sub

'''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''
'Remove the web.
'''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''
Sub DeleteWeb (WebServer, WebName)
'Delete the exsiting web (ignore error if missing)
On Error Resume Next
Dim vDir
Display "deleting" & WebName

WebServer. Delete "IISWebVirtualDir", WebName
WebServer. SetInfo
If Err = 0 Then
DISPLAY "WEB" & WebName & "deleted ."
Else
Display "can't find" & webname
End If

End Sub