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