收藏（用ASP.NET（VB版）创建WINDOWS2000SERVER站点 ）

用ASP.NET（VB）创建的WEB站点，我们的调用方式非常简单：

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