home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
DOS/V Power Report 2000 March
/
VPR0003B.ISO
/
nec98
/
iissettings.bas
< prev
next >
Wrap
BASIC Source File
|
1999-10-14
|
8KB
|
270 lines
Attribute VB_Name = "Settings"
Option Explicit
Global Const APP_PATH As String = "IIS://localhost/w3svc/1/Root/IISSamples"
Global Const APP_NAME As String = "ExAir"
' The main entry into setting all the IIS ExAir options
Public Function IISSettings(strPath As String) As Boolean
On Error GoTo ErrorHandler
NukeApplication
' For debugging only
'MsgBox "Nuked"
SetDir strPath, APP_NAME
SetDir strPath, APP_NAME & "/Catalog"
SetDir strPath, APP_NAME & "/Benefits"
SetDir strPath, APP_NAME & "/FreqFlyer"
SetDir strPath, APP_NAME & "/BusinessPartners"
SetDir strPath, APP_NAME & "/SiteAdmin"
' For debugging only
'MsgBox "Paths set"
SetSecurity strPath
SetErrorRedirects strPath & "ErrPages"
' For debugging only
'MsgBox "About to set applications"
SetApplication APP_NAME, "Exploration Air Sample Site", True
SetApplication APP_NAME & "/Catalog", "Test Catalog Site", False
SetApplication APP_NAME & "/Benefits", "Intranet Benefits", True
' For debugging only
'MsgBox "Applications set"
SetDebug
IISSettings = True
Exit Function
ErrorHandler:
MsgBox "An error occurred while setting ExAir config details." _
& " The error is: " & Hex(Err.Number) & " " & Err.Description, _
vbOKOnly + vbExclamation, "ExAir Config. Error"
IISSettings = False
End Function
' Attempt to delete an existing ExAir application
Private Sub NukeApplication()
Dim oRoot As Object
On Error Resume Next
Set oRoot = GetObject(APP_PATH)
If Err <> 0 Then GoTo NoPath
oRoot.Delete "IIsWebDirectory", APP_NAME
If Err <> 0 Then GoTo NoWebDir
SmallSleep
oRoot.SetInfo
SmallSleep
NoPath:
NoWebDir:
Set oRoot = Nothing
End Sub
' Set ExAir etc as a directory
Private Sub SetDir(strPath As String, strName As String)
On Error GoTo ErrorHandler
Dim oRoot As Object
Dim oDir As Object
Set oRoot = GetObject(APP_PATH)
SmallSleep
SmallSleep
Set oDir = oRoot.Create("IIsWebDirectory", strName)
oDir.SetInfo
Set oDir = Nothing
Set oRoot = Nothing
Exit Sub
ErrorHandler:
MsgBox "An error occurred while setting ExAir Web Directory details." _
& " The error is: " & Hex(Err.Number) & " " & Err.Description, _
vbOKOnly + vbExclamation, "ExAir Config. Error (SetDir)"
End Sub
' Turn on debugging for the IISSamples VDir
Private Sub SetDebug()
On Error GoTo ErrorHandler
Dim oRoot As Object
Set oRoot = GetObject(APP_PATH)
oRoot.AppAllowDebugging = True
Set oRoot = Nothing
Exit Sub
ErrorHandler:
MsgBox "An error occurred while setting ExAir Web Debugging." _
& " The error is: " & Hex(Err.Number) & " " & Err.Description, _
vbOKOnly + vbExclamation, "ExAir Config. Error (SetDebug)"
End Sub
' Set the application type...
Private Sub SetApplication(strAppName As String, strFriendlyName As String, fInProc As Boolean)
On Error GoTo ErrorHandler
Dim oRoot As Object
Dim oDir As Object
Dim strWhere As String
strWhere = "getting Root"
Set oRoot = GetObject(APP_PATH)
strWhere = "getting app"
Set oDir = oRoot.GetObject("IISWebDirectory", strAppName)
SmallSleep
SmallSleep
strWhere = "creating app"
oDir.AppCreate fInProc ' Run the application in-process/out-of-proc
strWhere = "setting friendly name"
oDir.AppFriendlyName = strFriendlyName ' Name of application
strWhere = "setting exception handling"
oDir.AspExceptionCatchEnable = False ' We don't want ASP to catch exceptions (makes debugging easier!)
strWhere = "flushing info"
oDir.SetInfo
Set oDir = Nothing
Set oRoot = Nothing
Exit Sub
ErrorHandler:
MsgBox "An error occurred setting ExAir Web Applications details while " & strWhere & "." _
& " The error is: " & Hex(Err.Number) & " " & Err.Description, _
vbOKOnly + vbExclamation, "ExAir Config. Error (SetApplication - " & strAppName & ")"
End Sub
' Set some of the error pages (403.4, 403.7 & 404)
Private Sub SetErrorRedirects(strDir As String)
On Error GoTo ErrorHandler
Dim oRoot As Object
Dim oDir As Object
Set oRoot = GetObject(APP_PATH)
Set oDir = oRoot.GetObject("IIsWebDirectory", APP_NAME)
Dim strErrs(), strErr
Dim i As Integer, j As Integer
Dim strReplace(3) As String
strReplace(0) = "403,4,FILE," & strDir & "\Err403-4.htm"
strReplace(1) = "403,7,FILE," & strDir & "\Err403-7.htm"
strReplace(2) = "404,*,FILE," & strDir & "\Err404.htm"
' First get all the existing errors
' Then search for the error message in the collection
' If the error exists then replace it with the correct one from strReplace()
i = 0
Const SEARCH_SIZE As Integer = 5
For Each strErr In oDir.HttpErrors
ReDim Preserve strErrs(i)
strErrs(i) = strErr
For j = 0 To 2
If Left(strErr, SEARCH_SIZE) = Left(strReplace(j), SEARCH_SIZE) Then
strErrs(i) = strReplace(j)
Exit For
End If
Next j
i = i + 1
Next
oDir.HttpErrors = strErrs
oDir.SetInfo
Set oDir = Nothing
Set oRoot = Nothing
Exit Sub
ErrorHandler:
MsgBox "An error occurred while setting ExAir Error details." _
& " The error is: " & Hex(Err.Number) & " " & Err.Description, _
vbOKOnly + vbExclamation, "ExAir Config. Error (SetErrorRedirects)"
End Sub
' Set SSL requirements on two directories
' Set Authentication requirements on one
Private Sub SetSecurity(strPath As String)
On Error GoTo ErrorHandler
Dim oRoot As Object
Dim oDir As Object
Set oRoot = GetObject(APP_PATH)
Set oDir = oRoot.GetObject("IIsWebDirectory", APP_NAME)
' SSL Constants from IISCnfg.h
Const ACCESS_SSL As Integer = &H8
Const ACCESS_SSL_ALLOW_CERT = &H20
Const ACCESS_SSL_REQUIRE_CERT As Integer = &H40
' Authentication constants from IISCnfg.h
Const AUTH_NTLM As Integer = &H4
Dim oFFDir As Object
Set oFFDir = oDir.GetObject("IIsWebDirectory", "FreqFlyer")
oFFDir.AccessSSLFlags = 0 ' Use ACCESS_SSL for SSL channel
oFFDir.SetInfo
Set oFFDir = Nothing
Dim oBizDir As Object
Set oBizDir = oDir.GetObject("IIsWebDirectory", "BusinessPartners")
oBizDir.AccessSSLFlags = 0 ' Use ACCESS_SSL + ACCESS_SSL_REQUIRE_CERT + ACCESS_SSL_ALLOW_CERT for client authentication
oBizDir.SetInfo
Set oBizDir = Nothing
Dim oAdminDir As Object
Set oAdminDir = oDir.GetObject("IIsWebDirectory", "SiteAdmin")
oAdminDir.AuthFlags = AUTH_NTLM
oAdminDir.SetInfo
Set oAdminDir = Nothing
Dim oBenefitsDir As Object
Set oBenefitsDir = oDir.GetObject("IIsWebDirectory", "Benefits")
' oBenefitsDir.AuthFlags = AUTH_NTLM
oBenefitsDir.SetInfo
Set oBenefitsDir = Nothing
Set oDir = Nothing
Set oRoot = Nothing
Exit Sub
ErrorHandler:
MsgBox "An error occurred while setting ExAir Security details." _
& " The error is: " & Hex(Err.Number) & " " & Err.Description, _
vbOKOnly + vbExclamation, "ExAir Config. Error (SetSecurity)"
End Sub
Private Sub SmallSleep()
Sleep 1000
End Sub