IIS操作类，包含创建应用程序池、站点和用户的功能

Class IISClass
Public Site()
Public AppPool()
Private SiteN,PoolN
Private AnonyMouseName,ComputerName
Private AppPoolAndIIsSplitStr,SplitStr
Private CreateSiteTmpNum
Private Sub Class_Initialize()
SiteN=0
PoolN=0
ComputerName=GetComputerName
AnonyMouseName="IUSR_" & ComputerName
AppPoolAndIIsSplitStr=vbCrlf & "|AppPoolEndIIsStart|" & vbCrLf '生成备份文件时，应用程序池和IIS站点信息的分隔线
SplitStr="<|>"
CreateSiteTmpNum=0
End Sub

'获取当前计算机的名称
Private Function GetComputerName()
Dim ObjNetWork,NetworkStr
NetworkStr="Wscript.Network"
Set objNetwork = CreateObject(NetworkStr)
GetComputerName = objNetwork.ComputerName
Set ObjNetWork=Nothing
End Function

'把域名绑定的对象转换成数组的原始数据
Private Function DomainObjToArr(ByRef Obj)
Dim Tmp(),Val,i,s
i=0
s=""
For Each Val In Obj
ReDim Preserve Tmp(i)
s=Val.IP & ":" & Val.Port & ":" & Val.Domain
Tmp(i)=s
i=i+1
Next
DomainObjToArr=Tmp
End Function
'把用户添加到指定的组中
Public Function AddUserToGroup(byRef UserName,byRef GroupName,ByRef ErrMsg)
Dim Obj,GroupObj
AddUserToGroup=False
On Error Resume Next
Err.Clear
Set Obj=GetObject("WinNT://" & ComputerName)
If Err.number<>0 Then
ErrMsg="无法使用ADSI功能"
Exit Function
End If
Err.Clear
Set GroupObj=Obj.GetObject("Group",GroupName)
If Err.number<>0 Then
ErrMsg="控制用户组失败，请检查组的名称是否正确"
Exit Function
End If
Err.Clear
GroupObj.add("WinNT://" & ComputerName & "/" & UserName)
If Err.number<>0 Then
ErrMsg="在把用户添加到组中时出现错误，可能是该组中已存在此用户"
Exit Function
End If
AddUserToGroup=True
Set Obj=Nothing
Set GroupObj=Nothing
End Function
'创建一个用户
Function CreateUser(byRef UserName,byRef UserPass,byRef FullName,byRef ExtInfo,ByRef ErrMsg)
Dim ComputerObj,NewUser
CreateUser=False
On Error Resume Next
Err.Clear
Set ComputerObj = GetObject("WinNT://"& ComputerName)
If Err.number<>0 Then
ErrMsg="无法使用ADSI功能"
Exit Function
End If
Err.Clear
Set NewUser = ComputerObj.Create("User" , UserName)
NewUser.SetInfo
If Err.number<>0 Then
ErrMsg="创建用户出错" & Err.Description
Exit Function
End If
Err.Clear
'进行帐号设置
NewUser.SetPassword UserPass '帐号密码
NewUser.FullName=FullName '帐号全名
NewUser.Description=ExtInfo '帐号说明
NewUser.UserFlags=&H10040 '&H20000(使用者下次登入时须变更密码) &H0040(使用者不得变更密码) &H10000(密码永久正确) &H0002(帐户暂时停用)
NewUser.SetInfo
If Err.number<>0 Then
ErrMsg="设置用户信息时出错" & Err.Description
Exit Function
End If
Set ComputerObj=nothing
CreateUser=True
End Function

'创建一个应用程序池
Public Function CreateAppPool(ByRef AppPoolObj,ByRef ErrMsg)
Dim ServerObj, AppObj
CreateAppPool=False
On Error Resume Next
Set ServerObj = GetObject("IIS://Localhost/W3SVC/AppPools")
Err.Clear
Set AppObj = ServerObj.Create("IIsApplicationPool", AppPoolObj.Name)
AppObj.SetInfo
If Err.Number <> 0 Then
ErrMsg="创建应用程序池出错" & Err.Description
Exit Function
End If
Set AppObj=Nothing
Set ServerObj=Nothing
CreateAppPool=True
End Function
'设置站点的应用程序池
Public Function SetSiteAppPool(ByRef SiteObj,ByRef ErrMsg)
Dim WWWServer,Obj
SetSiteAppPool=False
On Error Resume Next
Err.Clear
Set WWWServer = GetObject(SiteObj.AdsPath & "/ROOT")
WWWServer.AppPoolId=SiteObj.AppPool
WWWServer.SetInfo
If Err.Number<>0 Then
ErrMsg="设置站点的应用程序池时出错"
Exit Function
End If
Set WWWServer=Nothing
SetSiteAppPool=True
End Function

'设置站点的用户名和密码
Public Function SetSiteUser(ByRef SiteObj,ByRef ErrMsg)
Dim WWWServer,Obj
SetSiteUser=False
If SiteObj.User<>"" And SiteObj.Password<>"" Then
On Error Resume Next
Err.Clear
Set WWWServer = GetObject(SiteObj.AdsPath & "/ROOT")
WWWServer.AnonymousUserName=SiteObj.User
WWWServer.AnonymousUserPass=SiteObj.Password
WWWServer.SetInfo
If Err.Number<>0 Then
ErrMsg="设置站点的用户名和密码时出错"
Exit Function
End If
Set WWWServer=Nothing
Else
ErrMsg="没有设置用户名和密码"
Exit Function
End If
SetSiteUser=True
End Function

'创建一个站点，由于便与分析出错信息，此处创建站点只创建最基本的属性（站点名称，绑定域名，站点目录）
Public Function CreateSite(ByRef SiteObj,ByRef ErrMsg)
'默认从配置文件中获取的信息不会出错，不再写容错处理程序
Dim WWWServer,IIsAdsNum,TmpObj,VDirObj,ServerObj
CreateSite=False
On Error Resume Next
Set WWWServer = GetObject("IIS://Localhost/W3SVC")
IIsAdsNum=SiteObj.AdsNum
Err.Clear
Set TmpObj = WWWServer.GetObject("IIsWebServer", IIsAdsNum)
If Err.Number = 0 Then
Err.Clear
'程序执行没有出错说明该站点已存在
ErrMsg = "该服务器已经存在和此站点AdsPath相同的站点"
Exit Function
End If
'开始创建站点
Err.Clear
Set ServerObj = WWWServer.Create("IIsWebServer", IIsAdsNum)
If Err.Number <> 0 Then
ErrMsg = "创建站点失败"
Exit Function
End If
'配置站点
Err.Clear
ServerObj.ServerComment = SiteObj.Name
ServerObj.LogType=SiteObj.LogType
If SiteObj.LogType Then
ServerObj.LogFileDirectory=SiteObj.LogDir
End If
ServerObj.ServerBindings = DomainObjToArr(SiteObj.Domains)
ServerObj.SetInfo
If Err.Number <> 0 Then
ErrMsg = "配置站点时出错"
Exit Function
End If
'建立ROOT虚拟目录
Err.Clear
Set VDirObj = ServerObj.Create("IIsWebVirtualDir", "ROOT")
If Err.Number <> 0 Then
ErrMsg = "创建ROOT虚拟目录失败"
Exit Function
End If
'默认ROOT信息
Err.Clear
VDirObj.Path=SiteObj.Path
VDirObj.DefaultDoc=SiteObj.DefaultDoc
VDirObj.SetInfo
If Err.Number <> 0 Then
ErrMsg = "配置站点时出错"
Exit Function
End If
Err.Clear
VDirObj.AppFriendlyName = "默认应用程序"
VDirObj.SetInfo
VDirObj.AppCreate2 2
VDirObj.SetInfo
VDirObj.AccessScript = True
VDirObj.AccessFlags = 513
VDirObj.SetInfo
If Err.Number <> 0 Then
ErrMsg = "配置ROOT虚拟目录时出错"
Exit Function
End If
If CInt(SiteObj.Stat)=2 Then
ServerObj.Start
Else
ServerObj.Stop
End If

Set VDirObj = Nothing
Set TmpObj = Nothing
Set ServerObj = Nothing
Set WWWServer = Nothing
CreateSite = True
End Function
'创建一个FTP
Public Function CreateFTP(ByRef SiteObj,ByRef ErrMsg)
Dim FtpObj,RootObj,VirObj
On Error Resume Next
CreateFTP=False
If SiteObj.User<>"" And SiteObj.Password<>"" Then
Err.Clear
Set FtpObj= GetObject("IIS://Localhost/MSFTPSVC/1")
Set RootObj=FtpObj.GetObject("IIsFtpVirtualDir", "ROOT")
Set VirObj=RootObj.Create("IIsFtpVirtualDir",SiteObj.User)
VirObj.AccessFlags=3
VirObj.DontLog=0
VirObj.Path=SiteObj.Path
VirObj.SetInfo
If Err.Number<>0 Then
ErrMsg="创建站点失败" & Err.Description
Exit Function
End If
Set VirObj=Nothing
Set RootObj=Nothing
Set FtpObj=Nothing
End If
CreateFTP=True
End Function
'把IIS信息整合成文本内容
Public Function BackUP()
Dim Str,s,v
Str=""
s=""
For Each v In AppPool
If s="" Then
s=v.Name
Else
s=s & "," & v.Name
End If
Next
Str=s & AppPoolAndIIsSplitStr
'以上为应用程序池的保存
'下面保存IIS的信息
s=""
Dim Tmp,D,DStr
Tmp=""
For Each v In Site
If CLng(v.AdsNum)<>1 Then
DStr=""
For Each D In v.Domains
If DStr="" Then
DStr=D.IP & ":" & D.Port & ":" & D.Domain
Else
DStr=DStr & "," & D.IP & ":" & D.Port & ":" & D.Domain
End If
Next
Tmp=v.Name & SplitStr & _
v.Path & SplitStr & _
v.User & SplitStr & _
v.Password & SplitStr & _
v.AppPool & SplitStr & _
v.DefaultDoc & SplitStr & _
v.LogType & SplitStr & _
v.LogDir & SplitStr & _
v.AdsPath & SplitStr & _
v.AdsNum & SplitStr & _
v.Stat & SplitStr & _
DStr
If s="" Then
s=Tmp
Else
s=s & vbCrLf & Tmp
End If
End If
Next
Str=Str & s
Backup=Str
End Function

'从以前备份的IIS内容中读出信息
Public Sub ReadFromFile(ByRef Content)
Dim Arr,PoolStr,IIsStr,Pool,S,TmpArr,Val
Arr=Split(Content,AppPoolAndIIsSplitStr)
PoolStr=Arr(0)
IIsStr=Arr(1)
For Each Pool In Split(PoolStr,",")
ReDim Preserve AppPool(PoolN)
Set AppPool(PoolN)=New AppPoolTypes
AppPool(PoolN).Name=Pool
PoolN=PoolN+1
Next
For Each S In Split(IIsStr,vbCrLf)
ReDim Preserve Site(SiteN)
Set Site(SiteN)=New IIsTypes
TmpArr=Split(S,SplitStr)
With Site(SiteN)
.Name=TmpArr(0)
.Path=TmpArr(1)
.User=TmpArr(2)
.Password=TmpArr(3)
.AppPool=TmpArr(4)
.DefaultDoc=TmpArr(5)
.LogType=TmpArr(6)
.LogDir=TmpArr(7)
.AdsPath=TmpArr(8)
.AdsNum=TmpArr(9)
.Stat=TmpArr(10)
For Each Val In Split(TmpArr(11),",")
.AddDomain Val
Next
End With
SiteN=SiteN+1
Next
End Sub

'从当前服务器上IIS中读取应用程序池的列表
Public Sub GetPool()
Dim WWWObj,AppObj
Set WWWObj=GetObject("IIS://Localhost/W3SVC/AppPools")
For Each AppObj In WWWObj
ReDim Preserve AppPool(PoolN)
Set AppPool(PoolN)=New AppPoolTypes
AppPool(PoolN).Name=AppObj.name
PoolN=PoolN+1
Next
Set WWWObj=Nothing
End Sub

'从当前服务器上IIS中读取站点的列表
Public Sub GetIIS()
Dim WWWObj,SiteObj,Obj,UserName,UserPass,SiteName
Dim Binds,AppPool,VirObj
'从IIS站点中获取所有IIS信息
Set WWWObj=GetObject("IIS://Localhost/w3svc")
For Each SiteObj In WWWObj
If SiteObj.Class="IIsWebServer" Then
Binds=SiteObj.ServerBindings
SiteName=SiteObj.ServerComment
Set Obj=SiteObj.GetObject("IIsWebVirtualDir","ROOT")
UserName=Obj.AnonymousUserName
UserPass=Obj.AnonymousUserPass
AppPool=Obj.AppPoolId
'处理一下用户名的信息
UserName=Replace(UserName,ComputerName & "\","")
UserName=Replace(UserName,AnonyMouseName,"")
If UserName="" Then
UserName=""
UserPass=""
End If
ReDim Preserve Site(SiteN)
Set Site(SiteN)=New IIsTypes
With Site(SiteN)
.Name=SiteName
.Path=Obj.Path
.DefaultDoc=Obj.DefaultDoc
.LogType=SiteObj.LogType
.LogDir=SiteObj.LogFileDirectory
For Each Val In Binds
.AddDomain Val
Next
.User=UserName
.Password=UserPass
.AppPool=AppPool
.AdsPath=SiteObj.AdsPath
.AdsNum=SiteObj.Name
.Stat=SiteObj.Status
End With
SiteN=SiteN+1
End If
Next
Set WWWObj=Nothing
End Sub
End Class

'站点绑定信息数据类型
Class BindsTypes
Public IP
Public Domain
Public Port
Private Sub Class_Initialize()
IP=""
Domain=""
Port="80"
End Sub
End Class
'应用程序池的数据类型
Class AppPoolTypes
Public Name
'由于池比较少，不再加大程序的复杂性，只记录一下池的名称就成了，其它信息由默认池中获取
Private Sub Class_Initialze()
Name=""
End Sub
End Class
'站点的数据类型
Class IIsTypes
Public Name
Public Path
Public Domains()
Public User
Public Password
Public AppPool
Public DefaultDoc
Public LogDir,LogType
Public AdsPath,AdsNum
Public Stat
Private DomainN
Private Sub Class_Initialze()
Name=""
Path=""
User=""
Password=""
AppPool=""
DomainN=0
AdsPath=""
AdsNum=0
Stat=2
End Sub
Public Sub AddDomain(ByRef Str)
Dim Arr
Arr=Split(Str,":")
ReDim Preserve Domains(DomainN)
Set Domains(DomainN)=New BindsTypes
With Domains(DomainN)
.IP=Arr(0)
.Port=Arr(1)
.Domain=Arr(2)
End With
DomainN=DomainN+1
End Sub
End Class