点选直线靠角点的边得出对角点

csharp

还是向量运算简便

XDSoft

csharp 发表于 2014-9-5 07:22
还是向量运算简便

主要是清晰，涉及到方向的，向量都简洁。

ymcui2005

zxq0220 发表于 2014-9-4 20:58

zxq0220 老大的程序简单对我比较实用，
现在还有一个问题是右下角红色框会跑出外面能否修改。谢谢

ymcui2005

newer 发表于 2014-9-4 22:55
来个API 版本的，主要是用向量判断方向，保存默认值的。

错误: no function definition: XDRX_ENTSEL

XDSoft

ymcui2005 发表于 2014-9-5 09:00
错误: no function definition: XDRX_ENTSEL

点我签名，下载XDRX_API和晓东LISP函数库加载。

Free-Lancer

XDSoft 发表于 2014-9-5 11:09
点我签名，下载XDRX_API和晓东LISP函数库加载。

XD::Polylie:NearIndex 和 XD::Polyline:-Index+ 还有 Bug

前者在闭合曲线靠近 0 但不是 0-1区间时不对，后者在非闭合 pline 时没有判断
重新改的

1. (if (not $rectang_wid)
   
2.   (setq $rectang_wid 12.)
   
3. )
   
4. (if (not $rectang_hig)
   
5.   (setq $rectang_hig 5)
   
6. )
   
7. (defun c:tt (/ dcl fn id lst wid hig bp        e p p1 p2 p3 pams index        v vw vh
   
8.              vd        v1 v2)
   
9.   (defun Checkin (kl)
   
10.     (mapcar '(lambda (x)
    
11.                (action_tile
    
12.                  x
    
13.                  (strcat "(dcl:checkin $value \"数字\" \"" x "\"" ")")
    
14.                )
    
15.              )
    
16.             kl
    
17.     )
    
18.   )
    
19.   (setq        dcl '("temp:dialog {                      "
    
20.               "    label = \"参数输入\" ;     "
    
21.               "    :column {                  "
    
22.               "        :edit_box {            "
    
23.               "            key = \"wid\" ;    "
    
24.               "            label = \"宽度\" ; "
    
25.               "        }                      "
    
26.               "        :edit_box {            "
    
27.               "            key = \"hig\" ;    "
    
28.               "            label = \"高度\" ; "
    
29.               "        }                      "
    
30.               "    }                          "
    
31.               "    ok_only;                   "
    
32.               "    errtile;                   "
    
33.               "}                              "
    
34.              )
    
35. 
    
36.   )
    
37.   (setq        fn (dcl:make dcl)
    
38.         id (dcl:load fn "temp")
    
39.   )
    
40.   (dcl:settile
    
41.     '("wid" "hig")
    
42.     (mapcar 'vl-princ-to-string
    
43.             (list $rectang_wid $rectang_hig)
    
44.     )
    
45.   )
    
46.   (checkin '("wid" "hig"))
    
47.   (action_tile
    
48.     "accept"
    
49.     "(setq lst (dcl:gettile '(\"wid\" \"hig\")))(done_dialog)"
    
50.   )
    
51.   (dcl:start id fn)
    
52.   (if (not (member "" lst))
    
53.     (progn
    
54.       (mapcar 'set
    
55.               '($rectang_wid $rectang_hig)
    
56.               (mapcar 'distof lst)
    
57.       )
    
58.       (while
    
59.         (and
    
60.           (setq        e
    
61.                  (xdrx_entsel "\n拾取多义线转角处: " '((0 . "LWPOLYLINE")))
    
62.           )
    
63.           (setq        p     (apply 'xdrx_curve_getclosestpoint e)
    
64. 
    
65.                 index (apply 'xd::polyline:nearindex e)
    
66.                 e     (car e)
    
67.                 bp    (xdrx_curve_getpointatparam e index)
    
68.           )
    
69.           (or (vlax-curve-isclosed e)
    
70.               (and (not (vlax-curve-isclosed e))
    
71.                    (/= index (vlax-curve-getstartparam e))
    
72.                    (/= index (vlax-curve-getendparam e))
    
73.               )
    
74.           )
    
75.           (setq pams (XD::PolyLine:-Index+ e index))
    
76.           (vl-every 'zerop
    
77.                     (mapcar '(lambda (x)
    
78.                                (xdrx_polyline_getbulgeat e x)
    
79.                              )
    
80.                             (list (car pams) index)
    
81.                     )
    
82.           )
    
83.         )
    
84.          (setq v  (xdrx_vector_normalize (mapcar '- p bp))
    
85.                v1 (xdrx_vector_normalize
    
86.                     (mapcar '-
    
87.                             (xdrx_curve_getpointatparam e (car pams))
    
88.                             bp
    
89.                     )
    
90.                   )
    
91.                v2 (xdrx_vector_normalize
    
92.                     (mapcar '-
    
93.                             (xdrx_curve_getpointatparam e (cadr pams))
    
94.                             bp
    
95.                     )
    
96.                   )
    
97.          )
    
98.          (if (equal v v1 1e-3)
    
99.            (setq vw (xdrx_vector_product v $rectang_wid)
    
100.                  vh (xdrx_vector_product v2 $rectang_hig)
     
101.                  vd (mapcar '+ vw vh)
     
102.                  p1 (mapcar '+ bp vw)
     
103.                  p2 (mapcar '+ bp vh)
     
104.                  p3 (mapcar '+ bp vd)
     
105.            )
     
106.            (setq vw (xdrx_vector_product v2 $rectang_wid)
     
107.                  vh (xdrx_vector_product v1 $rectang_hig)
     
108.                  vd (mapcar '+ vw vh)
     
109.                  p1 (mapcar '+ bp vw)
     
110.                  p2 (mapcar '+ bp vh)
     
111.                  p3 (mapcar '+ bp vd)
     
112.            )
     
113.          )
     
114.          (apply 'xdrx_polyline_make (cons t (list bp p1 p3 p2)))
     
115.       )
     
116.     )
     
117.   )
     
118.   (princ)
     
119. )

(if (not $rectang_wid)<br />   (setq $rectang_wid 12.)<br /> )<br /> (if (not $rectang_hig)<br />   (setq $rectang_hig 5)<br /> )<br /> (defun c:tt (/ dcl fn id lst wid hig bp        e p p1 p2 p3 pams index        v vw vh<br />              vd        v1 v2)<br />   (defun Checkin (kl)<br />     (mapcar '(lambda (x)<br />                (action_tile<br />                  x<br />                  (strcat "(dcl:checkin $value \"数字\" \"" x "\"" ")")<br />                )<br />              )<br />             kl<br />     )<br />   )<br />   (setq        dcl '("temp:dialog {                      "<br />               "    label = \"参数输入\" ;     "<br />               "    :column {                  "<br />               "        :edit_box {            "<br />               "            key = \"wid\" ;    "<br />               "            label = \"宽度\" ; "<br />               "        }                      "<br />               "        :edit_box {            "<br />               "            key = \"hig\" ;    "<br />               "            label = \"高度\" ; "<br />               "        }                      "<br />               "    }                          "<br />               "    ok_only;                   "<br />               "    errtile;                   "<br />               "}                              "<br />              )<br /> <br />   )<br />   (setq        fn (dcl:make dcl)<br />         id (dcl:load fn "temp")<br />   )<br />   (dcl:settile<br />     '("wid" "hig")<br />     (mapcar 'vl-princ-to-string<br />             (list $rectang_wid $rectang_hig)<br />     )<br />   )<br />   (checkin '("wid" "hig"))<br />   (action_tile<br />     "accept"<br />     "(setq lst (dcl:gettile '(\"wid\" \"hig\")))(done_dialog)"<br />   )<br />   (dcl:start id fn)<br />   (if (not (member "" lst))<br />     (progn<br />       (mapcar 'set<br />               '($rectang_wid $rectang_hig)<br />               (mapcar 'distof lst)<br />       )<br />       (while<br />         (and<br />           (setq        e<br />                  (xdrx_entsel "\n拾取多义线转角处: " '((0 . "LWPOLYLINE")))<br />           )<br />           (setq        p     (apply 'xdrx_curve_getclosestpoint e)<br /> <br />                 index (apply 'xd::polyline:nearindex e)<br />                 e     (car e)<br />                 bp    (xdrx_curve_getpointatparam e index)<br />           )<br />           (or (vlax-curve-isclosed e)<br />               (and (not (vlax-curve-isclosed e))<br />                    (/= index (vlax-curve-getstartparam e))<br />                    (/= index (vlax-curve-getendparam e))<br />               )<br />           )<br />           (setq pams (XD::PolyLine:-Index+ e index))<br />           (vl-every 'zerop<br />                     (mapcar '(lambda (x)<br />                                (xdrx_polyline_getbulgeat e x)<br />                              )<br />                             (list (car pams) index)<br />                     )<br />           )<br />         )<br />          (setq v  (xdrx_vector_normalize (mapcar '- p bp))<br />                v1 (xdrx_vector_normalize<br />                     (mapcar '-<br />                             (xdrx_curve_getpointatparam e (car pams))<br />                             bp<br />                     )<br />                   )<br />                v2 (xdrx_vector_normalize<br />                     (mapcar '-<br />                             (xdrx_curve_getpointatparam e (cadr pams))<br />                             bp<br />                     )<br />                   )<br />          )<br />          (if (equal v v1 1e-3)<br />            (setq vw (xdrx_vector_product v $rectang_wid)<br />                  vh (xdrx_vector_product v2 $rectang_hig)<br />                  vd (mapcar '+ vw vh)<br />                  p1 (mapcar '+ bp vw)<br />                  p2 (mapcar '+ bp vh)<br />                  p3 (mapcar '+ bp vd)<br />            )<br />            (setq vw (xdrx_vector_product v2 $rectang_wid)<br />                  vh (xdrx_vector_product v1 $rectang_hig)<br />                  vd (mapcar '+ vw vh)<br />                  p1 (mapcar '+ bp vw)<br />                  p2 (mapcar '+ bp vh)<br />                  p3 (mapcar '+ bp vd)<br />            )<br />          )<br />          (apply 'xdrx_polyline_make (cons t (list bp p1 p3 p2)))<br />       )<br />     )<br />   )<br />   (princ)<br /> )

zxq0220

ymcui2005 发表于 2014-9-5 08:58
zxq0220 老大的程序简单对我比较实用，
现在还有一个问题是右下角红色框会跑出外面能否修改。谢谢

13楼已改，再试试

ymcui2005

zxq0220 发表于 2014-9-5 20:41
13楼已改，再试试

谢谢zxq0220老大的帮助,程序对我的帮助非常大谢谢.