AutoCAD VBA部署方案分享
通过创建快捷方式用于加载dvb，写入菜单
1’通过代码编写scr文件和创建dvb工程加载快捷方式
"C:\Program Files\Autodesk\AutoCAD 2022\acad.exe" /nologo /b "D:\VBProject\AutoCADVbaProject\MyVbaCmd_2022\算法研究.scr"
/nologo 表示启动跳过界面加快cad的启动速度
/b 表示需要启动cad的时候，加载二进制程序
具体参考官方说明
2.scr文件的内部如下
创建快捷方式
Public Sub Mycmd_创建DVB加载快捷方式()
Dim curDvbName As String, fso As New FileSystemObject, scrFn As String, dvbName As String
curDvbName = Application.VBE.ActiveVBProject.FileName
'创建scr文件
scrFn = VBA.Replace(curDvbName, ".dvb", ".scr")
dvbName = VBA.Replace(fso.GetFileName(curDvbName), ".dvb", vbNullString)
Open scrFn For Output As #1 '如改为For Append，则为追加文件。
Print #1, "filedia 0"
Print #1, "cmdecho 0"
Print #1, "_vbarun " & Chr(34) & VBA.Replace(curDvbName, "\", "/") & "!ThisDrawing.AddBar" & Chr(34) 'addbar表示需要随cad启动而执行的过程
Print #1, "filedia 1"
Close #1
'创建快捷方式
Dim wsh As Object, lnkFilePath As String, shortCut As Object
Set wsh = VBA.CreateObject("WScript.Shell") ''IWshRuntimeLibrary;C:\Windows\SysWOW64\wshom.ocx
lnkFilePath = wsh.SpecialFolders("Desktop") & "\" & VBA.Replace(dir(curDvbName), ".dvb", "(" & fso.GetFolder(Application.Path).Name & ").lnk") '创建快捷方式到桌面
'关于SpecialFolders 查看下面的网站即可查阅
Rem https://www.vbsedit.com/html/7682257e-4042-4f7d-b266-03382021d0aa.asp
'var startMenuDir = $@"C:\ProgramData\Microsoft\Windows\Start Menu\Programs";
'"C:\Program Files (x86)\AutoCAD 2008\acad.exe" /nologo /b "C:\Users\NanSheng\AppData\Local\Temp\算法研究.scr"
With wsh.CreateShortcut(lnkFilePath)
.TargetPath = Chr(34) & Application.FullName & Chr(34)
.Arguments = "/nologo /b " & Chr(34) & scrFn & Chr(34)
.WorkingDirectory = fso.GetParentFolderName(scrFn)
.WindowStyle = 1 '//设置运行方式，默认为常规窗口 '// '设置备注
'//shortcut.IconLocation = String.IsNullOrWhiteSpace(iconLocation) ? targetPath : iconLocation;//设置图标路径
.Save
End With
Set wsh = Nothing
End Sub
创建菜单的主过程，这个也是在scr中需要与cad启动同时执行的过程
此处开发者需要根据需要自己设定需要加载到菜单的方法的规则
Public Sub AddBar()
Dim mycmds As Dictionary, menuName As String, vbeobj As Object, curDvb As Object
Set vbeobj = Application.VBE
Set curDvb = vbeobj.ActiveVBProject
menuName = VBA.Replace(VBA.dir(curDvb.FileName), ".dvb", vbNullString)
Set mycmds = GetCurProjectSubNames("Mycmd_", menuName)
Call AddMenuBarAndToolBar(mycmds, menuName, True, True)
Dim cadVer As Double
cadVer = VBA.CDbl(VBA.Left(Application.Version, 4))
If cadVer > 17.1 Then '2009版本开需要修改系统变量
If ThisDrawing.GetVariable("MenuBar") = 0 Then ThisDrawing.SetVariable "MenuBar", 1
End If
Set vbeobj = Nothing: Set curDvb = Nothing
End Sub利用代码导出需要的方法名称和宏，用于动态加载菜单
'' <summary>
''' 提取方法名称
''' </summary>
''' <param name="serachTxt"></param>
''' <param name="curProjName"></param>
''' <returns></returns>
Public Function GetCurProjectSubNames(serachTxt As String, curProjName As String) As Dictionary
Dim rtnDicts As New Dictionary, dicts As New Dictionary
Dim VBComponent As Object, basModule As Object, curVBProject As Object, vbpro As Object, k As Long, i As Long
'获取当前项目
Set curVBProject = Application.VBE.ActiveVBProject
If Not (curVBProject Is Nothing) Then
For Each VBComponent In curVBProject.VBComponents
If VBComponent.Type = 2 Or VBComponent.Type = 100 Then
If VBComponent.CodeModule.Name = "ThisDrawing" Or VBComponent.CodeModule.Name = "ThisWorkBook" Then
Set basModule = VBComponent.CodeModule
End If
ElseIf VBComponent.Type = 1 Then
Set basModule = VBComponent.CodeModule
End If
If Not (basModule Is Nothing) Then
For i = 1 To basModule.CountOfLines
If basModule.ProcOfLine(i, vbext_pk_Proc) <> "" Then
Dim clsName As String, methodName As String
clsName = basModule.Name
methodName = basModule.ProcOfLine(i, vbext_pk_Proc)
If Not dicts.Exists(clsName & "." & methodName) And methodName Like serachTxt & "*" Then
rtnDicts(VBA.Replace(methodName, serachTxt, vbNullString)) _
= Chr(3) & Chr(3) & Chr(95) & "-vbarun " & """" & clsName & "." & methodName & """" & Chr(32)
dicts.Add clsName & "." & methodName, ""
End If
End If
Next i
End If
Next
End If
Set curVBProject = Nothing
Set dicts = Nothing
Set GetCurProjectSubNames = rtnDicts
End Function创建菜单函数
'@动态加载菜单栏
Public Sub AddMenuBarAndToolBar(ByRef cmds As Dictionary, MenuBarName As String, Optional LoadMenubar As Boolean = True, Optional LoadToolbar As Boolean = False)
On Error Resume Next
Dim mg As AcadMenuGroup, mcount As Integer, popMenu As AcadPopupMenu, index As Long
Dim varKey As Variant, i As Long
mcount = Application.MenuGroups.Count
For index = 0 To mcount - 1
If Application.MenuGroups.Item(index).Name = "ACAD" Then Set mg = Application.MenuGroups.Item(index): Exit For
Next
'创建弹出菜单
For index = mg.Menus.Count - 1 To 0 Step -1
If mg.Menus.Item(index).Name = MenuBarName Then
Set popMenu = mg.Menus.Item(index)
Exit For
End If
Next
If Not (popMenu Is Nothing) Then
'mg.Menus.RemoveMenuFromMenuBar MenuBarName
For i = popMenu.Count - 1 To 0 Step -1
popMenu(i).Delete
Next
'插入命令
For Each varKey In cmds.Keys()
popMenu.AddMenuItem popMenu.Count + 1, varKey, cmds(varKey)
Next
If Not popMenu.OnMenuBar Then popMenu.InsertInMenuBar (MenuBarName)
End If
'
If popMenu Is Nothing Then
Set popMenu = mg.Menus.Add(MenuBarName)
'提取全部的自定义命令
For Each varKey In cmds.Keys()
popMenu.AddMenuItem popMenu.Count + 1, varKey, cmds(varKey)
Next
popMenu.InsertInMenuBar (mg.Menus.Count + 1)
End If
'创建工具条
Dim tb As AcadToolbar
For index = mg.Toolbars.Count - 1 To 0 Step -1
If mg.Toolbars.Item(index).Name = MenuBarName Then
Set tb = mg.Toolbars.Item(index)
Exit For
End If
Next
If Not (tb Is Nothing) Then
'mg.Menus.RemoveMenuFromMenuBar MenuBarName
For i = tb.Count - 1 To 0 Step -1
tb(i).Delete
Next
'插入命令
For Each varKey In cmds.Keys()
tb.AddToolbarButton tb.Count + 1, varKey, varKey, cmds(varKey)
Next
If Not tb.Visible = False Then tb.Visible = True
tb.Dock acToolbarDockRight
End If
'
If tb Is Nothing Then
Set tb = mg.Toolbars.Add(MenuBarName)
'提取全部的自定义命令
For Each varKey In cmds.Keys()
tb.AddToolbarButton tb.Count + 1, varKey, varKey, cmds(varKey)
Next
tb.Visible = True
tb.Dock acToolbarDockRight
End If
End Sub将dvb的内部的代码保存问文本文件，截图如下
''' <summary>
'''
''' </summary>
''' <param name="app">excel 或者 autocad的application对象</param>
''' <param name="vbafilefn">vba文件名称</param>
''' <param name="codeSavefdName">代码保存的文件夹</param>
Public Sub Mycmd_导出代码到文件()
Dim VBComponent As Object, Count As Integer, dir As String, extension As String, curVBProject As Object, fso As New FileSystemObject, vbCompo As Object
Set curVBProject = Application.VBE.ActiveVBProject
dir = VBA.Replace(curVBProject.FileName, ".dvb", vbNullString) & "-代码备份文件\"
If Not fso.FolderExists(dir) Then fso.CreateFolder dir
For Each vbCompo In curVBProject.VBComponents
Select Case vbCompo.Type
Case 2, 100
extension = ".cls"
Case 3
extension = ".frm"
Case 1
extension = ".bas"
Case Else
extension = ".txt"
End Select
On Error Resume Next
Err.Clear
Dim dirCode As String
dirCode = dir & "\" & vbCompo.Name & extension
Call vbCompo.Export(dirCode)
If Err.number <> 0 Then
Call MsgBox("Failed to export " & vbCompo.Name & " to " & dirCode, vbCritical)
Else
Count = Count + 1
'Debug.Print "Exported " & Left$(VBComponent.Name & ":" & Space(Padding), Padding) & path
End If
Next
Set curVBProject = Nothing
End Sub最后定义用于存储命令的自定义类型
Public Type VbaCmd
Name As String
Macro As String
End Type在模块的通用里面加入参数
Const vbext_pk_Get = 3
Const vbext_pk_Let = 1
Const vbext_pk_Proc = 0
Const vbext_pk_Set = 2
最终效果如图
=================
2022-05-15更新
部分网友觉得部署比较麻烦还得开cad软件
今天就利用vbs部署,新建一个文本文件，复制下面的代码到文本，另存为vbs格式，记得保存为ANSI编码格式，
将vbs文件复制到dvb文件所在的目录，双击vbs文件即完成部署工作
Dim curDvbFileName, fso, scrFn, curDirName,acApp,acadPath,curDir,wsh,curAcadVer
Set wsh = WScript.CreateObject("WScript.Shell")''IWshRuntimeLibrary;C:\Windows\SysWOW64\wshom.ocx
Set fso=WScript.CreateObject("Scripting.FileSystemObject")
'提取cad的安装路径
curAcadVer= Replace(wsh.RegRead("HKEY_CURRENT_USER\SOFTWARE\Autodesk\AutoCAD\CurVer"),"R",vbNullString)'读取cad最后启动的版本
Set acApp=WScript.CreateObject("AutoCAD.Application."& CInt(curAcadVer))
acadPath=acApp.Path
acApp.Quit'关闭cad软件
Set acApp=Nothing
'获取当前vbs所在的文件夹名称
curDirName=fso.GetFile(WScript.ScriptFullName).ParentFolder.Path
'MsgBox curDirName
Set curDir=fso.GetFolder(curDirName)
Dim fl
For Each fl In curDir.Files
'MsgBox fl.Name & "," & fl.Path
If StrComp(fso.GetExtensionName(fl.Path),"dvb",1)=0 Then
curDvbFileName=fl.path
Exit For
End If
Next
'提取dvb文件
If curDvbFileName<>vbNullString Then
'MsgBox curDvbFileName & acadpath
'创建scr文件
scrFn = Replace(curdvbfilename, ".dvb", ".scr")
dvbName = Replace(fso.GetFileName(curdvbfilename), ".dvb", vbNullString)
With fso.CreateTextFile(scrFn,True,False)
.WriteLine "filedia 0"
.WriteLine "cmdecho 0"
.WriteLine "_vbarun " & Chr(34) & Replace(curdvbfilename, "\", "/") & "!ThisDrawing.AddBar" & Chr(34) 'addbar表示需要随cad启动而执行的过程
.WriteLine "filedia 1"
.Close
End With
'创建桌面快捷方式
Dim lnkFilePath , shortCut
lnkFilePath = wsh.SpecialFolders("Desktop") & "\" & Replace(fso.GetFileName(curdvbfilename), ".dvb", "(" & fso.GetFolder(acadPath).Name & ").lnk") '创建快捷方式到桌面
With wsh.CreateShortcut(lnkFilePath)
.TargetPath = Chr(34) & acadPath &"\acad.exe" & Chr(34)
.Arguments = "/nologo /b " & Chr(34) & scrFn & Chr(34)
.WorkingDirectory = fso.GetParentFolderName(scrFn)
.WindowStyle = 1 '//设置运行方式，默认为常规窗口 '// '设置备注
.Save
End With
wsh.Run "explorer.exe /select," & lnkFilePath,1
MsgBox "安装成功！",vbInformation+vbOKOnly
Else
MsgBox "安装失败!找不到dvb文件", vbAbort+ vbOKOnly
End If
Set fso= Nothing：Set wsh = Nothing
