// by redice 2009.6.1
// redice@163.com
// http://www.redicecn.cn
// 转载至少请保留上述信息...
// 今天是儿童节，再开源点东西出来，祝我的两个小外甥以及所有的小朋友都节日快乐...

' 获取站点日志文件的目录
' siteId - 站点id
Public Function GetLogFileDirectory(siteId As String) As String
    On Error GoTo err:
    Dim site As Object
    DoEvents
    Set site = GetObject("IIS://127.0.0.1/w3svc/" & siteId)
    GetLogFileDirectory = site.LogFileDirectory
    Set site = Nothing
    Exit Function
err:
End Function

' 获取虚拟主机的匿名账户
' 参数说明:
' siteId - 站点id,传入值
' UserName - 匿名账户,返回值
' UserPass - 匿名账户的密码,返回值
Public Function GetVMAnonymousUser(siteId As String, UserName As String, UserPass As String) As Boolean
    GetVMAnonymousUser = True
    On Error GoTo err:
    Dim site As Object
    DoEvents
    Set site = GetObject("IIS://127.0.0.1/w3svc/" & siteId)
    UserName = site.AnonymousUserName
    UserPass = site.AnonymousUserPass
    Set site = Nothing
    Exit Function
err:
   GetVMAnonymousUser = False
End Function

' 设置虚拟主机的匿名账户
' 参数说明:
' siteId - 站点id,传入值
' UserName - 匿名账户,传入值
' UserPass - 匿名账户的密码,传入值
Public Function SetVMAnonymousUser(siteId As String, UserName As String, UserPass As String) As Boolean
    SetVMAnonymousUser = True
    On Error GoTo err:
    Dim site As Object
    DoEvents
    Set site = GetObject("IIS://127.0.0.1/w3svc/" & siteId)
    
    ' 对root目录匿名账户的设置容易被忽视
    Dim vDir As Object
    Set vDir = site.GetObject("IISWebVirtualDir", "root")
    
    vDir.AuthFlags = 5
    vDir.AnonymousUserName = UserName
    vDir.AnonymousUserPass = UserPass
    vDir.SetInfo

    site.AuthFlags = 5
    site.AnonymousUserName = UserName
    site.AnonymousUserPass = UserPass
    site.SetInfo
    Set site = Nothing
    Exit Function
err:
   SetVMAnonymousUser = False
End Function


' 获取iis 的版本号
Public Function GetIISVersion() As String
    On Error GoTo err

    Dim w3svcInfo As Object
    DoEvents
    Set w3svcInfo = GetObject("IIS://127.0.0.1/w3svc/info")
    GetIISVersion = w3svcInfo.MajorIISVersionNumber
    Set w3svcInfo = Nothing
err:
End Function

' 判断该站点根目录是否开放了iis写权限
Public Function RootOpenIisPut(siteId As String) As Boolean
       On Error GoTo err:
       RootOpenIisPut = False
       Dim site As Object
       If siteId = "" Then Exit Function
       DoEvents
       Set site = GetObject("IIS://127.0.0.1/w3svc/" & siteId)
       
       Dim vDir As Object
       Set vDir = site.GetObject("IISWebVirtualDir", "root")
       
       If vDir.AccessWrite = -1 Then
          RootOpenIisPut = True
       Else
          RootOpenIisPut = False
       End If
       Set vDir = Nothing
       Set site = Nothing
       Exit Function
err:
End Function

' 获取站点根目录
Public Function GetSiteRootDir(siteText As String) As String
    
    On Error GoTo err:

    Dim siteId As String
    siteId = SplitSiteId(siteText)
    If siteId = "" Then Exit Function
    
    Dim site As Object
    DoEvents
    Set site = GetObject("IIS://127.0.0.1/w3svc/" & siteId)
    
    Dim vDir As Object
    Set vDir = site.GetObject("IISWebVirtualDir", "root")
    GetSiteRootDir = vDir.Path
    Set vDir = Nothing
    Set site = Nothing
err:
End Function


下面这个函数在我的之前一篇文章中就给出了。

' 设置主机目录权限
' 参数说明:
' siteId - 站点id
' strPath - 子目录相对根目录的路径,使用","将各个目录分开
'         例如:站点根目录是d:wwwroot,要设置的目录为d:wwwroot    aoyardbs,那么这里strPath应为"taoyard,bbs"
'         如果strPath为空则表示主目录
' strName - 要设置的属性
' bValue - 设置的属性值
Public Function ChSiteDirAccess(siteId As String, strPath As String, strName, bValue) As Boolean
    ChSiteDirAccess = True
    Dim oAdmin As Object
    Set oAdmin = GetObject("IIS://127.0.0.1/w3svc/" & siteId & "/root")
    
    If strPath <> "" Then ' 对站点子目录的设置
        Dim dirCells() As String
        dirCells = Split(strPath, ",")
        Dim i As Integer
        
        Dim oWebDir As Object
        Set oWebDir = oAdmin
        For i = 0 To UBound(dirCells)
            If dirCells(i) <> "" Then
                Set oWebDir = oWebDir.GetObject("IISWebDirectory", dirCells(i))
                ' 获取IISWebDirectory失败，则可能是因为metabase中没有记录
                If err.Number <> 0 Then
                   '在metabase中创建相关记录
                   On Error GoTo err
                   Set oWebDir = oWebDir.Create("IISWebDirectory", dirCells(i))
                End If
                
                On Error GoTo err
                If i = UBound(dirCells) Then
                   oWebDir.put strName, bValue
                   oWebDir.SetInfo
                End If
            End If
        Next
        Set oWebDir = Nothing
    Else ' 对站点根目录的设置
       oAdmin.put strName, bValue
       oAdmin.SetInfo
    End If

    Set oAdmin = Nothing
    Exit Function
err:
    ChSiteDirAccess = False
End Function