我也玩玩山寨,哈哈,DCL 控件

邹锋 · 发表于 2014-6-24 19:44:08

本帖最后由邹锋于 2014-6-24 19:46 编辑

大家好,我TONY 又来分享我的程序了,爱分享爱源码,

,希望帮到更多人,提高大家的水平
这是个初级帖子,高手请绕路,

此程序只适合模具介使用,但调用DCL 各控件你们可以借鉴下学习下,
在工作作常用的燕秀外挂,但是它的只使用的是大同顶针,我公司常做欧洲模具,经常用到HASCO 顶针,所以模仿燕秀外挂做了个DCL 介面的工具

下面是燕秀外挂中的

下面是我仿他的程序, 使用HASCO 标准件

点击下面可下载

(defun c:HET(/ pl ddlst l1 l3 l4 cl1 cl2 cl3 cl4 dd TYP)
(setvar "cmdecho" 0)
(hascocanshu);设置顶针参数
(hascodcl)
(prin1)
)
(defun hascocanshu ()
(setq ddlst '("dd1" "dd2" "dd3" "dd4" "dd5" "dd6"))
(setq pl '("顶针Z41/" "托针Z44" "司筒Z45" "扁顶Z46" "镶针Z40/Z41"))
(setq L1 '("1" "1.2" "1.5" "2" "2.5" "3" "3.5" "4"
"4.5" "5" "5.5" "6" "6.5" "7" "8" "8.5"
"9" "10" "10.5" "11" "12" "12.5" "14" "16"
"18" "20" "25" "32"
)
)
(setq L2 '("0.8" "0.9" "1" "1.1" "1.2" "1.3" "1.4"
"1.5" "1.6" "1.7" "1.8" "1.9" "2" "2.2"
"2.5"
)
)
(setq L3 '("2" "2.5" "3" "4" "4.5" "5" "5.5"
"6" "7" "8" "9" "10" "11" "12"
"14" "16" "20" "25"
)
)
(setq L4 '("3.8X0.8" "3.8X1" "3.8X1.2" "4.5X1"
"4.5X1.2" "4.5X1.5" "5.5X1" "5.5X1.2"
"5.5X1.5" "5.5X2" "7.5X1.2" "7.5X1.5"
"7.5X2" "9.5X1.5" "9.5X2" "11.5X2"
"11.5X2.5" "15.5X2" "15.5X2.5"
)
)
(setq cl1 (list '(2.5 1.2) '(2.5 1.2) '(3 1.5) '(4 2)
'(5 2) '(6 3) '(7 3) '(8 3)
'(8 3) '(10 3) '(10 3) '(12 5)
'(12 5) '(12 5) '(14 5) '(14 5)
'(14 5) '(16 5) '(16 5) '(16 5)
'(18 7) '(18 7) '(22 7) '(22 7)
'(24 7) '(26 8) '(32 10) '(40 10)
)
)
(setq cl2 (list '(4 2 2) '(6 3 3)
)
)
(setq cl3 (list '(4 2 1) '(5 2 1) '(6 3 1.5) '(8 3 2) '(8 3 2.5) '(10 3 2.5) '(10 3 3.5)
'(12 5 3.5) '(12 5 4.5) '(14 5 5) '(14 5 6) '(16 5 6) '(18 5 8) '(20 7 8)
'(22 7 10) '(22 7 12) '(26 7 16) '(32 10 20)
)
)
(setq cl4 (list '(4.2 8 3 3.8 0.8) '(4.2 8 3 3.8 1) '(4.2 8 3 3.8 1.2) '(5 10 3 4.5 1)
'(5 10 3 4.5 1.2) '(5 10 3 4.5 1.5) '(6 12 5 5.5 1) '(6 12 5 5.5 1.2)
'(6 12 5 5.5 1.5) '(6 12 5 5.5 2) '(8 14 5 7.5 1.2) '(8 14 5 7.5 1.5)
'(8 14 5 7.5 2) '(10 16 5 9.5 1.5) '(10 16 5 9.5 2) '(12 18 7 11.5 2)
'(12 18 7 11.5 2.5) '(16 22 7 15.5 2) '(16 22 7 15.5 2.5)
)
)
)
(defun hascodcl()
(setq dcl_id (load_dialog "hascoet"))
(if (not (new_dialog "hascoet" dcl_id))
(progn (alert "不能装入对话框") (exit))
)
(setetdcl)
(action_tile "poplist" "(sub_LIST2 $value)")
(action_tile "listbox" "(sub_LIST3 $value)")
(action_tile "im1" "(sub_lst 0)")
(action_tile "accept" "(getlist)(done_dialog 1)")
(action_tile "cancel" "(done_dialog)")
(setq dd (start_dialog))
(if (= dd 1)
(makehet)
)
)
(defun setetdcl(/ sldlist ii aa)
(show_list "poplist" pl)
(show_list "listbox" L1)
(show_sld "img1" "顶针")
(set_tile "text1" "顶针直径:")
(set_tile "listbox" (itoa 7))
(mapcar 'set_tile (list "dd1" "dd2" "dd3" "dd4" "dd5" "dd6") (list "4" "" "" "8" "3" ""))
(mapcar 'mode_tile ddlst '(0 1 1 0 0 1));设置那6个编辑框状态,1为灰色不可编辑,0为可编辑
)
(defun show_list (key newlist)
(start_list key)
(mapcar 'add_list newlist)
(end_list)
)
(defun show_sld (key sld)
(setq x (dimx_tile key))
(setq y (dimy_tile key))
(start_image key)
(fill_image 0 0 x y 0)
(slide_image 0 0 x y sld)
(end_image)
)
(defun sub_LIST2 (num / )
(cond ((= num "0")
(setetdcl)
)
((= num "1")
(show_list "listbox" L2)
(show_sld "img1" "托针")
(set_tile "text1" "托针直径:");设置编辑框左边的文字
(set_tile "text2" " 托直径:");设置编辑框左边的文字
(set_tile "listbox" (itoa 0));默认设置为第一个
(mapcar 'set_tile ddlst '("0.8" "2" "" "4" "2" "50"));设置编辑框默认参数
(mapcar 'mode_tile ddlst '(0 0 1 0 0 0));设置编辑框默认编辑状态
)
((= num "2")
(show_list "listbox" L3)
(show_sld "img1" "司筒")
(set_tile "text1" " 筒直径:")
(set_tile "text2" " 针直径:")
(set_tile "listbox" (itoa 3))
(mapcar 'set_tile ddlst '("4" "2" "" "8" "3" ""))
(mapcar 'mode_tile ddlst '(0 0 1 0 0 1))
)
((= num "3")
(show_list "listbox" L4)
(show_sld "img1" "扁顶")
(set_tile "text1" " 长:")
(set_tile "text2" " 宽:")
(set_tile "text3" " 直径:")
(set_tile "listbox" (itoa 1))
(mapcar 'set_tile ddlst '("3.8" "1" "4.2" "8" "3" "50"))
(mapcar 'mode_tile ddlst '(0 0 0 0 0 0))
)
((= num "4")
(show_list "listbox" L1)
(show_sld "img1" "镶针")
(set_tile "text1" "镶针直径:")
(set_tile "listbox" (itoa 7))
(mapcar 'set_tile (list "dd1" "dd2" "dd3" "dd4" "dd5" "dd6") (list "4" "" "" "8" "3" ""))
(mapcar 'mode_tile ddlst '(0 1 1 0 0 1))
)
)
)
(defun sub_LIST3 (num)
(setq nn (atoi num))
(setq typ (get_tile "poplist"))
(cond ((or (= typ "0") (= typ "4"))
(setq 2rad (nth nn l1))
(setq d1 (rtos (car (nth nn cl1)) 2 0))
(setq k (rtos (cadr (nth nn cl1)) 2 0))
(set_tile "dd1" 2rad)
(set_tile "dd4" d1)
(set_tile "dd5" k)
)
((= typ "1")
(setq 2rad (atof (nth nn l2)))
(if (< 2rad 1.5)
(setq tuocs (nth 0 cl2))
(setq tuocs (nth 1 cl2))
)
(setq d2 (rtos (car tuocs) 2 0))
(setq k (rtos (cadr tuocs) 2 0))
(setq d3 (rtos (caddr tuocs) 2 0))
(set_tile "dd1" (rtos 2rad 2 1))
(mapcar 'set_tile (list "dd1" "dd2" "dd3" "dd4" "dd5" "dd6")
(list (rtos 2rad 2 1) d3 "" d2 k "50"))
)
((= typ "2")
(setq 2rad (nth nn l3))
(setq tuocs (nth nn cl3))
(setq d2 (rtos (car tuocs) 2 0))
(setq k (rtos (cadr tuocs) 2 0))
(setq d3 (rtos (caddr tuocs) 2 0))
(mapcar 'set_tile (list "dd1" "dd2" "dd3" "dd4" "dd5" "dd6")
(list 2rad d3 "" d2 k ""))
)
((= typ "3")
(setq tuocs (nth nn cl4))
(setq d1 (rtos (nth 0 tuocs) 2 1))
(setq d2 (rtos (nth 1 tuocs) 2 1))
(setq k (rtos (nth 2 tuocs) 2 1))
(setq aa (rtos (nth 3 tuocs) 2 1))
(setq bb (rtos (nth 4 tuocs) 2 1))
(mapcar 'set_tile (list "dd1" "dd2" "dd3" "dd4" "dd5" "dd6")
(list aa bb d1 d2 k "50"))
)
)
)
(defun getlist ()
(setq typ (get_tile "poplist"))
(cond ((or (= typ "0") (= typ "4"))
(setq etdd (atof (get_tile "dd1")))
(setq w1 (/ (atof (get_tile "dd4")) 2))
(setq h1 (atof (get_tile "dd5")))
)
((= typ "1")
(setq etd (atof (get_tile "dd1")))
(setq netd (atof (get_tile "dd2")))
(setq w1 (/ (atof (get_tile "dd4")) 2))
(setq h1 (atof (get_tile "dd5")))
(setq netdh (atof (get_tile "dd6")))
)
((= typ "2")
(setq etdd (atof (get_tile "dd1")))
(setq netd (atof (get_tile "dd2")))
(setq w1 (/ (atof (get_tile "dd4")) 2))
(setq h1 (atof (get_tile "dd5")))
(setq netdz (get_tile "dd2"))
(if (/= (vl-position netdz l1) nil)
(progn
(setq i (vl-position netdz l1))
(setq necs (nth i cl1))
(setq w2 (/ (float (car necs)) 2))
(setq h2 (cadr necs))
)
(progn
(setq netdz (rtos (fix netd) 2 0))
(setq i (vl-position netdz l1))
(setq necs (nth i cl1))
(setq w2 (/ (float (car necs)) 2))
(setq h2 (cadr necs))
)
)
)
((= typ "3")
(setq etd (atof (get_tile "dd2")))
(setq netd (atof (get_tile "dd3")))
(setq w1 (/ (atof (get_tile "dd4")) 2))
(setq h1 (atof (get_tile "dd5")))
(setq netdh (atof (get_tile "dd6")))
)
)
(princ)
)
(defun makehet(/ p1 p2 chklty ang1 ettyp p3)
(setvar "orthomode" 1)
(setq chklty (tblsearch "LTYPE" "CENTER"))
(if (= chklty nil)
(entmake
(list '(0 . "LTYPE")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLinetypeTableRecord")
(cons 2 "CENTER")
'(3 . "Center ____ _ ____ _ ____ _ ____ _ ____ _ ____")
'(70 . 0)
'(73 . 2)
'(40 . 15.0)
'(49 . 10.0)
'(74 . 0)
'(49 . -5.0)
'(74 . 0)
)
)
)
(cond ((= typ "0")
(setq ettyp "epin")
(while (setq p1 (getpoint "\n 指定第一点:"))
(setq p2 (getpoint p1 "\n 指定第二点:"))
(setq ang1 (angle p1 p2))
(if (> (distance p1 p2) 30)
(makedz p1 p2 ettyp etdd w1 h1 ang1)
(alert "两点小于30,重新选择")
)
)
)
((= typ "1")
(setq ettyp "epin")
(while (setq p1 (getpoint "\n 指定第一点:"))
(setq p2 (getpoint p1 "\n 指定第二点:"))
(setq ang1 (angle p1 p2))
(if (> (distance p1 p2) 76)
(make_bd p1 p2 ettyp etd netd w1 h1 netdh ang1)
(alert "长度小于75,重新选择")
)
)
)
((= typ "2")
(setq ettyp "epin")
(while (setq p1 (getpoint "\n 指定第一点:"))
(setq p2 (getpoint p1 "\n 指定第二点:"))
(setq p3 (getpoint p2 "\n 指定第下一点:"))
(setq ang1 (angle p1 p2))
(setq p3 (polar p2 ang1 (distance p2 p3)))
(makedz p1 p3 ettyp netd w2 h2 ang1)
(makedz p2 p3 ettyp etdd w1 h1 ang1)
)
)
((= typ "3")
(setq ettyp "epin")
(while (setq p1 (getpoint "\n 指定第一点:"))
(setq p2 (getpoint p1 "\n 指定第二点:"))
(setq ang1 (angle p1 p2))
(if (> (distance p1 p2) 76)
(make_bd p1 p2 ettyp etd netd w1 h1 netdh ang1)
(alert "长度小于75,重新选择")
)
)
)
((= typ "4")
(setq ettyp "insert")
(while (setq p1 (getpoint "\n 指定第一点:"))
(setq p2 (getpoint p1 "\n 指定第二点:"))
(setq ang1 (angle p1 p2))
(if (> (distance p1 p2) 10)
(makedz p1 p2 ettyp etdd w1 h1 ang1)
(alert "两点小于10,重新选择")
)
)
)
)
(princ)
)
;;;;;;;;;;;;;;;画顶针与镶针函数，
;;p1第一点，P2,第二点，TYP为顶针或者镶针;ETD为顶针直径 W1为顶针头的半径，H1为顶针头的高度
(defun makedz(p1 p2 typ etd w1 h1 ang1 / 0.5pi 1.5pi 2pi ang1 ang2 ang3 etd
p3 p4 p5 p6 p7 p8 p9 p10 p11 p12 p13 p14 p15 p16 p17 p18 p19 p20)
(setq 0.5pi (* pi 0.5))
(setq 1.5pi (* pi 2))
(setq 2pi (* pi 2))
(setq P1 (trans p1 1 0))
(setq P2 (trans p2 1 0))
(entmake (list
'(0 . "LINE")
(cons 10 p1)
(cons 11 p2)
(cons 62 1)
(cons 6 "CENTER")
(cons 8 typ)
(cons 48 0.1)
)
)
(setq ang2 (nth 0 (getang ang1)))
(setq ang3 (nth 1 (getang ang1)))
(setq p3 (polar p1 ang2 w1)
p4 (polar p3 ang1 h1)
)
(setq p5 (polar p3 ang2 0.5)
p6 (polar p5 ang1 h1)
)
(setq p7 (polar p1 ang3 w1)
p8 (polar p7 ang1 h1)
)
(setq p9 (polar p7 ang3 0.5)
p10 (polar p9 ang1 h1)
)
(setq p11 (polar (polar p1 ang2 (/ etd 2)) ang1 h1)
p12 (polar p2 ang2 (/ etd 2))
)
(setq p13 (polar (polar p1 ang3 (/ etd 2)) ang1 h1)
p14 (polar p2 ang3 (/ etd 2))
)
(mkl p3 p4 typ)
(mkl p5 p6 typ)
(mkl p7 p8 typ)
(mkl p9 p10 typ)
(mkl p4 p8 typ)
(mkl p6 p10 typ)
(mkl p11 p12 typ)
(mkl p13 p14 typ)
(if (= typ "epin")
(if (> (distance p1 p2) 30)
(progn
(setq p15 (polar p11 ang2 0.25)
p16 (polar p15 ang1 (- (distance p1 p2) 30))
p17 (polar p11 ang1 (+ (- (distance p1 p2) 30) 0.25))
)
(setq p18 (polar p13 ang3 0.25)
p19 (polar p18 ang1 (- (distance p1 p2) 30))
p20 (polar p13 ang1 (+ (- (distance p1 p2) 30) 0.25))
)
(mkl p15 p16 "epin")
(mkl p16 p17 "epin")
(mkl p18 p19 "epin")
(mkl p19 p20 "epin")
)
)
)
)
;;;此处可以做成一个子函数,可节省代码行数,但便于别人好学习,还是分开为两处子程序
(defun make_bd(p1 p2 typ etd netd w1 h1 netdh ang1 / 0.5pi 1.5pi 2pi
ang2 ang3 p3 p4 p5 p6 p6 p7 p8 p9 p10 p11 p12 p13
p14 p15 p16 p17 p18 b1 b2 b3 b4 b5 b6 b7 b8 aa)
(setq 0.5pi (* pi 0.5))
(setq 1.5pi (* pi 2))
(setq 2pi (* pi 2))
(setq P1 (trans p1 1 0))
(setq P2 (trans p2 1 0))
(entmake (list
'(0 . "LINE")
(cons 10 p1)
(cons 11 p2)
(cons 62 1)
(cons 6 "CENTER")
(cons 8 typ)
(cons 48 0.1)
)
)
(setq ang2 (nth 0 (getang ang1)))
(setq ang3 (nth 1 (getang ang1)))
(setq p3 (polar p1 ang2 w1)
p4 (polar p3 ang1 h1)
)
(setq p5 (polar p3 ang2 0.25)
p6 (polar p5 ang1 h1)
)
(setq p7 (polar p1 ang3 w1)
p8 (polar p7 ang1 h1)
)
(setq p9 (polar p7 ang3 0.25)
p10 (polar p9 ang1 h1)
)
(setq p11 (polar (polar p1 ang2 (/ netd 2)) ang1 h1)
p12 (polar p11 ang1 (- netdh h1 2))
)
(setq p13 (polar (polar p1 ang3 (/ netd 2)) ang1 h1)
p14 (polar p13 ang1 (- netdh h1 2))
)
(setq p15 (polar (polar p1 ang2 (/ etd 2)) ang1 netdh)
p16 (polar p15 ang1 (- (distance p1 p2) netdh))
)
(setq p17 (polar p15 ang3 etd)
p18 (polar p16 ang3 etd)
)
(setq aa (- (distance p1 p2) netdh 30));;设置避空长度
(if (< aa 0)
(setq aa 10)
);;设置避空长度
(setq b1 (polar p11 ang2 0.25)
b2 (polar b1 ang1 (+ (- netdh h1) aa))
)
(setq b3 (polar b2 ang3 (- (+ 0.25 (/ netd 2)) (/ etd 2)))
b4 (polar b3 ang1 1)
)
(setq b5 (polar b1 ang3 (* (+ 0.25 (/ netd 2)) 2))
b6 (polar b2 ang3 (* (+ 0.25 (/ netd 2)) 2))
)
(setq b7 (polar b3 ang3 etd)
b8 (polar b7 ang1 1)
)
(mkl p3 p4 typ)
(mkl p5 p6 typ)
(mkl p7 p8 typ)
(mkl p9 p10 typ)
(mkl p4 p8 typ)
(mkl p6 p10 typ)
(mkl p11 p12 typ)
(mkl p13 p14 typ)
(mkl p15 p16 typ)
(mkl p17 p18 typ)
(mkl p12 p15 typ);托斜线
(mkl p14 p17 typ);托斜线
(mkl p15 p17 typ);托平线
(mkl p12 p14 typ);托平线
(mkl b1 b2 typ);左逼空竖线
(mkl b3 b2 typ);左逼空横线
(mkl b4 b2 typ);左逼空斜线
(mkl b5 b6 typ);右逼空竖线
(mkl b7 b6 typ);右逼空横线
(mkl b8 b6 typ);右逼空斜线
)
;;或取另外两个角度ANG2为左边的角度，ANG3为右边的
(defun getang(ang1 / ang2 ang3)
(cond ((and (< ang1 0.5pi) (>= ang1 0))
(setq ang2 (+ ang1 0.5pi))
(setq ang3 (- ang2 pi))
)
((and (>= ang1 0.5pi) (< ang1 pi))
(setq ang2 (+ ang1 0.5pi))
(setq ang3 (- ang1 0.5pi))
)
((and (<= ang1 1.5pi) (>= ang1 pi))
(setq ang2 (+ ang1 0.5pi))
(setq ang3 (- ang1 0.5pi))
)
((and (< ang1 2pi) (> ang1 1.5pi))
(setq ang3 (- ang1 0.5pi))
(setq ang2 (- ang3 pi))
)
)
(list ang2 ang3)
)
;自定义函数,取两点与图层,生成一条直线
(defun mkl (pt1 pt2 lay /)
(entmake (list '(0 . "LINE")
(cons 10 pt1)
(cons 11 pt2)
(cons 8 lay)
)
)
)

(defun c:HET(/ pl ddlst l1 l3 l4 cl1 cl2 cl3 cl4 dd TYP) 
  (setvar "cmdecho" 0) 
  (hascocanshu);设置顶针参数 
  (hascodcl) 
  (prin1) 
) 
 
(defun hascocanshu () 
  (setq ddlst '("dd1" "dd2" "dd3" "dd4" "dd5" "dd6")) 
  (setq pl '("顶针Z41/" "托针Z44" "司筒Z45" "扁顶Z46" "镶针Z40/Z41")) 
  (setq        L1 '("1"    "1.2"  "1.5"  "2"         "2.5"        "3"    "3.5"  "4" 
             "4.5"  "5"           "5.5"  "6"         "6.5"        "7"    "8"    "8.5" 
             "9"    "10"   "10.5" "11"         "12"        "12.5" "14"   "16" 
             "18"   "20"   "25"          "32" 
            ) 
        ) 
  (setq        L2 '("0.8"   "0.9"   "1"     "1.1"   "1.2"   "1.3"   "1.4" 
             "1.5"   "1.6"   "1.7"   "1.8"   "1.9"   "2"     "2.2" 
             "2.5" 
            ) 
        ) 
  (setq        L3 '("2"    "2.5"  "3"         "4"        "4.5"  "5"    "5.5" 
             "6"    "7"           "8"          "9"         "10"  "11"    "12" 
             "14"   "16"  "20"   "25" 
            ) 
        ) 
  (setq        L4 '("3.8X0.8"          "3.8X1"      "3.8X1.2"    "4.5X1" 
             "4.5X1.2"          "4.5X1.5"    "5.5X1"            "5.5X1.2" 
             "5.5X1.5"          "5.5X2"      "7.5X1.2"    "7.5X1.5" 
             "7.5X2"          "9.5X1.5"    "9.5X2"            "11.5X2" 
             "11.5X2.5"          "15.5X2"     "15.5X2.5" 
            ) 
        ) 
  (setq        cl1 (list '(2.5 1.2) '(2.5 1.2)        '(3 1.5)   '(4 2) 
                  '(5 2)     '(6 3)        '(7 3)           '(8 3) 
                  '(8 3)     '(10 3)        '(10 3)           '(12 5) 
                  '(12 5)    '(12 5)        '(14 5)           '(14 5) 
                  '(14 5)    '(16 5)        '(16 5)           '(16 5) 
                  '(18 7)    '(18 7)        '(22 7)           '(22 7) 
                  '(24 7)    '(26 8)        '(32 10)   '(40 10) 
                 ) 
        ) 
  (setq cl2 (list '(4 2 2) '(6 3 3) 
                  ) 
        ) 
  (setq cl3 (list '(4 2 1) '(5 2 1) '(6 3 1.5) '(8 3 2) '(8 3 2.5) '(10 3 2.5) '(10 3 3.5) 
                  '(12 5 3.5) '(12 5 4.5) '(14 5 5) '(14 5 6) '(16 5 6) '(18 5 8) '(20 7 8) 
                  '(22 7 10)  '(22 7 12) '(26 7 16) '(32 10 20) 
                  ) 
        ) 
  (setq cl4 (list '(4.2 8 3 3.8 0.8) '(4.2 8 3 3.8 1) '(4.2 8 3 3.8 1.2) '(5 10 3 4.5 1) 
                  '(5 10 3 4.5 1.2) '(5 10 3 4.5 1.5) '(6 12 5 5.5 1) '(6 12 5 5.5 1.2) 
                  '(6 12 5 5.5 1.5) '(6 12 5 5.5 2) '(8 14 5 7.5 1.2) '(8 14 5 7.5 1.5) 
                  '(8 14 5 7.5 2) '(10 16 5 9.5 1.5) '(10 16 5 9.5 2)  '(12 18 7 11.5 2) 
                  '(12 18 7 11.5 2.5) '(16 22 7 15.5 2) '(16 22 7 15.5 2.5) 
                  ) 
        ) 
) 
 
 
 
 
(defun hascodcl() 
  (setq dcl_id (load_dialog "hascoet")) 
  (if (not (new_dialog "hascoet" dcl_id)) 
    (progn (alert "不能装入对话框") (exit)) 
  ) 
  (setetdcl) 
  (action_tile "poplist" "(sub_LIST2 $value)") 
  (action_tile "listbox" "(sub_LIST3 $value)") 
  (action_tile "im1" "(sub_lst 0)") 
  (action_tile "accept" "(getlist)(done_dialog 1)") 
  (action_tile "cancel" "(done_dialog)") 
  (setq dd (start_dialog)) 
  (if (= dd 1) 
    (makehet) 
  ) 
) 
 
(defun setetdcl(/ sldlist ii aa) 
  (show_list "poplist" pl) 
  (show_list "listbox" L1) 
  (show_sld "img1" "顶针") 
  (set_tile "text1" "顶针直径:") 
  (set_tile "listbox" (itoa  7)) 
  (mapcar 'set_tile  (list "dd1" "dd2" "dd3" "dd4" "dd5" "dd6") (list "4" "" "" "8" "3" "")) 
  (mapcar 'mode_tile  ddlst '(0 1 1 0 0 1));设置那6个编辑框状态,1为灰色不可编辑,0为可编辑 
) 
 
(defun show_list (key newlist) 
  (start_list key) 
  (mapcar 'add_list newlist) 
  (end_list) 
) 
 
(defun show_sld        (key sld) 
  (setq x (dimx_tile key)) 
  (setq y (dimy_tile key)) 
  (start_image key) 
  (fill_image 0 0 x y 0) 
  (slide_image 0 0 x y sld) 
  (end_image) 
) 
 
(defun sub_LIST2 (num / ) 
  (cond ((= num "0") 
         (setetdcl) 
         ) 
        ((= num "1") 
         (show_list "listbox" L2) 
         (show_sld "img1" "托针") 
         (set_tile "text1" "托针直径:");设置编辑框左边的文字 
         (set_tile "text2" "  托直径:");设置编辑框左边的文字 
         (set_tile "listbox" (itoa  0));默认设置为第一个 
         (mapcar 'set_tile  ddlst '("0.8" "2" "" "4" "2" "50"));设置编辑框默认参数 
         (mapcar 'mode_tile  ddlst '(0 0 1 0 0 0));设置编辑框默认编辑状态 
         ) 
        ((= num "2") 
         (show_list "listbox" L3) 
         (show_sld "img1" "司筒") 
         (set_tile "text1" "  筒直径:") 
         (set_tile "text2" "  针直径:") 
         (set_tile "listbox" (itoa  3)) 
         (mapcar 'set_tile  ddlst '("4" "2" "" "8" "3" "")) 
         (mapcar 'mode_tile  ddlst '(0 0 1 0 0 1)) 
         ) 
        ((= num "3") 
         (show_list "listbox" L4) 
         (show_sld "img1" "扁顶") 
         (set_tile "text1" "      长:") 
         (set_tile "text2" "      宽:") 
         (set_tile "text3" "    直径:") 
         (set_tile "listbox" (itoa  1)) 
         (mapcar 'set_tile  ddlst '("3.8" "1" "4.2" "8" "3" "50")) 
         (mapcar 'mode_tile  ddlst '(0 0 0 0 0 0)) 
         ) 
        ((= num "4") 
         (show_list "listbox" L1) 
         (show_sld "img1" "镶针") 
         (set_tile "text1" "镶针直径:") 
         (set_tile "listbox" (itoa  7)) 
         (mapcar 'set_tile  (list "dd1" "dd2" "dd3" "dd4" "dd5" "dd6") (list "4" "" "" "8" "3" "")) 
         (mapcar 'mode_tile  ddlst '(0 1 1 0 0 1)) 
         ) 
        ) 
) 
 
(defun sub_LIST3 (num) 
  (setq nn (atoi num)) 
  (setq typ (get_tile "poplist")) 
  (cond ((or (= typ "0") (= typ "4")) 
         (setq 2rad (nth nn l1)) 
         (setq d1 (rtos (car (nth nn cl1)) 2 0)) 
         (setq k (rtos (cadr (nth nn cl1)) 2 0)) 
         (set_tile "dd1" 2rad) 
         (set_tile "dd4" d1) 
         (set_tile "dd5" k) 
         ) 
        ((= typ "1") 
         (setq 2rad (atof (nth nn l2))) 
         (if (< 2rad 1.5) 
           (setq tuocs (nth 0 cl2)) 
           (setq tuocs (nth 1 cl2)) 
           ) 
         (setq d2 (rtos (car tuocs) 2 0)) 
         (setq k (rtos (cadr tuocs) 2 0)) 
         (setq d3 (rtos (caddr tuocs) 2 0)) 
         (set_tile "dd1" (rtos 2rad 2 1)) 
         (mapcar 'set_tile  (list "dd1" "dd2" "dd3" "dd4" "dd5" "dd6") 
                 (list (rtos 2rad 2 1) d3 "" d2 k "50")) 
         ) 
        ((= typ "2") 
         (setq 2rad (nth nn l3)) 
         (setq tuocs (nth nn cl3)) 
         (setq d2 (rtos (car tuocs) 2 0)) 
         (setq k (rtos (cadr tuocs) 2 0)) 
         (setq d3 (rtos (caddr tuocs) 2 0)) 
         (mapcar 'set_tile  (list "dd1" "dd2" "dd3" "dd4" "dd5" "dd6") 
                 (list 2rad d3 "" d2 k "")) 
         ) 
        ((= typ "3") 
         (setq tuocs (nth nn cl4)) 
         (setq d1 (rtos (nth 0 tuocs) 2 1)) 
         (setq d2 (rtos (nth 1 tuocs) 2 1)) 
         (setq k (rtos (nth 2 tuocs) 2 1)) 
         (setq aa (rtos (nth 3 tuocs) 2 1)) 
         (setq bb (rtos (nth 4 tuocs) 2 1)) 
         (mapcar 'set_tile  (list "dd1" "dd2" "dd3" "dd4" "dd5" "dd6") 
                 (list aa bb d1 d2 k "50")) 
         ) 
        ) 
  ) 
 
(defun getlist () 
  (setq typ (get_tile "poplist")) 
  (cond ((or (= typ "0") (= typ "4")) 
         (setq etdd (atof (get_tile "dd1"))) 
         (setq w1 (/ (atof (get_tile "dd4")) 2)) 
         (setq h1 (atof (get_tile "dd5"))) 
         ) 
        ((= typ "1") 
         (setq etd (atof (get_tile "dd1"))) 
         (setq netd (atof (get_tile "dd2"))) 
         (setq w1 (/ (atof (get_tile "dd4")) 2)) 
         (setq h1 (atof (get_tile "dd5"))) 
         (setq netdh (atof (get_tile "dd6"))) 
         ) 
        ((= typ "2") 
         (setq etdd (atof (get_tile "dd1"))) 
         (setq netd (atof (get_tile "dd2"))) 
         (setq w1 (/ (atof (get_tile "dd4")) 2)) 
         (setq h1 (atof (get_tile "dd5"))) 
         (setq netdz (get_tile "dd2")) 
         (if  (/= (vl-position netdz l1) nil) 
           (progn 
             (setq i (vl-position netdz l1)) 
             (setq necs (nth i cl1)) 
             (setq w2 (/ (float (car necs)) 2)) 
             (setq h2 (cadr necs)) 
             ) 
           (progn 
             (setq netdz (rtos (fix netd) 2 0)) 
             (setq i (vl-position netdz l1)) 
             (setq necs (nth i cl1)) 
             (setq w2 (/ (float (car necs)) 2)) 
             (setq h2 (cadr necs)) 
             ) 
           ) 
         ) 
        ((= typ "3") 
         (setq etd (atof (get_tile "dd2"))) 
         (setq netd (atof (get_tile "dd3"))) 
         (setq w1 (/ (atof (get_tile "dd4")) 2)) 
         (setq h1 (atof (get_tile "dd5"))) 
         (setq netdh (atof (get_tile "dd6"))) 
         ) 
        ) 
  (princ) 
  ) 
 
(defun makehet(/ p1 p2 chklty ang1 ettyp p3) 
  (setvar "orthomode" 1) 
  (setq chklty (tblsearch "LTYPE" "CENTER")) 
  (if (= chklty nil) 
    (entmake 
      (list '(0 . "LTYPE") 
            '(100 . "AcDbSymbolTableRecord") 
            '(100 . "AcDbLinetypeTableRecord") 
            (cons 2 "CENTER") 
            '(3 . "Center ____ _ ____ _ ____ _ ____ _ ____ _ ____") 
            '(70 . 0) 
            '(73 . 2) 
            '(40 . 15.0) 
            '(49 . 10.0) 
            '(74 . 0) 
            '(49 . -5.0) 
            '(74 . 0) 
      ) 
    ) 
  ) 
  (cond ((= typ "0") 
         (setq ettyp "epin") 
         (while   (setq p1 (getpoint "\n 指定第一点:")) 
           (setq p2 (getpoint p1 "\n 指定第二点:")) 
           (setq ang1 (angle p1 p2)) 
           (if (> (distance p1 p2) 30) 
             (makedz p1 p2 ettyp etdd w1 h1 ang1) 
             (alert "两点小于30,重新选择") 
             ) 
           ) 
         ) 
        ((= typ "1") 
         (setq ettyp "epin") 
         (while   (setq p1 (getpoint "\n 指定第一点:")) 
           (setq p2 (getpoint p1 "\n 指定第二点:")) 
           (setq ang1 (angle p1 p2)) 
           (if (> (distance p1 p2) 76) 
             (make_bd p1 p2 ettyp etd netd w1 h1 netdh ang1) 
             (alert "长度小于75,重新选择") 
             ) 
           ) 
         ) 
        ((= typ "2") 
         (setq ettyp "epin") 
         (while   (setq p1 (getpoint "\n 指定第一点:")) 
           (setq p2 (getpoint p1 "\n 指定第二点:")) 
           (setq p3 (getpoint p2 "\n 指定第下一点:")) 
           (setq ang1 (angle p1 p2)) 
           (setq p3 (polar p2 ang1 (distance p2 p3))) 
           (makedz p1 p3 ettyp netd w2 h2 ang1) 
           (makedz p2 p3 ettyp etdd w1 h1 ang1) 
           ) 
         ) 
        ((= typ "3") 
         (setq ettyp "epin") 
         (while   (setq p1 (getpoint "\n 指定第一点:")) 
           (setq p2 (getpoint p1 "\n 指定第二点:")) 
           (setq ang1 (angle p1 p2)) 
           (if (> (distance p1 p2) 76) 
             (make_bd p1 p2 ettyp etd netd w1 h1 netdh ang1) 
             (alert "长度小于75,重新选择") 
             ) 
           ) 
         )        
        ((= typ "4") 
         (setq ettyp "insert") 
         (while   (setq p1 (getpoint "\n 指定第一点:")) 
           (setq p2 (getpoint p1 "\n 指定第二点:")) 
           (setq ang1 (angle p1 p2)) 
           (if (> (distance p1 p2) 10) 
             (makedz p1 p2 ettyp etdd w1 h1 ang1) 
             (alert "两点小于10,重新选择") 
             ) 
           ) 
         ) 
        ) 
  (princ) 
) 
 
 
 
 
 
 
;;;;;;;;;;;;;;;画顶针与镶针函数， 
;;p1第一点，P2,第二点，TYP为顶针或者镶针;ETD为顶针直径 W1为顶针头的半径，H1为顶针头的高度 
(defun makedz(p1 p2 typ etd w1 h1 ang1 / 0.5pi 1.5pi 2pi ang1 ang2 ang3 etd 
              p3 p4 p5 p6 p7 p8 p9 p10 p11 p12 p13 p14 p15 p16 p17 p18 p19 p20) 
  (setq 0.5pi (* pi 0.5)) 
  (setq 1.5pi (* pi 2)) 
  (setq 2pi (* pi 2)) 
  (setq P1 (trans p1 1 0)) 
  (setq P2 (trans p2 1 0))   
  (entmake (list 
             '(0 . "LINE") 
             (cons 10 p1) 
             (cons 11 p2) 
             (cons 62 1) 
             (cons 6 "CENTER") 
             (cons 8 typ) 
             (cons 48 0.1) 
             ) 
           ) 
  (setq ang2 (nth 0 (getang ang1))) 
  (setq ang3 (nth 1 (getang ang1))) 
  (setq p3 (polar p1 ang2 w1) 
        p4 (polar p3 ang1 h1) 
        ) 
  (setq p5 (polar p3 ang2 0.5) 
        p6 (polar p5 ang1 h1) 
        ) 
  (setq p7 (polar p1 ang3 w1) 
        p8 (polar p7 ang1 h1) 
        ) 
  (setq p9 (polar p7 ang3 0.5) 
        p10 (polar p9 ang1 h1) 
        ) 
  (setq p11 (polar (polar p1 ang2 (/ etd 2)) ang1 h1) 
        p12 (polar p2 ang2 (/ etd 2)) 
        ) 
  (setq p13 (polar (polar p1 ang3 (/ etd 2)) ang1 h1) 
        p14 (polar p2 ang3 (/ etd 2)) 
        ) 
  (mkl p3 p4 typ) 
  (mkl p5 p6 typ) 
  (mkl p7 p8 typ) 
  (mkl p9 p10 typ) 
  (mkl p4 p8 typ) 
  (mkl p6 p10 typ) 
  (mkl p11 p12 typ) 
  (mkl p13 p14 typ) 
  (if (= typ "epin") 
    (if (> (distance p1 p2) 30) 
      (progn 
        (setq p15 (polar p11 ang2 0.25) 
              p16 (polar p15 ang1 (- (distance p1 p2) 30)) 
              p17 (polar p11 ang1 (+ (- (distance p1 p2) 30) 0.25)) 
              ) 
        (setq p18 (polar p13 ang3 0.25) 
              p19 (polar p18 ang1 (- (distance p1 p2) 30)) 
              p20 (polar p13 ang1 (+ (- (distance p1 p2) 30) 0.25)) 
              ) 
        (mkl p15 p16 "epin") 
        (mkl p16 p17 "epin") 
        (mkl p18 p19 "epin") 
        (mkl p19 p20 "epin") 
        ) 
      ) 
    ) 
  ) 
 
 
;;;此处可以做成一个子函数,可节省代码行数,但便于别人好学习,还是分开为两处子程序 
(defun make_bd(p1 p2 typ etd netd w1 h1 netdh ang1 / 0.5pi 1.5pi 2pi 
               ang2 ang3 p3 p4 p5 p6 p6 p7 p8 p9 p10 p11 p12 p13 
               p14 p15 p16 p17 p18 b1 b2 b3 b4 b5 b6 b7 b8 aa) 
  (setq 0.5pi (* pi 0.5)) 
  (setq 1.5pi (* pi 2)) 
  (setq 2pi (* pi 2)) 
  (setq P1 (trans p1 1 0)) 
  (setq P2 (trans p2 1 0)) 
  (entmake (list 
             '(0 . "LINE") 
             (cons 10 p1) 
             (cons 11 p2) 
             (cons 62 1) 
             (cons 6 "CENTER") 
             (cons 8 typ) 
             (cons 48 0.1) 
             ) 
           ) 
  (setq ang2 (nth 0 (getang ang1))) 
  (setq ang3 (nth 1 (getang ang1))) 
  (setq p3 (polar p1 ang2 w1) 
        p4 (polar p3 ang1 h1) 
        ) 
  (setq p5 (polar p3 ang2 0.25) 
        p6 (polar p5 ang1 h1) 
        ) 
  (setq p7 (polar p1 ang3 w1) 
        p8 (polar p7 ang1 h1) 
        ) 
  (setq p9 (polar p7 ang3 0.25) 
        p10 (polar p9 ang1 h1) 
        ) 
  (setq p11 (polar (polar p1 ang2 (/ netd 2)) ang1 h1) 
        p12 (polar p11 ang1 (- netdh h1 2)) 
        ) 
  (setq p13 (polar (polar p1 ang3 (/ netd 2)) ang1 h1) 
        p14 (polar p13 ang1 (- netdh h1 2)) 
        ) 
  (setq p15 (polar (polar p1 ang2 (/ etd 2)) ang1 netdh) 
        p16 (polar p15 ang1 (- (distance p1 p2) netdh)) 
        ) 
  (setq p17 (polar p15 ang3  etd) 
        p18 (polar p16 ang3  etd) 
        ) 
  (setq aa (- (distance p1 p2) netdh 30));;设置避空长度 
  (if (< aa 0) 
    (setq aa 10) 
    );;设置避空长度 
  (setq b1 (polar p11 ang2  0.25) 
        b2 (polar b1 ang1  (+ (- netdh h1) aa)) 
        ) 
  (setq b3 (polar b2 ang3  (- (+ 0.25 (/ netd 2)) (/ etd 2))) 
        b4 (polar b3 ang1  1) 
        ) 
  (setq b5 (polar b1 ang3  (* (+ 0.25 (/ netd 2)) 2)) 
        b6 (polar b2 ang3  (* (+ 0.25 (/ netd 2)) 2)) 
        ) 
  (setq b7 (polar b3 ang3  etd) 
        b8 (polar b7 ang1  1) 
        ) 
  (mkl p3 p4 typ) 
  (mkl p5 p6 typ) 
  (mkl p7 p8 typ) 
  (mkl p9 p10 typ) 
  (mkl p4 p8 typ) 
  (mkl p6 p10 typ) 
  (mkl p11 p12 typ) 
  (mkl p13 p14 typ) 
  (mkl p15 p16 typ) 
  (mkl p17 p18 typ) 
  (mkl p12 p15 typ);托斜线 
  (mkl p14 p17 typ);托斜线 
  (mkl p15 p17 typ);托平线 
  (mkl p12 p14 typ);托平线 
  (mkl b1 b2 typ);左逼空竖线 
  (mkl b3 b2 typ);左逼空横线 
  (mkl b4 b2 typ);左逼空斜线 
  (mkl b5 b6 typ);右逼空竖线 
  (mkl b7 b6 typ);右逼空横线 
  (mkl b8 b6 typ);右逼空斜线 
  ) 
   
 
 
;;或取另外两个角度ANG2为左边的角度，ANG3为右边的 
(defun getang(ang1 / ang2 ang3) 
  (cond        ((and (< ang1 0.5pi) (>= ang1 0)) 
         (setq ang2 (+ ang1 0.5pi)) 
         (setq ang3 (- ang2 pi)) 
        ) 
        ((and (>= ang1 0.5pi) (< ang1 pi)) 
         (setq ang2 (+ ang1 0.5pi)) 
         (setq ang3 (- ang1 0.5pi)) 
        ) 
        ((and (<= ang1 1.5pi) (>= ang1 pi)) 
         (setq ang2 (+ ang1 0.5pi)) 
         (setq ang3 (- ang1 0.5pi)) 
        ) 
        ((and (< ang1 2pi) (> ang1 1.5pi)) 
         (setq ang3 (- ang1 0.5pi)) 
         (setq ang2 (- ang3 pi)) 
        ) 
        ) 
  (list ang2 ang3) 
  ) 
   
 
 
 
 
;自定义函数,取两点与图层,生成一条直线 
(defun mkl (pt1 pt2 lay /) 
  (entmake (list '(0 . "LINE") 
                 (cons 10 pt1) 
                 (cons 11 pt2) 
                 (cons 8 lay) 
           ) 
  ) 
)

该贴已经同步到邹锋的微博

lostbalance · 发表于 2014-6-24 20:06:23

好东西，感谢分享

海盗曹 · 发表于 2014-6-25 09:48:34

留下脚印，以备学习

ynhh · 发表于 2014-6-25 10:20:11

自动化顶针

很牛啊

风雨依然 · 发表于 2014-6-25 11:47:47

下载收藏了

CY建筑师 · 发表于 2014-6-25 12:57:31

留脚印留脚印

emk · 发表于 2014-6-25 18:31:55

必须支持！！

潇湘飞雨 · 发表于 2014-6-26 16:24:13

好强大啊收藏先！

陈亚娣 · 发表于 2014-6-27 14:56:55

支持楼主的源码精神

xhq1954425 · 发表于 2014-6-27 14:59:11

支持楼主的源码精神

账号		自动登录	找回密码
密码			注册

[基础] 我也玩玩山寨,哈哈,DCL 控件

本帖子中包含更多资源

点评

评分

本帖被以下淘专辑推荐: