动态添加IIS站点和创建目录函数

chenqb

　　<%
　　'**********************************************************************************
' 创建站点功能模块库
' Author nonepassby@163.com(Jack Lee)
' WriteDate 2002.03.26
' LastModify 2002.04.02
' Version 1.00
'**********************************************************************************
'
'
'**********************************************************************************
' 检查是否存在盘和类型
' 如果不存在或是CD-ROM返回0，是返回1
'**********************************************************************************
Function CheckDrive(drive)
Dim Fso,Dname,ReturnValue
ReturnValue=0
Set Fso=Server.CreateObject("Scripting.FileSystemObject")
If Fso.DriveExists(drive) Then
Set Dname=Fso.GetDrive(drive)
If Dname.DriveType<>4 Then  
ReturnValue=1
End If
Set Dname=nothing
End If
Set Fso=nothing
CheckDrive=ReturnValue
End Function
　　
'**********************************************************************************
' 检测目录已用空间
' 如果目录不存在，则返回-1，
' 根据所占空间大小，分别返回以GB,MB,KB,Bytes为单位的空间数
'**********************************************************************************
Function GetTotalSize(folder)
Dim Fso,ObjFld,ftotal
Set Fso=Server.CreateObject("Scripting.FileSystemObject")
If Fso.folderExists(folder) Then
Set ObjFld=Fso.GetFolder(folder)
ftotal=ObjFld.Size
If ftotal<1024 Then
ftotal=ftotal&"Bytes"
Else
ftotal=int(ftotal/1024)
If ftotal<1024 Then
ftotal=ftotal&"KB"
Else
ftotal=int(ftotal/1024)
If Ftotal<1024 Then
ftotal=ftotal&"MB"
Else
ftotal=int(ftotal/1024)
ftotal=ftotal&"GB"
End If
End If
End If
FolderTotalSize=ftotal
Else
FolderTotalSize=-1
End If
End Function
　　
'**********************************************************************************
' 判断可用空间是否已满
' 参数folder为测试目录，maxsize为最大允许空间，可以带MB,GB,KB等单位
' 当目录不存在时，返回-1，当小于可用空间时，返回0，当大于或等于可用空间时，返回1
'**********************************************************************************
Function IsFull(folder,maxsize)
Dim Fso,ObjFld,ftotal,unitFlag
Set Fso=Server.CreateObject("Scripting.FileSystemObject")
If Fso.folderExists(folder) Then
unitFlag=Right(maxsize,2)
If Not IsNumeric(unitFlag) Then
maxsize=Left(maxsize,Len(maxsize)-2)
Select Case unitFlag
Case "KB"
maxsize=maxsize*1024
Case "MB"
maxsize=maxsize*1024*1024
Case "GB"
maxsize=maxsize*1024*1024*1024
End Select
End If
Set ObjFld=Fso.GetFolder(folder)
ftotal=ObjFld.Size
Set ObjFld=nothing
Set Fso=Nothing
If ftotal>=maxsize Then
IsFull=1
Else
IsFull=0
End If
Else
Set Fso=nothing
IsFull=-1
End If
End Function
　　
'**********************************************************************************
' 用来创建新目录
' path为要创建的目录
' 当创建成功时，返回1，当目录已存在或不成功时，返回0
'**********************************************************************************
Function CreateFolder(path)
Dim ReturnValue
ReturnValue=0
If Checkdrive(Left(path,1))=1 Then
Dim Fso
Set Fso=Server.CreateObject("Scripting.FileSystemObject")
If Not Fso.FolderExists(path) Then
Fso.CreateFolder(path)
ReturnValue=1
End If
Set Fso=nothing
End If
CreateFolder=ReturnValue
End Function
　　
　　'**********************************************************************************
' 用来删除目录
' path为要删除的目录
' 当删除成功时，返回1，当目录不存在或不成功时，返回0
'**********************************************************************************
Function DelFolder(path)
On Error Resume Next
Dim ReturnValue
ReturnValue=0
If Checkdrive(Left(path,1))=1 Then
Dim Fso
Set Fso=Server.CreateObject("Scripting.FileSystemObject")
If Fso.FolderExists(path) Then
Fso.DeleteFolder(path)
If Err.number=0 Then
ReturnValue=1
End If
End If
Set Fso=nothing
End If
Err.Clear()
DelFolder=ReturnValue
End Function
　　
'**********************************************************************************
' COPY首页index.htm到domain下
' 如果成功返回1，否则返回0
'**********************************************************************************
Function CopyIndexhtm(domain)
Dim Fso,FilePath,ReturnValue
ReturnValue=0
FilePath="D:/index.htm"
Set Fso=Server.CreateObject("Scripting.FileSystemObject")
If Fso.FileExists(FilePath) Then
Fso.CopyFile filepath,domain&"\"
ReturnValue=1
End If
Set Fso=nothing
CopyIndexhtm=ReturnValue
End Function
　　
　　'**********************************************************************************
' 创建一个WebServer
' 必须参数：oComputer为计算机;WRoot,为创建站点的主目录；WComment为站点说明； WPort为站点端口；ServerRun为是否自动运行
' 当创建成功时返回1，否则提示出错信息并结束
'**********************************************************************************
Function CreateWebServer(oComputer,WRoot,WComment,WPort,ServerRun)
On Error Resume Next
Dim ServiceObj,ServerObj,VDirObj
Set ServiceObj = GetObject("IIS://"&oComputer&"/W3SVC")' 首先创建一个服务实例
　　WNumber=1
Do While IsObject(ServiceObj.GetObject("IIsWebServer",WNumber))
If Err.number<>0 Then  
Err.Clear()
Exit Do
End If
WNumber=WNumber+1
Loop
　　Set ServerObj = ServiceObj.Create("IIsWebServer", WNumber)' 然后创建一个WEB服务器
　　If (Err.Number <> 0) Then' 是否出错
Response.Write "错误:  创建Web服务器的ADSI操作失败！"
CreateWebServer=0
Exit Function
End If
   
  ' 接着配置服务器
  ServerObj.ServerSize = 1   ' 中型大小
  ServerObj.ServerComment = WComment '说明
  ServerObj.ServerBindings = WPort '端口
  ServerObj.EnableDefaultDoc=True
　　' 提交信息
  ServerObj.SetInfo
　　' 最后，建立虚拟目录
  Set VDirObj = ServerObj.Create("IIsWebVirtualDir", "ROOT")
     
    If (Err.Number <> 0) Then' 是否出错
Response.Write "错误:  创建虚拟目录的ADSI操作失败！"
Err.Clear()
CreateWebServer=0
Exit Function
    End If
　　' 配置虚拟目录
  VDirObj.Path = WRoot
  VDirObj.AccessRead = True
  VDirObj.AccessWrite = True
  VDirObj.EnableDirBrowsing = False
  VDirObj.EnableDefaultDoc=True
  VDirObj.AccessScript=True
  VDirObj.AppCreate2 2
  VDirObj.AppFriendlyName="默认应用程序"
  VDirObj.SetInfo
　　If ServerRun = True Then
     ServerObj.Start
       If (Err.Number <> 0) Then    ' Error！
Response.Write "错误:  起动服务器时出错！请手动启动WebServer "&WComment&"！<br>"
Err.Clear()
CreateWebServer=2
Exit Function
       End If
  End If
  Set VDirObj=Nothing
  Set ServerObj=Nothing
  Set ServiceObj=Nothing
  CreateWebServer=1
End Function
　　'=============================================================
'函数介绍：删除指定IIS站点
'本函数使用ADSI，需要Administrators组用户权限
'函数名称：DelWebSite (Computer,SiteNum)
'用法：DelWebSite 计算机名，站点编号
'例：DelWebSite "127.0.0.1","2"
'=============================================================
Function DelWebSite(Computer,SiteNum)
Set W3SVC = GetObject("IIS://"&Computer&"/w3svc")
W3SVC.delete "IIsWebServer",SiteNum
response.write "删除成功！"
End Function
　　'=============================================================
'函数介绍：列出当前服务器WEB站点信息
'本函数使用ADSI，需要Administrators组用户权限
'函数名称：ListWebSite (Computer,Num)
'用法：ListWebSite (计算机名称,显示站点数量)
'例：显示127.0.0.1计算机上1000个站点信息
'ListWebSite "127.0.0.1","1000"
'=============================================================
Function ListWebSite(Computer,Num)
On Error Resume Next
Set SiteObj = GetObject("IIS://"&Computer&"/w3svc/"&i)
for i=0 to Num
Err.Clear
if Err.Number=0 then
response.write "<p><b>以下显示为计算机："&Computer&"上所有站点信息</b></p>"
ShowWebSite = SiteObj.Get("ServerBindings") '获得站点IP地址:端口:主机头
Info=split(ShowWebSite(0),":")
response.write "站点编号："&i&"<br>"
response.write "站点IP地址："&ShowWebSite(0)&"<br>"
response.write "站点端口："&Info(1)&"<br>"
response.write "站点主机头："&Info(2)&"<br><br>"
end if
next
set SiteOjb=nothing
End Function
　　
'=============================================================
'函数介绍：使用ASP启动/停止指定WEB站点
'本函数使用ADSI，需要Administrators组用户权限
'函数名称：AdminWebSite(Computer,WebSiteNum,DoWhat)
'用法：AdminWebSite(计算机名称,站点编号,启动/停止)
'例：启动127.0.0.1计算机上站点编号为1的站点
'AdminWebSite "127.0.0.1","1",1
'例：停止127.0.0.1计算机上站点编号为1的站点
'AdminWebSite "127.0.0.1","1",0
'=============================================================
Function AdminWebSite(Computer,WebSiteNum,DoWhat)
On Error Resume Next
Set objServer = GetObject("IIS://" & Computer & "/W3SVC/" & WebSiteNum)
If Err.Number <> 0 Then
Response.Write Now & ". 错误码: " & Hex(Err)& " - " & "无法开启指定站点<br>"
End If
if Dowhat=1 then
'使用Start启动站点
objServer.Start
If Err.Number <> 0 Then
Response.Write "无法启动指定Web站点<br>"
else
Response.Write "已经启动指定Web站点<br>"
End If
elseif DoWhat=0 then
'使用Stop停止站点
objServer.Stop
If Err.Number <> 0 Then
Response.Write "无法停止指定Web站点<br>"
else
Response.Write "已经停止指定Web站点<br>"
End If
end if
End Function
　　'**********************************************************************************
' 创建一个FtpServer
' 必须参数：oComputer为计算机;WRoot,为创建站点的主目录；WComment为站点说明；WPort为站点端口；ServerRun为是否自动运行
' 当创建成功时返回1，否则提示出错信息并结束
'**********************************************************************************
Function CreateFtpServer(oComputer,WRoot,WComment,WPort,ServerRun)
On Error Resume Next
Dim ServiceObj,ServerObj,VDirObj
Dim WNumber
Set ServiceObj = GetObject("IIS://"&oComputer&"/MSFTPSVC")' 首先创建一个服务实例
　　WNumber=1
Do While IsObject(ServiceObj.GetObject("IIsFtpServer",WNumber))
If Err.number<>0 Then  
Err.Clear()
Exit Do
End If
WNumber=WNumber+1
Loop
　　Set ServerObj = ServiceObj.Create("IIsFtpServer", WNumber)' 然后创建一个WEB服务器
　　If (Err.Number <> 0) Then' 是否出错
'Response.Write "错误:  创建Ftp服务器的ADSI操作失败！"
Err.Clear()
CreateFtpServer=0
Exit Function
End If
   
  ' 接着配置服务器
  ServerObj.ServerSize = 1   ' 中型大小
  ServerObj.ServerComment = WComment '说明
  ServerObj.ServerBindings = WPort '端口
　　' 提交信息
  ServerObj.SetInfo
　　' 最后，建立虚拟目录
  Set VDirObj = ServerObj.Create("IIsFtpVirtualDir", "ROOT")
     
    If (Err.Number <> 0) Then' 是否出错
'Response.Write "错误:  创建虚拟目录的ADSI操作失败！"
Err.Clear()
CreateFtpServer=0
Exit Function
    End If
　　' 配置虚拟目录
  VDirObj.Path = WRoot
  VDirObj.AccessRead = True
  VDirObj.AccessWrite = True
  VDirObj.SetInfo
　　' 成功了！
  If ServerRun = True Then
     ServerObj.Start
       If (Err.Number <> 0) Then    ' Error！
'Response.Write "错误:  起动服务器时出错！"
Err.Clear()
CreateFtpServer=1
Exit Function
       End If
  End If
  Set VDirObj=Nothing
  Set ServerObj=Nothing
  Set ServiceObj=Nothing
  CreateFtpServer=1
End Function
　　
'**********************************************************************************
' 创建一个默认FtpServer的虚拟目录
' 必须参数：oComputer为计算机;VDir,为创建虚拟目录的物理路径；VDirName为虚拟目录说明
' 当创建成功时返回1，否则提示出错信息并返回0
'**********************************************************************************
Function CreateFtpVDir(oComputer,WNumber,VDir,VDirName)
On Error Resume Next
Dim ServerObj,VDirObj
Set ServerObj = GetObject("IIS://"&oComputer&"/MSFTPSVC/"&WNumber&"/ROOT")' 得到FtpServer的主目录对象
　　' 建立虚拟目录
  Set VDirObj = ServerObj.Create("IIsFtpVirtualDir", VDirName)
     
    If (Err.Number <> 0) Then' 是否出错
'Response.Write "错误:  创建Ftp虚拟目录的ADSI操作失败！<br>"
Err.Clear()
CreateFtpVDir=0
Exit Function
    End If
　　' 配置虚拟目录
  VDirObj.Path = VDir
  VDirObj.AccessRead = True
  VDirObj.AccessWrite = True
  VDirObj.SetInfo
　　' 成功了！
  Set VDirObj=Nothing
  Set ServerObj=Nothing
  CreateFtpVDir=1
End Function
　　
'**********************************************************************************
' 创建一个WebServer的虚拟目录
' 必须参数：oComputer为计算机;VDir,为创建虚拟目录的物理路径；WNumber为站点号;VDirName为虚拟目录名
' 当创建成功时返回1，否则提示出错信息并返回0
'**********************************************************************************
Function CreateWebVDir(oComputer,VDir,WNumber,VDirName)
On Error Resume Next
Dim ServerObj,VDirObj
Set ServerObj = GetObject("IIS://"&oComputer&"/W3SVC/"&WNumber&"/ROOT")' 得到FtpServer的主目录对象
　　' 建立虚拟目录
  Set VDirObj = ServerObj.Create("IIsWebVirtualDir", VDirName)
     
    If (Err.Number <> 0) Then' 是否出错
'Response.Write "错误:  创建Web虚拟目录的ADSI操作失败！<br>"
CreateWebVDir=0
Exit Function
    End If
　　' 配置虚拟目录
  VDirObj.Path = VDir
  VDirObj.AccessRead = True
  VDirObj.AccessWrite = False
  VDirObj.EnableDefaultDoc=True
  VDirObj.AccessScript=True
  VDirObj.AppCreate2 2
  VDirObj.AppFriendlyName="默认应用程序"
  VDirObj.SetInfo
　　' 成功了！
  Set VDirObj=Nothing
  Set ServerObj=Nothing
  CreateWebVDir=1
End Function
　　'**********************************************************************************
'用来增加一个WinNT的用户
'必须参数：oDomain为计算机域;NTuser，要创建的用户名;pwd，用户密码
'创建成功返回1，否则返回0
'**********************************************************************************
Function AddNtUser(oDomain,NTuser, pwd)  
on Error Resume Next
Dim ReturnValue
ReturnValue=0
Set oDomain = GetObject("WinNT://"&oDomain)  
    Set oUser = oDomain.Create("user", NTuser)  
    oUser.SetPassword pwd  
oUser.SetInfo  
    If Err.Number=0 Then      
        ReturnValue=1         
Set oUser=nothing
Set oDomain=nothing
    End If  
    AddNtUser=ReturnValue
End Function  
　　
'=============================================================
'函数介绍：列出NT用户组及用户
'本函数使用ADSI，需要Administrators组用户权限
'函数名称：ListGroup(Computer)
'用法：ListGroup(计算机名称)
'例：显示127.0.0.1计算机NT用户组及用户
'ListGroup "127.0.0.1"
'=============================================================
Function ListGroup(Computer)
response.write "<p><b>以下为计算机"&Computer&"系统用户组及用户列表</b></p>"
Set ComputerObj = GetObject("WinNT://"&Computer)
ComputerObj.Filter = Array("Group")
For Each Member in ComputerObj
Response.Write "用户组："&Member.Name&"<br>"
ListUser Computer,Member.Name
Next
end Function
　　'列出指定用户组用户
Function ListUser(Computer,Group)
Set UserObj = GetObject("WinNT://"&Computer&"/"&Group)
For Each Member in UserObj.Members
Response.write "&nbsp;&nbsp;&nbsp;&nbsp;组中用户："&Member.Name &"<br>"
Next
End Function
　　%>
　　本文来自互联网转载