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

!本文可能 超过1年没有更新,今后内容也许不会被维护或者支持,部分内容可能具有时效性,涉及技术细节或者软件使用方面,本人不保证相应的兼容和可操作性。

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

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

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

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
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. 使用全局变量

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
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. 使用传参的办法

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
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。

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
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类,接下来的事情就简单多了,我们改写一下上面的文件处理函数:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
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删除这个对象。为了使这个类更易于使用,我加入了数组的支持,你可以像下面这样写:

1
2
3
4
5
6
7
8
9
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等数组列表中的对象,直到创建成功并加入到列表中。

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

若无特别说明,本网站文章均为原创,原则上这些文章不允许转载,但是如果阁下是出于研究学习目的可以转载到阁下的个人博客或者主页,转载遵循创作共同性“署名-非商业性使用-相同方式共享”原则,请转载时注明作者出处谢绝商业性、非署名、采集站、垃圾站或者纯粹为了流量的转载。谢谢合作!
请稍后...

发表评论

电子邮件地址不会被公开。 必填项已用*标注

*