[源码]窗口右键菜单及下拉菜单的实现
本帖最后由 yxp 于 2013-7-6 06:32 编辑菜单的增加和减少，只需要改动3个地方
1 LISP代码*Namecap* 菜单名称
2 Lisp代码 菜单点击事件中对应的响应函数 dcf 定义
3 Odcl窗口对应的图像按钮增减及改名;;===============================================================
;;OpenDCL右键菜单的实现
;;原创，小蜜蜂，QQ:90345892013-6-23
;;===============================================================
(defun c:rmenu( / ssr lt *ss-rigthmenu*)
(setq ssr "Rmenu_Form1_RightMneu" n 0
*Namecap* '("菜单1" "背景-蓝色" "背景-红色" "前景-青色" "前景-黑色" "退出"))
(repeat (length *Namecap*)
(setq *ss-rigthmenu* (cons (strcat ssr (itoa (setq n (1+ n)))) *ss-rigthmenu*)))
(dcl_Project_Load "Rmenu.odcl" t)
(dcl_Form_Show Rmenu_Form1)
(princ)
)
;;初始化窗口
(defun c:Rmenu_Form1_OnInitialize (/)
(setq *RM-ent* (mapcar '(lambda(x)(eval (read x)))*ss-rigthmenu*)) ;;控件数组
(Def_Clicked_Fun)
(move_mouse_color *ss-rigthmenu*)
)
(defun c:Rmenu_Form1_PictureBox1_OnRightClick (/)
(right_menue_pos *x^_^x* *y^_^y*)
)
(defun c:Rmenu_Form1_PictureBox1_OnMouseMove (Flags X Y /)(setq *x^_^x* x *y^_^Y* y))
(defun c:Rmenu_Form1_PictureBox1_OnClicked (/)(show_hidee_cs nil))
;;设置菜单显示的位置
;;窗口宽度 ww 高度 wh;菜单宽度 cw 高度 ch
(defun right_menue_pos(x y / d zch xx yy nn)
(setq ww 600 wh 340 cw 100 ch 24 nn (length *Namecap*) zch (* nn ch))
(cond
((and (< x (- ww cw)) (> y (- wh zch))) (setq xx x yy (- wh zch))) ;;第一象限显示
((and (< x (- ww cw)) (< y (- wh zch))) (setq xx x yy y)) ;;第四象限
((and (> x (- ww cw)) (< y (- wh zch))) (setq xx (- x cw) yy y)) ;;第三象限
((and (> x (- ww cw)) (> y (- wh zch))) (setq xx (- x cw) yy (- wh zch)));;第二象限
)
(setq d (- yy ch)) ;;23为每条菜单的高度
(foreach a (mapcar 'cons *RM-ent* *Namecap*)
(dcl_Control_ZOrder (car a) 1);;提到最顶端显示，如果已经是最前就不需要
(dcl_Control_SetPos (car a) xx (setq d (+ d ch)) cw ch)
(dcl_Control_SetCaption (car a) (cdr a))
)
(show_hidee_cs t)
)
;;定义菜单单击事件
(defun Def_Clicked_Fun( / dcf)
(setq dcf '("fun1" "fun2" "fun3" "fun4" "fun5" "fun6")) ;;单击响应函数列表
(foreach x (mapcar 'cons *ss-rigthmenu* dcf)
(eval (read (strcat "(defun c:" (car x) "_OnClicked (/)"
"(" (cdr x) " (dcl_Control_GetCaption " (car x) ")))"))))
)
;;定义鼠标滑过菜单的高亮显示
(defun move_mouse_color(L / )
(setq *#$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$%^&* L)
(foreach x L
(eval (read (strcat "(defun c:" x "_OnMouseMove (Flags X Y / xxLt er)"
"(setq xxLt (mapcar '(lambda(y)(list y -16 -19)) *#$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$%^&*)"
" xxLt (subst (list \"" x "\" -3 -16)(assoc \"" x "\" xxLt) xxLt)"
"*LTMenu* (cons " x " (car *LTMenu*)) er (cdr *LTMenu*))";;防止菜单闪烁
"(if (and er (/= er (car *LTMenu*))) (foreach y xxLt "
"(dcl_Control_SetBackColor (eval (read (car y))) (cadr y))"
"(dcl_Control_SetForeColor (eval (read (car y))) (caddr y)))))"))))
)
;;菜单的切换显示
(defun show_hidee_cs(c)
(foreach x *RM-ent* (dcl_Control_SetVisible x c))
)
;;调用自定义函数
(defun fun1( ss )
(show_hidee_cs nil)
(dcl_MessageBox (strcat "你点击了 " ss "") "提示" 2 2)
)
(defun fun2( ss )
(show_hidee_cs nil)
(dcl_Control_SetBackColor Rmenu_Form1_PictureBox1 5)
)
(defun fun3( ss )
(show_hidee_cs nil)
(dcl_Control_SetBackColor Rmenu_Form1_PictureBox1 1)
)
(defun fun4( ss )
(show_hidee_cs nil)
(dcl_Control_SetBackColor Rmenu_Form1_Label1 4)
)
(defun fun5( ss )
(show_hidee_cs nil)
(dcl_Control_SetBackColor Rmenu_Form1_Label1 -22)
)
(defun fun6( ss )
(dcl_Form_Close Rmenu_Form1)
)
ODCL环境自理
源码下载 感谢楼主的无私分享 谢谢 感谢分享................................ 我来捧场，哈哈，又是沙发啊， 厉害啊，学习了 出现; 错误: no function definition: DCL_PROJECT_LOAD 这么好的东东
能教一下ODCL环境自理
学习了,你用的是哪个版本 opendcl没找到有后缀为**.arx 还有想把窗口放CAD的右上方,应在哪一句上修改,用哪个代码 不错，不过只带下拉菜单的代码，就像结构计算V1.0演示的那样，贴出了看看啊。 hao 。存下来 备用 很好，下载了作为参考
页:
[1]
2