[1201]怎样编写一个梯形的面积计算列式呢?

taner

我測試怎麽沒發現問題呢?

二位老兄,將源碼貼出來吧!

確實有問題，修改了一下：

[PHP](defun c:test (/ h  l1 l2 mj        polygon        pt1 pt2        pt3 pt4        ptlist
               str)
  (setq ptlist (vertexs (car (setq polygon (entsel "\n請點選梯形:")))))
  ;|(setq        ptlist
         (massoc 10
                 (entget (car (setq polygon (entsel "\n請點選梯形:"))))
         )
  )|;
  (setq mj (vlax-curve-getarea (car polygon)))
  (setq        pt1 (nth 0 ptlist)
        pt2 (nth 1 ptlist)
        pt3 (nth 2 ptlist)
        pt4 (nth 3 ptlist)
  )
  (if (inters
        pt1 pt2        pt3 pt4        nil)

    (if        (inters
          pt1 pt3 pt2 pt4 nil)

      (setq l1 (max
                 (distance pt1 pt4)
                 (distance pt2 pt3)
               )
            l2 (min
                 (distance pt1 pt4)
                 (distance pt2 pt3)
               )
      )
    )
    (setq l1 (max
               (distance pt1 pt2)
               (distance pt3 pt4)
             )
          l2 (min
               (distance pt1 pt2)
               (distance pt3 pt4)
             )
    )
  )
  (setq h (/ (* mj 2) (+ l1 l2)))
  (setq        str (strcat "L1="
                    (rtos l1)
                    "&L2="
                    (rtos l2)
                    "&H="
                    (rtos h)
                    "&S=("
                    (rtos l1)
                    "+"
                    (rtos l2)
                    ")*"
                    (rtos h)
                    "/2="
                    (rtos mj)
            )
  )
  (command "TEXT" "J" "C" (GE_CENTROID ptlist) "" "" str)
  (princ)
)[/PHP]

獲取頂點函數
[PHP](defun vertexs (ename / plist pp n)
  (setq obj (vlax-ename->vla-object ename))
  (setq        plist (vlax-safearray->list
                (vlax-variant-value
                  (vla-get-coordinates obj)
                )
              )
  )
  (setq n 0)
  (repeat (/ (length plist) 2)
    (setq pp (append
               pp
               (list (list (nth n plist) (nth (1+ n) plist)))
             )
    )
    (setq n (+ n 2))
  )
  pp
)[/PHP]
老外寫的質心函數
[PHP];; ******************************************************************************
;; GE_centroid
;; ******************************************************************************
;; Determine centroid of a polygon
;;
;; Algorithm:
;; 1. Form trapezoids by dropping lines from each segment to a basey axis.
;; 2. Calculate the area and CG of the triangle and rectangle in each trapezoid
;; 3. Sums up weighted moments against given axes in X and Y direction
;;    (may use x and y axes if number is small)
;; 4. Derived CG by dividing weighted sum by total area.
;; ! (C) 1999-2004, Four Dimension Technologies, Bangalore
;; ! e-mail   : rakesh.rao@4d-technologies.com
;; ! Web      : www.4d-technologies.com
;; ! ****************************************************************************

(defun GE_centroid (vlist  /          segno         n        ttl_area      basex
                    basey  p1          p2         x1        x2     y1     y2
                    t_x           t_y          t_area t_xm        t_ym   r_x    r_y
                    r_area r_xm          r_ym         Mx        My
                   )
  (setq
    vlist    (append vlist (list (car vlist)))
    segno    (1- (length vlist))        ; no of segments
    n             0
    Ttl_Area 0.0                        ; total area
    Mx             0.0                        ; Sum of moment to basex line
    My             0.0                        ; Sum of moment to basey line
    basex    (car (nth 0 vlist))        ; arbitrary axes (will reduce error for large numbers)
    basey    (cadr (nth 0 vlist))
  )

  (repeat segno
    (setq
      p1       (nth n vlist)                ; process current segment
      p2       (nth (1+ n) vlist)
      x1       (car p1)
      y1       (cadr p1)
      x2       (car p2)
      y2       (cadr p2)

                                        ; For the triangle
      t_x      (- (* (+ x2 x2 x1) 0.333333) basex) ; cg of trianlge
      t_y      (- (* (+ y1 y1 y2) 0.333333) basey)
      t_area   (* (- y2 y1) (- x2 x1) 0.5) ; area of triangle
      t_xm     (* t_area t_x)                ; moment to Basex
      t_ym     (* t_area t_y)                ; moment to basey

                                        ; For the rectangle
      r_x      (- (/ (+ x1 x2) 2) basex) ; CG of rectangle
      r_y      (- (/ (+ basey y1) 2) basey)
      r_area   (* (- x2 x1) (- y1 basey)) ; area of rectangle
      r_xm     (* r_area r_x)                ; moment to basex
      r_ym     (* r_area r_y)                ; moment to basey

      Ttl_Area (+ Ttl_Area t_area r_area)
      Mx       (+ Mx t_xm r_xm)                ; adds up moments to basex
      My       (+ My t_ym r_ym)                ; adds up moments to basey
      n               (1+ n)
    )
  )
  (list        (+ (/ Mx Ttl_Area) basex)
        (+ (/ My Ttl_Area) basey)
        0.0
  )
)
[/PHP]
測試結果如圖：(還是有問題，等會再改）

xyp1964

最初由 狂刀 发布
[B]ｘｙｐ，我测试怎么老说不是梯形呢？
发一个自己写的，
支持多点梯形多义线，
支持多义线起点任意位置．
自动识别梯形
支持预选
可指定文字标注位置．
命令：txbz [/B]

测试狂刀的程序:

1. [FONT=courier new]
   
2. 命令:
   
3. 命令: (LOAD "F:/BLOCK/LSP/txbz-狂刀.VLX") nil
   
4. 
   
5. 命令: txbz
   
6. 选择梯形:
   
7. 选择对象:
   
8. 
   
9. 绘图比例<1:>: 1: ; 错误: 参数类型错误: numberp: nil
   
10. [/FONT]

复制代码

加载程序时最好能直接显示程序执行的命令，时间长了就忘了。
“参数类型错误”是否因为“绘图比例的设置”没有放到程序前面作判断？
偶的程序已作修改，是CAD本身计算误差的BUG。

xyp1964

最初由 taner 发布
[B]我測試怎麽沒發現問題呢?
二位老兄,將源碼貼出來吧!
確實有問題，修改了一下：
[/B]

问题：
1、只支持四点纯粹梯形。
2、未作梯形真伪判断，非梯形也标注，三角形出错。

taner程序修改（只支持4点梯形）：

2. [FONT=courier new]
   
3. (defun c:test (/ h l1 l2 mj polygon pt1 pt2 pt3 pt4 ptlist str)
   
4.   (setq        ptlist (vertexs (car (setq polygon (entsel "\n請點選梯形:"))))
   
5.         mj     (vlax-curve-getarea (car polygon))
   
6.         pt1    (nth 0 ptlist)
   
7.         pt2    (nth 1 ptlist)
   
8.         pt3    (nth 2 ptlist)
   
9.         pt4    (nth 3 ptlist)
   
10.   )
    
11.   ;;判断是否平行
    
12.   (if (inters pt1 pt2 pt3 pt4 nil)
    
13.     (if        (not (inters pt1 pt3 pt2 pt4 nil))
    
14.       (setq l1 (max (distance pt1 pt4)
    
15.                     (distance pt2 pt3)
    
16.                )
    
17.             l2 (min (distance pt1 pt4)
    
18.                     (distance pt2 pt3)
    
19.                )
    
20.       )
    
21.     )
    
22.     (setq l1 (max
    
23.                (distance pt1 pt2)
    
24.                (distance pt3 pt4)
    
25.              )
    
26.           l2 (min
    
27.                (distance pt1 pt2)
    
28.                (distance pt3 pt4)
    
29.              )
    
30.     )
    
31.   )
    
32.   (if (and l1 l2)
    
33.     (progn
    
34.       (setq h        (/ (* mj 2) (+ l1 l2))
    
35.             str        (strcat        "L1="
    
36.                         (rtos l1)
    
37.                         "&L2="
    
38.                         (rtos l2)
    
39.                         "&H="
    
40.                         (rtos h)
    
41.                         "&S=("
    
42.                         (rtos l1)
    
43.                         "+"
    
44.                         (rtos l2)
    
45.                         ")*"
    
46.                         (rtos h)
    
47.                         "/2="
    
48.                         (rtos mj)
    
49.                 )
    
50.       )
    
51.       (command "TEXT"
    
52.                "J"
    
53.                "C"
    
54.                (inters pt1 pt2 pt3 pt4 nil)
    
55.                ""
    
56.                ""
    
57.                str
    
58.       )
    
59.     )
    
60.     (princ "\n非梯形!")
    
61.   )
    
62.   (princ)
    
63. )
    
64. ;;;獲取頂點函數
    
65. (defun vertexs (ename / plist pp n)
    
66.   (setq obj (vlax-ename->vla-object ename))
    
67.   (setq        plist (vlax-safearray->list
    
68.                 (vlax-variant-value
    
69.                   (vla-get-coordinates obj)
    
70.                 )
    
71.               )
    
72.   )
    
73.   (setq n 0)
    
74.   (repeat (/ (length plist) 2)
    
75.     (setq pp (append
    
76.                pp
    
77.                (list (list (nth n plist) (nth (1+ n) plist)))
    
78.              )
    
79.     )
    
80.     (setq n (+ n 2))
    
81.   )
    
82.   pp
    
83. )[/FONT]

[FONT=courier new]<br /> (defun c:test (/ h l1 l2 mj polygon pt1 pt2 pt3 pt4 ptlist str)<br />   (setq        ptlist (vertexs (car (setq polygon (entsel "\n請點選梯形:"))))<br />         mj     (vlax-curve-getarea (car polygon))<br />         pt1    (nth 0 ptlist)<br />         pt2    (nth 1 ptlist)<br />         pt3    (nth 2 ptlist)<br />         pt4    (nth 3 ptlist)<br />   )<br />   ;;判断是否平行<br />   (if (inters pt1 pt2 pt3 pt4 nil)<br />     (if        (not (inters pt1 pt3 pt2 pt4 nil))<br />       (setq l1 (max (distance pt1 pt4)<br />                     (distance pt2 pt3)<br />                )<br />             l2 (min (distance pt1 pt4)<br />                     (distance pt2 pt3)<br />                )<br />       )<br />     )<br />     (setq l1 (max<br />                (distance pt1 pt2)<br />                (distance pt3 pt4)<br />              )<br />           l2 (min<br />                (distance pt1 pt2)<br />                (distance pt3 pt4)<br />              )<br />     )<br />   )<br />   (if (and l1 l2)<br />     (progn<br />       (setq h        (/ (* mj 2) (+ l1 l2))<br />             str        (strcat        "L1="<br />                         (rtos l1)<br />                         "&L2="<br />                         (rtos l2)<br />                         "&H="<br />                         (rtos h)<br />                         "&S=("<br />                         (rtos l1)<br />                         "+"<br />                         (rtos l2)<br />                         ")*"<br />                         (rtos h)<br />                         "/2="<br />                         (rtos mj)<br />                 )<br />       )<br />       (command "TEXT"<br />                "J"<br />                "C"<br />                (inters pt1 pt2 pt3 pt4 nil)<br />                ""<br />                ""<br />                str<br />       )<br />     )<br />     (princ "\n非梯形!")<br />   )<br />   (princ)<br /> )<br /> ;;;獲取頂點函數<br /> (defun vertexs (ename / plist pp n)<br />   (setq obj (vlax-ename->vla-object ename))<br />   (setq        plist (vlax-safearray->list<br />                 (vlax-variant-value<br />                   (vla-get-coordinates obj)<br />                 )<br />               )<br />   )<br />   (setq n 0)<br />   (repeat (/ (length plist) 2)<br />     (setq pp (append<br />                pp<br />                (list (list (nth n plist) (nth (1+ n) plist)))<br />              )<br />     )<br />     (setq n (+ n 2))<br />   )<br />   pp<br /> )[/FONT]

思路：
[php]
1、选择（支持多选）多段线（*POLYLINE）判断是否闭合或首尾相连，是→继续。
2、取其顶点集，删除直线段上的所有顶点，如果首尾相连则删除首尾中的一个点，判断最后顶点数是否为4，是→继续。
3、判断剩余4点中是否存在平行线，是→继续。
4、计算平行线的长度、梯形高度、面积公式→完成标注。
[/php]

taner

再修改：
獲取頂點函數VERTEXS見前貼.

[PHP]
(defun c:test
       (/ h mj interpoint l1 l2 polygon pt1 pt2 pt3 pt4 ptlist str)
  (setq ptlist (vertexs (car (setq polygon (entsel "\n請點選梯形:")))))
  (setq mj (vlax-curve-getarea (car polygon)))
  (setq        pt1 (nth 0 ptlist)
        pt2 (nth 1 ptlist)
        pt3 (nth 2 ptlist)
        pt4 (nth 3 ptlist)
  )
  (if (inters
        pt1 pt2        pt3 pt4        nil)
    (princ "\n相交")
    (progn (setq l1 (max
                      (distance pt1 pt2)
                      (distance pt3 pt4)
                    )
                 l2 (min
                      (distance pt1 pt2)
                      (distance pt3 pt4)
                    )
           )
           (if (setq interspoint (inters pt1 pt4 pt2 pt3 t))
             interspoint
             (setq interspoint (inters pt1 pt3 pt2 pt4 t))

           )
    )
  )
  (if (inters
        pt1 pt3        pt2 pt4        nil)
    (princ "\n相交")
    (progn (setq l1 (max
                      (distance pt1 pt3)
                      (distance pt2 pt4)
                    )
                 l2 (min
                      (distance pt1 pt3)
                      (distance pt2 pt4)
                    )
           )
           (if (setq interspoint (inters pt1 pt2 pt3 pt4 t))
             interspoint
             (setq interspoint (inters pt1 pt4 pt2 pt3 t))

           )
    )
  )
  (if (inters
        pt1 pt4        pt2 pt3        nil)
    (princ "\n相交")
    (progn (setq l1 (max
                      (distance pt1 pt4)
                      (distance pt2 pt3)
                    )
                 l2 (min
                      (distance pt1 pt4)
                      (distance pt2 pt3)
                    )
           )
           (if (setq interspoint (inters pt1 pt2 pt3 pt4 t))
             interspoint
             (setq interspoint (inters pt1 pt3 pt2 pt4 t))

           )
    )
  )
  (if (and l1 l2)
    (progn (setq h (/ (* mj 2) (+ l1 l2)))
           (setq str (strcat "L1="
                             (rtos l1)
                             "&L2="
                             (rtos l2)
                             "&H="
                             (rtos h)
                             "&S=("
                             (rtos l1)
                             "+"
                             (rtos l2)
                             ")*"
                             (rtos h)
                             "/2="
                             (rtos mj)
                     )
           )
           (command "TEXT" "J" "C" interspoint "" "" str)
    )
  )
  (princ)
)
[/PHP]

文本的中心點在梯形的對角線交點上.

xyp1964

最初由 taner 发布
[B]再修改：
獲取頂點函數VERTEXS見前貼.
(defun c:test
       (/ h mj interpoint l1 l2 polygon pt1 pt2 pt3 pt4 ptlist str)
  (setq ptlist (vertexs (car (setq polygon (entsel "\n請點選梯形:")))... [/B]

请用一楼的DWG文件测试，如果运行成功就差不多了！

xyz518mm

xyp1964版主及taner兄
真是厉害的高手,但想在要求一下是否可以将各线段长度都标上去呢
如8楼的图片但要四边的长度有显示出来~
另外小弟用过 taner 兄的版本,想请教一下是否物件要先封闭程聚合线呢,如果是这样为何不能
先制做封闭聚合线呢?还是说程序中的判断是将各线段的线长及顶点做平行及大小判断
再延伸至面积计算
因为程度差很多不知道观念对吗

xyp1964

只标线长就简单多了：

xyz518mm

版主您提供的这程式
可以换成繁体的吗
我系统跑出来的都是乱码
另外这程序还要搭配您自行开发的 xyp_lib.VLX 程序吗?

狂刀

最初由 xyp1964 发布
[B][QUOTE]最初由 狂刀 发布
[B]ｘｙｐ，我测试怎么老说不是梯形呢？
发一个自己写的，
支持多点梯形多义线，
支持多义线起点任意位置．
自动识别梯形
支持预选
可指定文字标注位置．
命令：txbz [/B][/... [/B]

忘了设初值了，第一次执行输入比例（整数）不直接回车即可

taner

最初由 xyz518mm 发布
[B]xyp1964版主及taner兄
真是厉害的高手,但想在要求一下是否可以将各线段长度都标上去呢
如8楼的图片但要四边的长度有显示出来~
另外小弟用过 taner 兄的版本,想请教一下是否物件要先封闭程聚合线呢,如果是这样为何... [/B]

小弟也正在學習中!XYP和狂刀才是真正的高手!

如果是line線,需要先聚合成多義線.我的這個程序還不能算程序.還不能解決XYP版主貼的附件中的問題.正在思考中!

xyp1964

参考程序：

2. [FONT=courier new];;;txbz(梯形标注)
   
3. (defun c:txbz ()
   
4.   (CMDLASC0)
   
5.   (setq        ss (ssget '((0 . "*POLYLINE")))
   
6.         i  -1
   
7.   )
   
8.   (while (setq s1 (ssname ss (setq i (1+ i))))
   
9.     (if        (or (= (xyp-get-DXF 70 s1) 1)
   
10.             (equal (xyp-get-CurveEndPoint s1)
    
11.                    (xyp-get-CurveStartPoint s1)
    
12.             )
    
13.         )
    
14.       (progn
    
15.         (setq ptn (xyp-get-Vertexs s1 3))
    
16.         (if (= (length ptn) 4)
    
17.           (progn
    
18.             (setq pt0  (nth 0 ptn)
    
19.                   pt1  (nth 1 ptn)
    
20.                   pt2  (nth 2 ptn)
    
21.                   pt3  (nth 3 ptn)
    
22.                   pt28 (xyp-get-MinMaxPoint s1 2)
    
23.                   aa   (vla-get-Area (vla-obj s1))
    
24.             )
    
25.             (cond ((not (inters pt0 pt1 pt2 pt3 nil))
    
26.                    (setq l1 (distance pt0 pt1)
    
27.                          l2 (distance pt3 pt2)
    
28.                    )
    
29.                    (mkla "尺寸标注" 4)
    
30.                    (subtxt pt0 pt1)
    
31.                    (subtxt pt1 pt2)
    
32.                    (subtxt pt2 pt3)
    
33.                    (subtxt pt3 pt0)
    
34.                    (setq pt01 (polar pt0 (+ (angle pt0 pt1) (* pi 0.5)) 1000)
    
35.                          pt02 (inters pt0 pt01 pt2 pt3 nil)
    
36.                          h    (distance pt0 pt02)
    
37.                    )
    
38.                    (subtxt pt0 pt02)
    
39.                    (setq txt1 (/ (* (+ l1 l2) h) 2.0)
    
40.                          txt2 (strcat "S "
    
41.                                       (rtos txt1 2 3)
    
42.                                       " = "
    
43.                                       "("
    
44.                                       (rtos l1 2 3)
    
45.                                       "＋"
    
46.                                       (rtos l2 2 3)
    
47.                                       ")"
    
48.                                       "×"
    
49.                                       (rtos h 2 3)
    
50.                                       "/"
    
51.                                       (itoa 2)
    
52.                               )
    
53.                    )
    
54.                    (xyp-Text 8 pt28 txt2)
    
55.                    (mkla "辅助线" 1)
    
56.                    (command "line" pt0 pt02 "")
    
57.                   )
    
58.                   ((not (inters pt0 pt3 pt1 pt2 nil))
    
59.                    (setq l1 (distance pt0 pt3)
    
60.                          l2 (distance pt1 pt2)
    
61.                    )
    
62.                    (mkla "尺寸标注" 4)
    
63.                    (subtxt pt0 pt1)
    
64.                    (subtxt pt1 pt2)
    
65.                    (subtxt pt2 pt3)
    
66.                    (subtxt pt3 pt0)
    
67.                    (setq pt01 (polar pt0 (+ (angle pt0 pt3) (* pi 0.5)) 1000)
    
68.                          pt02 (inters pt0 pt01 pt1 pt2 nil)
    
69.                          h    (distance pt0 pt02)
    
70.                    )
    
71.                    (subtxt pt0 pt02)
    
72.                    (setq txt1 (/ (* (+ l1 l2) h) 2.0)
    
73.                          txt2 (strcat "S "
    
74.                                       (rtos txt1 2 3)
    
75.                                       " = "
    
76.                                       "("
    
77.                                       (rtos l1 2 3)
    
78.                                       "＋"
    
79.                                       (rtos l2 2 3)
    
80.                                       ")"
    
81.                                       "×"
    
82.                                       (rtos h 2 3)
    
83.                                       "/"
    
84.                                       (itoa 2)
    
85.                               )
    
86.                    )
    
87.                    (xyp-Text 8 pt28 txt2)
    
88.                    (mkla "辅助线" 1)
    
89.                    (command "line" pt0 pt02 "")
    
90.                   )
    
91.                   (t (princ "\n非梯形!"))
    
92.             )
    
93.           )
    
94.           (princ "\n非梯形!")
    
95.         )
    
96.       )
    
97.       (princ "\n多段线不闭合!")
    
98.     )
    
99.   )
    
100.   (CMDLA1)
     
101. )
     
102. (defun subtxt (Point1 Point2 / ang)
     
103.   (setq ang (rad2ang (angle Point1 Point2)))
     
104.   (while (> ang 90)
     
105.     (setq ang (- ang 180))
     
106.   )
     
107.   (command "text"
     
108.            "j"
     
109.            "BC"
     
110.            (xyp-get-RightPoint Point1 Point2 (* sc 100))
     
111.            (* sc 300)
     
112.            ang
     
113.            (rtos (distance Point1 Point2) 2 3)
     
114.   )
     
115. )
     
116. (pxyp "txbz  (梯形标注)")[/FONT]

[FONT=courier new];;;txbz(梯形标注)<br /> (defun c:txbz ()<br />   (CMDLASC0)<br />   (setq        ss (ssget '((0 . "*POLYLINE")))<br />         i  -1<br />   )<br />   (while (setq s1 (ssname ss (setq i (1+ i))))<br />     (if        (or (= (xyp-get-DXF 70 s1) 1)<br />             (equal (xyp-get-CurveEndPoint s1)<br />                    (xyp-get-CurveStartPoint s1)<br />             )<br />         )<br />       (progn<br />         (setq ptn (xyp-get-Vertexs s1 3))<br />         (if (= (length ptn) 4)<br />           (progn<br />             (setq pt0  (nth 0 ptn)<br />                   pt1  (nth 1 ptn)<br />                   pt2  (nth 2 ptn)<br />                   pt3  (nth 3 ptn)<br />                   pt28 (xyp-get-MinMaxPoint s1 2)<br />                   aa   (vla-get-Area (vla-obj s1))<br />             )<br />             (cond ((not (inters pt0 pt1 pt2 pt3 nil))<br />                    (setq l1 (distance pt0 pt1)<br />                          l2 (distance pt3 pt2)<br />                    )<br />                    (mkla "尺寸标注" 4)<br />                    (subtxt pt0 pt1)<br />                    (subtxt pt1 pt2)<br />                    (subtxt pt2 pt3)<br />                    (subtxt pt3 pt0)<br />                    (setq pt01 (polar pt0 (+ (angle pt0 pt1) (* pi 0.5)) 1000)<br />                          pt02 (inters pt0 pt01 pt2 pt3 nil)<br />                          h    (distance pt0 pt02)<br />                    )<br />                    (subtxt pt0 pt02)<br />                    (setq txt1 (/ (* (+ l1 l2) h) 2.0)<br />                          txt2 (strcat "S "<br />                                       (rtos txt1 2 3)<br />                                       " = "<br />                                       "("<br />                                       (rtos l1 2 3)<br />                                       "＋"<br />                                       (rtos l2 2 3)<br />                                       ")"<br />                                       "×"<br />                                       (rtos h 2 3)<br />                                       "/"<br />                                       (itoa 2)<br />                               )<br />                    )<br />                    (xyp-Text 8 pt28 txt2)<br />                    (mkla "辅助线" 1)<br />                    (command "line" pt0 pt02 "")<br />                   )<br />                   ((not (inters pt0 pt3 pt1 pt2 nil))<br />                    (setq l1 (distance pt0 pt3)<br />                          l2 (distance pt1 pt2)<br />                    )<br />                    (mkla "尺寸标注" 4)<br />                    (subtxt pt0 pt1)<br />                    (subtxt pt1 pt2)<br />                    (subtxt pt2 pt3)<br />                    (subtxt pt3 pt0)<br />                    (setq pt01 (polar pt0 (+ (angle pt0 pt3) (* pi 0.5)) 1000)<br />                          pt02 (inters pt0 pt01 pt1 pt2 nil)<br />                          h    (distance pt0 pt02)<br />                    )<br />                    (subtxt pt0 pt02)<br />                    (setq txt1 (/ (* (+ l1 l2) h) 2.0)<br />                          txt2 (strcat "S "<br />                                       (rtos txt1 2 3)<br />                                       " = "<br />                                       "("<br />                                       (rtos l1 2 3)<br />                                       "＋"<br />                                       (rtos l2 2 3)<br />                                       ")"<br />                                       "×"<br />                                       (rtos h 2 3)<br />                                       "/"<br />                                       (itoa 2)<br />                               )<br />                    )<br />                    (xyp-Text 8 pt28 txt2)<br />                    (mkla "辅助线" 1)<br />                    (command "line" pt0 pt02 "")<br />                   )<br />                   (t (princ "\n非梯形!"))<br />             )<br />           )<br />           (princ "\n非梯形!")<br />         )<br />       )<br />       (princ "\n多段线不闭合!")<br />     )<br />   )<br />   (CMDLA1)<br /> )<br /> (defun subtxt (Point1 Point2 / ang)<br />   (setq ang (rad2ang (angle Point1 Point2)))<br />   (while (> ang 90)<br />     (setq ang (- ang 180))<br />   )<br />   (command "text"<br />            "j"<br />            "BC"<br />            (xyp-get-RightPoint Point1 Point2 (* sc 100))<br />            (* sc 300)<br />            ang<br />            (rtos (distance Point1 Point2) 2 3)<br />   )<br /> )<br /> (pxyp "txbz  (梯形标注)")[/FONT]

xyp1964

效果

狂刀

建议把多点的梯形自动改成４顶点的多义线

taner

最初由 狂刀 发布
[B]建议把多点的梯形自动改成４顶点的多义线 [/B]

支持!我的想法正是這樣,先將梯形轉化爲4頂點的梯形.後面的步驟前面都談過了.

xyp1964

首先要判断是否四边形：
(= (length (xyp-get-Vertexs ename 3)) 4)