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