<% '==================================================
' Microsoft Server Appliance
'
' Page-level functions
'
' Copyright (c) Microsoft Corporation. All rights reserved.
'================================================== %>
<%
'
' This file (i.e., sh_page.asp) should be the first include file
' in all asp files, since autoconfiglang.asp sets the default
' language settings for the web UI.
'
%>
<%
'
' If page caching is disabled, then set HTTP Headers to disable caching.
' Default case is disabled.
'
If ( FALSE = SAI_GetPageCaching() ) Then
If ( IsNull(Response.Expires) OR Response.Expires >= 0 ) Then
Response.Buffer = True
Response.ExpiresAbsolute = DateAdd("yyyy", -10, Date)
Response.AddHeader "pragma", "no-cache"
Response.AddHeader "cache-control", "no-store"
End If
Call SA_TraceOut(SA_GetScriptFileName(), "Page Caching DISABLED")
Else
Call SA_TraceOut(SA_GetScriptFileName(), "Page Caching enabled")
End If
'--------------------------------------------------------------------
' Public Constants
'--------------------------------------------------------------------
'
Const SA_RESERVED = ""
Const SA_DEFAULT = ""
'
' Page Types:
' -----------
Const PT_PROPERTY = 1
Const PT_TABBED = 2
Const PT_WIZARD = 3
Const PT_AREA = 4
Const PT_PAGELET = 5
'
' File System Explorer:
' -----------
Const EXPLORE_FOLDERS = "0"
Const EXPLORE_FILES_AND_FOLDERS = "1"
'--------------------------------------------------------------------
' Framework Parameter Name
'--------------------------------------------------------------------
'
Dim FLD_PagingAction
Dim FLD_PagingRequest
Dim FLD_PagingEnabled
Dim FLD_PagingPageMin
Dim FLD_PagingPageMax
Dim FLD_PagingPageCurrent
Dim FLD_SearchItem
Dim FLD_SearchValue
Dim FLD_SearchRequest
Dim FLD_SortingColumn
Dim FLD_SortingSequence
Dim FLD_SortingRequest
Dim FLD_SortingEnabled
Dim FLD_IsToolbarEnabled
FLD_PagingAction = "fldPagingAction"
FLD_PagingRequest = "fldPagingRequest"
FLD_PagingEnabled = "PageE"
FLD_PagingPageMin = "PageMi"
FLD_PagingPageMax = "PageMx"
FLD_PagingPageCurrent = "PageCu"
FLD_SearchItem = "SearchI"
FLD_SearchValue = "SearchV"
FLD_SearchRequest = "fldSearchRequest"
FLD_SortingColumn = "SortC"
FLD_SortingSequence = "SortS"
FLD_SortingRequest = "fldSortingRequest"
FLD_SortingEnabled = "SortE"
FLD_IsToolbarEnabled = "fldIsToolbarEnabled"
'--------------------------------------------------------------------
' Framework Version
'--------------------------------------------------------------------
'
Dim g_iFrameworkVersion
Const gc_V2 = 2.0
g_iFrameworkVersion = 1.0
Dim m_bPageCaching
m_bPageCaching = FALSE
Dim objLocMgr
'Dim intCaptionID
'Dim intDescriptionID
Dim varReplacementStrings
Dim m_intSpanIndex
Dim m_VirtualRoot
Dim miPageType
Dim iNextButtonNumber
iNextButtonNumber = 0
Dim strSourceName
strSourceName = ""
m_intSpanIndex=0
m_VirtualRoot = getVirtualDirectory()
strSourceName = "sakitmsg.dll"
Set objLocMgr = Server.CreateObject("ServerAppliance.LocalizationManager")
If Err.number <> 0 Then
If ( Err.number = &H800401F3 ) Then
Response.Write("
Problem:
")
Response.Write("Unable to locate a software component on the Server Appliance. ")
Response.Write("The Server Appliance core software components do not appear to be installed correctly.")
Else
Response.Write("
Problem:
")
Response.Write("Server.CreateObject(ServerAppliance.LocalizationManager) failed with error code: " + CStr(Hex(Err.Number)) + " " + Err.Description)
End If
Call SA_TraceOut("SH_TASK", "Server.CreateObject(ServerAppliance.LocalizationManager) failed with error code: " + CStr(Hex(Err.Number)) )
Response.End
End If
'-----------------------------------------------------
'START of localization content
Dim L_FOKBUTTON_TEXT
Dim L_FCANCELBUTTON_TEXT
Dim L_FBACKBUTTON_TEXT
Dim L_FNEXTBUTTON_TEXT
Dim L_FFINISHBUTTON_TEXT
Dim L_FCLOSEBUTTON_TEXT
Dim L_AREABACKBUTTON_TEXT
L_FOKBUTTON_TEXT = GetLocString(strSourceName, "&H40010012", "")
L_FCANCELBUTTON_TEXT = GetLocString(strSourceName, "&H40010013", "")
L_FBACKBUTTON_TEXT = GetLocString(strSourceName, "&H40010014", "")
L_FNEXTBUTTON_TEXT = GetLocString(strSourceName, "&H40010015", "")
L_FFINISHBUTTON_TEXT = GetLocString(strSourceName, "&H40010016", "")
L_FCLOSEBUTTON_TEXT = GetLocString(strSourceName, "&H40010017", "")
L_AREABACKBUTTON_TEXT = GetLocString(strSourceName, "&H40010018", "")
'End of localization content
'-----------------------------------------------------
'--------------------------------------------------------------------
' Private global variables
'--------------------------------------------------------------------
'
Dim m_oLocManager
Private Function SAI_GetNextButtonName()
iNextButtonNumber = iNextButtonNumber + 1
SAI_GetNextButtonName = "btnInternal_" + CStr(iNextButtonNumber)
End Function
Private Function SAI_EnablePageCaching(ByVal bEnable)
m_bPageCaching = bEnable
End Function
Private Function SAI_GetPageCaching()
'
' If Page Caching is not specified then it's disabled
If ( Len(m_bPageCaching) <= 0 ) Then
m_bPageCaching = FALSE
End If
SAI_GetPageCaching = m_bPageCaching
End Function
Private Function SAI_GetTSClientCodeBase()
On Error Resume Next
Err.Clear
Dim objRegistry
Dim s
'
' Set default return value
'SAI_GetTSClientCodeBase = "../tsweb/msrdp.cab#version=5,1,2524,0"
SAI_GetTSClientCodeBase = "/tsweb/msrdp.cab"
'
' Connect to the Registry WMI Provider
Set objRegistry = RegConnection()
If (NOT IsObject(objRegistry)) Then
Call SA_TraceOut(SA_GetScriptFileName() , "SAI_GetTSClientInfo::RegConnection() failed: " + CStr(Hex(Err.Number)))
Exit Function
End If
'
' Fetch the REG key
s = GetRegkeyValue( objRegistry, _
"SOFTWARE\Microsoft\ServerAppliance\TSClient",_
"Codebase", CONST_STRING)
If ( Err.Number <> 0 ) Then
Call SA_TraceOut(SA_GetScriptFileName() , "SAI_GetTSClientInfo::GetRegkeyValue() failed: " + CStr(Hex(Err.Number)))
Set objRegistry = Nothing
Exit Function
End If
'
' Check for invalid, empty value
If ( Len(s) <= 0 ) Then
Set objRegistry = Nothing
Exit Function
End If
'
' Set the return value
SAI_GetTSClientCodeBase = s
Set objRegistry = Nothing
End Function
Private Function SA_SetPageID(ByVal sPageID)
FLD_SearchItem = sPageID + FLD_SearchItem
FLD_SearchValue = sPageID + FLD_SearchValue
FLD_PagingEnabled = sPageID + FLD_PagingEnabled
FLD_PagingPageMin = sPageID + FLD_PagingPageMin
FLD_PagingPageMax = sPageID + FLD_PagingPageMax
FLD_PagingPageCurrent = sPageID + FLD_PagingPageCurrent
FLD_SortingColumn = sPageID + FLD_SortingColumn
FLD_SortingSequence = sPageID + FLD_SortingSequence
FLD_SortingEnabled = sPageID + FLD_SortingEnabled
FLD_IsToolbarEnabled = sPageID + FLD_IsToolbarEnabled
End Function
Private Function SA_SetVersion(ByVal iVersion)
g_iFrameworkVersion = iVersion
End Function
Public Function SA_GetVersion()
SA_GetVersion = g_iFrameworkVersion
End Function
Public Function SA_GetParam(ByVal sParamName)
If (Len(Request.Form(sParamName)) > 0 ) Then
SA_GetParam = Request.Form(sParamName)
'Call SA_TraceOut("SH_PAGE", "SA_GetParam returning Request.Form("+sParamName+") value:" + CStr(SA_GetParam))
Else
SA_GetParam = Request.QueryString(sParamName)
'Call SA_TraceOut("SH_PAGE", "SA_GetParam returning Request.QueryString("+sParamName+") value:" + CStr(SA_GetParam))
End If
End Function
'--------------------------------------------------------------------
'
' Function: SA_GetNewHostURLBase
'
' Synopsis: Format and return a new HOST URL base using the specified
' parameters.
'
' Arguments: [in] sServerName Specifies the server name, optional.
' Use SA_DEFAULT to specify not change to the
' server name.
'
' [in] sServerPort Port on the server, optional. Use the constant
' SA_DEFAULT to specify the current port.
'
' [in] bUseSecurePort TRUE to indicate a secure (HTTPS) connection, FALSE
' for a normal connection (HTTP).
'
' [in] sAdminRoot Administrative web root, which includes a trailing backslash,
' optional. To specify the current admin root use the constant
' SA_DEFAULT.
'
' Returns: The new base url in the form http://server:port/adminroot/
'
'--------------------------------------------------------------------
Public Function SA_GetNewHostURLBase(ByVal sHostName, ByVal sHostPort, ByVal bUseSecurePort, ByVal sAdminRoot)
Dim bIsCurrentlySecure
Dim sHostConnection
'
' Validate bUseSecurePort argument
'
If ( bUseSecurePort = SA_DEFAULT ) Then
bUseSecurePort = CInt(Request.ServerVariables("SERVER_PORT_SECURE"))
End If
If ( bUseSecurePort = TRUE ) Then
ElseIf ( bUseSecurePort = FALSE ) Then
Else
Call SA_TraceErrorOut(SA_GetScriptFileName(), "SA_GetChangedHostPath called with invalid value specified for bUseSecurePort: " + CStr(bUseSecurePort))
bUseSecurePort = FALSE
End If
'
' http://
If ( TRUE = bUseSecurePort ) Then
sHostConnection = "https://"
Else
sHostConnection = "https://"
End If
'
' http://server
If ( Len(sHostName) <= 0 ) Then
sHostName = GetServerName()
End If
sHostConnection = sHostConnection + sHostName
'
' http://server:8080
If ( Len(sHostPort) <= 0 ) Then
sHostPort = Request.ServerVariables("SERVER_PORT")
End If
sHostConnection = sHostConnection + ":" + CStr(sHostPort)
'
' http://server:8080/adminroot/
sAdminRoot = Trim(sAdminRoot)
If ( Len(sAdminRoot) <= 0 ) Then
sAdminRoot = m_VirtualRoot
End If
If ( Left(sAdminRoot, 1) <> "/" ) Then
sAdminRoot = "/" + sAdminRoot
End If
If ( Right(sAdminRoot, 1) <> "/" ) Then
sAdminRoot = sAdminRoot + "/"
End If
sHostConnection = sHostConnection + sAdminRoot
SA_GetNewHostURLBase = sHostConnection
Call SA_TraceOut(SA_GetScriptFileName(), "SA_GetNewHostURLBase returning: " + CStr(SA_GetNewHostURLBase))
End Function
'--------------------------------------------------------------------
'
' Function: SA_ServeFileExplorer
'
' Synopsis: Serve the Appliance File System Explorer Widget. This Widget
' provides UI to allow the user to browse the Server Appliance
' file system to select a file or folder.
'
' Arguments: [in] iExploreOptions (EXPLORE_FOLDERS, EXPLORE_FILES_AND_FOLDERS)
' [in] sStartingFolder
' [in] sNotifyFn
' [in] iWidth
' [in] iHeight
' [in] Reserved
'
' Returns: Nothing
'
'--------------------------------------------------------------------
Public Function SA_ServeFileExplorer( ByVal ExploreOptions,_
ByVal sStartingFolder,_
ByVal sNotifyFn,_
ByVal iWidth,_
ByVal iHeight,_
ByRef Reserved)
Dim sExplorerURL
If ( Len(iWidth) <= 0 ) Then
iWidth = "100%"
End If
If ( Len(iHeight) <= 0 ) Then
iHeight="350px"
End If
sExplorerURL = m_VirtualRoot + "sh_fsexplorer.asp"
Call SA_MungeURL(sExplorerURL, SAI_FLD_PAGEKEY, SAI_GetPageKey())
If ( Len(Trim(sStartingFolder)) > 0 ) Then
Call SA_MungeURL(sExplorerURL, "BaseFolder", Trim(sStartingFolder))
End If
Select Case ExploreOptions
Case EXPLORE_FOLDERS
Call SA_MungeURL(sExplorerURL, "Opt", CStr(EXPLORE_FOLDERS))
Case EXPLORE_FILES_AND_FOLDERS
Call SA_MungeURL(sExplorerURL, "Opt", CStr(EXPLORE_FILES_AND_FOLDERS))
Case Else
Call SA_TraceOut("SH_PAGE", "SA_ServeFileExplorerWidget invalid iExploreOptions: " + CStr(iExploreOptions))
Call SA_MungeURL(sExplorerURL, "Opt", ""+EXPLORE_FOLDERS)
End Select
If ( Len(Trim(sNotifyFn)) > 0 ) Then
Call SA_MungeURL(sExplorerURL, "NotifyFn", sNotifyFn )
End If
Response.Write("")
End Function
'--------------------------------------------------------------------
'
' Function: SA_ServeResourceStatus
'
' Synopsis: Serve Resource status information and reference link. This API
' should be used to emit resource status information which is shown
' on the appliance status page.
'
' Arguments: [in] sImage Optional image url
' [in] sCaption Caption text
' [in] sHoverText Hover text
' [in] sURL Optional url which shows resource status details page
' [in] sURLTarget Optional target for url
' [in] sStatusInfo Status information text
'
' Returns: Nothing
'
'--------------------------------------------------------------------
Public Function SA_ServeResourceStatus(ByVal sImage, ByVal sCaption, ByVal sHoverText, ByVal sURL, ByVal sURLTarget, ByVal sStatusInfo)
Dim sDefaultTarget
If ( Len(sURLTarget) <= 0 ) Then
sDefaultTarget = Request.QueryString("ContentTarget")
If ( Len(sDefaultTarget) > 0 ) Then
sDefaultTarget = " target='" + sDefaultTarget + "' "
End If
Else
sDefaultTarget = " target='" + sURLTarget + "' "
End If
If ( Len(sImage) <= 0 ) Then
Response.Write("
"+vbCrLf)
Else
Response.Write("
"+vbCrLf)
End If
If ( Len(sURL) > 0 ) Then
Call SA_MungeURL(sURL, "Tab1", Request.QueryString("Tab1"))
Call SA_MungeURL(sURL, "Tab2", Request.QueryString("Tab2"))
Call SA_MungeURL(sURL, "ReturnURL", Request.QueryString("ReturnURL"))
Call SA_MungeURL(sURL, SAI_FLD_PAGEKEY, SAI_GetPageKey())
Response.Write("
<%
End Function
'--------------------------------------------------------------------
'
' Function: SA_ServeAlertsPanel
'
' Synopsis: Serve the alerts panel pagelet.
'
' Arguments: [in] sAlertDefContainer
' [in] sPageTitle
' [in] sWidthAttr
' [in] sHeightAttr
' [in] sDetailsURLTarget
'
' Returns: Nothing
'
'--------------------------------------------------------------------
Public Function SA_ServeAlertsPanel(ByVal sAlertDefContainer, ByVal sPageTitle, ByVal sWidthAttr, ByVal sHeightAttr, ByVal sDetailsURLTarget)
Dim sURL
Dim sTarget
Dim sReturnURL
sURL = m_VirtualRoot+"sh_alertpanel.asp"
If ( Len(sDetailsURLTarget) > 0 ) Then
sTarget = sDetailsURLTarget
sReturnURL = GetScriptPath()
Dim tab
tab = GetTab1()
If ( Len(tab) > 0 ) Then
Call SA_MungeURL(sReturnURL, "Tab1", tab)
End If
tab = GetTab2()
If ( Len(tab) > 0 ) Then
Call SA_MungeURL(sReturnURL, "Tab2", tab)
End If
Call SA_MungeURL(sReturnURL, SAI_FLD_PAGEKEY, SAI_GetPageKey())
Else
sTarget = "IFStatusContent"
sReturnURL = ""
End If
If ( Len(sAlertDefContainer) <= 0 ) Then
sAlertDefContainer = "AlertDefinitions"
End If
If ( Len(sWidthAttr) <= 0 ) Then
sWidthAttr = "100%"
End If
If ( Len(sHeightAttr) <= 0 ) Then
sHeightAttr = "250px"
End If
Call SA_MungeURL(sURL, "ContentTarget", sTarget)
Call SA_MungeURL(sURL, "AlertContainer", sAlertDefContainer)
Call SA_MungeURL(sURL, "Title", sPageTitle)
Call SA_MungeURL(sURL, "ReturnURL", sReturnURL)
Call SA_MungeURL(sURL, "Tab1", GetTab1())
Call SA_MungeURL(sURL, "Tab2", GetTab2())
Call SA_MungeURL(sURL, SAI_FLD_PAGEKEY, SAI_GetPageKey())
Response.Write("")
End Function
'--------------------------------------------------------------------
'
' Function: SA_ServeResourcesPanel
'
' Synopsis: Serve the Resources panel pagelet.
'
' Arguments: [in] sResourcesContainer
' [in] sPageTitle
' [in] sWidthAttr
' [in] sHeightAttr
' [in] sDetailsURLTarget
'
' Returns: Nothing
'
'--------------------------------------------------------------------
Public Function SA_ServeResourcesPanel(ByVal sResourcesContainer, ByVal sPageTitle, ByVal sWidthAttr, ByVal sHeightAttr, ByVal sDetailsURLTarget)
Dim sURL
Dim sTarget
Dim sReturnURL
Dim tab
sURL = m_VirtualRoot+"sh_resourcepanel.asp"
If ( Len(sDetailsURLTarget) > 0 ) Then
sTarget = sDetailsURLTarget
Else
sTarget = "IFStatusContent"
End If
sReturnURL = GetScriptPath()
tab = GetTab1()
If ( Len(tab) > 0 ) Then
Call SA_MungeURL(sReturnURL, "Tab1", tab)
End If
tab = GetTab2()
If ( Len(tab) > 0 ) Then
Call SA_MungeURL(sReturnURL, "Tab2", tab)
End If
Call SA_MungeURL(sReturnURL, SAI_FLD_PAGEKEY, SAI_GetPageKey())
If ( Len(sResourcesContainer) <= 0 ) Then
sResourcesContainer = "Resource"
End If
If ( Len(sWidthAttr) <= 0 ) Then
sWidthAttr = "100%"
End If
If ( Len(sHeightAttr) <= 0 ) Then
sHeightAttr = "250px"
End If
Call SA_MungeURL(sURL, "ContentTarget", sTarget)
Call SA_MungeURL(sURL, "ResContainer", sResourcesContainer)
Call SA_MungeURL(sURL, "Title", sPageTitle)
Call SA_MungeURL(sURL, "ReturnURL", sReturnURL)
Call SA_MungeURL(sURL, "Tab1", GetTab1())
Call SA_MungeURL(sURL, "Tab2", GetTab2())
Call SA_MungeURL(sURL, SAI_FLD_PAGEKEY, SAI_GetPageKey())
Response.Write("")
End Function
'--------------------------------------------------------------------
'
' Function: SA_EmitAdditionalStyleSheetReferences
'
' Synopsis: Emit optional OEM CSS references into the response stream
'
' Arguments: [in] sCSS_ContainerName optional container name to use for
' selecting the additional CSS sheets.
'
' Returns: Nothing
'
'--------------------------------------------------------------------
Public Function SA_EmitAdditionalStyleSheetReferences(ByVal sCSS_ContainerName)
on error resume next
err.clear
Dim sStyleURL
Dim oContainer
Dim oElement
If ( Len(Trim(sCSS_ContainerName)) <= 0 ) Then
sCSS_ContainerName = "CSS"
End If
Set oContainer = GetElements(sCSS_ContainerName)
If (Err.Number <> 0) Then
Exit Function
End If
For each oElement in oContainer
sStyleURL = Trim(oElement.GetProperty("URL"))
If (Err.Number = 0) Then
If ( Len(sStyleURL) > 0 ) Then
Response.Write(""+vbCrLf)
End If
End If
Next
Set oContainer = nothing
End Function
'--------------------------------------------------------------------
'
' Function: SA_GetHelpRootDirectory
'
' Synopsis: Return base directory for help files depending upon current
' language setting
'
' Arguments: [out] sRootHelp output variable to recieve root directory for help
' html files.
'
' Returns: True if success, False if an error occured. Errors are written
' to the web framework trace log file.
'
'--------------------------------------------------------------------
Function SA_GetHelpRootDirectory(ByRef sRootOut)
on error resume next
Err.Clear
Dim oLocalizationMgr
Dim iCurLangID
SA_GetHelpRootDirectory = TRUE
sRootOut = "help/"
Set oLocalizationMgr = Server.CreateObject("ServerAppliance.LocalizationManager")
If ( Err.Number <> 0 ) Then
SA_GetHelpRootDirectory = FALSE
Call SA_TraceOut("ContextHelp", "Server.CreateObject(ServerAppliance.LocalizationManager) encountered error: " + Err.Number + " " + Err.Description)
Exit Function
End If
iCurLangID = oLocalizationMgr.CurrentLangID
If ( Err.Number <> 0 ) Then
Set oLocalizationMgr = nothing
SA_GetHelpRootDirectory = FALSE
Call SA_TraceOut("ContextHelp", "oLocalizationMgr.CurrentLangID() encountered error: " + Err.Number + " " + Err.Description)
Exit Function
End If
'
' MUI Language directory names are 4 digit hex codes
'
iCurLangID = CStr(Hex(iCurLangID))
If ( Len(iCurLangID) < 4 ) Then
iCurLangID = Left("0000", 4 - Len(iCurLangID)) + iCurLangID
End If
sRootOut = m_VirtualRoot + sRootOut + iCurLangID + "/"
' Call SA_TraceOut("SH_PAGE", "SA_GetHelpRootDirectory returning: " + sRootOut)
Set oLocalizationMgr = nothing
End Function
'--------------------------------------------------------------------
'
' Function: SA_IsCurrentPageType
'
' Synopsis: Check if current page matches the specified page type
'
' Arguments: Page type (See PT_XXXX enumeration)
'
' Returns: True if it matches, otherwise false
'
'--------------------------------------------------------------------
Public Function SA_IsCurrentPageType(ByVal iPageType)
SA_ClearError()
If ( miPageType = iPageType ) Then
SA_IsCurrentPageType = true
Else
SA_IsCurrentPageType = false
End If
End Function
'----------------------------------------------------------------------------
'
' Function : SA_GetCharSet
'
' Synopsis : Gets character set to use for current language
'
' Arguments: None
'
' Returns : charset string
'
'----------------------------------------------------------------------------
Public Function SA_GetCharSet()
SA_GetCharSet = GetCharSet()
End Function
Private Function GetCharSet()
' Err.Clear
'
' Dim strCharSet
'
' ' call Localization Manager
' Set objLocMgr = Server.CreateObject("ServerAppliance.LocalizationManager")
'
' strCharSet = objLocMgr.CurrentCharSet
'
' if strCharSet ="" then
' strCharSet = "iso-8859-1"
' end if
'
' set objLocMgr = nothing
'
' GetCharSet = strCharSet
'Hard coded for Unicode
GetCharSet = "utf-8"
End Function
'----------------------------------------------------------------------------
'
' Function : ServePageHeader
'
' Synopsis : Serves the first part of the HTML
'
' Arguments: (IN) -
'
' Returns : None
'
'----------------------------------------------------------------------------
Private Function ServePageHeader(Caption)
End Function
'----------------------------------------------------------------------------
'
' Function : ServeStandardLabelBar
'
' Synopsis : Serves label text inside of a bar, with an optional image
'
' Arguments: Caption(IN) - label text
'
' Returns : None
'
'----------------------------------------------------------------------------
Private Function ServeStandardLabelBar(Caption)
%>
<% =Caption %>
<%
End Function
'----------------------------------------------------------------------------
'
' Function : ServeStandardHeaderBar
'
' Synopsis : Serves label text followed by a line
'
' Arguments: [in] sCaption label text
' [in] Image path to image file
'
' Returns : None
'
'----------------------------------------------------------------------------
Private Function ServeStandardHeaderBar(ByVal sCaption, ByVal Image)
If ( Len(CStr(Image)) <= 0 AND Len(CStr(sCaption)) <= 0 ) Then
Call SA_TraceOut("SH_PAGE", "ServeStandardHeaderBar() called with empty Caption and Image")
Exit Function
End If
If (Len(CStr(Image)) <= 0) Then
Response.Write("
"+Server.HTMLEncode(sCaption)+"
")
Else
Response.Write("
")
Response.Write("
")
Response.Write("
"+Server.HTMLEncode(sCaption)+"
")
Response.Write("
")
End If
End Function
'----------------------------------------------------------------------------
'
' Function : ServeAreaLabelBar
'
' Synopsis : Serves label text for area pages followed by line
'
' Arguments: Caption(IN) - label text
'
' Returns : None
'
'----------------------------------------------------------------------------
Private Function ServeAreaLabelBar(Caption)
%>
<% =Caption %>
<%
End Function
'----------------------------------------------------------------------------
'
' Function : SA_ServeBackButton
'
' Synopsis : Serves special back button (mostly used in area pages)
'
' Arguments: [in] bIndent - True if the button should be indented using
' blockquote. False if the button should not be indented.
' [in] strBackURL - URL that should be opened when the back
' button is pressed. If the URL is blank then the button will
' navigate to the last page using window.history.back()
'
' Returns : None
'
'----------------------------------------------------------------------------
Public Function SA_ServeBackButton(ByVal bIndent, ByVal strBackURL)
SA_ServeBackButton = ServeBackButton(bIndent, strBackURL)
End Function
Private Function ServeBackButton(ByVal bIndent, ByVal strBackURL)
If (bIndent) Then
Response.Write("
")
End If
%>
<%
Response.Write("")
%>
<%
If (bIndent) Then
Response.Write("
")
End If
End Function
'----------------------------------------------------------------------------
'
' Function : ServeAreaButton
'
' Synopsis : This function has been Deprecated, see SA_ServeOnClickButton
'
'----------------------------------------------------------------------------
Private Function ServeAreaButton(ByVal Caption, ByVal URL, ByVal Image, ByVal iWidth, ByVal iImageWidth)
Call SA_ServeOnClickButton(Caption, Image, URL, iWidth, iImageWidth, SA_DEFAULT)
End Function
'----------------------------------------------------------------------------
'
' Function : SA_ServeOnClickButton
'
' Synopsis : Serves image button that invokes the specified Javascript function when clicked.
'
' Arguments : [in] Caption Button caption
' [in] Image Button image
' [in] OnClickFn Javascript function to invoke when button is clicked
' [in] iWidth Width of button in pixels.
' [in] iImageWidth Width of button image in pixels
' [in] Attributes additional attributes, like DISABLED
'
' Returns : Nothing
'
'----------------------------------------------------------------------------
Public Function SA_ServeOnClickButton(ByVal Caption, ByVal Image, ByVal OnClickFn, ByVal iWidth, ByVal iImageWidth, ByVal Attributes)
Call SA_ServeOnClickButtonEx(Caption, Image, OnClickFn, iWidth, iImageWidth, Attributes, SA_DEFAULT)
End Function
Public Function SA_ServeOnClickButtonEx(ByVal Caption, ByVal Image, ByVal OnClickFn, ByVal iWidth, ByVal iImageWidth, ByVal Attributes, ByVal sButtonName)
Dim iCaptionWidth
Dim sButtonWidthAttr
Dim sImageWidthAttr
Dim sCaptionWidthAttr
Dim sCaptionAlign
'
' Edit parameters, iWidth must be greater than iImageWidth
'
If ( Len(iWidth) <= 0 ) Then
iWidth = 0
End If
If ( Len(iImageWidth) <= 0 ) Then
iImageWidth = 0
End If
iCaptionWidth = CInt(iWidth) - CInt(iImageWidth)
If ( iCaptionWidth <= 0 ) Then
iCaptionWidth = iWidth
End If
If ( iWidth > 0 ) Then
sButtonWidthAttr = " width="+CStr(iWidth)+" "
sCaptionWidthAttr = " width="+CStr(iCaptionWidth)+" "
Else
sButtonWidthAttr = ""
sCaptionWidthAttr = ""
End If
If ( iImageWidth > 0 ) Then
sImageWidthAttr = " width="+CStr(iImageWidth)+" "
Else
sImageWidthAttr = ""
End If
If ( Len(sButtonName) > 0 ) Then
sButtonName = " name="+sButtonName + " "
End If
If ( Len(Image) <= 0 AND iImageWidth <= 0 ) Then
sCaptionAlign = "align='center'"
Else
sCaptionAlign = ""
End If
'
' Emit the button
'
Response.Write(""+vbCrLf)
End Function
'----------------------------------------------------------------------------
'
' Function : SA_ServeOpenPageButton
'
' Synopsis : Create an image button that allows opening the specified page type.
'
' Arguments: [in] enPageType Type of page (PT_AREA, PT_PROPERTY, PT_TABBED, PT_WIZARD)
' [in] sURL URL of page to open
' [in] sReturnURL Return URL
' [in] sPageTitle Title for page
' [in] sButtonCaption Button caption
' [in] sButtonImage Button image
' [in] iButtonWidth Width of button
' [in] iButtonImageWidth Width of button image
' [in] sButtonAttr Additional HTML attributes for button (DISABLED)
'
' Returns : None
'
'----------------------------------------------------------------------------
Public Function SA_ServeOpenPageButton(ByVal enPageType, _
ByVal sURL, _
ByVal sReturnURL, _
ByVal sPageTitle, _
ByVal sButtonCaption, _
ByVal sButtonImage, _
ByVal iButtonWidth, _
ByVal iButtonImageWidth, _
ByVal sButtonAttr)
Call SA_ServeOpenPageButtonEx(enPageType, sURL, sReturnURL, sPageTitle, sButtonCaption, _
sButtonImage, iButtonWidth, iButtonImageWidth, sButtonAttr, SA_DEFAULT)
End Function
Public Function SA_ServeOpenPageButtonEx(ByVal enPageType, _
ByVal sURL, _
ByVal sReturnURL, _
ByVal sPageTitle, _
ByVal sButtonCaption, _
ByVal sButtonImage, _
ByVal iButtonWidth, _
ByVal iButtonImageWidth, _
ByVal sButtonAttr, _
ByVal sButtonName )
Dim sOpenPage
Dim iCaptionWidth
Dim sButtonWidthAttr
Dim sImageWidthAttr
Dim sCaptionWidthAttr
Dim sCaptionAlign
'
' Edit parameters, iButtonWidth must be greater than iImageWidth
'
If ( Len(iButtonWidth) <= 0 ) Then
iButtonWidth = 0
End If
If ( Len(iButtonImageWidth) <= 0 ) Then
iButtonImageWidth = 0
End If
iCaptionWidth = iButtonWidth - iButtonImageWidth
If ( iCaptionWidth <= 0 ) Then
iCaptionWidth = iButtonWidth
End If
If ( iButtonWidth > 0 ) Then
sButtonWidthAttr = " width="+CStr(iButtonWidth)+" "
sCaptionWidthAttr = " width="+CStr(iCaptionWidth)+" "
Else
sButtonWidthAttr = ""
sCaptionWidthAttr = ""
End If
If ( iButtonImageWidth > 0 ) Then
sImageWidthAttr = " width="+CStr(iButtonImageWidth)+" "
Else
sImageWidthAttr = ""
End If
If ( Len(sButtonName) > 0 ) Then
sButtonName = " name="+Trim(sButtonName)
Else
sButtonName = " name="+Trim(SAI_GetNextButtonName())
End If
If ( Len(sButtonImage) <= 0 AND iButtonImageWidth <= 0 ) Then
sCaptionAlign = "align='center'"
Else
sCaptionAlign = ""
End If
'
' Get the open page script
Select Case enPageType
Case PT_AREA
sOpenPage = "onClick=""SA_OnOpenNormalPage('"+m_VirtualRoot+"', '"+sURL+"', '"+sReturnURL+"'); "" "
Case PT_PROPERTY
sOpenPage = "onClick=""SA_OnOpenPropertyPage('"+m_VirtualRoot+"', '"+sURL+"', '"+sReturnURL+"', '"+sPageTitle+"'); "" "
Case PT_TABBED
sOpenPage = "onClick=""SA_OnOpenPropertyPage('"+m_VirtualRoot+"', '"+sURL+"', '"+sReturnURL+"', '"+sPageTitle+"'); "" "
Case PT_WIZARD
sOpenPage = "onClick=""SA_OnOpenPropertyPage('"+m_VirtualRoot+"', '"+sURL+"', '"+sReturnURL+"', '"+sPageTitle+"'); "" "
Case Else
Call SA_TraceOut("SH_PAGE", "SA_ServeOpenPageButton invalid PageType: " +CStr(enPageType))
sOpenPage = "onClick=""SA_OnOpenNormalPage('"+m_VirtualRoot+"', '"+sURL+"', '"+sReturnURL+"'); "" "
End Select
'Call SA_TraceOut("SH_PAGE", sOpenPage)
'
' Emit the button
'
Response.Write(""+vbCrLf)
End Function
'----------------------------------------------------------------------------
'
' Function : SA_IsIE
'
' Synopsis : Is client browser IE
'
' Arguments: None
'
' Returns : true/false
'
'----------------------------------------------------------------------------
Public Function SA_IsIE()
SA_IsIE = IsIE()
End Function
Private Function IsIE()
If InStr(Request.ServerVariables("HTTP_USER_AGENT"), "MSIE") Then
IsIE = True
Else
IsIE = False
End If
End Function
'----------------------------------------------------------------------------
'
' Function : GetFirstTabURL
'
' Synopsis : Get URL of the first tab
'
' Arguments: None
'
' Returns : URL string of the first tab
'
'----------------------------------------------------------------------------
Function GetFirstTabURL()
Dim objTabs
Dim objTab
Dim strHomeURL
strHomeURL = ""
Set objTabs = GetElements("TABS")
For Each objTab in objTabs
strHomeURL = objTab.GetProperty("URL")
Exit For
Next
Set objTab = Nothing
Set objTabs = Nothing
GetFirstTabURL = strHomeURL
End Function
'----------------------------------------------------------------------------
'
' Function : GetServerName
'
' Synopsis : Return server name as referred to in remote client
'
' Arguments: None
'
' Returns : server name string
'
'----------------------------------------------------------------------------
Function GetServerName()
GetServerName = Request.ServerVariables("SERVER_NAME")
End Function
'----------------------------------------------------------------------------
'
' Function : GetScriptFileName
'
' Synopsis : file name of current file being request by client
'
' Arguments: None
'
' Returns : file name string
'
'----------------------------------------------------------------------------
Public Function SA_GetScriptFileName()
SA_GetScriptFileName = GetScriptFileName()
End Function
Private Function GetScriptFileName()
Dim strPath
Dim intPos
strPath = Request.ServerVariables("PATH_INFO")
intPos = InStr(strPath, "/")
Do While intPos > 0
strPath = Right(strPath, Len(strPath) - intPos)
intPos = InStr(strPath, "/")
Loop
GetScriptFileName = strPath
End Function
'----------------------------------------------------------------------------
'
' Function : SA_GetScriptPath
'
' Synopsis : path of file name being request by client
'
' Arguments: None
'
' Returns : path string
'
'----------------------------------------------------------------------------
Public Function SA_GetScriptPath()
SA_GetScriptPath = GetScriptPath()
End Function
Function GetScriptPath()
' Returns the path w/o virtual root
'
Dim strPath
strPath = Request.ServerVariables("PATH_INFO")
If Left(strPath, Len(m_VirtualRoot)) = m_VirtualRoot Then
strPath = Right(strPath, Len(strPath)-Len(m_VirtualRoot))
End If
'In XPE, we need to remove the virtualRoot from the ScriptPath
If CONST_OSNAME_XPE = GetServerOSName() Then
strPath = "/" & strPath
if inStr(strPath, m_VirtualRoot) = 1 Then
strPath = mid(strPath, Len(m_VirtualRoot)+1)
End If
End If
GetScriptPath = strPath
End Function
'----------------------------------------------------------------------------
'
' Function : SA_GetLocString
'
' Synopsis : Retrieves a localized string resource
'
' Arguments: SourceFile(IN) - resource dll name
' ResourceID(IN) - resource id in hex
' ReplacementStrings(IN) - parameters to replace in string
'
' Returns : localized string
'
'----------------------------------------------------------------------------
Public Function SA_GetLocString(ByVal SourceFile, ByVal ResourceID, ByRef ReplacementStrings)
SA_GetLocString = GetLocString(SourceFile, ResourceID, ReplacementStrings)
End Function
Private Function GetLocString(ByVal SourceFile, ByVal ResourceID, ByRef ReplacementStrings)
on error resume next
Err.Clear
Dim errorCode
Dim errorDesc
Dim varReplacementStrings
Dim sDebugResourceID
sDebugResourceID = ResourceID
'
' Validate parameters
'
If Left(ResourceID, 2) <> "&H" Then
ResourceID = "&H" & ResourceID
End If
If Trim(SourceFile) = "" Then
SourceFile = "svrapp"
End If
If (Not IsArray(ReplacementStrings)) Then
ReplacementStrings = varReplacementStrings
End If
'
' Initialize the localization manager private global object reference
'
If ( NOT IsObject(m_oLocManager) ) Then
Set m_oLocManager = Server.CreateObject("ServerAppliance.LocalizationManager")
If ( Err.Number <> 0 ) Then
GetLocString = sDebugResourceID
Call SA_TraceOut("SH_PAGE", _
"Server.CreateObject(ServerAppliance.LocalizationManager) encountered exception: " _
+ CStr(Hex(Err.Number)) + " " + Err.Description)
Exit Function
End If
End If
'
' Get the string
'
GetLocString = m_oLocManager.GetString(SourceFile, ResourceID, ReplacementStrings)
'
' Check error codes, primary error is string resource not found
'
errorCode = Err.Number
errorDesc = Err.description
Err.Clear
If errorCode <> 0 Then
GetLocString = sDebugResourceID
End If
End Function
'----------------------------------------------------------------------------
'
' Function : SA_EscapeQuotes
'
' Synopsis : Insert escape character before quote
'
' Arguments: InString(IN) - string to fix
'
' Returns : None
'
'----------------------------------------------------------------------------
Public Function SA_EscapeQuotes(ByVal InString)
SA_EscapeQuotes = EscapeQuotes(InString)
End Function
Function EscapeQuotes(ByVal InString)
Dim i
Dim strOut
strOut = InString
i = 1
Do While i <> 0
i = InStr(i, strOut, "'")
If i <> 0 Then
If (i > 1) And (Mid(strOut, i-1, 2) = "\'") Then
' input string was escaped already - do nothing
Else
strOut = Left(strOut, i-1) & "\'" & Right(strOut, Len(strOut)-i)
End If
End If
If (i < Len(strOut)) And (i <> 0) Then
i = i + 1
Else
Exit Do
End If
Loop
'
' Do not HTML encode the return url. If anything, URLEncode it
'
'EscapeQuotes = Server.HTMLEncode(strOut)
'
EscapeQuotes = strOut
End Function
'----------------------------------------------------------------------------
'
' Function : SA_GetElements
'
' Synopsis : Return collection of IWebElement objects based on the
' Container parm
'
' Arguments: Container(IN) - container name
'
' Returns : collection of elements
'
'----------------------------------------------------------------------------
Public Function SA_GetElements(ByVal Container)
Set SA_GetElements = GetElements(Container)
End Function
Function GetElements(ByVal Container)
'Return collection of IWebElement objects based on the Container parm.
Dim objRetriever
Dim objElements
Set objRetriever = Server.CreateObject("Elementmgr.ElementRetriever")
Set objElements = objRetriever.GetElements(1, Container)
If Err.Number <> 0 Then
Err.Clear
End If
Set GetElements = objElements
Set objElements = Nothing
Set objRetriever = Nothing
End Function
Public Function SA_ServeRestartingPage(ByVal strOption, ByVal sInitialWait, ByVal sRetryWait, ByVal strRsrcDLL, ByVal sTitleRID, ByVal sMessageRID)
Call SA_ServeRestartingPageEx( strOption, sInitialWait, sRetryWait, strRsrcDLL, sTitleRID, sMessageRID, SA_DEFAULT )
End Function
Public Function SA_ServeRestartingPageEx(ByVal strOption, ByVal sInitialWait, ByVal sRetryWait, ByVal strRsrcDLL, ByVal sTitleRID, ByVal sMessageRID, ByVal sURLBase)
Dim sURL
sURL = m_VirtualRoot + "sh_restarting.asp"
If ( Len(strOption) > 0 ) Then
Call SA_MungeURL(sURL, "Option", strOption)
Else
Call SA_MungeURL(sURL, "Resrc", strRsrcDLL)
Call SA_MungeURL(sURL, "Title", sTitleRID)
Call SA_MungeURL(sURL, "Msg", sMessageRID)
End If
Call SA_MungeURL(sURL, "T1", sInitialWait)
Call SA_MungeURL(sURL, "T2", sRetryWait)
Call SA_MungeURL(sURL, "URLBase", sURLBase)
Call SA_MungeURL(sURL, SAI_FLD_PAGEKEY, SAI_GetPageKey())
Randomize
Call SA_MungeURL(sURL, "R", CStr(Rnd()))
%>
<%
Response.End
End Function
'----------------------------------------------------------------------------
'
' Function : Redirect
'
' Synopsis : Redirect to given URL
'
' Arguments: URL(IN) - URL to redirect to
'
' Returns : None
'
'----------------------------------------------------------------------------
Function Redirect(URL)
%>
<%
End Function
'----------------------------------------------------------------------------
'
' Function : SwapRows
'
' Synopsis : Swap routine used by QuickSort
'
' Arguments: arr(IN) - array whose row needs to be swapped
' row1(IN) - row to swap
' row2(IN) - row to swap
'
' Returns : None
'
'----------------------------------------------------------------------------
Sub SwapRows(ary,row1,row2)
'== This proc swaps two rows of an array
Dim x,tempvar
For x = 0 to Ubound(ary,2)
tempvar = ary(row1,x)
ary(row1,x) = ary(row2,x)
ary(row2,x) = tempvar
Next
End Sub 'SwapRows
'----------------------------------------------------------------------------
'
' Function : QuickSort
'
' Synopsis : the quick sort algorithm
'
' Arguments: vec(IN) - array whose row needs to be swapped
' loBound(IN) - lower bound of array vec
' hiBound(IN) - upped bound of array vec
' SortField(IN) - the field to sort on
'
' Returns : None
'
'----------------------------------------------------------------------------
Sub QuickSort(vec, loBound, hiBound, SortField)
Dim pivot(),loSwap,hiSwap,temp,counter
Redim pivot (Ubound(vec,2))
'== Two items to sort
if hiBound - loBound = 1 then
if vec(loBound,SortField) > vec(hiBound,SortField) then Call SwapRows(vec,hiBound,loBound)
End If
'== Three or more items to sort
For counter = 0 to Ubound(vec,2)
pivot(counter) = vec(int((loBound + hiBound) / 2),counter)
vec(int((loBound + hiBound) / 2),counter) = vec(loBound,counter)
vec(loBound,counter) = pivot(counter)
Next
loSwap = loBound + 1
hiSwap = hiBound
do
'== Find the right loSwap
while loSwap < hiSwap and vec(loSwap,SortField) <= pivot(SortField)
loSwap = loSwap + 1
wend
'== Find the right hiSwap
while vec(hiSwap,SortField) > pivot(SortField)
hiSwap = hiSwap - 1
wend
'== Swap values if loSwap is less then hiSwap
if loSwap < hiSwap then Call SwapRows(vec,loSwap,hiSwap)
loop while loSwap < hiSwap
For counter = 0 to Ubound(vec,2)
vec(loBound,counter) = vec(hiSwap,counter)
vec(hiSwap,counter) = pivot(counter)
Next
'== Recursively call function .. the beauty of Quicksort
'== 2 or more items in first section
if loBound < (hiSwap - 1) then Call QuickSort(vec,loBound,hiSwap-1,SortField)
'== 2 or more items in second section
if hiSwap + 1 < hibound then Call QuickSort(vec,hiSwap+1,hiBound,SortField)
End Sub 'QuickSort
'----------------------------------------------------------------------------
'
' Function : getVirtualDirectory
'
' Synopsis : Gets the virtual directory where the serverappliance is installed.
'
' Arguments: None
'
' Returns : The virtual directory where serverappliance is installed.
'
'----------------------------------------------------------------------------
Function getVirtualDirectory
getVirtualDirectory = "/admin/"
'Dim strVDir,strFinal
'Dim idx
'strVDir = Request.ServerVariables("APPL_MD_PATH")
'idx = instr(2,strVDir,"ROOT",1)
'strFinal=mid(strVDir,idx+4)
'If strFinal<>"" Then
' strFinal=strFinal& "/"
'else
' strFinal ="/"
'End IF
'getVirtualDirectory=strFinal
End Function
'----------------------------------------------------------------------------
'
' Function : SA_GetCurrentURL
'
' Synopsis : Gets the current url including query string
'
' Arguments: None
'
' Returns : The current url including query string
'
'----------------------------------------------------------------------------
Public Function SA_GetCurrentURL()
SA_GetCurrentURL = Request.ServerVariables("URL") + "?" + Request.ServerVariables("QUERY_STRING")
End Function
'-------------------------------------------------------------------------
'Function name: CheckForSecureSite
'Description:
'Output Variables: None
'Returns: None
'-------------------------------------------------------------------------
Sub CheckForSecureSite()
Dim objContextHelp
Dim objElement
Dim strHelpURL
Dim strSecureURL
Dim strURL
Dim L_WARN_TO_USE_HTTPS
Dim L_WARN_TO_INSTALL_CERT
Dim L_SECURE_SITE_LINK_PROMPT
L_WARN_TO_INSTALL_CERT = GetLocString("sacoremsg.dll", "&H402003EB", "")
Dim sHelpRoot
Call SA_GetHelpRootDirectory(sHelpRoot)
'strHelpURL = sHelpRoot + "_nas_HTTPS__Creating_a_Secure_Connection.htm"
' No SSL Certificate case
If ( FALSE = SAI_IsSSLCertificateInstalled()) Then
Response.write ("
" & L_WARN_TO_INSTALL_CERT & " " & "
" )
' Not using https warn use to use https
ElseIf LCASE( Request.ServerVariables("HTTPS") ) = "off" Then
Dim sSecureWebSite
Dim sSecurePort
Dim aRepString(1)
sSecurePort = SAI_GetSecurePort()
If ( sSecurePort > 0 ) Then
aRepString(0) = CStr(sSecurePort)
L_WARN_TO_USE_HTTPS = GetLocString("sacoremsg.dll", "&H402003E9", aRepString)
sSecureWebSite = SA_GetNewHostURLBase("", sSecurePort, TRUE, "")
Call SA_TraceOut("SH_PAGE", "Secure URL: " + sSecureWebSite)
If ( Len(sSecureWebSite) > 0 ) Then
L_SECURE_SITE_LINK_PROMPT = GetLocString("sacoremsg.dll", "402003EC", "")
End If
Else
L_WARN_TO_USE_HTTPS = GetLocString("sacoremsg.dll", "&H402003EA", "")
End If
strURL = "javascript:OpenRawPage('" & sSecureWebSite & "' );"
Response.write ("
" )
End If
End Sub
'----------------------------------------------------------------------------
'
' Function : SA_ServeFailurePage
'
' Synopsis : Serve the page which redirects the browser to the err_view.asp
' failure page
'
' Arguments: Message(IN) - message to be displayed by err_view.asp
'
' Returns : None
'
'----------------------------------------------------------------------------
Public Function SA_ServeFailurePage(ByVal Message)
Call SA_ServeFailurePageEx(Message, mstrReturnURL)
End Function
'----------------------------------------------------------------------------
'
' Function : SA_ServeFailurePageEx
'
' Synopsis : Serve the page which redirects the browser to the err_view.asp
' failure page
'
' Arguments: [in] Message - Message that will be displayed in the error page
' [in] ReturnURL - URL that should be navigated to when the user
' clicks the OK button. If this value is SA_DEFAULT
' the default home page will be used.
'
' Returns : None
'
'----------------------------------------------------------------------------
Public Function SA_ServeFailurePageEx(ByVal Message, sReturnPage)
Dim sReturnURL
Dim sFailurePageURL
Const MINIMUM_VALID_URL = 3
Response.Clear
sReturnURL = sReturnPage
If ( Len(sReturnURL) <= MINIMUM_VALID_URL ) Then
sReturnURL = m_VirtualRoot + "default.asp"
Else
'
' Make sure ReturnURL has the virtual root prepended
If ( Left(sReturnURL, Len("http://")) = "http://" OR Left(sReturnURL, Len("https://")) = "https://" ) Then
'
' ReturnURL is fully qualified
'
ElseIf ( Left(sReturnURL, 1) <> "/" ) Then
'
' Prepend the virtual root
'
sReturnURL = m_VirtualRoot + sReturnURL
End If
End If
Randomize()
Call SA_MungeURL(sReturnURL, "R", ""+CStr(Rnd()))
sFailurePageURL = m_VirtualRoot + "util/err_view.asp"
Call SA_MungeURL( sFailurePageURL, "Message", Message)
Call SA_MungeURL( sFailurePageURL, "ReturnURL", sReturnURL)
Call SA_TraceOut(SA_GetScriptFileName(), "SA_ServeFailurePage redirecting to: " + sFailurePageURL)
%>
<%
Response.Flush
Response.End
End Function
'--------------------------------------------------------------------
'
' Function: SA_MungeURL
'
' Synopsis: Munge the specified URL, to add, update, or delete the specified
' parameter. This function will URLEncode the sParamValue parameter,
' DO NOT Server.URLEncode(sParamValue) before passing to this function.
'
' To delete a parameter value from the URL, specify the parameter name
' and a blank value as in:
' Call SA_MungURL(sURL, "FavoriteFood", "")
'
' To add or update a parameter to the URL, specify the parameter name
' and a valid non-blank value as in:
' Call SA_MungeURL(sURL, "FavoriteFood", "ApplePie")
'
' Arguments: [in/out] sURL - URL that is to be Munged, or updated.
' [in] sParamName - Name of parameter that is to be changed
' or added.
' [in] sParamValue - Value of the parameter
'
' Returns: Nothing
'
' Example:
' Dim sURLExample
' Dim sOutput
'
' sURLExample = "http://localhost/Tasks.asp?Param1=Red&Param2=Peach&Param3=Bird"
' sOutput = "Starting with: " + sURLExample + vbCrLf
'
' Call SA_MungeURL(sURLExample, "Param1", "Green")
' sOutput = sOutput + sURLExample + vbCrLf
'
' Call SA_MungeURL(sURLExample, "Param1", "Blue")
' sOutput = sOutput + sURLExample + vbCrLf
'
' Call SA_MungeURL(sURLExample, "Param3", "Dog")
' sOutput = sOutput + sURLExample + vbCrLf
'
' Call SA_MungeURL(sURLExample, "Param2", "Pear")
' sOutput = sOutput + sURLExample + vbCrLf
'
' Call SA_MungeURL(sURLExample, "Param4", "Software")
' sOutput = sOutput + sURLExample + vbCrLf
'
' WScript.Echo sOutput
'
'--------------------------------------------------------------------
Public Function SA_MungeURL(ByRef sURL, ByVal sParamName, ByVal sParamValue)
Dim rc
SA_MungeURL = 0
'
' Strip off leading ?, & parameter token if it exists.
' We are going to check for both cases in the URL.
'
sParamName = SA_StripParamToken(sParamName)
'
' Strip leading and trailing spaces
'
sParamName = Trim(sParamName)
sParamValue = Trim(sParamValue)
'
' Is this a delete parameter request
'
If (Len(sParamValue) <= 0 ) Then
'
' Look for parameter using the ? token
'
rc = SA_DelURLParamInternal(sURL, "&"+sParamName)
If ( rc <> TRUE ) Then
'
' Look for parameter using the "?" token
'
Call SA_DelURLParamInternal(sURL, "?"+sParamName)
End If
Exit Function
End If
'
' URL Encode the parameter value
'
sParamValue = Server.URLEncode(sParamValue)
'
' Look for matching param starting with "&" token
'
rc = SA_SetURLParamInternal(sURL, "&"+sParamName, sParamValue)
If ( rc <> TRUE ) Then
'
' Look for matching param starting with "?" token
'
rc = SA_SetURLParamInternal(sURL, "?"+sParamName, sParamValue)
If ( rc <> TRUE ) Then
'
' Param did not exist in the URL, add it
'
If InStr(sURL, "?") Then
sURL = sURL + "&" + sParamName + "=" + sParamValue
Else
sURL = sURL + "?" + sParamName + "=" + sParamValue
End If
End If
End If
End Function
Public Function SA_SetURLParamInternal(ByRef sURL, ByVal sParamName, ByVal sParamValue)
SA_SetURLParamInternal = FALSE
Dim i
Dim sUrl1
Dim sUrl2
'
' Do Case insensitive search, starting in the first position
'
i = InStr(1, sURL, sParamName+"=", 1)
If ( i > 0 ) Then
sURL1 = Left(sURL, i - 1)
sURL2 = Mid(sURL, i + 1)
i = InStr(sURL2, "&")
If ( i > 0 ) Then
sURL2 = Mid( sURL2, i )
Else
sURL2 = ""
End If
If InStr(sURL1, "?") Then
sURL = sURL1 + "&" + SA_StripParamToken(sParamName) + "=" + sParamValue + sURL2
Else
sURL = sURL1 + "?" + SA_StripParamToken(sParamName) + "=" + sParamValue + sURL2
End If
SA_SetURLParamInternal = TRUE
End If
End Function
Public Function SA_DelURLParamInternal(ByRef sURL, ByVal sParamName)
SA_DelURLParamInternal = FALSE
Dim i
Dim sUrl1
Dim sUrl2
'
' Do Case insensitive search, starting in the first position
'
i = InStr(1, sURL, sParamName+"=", 1)
If ( i > 0 ) Then
sURL1 = Left(sURL, i - 1)
sURL2 = Mid(sURL, i + 1)
i = InStr(sURL2, "&")
If ( i > 0 ) Then
sURL2 = Mid( sURL2, i )
Else
sURL2 = ""
End If
If InStr(sURL1, "?") Then
sURL = sURL1 + sURL2
ElseIf (Len(sURL2) > 0 ) Then
sURL = sURL1 + "?" + SA_StripParamToken(sURL2)
Else
sURL = sURL1
End If
SA_DelURLParamInternal = TRUE
End If
End Function
Public Function SA_StripParamToken(ByRef sParam )
If (Left(sParam,1) = "?") OR (Left(sParam,1) = "&") Then
SA_StripParamToken = Mid(sParam, 2)
Else
SA_StripParamToken = sParam
End If
End Function
Private Function SAI_IsSSLCertificateInstalled()
on error resume next
Err.Clear
Dim oWebServer
Dim sAdminSiteID
SAI_IsSSLCertificateInstalled = FALSE
'sAdminSiteID = SAI_GetWebSiteID("Administration" )
sAdminSiteID = GetCurrentWebsiteName()
Call SA_TraceOut("SH_PAGE", "SAI_IsSSLCertificateInstalled - Checking for SSL Certificate on site ID: " + sAdminSiteID)
Set oWebServer = GetObject( "IIS://localhost/" + sAdminSiteID )
If (Len(oWebServer.SSLStoreName) > 0 ) Then
Call SA_TraceOut("SH_PAGE", "SSL Certificate found")
SAI_IsSSLCertificateInstalled = TRUE
End IF
Set oWebServer = Nothing
End Function
Function SAI_GetSecurePort()
On Error Resume Next
Err.Clear
Dim strSitename
Dim objService
Dim objWebsite
Dim strObjPath
Dim strSSLPort
Dim strIPArr
SAI_GetSecurePort = 0
strSitename = GetCurrentWebsiteName()
'strSitename = SAI_GetWebSiteID("Administration" )
strObjPath = GetIISWMIProviderClassName("IIs_WebServerSetting") & ".Name=" & chr(34) & strSitename & chr(34)
Set objService = GetWMIConnection(CONST_WMI_IIS_NAMESPACE)
Set objWebsite = objService.get(strObjPath)
If IsIIS60Installed() Then
strSSLPort = objWebsite.SecureBindings(0).Port
strSSLPort = Left(strSSLPort, len(strSSLPort)-1)
Else
strIPArr=split(objWebsite.SecureBindings(0),":")
strSSLPort = strIPArr(1)
End If
If Err.number <> 0 Then
SA_TraceOut "SH_PAGE", "SAI_GetSecurePort(): failed:" + CStr(Hex(Err.Number))
Exit Function
End If
SAI_GetSecurePort = strSSLPort
Call SA_TraceOut("sh_page", "SAI_GetSecurePort() returning: " & SAI_GetSecurePort )
End Function
%>
![](" & m_VirtualRoot & "images/alert.gif)