[原创]：树苗木标注

aeo · 发表于 2003-5-23 01:12:50

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

请大家试用,不好就不往下写了,而且近期没时间
特别是雪晴斑竹,树种是你提供.

(defun dxf(a b)(cdr(assoc a b)))
(defun ch-smmc( / )
(if (/= ""(car $smmc))
(setq up(strcat(car $smmc)
(if(/= ""(cadr $smmc))(strcat ",S="(cadr $smmc))"")
(if(/= ""(caddr $smmc))(strcat ","(caddr $smmc))"") )
down ""
down(strcat down (if(/= ""(car $smts))(strcat "D="(car $smts))""))
down(strcat down(if(/= ""(cadr $smts))(strcat(if(/= down "")",""") "W="(cadr $smts))""))
down(strcat down(if(/= ""(caddr $smts))(strcat(if(/= down "")",""") "H="(caddr $smts))""))
))
)
;;;;;----
(defun smmc( / a id_dia what b e $li-qmmc $li-gmmc do-ok do-get addtolist)
(defun do-ok()
(if(= ""(get_tile "t-mc"))(set_tile "text""名称不能为空")
(progn(setq $smmc (list(get_tile"t-mc")(get_tile"t-sl")(get_tile"t-sm"))
$smts (list(get_tile"t-d")(get_tile"t-w")(get_tile"t-h"))
)
(done_dialog 1)
)))
(defun do-get()
(get-smmc (car(entsel)) nil)
)
(defun addtolist()
(start_list "listsm")
(mapcar 'add_list $qm-gm)
(end_list)
)
(setq $li-qmmc '("无患子" "雪松" "日本柳杉" "香樟" "日本早樱" "广玉兰" "桂花" "杜英" "银杏"
"合欢" "马褂木" "水杉" "垂柳" "白玉兰" "深山含笑" "乐昌含笑" "榉树" "七叶树"
"油松" "黑松" "白皮松" "湿地松" "南洋杉" "侧柏" "圆柏" "金钱松" "赤松" "池杉"
"白兰花" "青冈轹" "榕树" "女贞" "棕榈" "鹅掌秋" "国槐" "枫香" "悬铃木" "青杨"
"朴树" "旱柳" "乌桕" "白桦" "枫杨" "楝树" "元宝枫" "三角枫" "樱花" "栾树"
"臭椿" "白蜡")
$li-gmmc '("杜鹃" "连翘" "洒金珊瑚" "金叶女贞" "红花继木" "茶梅" "月季" "云南黄馨" "栀子"
"龟背冬青" "金丝桃" "贴梗海棠" "六月雪" "小叶黄杨" "八角金盘" "小腊" "龙柏"
"金边绣线菊" "南天竹"))
(setq a '("t-mc""t-sl""t-sm") b '("t-d""t-w""t-h")what 10)
(if(< (setq id_dia(load_dialog "smmc.dcl"))0)(exit))
(while (< 2 what)
(new_dialog "smtj" id_dia)
(if(not $qm-gm)(setq $qm-gm $li-qmmc))
(if(equal $qm-gm $li-qmmc)(set_tile "qm-gm""qm")(set_tile "qm-gm""gm") )
(addtolist)
(action_tile "listsm" "(set_tile "t-mc"(nth(atoi(get_tile "listsm")) $qm-gm))")
(action_tile "qm" "(setq $qm-gm $li-qmmc)(addtolist)")
(action_tile "gm" "(setq $qm-gm $li-gmmc)(addtolist)")
(mapcar '(lambda(x y)(set_tile x y)) a $smmc)
(mapcar '(lambda(x y)(set_tile x y)) b $smts)
(action_tile "get" "(done_dialog 3)")
(action_tile "accept" "(do-ok)")
(setq what(start_dialog))
(if(= what 3)(do-get))
)
(unload_dialog id_dia)
)
;;;-------
(defun c:sm (/ p0 p1 p2 up down ins-to-screen e f)
(defun ins-to-screen (p0 p1 p2 / box dis e e1 e1n e2 e2n p11 p22 p33 p44)
(if (/= up "")
(progn
(command "insert" "$_smmc" p1 "1" "1" "0" up (if (/= "" down)
down
""
)
)
(setq e (entget (entlast)))
(entmod (setq e (subst
(cons 8 "$SMMC")
(assoc 8 e)
e
)
)
)
(vla-GetBoundingBox (vlax-ename->vla-object (entlast)) 'e 'f)
(setq dis (- (car (vlax-safearray->list f)) (car
(vlax-safearray->list e)
)
)
)
(if (> (car p1) (car p2))
(progn
(setq e (entlast)
e1 (entnext e)
e1n (entget e1)
e2 (entnext e1)
e2n (entget e2)
p11 (dxf 10 e1n)
p22 (dxf 10 e2n)
p33 (polar p11 pi (+ dis 600))
p44 (polar p22 pi (+ dis 600))
)
(entmod (setq e1n (subst
(cons 10 p33)
(assoc 10 e1n)
e1n
)
)
)
(entmod (setq e2n (subst
(cons 10 p44)
(assoc 10 e2n)
e2n
)
)
)
(entupd e)
(command "pline" (polar p1 pi (+ dis 400)) p1 (if p0
p0
) ^c
)
)
(command "pline" (polar p1 0 (+ dis 400)) p1 (if p0
p0
) ^C
)
)
(setq e (entget (entlast)))
(entmod (setq e (subst
(cons 8 "$SMMC")
(assoc 8 e)
e
)
)
)
)
)
)
(if (not $smmc)
(setq $smmc '("" ""
""
)
$smts '("" ""
""
)
)
)
(if (= "" (car $smmc))
(progn
(smmc)
(ch-smmc)
)
)
(setq p0 t)
(while (and
p0
(not (listp p0))
(/= "" (car $smmc))
)
(initget "S")
(setq p0 (getpoint "\nStart(S设置)"))
(if (= p0 "S")
(progn
(smmc)
(ch-smmc)
)
)
)
(if (and
p0
(setq p1 (getpoint p0 "NEXT:"))
)
(progn
(setq p2 (getpoint p1 "NEXT:"))
(if (not p2)
(setq p2 p1
p1 p0
p0 nil
)
)
(ch-smmc)
(command "undo" "group")
(ins-to-screen p0 p1 p2)
(command "undo" "end")
)
)
(princ)
)
;;; -----------
(defun get-smmc (e how / a b c e e1 e1n e2 e2n en len li1 name1 name2 no)
(if (and
(setq en (entget e))
(dxf 2 en)
(= (strcase (dxf 2 en)) "$_SMMC")
)
(progn
(setq li1 '())
(setq e1 (entnext e)
e1n (entget e1)
e2 (entnext e1)
e2n (entget e2)
)
(setq name1 (dxf 1 e1n)
name2 (dxf 1 e2n)
) ;
(while (setq no (vl-string-search "," name1))
(setq li1 (cons (substr name1 1 no) li1)
name1 (substr name1 (+ no 2))
)
)
(if (/= "" name1)
(setq li1 (cons name1 li1))
)
(setq li1 (reverse li1)
len (length li1)
)
(cond
((= len 1)
(setq $smmc li1)
)
((= len 2)
(setq $smmc (if (and
(setq sec (cadr li1))
(wcmatch sec "S=*")
)
(list (car li1) (substr sec 3) "")
(list (car li1) "" sec)
)
)
)
((= len 3)
(setq $smmc (list (car li1) (substr (cadr li1) 3) (caddr li1)))
)
) ;
(setq li1 '())
(while (setq no (vl-string-search "," name2))
(setq li1 (cons (substr name2 1 no) li1)
name2 (substr name2 (+ no 2))
)
)
(if (/= "" name2)
(setq li1 (cons name2 li1))
)
(setq li1 (reverse li1)
len (length li1)
)
(foreach x li1
(cond
((wcmatch x "D=*")
(setq a (substr x 3))
)
((wcmatch x "W=*")
(setq b (substr x 3))
)
((wcmatch x "H=*")
(setq c (substr x 3))
)
)
)
(setq $smts (list (if a
a
""
) (if b
b
""
) (if c
c
""
)
)
) ;
(if how
(progn
(smmc)
(ch-smmc)
(if (/= up "")
(entmod (setq e1n (subst
(cons 1 up)
(assoc 1 e1n)
e1n
)
)
)
)
(entmod (setq e2n (subst
(cons 1 down)
(assoc 1 e2n)
e2n
)
)
)
(entupd e)
)
)
)
)
)
;;; --------------
(defun c:csm (/ up down e en)
(command "undo" "group")
(if (and
(setq e (car (entsel)))
(setq en (entget e))
(dxf 2 en)
(= (strcase (dxf 2 en)) "$_SMMC")
)
(get-smmc e t)
)
(command "undo" "end")
(princ)
)

(defun dxf(a b)(cdr(assoc a b))) 
(defun ch-smmc( / ) 
  (if (/= ""(car $smmc)) 
          (setq up(strcat(car $smmc) 
                          (if(/= ""(cadr $smmc))(strcat ",S="(cadr $smmc))"") 
                          (if(/= ""(caddr $smmc))(strcat ","(caddr $smmc))"")   ) 
                down "" 
                down(strcat down (if(/= ""(car $smts))(strcat "D="(car $smts))"")) 
                down(strcat down(if(/= ""(cadr $smts))(strcat(if(/=  down "")",""") "W="(cadr $smts))"")) 
                down(strcat down(if(/= ""(caddr $smts))(strcat(if(/=  down "")",""") "H="(caddr $smts))""))      
     )) 
 ) 
;;;;;---- 
(defun smmc( / a id_dia what b e $li-qmmc  $li-gmmc do-ok do-get addtolist) 
 (defun do-ok() 
  (if(= ""(get_tile "t-mc"))(set_tile "text""名称不能为空") 
     (progn(setq $smmc (list(get_tile"t-mc")(get_tile"t-sl")(get_tile"t-sm")) 
                 $smts (list(get_tile"t-d")(get_tile"t-w")(get_tile"t-h")) 
            ) 
           (done_dialog 1) 
  ))) 
 (defun do-get() 
   (get-smmc (car(entsel)) nil) 
 ) 
 (defun addtolist() 
  (start_list "listsm") 
  (mapcar 'add_list $qm-gm) 
  (end_list) 
 ) 
 (setq $li-qmmc '("无患子" "雪松" "日本柳杉" "香樟" "日本早樱" "广玉兰" "桂花" "杜英" "银杏" 
                  "合欢" "马褂木" "水杉" "垂柳" "白玉兰" "深山含笑" "乐昌含笑" "榉树" "七叶树" 
                  "油松" "黑松" "白皮松" "湿地松" "南洋杉" "侧柏" "圆柏" "金钱松" "赤松" "池杉" 
                  "白兰花" "青冈轹" "榕树" "女贞" "棕榈" "鹅掌秋" "国槐" "枫香" "悬铃木" "青杨" 
                  "朴树" "旱柳" "乌桕" "白桦" "枫杨" "楝树" "元宝枫" "三角枫" "樱花" "栾树" 
                  "臭椿" "白蜡") 
       $li-gmmc '("杜鹃" "连翘" "洒金珊瑚" "金叶女贞" "红花继木" "茶梅" "月季" "云南黄馨" "栀子" 
                  "龟背冬青" "金丝桃" "贴梗海棠" "六月雪" "小叶黄杨" "八角金盘" "小腊" "龙柏" 
                  "金边绣线菊" "南天竹")) 
 (setq a '("t-mc""t-sl""t-sm") b '("t-d""t-w""t-h")what 10) 
 (if(< (setq id_dia(load_dialog  "smmc.dcl"))0)(exit)) 
(while (< 2 what) 
 (new_dialog "smtj" id_dia) 
 (if(not $qm-gm)(setq $qm-gm $li-qmmc)) 
 (if(equal $qm-gm $li-qmmc)(set_tile "qm-gm""qm")(set_tile "qm-gm""gm") ) 
 (addtolist) 
 (action_tile "listsm" "(set_tile "t-mc"(nth(atoi(get_tile "listsm")) $qm-gm))") 
 (action_tile "qm" "(setq $qm-gm $li-qmmc)(addtolist)") 
 (action_tile "gm" "(setq $qm-gm $li-gmmc)(addtolist)") 
 (mapcar '(lambda(x y)(set_tile x y)) a $smmc) 
 (mapcar '(lambda(x y)(set_tile x y)) b $smts) 
 (action_tile "get" "(done_dialog 3)") 
 (action_tile "accept" "(do-ok)") 
 (setq what(start_dialog)) 
 
 (if(= what 3)(do-get)) 
) 
 (unload_dialog id_dia) 
) 
;;;------- 
(defun c:sm (/ p0 p1 p2 up down ins-to-screen e f) 
  (defun ins-to-screen (p0 p1 p2 / box dis e e1 e1n e2 e2n p11 p22 p33 p44) 
    (if (/= up "") 
      (progn 
        (command "insert" "$_smmc" p1 "1" "1" "0" up (if (/= "" down) 
                                                       down 
                                                       "" 
                                                     ) 
        ) 
        (setq e (entget (entlast))) 
        (entmod (setq e (subst 
                          (cons 8 "$SMMC") 
                          (assoc 8 e) 
                          e 
                        ) 
                ) 
        ) 
        (vla-GetBoundingBox (vlax-ename->vla-object (entlast)) 'e 'f) 
        (setq dis (- (car (vlax-safearray->list f)) (car 
                                                         (vlax-safearray->list e) 
                                                    ) 
                  ) 
        ) 
        (if (> (car p1) (car p2)) 
          (progn 
            (setq e (entlast) 
                  e1 (entnext e) 
                  e1n (entget e1) 
                  e2 (entnext e1) 
                  e2n (entget e2) 
                  p11 (dxf 10 e1n) 
                  p22 (dxf 10 e2n) 
                  p33 (polar p11 pi (+ dis 600)) 
                  p44 (polar p22 pi (+ dis 600)) 
            ) 
            (entmod (setq e1n (subst 
                                (cons 10 p33) 
                                (assoc 10 e1n) 
                                e1n 
                              ) 
                    ) 
            ) 
            (entmod (setq e2n (subst 
                                (cons 10 p44) 
                                (assoc 10 e2n) 
                                e2n 
                              ) 
                    ) 
            ) 
            (entupd e) 
            (command "pline" (polar p1 pi (+ dis 400)) p1 (if p0 
                                                            p0 
                                                          ) ^c 
            ) 
          ) 
          (command "pline" (polar p1 0 (+ dis 400)) p1 (if p0 
                                                         p0 
                                                       ) ^C 
          ) 
        ) 
        (setq e (entget (entlast))) 
        (entmod (setq e (subst 
                          (cons 8 "$SMMC") 
                          (assoc 8 e) 
                          e 
                        ) 
                ) 
        ) 
      ) 
    ) 
  ) 
  (if (not $smmc) 
    (setq $smmc '("" "" 
           "" 
          ) 
          $smts '("" "" 
           "" 
          ) 
    ) 
  ) 
  (if (= "" (car $smmc)) 
    (progn 
      (smmc) 
      (ch-smmc) 
    ) 
  ) 
  (setq p0 t) 
  (while (and 
           p0 
           (not (listp p0)) 
           (/= "" (car $smmc)) 
         ) 
    (initget "S") 
    (setq p0 (getpoint "\nStart(S设置)")) 
    (if (= p0 "S") 
      (progn 
        (smmc) 
        (ch-smmc) 
      ) 
    ) 
  ) 
  (if (and 
        p0 
        (setq p1 (getpoint p0 "NEXT:")) 
      ) 
    (progn 
      (setq p2 (getpoint p1 "NEXT:")) 
      (if (not p2) 
        (setq p2 p1 
              p1 p0 
              p0 nil 
        ) 
      ) 
      (ch-smmc) 
      (command "undo" "group") 
      (ins-to-screen p0 p1 p2) 
      (command "undo" "end") 
    ) 
  ) 
  (princ) 
) 
;;; ----------- 
(defun get-smmc (e how / a b c e e1 e1n e2 e2n en len li1 name1 name2 no) 
  (if (and 
        (setq en (entget e)) 
        (dxf 2 en) 
        (= (strcase (dxf 2 en)) "$_SMMC") 
      ) 
    (progn 
      (setq li1 '()) 
      (setq e1 (entnext e) 
            e1n (entget e1) 
            e2 (entnext e1) 
            e2n (entget e2) 
      ) 
      (setq name1 (dxf 1 e1n) 
            name2 (dxf 1 e2n) 
      )                                       ; 
      (while (setq no (vl-string-search "," name1)) 
        (setq li1 (cons (substr name1 1 no) li1) 
              name1 (substr name1 (+ no 2)) 
        ) 
      ) 
      (if (/= "" name1) 
        (setq li1 (cons name1 li1)) 
      ) 
      (setq li1 (reverse li1) 
            len (length li1) 
      ) 
      (cond 
        ((= len 1) 
          (setq $smmc li1) 
        ) 
        ((= len 2) 
          (setq $smmc (if (and 
                            (setq sec (cadr li1)) 
                            (wcmatch sec "S=*") 
                          ) 
                        (list (car li1) (substr sec 3) "") 
                        (list (car li1) "" sec) 
                      ) 
          ) 
        ) 
        ((= len 3) 
          (setq $smmc (list (car li1) (substr (cadr li1) 3) (caddr li1))) 
        ) 
      )                                       ; 
      (setq li1 '()) 
      (while (setq no (vl-string-search "," name2)) 
        (setq li1 (cons (substr name2 1 no) li1) 
              name2 (substr name2 (+ no 2)) 
        ) 
      ) 
      (if (/= "" name2) 
        (setq li1 (cons name2 li1)) 
      ) 
      (setq li1 (reverse li1) 
            len (length li1) 
      ) 
      (foreach x li1 
        (cond 
          ((wcmatch x "D=*") 
            (setq a (substr x 3)) 
          ) 
          ((wcmatch x "W=*") 
            (setq b (substr x 3)) 
          ) 
          ((wcmatch x "H=*") 
            (setq c (substr x 3)) 
          ) 
        ) 
      ) 
      (setq $smts (list (if a 
                          a 
                          "" 
                        ) (if b 
                            b 
                            "" 
                          ) (if c 
                              c 
                              "" 
                            ) 
                  ) 
      )                                       ; 
      (if how 
        (progn 
          (smmc) 
          (ch-smmc) 
          (if (/= up "") 
            (entmod (setq e1n (subst 
                                (cons 1 up) 
                                (assoc 1 e1n) 
                                e1n 
                              ) 
                    ) 
            ) 
          ) 
          (entmod (setq e2n (subst 
                              (cons 1 down) 
                              (assoc 1 e2n) 
                              e2n 
                            ) 
                  ) 
          ) 
          (entupd e) 
        ) 
      ) 
    ) 
  ) 
) 
;;; -------------- 
(defun c:csm (/ up down e en) 
  (command "undo" "group") 
  (if (and 
        (setq e (car (entsel))) 
        (setq en (entget e)) 
        (dxf 2 en) 
        (= (strcase (dxf 2 en)) "$_SMMC") 
      ) 
    (get-smmc e t) 
  ) 
  (command "undo" "end") 
  (princ) 
)

下面是要的dcl和dwg,拷到cad路径里.

aeo · 发表于 2003-5-23 01:15:18

用法
sm标
csm改
可以从图上抓属性.

要扩充树种,在上面树种里加.

我不搞园林,所以不知道要什么.

eachy · 发表于 2003-5-23 13:11:41

最初由 aeo 发布
[B]用法
sm标
csm改
可以从图上抓属性.

要扩充树种,在上面树种里加.

我不搞园林,所以不知道要什么. [/B]

呵呵，我也改了个。

http://www.xdcad.net/forum/showt ... d=286216#post286216

程序完成后将公布源码，不过不再免费，想看的多挣积分吧。

ctiger · 发表于 2003-5-24 09:16:23

辛苦了 ,继续写吧,谢谢!

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

[原创]：树苗木标注

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子

浏览过的版块