home *** CD-ROM | disk | FTP | other *** search
/ Chip 1998 February / CHIP_2_98.iso / software / pelne / optionp / iis4_07.cab / IISsettings.bas < prev    next >
BASIC Source File  |  1997-11-01  |  8KB  |  270 lines
  1. Attribute VB_Name = "Settings"
  2. Option Explicit
  3.  
  4. Global Const APP_PATH As String = "IIS://localhost/w3svc/1/Root/IISSamples"
  5. Global Const APP_NAME As String = "ExAir"
  6.  
  7.  
  8. ' The main entry into setting all the IIS ExAir options
  9. Public Function IISSettings(strPath As String) As Boolean
  10.     
  11.     On Error GoTo ErrorHandler
  12.     
  13.     NukeApplication
  14.     
  15.     ' For debugging only
  16.     'MsgBox "Nuked"
  17.     
  18.     SetDir strPath, APP_NAME
  19.     SetDir strPath, APP_NAME & "/Catalog"
  20.     SetDir strPath, APP_NAME & "/Benefits"
  21.     SetDir strPath, APP_NAME & "/FreqFlyer"
  22.     SetDir strPath, APP_NAME & "/BusinessPartners"
  23.     SetDir strPath, APP_NAME & "/SiteAdmin"
  24.     
  25.     ' For debugging only
  26.     'MsgBox "Paths set"
  27.     
  28.     SetSecurity strPath
  29.     SetErrorRedirects strPath & "ErrPages"
  30.     
  31.     ' For debugging only
  32.     'MsgBox "About to set applications"
  33.     
  34.     SetApplication APP_NAME, "Exploration Air Sample Site", True
  35.     SetApplication APP_NAME & "/Catalog", "Test Catalog Site", False
  36.     SetApplication APP_NAME & "/Benefits", "Intranet Benefits", True
  37.     
  38.     ' For debugging only
  39.     'MsgBox "Applications set"
  40.     
  41.     SetDebug
  42.     
  43.     IISSettings = True
  44.     
  45.     Exit Function
  46.     
  47. ErrorHandler:
  48.     MsgBox "An error occurred while setting ExAir config details." _
  49.         & " The error is: " & Hex(Err.Number) & " " & Err.Description, _
  50.         vbOKOnly + vbExclamation, "ExAir Config. Error"
  51.     
  52.     IISSettings = False
  53.  
  54. End Function
  55. ' Attempt to delete an existing ExAir application
  56. Private Sub NukeApplication()
  57.     Dim oRoot As Object
  58.     
  59.     On Error Resume Next
  60.         
  61.     Set oRoot = GetObject(APP_PATH)
  62.     If Err <> 0 Then GoTo NoPath
  63.     
  64.     oRoot.Delete "IIsWebDirectory", APP_NAME
  65.     If Err <> 0 Then GoTo NoWebDir
  66.     
  67.     SmallSleep
  68.     
  69.     oRoot.SetInfo
  70.     SmallSleep
  71.     
  72. NoPath:
  73. NoWebDir:
  74.     Set oRoot = Nothing
  75.  
  76. End Sub
  77.  
  78. ' Set ExAir etc as a directory
  79. Private Sub SetDir(strPath As String, strName As String)
  80.  
  81.     On Error GoTo ErrorHandler
  82.     
  83.     Dim oRoot As Object
  84.     Dim oDir As Object
  85.     
  86.     Set oRoot = GetObject(APP_PATH)
  87.     
  88.     SmallSleep
  89.     SmallSleep
  90.     Set oDir = oRoot.Create("IIsWebDirectory", strName)
  91.     oDir.SetInfo
  92.     
  93.     Set oDir = Nothing
  94.     Set oRoot = Nothing
  95.     
  96.     Exit Sub
  97.     
  98. ErrorHandler:
  99.     MsgBox "An error occurred while setting ExAir Web Directory details." _
  100.         & " The error is: " & Hex(Err.Number) & " " & Err.Description, _
  101.         vbOKOnly + vbExclamation, "ExAir Config. Error (SetDir)"
  102. End Sub
  103.  
  104. ' Turn on debugging for the IISSamples VDir
  105. Private Sub SetDebug()
  106.  
  107.     On Error GoTo ErrorHandler
  108.     
  109.     Dim oRoot As Object
  110.     
  111.     Set oRoot = GetObject(APP_PATH)
  112.     oRoot.AppAllowDebugging = True
  113.     Set oRoot = Nothing
  114.     
  115.     Exit Sub
  116.     
  117. ErrorHandler:
  118.     MsgBox "An error occurred while setting ExAir Web Debugging." _
  119.         & " The error is: " & Hex(Err.Number) & " " & Err.Description, _
  120.         vbOKOnly + vbExclamation, "ExAir Config. Error (SetDebug)"
  121. End Sub
  122. ' Set the application type...
  123. Private Sub SetApplication(strAppName As String, strFriendlyName As String, fInProc As Boolean)
  124.     
  125.     On Error GoTo ErrorHandler
  126.     
  127.     Dim oRoot As Object
  128.     Dim oDir As Object
  129.     Dim strWhere As String
  130.     
  131.     strWhere = "getting Root"
  132.     Set oRoot = GetObject(APP_PATH)
  133.     
  134.     strWhere = "getting app"
  135.     Set oDir = oRoot.GetObject("IISWebDirectory", strAppName)
  136.     
  137.     SmallSleep
  138.     SmallSleep
  139.     
  140.     strWhere = "creating app"
  141.     oDir.AppCreate fInProc                    ' Run the application in-process/out-of-proc
  142.     
  143.     strWhere = "setting friendly name"
  144.     oDir.AppFriendlyName = strFriendlyName    ' Name of application
  145.     
  146.     strWhere = "setting exception handling"
  147.     oDir.AspExceptionCatchEnable = False      ' We don't want ASP to catch exceptions (makes debugging easier!)
  148.     
  149.     strWhere = "flushing info"
  150.     oDir.SetInfo
  151.     
  152.     Set oDir = Nothing
  153.     Set oRoot = Nothing
  154.     
  155.     Exit Sub
  156.     
  157. ErrorHandler:
  158.     MsgBox "An error occurred setting ExAir Web Applications details while " & strWhere & "." _
  159.         & " The error is: " & Hex(Err.Number) & " " & Err.Description, _
  160.         vbOKOnly + vbExclamation, "ExAir Config. Error (SetApplication - " & strAppName & ")"
  161. End Sub
  162.  
  163. ' Set some of the error pages (403.4, 403.7 & 404)
  164. Private Sub SetErrorRedirects(strDir As String)
  165.     
  166.     On Error GoTo ErrorHandler
  167.     
  168.     Dim oRoot As Object
  169.     Dim oDir As Object
  170.     Set oRoot = GetObject(APP_PATH)
  171.     Set oDir = oRoot.GetObject("IIsWebDirectory", APP_NAME)
  172.     
  173.     Dim strErrs(), strErr
  174.     Dim i As Integer, j As Integer
  175.     Dim strReplace(3) As String
  176.         
  177.     strReplace(0) = "403,4,FILE," & strDir & "\Err403-4.htm"
  178.     strReplace(1) = "403,7,FILE," & strDir & "\Err403-7.htm"
  179.     strReplace(2) = "404,*,FILE," & strDir & "\Err404.htm"
  180.     
  181.     ' First get all the existing errors
  182.     ' Then search for the error message in the collection
  183.     ' If the error exists then replace it with the correct one from strReplace()
  184.     i = 0
  185.     Const SEARCH_SIZE As Integer = 5
  186.     For Each strErr In oDir.HttpErrors
  187.         ReDim Preserve strErrs(i)
  188.         strErrs(i) = strErr
  189.         For j = 0 To 2
  190.             If Left(strErr, SEARCH_SIZE) = Left(strReplace(j), SEARCH_SIZE) Then
  191.                 strErrs(i) = strReplace(j)
  192.                 Exit For
  193.             End If
  194.         Next j
  195.         
  196.         i = i + 1
  197.     Next
  198.              
  199.     oDir.HttpErrors = strErrs
  200.     oDir.SetInfo
  201.  
  202.     Set oDir = Nothing
  203.     Set oRoot = Nothing
  204.  
  205.     Exit Sub
  206.     
  207. ErrorHandler:
  208.     MsgBox "An error occurred while setting ExAir Error details." _
  209.         & " The error is: " & Hex(Err.Number) & " " & Err.Description, _
  210.         vbOKOnly + vbExclamation, "ExAir Config. Error (SetErrorRedirects)"
  211. End Sub
  212.  
  213. ' Set SSL requirements on two directories
  214. ' Set Authentication requirements on one
  215. Private Sub SetSecurity(strPath As String)
  216.  
  217.     On Error GoTo ErrorHandler
  218.     
  219.     Dim oRoot As Object
  220.     Dim oDir As Object
  221.     Set oRoot = GetObject(APP_PATH)
  222.     Set oDir = oRoot.GetObject("IIsWebDirectory", APP_NAME)
  223.     
  224.     ' SSL Constants from IISCnfg.h
  225.     Const ACCESS_SSL As Integer = &H8
  226.     Const ACCESS_SSL_ALLOW_CERT = &H20
  227.     Const ACCESS_SSL_REQUIRE_CERT As Integer = &H40
  228.     
  229.     ' Authentication constants from IISCnfg.h
  230.     Const AUTH_NTLM As Integer = &H4
  231.     
  232.     Dim oFFDir As Object
  233.     Set oFFDir = oDir.GetObject("IIsWebDirectory", "FreqFlyer")
  234.     oFFDir.AccessSSLFlags = 0 ' Use ACCESS_SSL for SSL channel
  235.     oFFDir.SetInfo
  236.     Set oFFDir = Nothing
  237.     
  238.     Dim oBizDir As Object
  239.     Set oBizDir = oDir.GetObject("IIsWebDirectory", "BusinessPartners")
  240.     oBizDir.AccessSSLFlags = 0 ' Use ACCESS_SSL + ACCESS_SSL_REQUIRE_CERT + ACCESS_SSL_ALLOW_CERT for client authentication
  241.     oBizDir.SetInfo
  242.     Set oBizDir = Nothing
  243.     
  244.     Dim oAdminDir As Object
  245.     Set oAdminDir = oDir.GetObject("IIsWebDirectory", "SiteAdmin")
  246.     oAdminDir.AuthFlags = AUTH_NTLM
  247.     oAdminDir.SetInfo
  248.     Set oAdminDir = Nothing
  249.     
  250.     Dim oBenefitsDir As Object
  251.     Set oBenefitsDir = oDir.GetObject("IIsWebDirectory", "Benefits")
  252.     oBenefitsDir.AuthFlags = AUTH_NTLM
  253.     oBenefitsDir.SetInfo
  254.     Set oBenefitsDir = Nothing
  255.     
  256.     Set oDir = Nothing
  257.     Set oRoot = Nothing
  258.     
  259.     Exit Sub
  260.     
  261. ErrorHandler:
  262.     MsgBox "An error occurred while setting ExAir Security details." _
  263.         & " The error is: " & Hex(Err.Number) & " " & Err.Description, _
  264.         vbOKOnly + vbExclamation, "ExAir Config. Error (SetSecurity)"
  265. End Sub
  266.  
  267. Private Sub SmallSleep()
  268.     Sleep 1000
  269. End Sub
  270.