[求助]：VBA工程加载

wtkc

cad中用vba编制工程,加载命令很不方便,vba无法注册系统命令,我一般编制一个lsp文件,通过该文件定义命令,如
(defun C:ETDAD ()
        (command "_-vbarun" "dimArrowDot")
)
但当vba代码很多时,分别从属于多个dvb文件,我想在函数中添加代码首先判断该dvb是否加载,没有加载则加载,然后执行该dvb中的相关宏,以实现动态加载,请帮帮我?vba我懂,但lsp则只知皮毛!!

雪山飞狐(lzh)

直接给全路径即可，如：
(command "_-vbarun" "c:\Test.dvb!dimArrowDot")

wtkc

谢谢,我已经直接通过vba工程解决了,代代码如下:可直接通过菜单加载.
由此可实现多模块动态加载,卸载,并可动态构造菜单
Public Function GetVBAProjFileNames(Optional projName As String = "")
    Dim i As Long, projects() As String
    Dim objIDE As VBIDE.VBE
    Set objIDE = Application.VBE
    ReDim projects(0 To objIDE.VBProjects.Count - 1)
    For i = 0 To objIDE.VBProjects.Count - 1
        projects(i) = objIDE.VBProjects(i + 1).fileName
    Next
    If projName = "" Then
        '未指定则返回全部
        GetVBAProjFileNames = projects
        Exit Function
    Else
        '返回特定
        Dim length As Long
        If Right(projName, 4) <> ".dvb" Then projName = projName & ".DVB"
        length = Len(projName)
        For i = 0 To objIDE.VBProjects.Count - 1
            If Right(projects(i), length) = projName Then
                GetVBAProjFileNames = projects(i)
                Exit Function
            End If
        Next
        '未找到特定,则返回空
        GetVBAProjFileNames = ""
    End If
End Function
Sub AddmainMenu()
    Dim MenuGroup As AcadMenuGroup
    Dim etMainMenu As AcadPopupMenu
    Dim menuItem
    Set MenuGroup = Application.MenuGroups("ACAD")
    On Error Resume Next
    Set etMainMenu = MenuGroup.Menus(APPName)
    If err.Number = 0 Then
        On Error GoTo 0
        For Each menuItem In etMainMenu
            menuItem.Delete
        Next
    Else
        On Error GoTo 0
        Set etMainMenu = MenuGroup.Menus.Add(APPName)
    End If
    etMainMenu.AddMenuItem 1, "xxxxxxxxxxxx", "-vbarun DoUtility acadet FixLayOutScale" & vbCr
     If Not etMainMenu.OnMenuBar Then etMainMenu.InsertInMenuBar Application.MenuBar.Count - 1
End Sub

'主执行模块
Public Sub DoUtility()
    Dim strModul As String, strVbaSub As String
    strModul = ThisDrawing.Utility.GetString(False)
    strVbaSub = ThisDrawing.Utility.GetString(False)
    If GetVBAProjFileNames(strModul) = "" Then
        '判断模块是否存在,不存在则加载
        Application.LoadDVB GetETToolsPath & strModul & ".dvb"
    End If
    ThisDrawing.SendCommand "-VBARUN" & " " & strVbaSub & vbCrLf
End Sub

Function GetETToolsPath() As String
    Static etToolsPath As String
    If etToolsPath = "" Then
        etToolsPath = GetVBAProjFileNames("ACADET.DVB")
        etToolsPath = Left(etToolsPath, Len(etToolsPath) - 10)
    End If
    GetETToolsPath = etToolsPath
End Function

efan2000

构思不错，借助于VBE，可以定制和扩充VBA的功能。