用ASP.NET（VB版）创建WINDOWS 2000 SERVER站点Java教程 -免费技术教程下载中心

用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