请教VBA代码中断后，全局IRibbonUI变量丢失问题

249282332

完美支持，赞！

风转砂

楼主，按照你的方法改了之后，显示IngRibPointer类型不匹配，使用 @zzyyzzexcel 优化方案则显示“溢出”，是怎么回事呢？
问题都出在这一句上面
lngRibPointer = GetSetting("CustomUI", ThisWorkbook.Name, "RibbonPointer")

这么老的帖子，期待大神们的回复啊。
感谢！！！

山菊花

风转砂 发表于 2019-1-14 23:30
楼主，按照你的方法改了之后，显示IngRibPointer类型不匹配，使用 @zzyyzzexcel 优化方案则显示“溢出”， ...

问题应该出在声明变量lngRibPointer时，请检查。

风转砂

感谢。确实是这个问题，受系统影响，32位系统可以声明IngRibPointer为 long，64位需要声明为longlong，最好是声明为longPtr，不受系统影响。

星浩

老帖子很有用，解决我困惑已久的问题，百度很久都没找到，偶然百度才找到

qszz

4053005 发表于 2017-3-17 14:55
使用了这个以后,每次一关闭EXCEL就显示失去响应...

使用了这个后，在工作簿的open、beforeclose、Deactivate等事件中都不要放任何触发其响应的语句。否则关闭文件就会失去响应，打开文件就会闪退。

zhufeng012

没想到过了这么多年，经好友推荐，找到到了宝藏资源，谢谢。
结合前面各个前辈的回复，我做个终结版汇总：

楼主原版如下：

1. Option Explicit
   
2. 
   
3. '增加32/64位兼容API声明
   
4. #If VBA7 And Win64 Then
   
5.     Public Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef destination As Any, ByRef source As Any, ByVal length As Long)
   
6. #Else
   
7.     Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef destination As Any, ByRef source As Any, ByVal length As Long)
   
8. #End If
   
9. 
   
10. Public MyRibbon As IRibbonUI
    
11. 
    
12. Sub IRibbonUI_onLoad(ribbon As IRibbonUI) '原版楼主估计CustomeUI少写了一个e。这里修正补上。
    
13.     SaveSetting "CustomeUI", ThisWorkbook.Name, "RibbonPointer", ObjPtr(ribbon)
    
14.     '注册表保存方案；容易受权限影响，如果用户没有注册表操作权限就要保存失败。
    
15.     Set MyRibbon = ribbon
    
16. End Sub
    
17. 
    
18. Function GetRibbon(ByVal lRibbonPointer As LongPtr) As Object '原始版本 将指针lRibbonPointer 定义为LongPtr，提高兼容性
    
19.     If Not Rib Is Nothing Then
    
20.         Set GetRibbon = Rib
    
21.         Exit Function
    
22.     End If
    
23.    
    
24.     Dim objRibbon As Object
    
25.     Dim lngRibPointer As LongPtr '32位用long,64位用longlong,大神建议用Longptr，兼容32/64位。
    
26.    
    
27.     lngRibPointer = GetSetting("CustomeUI", ThisWorkbook.Name, "RibbonPointer")
    
28.     CopyMemory objRibbon, lngRibPointer, LenB(lngRibPointer)
    
29.    
    
30.     Set GetRibbon = objRibbon
    
31.     Set objRibbon = Nothing
    
32.    
    
33. End Function
    
34. 
    

复制代码

大神修改精简版的版本：

1. Option Explicit
   
2. 
   
3. #If VBA7 And Win64 Then
   
4.     Public Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef destination As Any, ByRef source As Any, ByVal length As Long)
   
5. #Else
   
6.     Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef destination As Any, ByRef source As Any, ByVal length As Long)
   
7. #End If
   
8. 
   
9. Public MyRibbon As IRibbonUI
   
10. Sub IRibbonUI_onLoad(ribbon As IRibbonUI)
    
11.     SaveSetting "CustomeUI", ThisWorkbook.Name, "RibbonPointer", ObjPtr(ribbon)
    
12.     '注册表保存方案；容易受权限影响，如果用户没有注册表操作权限就要保存失败。
    
13.     Set MyRibbon = ribbon
    
14. End Sub
    
15. 
    
16. 
    
17. Function GetRibbon_V2() As Object   '修改版V2  ''指针已存在注册表中，无需另外传递，其他多余部分删去，根据某位贴友建议将long修改为longptr
    
18.    
    
19.     Dim objRibbon As Object, lngRibPointer As LongPtr
    
20.    
    
21.     lngRibPointer = GetSetting("CustomeUI", ThisWorkbook.Name, "RibbonPointer")
    
22.    
    
23.     CopyMemory objRibbon, lngRibPointer, LenB(lngRibPointer)
    
24.    
    
25.     Set GetRibbon = objRibbon
    
26.    
    
27. End Function
    
28. 
    
29. 
    
30. '
    
31. '3 调用:
    
32. '可以在VBA任何程序段中调用，（我是在错误处理部分调用），如
    
33. Sub a()
    
34.     '.....
    
35.    
    
36.     On Error GoTo herr
    
37.    
    
38. herr:
    
39.     Set MyRibbon = GetRibbon
    
40.     MyRibbon.Invalidate
    
41. End Sub
    
42. 
    

复制代码

我再各位前辈的基础上，用Excel系统级隐藏名称来做系统级变量，代替注册表保存指针地址的方法。可以提高整个程序的兼容性：

1. Option Explicit
   
2. '增加 32/64位兼容性API声明
   
3. #If VBA7 And Win64 Then
   
4.     Public Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef destination As Any, ByRef source As Any, ByVal length As Long)
   
5. #Else
   
6.     Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef destination As Any, ByRef source As Any, ByVal length As Long)
   
7. #End If
   
8. 
   
9. Public MyRibbon As IRibbonUI
   
10. 
    
11. Sub IRibbonUI_onLoad(ribbon As IRibbonUI)   
    
12.     'SaveSetting "CustomeUI", ThisWorkbook.Name, "RibbonPointer", ObjPtr(ribbon)
    
13.     '注册表保存方案；容易受权限影响，如果用户没有注册表操作权限就要保存失败。   
    
14.     'SetHideName "RibbonPointer", ObjPtr(ribbon)  '这个是封装好的给Excel系统级变量赋值的方法。
    
15.     'Excel Application 级别变量，只要Excel程序不关闭，变量一直有效；    '不受任何环境影响。
    
16. 
    
17.     Application.ExecuteExcel4Macro "SET.NAME(""RibbonPointer""," & ObjPtr(ribbon) & ")"     '这个仅限整数型的，如果是文本型变量需要在value上再加一层嵌套""""
    
18.    
    
19.     Set MyRibbon = ribbon
    
20.    
    
21. End Sub
    
22. 
    
23. 
    
24. 
    
25. 
    
26. Function GetRibbon() As Object   '修改版V3  '指针存到隐藏Name中
    
27.    
    
28.     Dim objRibbon As Object, lngRibPointer As LongPtr
    
29.   
    
30.     lngRibPointer = Application.ExecuteExcel4Macro("RibbonPointer")
    
31.     CopyMemory objRibbon, lngRibPointer, LenB(lngRibPointer)
    
32.    
    
33.     Set GetRibbon = objRibbon
    
34.    
    
35. End Function
    
36. 
    
37. '
    
38. '3 调用:
    
39. '可以在VBA任何程序段中调用，（我是在错误处理部分调用），如
    
40. Sub a()
    
41.     '.....
    
42.    
    
43.     On Error GoTo herr
    
44.    
    
45. herr:
    
46.     Set MyRibbon = GetRibbon
    
47.     MyRibbon.Invalidate
    
48. End Sub
    
49. 
    
50. '再来一个例子，激活某个Tab
    
51. Sub 激活某个Tab()
    
52.     Set MyRibbon = GetRibbon()
    
53.     MyRibbon.ActivateTabMso "TabData"
    
54.     'MyRibbon.ActivateTab "方方格子"
    
55. End Sub
    
56. 
    
57. '再来个例子，需要用MyRibbon的时候提前赋值一次就可以
    
58. Sub PageBreaks_clicked(control As IRibbonControl, pressed As Boolean)
    
59.     ActiveSheet.DisplayPageBreaks = pressed
    
60.     Set MyRibbon = GetRibbon()
    
61.     MyRibbon.InvalidateControl ("StyleInsp")
    
62. End Sub
    
63. 
    
64. 
    
65. 
    

复制代码

三流高手

学习学习，谢谢谢谢！