[已解决]VBA字典与正则表达式引用的疑问

zhoucs00

每次打开EXCEL的时候总得重新引用一下，正则表达式与字典，无法一次引用之后，就一直有效，不知这是什么情况，如何解决？非常感谢！！

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2012-12-13 19:32

自动检测加载代码

1. Private Sub Workbook_Open()
   
2.     '信任对VBA工程的访问
   
3.     Dim WshSHell
   
4.     Set WshSHell = CreateObject("WScript.Shell")
   
5.     WshSHell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office" & Application.Version & "\Excel\Security\AccessVBOM", 1, "REG_DWORD"
   
6.    
   
7.     If Not CheckReference("Scripting") Then
   
8.         'Microsoft Scripting Runtime
   
9.         If Application.VBE.ActiveVBProject.References.AddFromGuid("{420B2830-E718-11CF-893D-00A0C9054228}", 1, 0) Is Nothing Then
   
10.             Debug.Print "Microsoft Scripting Runtime error"
    
11.         End If
    
12.     End If
    
13.    
    
14.     If Not CheckReference("VBScript_RegExp_55") Then
    
15.         'VBScript_RegExp_55
    
16.         If Application.VBE.ActiveVBProject.References.AddFromGuid("{3F4DACA7-160D-11D2-A8E9-00104B365C9F}", 5, 5) Is Nothing Then
    
17.             Debug.Print "VBScript_RegExp_55 error"
    
18.         End If
    
19.     End If
    
20.    
    
21.     If Not CheckReference("VBIDE") Then
    
22.         'VBIDE
    
23.         If Application.VBE.ActiveVBProject.References.AddFromGuid("{0002E157-0000-0000-C000-000000000046}", 5, 3) Is Nothing Then
    
24.             Debug.Print "VBIDE error"
    
25.         End If
    
26.     End If
    
27. End Sub
    
28. 
    
29. 
    
30. Function CheckReference(ByVal refname As String) As Boolean
    
31.     Dim ref
    
32.     For Each ref In ThisWorkbook.VBProject.References
    
33.         If UCase(ref.Name) Like UCase(refname) Then
    
34.             CheckReference = True
    
35.             Exit Function
    
36.         End If
    
37.     Next
    
38. End Function

复制代码

跳转到最佳答案楼层

hwc2ycy

1.采用后期创建法；
dim dic as object
set dic=createobject("scripting.dictionary")
dim reg as object
set reg=createobject("vbscript.regexp")

2.加入自动引用的代码；

zhoucs00

hwc2ycy 发表于 2012-12-13 18:56
1.采用后期创建法；
dim dic as object
set dic=createobject("scripting.dictionary")

嗯嗯，非常感谢您！估计这跟电脑有关吧，不过采用后期引用的话， 也是一个很不错的方法。

hwc2ycy

自动检测加载代码

1. Private Sub Workbook_Open()
   
2.     '信任对VBA工程的访问
   
3.     Dim WshSHell
   
4.     Set WshSHell = CreateObject("WScript.Shell")
   
5.     WshSHell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office" & Application.Version & "\Excel\Security\AccessVBOM", 1, "REG_DWORD"
   
6.    
   
7.     If Not CheckReference("Scripting") Then
   
8.         'Microsoft Scripting Runtime
   
9.         If Application.VBE.ActiveVBProject.References.AddFromGuid("{420B2830-E718-11CF-893D-00A0C9054228}", 1, 0) Is Nothing Then
   
10.             Debug.Print "Microsoft Scripting Runtime error"
    
11.         End If
    
12.     End If
    
13.    
    
14.     If Not CheckReference("VBScript_RegExp_55") Then
    
15.         'VBScript_RegExp_55
    
16.         If Application.VBE.ActiveVBProject.References.AddFromGuid("{3F4DACA7-160D-11D2-A8E9-00104B365C9F}", 5, 5) Is Nothing Then
    
17.             Debug.Print "VBScript_RegExp_55 error"
    
18.         End If
    
19.     End If
    
20.    
    
21.     If Not CheckReference("VBIDE") Then
    
22.         'VBIDE
    
23.         If Application.VBE.ActiveVBProject.References.AddFromGuid("{0002E157-0000-0000-C000-000000000046}", 5, 3) Is Nothing Then
    
24.             Debug.Print "VBIDE error"
    
25.         End If
    
26.     End If
    
27. End Sub
    
28. 
    
29. 
    
30. Function CheckReference(ByVal refname As String) As Boolean
    
31.     Dim ref
    
32.     For Each ref In ThisWorkbook.VBProject.References
    
33.         If UCase(ref.Name) Like UCase(refname) Then
    
34.             CheckReference = True
    
35.             Exit Function
    
36.         End If
    
37.     Next
    
38. End Function

复制代码

hwc2ycy

检测加载的引用列表，千万不要在有数据的工作表内运行，会清除A:G列的数据

1. Sub ListReferenct()
   
2.     Dim a, rg As Range
   
3.     Set rg = Range("a1")
   
4.     For Each a In ThisWorkbook.VBProject.References
   
5.         rg(1, 1) = a.Name
   
6.         rg(1, 6) = a.fullpath
   
7.         rg(1, 2) = a.GUID
   
8.         rg(1, 3) = a.Major
   
9.         rg(1, 4) = a.Minor
   
10.         rg(1, 7) = a.isbroken
    
11.         rg(1, 5) = a.Description
    
12.         Set rg = rg(2, 1)
    
13.     Next
    
14. End Sub

复制代码

zhoucs00

hwc2ycy 发表于 2012-12-13 19:32
自动检测加载代码

非常非常感谢您，您真是太热心了。。

hwc2ycy

这贴子居然没给最佳呀，楼主。
我今天找这个代码又找回来了，

zhoucs00

hwc2ycy 发表于 2013-1-8 21:33
这贴子居然没给最佳呀，楼主。
我今天找这个代码又找回来了，

之前不懂规矩，忘记了

hwc2ycy

，呵呵，多谢。