用ASP.NET（VB）创建WINDOWS 2000/2003 SERVER站点

郗梨祎

　　用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
'
<script type="text/javascript"><!--google_ad_client = "pub-5805713535161226";google_ad_width = 468;google_ad_height = 60;google_ad_format = "468x60_as";google_ad_channel ="";google_color_border = "FF4500";google_color_bg = "FFEBCD";google_color_link = "DE7008";google_color_url = "E0AD12";google_color_text = "8B4513";//--></script><script src="http://pagead2.googlesyndication.com/pagead/show_ads.js" type="text/javascript"></script><iframe name="google_ads_frame" marginwidth="0" marginheight="0" src="http://pagead2.googlesyndication.com/pagead/ads?client=ca-pub-5805713535161226&amp;dt=1151566440171&amp;lmt=1151566440&amp;prev_fmts=160x90_0ads_al_s%2C160x600_as%2C336x280_as&amp;format=468x60_as&amp;output=html&amp;url=http%3A%2F%2Fwww.outof8.com%2Fblog%2Fblogview.asp%3FlogID%3D4724&amp;color_bg=FFEBCD&amp;color_text=8B4513&amp;color_link=DE7008&amp;color_url=E0AD12&amp;color_border=FF4500&amp;cc=3125&amp;u_h=768&amp;u_w=1024&amp;u_ah=738&amp;u_aw=1024&amp;u_cd=32&amp;u_tz=480" frameborder="0" width="468" scrolling="no" height="60" allowtransparency="allowtransparency"></iframe>";
建立活动桌面'（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