[求助]：请问在2004下,用ActiveX新增一个工具栏按钮设置图标时为什么会引起错误并退出

zezh

在2004下,VB用ActiveX在CAD新增一个工具栏按钮(在标准工具栏)设置图标时,就会引起CAD错误并退出,请问是怎麽回事?谢谢!

雪山飞狐(lzh)

看一下你的代码好么？

zezh

2. 
   
3.   [FONT=courier new]
   
4. Option Explicit
   
5. '
   
6. '**abCAD Setup**
   
7. '
   
8. 'COPY文件并在AutoCAD中新建工具栏图标
   
9. '
   
10. 'author: abt(ze_zh@sina.com：意见、建议)
    
11. 'date: 2004-7-25/7-27
    
12. '****
    
13. '
    
14. 
    
15. Const AppName As String = "abCAD"
    
16. Const AppMacroName As String = AppName
    
17. Const AppMacro As String = "abCAD/abCAD.dvb!ThisDrawing.Main"
    
18. Const AppBitmaps As String = AppName & ".bmp"
    
19. Const AppToolBarTag As String = "ID_TbStandar"
    
20. 
    
21. Const PathSep As String * 1 = ""
    
22. Const CADVerMin As Integer = 15
    
23. 
    
24. Private acadApp As Object
    
25. Private fs As Object
    
26. Private mbCloseAcad As Boolean '是否关闲Acad
    
27. 
    
28. Public Sub Main()
    
29.     Dim r As String
    
30.    
    
31.     On Error Resume Next
    
32.    
    
33.     If Not getAcad() Then r = "无可用AutoCAD": GoTo L
    
34.     If Not chkVer(acadApp.Version) Then r = "不支持的AutoCAD版本": GoTo L
    
35.    
    
36.     Set fs = CreateObject("Scripting.FileSystemObject")
    
37.    
    
38.     copyFiles fs.GetFolder(App.path), acadApp.path & PathSep
    
39.     If Not createAppButton() Then r = "未能生成AutoCAD工具栏图标"
    
40.    
    
41. L:  If mbCloseAcad Then acadApp.Quit
    
42.    
    
43.     If r <> "" Then r = AppName & "安装失败:" & r Else r = AppName & "成功安装!" & vbCrLf & "欢迎使用！" & vbCrLf & "查看帮助请点击AutoCAD标准工具栏中<ab>图标"
    
44.     showInfo r
    
45. End Sub
    
46. 
    
47. 'get AutoCAD app
    
48. Private Function getAcad() As Boolean
    
49.     Dim i As Integer
    
50.    
    
51.     On Error Resume Next
    
52.    
    
53.     mbCloseAcad = False
    
54.     Do
    
55.         Set acadApp = GetObject(, "AutoCAD.Application")
    
56.         If Err = 0 Then
    
57.             getAcad = True: Exit Function
    
58.         End If
    
59.         
    
60.         Err.Clear
    
61.         i = MsgBox("当前没有正在运行的AutoCAD." & vbCrLf & "强烈建议安装" & AppName & "之前，先打开AutoCAD!", vbAbortRetryIgnore + vbExclamation)
    
62.         If i = vbAbort Then getAcad = False: Exit Function
    
63.     Loop While i = vbRetry
    
64.    
    
65.     Set acadApp = CreateObject("AutoCAD.Application")
    
66.     If Err <> 0 Then getAcad = False: Exit Function
    
67.     acadApp.Visible = False
    
68.    
    
69.     mbCloseAcad = True
    
70.     getAcad = True
    
71. End Function
    
72. 
    
73. 'chk version
    
74. Private Function chkVer(sVer As String) As Boolean
    
75.     Dim i As Integer
    
76.     Dim s As String
    
77.    
    
78.     chkVer = False
    
79.    
    
80.     i = InStr(sVer, ".")
    
81.     If i <= 1 Then Exit Function
    
82.     s = Left(sVer, i - 1)
    
83.     If Not IsNumeric(s) Then Exit Function
    
84.    
    
85.     chkVer = CInt(s) >= CADVerMin
    
86. End Function
    
87. 
    
88. 'recur to copy files
    
89. Private Sub copyFiles(fo As Object, pathDest As String)
    
90.     Dim foSub As Object
    
91.     Dim path As String
    
92.    
    
93.     On Error Resume Next
    
94.    
    
95.     For Each foSub In fo.SubFolders
    
96.         path = pathDest & foSub.Name & PathSep
    
97.         If Not fs.FolderExists(path) Then fs.CreateFolder path
    
98.         fs.CopyFile foSub.path & PathSep & "*.*", path, True
    
99.         If Err <> 0 Then Err.Clear
    
100.         
     
101.         copyFiles foSub, path
     
102.     Next
     
103. End Sub
     
104. 
     
105. 'show info
     
106. Private Sub showInfo(sInfo As String)
     
107.     MsgBox sInfo, vbInformation
     
108. End Sub
     
109. 
     
110. [B]'主要是这个函数[/B]
     
111. 'creat tool bar button
     
112. Private Function createAppButton() As Boolean
     
113.     Dim menuGroup As Object
     
114.     Dim toolBar As Object
     
115.     Dim button As Object
     
116.     Dim doc As Object
     
117.    
     
118.     Dim sMacro As String
     
119.     Dim b As Boolean
     
120.    
     
121.     On Error Resume Next
     
122.    
     
123.     createAppButton = False
     
124.    
     
125.     'save doc
     
126.     For Each doc In acadApp.Documents
     
127.         If Not doc.Saved Then doc.Save
     
128.     Next
     
129.    
     
130.     Set menuGroup = acadApp.MenuGroups("ACAD")
     
131.     If Err <> 0 Then Exit Function
     
132.    
     
133.     b = False
     
134.     For Each toolBar In menuGroup.Toolbars
     
135.         If StrComp(toolBar.TagString, AppToolBarTag, vbTextCompare) = 0 Then b = True: Exit For
     
136.     Next
     
137.     If Not b Then Exit Function
     
138.    
     
139.     If Not toolBar.Visible Then toolBar.Visible = True
     
140.     Set button = toolBar.Item(toolBar.Count - 1)
     
141.    
     
142.     sMacro = Chr(3) & Chr(3) & Chr(95) & "-VBARUN " & AppMacro & Chr(32)
     
143.     'b = True
     
144.     If button.Type = 0 Then 'acToolbarButton
     
145.         If StrComp(Left(button.Name, Len(AppMacroName)), AppMacroName, vbTextCompare) = 0 Then
     
146.             button.Macro = sMacro
     
147.             menuGroup.Save 1 'acMenuFileSource
     
148.             
     
149.             createAppButton = Err = 0
     
150.             Exit Function
     
151.         End If
     
152.     End If
     
153.    
     
154.     Set button = toolBar.AddToolbarButton(toolBar.Count, AppMacroName, AppMacroName, sMacro)
     
155.     toolBar.AddSeparator toolBar.Count
     
156.     [B]'下面这条语句引用CAD2004退出[/B]
     
157.     button.SetBitmaps AppBitmaps, AppBitmaps
     
158.     menuGroup.Save 1 'acMenuFileSource
     
159.    
     
160.     createAppButton = Err = 0
     
161. End Function
     
162.   [/FONT]
     

<br />   [FONT=courier new]<br /> Option Explicit<br /> '<br /> '**abCAD Setup**<br /> '<br /> 'COPY文件并在AutoCAD中新建工具栏图标<br /> '<br /> 'author: abt(ze_zh@sina.com：意见、建议)<br /> 'date: 2004-7-25/7-27<br /> '****<br /> '<br /> <br /> Const AppName As String = "abCAD"<br /> Const AppMacroName As String = AppName<br /> Const AppMacro As String = "abCAD/abCAD.dvb!ThisDrawing.Main"<br /> Const AppBitmaps As String = AppName & ".bmp"<br /> Const AppToolBarTag As String = "ID_TbStandar"<br /> <br /> Const PathSep As String * 1 = ""<br /> Const CADVerMin As Integer = 15<br /> <br /> Private acadApp As Object<br /> Private fs As Object<br /> Private mbCloseAcad As Boolean '是否关闲Acad<br /> <br /> Public Sub Main()<br />     Dim r As String<br />     <br />     On Error Resume Next<br />     <br />     If Not getAcad() Then r = "无可用AutoCAD": GoTo L<br />     If Not chkVer(acadApp.Version) Then r = "不支持的AutoCAD版本": GoTo L<br />     <br />     Set fs = CreateObject("Scripting.FileSystemObject")<br />     <br />     copyFiles fs.GetFolder(App.path), acadApp.path & PathSep<br />     If Not createAppButton() Then r = "未能生成AutoCAD工具栏图标"<br />     <br /> L:  If mbCloseAcad Then acadApp.Quit<br />     <br />     If r <> "" Then r = AppName & "安装失败:" & r Else r = AppName & "成功安装!" & vbCrLf & "欢迎使用！" & vbCrLf & "查看帮助请点击AutoCAD标准工具栏中<ab>图标"<br />     showInfo r<br /> End Sub<br /> <br /> 'get AutoCAD app<br /> Private Function getAcad() As Boolean<br />     Dim i As Integer<br />     <br />     On Error Resume Next<br />     <br />     mbCloseAcad = False<br />     Do<br />         Set acadApp = GetObject(, "AutoCAD.Application")<br />         If Err = 0 Then<br />             getAcad = True: Exit Function<br />         End If<br />         <br />         Err.Clear<br />         i = MsgBox("当前没有正在运行的AutoCAD." & vbCrLf & "强烈建议安装" & AppName & "之前，先打开AutoCAD!", vbAbortRetryIgnore + vbExclamation)<br />         If i = vbAbort Then getAcad = False: Exit Function<br />     Loop While i = vbRetry<br />     <br />     Set acadApp = CreateObject("AutoCAD.Application")<br />     If Err <> 0 Then getAcad = False: Exit Function<br />     acadApp.Visible = False<br />     <br />     mbCloseAcad = True<br />     getAcad = True<br /> End Function<br /> <br /> 'chk version<br /> Private Function chkVer(sVer As String) As Boolean<br />     Dim i As Integer<br />     Dim s As String<br />     <br />     chkVer = False<br />     <br />     i = InStr(sVer, ".")<br />     If i <= 1 Then Exit Function<br />     s = Left(sVer, i - 1)<br />     If Not IsNumeric(s) Then Exit Function<br />     <br />     chkVer = CInt(s) >= CADVerMin<br /> End Function<br /> <br /> 'recur to copy files<br /> Private Sub copyFiles(fo As Object, pathDest As String)<br />     Dim foSub As Object<br />     Dim path As String<br />     <br />     On Error Resume Next<br />     <br />     For Each foSub In fo.SubFolders<br />         path = pathDest & foSub.Name & PathSep<br />         If Not fs.FolderExists(path) Then fs.CreateFolder path<br />         fs.CopyFile foSub.path & PathSep & "*.*", path, True<br />         If Err <> 0 Then Err.Clear<br />         <br />         copyFiles foSub, path<br />     Next<br /> End Sub<br /> <br /> 'show info<br /> Private Sub showInfo(sInfo As String)<br />     MsgBox sInfo, vbInformation<br /> End Sub<br /> <br /> [B]'主要是这个函数[/B]<br /> 'creat tool bar button<br /> Private Function createAppButton() As Boolean<br />     Dim menuGroup As Object<br />     Dim toolBar As Object<br />     Dim button As Object<br />     Dim doc As Object<br />     <br />     Dim sMacro As String<br />     Dim b As Boolean<br />     <br />     On Error Resume Next<br />     <br />     createAppButton = False<br />     <br />     'save doc<br />     For Each doc In acadApp.Documents<br />         If Not doc.Saved Then doc.Save<br />     Next<br />     <br />     Set menuGroup = acadApp.MenuGroups("ACAD")<br />     If Err <> 0 Then Exit Function<br />     <br />     b = False<br />     For Each toolBar In menuGroup.Toolbars<br />         If StrComp(toolBar.TagString, AppToolBarTag, vbTextCompare) = 0 Then b = True: Exit For<br />     Next<br />     If Not b Then Exit Function<br />     <br />     If Not toolBar.Visible Then toolBar.Visible = True<br />     Set button = toolBar.Item(toolBar.Count - 1)<br />     <br />     sMacro = Chr(3) & Chr(3) & Chr(95) & "-VBARUN " & AppMacro & Chr(32)<br />     'b = True<br />     If button.Type = 0 Then 'acToolbarButton<br />         If StrComp(Left(button.Name, Len(AppMacroName)), AppMacroName, vbTextCompare) = 0 Then<br />             button.Macro = sMacro<br />             menuGroup.Save 1 'acMenuFileSource<br />             <br />             createAppButton = Err = 0<br />             Exit Function<br />         End If<br />     End If<br />     <br />     Set button = toolBar.AddToolbarButton(toolBar.Count, AppMacroName, AppMacroName, sMacro)<br />     toolBar.AddSeparator toolBar.Count<br />     [B]'下面这条语句引用CAD2004退出[/B]<br />     button.SetBitmaps AppBitmaps, AppBitmaps<br />     menuGroup.Save 1 'acMenuFileSource<br />     <br />     createAppButton = Err = 0<br /> End Function<br />   [/FONT]<br />

一个很小的安装程序，用的VB6，COPY文件再在CAD中创建工具栏按钮，在R2002下无错，R2004下设置图标时错误并退出。请看看最后一个函数。
多谢斑竹！！！

雪山飞狐(lzh)

abCAD.bmp文件在2004的搜索目录下面麽？

zezh

COPY文件时，已COPY到CAD的Support中了
引起2004退出，再打开2004，有时按钮＆图标已搞好了，但有时不行，不知为啥。逐步调试时发现那条设置图标的语句有错。有点莫名其妙。。。

雪山飞狐(lzh)

直接做成文件加载不好些麽？

zezh

谢谢!我在看看吧!