mouse-reactor.lsp

Autocad-2005-简体中文-解密版.zip

		  )
	(progn
	  (ac:addCustomPopupMenu)
	  (princ "\nCustom menu popup enabled!\n")
	  )
	)
  (princ)
  )
;;; --------------------------------------------------------------------------
;;; disables the custom popup menu
(defun c:mouse-popup-off	()
  (if *Custom-Popup*
	(progn 
	(mapcar 'vla-delete (ac:get-Menu-Items *Custom-Popup*))
	
  ;; always return the pop0 to the acad system.
  (menucmd "p0=acad.pop0")
  (princ
	(strcat
	  "\nAll menu items have been removed from: \n; menugroup = "
	  (vla-get-name (vla-get-parent (vla-get-parent *Custom-Popup*)))
	  "\n; Name = "
	  (vla-get-name *Custom-Popup*)
	  "\n"
	  )
	)
	))
  (princ)
  )
;;; --------------------------------------------------------------------------
;;; returns a list of menuObjects currently loaded in acad.
;;; presently not used.
(defun ac:Menus	(/ acad menuGroups dl)
  (setq	acad			 (vlax-get-acad-object)
		*acadmenuGroups* (vla-get-MenuGroups acad)
		)
  (vlax-for Item *acadmenuGroups* (setq dl (cons item dl)))
  (reverse dl)
  )

;;; --------------------------------------------------------------------------
;;; returns a menuObject. The parameter must be a valid menugroup
(defun ac:ReturnMenuObject (MenuName / dl)
  (if (menugroup MenuName)
	(progn
	  (vlax-for	Item (vla-get-MenuGroups (vlax-get-acad-object))
		(setq dl (cons (list (strcase (vla-get-name item)) item) dl))
		)
	  (cadr (assoc (strcase MenuName) dl))
	  )
	)
  )
;;; --------------------------------------------------------------------------
;;; Predicate for a string
;;; Returns T if successfull nil otherwise.
(defun vlaxx-string-p (arg)
  (and (equal (type arg) 'str))
  )
;;; --------------------------------------------------------------------------
;;; Predicate for an integer 
;;; Returns T if successfull nil otherwise.
(defun vlaxx-integer-p (arg)
  (and (equal (type arg) 'int))
  )
;;; --------------------------------------------------------------------------
;;; Predicate for a real number
;;; Returns T if successfull nil otherwise.
(defun vlaxx-real-p	(arg)
  (and (equal (type arg) 'real))
  )
;;; --------------------------------------------------------------------------
;;; adds a menu item to a popupobject.
;;; This function is identical to vla-AddMenuItem except that
;;; error checking is performed. Returns the menuitem
;;; object if successful. If an error is encountered an error
;;; message is printed and the function returns nil.
(defun ac:Add-Menu-Item	(ParentMenuObject Index Label Macro / res)
  (print (list ParentMenuObject Index Label Macro))
  (if (and (vlaxx-string-p Label)
		   (or (vlaxx-integer-p Index)
			   (vlaxx-string-p Index)
			   (equal (vlax-variant-type Index) 2)
										; is it a variant integer?
			   (equal (vlax-variant-type Index) 8)
										; is it a variant String?
			   )
		    (vlaxx-string-p Macro)
		   )
	;; now check for pop menu Object
	(if
	  (and (equal (type ParentMenuObject) 'vla-object)
		   ;; Check if its a IAcadPopupMenu:
		   (vlax-property-available-p ParentMenuObject "ShortcutMenu")
		   )
	   (progn

		 (setq res (vla-AddMenuItem ParentMenuObject Index Label Macro))

		 )
	   (princ
		 "\nError: ParentMenuObject is not a valid pop up menu object"
		 )
	   )
	(princ "\nError: Index, Label or Macro are not correct")
	)
  res
  )
;;; --------------------------------------------------------------------------
;; Dumps a menuitem
;; use ac:get-Menu-Items to retrieve individual menu items. such as:
;;;	_$ (mapcar 'ac:dump-MenuItem (ac:get-Menu-Items *Custom-Popup*))
;;;
;;;	; APPLICATION = #<VLA-OBJECT IAcadApplication 00d935f0>
;;;	; CAPTION = "&Line"
;;;	; CHECK = :vlax-false
;;;	; ENABLE = :vlax-true
;;;	; HELPSTRING = ""
;;;	; INDEX = 0
;;;	; LABEL = "&Line"
;;;	; MACRO = "\003\003_Line\n"
;;;	; PARENT = #<VLA-OBJECT IAcadPopupMenu 014d4648>
;;;	; TAGSTRING = "ID_Line"
;;;	; TYPE = 0
;;; ...
;;;	(T T T T T)
;;;	_$ 
;;; Prints an object dump of a menuitem. Always returns T
;;; Similar to vlax-dump-Object but without the error
;;; encountered by querying the Submenu property if the object
;;; does not have a submenu.
(defun ac:dump-MenuItem	(item)
  (princ
	(apply 'strcat
		   (mapcar
			 (function
			   (lambda (x)
				 (strcat
				   "\n; "
				   (vl-princ-to-string x)
				   " = "
				   (vl-prin1-to-string
					 (eval
					   (list (read
							   (strcat "vla-get-" (vl-princ-to-string x))
							   )
							 item
							 )
					   )
					 )
				   )
				 )
			   )

			 '(Application			 Caption	Check	   Enable
			   HelpString Index		 Label		Macro	   Parent
										; Submenu ; this causes an error if the item is not a submenu
			   Tagstring  Type
			   )
			 )
		   )
	)
  (terpri)
  T
  )
;;; --------------------------------------------------------------------------
;;; searches for a popup label in a popupmenu object
;;; returns the popupmenu object is it exists.
(defun ac:MenuPopExist (MenuGroupObject popupLabel / dl)
  (vlax-for	item MenuGroupObject
	(setq dl (cons
			   (list (strcase (vla-get-NameNoMnemonic item))
					  item ) dl))
	)
   (cadr (assoc (strcase popuplabel)  dl))
  )
;;; --------------------------------------------------------------------------
;;; searches for an id string label in a popupmenuitem object
;;; returns the popupmenu object is it exists.
(defun ac:MenuItemLabelExist (MenuPopupObject itemLabel / dl)
  (vlax-for	item   MenuPopupObject 
	(setq dl (cons
			   (list (strcase (vla-get-TagString item))
					  item ) dl))
	)
   (cadr (assoc (strcase itemLabel)  dl))
  )
;;; --------------------------------------------------------------------------
;;; returns a list of all menuitem objects contained within a popupmenu object
(defun ac:get-Menu-Items (popup / dl)
  (if popup
	(progn
	  (vlax-for	MenuItem POpup
		(setq dl (cons MenuItem dl))
		)
	  (reverse dl)
	  )
	)
  )
;;; --------------------------------------------------------------------------
;;; Adds a specific custom popup menu
;;; to AutoCAD. Returns the newly created popupmenu Object.
(defun ac:addCustomPopupMenu ()
  (if (or (null *Custom-Popup*)
		  (null (ac:get-Menu-Items *Custom-Popup*))
		  )
	(progn
	  (setq	acadMenuObject	   (ac:ReturnMenuObject *MenuGroupname*)

			acadPopupMenuGroup (vla-get-Menus acadMenuObject)
			)
	  (if
		(not (ac:MenuPopExist acadPopupMenuGroup "Custom-Menu"))
		 (setq *Custom-Popup*
				(vla-add acadPopupMenuGroup "Custom-Menu")
			   )
		 )
	  )
	)
  (setq
	item0		 (ac:Add-Menu-Item *Custom-Popup* 0 "&Enter" "\n")
	item1		 (vla-AddSeparator *Custom-Popup* 1)
	item2		 (ac:Add-Menu-Item *Custom-Popup* 2 "&Move" "_Move ")
	item3		 (ac:Add-Menu-Item *Custom-Popup* 3 "&Erase" "_Erase ")
	item4		 (ac:Add-Menu-Item *Custom-Popup* 4 "&Cop&y" "_Copy ")
	;; add a separator 
	item5		 (vla-AddSeparator *Custom-Popup* 5)
	;; add a submenu
	*ColorSubMenu* (vla-AddSubMenu
				   *Custom-Popup*
				   8
				   "C&hange Color"
				   )
	*BylayerMenuItem*  (ac:Add-Menu-Item
				   *ColorSubMenu*
				   0
				   "&Bylayer"
				   "(ac:Change-Color 256) "
				   )
	*RedMenuItem*		 (ac:Add-Menu-Item
				   *ColorSubMenu*
				   1
				   "&Red"
				   "(ac:Change-Color 1) "
				   )
	*YellowMenuItem*		 (ac:Add-Menu-Item
				   *ColorSubMenu*
				   2
				   "&Yellow"
				   "(ac:Change-Color 2) "
				   )

	*GreenMenuItem*		 (ac:Add-Menu-Item
				   *ColorSubMenu*
				   3
				   "&Green"
				   "(ac:Change-Color 3) "
				   )
	*CyanMenuItem*		 (ac:Add-Menu-Item
				   *ColorSubMenu*
				   4
				   "&Cyan"
				   "(ac:Change-Color 4) "
				   )
	*BlueMenuItem*
				 (ac:Add-Menu-Item
				   *ColorSubMenu*
				   5
				   "&Blue"
				   "(ac:Change-Color 5) "
				   )
	*MagentaMenuItem*
				 (ac:Add-Menu-Item
				   *ColorSubMenu*
				   6
				   "&Magenta"
				   "(ac:Change-Color 6) "
				   )
	)

  (setq	*colors* (list (list 256 *BylayerMenuItem*)
					   (list 1 *RedMenuItem*)
					   (list 2 *YellowMenuItem*)
					   (list 3 *GreenMenuItem*)
					   (list 4 *CyanMenuItem*)
					   (list 5 *BlueMenuItem*)
					   (list 6 *MagentaMenuItem*)
					   )
		)
  
  *Custom-Popup*
  )


;;; --------------------------------------------------------------------------
;; Changes the color of the Object contained in the global variable
;; global variable *objectUnderCursor*. See function ac:beginRightClick
;; for its settings.
(defun ac:Change-Color ( whatColor )
	 (if *objectUnderCursor*
	     (vla-put-color *objectUnderCursor* whatColor)
	   )
  )

;;; --------------------------------------------------------------------------
;;; (vla-SaveAs acadMenuObject "c:/acad/mystuff.mns" acPartialMenuGroup)
;;; Once you save the menu look at ***CUSTOM-MENU

(defun ac:SavePOpup (Object Filename)
  (vla-SaveAs Object Filename acPartialMenuGroup))


(princ "Mouse Reactor Example Loaded!")
(princ)