用ASP.NET（VB版）创建WINDOWS 2000 SERVER站点
点击次数：17 次 发布日期：2008-11-27 00:59:26 作者：源代码网
|
Dim test As New Class1() test.CreateWebSit(webname,port, "D:VB", "localhost") 下面是Class1的代码，该代码做的工作就是建立站点，如果有此站点的名称则自动覆盖（注意：本类需要引用Actice DS Type Library） Public Class Class1 用localhost "=========================== Function CreateWebSit(ByVal WWWSiteName As String, _ ByVal WWWTCPPort As String, _ ByVal WWWFilesPath As String, _ ByVal ComputerName As String) As Boolean CreateWebSit = True Dim TCPPort() As Object "建立活动桌面"（IADS）对象。首先要在 VB 中的 "prject"菜单中的"references"中引"用 Active DS "Type "library 组件 Dim WWWServer As ActiveDs.IADs Dim WWWService Dim WWWVdir, WWWVdir2, WWWVdirRes As ActiveDs.IADs Dim i As Integer Dim HandleSameCase As Boolean "取得W3SVC服务 WWWService = GetObject("IIS://" & ComputerName & "/W3SVC") i = 1 HandleSameCase = True On Error GoTo ErrWouldDo "在IIS中查找每一个WEB站点 For Each WWWServer In WWWService WWWServer = Nothing WWWServer = GetObject("IIS://" & ComputerName & "/W3SVC/" & i) "Debug.Print WWWServer.ServerComment "如果在安装时系统中已经有了要加的站点，则要先删除干净 If UCase(WWWServer.ServerComment) = UCase(WWWSiteName) Then WWWService.Delete("IISWebServer", i) "再删除 Exit For End If ReDim TCPPort(1) TCPPort(0) = "" TCPPort = WWWServer.Serverbindings "如果端口已经有了则也要先删除 If TCPPort(0) = ":" & WWWTCPPort & ":" Then WWWService.Delete("IISWebServer", i) "删除 Else i = i + 1 End If Next HandleSameCase = False CreateSite: "MsgBox I WWWServer = WWWService.Create("IISWebServer", i) "创建新站点 WWWServer.ServerComment = WWWSiteName "设置站点名 WWWServer.Serverbindings = ":" & WWWTCPPort & ":" "设置端口号 WWWServer.DefaultDoc = "default.asp,index.asp,default.htm,index.htm" "设置默认启动文件 WWWServer.AccessScript = True "设置权限 WWWServer.AccessRead = True WWWServer.SetInfo() "创建设置主目录 WWWServer = GetObject("IIS://" & ComputerName & "/W3SVC/" & i) WWWVdir = WWWServer.Create("IISWebVirtualDir", "root") WWWVdir.Path = WWWFilesPath "主目录的实际磁盘路径 WWWVdir.SetInfo() WWWVdir.AppCreate(True) WWWServer.Start() "启动新站点 "建立虚拟目录 "Set WWWVdirRes = WWWVdir.Create("IISWebVirtualDir", "Resource") "创建虚拟目录 "WWWVdirRes.Path = WWWFilesPath + "Resource" "WWWVdirRes.AccessRead = True "WWWVdirRes.AccessWrite = True "WWWVdirRes.SetInfo "下面为自定义IIS Web Server的错误信息，等发生404错误时候指定调用网站主目录下的404.htm页面显示 WWWServer.HttpErrors = "404,0,FILE," + WWWFilesPath + "404.htm" WWWServer.SetInfo() CreateWebSit = True Exit Function ErrWouldDo: "MsgBox Err.Description If (HandleSameCase = True) Then GoTo CreateSite Else MsgBox(Err.Description) CreateWebSit = False Exit Function End If End Function REM 建立虚拟目录程序 "ComputerName 服务器名（可以为localhost） "DirName 要建立的虚拟目录名 "LinkAddr 该虚拟目录的真实路径 "WWWSiteName 站点名称 Function CreateVirtualDir(ByVal ComputerName As String, _ ByVal DirName As String, ByVal LinkAddr As String, _ ByVal WWWSiteName As String) As Boolean Dim i As Integer CreateVirtualDir = True "取得W3SVC服务 Dim WWWServer As ActiveDs.IADs Dim WWWService WWWService = GetObject("IIS://" & ComputerName & "/W3SVC") i = 1 Dim HandleSameCase As Boolean HandleSameCase = True Dim temp As Boolean temp = False For Each WWWServer In WWWService WWWServer = Nothing WWWServer = GetObject("IIS://" & ComputerName & "/W3SVC/" & i) If UCase(WWWServer.ServerComment) = UCase(WWWSiteName) Then temp = True Exit For End If i = i + 1 Next If Not temp Then CreateVirtualDir = False Exit Function End If Dim WWWVirtualDir, WWWIF As ActiveDs.IADs WWWServer = GetObject("IIS://" & ComputerName & "/W3SVC/" & i & "/Root") REM 检查是否该站点中已有该虚拟目录 On Error GoTo ErrHandle WWWIF = GetObject("IIS://" & ComputerName & "/W3SVC/" & i & "/Root/" & DirName) REM 如果有，则返回False If WWWIF.Name <> "" Then CreateVirtualDir = False Exit Function End If ErrHandle: "Debug.Print Err.Number If Err.Number = -2147024893 Then Err.Clear() REM 如果是因为没有找到该虚拟目录出错的话则进行CreateVirtualDir建立虚拟目录 GoTo ReturnCreate Else CreateVirtualDir = False Exit Function End If REM 建立虚拟目录 ReturnCreate: WWWVirtualDir = WWWServer.Create("IISWebVirtualDir", DirName) WWWVirtualDir.Path = LinkAddr WWWVirtualDir.AccessRead = True WWWVirtualDir.AccessScript = True WWWVirtualDir.AppCreate(True) WWWVirtualDir.SetInfo() CreateVirtualDir = True End Function Function GetDBConnStr(ByVal DBName As String) As String Select Case DBName Case "friend" GetDBConnStr = CStr(GetSetting("HostTask", "DBini", "ConnStr")) Case "wuye" GetDBConnStr = Replace$(CStr(GetSetting("HostTask", "DBini", "ConnStr")), "friend", "wuye") Case Else GetDBConnStr = CStr(GetSetting("HostTask", "DBini", "ConnStr")) End Select End Function End Class  源代码网供稿. |
