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

tctabc

最初由 xyp1964 发布
[B]首先要判断是否四边形：
(= (length (xyp-get-Vertexs ename 3)) 4) [/B]

先谢谢版主的解答
版主真是利害的高手
要好好的理解一下您的程序

另在请问版主
如果要判断 弧形面积 及 三角形面积 该怎样判断呢

xyp1964

判断“三角形”的条件：
(= (length (xyp-get-Vertexs ename 3)) 3)

标三角形的面积及公式较简单，而弧形的就相对难了！

tctabc

最初由 xyp1964 发布
[B]判断“三角形”的条件：
(= (length (xyp-get-Vertexs ename 3)) 3)

标三角形的面积及公式较简单，而弧形的就相对难了！ [/B]

版主您提供的 xyp-get-Vertexs  这函数
是您自己写的是吗?
如果不用这组来判断
那可以写的出判断条件程序吗?

另外弧形的部分小弟的想法是用弧形面积公式
弧的两端连线并设为底(L).
再由线的中点垂直延伸至弧面中点,
此连接线段设为高(H).
再列出计算式为 2/3*L*H
但仍有一问题,就是此公式算法与电脑列出的面积值为少.

但也较符合手算方法

taner

思考了兩天,終於通過了一樓的測試(不能自動標注尺寸),最終的結果是將面積等信息寫在梯形的對角線的交點上.
思路:
1.先求梯形的四個角點的點表.(故這兩天收集了些表的函數).
2.四角點求出來後,思路同19樓.
3.程序中用到的子函數,見下列鏈接:(vertexs见16楼)
3.1.  http://www.xdcad.net/forum/showt ... 2444330#post2444330
3.2.  http://www.xdcad.net/forum/showthread.php?s=&threadid=496647
3.3.  http://www.xdcad.net/forum/showthread.php?s=&threadid=471571
3.4. 求四角點子程序:
[PHP](defun 4ptlist (ptlist / i j lst lst1 lst2 lst3)
  (setq i (length ptlist))
  (setq j 2)
  (setq lst (list (nth 0 ptlist) (nth 1 ptlist)))
  (while (< j i)
    (if (pd-ptlst-gx (cons (nth j ptlist) lst))
      (setq lst (cons (nth j ptlist) lst))
    )
    (setq j (1+ j))
  )
  (setq ptlist (li_subtract ptlist lst))
  (setq lst1 (list (xd-points_miny_minx lst) (xd-points_maxy_maxx lst)))
  (setq i (length ptlist))
  (setq j 2)
  (setq lst (list (nth 0 ptlist) (nth 1 ptlist)))
  (while (< j i)
    (if (pd-ptlst-gx (cons (nth j ptlist) lst))
      (setq lst (cons (nth j ptlist) lst))
    )
    (setq j (1+ j))
  )
  (setq ptlist (li_subtract ptlist lst))
  (if (pd-ptlst-gx (cons (car lst1) lst))
    (setq lst2 (cons (car lst1) lst))
  )
  (if (pd-ptlst-gx (cons (cadr lst1) lst))
    (setq lst2 (cons (cadr lst1) lst))
  )
  (setq lst2 (list (xd-points_miny_minx lst2) (xd-points_maxy_maxx lst2)))
  (setq i (length ptlist))
  (setq j 2)
  (setq lst (list (nth 0 ptlist) (nth 1 ptlist)))
  (while (< j i)
    (if (pd-ptlst-gx (cons (nth j ptlist) lst))
      (setq lst (cons (nth j ptlist) lst))
    )
    (setq j (1+ j))
  )
  (if (pd-ptlst-gx (cons (car lst1) lst))
    (setq lst3 (cons (car lst1) lst))
  )
  (if (pd-ptlst-gx (cons (cadr lst1) lst))
    (setq lst3 (cons (cadr lst1) lst))
  )
  (if lst3
    (if (pd-ptlst-gx (cons (car lst2) lst3))
      (setq lst3 (cons (car lst2) lst3))
    )
    (if (pd-ptlst-gx (cons (car lst2) lst))
      (setq lst3 (cons (car lst2) lst))
    )
  )
  (if lst3
    (if (pd-ptlst-gx (cons (cadr lst2) lst3))
      (setq lst3 (cons (cadr lst2) lst3))
    )
    (if (pd-ptlst-gx (cons (cadr lst2) lst))
      (setq lst3 (cons (cadr lst2) lst))
    )
  )
  (setq lst3 (list (xd-points_miny_minx lst3) (xd-points_maxy_maxx lst3)))
  (setq lst4 (li-union (li-union lst1 lst2) lst3))
)[/PHP]
主程序:
[PHP](defun c:test (/ h mj interpoint l1 l2 polygon pt1 pt2 pt3 pt4 str)
  (setq ptlist (vertexs (car (setq polygon (entsel "\n請點選梯形:")))))
  (setq ptlist (4ptlist ptlist))
  (if (= (length ptlist) 4)
    (progn
      (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 "\n非四邊形!")
  )
  (princ)
)
[/PHP]
寫得有點繁,但是畢竟是自己完成的.
請XYP版主看看是否有問題.能否在主體不變的情況下(仍用上面的函數),將程序再簡化點.

xyp1964

楼上：
vertexs 函数未定义！无法测试！
为什么不把你信箱里的“垃圾”清一清？

xyp1964

三角形底、高、腰长、面积公式标注

2. [FONT=courier new](load "xyp_lib");版本 V.20051205
   
3. ;|加载通用函数(可在签名栏直接下载)
   
4. 如果已经下载xyp_lib并放到搜索路径下可以不再下载!
   
5. 利用以下任何一种方式（首选第一种）即可加载和运行通用函数内的所有子程序：
   
6. ★1·在acad.lsp中增加(load"xyp_lib")
   
7. ■2·在每个程序内增加(load"xyp_lib")
   
8. ■3·在command下，输入(load"xyp_lib")
   
9. ■4·在菜单.mnl中增加(load"xyp_lib")
   
10. ■5·将xyp_lib.vlx文件直接拽到cad屏幕
    
11. ★通用函数下载地址：
    
12. [url]http://www.xdcad.net/forum/attachme...&postid=1606661[/url]
    
13. |;
    
14. 
    
15. ;;;三角形面积边长、面积公式标注
    
16. (defun c:test ()
    
17.   (CMDLASC0)
    
18.   (setq        ss (ssget '((0 . "*POLYLINE")))
    
19.         i  -1
    
20.   )
    
21.   (setvar "OSMODE" 0)
    
22.   (while (setq s1 (ssname ss (setq i (1+ i))))
    
23.     (if        (= (length (setq ptn (xyp-get-vertexs s1 3))) 3)
    
24.       (progn
    
25.         (setq pt1  (car ptn)
    
26.               pt2  (cadr ptn)
    
27.               pt3  (caddr ptn)
    
28.               pt4  (inters pt1
    
29.                            (polar pt1 (+ (angle pt2 pt3) (* pi 0.5)) 100)
    
30.                            pt2
    
31.                            pt3
    
32.                            nil
    
33.                    )
    
34.               pt28 (xyp-get-MinMaxPoint s1 2)
    
35.               txt1 (/ (* (distance pt2 Pt3) (distance pt1 Pt4)) 2.0)
    
36.               txt2 (strcat "S "
    
37.                            (rtos txt1 2 3)
    
38.                            " = "
    
39.                            (rtos (distance pt2 Pt3) 2 3)
    
40.                            "×"
    
41.                            (rtos (distance pt1 Pt4) 2 3)
    
42.                            "/"
    
43.                            (itoa 2)
    
44.                    )
    
45.         )
    
46.         (mkla "尺寸标注" 4)
    
47.         (subtxt pt1 pt2)
    
48.         (subtxt pt2 pt3)
    
49.         (subtxt pt1 pt3)
    
50.         (subtxt pt1 pt4)
    
51.         (xyp-Text 8 pt28 txt2)
    
52.         (mkla "辅助线" 1)
    
53.         (command "line" pt1 pt4 "")
    
54. 
    
55.       )
    
56.     )
    
57.   )
    
58.   (CMDLA1)
    
59. )
    
60. (defun subtxt (Point1 Point2 / ang)
    
61.   (setq ang (rad2ang (angle Point1 Point2)))
    
62.   (while (> ang 90)
    
63.     (setq ang (- ang 180))
    
64.   )
    
65.   (command "text"
    
66.            "j"
    
67.            "BC"
    
68.            (xyp-get-RightPoint Point1 Point2 (* sc 100))
    
69.            (* sc 300)
    
70.            ang
    
71.            (rtos (distance Point1 Point2) 2 3)
    
72.   )
    
73. )[/FONT]

[FONT=courier new](load "xyp_lib");版本 V.20051205<br /> ;|加载通用函数(可在签名栏直接下载)<br /> 如果已经下载xyp_lib并放到搜索路径下可以不再下载!<br /> 利用以下任何一种方式（首选第一种）即可加载和运行通用函数内的所有子程序：<br /> ★1·在acad.lsp中增加(load"xyp_lib")<br /> ■2·在每个程序内增加(load"xyp_lib")<br /> ■3·在command下，输入(load"xyp_lib")<br /> ■4·在菜单.mnl中增加(load"xyp_lib")<br /> ■5·将xyp_lib.vlx文件直接拽到cad屏幕<br /> ★通用函数下载地址：<br /> [url]http://www.xdcad.net/forum/attachme...&postid=1606661[/url]<br /> |;<br /> <br /> ;;;三角形面积边长、面积公式标注<br /> (defun c:test ()<br />   (CMDLASC0)<br />   (setq        ss (ssget '((0 . "*POLYLINE")))<br />         i  -1<br />   )<br />   (setvar "OSMODE" 0)<br />   (while (setq s1 (ssname ss (setq i (1+ i))))<br />     (if        (= (length (setq ptn (xyp-get-vertexs s1 3))) 3)<br />       (progn<br />         (setq pt1  (car ptn)<br />               pt2  (cadr ptn)<br />               pt3  (caddr ptn)<br />               pt4  (inters pt1<br />                            (polar pt1 (+ (angle pt2 pt3) (* pi 0.5)) 100)<br />                            pt2<br />                            pt3<br />                            nil<br />                    )<br />               pt28 (xyp-get-MinMaxPoint s1 2)<br />               txt1 (/ (* (distance pt2 Pt3) (distance pt1 Pt4)) 2.0)<br />               txt2 (strcat "S "<br />                            (rtos txt1 2 3)<br />                            " = "<br />                            (rtos (distance pt2 Pt3) 2 3)<br />                            "×"<br />                            (rtos (distance pt1 Pt4) 2 3)<br />                            "/"<br />                            (itoa 2)<br />                    )<br />         )<br />         (mkla "尺寸标注" 4)<br />         (subtxt pt1 pt2)<br />         (subtxt pt2 pt3)<br />         (subtxt pt1 pt3)<br />         (subtxt pt1 pt4)<br />         (xyp-Text 8 pt28 txt2)<br />         (mkla "辅助线" 1)<br />         (command "line" pt1 pt4 "")<br /> <br />       )<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 /> )[/FONT]

tctabc

xyp版主
您这副程式中的xyp-get-RightPoint这函数
是做什么用途的呢
可以公布一下做法吗

另外这段 (* sc 100)   (* sc 300) 有何含意呢
烦请版主可以解惑一下

谢谢

(defun subtxt (Point1 Point2 / ang)
  (setq ang (rad2ang (angle Point1 Point2)))
  (while (> ang 90)
    (setq ang (- ang 180))
  )
  (command "text"
           "j"
           "BC"
           (xyp-get-RightPoint Point1 Point2 (* sc 100))
           (* sc 300)
           ang
           (rtos (distance Point1 Point2) 2 3)
  )
)

xyz518mm

示范六点物件列示座标:
只要改一下就可以变成显示其他的点形.

[PHP]
(defun c:ts ( / polygon pt1 pt2 pt3 pt4 pt5 pt6 ptlist str1 str2 str3

str4 str5 str6)

(setq ptlist (vertexs (car (setq polygon (entsel "\n请点选物件:")))))
(setq   pt1 (nth 0 ptlist)
        pt2 (nth 1 ptlist)
        pt3 (nth 2 ptlist)
        pt4 (nth 3 ptlist)
        pt5 (nth 4 ptlist)
        pt6 (nth 5 ptlist)
)

(setq str1 (strcat "PT1:X=" (rtos (car pt1) 2 4) ", Y=" (rtos (cadr

pt1) 2 4)))
(setq str2 (strcat "PT2:X=" (rtos (car pt2) 2 4) ", Y=" (rtos (cadr

pt2) 2 4)))
(setq str3 (strcat "PT3:X=" (rtos (car pt3) 2 4) ", Y=" (rtos (cadr

pt3) 2 4)))
(setq str4 (strcat "PT4:X=" (rtos (car pt4) 2 4) ", Y=" (rtos (cadr

pt4) 2 4)))
(setq str5 (strcat "PT5:X=" (rtos (car pt5) 2 4) ", Y=" (rtos (cadr

pt5) 2 4)))
(setq str6 (strcat "PT6:X=" (rtos (car pt6) 2 4) ", Y=" (rtos (cadr

pt6) 2 4)))

(command "text" "j" "tl" pt1 "3" "0" str1)
(command "text" "j" "tl" pt2 "3" "0" str2)
(command "text" "j" "tl" pt3 "3" "0" str3)
(command "text" "j" "tl" pt4 "3" "0" str4)
(command "text" "j" "tl" pt5 "3" "0" str5)
(command "text" "j" "tl" pt6 "3" "0" str6)

(prin1))


(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]

另请教可以将下列这段程序改变为自动判断物件顶点自动编号列出吗?

(setq   pt1 (nth 0 ptlist)
        pt2 (nth 1 ptlist)
        pt3 (nth 2 ptlist)
        pt4 (nth 3 ptlist)
        pt5 (nth 4 ptlist)
        pt6 (nth 5 ptlist)
)

(setq str1 (strcat "PT1:X=" (rtos (car pt1) 2 4) ", Y=" (rtos (cadr

pt1) 2 4)))
(setq str2 (strcat "PT2:X=" (rtos (car pt2) 2 4) ", Y=" (rtos (cadr

pt2) 2 4)))
(setq str3 (strcat "PT3:X=" (rtos (car pt3) 2 4) ", Y=" (rtos (cadr

pt3) 2 4)))
(setq str4 (strcat "PT4:X=" (rtos (car pt4) 2 4) ", Y=" (rtos (cadr

pt4) 2 4)))
(setq str5 (strcat "PT5:X=" (rtos (car pt5) 2 4) ", Y=" (rtos (cadr

pt5) 2 4)))
(setq str6 (strcat "PT6:X=" (rtos (car pt6) 2 4) ", Y=" (rtos (cadr

pt6) 2 4)))

(command "text" "j" "tl" pt1 "3" "0" str1)
(command "text" "j" "tl" pt2 "3" "0" str2)
(command "text" "j" "tl" pt3 "3" "0" str3)
(command "text" "j" "tl" pt4 "3" "0" str4)
(command "text" "j" "tl" pt5 "3" "0" str5)
(command "text" "j" "tl" pt6 "3" "0" str6)

tctabc

确实如果可以自动判断点数就不用写那么长了~

xyp1964

最初由 xyz518mm 发布
[B]示范六点物件列示座标:
只要改一下就可以变成显示其他的点形.
[/B]

2. [FONT=courier new](defun c:test ()
   
3.   (CMDLA0)
   
4.   (setq        ss (ssget '((0 . "*POLYLINE")))
   
5.         i  -1
   
6.   )
   
7.   (while (setq s1 (ssname ss (setq i (1+ i))))
   
8.     (setq ptn (xyp-get-Vertexs s1 3))
   
9.     (if        (= (length ptn) 6)
   
10.       (foreach pt ptn (xyp-ZB pt))
    
11.     )
    
12.   )
    
13.   (CMDLA1)
    
14. )[/FONT]

[FONT=courier new](defun c:test ()<br />   (CMDLA0)<br />   (setq        ss (ssget '((0 . "*POLYLINE")))<br />         i  -1<br />   )<br />   (while (setq s1 (ssname ss (setq i (1+ i))))<br />     (setq ptn (xyp-get-Vertexs s1 3))<br />     (if        (= (length ptn) 6)<br />       (foreach pt ptn (xyp-ZB pt))<br />     )<br />   )<br />   (CMDLA1)<br /> )[/FONT]

tctabc

感谢XYP版主的解答
请教如果程序不用 xyp-get-Vertexs 这函数
运作可以完成吗?

另外 xyp-ZB 这函数是用来做什么用的呢?
烦请版主或各位高手们可以解答一下~
谢谢

taner

求n多边形的角点表,多边形顶点数可能为n,可能大于n(即有可能有多点共线的顶点)
[PHP]
(defun pt (ptlistn / i j lst lst0 lst1 ptlist);主程序
  (setq ptlist ptlistn)
  (while (and
           ptlist
           (not (ptsonline ptlist))
         )
    (setq i (length ptlist))
    (setq j 2)
    (setq lst (list (nth 0 ptlist) (nth 1 ptlist)))
    (while (< j i)
      (if (ptsonline (cons (nth j ptlist) lst))
        (setq lst (cons (nth j ptlist) lst))
      )
      (setq j (1+ j))
    )
    (if (> (length lst) 2)
      (progn
        (setq lst1 (list (xd-points_miny_minx lst)
                         (xd-points_maxy_maxx lst)
                   )
        )
        (setq lst0 (li_subtract lst lst1))
        (setq ptlist (li-union (li_subtract ptlist lst) lst1))
        (setq ptlistn (li_subtract ptlistn lst0))
      )
      (progn
        (setq lst1 lst)
        (setq lst0 '())
        (setq ptlist (li_subtract ptlist lst))
        (setq ptlistn (li_subtract ptlistn lst0))
      )
    )
  )
  ptlistn
)
(defun xd-points_miny_minx (pts)       ; y優先於x
  (car (vl-sort pts '(lambda (e1 e2)
                       (if (equal (cadr e1) (cadr e2) 1e-10)
                         (< (car e1) (car e2))
                         (< (cadr e1) (cadr e2))
                       )
                     )
       )
  )
)
(defun xd-points_maxy_maxx (pts)       ; y優先於x
  (car (vl-sort pts '(lambda (e1 e2)
                       (if (equal (cadr e1) (cadr e2) 1e-10)
                         (> (car e1) (car e2))
                         (> (cadr e1) (cadr e2))
                       )
                     )
       )
  )
)
(defun li-union (lst1 lst2 / lst tmp);表并集
  (setq lst '())
  (foreach tmp lst2
    (if (not (member tmp lst1))
      (setq lst (cons tmp lst))
    )
  )
  (setq lst (reverse lst)
        lst (append
              lst1
              lst
            )
  )
  lst
)
(defun li_subtract (lst1 lst2 / lst);表差集
  (setq lst '())
  (if lst1
    (progn
      (foreach tmp lst1
        (if (not (member tmp lst2))
          (setq lst (cons tmp lst))
        )
      )
    )
  )
  (setq lst (reverse lst))
  lst
)
(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
)
(defun radtoang (n)弧度转角度
  (/ (* 180 n) pi)
)
(defun ptsonline (ptlist / angle01 i j yesorno);判断点表是否共线
  (if (> (setq i (length ptlist))
         2
      )
    (progn
      (setq angle01 (radtoang (angle (nth 0 ptlist) (nth 1 ptlist))))
      (setq j 2)
      (while (< j i)
        (if (or
              (equal (abs (- angle01 (radtoang (angle (nth 0 ptlist)
                                                      (nth j ptlist)
                                               )
                                     )
                          )
                     ) 180 1e-10
              )
              (equal (abs (- angle01 (radtoang (angle (nth 0 ptlist)
                                                      (nth j ptlist)
                                               )
                                     )
                          )
                     ) 0 1e-10
              )
            )
          (setq yesorno t)
          (setq yesorno nil)
        )
        (if yesorno
          (setq j (1+ j))
          (setq j i)
        )
      )
      yesorno
    )
    (setq yesorno t)
  )
)[/PHP]

david96007

我的想法：
梯形也是4边形，更宽一点说的n（n>=3）边形，只要能够得到n边形顶点坐标，就可以求得n边形的面积（划分成n-2个三角形进行计算，然后求和），不局限于梯形啊！

tctabc

那弧形的该怎么办呢?