VBScript Object Manager

cObjectManager.class.vbs

'
' Author : wangye
' For more information please visit:
'   http://wangye.org/blog/archives/267/
'
Class cObjectManager
 Public IsPersist
 Private objHost
 Private objDict
 
 ' 自动初始化可用的环境宿主
 ' Server - ASP 环境
 ' WScript,WSH - Windows Script 宿主
 Private Sub InitHost()
  Dim objDefaultHosts, i
  Set objHost = Nothing
  objDefaultHosts = Array("Server", "WScript", "WSH")
  For i = 0 To UBound(objDefaultHosts)
    If IsObject(Eval(objDefaultHosts(i))) Then
      Set objHost = Eval(objDefaultHosts(i))
      Exit For
    End If
  Next
  ' 如果不定义全局字典，请确保此处始终是False
  IsPersist = False
 End Sub
 
 ' 构造函数
 Private Sub Class_Initialize()
   Call InitHost()
   ' 建立对象字典，直接引用全局字典
   Set objDict = Application.StaticObjects("objMgrDict")
 End Sub
 
 ' 析构函数
 Private Sub Class_Terminate()
   If IsValidObject(objDict) And (Not IsPersist) Then
	DeleteAllObjects ' 删除所有对象及引用
	objDict.RemoveAll
   End If
   Set objDict = Nothing
   Set objHost = Nothing
 End Sub
 
 ' 得到已缓存的对象数目
 Public Function GetObjectsCount()
  GetObjectsCount = objDict.Count
 End Function
 
 ' 设置环境宿主类型
 ' Example :
 ' Object.Host = Server
 Public Property Let Host(obj) 
   Set objHost = obj
 End Property
 
 ' 创建COM对象
 Private Function CreateActiveXObject(progName)
  If objHost Is Nothing Then
   ' 如果环境宿主不存在就直接调用语言特性CreateObject
   Set CreateActiveXObject = CreateObject(progName)
  Else
   Set CreateActiveXObject = objHost.CreateObject(progName)
  End If
 End Function
 
 ' 建立新对象，支持数组组件名
 ' 如果传入数组组件名，那么将依次尝试创建对象
 ' 直到建立可用对象位置
 Public Function NewObject(progName)
   On Error Resume Next
   If Not IsArray(progName) Then
    Set NewObject = CreateActiveXObject(progName)
   Else
   Dim i
   For i=0 To UBound(progName)
    Set NewObject = CreateActiveXObject(progName(i))
    If Err.Number=0 And IsValidObject(NewObject) Then
     Exit For
    ElseIf Err.number = -2147352567 Then
     Err.Clear
  Else
   Err.Clear
   Exit For
    End If
   Next
  End If
  If Err.Number<>0 Then
   Err.Clear
   Set NewObject = Nothing
  End If
 End Function
 
 ' 判断建立的对象是否有效
 Private Function IsValidObject(obj)
  IsValidObject = (Not (obj Is Nothing) And IsObject(obj))
 End Function
 
 ' 获取字典缓存或者系统内可用的对象，支持数组
 Private Function GetExistsObject(progName, useGetObject)
    Set GetExistsObject = Nothing
  If Not IsArray(progName) Then
    If objDict.Exists(progName) Then
      Set GetExistsObject = objDict.Item(progName)
    ElseIf useGetObject Then
	  ' 如果useGetObject=true并且字典缓存内对象不存在，
	  ' 那么就通过GetObject来获取系统内缓存的对象，
	  ' 一般情况下不建议直接使用系统缓存的对象，
	  ' 所以正常情况下useGetObject=false
      On Error Resume Next
      Set GetExistsObject = objHost.GetObject("",progName)
      If IsValidObject(GetExistsObject) Then
        Exit Function
      End If
      Set GetExistsObject = Nothing
      If Err.Number<>0 Then
        Err.Clear
      End If
    End If
  Else
    Dim i
    For i=0 To UBound(progName)
      Set GetExistsObject = GetExistsObject(progName(i), useGetObject)
      If IsValidObject(GetExistsObject) Then Exit Function
    Next
  End If
 End Function
 
 '  获取对象实例，支持数组对象名称，如果使useGetObject=true
 '  那么字典获取不到的情况下将尝试使用GetObject获取系统内对象
 Public Function GetObjectInstance(progName, useGetObject)
  'If TypeName(useGetObject) = "Error" Then
  '  useGetObject = False
  'End If
  
  Set GetObjectInstance = GetExistsObject(progName, useGetObject)
  If IsValidObject(GetObjectInstance) Then Exit Function
 
  On Error Resume Next
  If Not IsArray(progName) Then
    Set GetObjectInstance = CreateActiveXObject(progName)
    If Err.Number<>0 Or Not IsValidObject(GetObjectInstance) Then
      Err.Clear
      Set GetObjectInstance = Nothing
    Else
      objDict.Add progName, GetObjectInstance
      Exit Function
    End If
  Else
    Dim i
    For i=0 To UBound(progName)
      Set GetObjectInstance = GetObjectInstance(progName(i), useGetObject)
      If IsValidObject(GetObjectInstance) Then Exit Function
    Next
  End If
 End Function
 
 '  删除一个对象并解除引用
 Public Sub DeleteObject(progName)
  If Not IsArray(progName) Then
    If objDict.Exists(progName) Then
      Set objDict.Item(progName) = Nothing
	  objDict.Remove progName
	End If
  Else
    Dim i
    For i=0 To UBound(progName)
      DeleteObject(progName(i))
    Next
  End If
 End Sub
 
 ' 删除所有对象并解除引用
 Public Sub DeleteAllObjects()
   Dim i,keys,items
   keys = objDict.Keys
   items = objDict.Items
   For i = 0 To objDict.Count-1
     DeleteObject keys(i)
   Next
 End Sub
End Class