[转帖]用ASP.NET（VB）创建的WEB站点

用ASP.NET（VB）创建的WEB站点，我们的调用方式非常简单：
Dim test As New Class1()
test.CreateWebSit(webname,port, "D:\VB", "localhost")

下面是Class1的代码，该代码做的工作就是建立站点，如果有此站点的名称则自动覆盖（注意：本类需要引用Actice DS Type Library）

Public Class Class1Class Class1 

用localhost 
'=========================== 

Function CreateWebSit()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()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()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