AutoCAD VBA部署方案分享
作者：互联网
通过创建快捷方式用于加载dvb，写入菜单
1’通过代码编写scr文件和创建dvb工程加载快捷方式
"C:\Program Files (x86)\AutoCAD 2008\acad.exe" /nologo /b "D:\VBProject\算法研究.scr"
/nologo 表示启动跳过界面加快cad的启动速度
/b 表示需要启动cad的时候，加载二进制程序
具体参考官方说明
2.scr文件的内部如下
创建快捷方式
Public Sub 创建DVB加载快捷方式()
Dim mycmds As Variant, menuName As String, curDvbName As String, fso As New FileSystemObject, scrFn As String
curDvbName = Application.VBE.ActiveVBProject.FileName
'创建scr文件
scrFn = VBA.Replace(curDvbName, ".dvb", ".scr")
'filedia 0
'cmdecho 0
'(vl-vbaload "D:/VBProject/算法研究.dvb")
'(vl-vbarun "AddBar")
'filedia 1
Open scrFn For Output As #1 '如改为For Append，则为追加文件。
Print #1, "filedia 0"
Print #1, "cmdecho 0"
Print #1, "(vl-vbaload " & Chr(34) & VBA.Replace(curDvbName, "\", "/") & Chr(34) & ")"
Print #1, "(vl-vbarun " & Chr(34) & "AddBar" & Chr(34) & ")" 'add bar表示需要随cad启动而执行的过程
Print #1, "filedia 1"
Print #1, vbNullString
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", ".lnk") '创建快捷方式到桌面
'var startMenuDir = $@"C:\ProgramData\Microsoft\Windows\Start Menu\Programs";
'lnkFilePath = "C:\ProgramData\Microsoft\Windows\Start Menu\Programs\" & VBA.Replace(dir(curDvbName), ".dvb", ".lnk") '创建快捷方式到开始菜单
'lnkFilePath = VBA.Replace(scrFn, ".scr", ".lnk")
'"C:\Program Files (x86)\AutoCAD 2008\acad.exe" /nologo /b "C:\Users\NanSheng\AppData\Local\Temp\算法研究.scr"
Set shortCut = wsh.CreateShortcut(lnkFilePath)
shortCut.TargetPath = Chr(34) & Application.FullName & Chr(34)
shortCut.Arguments = "/nologo /b " & Chr(34) & scrFn & Chr(34)
shortCut.WorkingDirectory = fso.GetParentFolderName(scrFn)
shortCut.WindowStyle = 1 '//设置运行方式，默认为常规窗口 '// '设置备注
'//shortcut.IconLocation = String.IsNullOrWhiteSpace(iconLocation) ? targetPath : iconLocation;//设置图标路径
shortCut.Save
Set wsh = Nothing
End Sub创建菜单的主过程，这个也是在scr中需要与cad启动同时执行的过程
此处开发者需要根据需要自己设定需要加载到菜单的方法的规则
Public Sub AddBar()
Dim mycmds As Variant, 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)
mycmds = GetCurProjectSubNames("Mycmd_", menuName)
Call AddMenuBarFunction(mycmds, menuName)
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 MyVbaCmd()
Dim CMDS() As MyVbaCmd, res As New Dictionary
Dim VBComponent As Object, basModule As CodeModule, curVBProject As VBProject, 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_ProcKind.vbext_pk_Proc) <> "" Then
Dim clsName As String, methodName As String
clsName = basModule.Name
methodName = basModule.ProcOfLine(i, vbext_ProcKind.vbext_pk_Proc)
If Not res.Exists(clsName & "." & methodName) And methodName Like serachTxt & "*" Then
ReDim Preserve CMDS(0 To k)
Dim cmd As New MyVbaCmd
With cmd
.Name = VBA.Replace(methodName, serachTxt, vbNullString)
.Macro = Chr(3) & Chr(3) & Chr(95) & "-vbarun " & """" & clsName & "." & methodName & """" & Chr(32)
End With
Set CMDS(k) = cmd
res.Add clsName & "." & methodName, ""
k = k + 1
Set cmd = Nothing
End If
End If
Next i
End If
Next
End If
GetCurProjectSubNames = CMDS
End Function创建菜单函数
Public Function AddMenuBarFunction(ByRef CMDS As Variant, MenuBarName As String)
On Error Resume Next
'If ThisDrawing.GetVariable("MenuBar") = 0 Then ThisDrawing.SetVariable "MenuBar", 1
Dim mg As AcadMenuGroup, mcount As Integer, popMenu As AcadPopupMenu, index 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
Dim i As Long
For i = popMenu.Count - 1 To 0 Step -1
popMenu(i).Delete
Next
For index = LBound(CMDS) To UBound(CMDS)
popMenu.AddMenuItem popMenu.Count + 1, CMDS(index).Name, CMDS(index).Macro
Next
If Not popMenu.OnMenuBar Then popMenu.InsertInMenuBar (MenuBarName)
End If
'
If popMenu Is Nothing Then
Set popMenu = mg.Menus.Add(MenuBarName)
'提取全部的自定义命令
For index = LBound(CMDS) To UBound(CMDS)
popMenu.AddMenuItem popMenu.Count + 1, CMDS(index).Name, CMDS(index).Macro
Next
popMenu.InsertInMenuBar (mg.Menus.Count + 1)
End If
End Function将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
Dim vbeobj As Object, vbCompo As Object
Set vbeobj = Application.VBE
Set curVBProject = vbeobj.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
End Sub最后类模块用于存储命令的信息
源代码下载
标签：index,VBA,Set,End,String,CMDS,popMenu,AutoCAD,分享 来源： https://www.cnblogs.com/NanShengBlogs/p/16212808.html