[求助]动态右键菜单,在CAD2004下可以用,但2006下不行

baolanjun

引用http://hi.baidu.com/xshrimp/blog/item/f6f2b2512394751d377abe19.html

帮忙指点一下,谢谢

;by  xshrimp 2007.1.5;(setq str (gps->popupmenu '("Line" "" "Circle" "Arc")))(DEFUN
  gps->popupmenu  (MENULST  /  acadobj  currmenugroup  flag  fn  menus  n  newmenu  newmenuitem
  openmacro  str  thisdoc  )
  (SETVAR  "cmdecho"  0)
  (SETQ  FLAG  nil)
  (SETQ  FN  (OPEN  "VbaMenu.mns"  "w"))
  (CLOSE  FN)
  (SETQ  ACADOBJ  (vlax-get-acad-object))
  (SETQ  THISDOC  (vla-get-ActiveDocument  ACADOBJ))
  (SETQ  MENUS  (vla-get-MenuGroups  ACADOBJ));  (VLAX-FOR N MENUS (IF (= (vla-get-Name N) "VbaMenu");        (SETQ FLAG T);      ) (TERPRI);  );  (IF FLAG;    (UnLoadMenuGroup "VbaMenu");  )
  (UnLoadMenuGroup  "VbaMenu")
  (vla-Load  MENUS  "VbaMenu.mns")
  (SETQ  CURRMENUGROUP  (vla-Item  MENUS  "VbaMenu"))
  (IF  (<=  (vla-get-Count  (vla-get-Menus  CURRMENUGROUP))  0)
    (PROGN      (SETQ  NEWMENU  (vla-Add  (vla-get-Menus  CURRMENUGROUP)
  "V&BA Menu"))
      (FOREACH  N  MENULST
		(IF  (=  (TYPE  N) (QUOTE  STR))   (COND     ((/=
  N
  "")
       (SETQ
  OPENMACRO
  (STRCAT
  (CHR
  3)
  (CHR
  3)
  "(setq xxx "
  N
  ")"
          (CHR
  32)
         )
      NEWMENUITEM
  (vla-AddMenuItem
  NEWMENU
  (1+
            (vla-get-Count
  NEWMENU)
        )
  N
  OPENMACRO
    )
       )
       (vla-put-HelpString
  NEWMENUITEM
  N)
     )
     ((=
  N
  "")
       (vla-AddSeparator
  NEWMENU
  (1+
  (vla-get-Count
  NEWMENU)))
     )
   )

		)
      )
      (vla-Save
  CURRMENUGROUP
  acMenuFileCompiled)
    )
    (PRINC
  "\nThe menu is already loaded")
  )  
  (PRIN1)  
  (MENUCMD
  "p0=VbaMenu.POP2")
  (MENUCMD
  "p0=*")   
)(defun
  UnLoadMenuGroup
  (iValue
  /
  rValue)
  (if
  (menugroup
  iValue)  
   (progn
     (if
  (not
  (vl-catch-all-error-p
    (setq
  rValue
      (vl-catch-all-apply
      'vla-unload
      (list
        (vla-item
  (vla-get-menugroups(vlax-get-acad-object))
  iValue)
      )
      )
    )
  )
  )
  (setq
  rValue
  T)
  )rValue
   )
  )
  

)