其他分享
首页 > 其他分享> > AutoCAD VBA部署方案分享

AutoCAD VBA部署方案分享

作者:互联网

通过创建快捷方式用于加载dvb,写入菜单

1’通过代码编写scr文件和创建dvb工程加载快捷方式

"C:\Program Files (x86)\AutoCAD 2008\acad.exe" /nologo /b "D:\VBProject\算法研究.scr"

/nologo 表示启动跳过界面加快cad的启动速度

/b 表示需要启动cad的时候,加载二进制程序

具体参考官方说明

https://knowledge.autodesk.com/zh-hans/support/autocad/learn-explore/caas/CloudHelp/cloudhelp/2018/CHS/AutoCAD-Core/files/GUID-8E54B6EC-5B52-4F62-B7FC-0D4E1EDF093A-htm.html

 

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

最后类模块用于存储命令的信息

源代码下载

https://files.cnblogs.com/files/NanShengBlogs/%E7%AE%97%E6%B3%95%E7%A0%94%E7%A9%B6-%E4%BB%A3%E7%A0%81%E5%A4%87%E4%BB%BD%E6%96%87%E4%BB%B6.zip?t=1651386037

标签:index,VBA,Set,End,String,CMDS,popMenu,AutoCAD,分享
来源: https://www.cnblogs.com/NanShengBlogs/p/16212808.html