控制IIS的DLL

新打开一个类模块
Public Function WebCreate(ByVal WebIP As String, ByVal WebDir As
String, ByVal WebComment As String, Optional hostname As String,
Optional DefaultDoc = "index.htm,index.asp,default.htm,default.asp",
Optional AccessExecute = True, Optional frontPageWeb = True, Optional
EnableDefaultDoc = True, Optional accessread = True, Optional
AccessScript = True)
If Dir(WebDir, vbDirectory) = Empty Then
WebCreate = 2 '没有该目录
Exit Function
End If
Dim obj As Object
Dim Web, NewWeb, child, VirDir As Object
Dim SBinds()
Dim WebName, Port As Integer
ReDim SBinds(0)
SBinds(0) = WebIP & ":" & Port & ":" & hostname
WebName = 1
Port = 80 '侦听端口
On Error Resume Next
Err.Clear
Set Web = GetObject("IIS://LocalHost/W3SVC")

Err.Clear
For Each child In Web
If child.Class = "IIsWebServer" Then
If child.ServerBindings = SBinds Then
WebCreate = 3 'IP地址相同
Exit Function
End If
If IsNumeric(child.Name) Then
If CInt(child.Name) >= WebName Then WebName = CInt
(child.Name) + 1
End If
Next
Set NewWeb = Web.Create("IIsWebServer", WebName)
NewWeb.servercomment = WebComment
NewWeb.KeyType = "IIsWebServer"
NewWeb.ServerBindings = SBinds
NewWeb.accessread = accessread
NewWeb.AccessScript = AccessScript
NewWeb.AccessExecute = AccessExecute
NewWeb.frontPageWeb = frontPageWeb
NewWeb.EnableDefaultDoc = True
NewWeb.DefaultDoc = DefaultDoc
Set VirDir = NewWeb.Create("IIsWebVirtualDir", "Root")
VirDir.Path = WebDir
VirDir.AppCreate "TRUE"
VirDir.setinfo
NewWeb.setinfo
NewWeb.start
WebCreate = 1
End Function

Public Function DirCreate(ByVal DirName As String)
If Dir(DirName, vbDirectory) = Empty Then
MkDir DirName
DirCreate = 1 '目录建立成功
Else
DirCreate = 0 '已存在该目录
End If
End Function

Public Function WebStart(ByVal DirName As String) As Integer
Dim Web As Object
Dim temp As Integer
temp = 0
Err.Clear
On Error Resume Next
Set Web = GetObject("IIS://LocalHost/W3SVC")
If Err.Number <> 0 Then
WebStart = 2
Exit Function
End If
For Each child In Web
If child.Class = "IIsWebServer" Then
If child.servercomment = DirName Then
child.start
child.setinfo
temp = 1
Exit For
End If
End If
Next
WebStart = temp 'temp=0，没有该站点。temp=1，停止站点成功。
temp=2，没有启动IIS服务器
End Function


Public Function WebStop(ByVal DirName As String) As Integer
Dim Web As Object
Dim temp As Integer
temp = 0
Err.Clear
On Error Resume Next
Set Web = GetObject("IIS://LocalHost/W3SVC")
If Err.Number <> 0 Then
WebStop = 2
Exit Function
End If
For Each child In Web
If child.Class = "IIsWebServer" Then
If child.servercomment = DirName Then
child.stop
child.setinfo
temp = 1
Exit For
End If
End If
Next
WebStop = temp 'temp=0，没有该站点。temp=1，停止站点成功。
temp=2，没有启动IIS服务器
End Function

Public Function WebDefaultDoc(ByVal Web As String, ByVal DefaultDoc
As String) As Integer
Dim Webs As Object
Dim child As Object
Set Webs = GetObject("IIS://LocalHost/W3SVC")
If Err.Number <> 0 Then
temp = 0 'IIS未启动
Err.Clear
Exit Function
Else
For Each child In Webs
If child.Class = "IIsWebServer" Then
If child.servercomment = Web Then
child.DefaultDoc = DefaultDoc
child.setinfo
temp = 1 '成功
Exit Function
Else
temp = 2
End If
End If
Next
End If
WebDefaultDoc = temp
End Function

Public Function WebServerDelete(ByVal Web As String) As Integer
Dim Webs As Object
Dim child As Object
Dim temp As Integer
temp = 2 '没有该站点
Set Webs = GetObject("IIS://LocalHost/W3SVC")
If Err.Number <> 0 Then
temp = 0 'IIS未启动
Err.Clear
Else
For Each child In Webs
If child.Class = "IIsWebServer" Then
If child.servercomment = Web Then
Webs.Delete "IIsWebServer", child.Name
Webs.setinfo
temp = 1 '成功
Exit For
End If
End If
Next
End If
WebDefaultDoc = temp
End Function

Public Function WebVirtualDel(ByVal Web As String, ByVal VirtualDel
As String) As Integer
Dim Webs As Object
Dim child As Object
temp = 0 '不存在
Set Webs = GetObject("IIS://LocalHost/W3SVC")
For Each child In Webs
If child.Class = "IIsWebServer" Then
If child.servercomment = Web Then
Webs.Delete "IIsWebVirtualDir", child.Name
Webs.setinfo
temp = 1 '成功删除
End If
End If
Next
WebVirtualDel = temp
End Function

Public Function WebVirtualCreate(ByVal Web As String, ByVal Path As
String, ByVal VirtualName As String, Optional AppCreate = False,
Optional DirBrowseFlags = False, Optional VirtualComment = "",
Optional DefaultDoc = "index.htm,index.asp,default.htm,default.asp",
Optional AccessExecute = True, Optional frontPageWeb = True, Optional
EnableDefaultDoc = True, Optional accessread = True, Optional
AccessScript = True)
Dim Webs As Object
Dim Webschild As Object
Dim Virtual, VirtualChild As Object
Set Webs = GetObject("IIS://LocalHost/W3SVC")
For Each Webschild In Webs
If Webschild.Class = "IIsWebServer" Then
If Webschild.servercomment = Web Then
WebName = Webschild.Name
End If
End If
Next
If WebName = 0 Then
WebVirtualCreate = 0 '没有该站点
Exit Function
End If
Set Webs = Nothing
Set Webschild = Nothing
Set Virtual = GetObject("IIS://LocalHost/W3SVC/" & WebName & "/root")
For Each VirtualChild In Virtual
If VirtualChild.Name = VirtualDir Then
WebVirtualCreate = 2 '已经有该虚拟目录
Exit Function
End If
Next
If WebVirtualCreate <> 2 Then
Set Webs = Virtual.Create("IIsWebVirtualDir", VirtualName)
Webs.AccessScript = AccessScript
Webs.AccessExecute = AccessExecute
Webs.DefaultDoc = DefaultDoc
Webs.DirBrowseFlags = DirBrowseFlags
Webs.AppFriendlyName = AppFriendlyName
Webs.EnableDefaultDoc = EnableDefaultDoc
Webs.frontPageWeb = frontPageWeb
Webs.KeyType = "IIsWebVirtualDir"
Webs.Path = Path
Webs.setinfo
WebVirtualCreate = 1 '成功
End If
Set Webs = Nothing
Set Virtual = Nothing
End Function

文章来自: 本站原创
引用通告: 查看所有引用 | 我要引用此文章
Tags: IISIIS DLLDLL
相关日志: