Hi, everybody!
Evgeniy Elpanov linked me to this interesting thread from my post
http://www.theswamp.org/index.php?topic=20737.0My post was about the problem of how identify which shortcutmenu is the active using autolisp,
as the number of its items are needed to define which GRREAD code 11 represents the 1st item
of POP1, and so, be able to extract information of any menu item in a GRREAD loop.
This comes because GRREAD code 11 is organized as follows:
1º Items that belong to the active shortcut menu
2º Items that belong to popmenus on menu bar
3º Items that belong to images menus (those slides we used a long time ago...)
4º Items that belong to toolbars
5º Rest of the stuff (p.e. workspaces, etc...)
Both in shortcutmenus and popmenus you must not count separators, head of submenus, items
without macro, and macros which include 'syswindows' commands; in toolbars you must count
separators as items; the way to get the Images menus is reading .mns files for v2005 an lower
versions, and via activex and XML for v.2006 and upper versions.
The only way I found to avoid the problem caused by the imposibility of identifying which is the active
shortcutmenu, is reload the menu(s) in order to fit POP 0 (known) as the active shortcutmenu again.
This solution is slow and noisy, as I can't avoid the echo of the menu load.
The target of this routine is only to show the contents of the menu item selected by clicking on it.
It only works on pop menu bar, toolbars and shift+mouserightclick shortcutmenu items.
I've tested it on v.2005 and works properly but, although it should work properly too on v.2006 and upper
versions, sometimes crashes on reloading menu after calling the routine from the shortcutmenu after using
it. Don't ask me why , maybe activex' fault. So, in this case, be careful as pop menu bar will spoil.I'm not as tidy as many people here, so the code is not quoted (remarked?), and I've translated messages
into my foreign English (oh, my God!
)
Enjoy it!
(Oops! I posted yesterday a wrong code, now it's the right one.)
(defun tsterr (s)
(if (= s "Function cancelled")
(princ "\n*Cancelled*")
(princ s)
)
(mapcar '(lambda (x) (if (numberp x) (princ) (vlax-release-object x))) ty)
(setq *error* oe)
(princ)
)
(defun okd_k (a / okd_lm)
(mapcar
'(lambda (x)
(cond ((= x 3) (setq okd_lm (append okd_lm (list 94 67))))
((= x 16) (setq okd_lm (append okd_lm (list 94 80))))
((= x 10) (setq okd_lm (append okd_lm (list 59))))
(T (setq okd_lm (append okd_lm (list x))))
)
)
a)
(vl-list->string okd_lm)
)
(defun lod_m (a / loc_ac loc_cn loc_lb loc_lg loc_lm loc_lp loc_mb loc_mg loc_nm loc_tt)
(setq loc_mg (vla-get-menugroups a)
loc_mb (vla-get-menubar a)
loc_cn 0
)
(vlax-for it loc_mg
(setq loc_lm (cons (vla-get-menus it) loc_lm)
loc_nm (cons (vla-get-menufilename it) loc_nm)
loc_tt (cons (abs (1- (vla-get-type it))) loc_tt))
)
(mapcar
'(lambda (x)
(vlax-for it x
(if (= :vlax-true (vla-get-onmenubar it))
(setq loc_lg (cons (vla-get-name it) loc_lg)
loc_lp (append (list (vl-position x loc_lm)) loc_lp))
)
)
)
loc_lm
)
(vlax-for it loc_mb
(setq loc_lb (cons (cons loc_cn (vla-get-name it)) loc_lb)
loc_cn (1+ loc_cn))
)
(vlax-release-object loc_mb)
(gc)
(setq loc_nm (reverse loc_nm) loc_tt (reverse loc_tt))
(vlax-map-collection loc_mg 'vla-unload)
(mapcar '(lambda (x y) (vla-load loc_mg x y)) loc_nm loc_tt)
(vlax-release-object loc_mg)
(gc)
(setq loc_mg (vla-get-menugroups a)
loc_mb (vla-get-menubar a))
(vlax-for it loc_mg (setq loc_lm (cons (vla-get-menus it) loc_lm)))
(mapcar
'(lambda (x / mx pm)
(setq pm (vla-item (setq mx (nth (nth (vl-position (cdr x) loc_lg) loc_lp) loc_lm)) (cdr x)))
(if (= :vlax-false (vla-get-onmenubar pm))
(vla-insertmenuinmenubar mx (cdr x) (car x))
)
)
loc_lb)
(list loc_mb loc_mg)
)
(defun prn_a (a b / nm pp pr ps)
(setq pr (vla-get-parent a)
nm (vla-get-name pr)
)
(if (= nm "")
(progn
(setq ps (vla-get-parent (vla-get-parent pr)))
(if (= :vlax-true (vla-get-shortcutmenu ps))
(setq pp
(strcat "SHORTCUT MENU:"
"\n->NAME:\t"
(vla-get-namenomnemonic ps)
"\n[-------]"
)
)
(setq pp
(strcat "POP MENU ON BAR:"
"\n->NAME:\t"
(vla-get-namenomnemonic ps)
"\n[-------]"
)
)
)
(setq pp
(strcat pp
"\nSUBMENU:"
"\n->NAME:\t"
(vl-list->string
(vl-remove 38
(vl-string->list
(vla-get-caption
(vla-get-parent pr)
)
)
)
)
"\n[-------]\nPOP MENU ITEM:\nGRREAD Nº:\t"
(itoa b)
"\n->CAPTION:\t"
(vl-list->string
(vl-remove 38
(vl-string->list
(vla-get-caption a)
)
)
)
"\n->HELPSTRING:\t"
(vla-get-helpstring a)
"\n->MACRO:\t"
(okd_k (vl-string->list (vla-get-macro a)))
"\n->TAGSTRING:\t"
(vla-get-tagstring a)
)
)
)
(progn
(if (= :vlax-true (vla-get-shortcutmenu pr))
(setq pp
(strcat "SHORTCUT MENU:"
"\n->NAME:\t"
(vla-get-namenomnemonic pr)
"\n[-------]"
)
)
(setq pp
(strcat "POP MENU ON BAR:"
"\n->NAME:\t"
(vla-get-namenomnemonic pr)
"\n[-------]"
)
)
)
(setq pp
(strcat pp
"\nPOP MENU ITEM:\nGRREAD Nº:\t"
(itoa b)
"\n->CAPTION:\t"
(vl-list->string
(vl-remove 38
(vl-string->list
(vla-get-caption a)
)
)
)
"\n->HELPSTRING:\t"
(vla-get-helpstring a)
"\n->MACRO:\t"
(okd_k (vl-string->list (vla-get-macro a)))
"\n->TAGSTRING:\t"
(vla-get-tagstring a)
)
)
)
)
(alert pp)
)
(defun prn_b (a b / nm pp pr)
(setq pr (vla-get-parent a)
nm (vla-get-name pr)
pp (strcat "TOOL BAR:"
"\n->NAM:\t"
nm
"\n[-------]"
"\nTOOL BAR ITEM:\nGRREAD Nº:\t"
(itoa b)
"\n->NAME:\t\t"
(vla-get-name a)
"\n->HELPSTRING:\t"
(vla-get-helpstring a)
"\n->MACRO:\t"
(okd_k (vl-string->list (vla-get-macro a)))
"\n->TAGSTRING:\t"
(vla-get-tagstring a)
)
)
(alert pp)
)
(defun fna_j (a / ax cn ll)
(setq ax (vlax-invoke-method a 'getelementsbytagname "ImageMenu"))
(if (zerop (vlax-get-property ax 'length))
(vlax-get-property ax 'item 0)
(progn
(setq cn 0)
(while (> (vlax-get-property ax 'length) cn)
(setq ll (append ll (list (vlax-get-property ax 'item cn))) cn (1+ cn))
)
ll
)
)
)
(defun fnb_j (a / ax)
(setq ax (vlax-get-property (vlax-invoke-method a 'getelementsbytagname "Alias") 'item 0))
(if (null ax)
(setq lb (append lb (list a)))
(setq la (append la (list a)))
)
)
(defun fnc_j (a / ax cn ln lo oa)
(if (= :vlax-true (vlax-invoke-method a 'haschildnodes))
(progn
(setq cn 0
ax (vlax-get-property a 'childnodes)
ln (vlax-get-property ax 'length))
(while (> ln cn)
(setq oa (vlax-get-property ax 'item cn) cn (1+ cn))
(if (= (vlax-get-property oa 'nodename) "ImageMenuItem")
(setq lo (append lo (list oa)))
)
)
)
)
lo
)
(defun get_j (a / dc la lb lc)
(vl-load-com)
(vlax-invoke-method
(setq dc (vlax-create-object "MSXML.DOMDocument"))
'load
a
)
(mapcar 'fnb_j (fna_j dc))
(setq lc (mapcar 'length (mapcar 'fnc_j la)))
(mapcar 'vlax-release-object la)
(mapcar 'vlax-release-object lb)
(vlax-release-object dc)
(gc)
lc
)
(defun get_aa (a / cn ct it lx ty)
(setq ct (vla-get-count a) cn 0)
(repeat ct
(setq it (vlax-invoke-method a 'item cn)
ty (vla-get-type it)
cn (1+ cn))
(if (zerop ty)
(setq lx (append lx (list it)))
(if (= ty 2)
(setq lx (append lx (get_aa (vla-get-submenu it))))
)
)
)
(vl-remove-if
(function
(lambda (x)
(or (= (vla-get-macro x) "")
(wcmatch (vla-get-macro x) "*quit*")
(wcmatch (vla-get-macro x) "*closeall*")
(wcmatch (vla-get-macro x) "*syswindows*")
)
)
)
lx)
)
(defun get_ab (a / cn ct it lx ty)
(setq ct (vla-get-count a) cn 0)
(repeat ct
(setq it (vlax-invoke-method a 'item cn)
ty (vla-get-type it)
cn (1+ cn))
(if (zerop ty)
(setq lx (append lx (list it)))
(if (= ty 2)
(setq lx (append lx (get_ab (vla-get-submenu it))))
)
)
)
(vl-remove-if
(function
(lambda (x)
(or (= (vla-get-macro x) "")
(wcmatch (vla-get-macro x) "*_closeall*")
(wcmatch (vla-get-macro x) "*syswindows*")
)
)
)
lx)
)
(defun get_b (a / it ll)
(vlax-for it a (setq ll (append ll (list it))))
ll
)
(defun get_i (a / ax fi fs li lx)
(if (findfile (setq fs (vl-string-subst ".mns" ".mnc" a)))
(progn
(setq ax 0
fi (open fs "r"))
(while (/= (read-line fi) "***IMAGE") (princ))
(while (/= (substr (setq li (read-line fi)) 1 3) "***")
(cond ((wcmatch li "`*`**")
(if (zerop ax)
(princ)
(setq lx (append lx (list ax)) ax 0))
)
((wcmatch li "*(*,*)*") (setq ax (1+ ax)))
(T (princ))
)
)
(close fi)
(setq lx (append lx (list ax)))
)
(progn
(setq fi (reverse (vl-string->list fs)))
(while (/= (car fi) 92)
(setq lx (cons (car fi) lx) fi (cdr fi))
)
(alert (strcat "Couldn't find source menu for \"" (vl-list->string lx) "\"\nSorry, I can't follow"))
(exit)
)
)
)
(defun get_s (a / it ll)
(vlax-for it a (setq ll (append ll (list it))))
(vl-remove-if '(lambda (x) (= :vlax-false (vla-get-shortcutmenu x))) ll)
)
(defun get_t (a / it ll)
(vlax-for it a (setq ll (append ll (list it))))
)
(defun get_u (a / it ll)
(vlax-for it a (setq ll (append ll (list it))))
(vl-remove-if '(lambda (x)
(or
(= :vlax-true (vla-get-shortcutmenu x))
(= :vlax-true (vla-get-onmenubar x)))
)
ll)
)
(defun rng_a (a b / ax ll lm)
(setq lm a
ll (list (list (1+ b) (+ b (car lm))))
lm (cdr lm))
(while lm
(setq ax (cadr (last ll))
ll (append ll (list (list (1+ ax) (+ (car lm) ax))))
lm (cdr lm))
)
ll
)
(defun scm_a (a b c / ax cp gt nt)
(if (member a '(1000 2000 3000))
(progn
(grread T 2)
(menucmd "P0=POP0")
(menucmd "P0=*")
)
(setq ax (if (zerop a) nil a))
)
(if ax
(progn
(setq nt
(vl-position
'T
(mapcar
'(lambda (x)
(if
(and
(>= ax (car x))
(<= ax (cadr x))
)
(numberp (setq gt (- ax (car x))))
nil)
)
b)
)
)
(if
(vl-catch-all-error-p
(vl-catch-all-apply 'vla-get-onmenubar (list (nth nt c))))
(prn_b (nth gt (get_b (nth nt c))) a)
(prn_a
(nth gt
(if (< (atof (substr (getvar "ACADVER") 1 4)) 16.2)
(get_aa (nth nt c))
(get_ab (nth nt c))
)
)
a)
)
)
)
)
(defun tst_g (/ aa ab ac ad ae ao it lg li lp ls lt lu lx ly mb mg)
(setq mg (vla-get-menugroups (vlax-get-acad-object))
lg (reverse (vlax-for it mg (setq lg (cons it lg)))))
(mapcar '(lambda (x) (setq ls (append (get_s x) ls))) (mapcar 'vla-get-menus lg))
(if (> (length ls) 1)
(progn
(mapcar 'vlax-release-object ls)
(mapcar 'vlax-release-object lg)
(vlax-release-object mg)
(gc)
(setq ao (lod_m (vlax-get-acad-object))
mb (car ao)
mg (cadr ao)
lg nil
ls nil)
(vlax-for it mg (setq lg (append lg (list it))))
(vlax-for it mb (setq lp (append lp (list it))))
(mapcar '(lambda (x) (setq ls (append ls (get_s x)))) (mapcar 'vla-get-menus lg))
(terpri)
(terpri)
)
(progn
(setq mb (vla-get-menubar (vlax-get-acad-object)))
(vlax-for it mb (setq lp (append lp (list it))))
)
)
(if (< (atof (substr (getvar "ACADVER") 1 4)) 16.2)
(progn
(setq li (apply 'append (mapcar '(lambda (x) (get_i (vla-get-menufilename x))) lg)))
(mapcar '(lambda (x) (setq lt (append lt (get_t x)))) (mapcar 'vla-get-toolbars lg))
(mapcar '(lambda (x) (setq lu (append lu (get_u x)))) (mapcar 'vla-get-menus lg))
(setq aa (rng_a (mapcar (function (lambda (x) (length (get_aa x)))) ls) 499)
ab (rng_a (mapcar (function (lambda (x) (length (get_aa x)))) lp) (cadr (last aa)))
ac (rng_a li (cadr (last ab)))
ad (rng_a (mapcar (function (lambda (x) (length (get_b x)))) lt) (cadr (last ac)))
ae (rng_a (mapcar (function (lambda (x) (length (get_aa x)))) lu) (cadr (last ad)))
lx (append aa ab ac ad ae)
ly (append ls lp li lt lu)
)
)
(progn
(setq li (apply 'append (mapcar '(lambda (x) (get_j (vla-get-menufilename x))) lg)))
(mapcar '(lambda (x) (setq lt (append lt (get_t x)))) (mapcar 'vla-get-toolbars lg))
(mapcar '(lambda (x) (setq lu (append lu (get_u x)))) (mapcar 'vla-get-menus lg))
(setq aa (rng_a (mapcar (function (lambda (x) (length (get_ab x)))) ls) 499)
ab (rng_a (mapcar (function (lambda (x) (length (get_ab x)))) lp) (cadr (last aa)))
ac (rng_a li (cadr (last ab)))
ad (rng_a (mapcar (function (lambda (x) (length (get_b x)))) lt) (cadr (last ac)))
ae (rng_a (mapcar (function (lambda (x) (length (get_ab x)))) lu) (cadr (last ad)))
lx (append aa ab ac ad ae)
ly (append ls lp li lt lu)
)
)
)
(vlax-release-object mb)
(vlax-release-object mg)
(gc)
(list lx ly)
)
(defun C:TESTG (/ gr oe ts tx ty op sc)
(vl-load-com)
(if
(zerop (getvar "SHORTCUTMENU"))
(progn
(grread t 2)
(setq sc 12)
)
(setq sc 25)
)
(setq ts (tst_g)
tx (car ts)
ty (cadr ts)
oe *error*
*error* tsterr
)
(while (null op)
(setq gr (grread T 13))
(if (/= (car gr) 5) (setq pl (cons gr pl)))
(princ "\rCommand: Menu items evaluation: ")
(if (= (car gr) 11)
(progn
(scm_a (cadr gr) tx ty)
(princ "...Done!")
(terpri)
)
(if (or (= (car gr) sc) (and (= (car gr) 2) (= (cadr gr) 13)))
(progn
(princ "...I'm quitting")
(setq op T)
)
)
)
)
(mapcar '(lambda (x) (if (numberp x) (princ) (vlax-release-object x))) ty)
(gc)
(princ)
)
(princ "\nType TESTG to begin...")