Public   Sub   ServerCreateWeb()  
  Dim   ServiceObj,   ServerObj,   VDirObj,   ssBindingsList,   Child  
  Dim   sWebPath   As   String  
  Dim   sIP   As   String,   sDomain   As   String,   sPort   As   String  
  Dim   ii   As   Long,   nNumber   As   Long,   nNumber0   As   Long  
  Dim   ss   As   String,   sNowWeb   As   String,   sComment   As   String  
  Dim   nn   As   Long,   nIP   As   Long,   sIPs  
   
  On   Error   Resume   Next  
  Screen.MousePointer   =   vbHourglass  
  检测IP地址  
  sIP   =   Trim(Me.TWebIP.Text)  
  If   InStr(sIP,   "   ")   >   0   Then   GoTo   IPError  
  sIPs   =   Split(sIP,   ".",   -1)  
  nn   =   UBound(sIPs)  
  If   nn   <>   3   Then   GoTo   IPError  
  For   ii   =   0   To   nn  
      nIP   =   Val(sIPs(ii))  
      If   Not   IsNumeric(sIPs(ii))   Then  
          GoTo   IPError  
      ElseIf   nIP   <   0   Or   nIP   >   254   Then  
          GoTo   IPError  
      End   If  
  Next  
  检测端口  
  sPort   =   Trim(Me.TPort.Text)  
  If   Not   IsNumeric(sPort)   Then  
      MsgBox   LoadResString(18185)   &   ":   "   &   sPort   &   LoadResString(18212),   vbExclamation  
      Me.TPort.Text   =   80  
      Me.TPort.SetFocus  
      GoTo   LEnd  
  End   If  
  sDomain   =   LCase(Trim(Me.TDomain.Text))  
  If   InStr(sDomain,   "   ")   >   0   Then  
      MsgBox   Me.LDomain.Caption   &   ":   "   &   TDomain   &   LoadResString(18212),   vbExclamation  
      Me.TDomain.Text   =   ""  
      Me.TDomain.SetFocus  
      GoTo   LEnd  
  End   If  
  sWebPath   =   UCase(Trim(Me.TWebDir.Text))  
  Me.cmdYes.Enabled   =   False  
  Me.OptNo.Enabled   =   False  
  Me.OptYes.Enabled   =   False  
  Me.FWebInfo.Enabled   =   False  
  Me.LInfo.ForeColor   =   vbBlue  
  Me.LInfo.Text   =   ""  
  If   sDomain   <>   ""   Then  
      sNowWeb   =   sIP   &   ":"   &   sPort   &   ":"   &   sDomain  
  Else  
      sNowWeb   =   sIP   &   ":"   &   sPort   &   ":"  
  End   If  
  nNumber   =   0  
  set   ServiceObj   =   GetObject("IIS://"   &   Request.ServerVariables("SERVER_NAME")   &   "/SmtpSvc/1")  
  Set   ServiceObj   =   GetObject("IIS://Localhost/W3SVC")  
  For   Each   Child   In   ServiceObj  
      If   InStr(Child.KeyType,   "Server")   <>   0   Then  
          nn   =   UBound(Child.ServerBindings(0))  
          ss   =   ""  
          For   ii   =   0   To   nn  
              ss   =   ss   &   LCase(Child.ServerBindings(0)(ii))  
          Next  
          If   InStr(ss,   sNowWeb)   >   0   Then  
              欲建站点已经存在  
              nNumber   =   Child.Name     取出可用站点号  
              sComment   =   Child.ServerComment  
              删除该   Web   站点[Windows   2000不允许修改主目录(?)，因此只得删除重建]  
              Err.Clear  
              ServiceObj.Delete   "IIsWebServer",   nNumber  
              If   (Err.Number   <>   0)   Then  
                  Me.LInfo.Text   =   Me.LInfo.Text   &   LoadResString(18209)   &   vbCrLf  
                  GoTo   LEnd  
              End   If  
              ServiceObj.SetInfo  
              Me.LInfo.Text   =   Me.LInfo.Text   &   LoadResString(18210)   &   sComment   &   vbCrLf   &   vbCrLf  
              Exit   For  
          Else  
              nNumber0   =   Child.Name   +   1  
              If   nNumber0   >   nNumber   Then   nNumber   =   nNumber0  
          End   If  
      End   If  
  Next  
  创建   Web   Server  
  Err.Clear  
  Set   ServerObj   =   ServiceObj.Create("IIsWebServer",   nNumber)  
  If   (Err.Number   <>   0)   Then  
      Me.LInfo.Text   =   Me.LInfo.Text   &   LoadResString(18209)   &   vbCrLf  
  End   If  
  ServerObj.ServerSize   =   1  
  ServerObj.ServerComment   =   LoadResString(18211)  
  If   sDomain   <>   ""   Then  
      ssBindingsList   =   Array(0,   0)  
      ssBindingsList(0)   =   sIP   &   ":"   &   sPort   &   ":"  
      ssBindingsList(1)   =   sIP   &   ":"   &   sPort   &   ":"   &   sDomain  
  Else  
      ssBindingsList   =   Array(0)  
      ssBindingsList(0)   =   sIP   &   ":"   &   sPort   &   ":"  
  End   If  
  ServerObj.ServerBindings   =   ssBindingsList  
  ServerObj.SetInfo  
  Err.Clear  
  Set   VDirObj   =   ServerObj.Create("IIsWebVirtualDir",   "ROOT")  
  If   (Err.Number   <>   0)   Then  
      Me.LInfo.Text   =   Me.LInfo.Text   &   LoadResString(18213)   &   vbCrLf  
  End   If  
  Err.Clear  
  Web   主目录参数  
  VDirObj.Path   =   sWebPath   Web   主目录  
  VDirObj.AccessRead   =   (Me.chkRead.Value   =   vbChecked)       读取  
  VDirObj.AccessWrite   =   (Me.chkWrite.Value   =   vbChecked)   写入  
  VDirObj.EnableDirBrowsing   =   (Me.chkBrowse.Value   =   vbChecked)     目录浏览(允许浏览目录)  
  VDirObj.ContentIndexed   =   (Me.chkIndex.Value   =   vbChecked)     索引此资源(索引此目录)  
  VDirObj.DontLog   =   (Me.chkDontLog.Value   <>   vbChecked)   日志访问  
  VDirObj.DefaultDoc   =   Trim(Me.TDefaultDoc.Text)  
  VDirObj.EnableDefaultDoc   =   True  
  应用程序设置  
  VDirObj.AppFriendlyName   =   LoadResString(18121)     应用程序名(名)  
  执行许可(许可)  
  VDirObj.AccessScript   =   (Me.chkScript.Value   =   vbChecked)   如果   True   允许   .ASP   执行  
  VDirObj.AccessExecute   =   (Me.chkExecute.Value   =   vbChecked)   如果   True   允许   .ASP和其他可执行文件执行  
  If   OS_Ver.dwMajorVersion   =   VER_MajorVersion_NT4   Then   VDirObj.AppIsolated   =   (Me.chkIsolated.Value   =   vbChecked)   在分开的内存空间运行(孤立的进程)  
  VDirObj.AppCreate   True  
  VDirObj.SetInfo  
  Me.LInfo.Text   =   Me.LInfo.Text   &   LoadResString(18214)   &   vbCrLf  
  Err.Clear  
  启动   Web  
  If   ServerObj.ServerState   =   4   Or   ServerObj.ServerState   =   6   Then   ServerObj.Start  
  If   (Err.Number   <>   0)   Then  
      Me.LInfo.Text   =   Me.LInfo.Text   &   LoadResString(18216)   &   vbCrLf  
  Else  
      Me.LInfo.Text   =   Me.LInfo.Text   &   LoadResString(18217)   &   vbCrLf  
  End   If  
   
  LEnd:  
  Screen.MousePointer   =   vbDefault  
  Exit   Sub  
   
  IPError:  
  MsgBox   LoadResString(18184)   &   ":   "   &   sIP   &   LoadResString(18212),   vbExclamation  
  Me.TWebIP.Text   =   GetIPAddress  
  Me.TWebIP.SetFocus  
  GoTo   LEnd  
  End   Sub