求接地气！高飞鸟的程序太高了，请高手写个简单点的程序！
http://bbs.mjtd.com/thread-95997-1-1.html[趣味] 【飞鸟集】像素提取专家（更新至0830）
高飞鸟的程序非常强大，我看代码有点晕，希望有人能根据这个写一些简单的代码，供大家学习。
我的要求是：依http://bbs.mjtd.com/forum.php?mod=viewthread&tid=92311中的DCL界面，增加一个图片、一个图片按钮，鼠标点图片时无反应，点图片按钮时会弹出“高飞鸟就是高”这一句话。这两个我从未做过，应该是image和image_button吧，用于DCL的装饰，给个简单的例子更方便学习。
我也想学dcl希望高人写的简单的 那就继续顶，望有高手解决 下面是我的例子：
程序代码如下：
(defun c:test (/ dclid dclname filen gyxh stream tempname)
(defun act-dcl ()
(setq #gydata#
(subst (list $key $value) (assoc $key #gydata#) #gydata#)
)
(set_tile "GYXH"
(setq gyxh (strcat (get_tile "GY") (get_tile "XH")))
)
(setq #gydata# (subst (list "GYXH" gyxh)
(assoc "GYXH" #gydata#)
#gydata#
)
)
)
(defun act-dcl-gyxh ()
(setq #gydata# (subst (list "GYXH" $value)
(assoc "GYXH" #gydata#)
#gydata#
)
)
)
(defun act-dcl-in ()
(alert (cadr (assoc "GYXH" #gydata#)))
)
;;以下是修改段
(setq images (load "pictures")) ;编译vlx后用这句，注释下面的那句
;;(setq images (ReadFromFile)) ;用对话框读取用这句，注释上面的那句
(and (null Images) (exit))
;;;插入DCL头
(setq dclname (H:DCLHead '("test:dialog{" )))
;;;插入数据
(H:InsertDCLData
'(
"label=\"管牙型号标注\";"
":row{"
":boxed_radio_column{key=\"GY\";label=\"管牙\";width=15;"
":radio_button{key=\"PT\";label=\"PT\";}"
":radio_button{key=\"NPT\";label=\"NPT\";}"
":radio_button{key=\"BSP\";label=\"BSP\";}"
":radio_button{key=\"BSPT\";label=\"BSPT\";}"
"}"
":boxed_radio_column{key=\"XH\";label=\"型号\";width=15;"
":radio_button{key=\"1/8\";label=\"1/8\";}"
":radio_button{key=\"1/4\";label=\"1/4\";}"
":radio_button{key=\"3/8\";label=\"3/8\";}"
":radio_button{key=\"1/2\";label=\"1/2\";}"
":radio_button{key=\"3/4\";label=\"3/4\";}"
"}"
"}"
":edit_box{key=\"GYXH\";label=\"管牙型号\";}"
":row{"
)
dclname
)
;;把图像按钮插入你想要的地方
(setq Imglst (H:InsertImage Images T 0 dclname))
(H:InsertDCLData
'(
"}"
":row{"
":button{key=\"IN\";label=\"插入引线标注\";}"
":button{is_cancel=true;key=\"cancel\";label=\"取消\";}"
"}"
"}"
)
dclname
)
;;获取CAD颜色对象，为颜色转化做准备
(setq Version (substr (getvar 'acadver) 1 2))
(setq Version (strcat "AutoCAD.AcCmColor." version))
(setq ColorObj (vlax-create-object version))
;;修改段结束
;;写入DCL
(setq dclid (load_dialog dclname))
(if (not (new_dialog "test" dclid))
(progn (alert "dcl对话框加载失败.") (exit))
)
(if (null #gydata#)
(setq #gydata# (list (list "GY" "PT")
(list "XH" "1/8")
(list "GYXH" "PT1/8")
)
)
)
(set_tile "GY" (cadr (assoc "GY" #gydata#)))
(set_tile "XH" (cadr (assoc "XH" #gydata#)))
(set_tile "GYXH" (cadr (assoc "GYXH" #gydata#)))
(action_tile "GY" "(act-dcl)")
(action_tile "XH" "(act-dcl)")
(action_tile "GYXH" "(act-dcl-gyxh)")
(action_tile "IN" "(act-dcl-in)")
(action_tile "cancel" "(done_dialog 0)")
;;以下是修改段
;;在下面你可以为自己的图像按钮增加自己的动作函数
(foreach n Imglst
(action_tile (cdr n) "(alert key)")
)
;;填充每个图像按钮
(setq i 0)
(foreach image Images
(setq key (cdr (nth i ImgLst)))
(start_image key)
(fill_image 0 0 (dimx_tile key) (dimy_tile key) -15)
(foreach pt (cdr Image)
(setq x (car pt))
(setq y (cadr pt))
(setq r (nth 2 pt))
(setq g (nth 3 pt))
(setq b (nth 4 pt))
(setq IndexColor (RGB->Index ColorObj r g b))
(if (/= 0 (last pt))
(fill_image x y 1 1 IndexColor)
)
)
(end_image)
(setq i (1+ i))
)
;;修改段结束
(start_dialog)
(unload_dialog dclid)
(vl-file-delete dclname)
(and ColorObj (vlax-release-object ColorObj))
(princ)
)
;;;====================================================================================;
;;;功能: 写对话框头 ;
;;;参数: DCLData -- 对话框开始数据（不好忘记以后的插入和最后结尾部分能花括号匹配） ;
;;;返回: 对话框文件名,nil则说明打开文件错误 ;
;;;====================================================================================;
(defun H:DCLHead (DCLData / name file)
(if (and (setq name (vl-filename-mktemp "dcl-tmp.dcl"))
(setq file (open name "W"))
)
(progn
(foreach n DCLData
(write-line n file)
)
(close file)
name
)
)
)
;;;====================================================================================;
;;;功能: 插入对话框数据（包括对话框末尾） ;
;;;参数: DCLData -- 对话框开始数据（不好忘记以后的插入和最后结尾部分能花括号匹配） ;
;;;返回: 对话框文件名,nil则说明打开文件错误 ;
;;;====================================================================================;
(defun H:InsertDCLData (DCLData FileName / file)
(if (setq file (open FileName "A"))
(progn
(foreach n DCLData
(write-line n file)
)
(close file)
)
)
)
;;;====================================================================================;
;;;功能: 插入控件 ;
;;;参数: Images 程度得到的图片集 ;
;;; IsButton -- 是否是图像按钮 ;
;;; FirstIndex -- 控件的初始ID号，防止控件ID冲突 ;
;;; DCLFileName -- DCL的文件名（在插入前，确保文件已经关闭，防止写入失败） ;
;;;返回: 下一图像控件ID号,nil则说明打开文件错误 ;
;;;====================================================================================;
(defun H:InsertImage (Images IsButton FirstIndex DCLFileName / file w h str0 str1 lst keyName)
(if (setq file (open DCLFileName "A")) ;打开前确保文件已经关闭了
(progn
(if IsButton
(setq str0": image_button { key = " str1 "ImgBtn") ;控件名的前缀可以在这里改
(setq str0": image { key = " str1 "Img") ;控件名的前缀可以在这里改
)
(foreach image Images
(setq keyName (strcat str1 (itoa FirstIndex)))
(setq lst (cons (cons FirstIndex keyName) lst))
(write-line (strcat str0 keyName ";") file) ;控件名
(write-line " fixed_width = true;" file) ;宽度固定
(write-line " fixed_height = true;" file) ;高度固定
;(write-line " alignment = centered;" file) ;对齐方式
(setq w (1+ (car (last Image))))
(setq h (1+ (cadr (last Image))))
(write-line (strcat " width = " (rtos (/ w 6.0) 2 4) ";") file) ;宽度
;(write-line (strcat " height = " (rtos (/ h 6.0) 2 4) ";") file) ;高度这句不用写
(write-line (strcat " aspect_ratio = " (rtos (/ h w 1.0) 2 4) ";}") file) ;高宽比
(setq FirstIndex (1+ FirstIndex))
)
(close file) ;不要忘记关闭DCL文件
(reverse lst) ;返回控件ID号
)
)
)
;;;=====================================================
;;;Read pixel infomation from a lisp(data) file.
;;;=====================================================
(defun ReadFromFile (/ path name dlg)
(setq path (getvar 'users5))
(if (zerop (strlen path))
(setq path (getvar 'DWGPREFIX))
)
(setq dlg (vlax-create-object "MSComDlg.CommonDialog"))
(if dlg
(progn
(vlax-put dlg 'filter "Lisp file (*.lsp)|*.lsp")
(vlax-put dlg 'maxfilesize 260)
(vlax-put dlg 'initdir path)
(vlax-invoke dlg 'ShowOpen)
(setq name (vlax-get dlg 'filename))
(vlax-release-object dlg)
)
(setq name (getfiled "Select a data file" path "lsp" 0))
)
(if (and name (/= name ""))
(progn
(setvar 'users5 (strcat (VL-FILENAME-DIRECTORY name) "\\"))
(load name)
)
)
)
;;;=====================================================
;;;Draw a pixel by polyline method.(EntmakeX is faster.)
;;;=====================================================
(defun putpixel (x y color)
(entmakeX
(list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 2)
'(43 . 1.0)
(cons 420 color)
(cons 10 (list x y))
(cons 10 (list (1+ x) y))
)
)
)
;;;=====================================================
;;;Some functions about color conversion.
;;;=====================================================
;;;Truecolor Number (420) to RGB list
;;;=====================================================
(defun Number->RGB (color)
(list (lsh color -16)
(lsh (lsh color 16) -24)
(lsh (lsh color 24) -24)
)
)
;;;=====================================================
;;;RGB list to Truecolor Number (420)
;;;=====================================================
(defun RGB->Number (R G B)
(+ (lsh R 16) (lsh G 8) B)
)
;;;=====================================================
;;;RGB color(truecolor) to Index color
;;;=====================================================
(defun RGB->Index (ColorObj r g b / i)
(if (and (equal 0 r 10) (equal 0 g 10) (equal 0 b 10))
-16 ;It should be 0,but if you have set the CAD background color,then it looks strange.
(progn
(vla-setRGB ColorObj r g b)
(setq i (vla-get-ColorIndex ColorObj))
(if (= i 7) ;A little confused!
255
i
)
)
)
)
;;;=====================================================
;;;Index color to RGB color(truecolor)
;;;=====================================================
(defun Index->RGB (ColorObj ci /)
(vla-put-ColorIndex ColorObj ci)
(list (vla-get-red ColorObj)
(vla-get-green ColorObj)
(vla-get-blue ColorObj)
)
)
highflybir 发表于 2013-1-30 13:08 static/image/common/back.gif
下面是我的例子：
成功了！非常感谢你，我会把我研究出的代码继续贴上去的，有此功能，DCL不再那么冷冰冰了！ 你的这个标题不错，我也这么认为。 望革兄将之发扬光大，不负高飞鸟的一片苦心！ 我试试吧，高飞鸟的程序很高，要认真研读很多遍才能读懂 CAD二次发中写对话框就占用整个程序的一半时间 收藏起来慢慢学，我也想DCL不学连毛都未会
页:
[1]
2