ASP/WScript/VBScript实现ActiveX COM对象管理器(2)

提醒：本页面将不再更新、维护或者支持，文章、评论所叙述内容存在时效性，涉及技术细节或者软件使用方面不保证能够完全有效可操作，请谨慎参考！

上面一篇已经介绍了关于对象管理器类cObjectManager，这篇主要讲在ASP中实现持续性对象管理器，大家知道，在ASP技术中，Global.asa是一个特殊的文件，其随着用户访问网站而启用，并在整个会话期内有效，我们可以将cObjectManager字典对象Scripting.Dictionary单独分离到这个文件中，该怎么做才能让所有ASP文件都能共享这一个对象呢？其实我们只需要在Global.asa中应用<object runat="server"></object>这样的标签就可以创建一个静态的全局对象了。

语法：

<object runat="server" scope="scope" id="id"
{progid="progID"|classid="classID"}>
....
</object>

scope 设置对象的作用域（作用范围）（Session 或者 Application）。 id 为对象指定一个唯一的 id。 ProgID 与 ClassID 关联的 id。ProgID 的格式是：[Vendor.]Component[.Version]。ProgID 或 ClassID 必需被指定。 ClassID 为 COM 类对象指定唯一的 id。ProgID 或 ClassID 必需被指定。

global.asa

<object runat="server" scope="application" id="objMgrDict"
progid="Scripting.Dictionary"></object>

然后我们只需要简单修改一下cObjectManager类：

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

但是记得要设置cObjectManager的IsPersist=True哦，要不在cObjectManager对象生存期到了后会DeleteAllObjects的。如下所示：

<%
Dim objMgr

Set objMgr = New cObjectManager
' 重要，标记为持续对象，避免objMgr销毁时删除所有创建对象
objMgr.IsPersist = True

' TODO: 处理相关事务
Set objMgr = Nothing
%>

好了相关内容就介绍到这里，有什么问题欢迎讨论。

相关下载： ActiveX COM对象管理器.zip ，注意的是global.asa必须位于网站的根目录下。