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

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

本文仅实现了一种理论上的管理已经创建ActiveX COM方法，部分代码可以直接使用，由于未进行性能及稳定性测试，所以不建议使用到实际生产环境。下面所述将以VBScript脚本语言为例，同样适用于ASP、VB及VBA（Visual Basic For Application）技术。

大家知道在VBScript中创建对象是通过CreateObject实现的，由于是对象类型，所以必须通过Set关键字进行对象引用，当对象使用完毕后要通过Set [对象名] = Nothing进行对象销毁，这样VBS内部对象引用计数才下降，直至完全销毁回收。

大部分情况下，我们所创建的对象是可以复用的，也就是说，我们在一次使用完毕后可以不用急于销毁对象，然后第二、三次继续使用这个已经存在的对象，这样就避免多次调用CreateObject带来性能上的损耗，以及可能创建失败的风险。

比如说有这样的WScript/VBScript代码：

Function IsFileExists(filename)
  Dim fso
  Set fso = CreateObject("Scripting.FileSystemObject")
    IsFileExists = fso.FileExists(filename)
  Set fso = Nothing
End Function

Function IsFolderExists(filename)
  Dim fso
  Set fso = CreateObject("Scripting.FileSystemObject")
    IsFolderExists = fso.FolderExists(filename)
  Set fso = Nothing
End Function

Sub WriteTextFile(filename, text)
  Dim fso, f
  Set fso = CreateObject("Scripting.FileSystemObject")
    Set f = fso.CreateTextFile(filename, true)
      f.WriteLine text
      f.Close
    Set f = Nothing
  Set fso = Nothing
End Sub

If Not IsFileExists("C:\test\data.txt") Then
  If IsFolderExists("C:\test") Then
     WriteTextFile "C:\test\data.txt", "Hello world!"
  End If
End If

这里实现了一个简单的功能，判断文件data.txt，如果不存在，然后判断C:\test文件夹是否存在，存在的话就写入data.txt文件，简单的功能包含了“语法糖”般的函数调用，虽然这样做封装特性比较好，而且提升了我们编码的效率，但是我们这里创建了3次Scripting.FileSystemObject对象，因此程序执行的性能可想而知了，其实较好的做法是创建1次Scripting.FileSystemObject对象，然后FileExists、FolderExists以及CreateTextFile都属于上下文无关的方法，因此可以复用，所以有了下面2种办法：

1. 使用全局变量

Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")

Function IsFileExists(filename)
    IsFileExists = fso.FileExists(filename)
End Function

Function IsFolderExists(filename)
    IsFolderExists = fso.FolderExists(filename)
End Function

Sub WriteTextFile(filename, text)
    Set f = fso.CreateTextFile(filename, true)
      f.WriteLine text
      f.Close
    Set f = Nothing
End Sub

If Not IsFileExists("C:\test\data.txt") Then
  If IsFolderExists("C:\test") Then
     WriteTextFile "C:\test\data.txt", "Hello world!"
  End If
End If

Set fso = Nothing

这是一种比较常见的方法，确实在一定程度上复用了FSO对象，对于一种对象还好管理，如果说存在多种类型的对象，再加上复杂的编码环境，那么全局变量方法必然会导致对象管理的混乱，而且也容易忘记Set [对象] = Nothing。

2. 使用传参的办法

Function IsFileExists(filename, fso)
    IsFileExists = fso.FileExists(filename)
End Function

Function IsFolderExists(filename, fso)
    IsFolderExists = fso.FolderExists(filename)
End Function

Sub WriteTextFile(filename, text, fso)
    Set f = fso.CreateTextFile(filename, true)
      f.WriteLine text
      f.Close
    Set f = Nothing
End Sub

Dim fso1
Set fso1 = CreateObject("Scripting.FileSystemObject")

If Not IsFileExists("C:\test\data.txt", fso1) Then
  If IsFolderExists("C:\test", fso1) Then
     WriteTextFile "C:\test\data.txt", "Hello world!", fso1
  End If
End If

Set fso1 = Nothing

同样的，虽然解决了问题，但是给我们编码带来了麻烦，因为我们调用函数要多写一个对象参数。

现在，我们注意到上面第一种办法，对于一个页面或者脚本文件可能存在的N个对象，我们需要用一个全局变量进行有效的组织管理，并且达到最大程度的复用，这个全局变量引用了一个管理对象的对象，我们可以称之为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 = CreateActiveXObject("Scripting.Dictionary")
 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类，接下来的事情就简单多了，我们改写一下上面的文件处理函数：

Dim objMgr

Set objMgr = New cObjectManager ' 开始

Function IsFileExists(filename)
  Dim fso
  Set fso = objMgr.GetObjectInstance("Scripting.FileSystemObject", false)
    IsFileExists = fso.FileExists(filename)
  Set fso = Nothing
End Function

Function IsFolderExists(filename)
  Dim fso
  Set fso = objMgr.GetObjectInstance("Scripting.FileSystemObject", false)
    IsFolderExists = fso.FolderExists(filename)
  Set fso = Nothing
End Function

Sub WriteTextFile(filename, text)
  Dim fso, f
  Set fso = objMgr.GetObjectInstance("Scripting.FileSystemObject", false)
    Set f = fso.CreateTextFile(filename, true)
      f.WriteLine text
      f.Close
    Set f = Nothing
  Set fso = Nothing
End Sub

If Not IsFileExists("C:\test\data.txt") Then
  If IsFolderExists("C:\test") Then
     WriteTextFile "C:\test\data.txt", "Hello world!"
  End If
End If

    objMgr.DeleteObject "Scripting.FileSystemObject"
Set objMgr = Nothing ' 结束

可以看到我们仅仅需要一个全局变量来组织管理我们的对象，接下来的GetObjectInstance始终引用的是同一个对象，避免了对象的重复创建，最后不用时可以通过DeleteObject删除这个对象。为了使这个类更易于使用，我加入了数组的支持，你可以像下面这样写：

Set objXml = objMgr.GetObjectInstance(_
  Array(_
    "Microsoft.XMLHTTP",_
    "MSXML6.XMLHTTP",_
    "MSXML5.XMLHTTP",_
    "MSXML4.XMLHTTP",_
    "MSXML3.XMLHTTP",_
    "MSXML2.XMLHTTP",_
    "MSXML.XMLHTTP"), false)

这样系统将依次尝试创建Microsoft.XMLHTTP、MSXML6.XMLHTTP、MSXML5.XMLHTTP等数组列表中的对象，直到创建成功并加入到列表中。

相关脚本代码下载将在下一篇中给出。