[日积月累]：注册VBA宏为命令

雪山飞狐(lzh)

[php](defun RegVBAMacro(filename macrolist lsp_h lsp_f)
(mapcar '(lambda (macroname)
(eval
  (list 'defun
   (read (strcat "c:" macroname))
   '(/ ss)
   '(setq ss (cadr (ssgetfirst)))
   '(setvar "cmdecho" 0)
   '(command "undo" "be")
   lsp_h
   '(sssetfirst nil ss)
   (list 'vla-RunMacro
         '(vlax-get-acad-object)
          (strcat filename ".dvb!" macroname)
   )
   lsp_f
   '(command "undo" "e")
   '(setvar "cmdecho" 1)
   '(princ)
  )))
macrolist
)
(princ)
)
[/php]
调用格式：
(REGVBAMACRO 文件名 宏名列表 Lisp前缀 Lisp后缀)

例：

(REGVBAMACRO "tlscad" '("t3") nil nil)

说明：

修改自mccad的程序，不过已经脸面全非了：）

支持程序加Lisp前缀和后缀，一般来说是把命令的调用放在前缀或后缀里的

例：

(REGVBAMACRO "tlscad" '("TextExplodeH" "TextExplodeV") nil '(command "explode" "l"))

会在调用TextExplodeH及TextExplodeV宏后运行explode命令

gjliang

已经测试过，很好! 在2006以下和mccad的没感觉出来差别，但在2007里感觉还是楼主的好用，在2007里mccad的程序调用宏的时候会出现
Command: k
_.-VBARUN
Macro name: test.dvb!k
昨天刚下载了个2007,把自己以前写的小程序移植上去,vba的程序没问题，但是lisp的程序有些无法正常使用了!

雪山飞狐(lzh)

修改了一下，支持将当前选择集选定(欢迎测试)
http://www5.139.com/xsfhlzh/1025501/article/349617.html

gjliang

楼主您好，想请教个问题,下面的lisp程序是转自晓东工具箱的,主要控制屏幕菜单的开关，调整大小等.
我在2006以下版本测试使用并没有问题，但是在2007下使用的时候确无法运行,如果楼主装了2007,希望测试下，谢谢了!
(defun C:SCRMUN_REDRAW (/ ORG_POSITION_LST SCREEN CU_PROFILES)
  (if ;;(and (> (atof (getvar "acadver")) 15.0)
      (= (getenv "ScreenMenu") "1")
    ;;)
    (progn
      (setq SCREEN '(1024 768))  ;请查看看自己屏幕分辨率
      (setq ORG_POSITION_LST
      (strcat (rtos (- (car SCREEN) 86) 2 0)  ;参数屏幕菜单宽度
       " 95 "                          ;参数屏幕菜单长度
       (rtos (- (car SCREEN) 12) 2 0)  ;参数屏幕菜单宽度
       " "
       (rtos (- (last SCREEN) 120) 2 0);参数屏幕菜单长度
      )
      )
      (setq CU_PROFILES
      (strcat "HKEY_CURRENT_USER\\"
       (vlax-product-key)
       "\\PROFILES\\"
       (vla-get-activeprofile
         (vla-get-profiles
    (vla-get-preferences (vlax-get-acad-object))
         )
       )
       "\\DRAWING WINDOW\\"
      )
      )
      (setenv "ScreenMenu" "0")
      (if (vl-registry-read CU_PROFILES "SCREENMENU.POSITION")
(progn
   (vl-registry-write
     CU_PROFILES
     "ScreenMenu.Position"
     ORG_POSITION_LST
   )
   (vl-registry-write CU_PROFILES "ScreenMenu.Style" 4)
)
      )
      (setenv "ScreenMenu" "1")
    )
  )
  (princ)
)


(C:SCRMUN_REDRAW)


;;The following code "xscrmnud" written by LK
;;屏幕菜单开关控制For 2000+
(defun c:xscrmnud(/ AcadObject Preference Display bShowScreenMenu)
  (vl-load-com)
  (setq        AcadObject        (vlax-get-acad-object)
        Preference        (vla-get-Preferences AcadObject)
        Display                (vla-get-Display Preference)
        bShowScreenMenu        (vla-get-DisplayScreenMenu Display)
  )
  (if (= bShowScreenMenu :VLAX-TRUE)
    (vla-put-DisplayScreenMenu Display :VLAX-FALSE)
    (vla-put-DisplayScreenMenu Display :VLAX-TRUE)
  )
  (mapcar 'vlax-release-object
          (list Display Preference AcadObject)
  )
  (princ)
)
(if (> (atof (getvar "acadver")) 15.0)
  (progn
    (vl-load-com)
    (vl-bb-set '#mnu_display (getvar "screenboxes"))
  )
)
;;
;;屏幕菜单开关与切换控制For 2000+，R14中需手动打开屏幕菜单 written by eachy
;;
(defun c:xscrmnu (/ scr #scr_display #acadver)
  ;;保存屏幕菜单初始状态，0　菜单关闭
  (setq        #scr_display (getvar "screenboxes")
        #acadver     (atof (getvar "acadver"))
  )
  (if (and (< #acadver 15.0)
           (= #scr_display 0)
      )
    (progn
      (princ "\n\t您使用的版本为R14，请先手动加载屏幕菜单!!!")
      (exit)
    )
  )
  (if #xdscrmnu
    (progn
      (if (and (> #acadver 15.0)
               (if (> #acadver 15.0)
                 (= (vl-bb-ref '#mnu_display) 0)
               )
          )
        (c:xscrmnud)
        (progn
          (setq scr (last (getvar "menuname") "\\"))
          (menucmd (strcat "s=" scr ".screen"))
        )
      )
      (setq #xdscrmnu nil)
    )
    (progn
      (if (> #acadver 15.0)
        (progn
          (setvar "menuctl" 0)
          (cond
            ((= (getvar "screenboxes") 0)
             (c:xscrmnud)
            )
            ((= (vl-bb-ref '#mnu_display) 0)
             (c:xscrmnud)
            )
            (T)
          )
        )
      )
      (menucmd "s=test.screen")
      (setq #xdscrmnu T)
    )
  )
  (princ)
)

(c:xscrmnu)

;;屏幕菜单开关与切换控制，R14中需手动调整绘图窗口
;;written by eachy 2004.4.13
(defun c:XDTB_Scrmnu ()
  (setvar "menuctl" 0)
  (if #xdscrmnu
    (progn
      (menucmd "s=")
      (setq #xdscrmnu nil)
    )
    (progn
      (if (= (getenv "ScreenMenu") "0")
        (setenv "ScreenMenu" "1")
      )
      ;(menucmd "s=test.xcla_")
      (menucmd "s=test.screen")
      (setq #xdscrmnu T)
    )
  )
  (princ)
)

雪山飞狐(lzh)

2007还没装，机器太慢了，汗
你在Lisp版问问吧