'建立活动桌面'（IADS）对象,首先要引用 Active DS Type library 组件
Dim WWWServer As IADs,WWWService As IADs,WWWVDir,WWWVdirRes As IADs

Function CreateWebSite(ByVal WWWSiteName As String,_
ByVal WWWSitePort As String,_
ByVal WWWSitePath As String,_
ByVal WWWHostName As String,_
ByVal ComputerName As String) As Boolean
'变量定义
Dim SiteExist As Boolean
Dim WebName

'变量初始化
SiteExist = False
WebName = 1
CreateWebSite = True
On Error Resume Next
Err.Clear
'取得W3SVC服务
Set WWWService = GetObject("IIS://" & ComputerName & "/W3SVC")
Do While Err.Number <> 0
Err.Clear
Set WWWService = GetObject("IIS://" & ComputerName & "/W3SVC")
Loop
Err.Clear
'出错处理
'在IIS中查找每一个WEB站点
For Each WWWServer In WWWService
If UCase(Trim(WWWServer.ServerComment)) <> UCase(Trim(WWWSiteName)) Then
If IsNumeric(WWWServer.Name) Then
If CInt(WWWServer.Name) >= WebName Then WebName = CInt(WWWServer.Name) + 1
End If
Else
SiteExist = True
Exit For
End If
Next
If SiteExist Then
MsgBox "该站点已经存在！",vbInformation + vbOKOnly,"系统信息"
Exit Function
End If
'创建WebServer
Set WWWServer = WWWService.Create("IISWebServer",WebName) '创建新站点
WWWServer.ServerComment = WWWSiteName '设置站点名
WWWServer.KeyType = "IISWebServer"
WWWServer.ServerBindings = ":" & WWWSitePort & ":" & WWWHostName '设置端口号和主机头
WWWServer.DefaultDoc = "Default.asp,Index.asp,Default.htm,Index.htm" '设置默认启动文件
WWWServer.AccessScript = True '设置权限
WWWServer.AccessRead = True
WWWServer.FrontPageWeb = True
WWWServer.EnableDefaultDoc = True
WWWServer.DefaultDoc = "Default.htm,Default.asp,Index.htm,Index.asp"
Set WWWVDir = WWWServer.Create("IISWebVirtualDir","Root")
WWWVDir.Path = WWWSitePath
WWWVDir.AppCreate True
WWWVDir.SetInfo
WWWServer.SetInfo
WWWServer.Start
MsgBox "主机设置成功！","系统信息"

'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,FILE," + WWWFilesPath + "/404.htm"
'WWWServer.SetInfo
CreateWebSite = True
End Function

Function DeleteWebSite(ByVal WWWSiteName As String,ByVal ComputerName As String) As Boolean
'定义变量
Dim Tmp As Integer
Dim WebName
Dim SiteExist As Boolean
'变量初始化
SiteExist = False
DeleteWebSite = True
'取得W3SVC服务
On Error Resume Next
Err.Clear
Set WWWService = GetObject("IIS://" & ComputerName & "/W3SVC")
Do While Err.Number <> 0
Err.Clear
Set WWWService = GetObject("IIS://" & ComputerName & "/W3SVC")
Loop
Err.Clear
For Each WWWServer In WWWService
If UCase(Trim(WWWServer.ServerComment)) <> UCase(Trim(WWWSiteName)) Then
SiteExist = False
Else
If IsNumeric(WWWServer.Name) Then
WebName = WWWServer.Name
End If
SiteExist = True
Exit For
End If
Next
'删除站点
WWWService.Delete "IISWebServer",WebName
MsgBox "主机删除成功！","系统信息"
End Function

Private Sub cmdCreateWebSite_Click()
CreateWebSite txtSiteName.Text,txtSitePort.Text,txtSitePath.Text,txtHostName.Text,txtComputerName.Text
End Sub

Private Sub cmdDeleteWebSite_Click() DeleteWebSite txtSiteName.Text,txtComputerName.Text End Sub