Source code of Windows XP (NT5)
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

1232 lines
39 KiB

<?xml version="1.0"?>
<package>
<component id="IIS Script Helper">
<?component error="true" debug="true" ?>
<registration progid="Microsoft.IIsScriptHelper" classid="{BC47120F-1612-4CA5-A89F-FDFF76C28AB6}" description="IIS Script Helper" version="1.0">
</registration>
<public>
<property internalname="WScript" name="ScriptHost">
</property>
<property name="ProviderObj">
<get/>
</property>
<property name="Switches">
<get/>
</property>
<property internalname="aNamedArguments" name="NamedArguments">
<get/>
</property>
<property name="GlobalHelpRequested">
<get/>
</property>
<property name="FSObj">
<get/>
</property>
<property name="ERROR_UNKNOWN_SWITCH">
<get/>
</property>
<property name="ERROR_NOT_ENOUGH_ARGS">
<get/>
</property>
<method name="BuildNameSpace">
<parameter name="strPath"/>
</method>
<method name="CheckScriptEngine">
</method>
<method name="CreateFSDir">
<parameter name="strRoot"/>
</method>
<method name="DumpCmdLineOptions">
</method>
<method name="FindSite">
<parameter name="strType"/>
<parameter name="aArgs"/>
</method>
<method name="GetAbsolutePath">
<parameter name="strPath"/>
</method>
<method name="GetEnvironmentVar">
<parameter name="strVar"/>
</method>
<method name="GetSwitch">
<parameter name="strSwitchName"/>
</method>
<method name="InitAuthentication">
<parameter name="Server"/>
<parameter name="User"/>
<parameter name="Password"/>
</method>
<method name="IsHelpRequested">
<parameter name="strSwitch"/>
</method>
<method name="IsHelpSwitch">
<parameter name="strSwitch"/>
</method>
<method name="IsValidIPAddress">
<parameter name="strIPAddress"/>
</method>
<method name="IsValidPortNumber">
<parameter name="intPort"/>
</method>
<method name="NormalizeFilePath">
<parameter name="strPath"/>
</method>
<method name="ParseBindings">
<parameter name="bindings"/>
</method>
<method name="ParseCmdLineOptions">
<parameter name="ArgObj"/>
<parameter name="strCmdLine"/>
</method>
<method name="WMIConnect">
<parameter name="strServer"/>
<parameter name="strUser"/>
<parameter name="strPassword"/>
</method>
</public>
<object id="FSObj" progid="Scripting.FileSystemObject" events="false"/>
<object id="ShellObj" progid="WScript.Shell" events="false"/>
<object id="NetObj" progid="WScript.Network" events="false"/>
<object id="DictObj" progid="Scripting.Dictionary" events="false"/>
<resource id="ProductInfoRegValue">ProductSuite</resource>
<resource id="ProductInfoRegKey">System\CurrentControlSet\Control\ProductOptions</resource>
<resource id="L_RegProc_ErrorMessage">Error querying the WMI Registry provider.</resource>
<resource id="L_OnlyIIS6Supported_ErrorMessage">The IIS Admin scripts only support IIS 6.0.</resource>
<resource id="L_CredentialsIgnored_Message">Using local machine will cause supplied credentials to be ignored.</resource>
<resource id="L_Warning_Text">WARNING</resource>
<resource id="L_WriteReg_ErrorMessage">Error trying to write the registry settings!</resource>
<resource id="L_MetabasePath_Message">Metabase Path</resource>
<resource id="L_SiteName_Text">Site Name</resource>
<resource id="L_NotUnique2_Message">identify these sites:</resource>
<resource id="L_NotUnique1_Message">The following site names are not unique. Please use the Metabase Paths to</resource>
<resource id="L_Done_Message">Done.</resource>
<resource id="L_ConnectObject_ErrorMessage">Error trying to get WMI SWbemService object</resource>
<resource id="L_Error_ErrorMessage">Error</resource>
<resource id="L_Locator_ErrorMessage">Error trying to get WMI SWbemLocator object</resource>
<resource id="L_Connecting_Message">Connecting to server ... </resource>
<resource id="L_OkWriteReg_Message">Successfully registered CScript</resource>
<resource id="L_UseCScript_Message">To run this script type: "CScript.Exe IIsCnfg.vbs [params]"</resource>
<resource id="CIMv2_NAMESPACE">root/CIMv2</resource>
<resource id="WMI_NAMESPACE">root/MicrosoftIISv2</resource>
<resource id="LOCATOR_OBJ">WbemScripting.SWbemLocator</resource>
<resource id="WBemImpersonationLevelImpersonate">3</resource>
<resource id="WQL">WQL</resource>
<resource id="L_RegisterCScript_Message">Register CScript</resource>
<resource id="L_AskChangeScriptProcessor_Message">Would you like to register CScript as your default host for VBscript?</resource>
<resource id="L_WrongScriptProcessor_Message">This script does not work with WScript.</resource>
<resource id="CONST_NO_MATCHES_FOUND">0</resource>
<resource id="PATTERN_VBPRINTF">%\d</resource>
<script id="IIs Script Helper" language="VBScript">
<![CDATA[
'
' Copyright (c) Microsoft Corporation. All rights reserved.
'
' VBScript Source File
'
' Script Component Name: IIsScHlp.wsc
'
Option Explicit
On Error Resume Next
Dim LocatorObj, ProviderObj
Dim dictSwitches, dictHelpRequested
Dim aNamedArguments
Dim fGlobalHelpRequested
Dim strServer, strUser, strPassword
' Parser errors
Const ERROR_NOT_ENOUGH_ARGS = 1
Const ERROR_UNKNOWN_SWITCH = 2
' Object initialization
fGlobalHelpRequested = False
Set LocatorObj = Nothing
Set ProviderObj = Nothing
Set dictSwitches = Nothing
Set dictHelpRequested = Nothing
aNamedArguments = Array()
' Property get methods
Function get_ProviderObj()
Set get_ProviderObj = ProviderObj
End Function
Function get_Switches()
Set get_Switches = dictSwitches
End Function
Function get_aNamedArguments()
get_aNamedArguments = aNamedArguments
End Function
Function get_GlobalHelpRequested()
get_GlobalHelpRequested = fGlobalHelpRequested
End Function
Function get_FSObj()
Set get_FSObj = FSObj
End Function
Function get_ERROR_UNKNOWN_SWITCH()
get_ERROR_UNKNOWN_SWITCH = ERROR_UNKOWN_SWITCH
End Function
Function get_ERROR_NOT_ENOUGH_ARGS()
get_ERROR_NOT_ENOUGH_ARGS = ERROR_NOT_ENOUGH_ARGS
End Function
'''''''''''''''''''''''''''''''''
' Class Definitions
''''''''''''''''''''''
Class OptionItem
Public Name
Public ShortName
Public RequiredArgs
Public GroupID
Public fSearchChildren
Public aChildOptions
Public Sub SetInfo(strName, strShortName, strReqArg, intGroupID)
If Left(strName, 1) = "[" Then
Name = Mid(strName, 2)
Else
Name = CStr(strName)
End If
ShortName = CStr(strShortName)
If Right(strReqArg, 1) = "]" Then
RequiredArgs = Mid(strReqArg, 1, Len(strReqArg) - 1)
Else
RequiredArgs = CStr(strReqArg)
End If
GroupID = CInt(intGroupID)
fSearchChildren = False
aChildOptions = Empty
End Sub
Public Sub AddChild(element)
If IsEmpty(aChildOptions) Then
aChildOptions = Array(element)
Else
ReDim Preserve aChildOptions(Ubound(aChildOptions) + 1)
Set aChildOptions(Ubound(aChildOptions)) = element
End If
End Sub
Public Sub Visit()
' This options was recognized. If it has child options, make them available
If Not IsEmpty(aChildOptions) Then
fSearchChildren = True
End If
End Sub
End Class
Class Options
Private intOptionIndex
Public aOptions
Public Sub SetOptions(strCmdLineKeys)
Dim aCmdLineOptions, aOption
Dim intCount, i
aCmdLineOptions = Split(strCmdLineKeys, ";")
ReDim aOptions(UBound(aCmdLineOptions))
intOptionIndex = LBound(aCmdLineOptions)
InsertOptionsInArray aOptions, aCmdLineOptions, Empty
End Sub
Public Function GetInfo(strName)
Set GetInfo = Lookup(aOptions, strName)
End Function
'
' Private functions/subrotines
'
Private Function Lookup(aArray, strName)
Dim oOption
Dim oResult
Dim i
Set oResult = Nothing
For i = LBound(aArray) to UBound(aArray)
Set oOption = aArray(i)
If UCase(oOption.Name) = UCase(strName) Or UCase(oOption.ShortName) = UCase(strName) Then
Set oResult = oOption
Exit For
End If
If oOption.fSearchChildren Then
Set oResult = Lookup(oOption.aChildOptions, strName)
If Not oResult Is Nothing Then
Exit For
End If
End If
Next
Set Lookup = oResult
End Function
' InsertOptionsInArray(
' array to receive the options,
' options array to be parser,
' start index of the options array above,
' current scope (-1 to root)
')
Private Sub InsertOptionsInArray(aArray, aCmdLineOptions, intScope)
Dim intCount, i
Dim aOption, oOption
intCount = 0
Do While intOptionIndex <= UBound(aCmdLineOptions)
aOption = Split(aCmdLineOptions(intOptionIndex), ":")
Set oOption = New OptionItem
oOption.SetInfo aOption(0), aOption(1), aOption(2), intScope
' First, do we see a start of a block ('[')?
If Left(aOption(0), 1) = "[" Then
intOptionIndex = intOptionIndex + 1
InsertOptionsInArray oOption, aCmdLineOptions, intScope + 1
End If
If IsArray(aArray) Then
Set aArray(intCount) = oOption
Else
' aArray is actually an object
aArray.AddChild oOption
End If
' Now, do we see an end of a block (']')?
If Right(aOption(UBound(aOption)), 1) = "]" Then
Exit Sub
End If
intCount = intCount + 1
intOptionIndex = intOptionIndex + 1
Loop
ReDim Preserve aArray(intCount - 1)
End Sub
End Class
Class ParserError
Public SwitchName
Public ErrorCode
End Class
''''''''''''''''''''''''''''''''''''
' Methods
'''''''''''''''''''''''''
' Initialization
Function InitAuthentication(Server, User, Password)
Dim DefaultNamespaceObj, RegistryObj
Dim IISNameSpaceObj, ComputerObj
Dim iMajorVersion, iResult
Dim aResult
On Error Resume Next
iResult = 0
strServer = Server
strUser = User
strPassword = Password
If Server = "." Or UCase(Server) = UCase(GetEnvironmentVar("%COMPUTERNAME%")) Then
If User <> "" Or Password <> "" Then
WScript.Echo getResource("L_Warning_Text") & ": " & getResource("L_CredentialsIgnored_Message")
strUser = ""
strPassword = ""
End If
End If
' Initializes the WMI Locator object
Set LocatorObj = CreateObject(getResource("LOCATOR_OBJ"))
If Err.Number Then
WScript.Echo getResource("L_Locator_ErrorMessage")
WScript.Echo getResource("L_Error_ErrorMessage") & " &H" & Hex(Err.Number) & ": " & Err.Description
InitAuthentication = Err.Number
Exit Function
End If
LocatorObj.Security_.ImpersonationLevel = getResource("WBemImpersonationLevelImpersonate")
' Check if target machine has IIS6 installed (server and above)
Set IISNameSpaceObj = LocatorObj.ConnectServer(strServer, getResource("WMI_NAMESPACE"), strUser, strPassword)
If Err.Number Then
' Error connecting to the IIS namespace. If NOT_FOUND, this is probably not a Win2002 box
If Err.Number = &H8004100E Then ' INVALID_NAMESPACE
WScript.Echo getResource("L_OnlyIIS6Supported_ErrorMessage")
Else
WScript.Echo getResource("L_ConnectObject_ErrorMessage")
WScript.Echo getResource("L_Error_ErrorMessage") & " &H" & Hex(Err.Number) & ": " & Err.Description
End If
InitAuthentication = Err.Number
Exit Function
End If
Set ComputerObj = IISNameSpaceObj.get("IIsWebInfo='W3SVC/Info'")
If Err.Number Then
WScript.Echo getResource("L_OnlyIIS6Supported_ErrorMessage")
InitAuthentication = Err.Number
Exit Function
End If
iMajorVersion = ComputerObj.MD_SERVER_VERSION_MAJOR
If Err.Number Or iMajorVersion <> 6 Then
WScript.Echo getResource("L_OnlyIIS6Supported_ErrorMessage")
InitAuthentication = 1
Exit Function
End If
' Set DefaultNamespaceObj = LocatorObj.ConnectServer(strServer, "root\default", strUser, strPassword)
' If Err.Number Then
' WScript.Echo getResource("L_ConnectObject_ErrorMessage")
' WScript.Echo getResource("L_Error_ErrorMessage") & " &H" & Hex(Err.Number) & ": " & Err.Description
' InitAuthentication = Err.Number
' Exit Function
' End If
'
' Set RegistryObj = DefaultNamespaceObj.get("StdRegProv")
' iResult = RegistryObj.GetMultiStringValue(, getResource("ProductInfoRegKey"), _
' getResource("ProductInfoRegValue"), _
' aResult)
' If iResult <> 0 Or Err Then
' WScript.Echo getResource("L_RegProc_ErrorMessage")
' If iResult Then
' InitAuthentication = iResult
' Else
' InitAuthentication = Err.Number
' End If
' Exit Function
' Else
' If UBound(aResult) < 0 Then
' ' Target machine is PRO
' WScript.Echo getResource("L_OnlyIIS6Supported_ErrorMessage")
' InitAuthentication = &H80070032
' Exit Function
' ElseIf aResult(0) = "Personal" Then
' ' Target machine is PER
' WScript.Echo getResource("L_OnlyIIS6Supported_ErrorMessage")
' InitAuthentication = &H80070032
' Exit Function
' Else
' ' Target machine is SRV or above
' End If
' End If
' If we get here, everything went fine.
InitAuthentication = 0
End Function
''''''''''''''''''''''''''''''
' ParseCmdLineOptions
''''''''''''''''''''''''''
Function ParseCmdLineOptions(strCmdLine)
Dim oOptions, oOption, oError
Dim strItem, strValue
Dim intCount, intIndex, i
Dim ArgObj
Dim aValues
Set ArgObj = WScript.Arguments
If ArgObj.Count = 0 Then Exit Function
Set dictSwitches = CreateObject("Scripting.Dictionary")
Set dictHelpRequested = CreateObject("Scripting.Dictionary")
ReDim aNamedArguments(ArgObj.Count - 1)
Set oOptions = New Options
oOptions.SetOptions strCmdLine
' intCount has the number of named arguments in the command line
intCount = 0
' Parse command line options
For intIndex = 0 to ArgObj.Count - 1
strItem = ArgObj.Item(intIndex)
' Is this a help switch?
If IsHelpSwitch(strItem) Then
fGlobalHelpRequested = True
Exit For
End If
' Is this item a switch?
If (Left(strItem, 1) = "/" Or Left(strItem, 1) = "-") And Len(strItem) > 1 Then
' Check for required argument
strItem = Mid(strItem, 2)
' Do we have a switch with syntax '-switch:value'?
If InStr(strItem, ":") <> 0 Then
Dim aSwitch
aSwitch = Split(strItem, ":")
strItem = aSwitch(0)
strValue = aSwitch(1)
Else
strValue = Null
End If
Set oOption = oOptions.GetInfo(strItem)
If Not oOption Is Nothing And fGlobalHelpRequested = False Then
' Check if we already processed this switch before
If dictSwitches.Exists(oOption.Name) Then
dictSwitches.Remove(oOption.Name)
End If
' Option exists. Mark as visited
oOption.Visit
' Check for argument requirement
If IsNumeric(oOption.RequiredArgs) Then
' Is there an argument in the -switch:value,value,... format?
If oOption.RequiredArgs = 0 Then
' First, look for help switch
If intIndex + 1 < ArgObj.Count Then
If IsHelpSwitch(ArgObj(intIndex + 1)) Then
intIndex = intIndex + 1
dictHelpRequested.Add oOption.Name, True
End If
End If
' Option does not require an argument
dictSwitches.Add oOption.Name, ""
Else
If Not IsNull(strValue) Then
' Check how many arguments we get
aValues = Split(strValue, ",")
If CInt(oOption.RequiredArgs) <> (UBound(aValues) + 1) Then
Set oError = New ParserError
oError.SwitchName = oOption.Name
oError.ErrorCode = ERROR_NOT_ENOUGH_ARGS
Set ParseCmdLineOptions = oError
Exit Function
' WScript.Echo "ERROR: Switch /" & oOption.Name & " expects " & _
' oOption.RequiredArgs & " arguments. Got only " & UBound(aValues)
' WScript.Quit(0)
End If
If InStr(strValue, ",") <> 0 Then
dictSwitches.Add oOption.Name, aValues
Else
dictSwitches.Add oOption.Name, strValue
End If
Else
' We don't have '-switch:value1,value2,...'.
' Loop to get all RequiredArgs arguments asked for
If oOption.RequiredArgs > 1 Then
ReDim aValues(oOption.RequiredArgs - 1)
For i = 0 to oOption.RequiredArgs - 1
If intIndex + 1 < ArgObj.Count Then
' Get it. Add option to dictionary
intIndex = intIndex + 1
aValues(i) = ArgObj(intIndex)
' Is this option a help switch?
If IsHelpSwitch(ArgObj(intIndex)) Then
dictHelpRequested.Add oOption.Name, True
ReDim Preserve aValues(UBound(aValues) - i -1)
Exit For
End If
Else
Set oError = New ParserError
oError.SwitchName = oOption.Name
oError.ErrorCode = ERROR_NOT_ENOUGH_ARGS
Set ParseCmdLineOptions = oError
Exit Function
' Wscript.Echo "ERROR: Switch /" & oOption.Name & " requires " & _
' oOption.RequiredArgs & " argument(s)"
' WScript.Quit(-1)
End If
Next
dictSwitches.Add oOption.Name, aValues
Else
' Just one argument (most common scenario)
If intIndex + 1 < ArgObj.Count Then
' Get it. Add option to dictionary
intIndex = intIndex + 1
If IsHelpSwitch(ArgObj(intIndex)) Then
dictHelpRequested.Add oOption.Name, True
End If
dictSwitches.Add oOption.Name, ArgObj(intIndex)
Else
Set oError = New ParserError
oError.SwitchName = oOption.Name
oError.ErrorCode = ERROR_NOT_ENOUGH_ARGS
Set ParseCmdLineOptions = oError
Exit Function
' Wscript.Echo "ERROR: Switch /" & oOption.Name & " requires " & _
' oOption.RequiredArgs & " argument(s)"
' WScript.Quit(-1)
End If
End If
End If
End If
Else
' RequiredArgs not numeric
' We should read parameters until we find another switch
If Not IsNull(strValue) Then
' Check how many arguments we get
If InStr(strValue, ",") <> 0 Then
aValues = Split(strValue, ",")
dictSwitches.Add oOption.Name, aValues
Else
If IsHelpSwitch(strValue) Then
dictHelpRequested.Add oOption.Name, True
Else
dictSwitches.Add oOption.Name, strValue
End If
End If
Else
' We don't have '-switch:value1,value2,...'.
' Loop to get all RequiredArgs until the end of the command line arguments
' or until we find another switch
i = 0
intIndex = intIndex + 1
ReDim aValues(ArgObj.Count - intIndex - 1)
Do While intIndex < ArgObj.Count
If IsHelpSwitch(ArgObj(intIndex)) Then
dictHelpRequested.Add oOption.Name, True
Else
' Exit if we find another switch
If Left(ArgObj(intIndex), 1) = "/" Or Left(ArgObj(intIndex), 1) = "-" Then
intIndex = intIndex - 1
Exit Do
Else
aValues(i) = ArgObj(intIndex)
End If
End If
intIndex = intIndex + 1
i = i + 1
Loop
ReDim Preserve aValues(i - 1)
dictSwitches.Add oOption.Name, aValues
End If
End If
Else
' Item not present in the list of options
Set oError = New ParserError
oError.SwitchName = strItem
oError.ErrorCode = ERROR_UNKNOWN_SWITCH
Set ParseCmdLineOptions = oError
Exit Function
' WScript.Echo "ERROR: Unknown switch: /" & strItem
' WScript.Quit(-1)
End If
Else
' This is not a switch (named argument)
' Add argument to the array of named arguments
aNamedArguments(intCount) = strItem
intCount = intCount + 1
End If
Next
ReDim Preserve aNamedArguments(intCount - 1)
' Release Options object
Set oOptions = Nothing
Set ParseCmdLineOptions = Nothing
End Function
''''''''''''''''''''''''''''''''''''''''''''''
' GetSwitch(switchName)
' Return the value associated with a switch
' passed in the command line
'''''''''''''''''''''''''''''''''''''''''''''
Function GetSwitch(strSwitchName)
If IsObject(dictSwitches(strSwitchName)) Then
Set GetSwitch = dictSwitches(strSwitchName)
Else
GetSwitch = dictSwitches(strSwitchName)
End If
End Function
''''''''''''''''''''''''''''''''''''''''''''''
' IsHelpRequested(switchName)
' Return if the help switch was activated for
' a certain switch
'''''''''''''''''''''''''''''''''''''''''''''
Function IsHelpRequested(strSwitch)
Dim fHelpRequested
Dim fResult
fResult = False
If dictHelpRequested.Exists(strSwitch) Then
fResult = dictHelpRequested(strSwitch)
End If
IsHelpRequested = fResult
End Function
'''''''''''''''''''''''''''''''
' DumpCmdLineOptions()
' Show all command line options
' Used for debugging
''''''''''''''''''''''''''''''
Sub DumpCmdLineOptions()
Dim k
Dim value
If IsNull(dictSwitches) Or dictSwitches Is Nothing Then Exit Sub
WScript.Echo "Switches:"
For Each k in dictSwitches.Keys
If IsArray(dictSwitches(k)) Then
value = Join(dictSwitches(k), " and ")
Else
value = dictSwitches(k)
End If
If IsHelpRequested(k) Then
WScript.Echo k & " = " & value & " (HELP switch set)"
Else
WScript.Echo k & " = " & value
End If
Next
WScript.Echo
WScript.Echo "Named arguments:"
For k = LBound(aNamedArguments) to UBound(aNamedArguments)
WScript.Echo k & ". " & aNamedArguments(k)
Next
End Sub
'''''''''''''''''''''''''''
' CheckScriptEngine
'
' This can detect the type of exe the
' script is running under and warns the
' user of the popups.
'''''''''''''''''''''''''''
Sub CheckScriptEngine()
Dim ScriptHost
Dim CurrentPathExt
Dim EnvObject
Dim RegCScript
Dim RegPopupType ' This is used to set the pop-up box flags.
RegPopupType = 32 + 4
On Error Resume Next
ScriptHost = WScript.FullName
ScriptHost = Right(ScriptHost, Len(ScriptHost) - InStrRev(ScriptHost, "\"))
If (UCase(ScriptHost) = "WSCRIPT.EXE") Then
WScript.Echo getResource("L_WrongScriptProcessor_Message")
' Create a pop-up box and ask if they want to register cscript as the default host.
' -1 is the time to wait. 0 means wait forever.
RegCScript = ShellObj.PopUp(getResource("L_AskChangeScriptProcessor_Message"), 0, _
getResource("L_RegisterCScript_Message"), RegPopupType)
If (Err.Number <> 0) Then
WScript.Echo getResource("L_UseCScript_Message")
WScript.Quit(Err.Number)
End If
' Check to see if the user pressed yes or no. YES is 6, NO is 7
If (RegCScript = 6) Then
ShellObj.RegWrite "HKEY_CLASSES_ROOT\VBSFile\Shell\Open\Command\", "%WINDIR%\System32\CScript.exe //nologo ""%1"" %*", "REG_EXPAND_SZ"
ShellObj.RegWrite "HKEY_LOCAL_MACHINE\SOFTWARE\Classes\VBSFile\Shell\Open\Command\", "%WINDIR%\System32\CScript.exe //nologo ""%1"" %*", "REG_EXPAND_SZ"
' Check if PathExt already existed
CurrentPathExt = ShellObj.RegRead("HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Session Manager\Environment\PATHEXT")
If Err.Number = &H80070002 Then
Err.Clear
Set EnvObject = ShellObj.Environment("PROCESS")
CurrentPathExt = EnvObject.Item("PATHEXT")
End If
ShellObj.RegWrite "HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Session Manager\Environment\PATHEXT", CurrentPathExt & ";.VBS", "REG_SZ"
If (Err.Number <> 0) Then
WScript.Echo getResource("L_WriteReg_ErrorMessage")
WScript.Quit (Err.Number)
Else
WScript.Echo getResource("L_OkWriteReg_Message")
End If
Else
WScript.Echo getResource("L_UseCScript_Message")
End If
Dim ProcString
Dim ArgIndex
Dim ArgObj
Dim Result
ProcString = "Cscript //nologo " & WScript.ScriptFullName
Set ArgObj = WScript.Arguments
For ArgIndex = 0 To ArgCount - 1
ProcString = ProcString & " " & Args(ArgIndex)
Next
'Now, run the original executable under CScript.exe
Result = ShellObj.Run(ProcString, 0, True)
WScript.Quit (Result)
End If
End Sub
''''''''''''''''''''''''''''''''''''''''
' FindSite
'
' Return a web/ftp site paths given
' site names or site comments
''''''''''''''''''''''''''''''''''''''
Function FindSite(strType, aArgs)
Dim Server, Servers
Dim strQuery, strSvcName, line
Dim aSites, aResult, aComments
Dim bFoundDuplicate, bCheckForDuplicates
Dim i, j, iCount
On Error Resume Next
bCheckForDuplicates = False
If UCase(strType) = "WEB" Then
strQuery = "select Name, ServerComment from IIsWebServerSetting where "
strSvcName = "W3SVC"
Else
strQuery = "select Name, ServerComment from IIsFtpServerSetting where "
strSvcName = "MSFTPSVC"
End If
For i = LBound(aArgs) to UBound(aArgs)
strQuery = strQuery & "(Name=""" & aArgs(i) & """ or ServerComment=""" & aArgs(i) & """)"
If (i <> UBound(aArgs)) Then
strQuery = strQuery & " or "
End If
' Verify if we need to check for duplicate (occurs only when the user supply a site
' name instead of metabase path)
' Is this a site name?
If (InStr(UCase(aArgs(i)), strSvcName) = 0) Then
bCheckForDuplicates = True
End If
Next
' Semi-sync query. (flags = ForwardOnly Or ReturnImediately = &H30)
Set Servers = ProviderObj.ExecQuery(strQuery, , &H30)
If (Err.Number <> 0) Then
WScript.Echo L_Query_ErrorMessage
WScript.Echo getResource("L_Error_ErrorMessage") & " &H" & Hex(Err.Number) & ": " & Err.Description
WScript.Quit(Err.Number)
End If
ReDim aResult(0)
ReDim aComments(0)
bFoundDuplicate = False
i = 0
For Each Server in Servers
If Err Then
Exit For
End If
' Check for duplicates
If bCheckForDuplicates Then
For j = 0 to i - 1
If (UCase(Server.ServerComment) = UCase(aComments(j))) Then
If Not bFoundDuplicate Then
WScript.Echo getResource("L_NotUnique1_Message")
WScript.Echo getResource("L_NotUnique2_Message")
WScript.Echo
WScript.Echo getResource("L_SiteName_Text") & Space(20) & getResource("L_MetabasePath_Message")
WScript.Echo "================================================================="
WScript.Echo Server.ServerComment & Space(29 - Len(Server.ServerComment)) & aResult(j)
bFoundDuplicate = True
End If
WScript.Echo Server.ServerComment & Space(29 - Len(Server.ServerComment)) & Server.Name
Exit For
End If
Next
End If
aComments(i) = Server.ServerComment
aResult(i) = Server.Name
i = i + 1
ReDim Preserve aComments(i)
ReDim Preserve aResult(i)
Next
ReDim Preserve aComments(i - 1)
ReDim Preserve aResult(i - 1)
If bFoundDuplicate Then
FindSite = ""
Else
FindSite = aResult
End If
End Function
'''''''''''''''''''''''''''
' IsHelpSwitch
''''''''''''''''''''
Function IsHelpSwitch(strSwitch)
Dim fResult
fResult = False
If Left(strSwitch, 1) = "/" or Left(strSwitch, 1) = "-" Then
Select Case UCase(Right(strSwitch, Len(strSwitch) - 1))
Case "?"
fResult = True
Case "H"
fResult = True
Case "HELP"
fResult = True
Case Else
fResult = False
End Select
End If
IsHelpSwitch = fResult
End Function
'''''''''''''''''''''''''''
' CreateFSDir
'
''''''''''''''''''''''''''
Function CreateFSDir(strRoot)
Dim FolderObj
Dim intResult, iIndex
Dim strRemotePath, strFSPath
Dim strDrive, strDrvLetter
'On Error Resume Next
intResult = 0
If Mid(strRoot, 2, 2) <> ":\" Then
' Invalid Path - using Win32Error ERROR_INVALID_ACCESS
Err.Raise &H8007000C
Exit Function
End If
If strServer <> "." Then
' Server is remote. Find out first drive letter is available for mapping
strDrive = "NO DRIVE"
For strDrvLetter = Asc("C") to Asc("Z")
If Not FSObj.DriveExists(Chr(strDrvLetter)) Then
strDrive = Chr(strDrvLetter)
Exit For
End If
Next
If strDrive = "NO DRIVE" Then
' No drive letter available
' &H8007000F is Win32 error ERROR_INVALID_DRIVE
Err.Raise &H8007000F
Exit Function
End If
' Look for drive specification
strRemotePath = "\\" & strServer & "\" & Mid(strRoot, 1, 1) & "$"
' Map network drive
strDrive = strDrive & ":"
NetObj.MapNetworkDrive strDrive, strRemotePath, False, strUser, strPassword
strFSPath = strDrive & Mid(strRoot, 3)
Else
strFSPath = strRoot
End If
If Not FSObj.FolderExists(strFSPath) Then
'WScript.Echo L_CreatingRootDir_Message
' Have to create path, piece by piece
Dim aPathParts, strPathPart
aPathParts = Split(strFSPath, "\", -1)
strPathPart = aPathParts(0)
iIndex = 1
Do While iIndex <= UBound(aPathParts)
strPathPart = strPathPart & "\" & aPathParts(iIndex)
If Not FSObj.FolderExists(strPathPart) Then
Set FolderObj = FSObj.CreateFolder(strPathPart)
End If
iIndex = iIndex + 1
Loop
End If
If strServer <> "." Then
NetObj.RemoveNetworkDrive strDrive, True
End If
CreateFSDir = intResult
End Function
'''''''''''''''''''''''''''
' ParseBindings
'
' Try to get IP address, port number
' and host name from the
' ServerBindings property
'''''''''''''''''''''''''''
Function ParseBindings(bindings)
Dim firstColon, secondColon
Dim strIP, strPort, strHost
firstColon = Instr(bindings, ":")
secondColon = Instr(firstColon + 1, bindings, ":")
strIP = Mid(bindings, 1, firstColon - 1)
strPort = Mid(bindings, firstColon + 1, secondColon - firstColon - 1)
strHost = Mid(bindings, secondColon + 1)
ParseBindings = Array(strIP, strPort, strHost)
End Function
''''''''''''''''''''''''''''''
' WMIConnect()
'''''''''''''''''''''
Function WMIConnect()
'On Error Resume Next
If Not IsObject(LocatorObj) Then
Exit Function
End If
WScript.StdOut.Write getResource("L_Connecting_Message")
Set ProviderObj = LocatorObj.ConnectServer(strServer, getResource("WMI_NAMESPACE"), strUser, strPassword)
' If (Err.Number <> 0) Then
' 'WScript.Echo getResource("L_ConnectObject_ErrorMessage")
' 'WScript.Echo getResource("L_Error_ErrorMessage") & " &H" & Hex(Err.Number) & ": " & Err.Description
' WMIConnect = Err.Number
' 'WScript.Quit(Err.Number)
' Else
' WMIConnect = 0
' End If
WScript.StdOut.WriteLine getResource("L_Done_Message")
End Function
'''''''''''''''''''''''''
' ValidateIPAddress
' Returns TRUE if IP Address is associated with one of the network adapters
'''''''''''''''''''
Function IsValidIPAddress(strIPAddress)
Dim CIMv2ProviderObj, IPConfig, IPConfigSet
Dim strQuery, iCounter
Dim regExpObj, Matches, Match
Dim bResult
On Error Resume Next
bResult = False
' First test the IP address against a mask
Set regExpObj = New RegExp
regExpObj.Pattern = "(\d+)\.(\d+)\.(\d+)\.(\d+)"
regExpObj.Global = True
Set Matches = regExpObj.Execute(strIPAddress)
If Matches.Count <> 1 Then
IsValidIPAddress = bResult
Exit Function
End If
For Each Match in Matches(0).SubMatches
If Match < 0 Or Match > 255 Then
IsValidIPAddress = bResult
Exit Function
End If
Next
' Check if IP address belongs to the target machine
If Not IsObject(LocatorObj) Then
IsValidIPAddress = bResult
Exit Function
End If
Set CIMv2ProviderObj = LocatorObj.ConnectServer(strServer, "root/CIMv2", strUser, strPassword)
If Err.Number Then
WScript.Echo getResource("L_ConnectObject_ErrorMessage")
WScript.Echo getResource("L_Error_ErrorMessage") & " &H" & Hex(Err.Number) & ": " & Err.Description
'WScript.Quit(Err.Number)
End If
strQuery = "SELECT IPAddress FROM Win32_NetworkAdapterConfiguration WHERE IPEnabled = TRUE"
' Semi-sync query. (flags = ForwardOnly Or ReturnImediately = &H30)
Set IPConfigSet = CIMv2ProviderObj.ExecQuery(strQuery, , &H30)
For Each IPConfig in IPConfigSet
If Not IsNull(IPConfig.IPAddress) Then
iCounter = LBound(IPConfig.IPAddress)
Do While iCounter <= UBound(IPConfig.IPAddress)
If IPConfig.IPAddress(iCounter) = strIPAddress Then
bResult = True
Exit For
End If
iCounter = iCounter + 1
Loop
End If
Next
IsValidIPAddress = bResult
End Function
Function IsValidPortNumber(intPort)
Dim bResult
bResult = False
If IsNumeric(intPort) And intPort > 0 And intPort < 65535 Then
bResult = True
End If
IsValidPortNumber = bResult
End Function
Function GetEnvironmentVar(strVar)
GetEnvironmentVar = ShellObj.ExpandEnvironmentStrings(strVar)
End Function
Sub BuildNameSpace(strPath)
Dim aPath
Dim strNewPath, strFSPath, strVDirPath
Dim strQuery
Dim VDirObj, Dir, NewWebDir
Dim iStart, i, iErrNumber
' Skip the *SVC/n/ROOT part
iStart = InStr(InStr(strPath, "ROOT"), strPath, "/")
' If strPath is equal to *SVC/n/ROOT, there's nothing left to do.
If iStart = 0 Or iStart = Len(strPath) Then
Exit Sub
End If
' strPath now start from the first node after ROOT in the metabase path
strNewPath = Mid(strPath, iStart + 1)
strVDirPath = Mid(strPath, 1, iStart - 1)
' Grab root directory for *SVC/n/ROOT
Set VDirObj = ProviderObj.Get("IIsWebVirtualDirSetting='" & strVDirPath & "'")
strFSPath = VDirObj.Path
Set VDirObj = Nothing
aPath = Split(strNewPath, "/", -1)
For i = LBound(aPath) to UBound(aPath)
strFSPath = strFSPath & "\" & aPath(i)
Next
' First, make sure the file system path exists
If Not FSObj.FolderExists(strFSPath) Then
' FS Path not found
Err.Raise &H80070003 ' The system cannot find the path specified
Exit Sub
End If
' FS Path exists. Now let's build the web directories for each path component
If strServer = "." Then
strVDirPath = "IIS://" & GetEnvironmentVar("%COMPUTERNAME%") & "/" & strVDirPath
Else
strVDirPath = "IIS://" & strServer & "/" & strVDirPath
End If
On Error Resume Next
' Search for the first path component that doesn't exist.
For i = LBound(aPath) to UBound(aPath)
' For each path component, check if the component exists in the metabase
Set Dirs = GetObject(strVDirPath & "/" & aPath(i))
If Err = &H80070003 Then
Err.Clear
Exit For
End If
strVDirPath = strVDirPath & "/" & aPath(i)
Next
On Error Goto 0
' Create all path components that doesn't exist
For i = i to UBound(aPath)
Set Dir = GetObject(strVDirPath)
Set NewWebDir = Dir.Create("IIsWebDirectory", aPath(i))
If Err Then
iErrNumber = Err.Number
On Error Goto 0
Err.Raise iErrNumber
End If
NewWebDir.SetInfo
If Err Then
iErrNumber = Err.Number
On Error Goto 0
Err.Raise iErrNumber
End If
strVDirPath = strVDirPath & "/" & aPath(i)
Next
End Sub
Function GetAbsolutePath(strPath)
GetAbsolutePath = FSObj.GetAbsolutePathName(strPath)
End Function
Function NormalizeFilePath(strPath)
Dim strPathName
strPathName = GetAbsolutePath(strPath)
If FSObj.FolderExists(strPathName) Then
' Should not be a folder path
Err.Raise &H80070002 ' Could not find FILE specified
End If
' Parent folder should exist
If Not FSObj.FolderExists(FSObj.GetParentFolderName(strPathName)) Then
Err.Raise &H80070003 ' Could not find PATH specified
End If
NormalizeFilePath = strPathName
End Function
]]>
</script>
</component>
</package>