[编程申请]：如何将三段圆弧及一段直线围成的封闭形定义成面域？

chinali001

我做了一个三心圆（形成由三段圆弧和一段直线围成的区域）的隧道设计断面图，在上面套上了隧道实际的轮廓线，现在想要计算出超挖（位于设计线之外部分）面积和欠挖（位于设计线之内部分）面积，请问：怎么样在代码中实现上述问题的解决方法？谢谢

xstlf

i 不用编程，CAD自带的，面域命令，boundary

chinali001

我是用程序画的三段圆弧和一段直线围成的区域，用boundary 命令不行啊，提示未找到有效边界点。

xyp1964

发个图，叙述起来多简单！
先用boundary 命令，再用REGION命令，应该没问题。

Free-Lancer

(command ".region" ss ""))

chinali001

我把我的问题画了一张图，高手有空帮我看一下，问题如下：我在编一个隧道净空检测程序，图中红蓝圆弧及底边为设计隧道断面线，由三段圆弧和一段直线围以程序控制绘制，白色为实际开挖轮廓线，现在要求出实际开挖断面面积、超挖（位于设计断面线之外部分）面积、欠挖（位于设计断面线之内部分）面积，并分别标注在图形内，对于超欠点还要标注其距设计断面线的距离。谢谢！

Free-Lancer

又要求人又不把已有代码拿出来分析，让别人写好你拿现成的？

chinali001

７楼的误会了，我想有高手能提供一些思路啊，我现在是想求取实际断面线和设计断面线的并集之面积减去设计面积得出超挖面积，进而可以求出欠挖面积。但是求并集要求先定义域啊，我的设计轮廓线是三段圆弧和一段直线围，不能定义域啊，这才是问题的关键，也是我最想求助的嘛，至于完整和具体的实现方法，我想见仁见智，自己也可以嘛。
(defun c:sanxinyuan ()
  (setq        r1 (getreal "请输入半径：")
        r2 (+ r1 1.25)
  )
  (setq        o1 (getpoint "请指定上圆心点：")
        x1 (car o1)
        y1 (cdr o1)
        y1 (car y1)                        ;指定上圆心点位置
  )
  (setq        x2 (- x1 1.083)
        y2 (- y1 0.625)
        o2 (list x2 y2)                        ;指定左下圆心点位置
  )
  (setq o3 (list (+ x1 1.083) (- y1 0.625))) ;指定右下圆心点位置
  (setq p1 (- (sqrt (- (* r2 r2) (* 1.025 1.025))) 1.083))
                                        ;计算左圆弧起点、右圆弧终点距衬砌中线的平距
  (setq        lq (list (- x1 p1) (- y1 1.65))        ;指定左圆弧起点坐标
        rq (list (+ x1 p1) (- y1 1.65))        ;指定右圆弧终点坐标
  )
  (setq        p2 (* r1 (sin (/ pi 3)))        ;计算上圆弧起终点距衬砌中线平距
        h1 (* r1 (cos (/ pi 3)))        ;计算上圆弧起终点距上圆心高差
  )
  (setq        ld (list (- x1 p2) (+ y1 h1))        ;指定上圆弧左端点坐标
        rd (list (+ x1 p2) (+ y1 h1))        ;指定上圆弧右端点坐标
  )
  (setq jd (list x1 (- y1 1.65)))        ;指定衬砌中线上设计高程处坐标
  (command "arc" ld "c" o3 lq)                ;绘制右圆弧
  (command "arc" rd "c" o1 ld)                ;绘制左圆弧
  (command "arc" rq "c" o2 rd)                ;绘制上圆弧
  (command "line" lq rq "")                ;绘制设计高程水平线
  (command "pline" o1 o2 o3 "c")        ;绘制圆心三角形
                                        ;以下用于计算设计开挖面积
  (setq        a1 (atan (/ 1.025 (+ p1 1.083)))
        a2 (+ a1 (/ pi 6.0))
  )
  (setq area1 (/ (* pi r1 r1) 3))
  (setq area2 (* (* pi r2 r2) (/ a2 (* 2 pi))))
  (setq        dibian(+ 0.625 (* 1.083 (/ (sin a1) (cos a1)))))
  (setq area3 (* 1.083 dibian))
  (setq h2 (- 1.65 dibian))
  (setq area4 (* p1 h2))
  (setq area5 (- (+ area1 (* 2 area2) area4 ) area3))
  (setq ptext (list  x1  (+ y1 0.6) ))
  (setq areas (rtos area5))
  (setq sarea ( strcat  "设计面积为 " areas   " 平方米" ))
  (command "text" "s" "china" "j"  "mc" ptext 0.15 0   sarea  "" "")
  )
这是我画设计断面线的代码，请指正，谢谢！

xyp1964

以上程序画出的断面根本就不闭合，小心漏水或塌方！呵呵……

chinali001

通过努力，完善了以下代码，可以求取设计断面的面积了，也可以闭合了，不会漏水了。。。只是最后一行的文字样式要先设置好，能在代码中设计吗？谢谢。。。
(defun c:sanxinyuan()
  (setq        r1 (getreal "请输入半径：")
        r2 (+ r1 1.25)
  )
  (setq        o1 (getpoint "请指定上圆心点：")
        x1 (car o1)
        y1 (cdr o1)
        y1 (car y1)                        ;指定上圆心点位置
  )
  (setq        x2 (- x1 1.083)
        y2 (- y1 0.625)
        o2 (list x2 y2)                        ;指定左下圆心点位置
  )
  (setq o3 (list (+ x1 1.083) (- y1 0.625))) ;指定右下圆心点位置
  (setq p1 (- (sqrt (- (* r2 r2) (* 1.025 1.025))) 1.083))
                                        ;计算左圆弧起点、右圆弧终点距衬砌中线的平距
  (setq        lq (list (- x1 p1) (- y1 1.65))        ;指定左圆弧起点坐标
        rq (list (+ x1 p1) (- y1 1.65))        ;指定右圆弧终点坐标
  )
  (setq        p2 (* r1 (sin (/ pi 3)))        ;计算上圆弧起终点距衬砌中线平距
        h1 (* r1 (cos (/ pi 3)))        ;计算上圆弧起终点距上圆心高差
  )
  (setq        ld (list (- x1 p2) (+ y1 h1))        ;指定上圆弧左端点坐标
        rd (list (+ x1 p2) (+ y1 h1))        ;指定上圆弧右端点坐标
  )
  (setq jd (list x1 (- y1 1.65)))        ;指定衬砌中线上设计高程处坐标

  (command "arc" ld "c" o3 lq)                ;绘制右圆弧
  (setq rightarc (entlast))

  (command "arc" rd "c" o1 ld)                ;绘制上圆弧
  (setq uparc (entlast))

  (command "arc" rq "c" o2 rd)                ;绘制左圆弧
  (setq leftarc (entlast))


  (command "line" lq rq "")                ;绘制设计高程水平线
  (setq downline (entlast))

  (command "pline" o1 o2 o3 "c")        ;绘制圆心三角形

                                        ;以下用于计算设计开挖面积
  (command "pedit" "" "m" leftarc uparc        rightarc downline "" "y" "j" ""
           "c" "");合并三段圆弧及设计高处底边为一条闭合的多段线
  (setq shejidmx (entlast))
  (command "region" shejidmx "");设置面域
  (setq shejidmx (entlast))
  (command "area" "o" shejidmx)
  (setq area5 (getvar "area"));计算并求取设计断面的面积

  (setq ptext (list x1 (+ y1 0.6)))
  (setq areas (rtos area5))
  (setq sarea (strcat "设计面积为 " areas " 平方米"))
  (command "text" "s" "china" "j" "mc" ptext 0.15  sarea "" "");在指定位置标注设计断面的面积
)

xstlf

你编得太复杂了。给你点启示。
(command "-boundary" "A" "O" "P" "I" "Y" "B" "E" "" p1 "")
   (setq b (entlast))其中p1为图内你要求面积的任一点。

Free-Lancer

2. 
   
3. ;; 测试环境 AutoCAD 2005 + SP1 & AutoCAD R14
   
4. ;;基本编程，用 command 命令完成，实际就是将手动的步骤用程序完成
   
5. ;;关于赋值用下面的思路更好些，初学时养成好习惯对后面的提高有好处
   
6. ;;还有程序结构也要多看一些好的程序
   
7. ;;以下程序没有添加出错处理和Undo处理
   
8. (defun c:syx (/            area  area1        e     e0    e1          e2        h1    jd
   
9.               ld    lq          o1        o2    o3    oldosnap        p1    p2
   
10.               ptext r1          r2        rd    rq    sarea
    
11.              )
    
12.              ;|(setq        r1 (getreal "请输入半径：")
    
13.         r2 (+ r1 1.25)
    
14.   )
    
15.   (setq        o1 (getpoint "请指定上圆心点：")
    
16.         x1 (car o1)
    
17.         y1 (cdr o1)
    
18.         y1 (car y1)                        ;指定上圆心点位置
    
19.   )|;
    
20.   (setvar "cmdecho" 0)
    
21.   (if (and (setq o1 (getpoint "\n请指定圆心点<Exit>: "))
    
22.            (setq r1 (getdist "\n直径<Exit>: "))
    
23.       )
    
24.     (progn
    
25.       (setq r2 (+ r1 1.25))
    
26.       (setq o2 (mapcar '+ o1 '(-1.083 -0.625 0.)))
    
27.       ;|
    
28.       (setq        x2 (- x1 1.083)
    
29.                      y2 (- y1 0.625)
    
30.                 o2 (list x2 y2)                        ;指定左下圆心点位置
    
31.       )
    
32.       |;
    
33.       (setq o3 (mapcar '+ o1 '(1.083 -0.625 0.)))
    
34.       ;;(setq o3 (list (+ x1 1.083) (- y1 0.625))) ;指定右下圆心点位置
    
35.       ;;计算左圆弧起点、右圆弧终点距衬砌中线的平距
    
36.       (setq p1 (- (sqrt (- (* r2 r2) (* 1.025 1.025))) 1.083))
    
37.       ;|                                       
    
38.       (setq lq (list (- x1 p1) (- y1 1.65)) ;指定左圆弧起点坐标
    
39.             rq (list (+ x1 p1) (- y1 1.65)) ;指定右圆弧终点坐标
    
40.       )
    
41.       |;
    
42.       (setq lq (mapcar '+ o1 (list (- p1) -1.65 0.))
    
43.             rq (mapcar '+ o1 (list p1 -1.65 0.))
    
44.       )
    
45.       (setq p2 (* r1 (sin (/ pi 3))) ;_计算上圆弧起终点距衬砌中线平距
    
46.             h1 (* r1 (cos (/ pi 3))) ;_计算上圆弧起终点距上圆心高差
    
47.       )
    
48.       ;|
    
49.       (setq ld (list (- x1 p2) (+ y1 h1)) ;指定上圆弧左端点坐标
    
50.             rd (list (+ x1 p2) (+ y1 h1)) ;指定上圆弧右端点坐标
    
51.       )
    
52.       |;
    
53.       (setq ld (mapcar '+ o1 (list (- p2) h1 0.))
    
54.             rd (mapcar '+ o1 (list p2 h1 0.))
    
55.       )
    
56.       ;;(setq jd (list x1 (- y1 1.65)))        ;_指定衬砌中线上设计高程处坐标
    
57.       (setq jd (mapcar '+ o1 '(0. -1.65 0.)))
    
58.       ;|
    
59.       (command "arc" ld "c" o3 lq)        ;绘制右圆弧
    
60.       (command "arc" rq "c" o2 rd)        ;绘制上圆弧
    
61.       (command "arc" rd "c" o1 ld)        ;绘制左圆弧
    
62.       (command "line" lq rq "")                ;绘制设计高程水平线
    
63.       |;
    
64.       (setq oldosnap (getvar "osmode"))
    
65.       (setvar "osmode" 0)
    
66.       (command ".pline"        rq "a" "ce" o2 rd "ce" o1 ld "ce" o3 lq        "l" "c")
    
67.       (setq e (entlast)) ;_ Calc Area
    
68.       (command ".area" "e" "l")
    
69.       (command ".copy" "l" "" rd rd)
    
70.       (command ".region" "l" "") ;_ 用于后面的面与运算
    
71.       (setq e0 (entlast))
    
72.       (command "pline" o1 o2 o3 "c")        ;绘制圆心三角形
    
73.                                         ;以下用于计算设计开挖面积
    
74.       ;|
    
75.       (setq a1 (atan (/ 1.025 (+ p1 1.083)))
    
76.             a2 (+ a1 (/ pi 6.0))
    
77.       )
    
78.       (setvar "osmode" oldosnap)
    
79.       (setq area1 (/ (* pi r1 r1) 3))
    
80.       (setq area2 (* (* pi r2 r2) (/ a2 (* 2 pi))))
    
81.       (setq dibian (+ 0.625 (* 1.083 (/ (sin a1) (cos a1)))))
    
82.       (setq area3 (* 1.083 dibian))
    
83.       (setq h2 (- 1.65 dibian))
    
84.       (setq area4 (* p1 h2))
    
85.       (setq area5 (- (+ area1 (* 2 area2) area4) area3))
    
86.       (setq ptext (list x1 (+ y1 0.6)))
    
87.       (setq areas (rtos area5))
    
88.       (setq sarea (strcat "设计面积为 " areas " 平方米"))
    
89.       (command "text" "s" "china" "j" "mc" ptext 0.15 0        sarea "" "")
    
90.       |;
    
91.       (setq area (getvar "Area"))
    
92.       (setq sarea (strcat "Area = " (rtos area)))
    
93.       (setq ptext (mapcar '+ o1 '(0. 0.6 0.)))
    
94.       (command ".text" "j" "mc" ptext 0.15 0 sarea)
    
95.       (if (setq e1 (entsel "\n拾取封闭线: ")) ;_ 外围线
    
96.         (progn
    
97.           (command ".copy" e1 "" rd rd) ;_用副本运算
    
98.           (command ".region" "l" "")
    
99.           (command ".intersect" "l" e0 "") ;_ 求交集
    
100.           (setq e2 (entlast))
     
101.           (command ".area" "e" "l") ;_交集面积
     
102.           (entdel (entlast))
     
103.           (setq area1 (getvar "area"))
     
104.           (princ "\n面积差 = ")
     
105.           (princ (- area area1))
     
106.         )
     
107.       )
     
108.     )
     
109.   )
     
110.   (princ)
     
111. )
     
112. ;;进阶程序, 使用 vla 方法可以不出现面域生成的提示, 增加出错处理
     
113. ;;以下程序仅适用 AutoCAD 2000+ 以上
     
114. (defun c:fsyx (/     area  area1 e     e0    e1           e2         h1    jd
     
115.                ld    lq           o1         o2    o3    oldosnap         p1    p2
     
116.                ptext r1           r2         rd    rq    sarea error olderror
     
117.                doc   ms
     
118.               )
     
119.   (vl-load-com)
     
120.   (defun error (msg)
     
121.     (if        (/= msg "CANCEL")
     
122.       (princ "\n*Cancel*")
     
123.     )
     
124.     (setvar "osmode" oldosmode)
     
125.     (vla-endundomark Doc)
     
126.     (princ)
     
127.   )
     
128.   (setq        oldosmode (getvar "osmode")
     
129.         olderror  *error*
     
130.         *error*          error
     
131.         doc          (vlax-get-property (vlax-get-acad-object) 'activedocument)
     
132.         ms          (vlax-get-property doc 'modelspace)
     
133.   )
     
134.   (vla-startundomark doc)
     
135.   (setvar "cmdecho" 0)
     
136.   (if (and (setq o1 (getpoint "\n请指定上圆心点<Exit>: "))
     
137.            (setq r1 (getdist "\n直径<Exit>: "))          
     
138.       )
     
139.     (progn
     
140.       (setq r2 (+ r1 1.25))
     
141.       (setq o2 (mapcar '+ o1 '(-1.083 -0.625 0.))
     
142.             o3 (mapcar '+ o1 '(1.083 -0.625 0.)) ;_指定右下圆心点位置
     
143.       )
     
144.       ;;计算左圆弧起点、右圆弧终点距衬砌中线的平距
     
145.       (setq p1 (- (sqrt (- (* r2 r2) (* 1.025 1.025))) 1.083)
     
146.             lq (mapcar '+ o1 (list (- p1) -1.65 0.))
     
147.             rq (mapcar '+ o1 (list p1 -1.65 0.))
     
148.             p2 (* r1 (sin (/ pi 3))) ;_计算上圆弧起终点距衬砌中线平距
     
149.             h1 (* r1 (cos (/ pi 3))) ;_计算上圆弧起终点距上圆心高差
     
150.             ld (mapcar '+ o1 (list (- p2) h1 0.))
     
151.             rd (mapcar '+ o1 (list p2 h1 0.))
     
152.             jd (mapcar '+ o1 '(0. -1.65 0.)) ;_指定衬砌中线上设计高程处坐标
     
153.       )
     
154.       (setvar "osmode" 0)
     
155.       ;;这个线用 command 是最简单的
     
156.       (command ".pline"        rq "a" "ce" o2 rd "ce" o1 ld "ce" o3 lq        "l" "c")
     
157.       (setq area (vlax-curve-getarea (entlast)))
     
158.       (command ".copy" "l" "" rd rd)
     
159.       ;;也可以 (vla-copy (vlax-ename->vla-object (entlast)))
     
160.       ;;代替 region 命令，不出现提示
     
161.       (vla-addregion
     
162.         ms
     
163.         (vlax-make-variant
     
164.           (vlax-safearray-fill
     
165.             (vlax-make-safearray vlax-vbobject '(0 . 0))
     
166.             (list (vlax-ename->vla-object (entlast)))
     
167.           )
     
168.         )
     
169.       )
     
170.       (setq reg1 (vlax-ename->vla-object (entlast)))
     
171.       (command "pline" o1 o2 o3 "c")        ;绘制圆心三角形
     
172.       (setq sarea (strcat "Area = " (rtos area)))
     
173.       (setq ptext (mapcar '+ o1 '(0. 0.6 0.)))
     
174.       (command ".text" "j" "mc" ptext 0.15 0 sarea) ;_ 此 text 在 14 和以上版本时使用方法好像略有不同
     
175.       (if (and (setq e1 (entsel "\n拾取封闭线<退出>: ")) ;_ 外围线
     
176.                (= (cdr (assoc 70 (entget (car e1)))) 1) ;_ 此处可以使用 ssget 选择形成闭合区域的线
     
177.                                         ; 后面使用 vla 方法将选择集生成面域
     
178.           )
     
179.         (progn
     
180.           ;;选择集的话用 copy 命令，单个实体也可以用 vla 方法
     
181.           (command ".copy" e1 "" rd rd) ;_用副本运算
     
182.           ;;addregion 返回的 safearray 记录了生成的所有面域
     
183.           ;;如果用选择集还要判断是非生成面域
     
184.           (vla-addregion
     
185.             ms
     
186.             (vlax-make-variant
     
187.               (vlax-safearray-fill
     
188.                 (vlax-make-safearray vlax-vbobject '(0 . 0))
     
189.                 (list (vlax-ename->vla-object (entlast)))
     
190.               )
     
191.             )
     
192.           )
     
193.           ;;布尔运算，vla 操作不当会很危险
     
194.           ;;前面使用选择集的情况下要判断 addregion 是否生成才进行下面的运算
     
195.           (vla-boolean
     
196.             reg1
     
197.             acIntersection
     
198.             (vlax-ename->vla-object (entlast))
     
199.           )
     
200.           (setq area1 (vlax-get-property reg 'area))
     
201.           (princ "\n面积差 = ")
     
202.           (princ (- area area1)) ;_ 生成的弧线减去原线的交叉部分
     
203.         )
     
204.       )
     
205.     )
     
206.   )
     
207.   (setvar "osmode" oldosmode)
     
208.   (setq *error* olderror)
     
209.   (vla-endundomark doc)
     
210.   (princ)
     
211. )
     

<br /> ;; 测试环境 AutoCAD 2005 + SP1 & AutoCAD R14<br /> ;;基本编程，用 command 命令完成，实际就是将手动的步骤用程序完成<br /> ;;关于赋值用下面的思路更好些，初学时养成好习惯对后面的提高有好处<br /> ;;还有程序结构也要多看一些好的程序<br /> ;;以下程序没有添加出错处理和Undo处理<br /> (defun c:syx (/            area  area1        e     e0    e1          e2        h1    jd<br />               ld    lq          o1        o2    o3    oldosnap        p1    p2<br />               ptext r1          r2        rd    rq    sarea<br />              )<br />              ;|(setq        r1 (getreal "请输入半径：")<br />         r2 (+ r1 1.25)<br />   )<br />   (setq        o1 (getpoint "请指定上圆心点：")<br />         x1 (car o1)<br />         y1 (cdr o1)<br />         y1 (car y1)                        ;指定上圆心点位置<br />   )|;<br />   (setvar "cmdecho" 0)<br />   (if (and (setq o1 (getpoint "\n请指定圆心点<Exit>: "))<br />            (setq r1 (getdist "\n直径<Exit>: "))<br />       )<br />     (progn<br />       (setq r2 (+ r1 1.25))<br />       (setq o2 (mapcar '+ o1 '(-1.083 -0.625 0.)))<br />       ;|<br />       (setq        x2 (- x1 1.083)<br />                      y2 (- y1 0.625)<br />                 o2 (list x2 y2)                        ;指定左下圆心点位置<br />       )<br />       |;<br />       (setq o3 (mapcar '+ o1 '(1.083 -0.625 0.)))<br />       ;;(setq o3 (list (+ x1 1.083) (- y1 0.625))) ;指定右下圆心点位置<br />       ;;计算左圆弧起点、右圆弧终点距衬砌中线的平距<br />       (setq p1 (- (sqrt (- (* r2 r2) (* 1.025 1.025))) 1.083))<br />       ;|                                        <br />       (setq lq (list (- x1 p1) (- y1 1.65)) ;指定左圆弧起点坐标<br />             rq (list (+ x1 p1) (- y1 1.65)) ;指定右圆弧终点坐标<br />       )<br />       |;<br />       (setq lq (mapcar '+ o1 (list (- p1) -1.65 0.))<br />             rq (mapcar '+ o1 (list p1 -1.65 0.))<br />       )<br />       (setq p2 (* r1 (sin (/ pi 3))) ;_计算上圆弧起终点距衬砌中线平距<br />             h1 (* r1 (cos (/ pi 3))) ;_计算上圆弧起终点距上圆心高差<br />       )<br />       ;|<br />       (setq ld (list (- x1 p2) (+ y1 h1)) ;指定上圆弧左端点坐标<br />             rd (list (+ x1 p2) (+ y1 h1)) ;指定上圆弧右端点坐标<br />       )<br />       |;<br />       (setq ld (mapcar '+ o1 (list (- p2) h1 0.))<br />             rd (mapcar '+ o1 (list p2 h1 0.))<br />       )<br />       ;;(setq jd (list x1 (- y1 1.65)))        ;_指定衬砌中线上设计高程处坐标<br />       (setq jd (mapcar '+ o1 '(0. -1.65 0.)))<br />       ;|<br />       (command "arc" ld "c" o3 lq)        ;绘制右圆弧<br />       (command "arc" rq "c" o2 rd)        ;绘制上圆弧<br />       (command "arc" rd "c" o1 ld)        ;绘制左圆弧<br />       (command "line" lq rq "")                ;绘制设计高程水平线<br />       |;<br />       (setq oldosnap (getvar "osmode"))<br />       (setvar "osmode" 0)<br />       (command ".pline"        rq "a" "ce" o2 rd "ce" o1 ld "ce" o3 lq        "l" "c")<br />       (setq e (entlast)) ;_ Calc Area<br />       (command ".area" "e" "l")<br />       (command ".copy" "l" "" rd rd)<br />       (command ".region" "l" "") ;_ 用于后面的面与运算<br />       (setq e0 (entlast))<br />       (command "pline" o1 o2 o3 "c")        ;绘制圆心三角形<br />                                         ;以下用于计算设计开挖面积<br />       ;|<br />       (setq a1 (atan (/ 1.025 (+ p1 1.083)))<br />             a2 (+ a1 (/ pi 6.0))<br />       )<br />       (setvar "osmode" oldosnap)<br />       (setq area1 (/ (* pi r1 r1) 3))<br />       (setq area2 (* (* pi r2 r2) (/ a2 (* 2 pi))))<br />       (setq dibian (+ 0.625 (* 1.083 (/ (sin a1) (cos a1)))))<br />       (setq area3 (* 1.083 dibian))<br />       (setq h2 (- 1.65 dibian))<br />       (setq area4 (* p1 h2))<br />       (setq area5 (- (+ area1 (* 2 area2) area4) area3))<br />       (setq ptext (list x1 (+ y1 0.6)))<br />       (setq areas (rtos area5))<br />       (setq sarea (strcat "设计面积为 " areas " 平方米"))<br />       (command "text" "s" "china" "j" "mc" ptext 0.15 0        sarea "" "")<br />       |;<br />       (setq area (getvar "Area"))<br />       (setq sarea (strcat "Area = " (rtos area)))<br />       (setq ptext (mapcar '+ o1 '(0. 0.6 0.)))<br />       (command ".text" "j" "mc" ptext 0.15 0 sarea)<br />       (if (setq e1 (entsel "\n拾取封闭线: ")) ;_ 外围线<br />         (progn<br />           (command ".copy" e1 "" rd rd) ;_用副本运算<br />           (command ".region" "l" "")<br />           (command ".intersect" "l" e0 "") ;_ 求交集<br />           (setq e2 (entlast))<br />           (command ".area" "e" "l") ;_交集面积<br />           (entdel (entlast))<br />           (setq area1 (getvar "area"))<br />           (princ "\n面积差 = ")<br />           (princ (- area area1))<br />         )<br />       )<br />     )<br />   )<br />   (princ)<br /> )<br /> ;;进阶程序, 使用 vla 方法可以不出现面域生成的提示, 增加出错处理<br /> ;;以下程序仅适用 AutoCAD 2000+ 以上<br /> (defun c:fsyx (/     area  area1 e     e0    e1           e2         h1    jd<br />                ld    lq           o1         o2    o3    oldosnap         p1    p2<br />                ptext r1           r2         rd    rq    sarea error olderror<br />                doc   ms<br />               )<br />   (vl-load-com)<br />   (defun error (msg)<br />     (if        (/= msg "CANCEL")<br />       (princ "\n*Cancel*")<br />     )<br />     (setvar "osmode" oldosmode)<br />     (vla-endundomark Doc)<br />     (princ)<br />   )<br />   (setq        oldosmode (getvar "osmode")<br />         olderror  *error*<br />         *error*          error<br />         doc          (vlax-get-property (vlax-get-acad-object) 'activedocument)<br />         ms          (vlax-get-property doc 'modelspace)<br />   )<br />   (vla-startundomark doc)<br />   (setvar "cmdecho" 0)<br />   (if (and (setq o1 (getpoint "\n请指定上圆心点<Exit>: "))<br />            (setq r1 (getdist "\n直径<Exit>: "))           <br />       )<br />     (progn<br />       (setq r2 (+ r1 1.25))<br />       (setq o2 (mapcar '+ o1 '(-1.083 -0.625 0.))<br />             o3 (mapcar '+ o1 '(1.083 -0.625 0.)) ;_指定右下圆心点位置<br />       )<br />       ;;计算左圆弧起点、右圆弧终点距衬砌中线的平距<br />       (setq p1 (- (sqrt (- (* r2 r2) (* 1.025 1.025))) 1.083)<br />             lq (mapcar '+ o1 (list (- p1) -1.65 0.))<br />             rq (mapcar '+ o1 (list p1 -1.65 0.))<br />             p2 (* r1 (sin (/ pi 3))) ;_计算上圆弧起终点距衬砌中线平距<br />             h1 (* r1 (cos (/ pi 3))) ;_计算上圆弧起终点距上圆心高差<br />             ld (mapcar '+ o1 (list (- p2) h1 0.))<br />             rd (mapcar '+ o1 (list p2 h1 0.))<br />             jd (mapcar '+ o1 '(0. -1.65 0.)) ;_指定衬砌中线上设计高程处坐标<br />       )<br />       (setvar "osmode" 0)<br />       ;;这个线用 command 是最简单的<br />       (command ".pline"        rq "a" "ce" o2 rd "ce" o1 ld "ce" o3 lq        "l" "c")<br />       (setq area (vlax-curve-getarea (entlast)))<br />       (command ".copy" "l" "" rd rd)<br />       ;;也可以 (vla-copy (vlax-ename->vla-object (entlast)))<br />       ;;代替 region 命令，不出现提示<br />       (vla-addregion<br />         ms<br />         (vlax-make-variant<br />           (vlax-safearray-fill<br />             (vlax-make-safearray vlax-vbobject '(0 . 0))<br />             (list (vlax-ename->vla-object (entlast)))<br />           )<br />         )<br />       )<br />       (setq reg1 (vlax-ename->vla-object (entlast)))<br />       (command "pline" o1 o2 o3 "c")        ;绘制圆心三角形<br />       (setq sarea (strcat "Area = " (rtos area)))<br />       (setq ptext (mapcar '+ o1 '(0. 0.6 0.)))<br />       (command ".text" "j" "mc" ptext 0.15 0 sarea) ;_ 此 text 在 14 和以上版本时使用方法好像略有不同<br />       (if (and (setq e1 (entsel "\n拾取封闭线<退出>: ")) ;_ 外围线<br />                (= (cdr (assoc 70 (entget (car e1)))) 1) ;_ 此处可以使用 ssget 选择形成闭合区域的线<br />                                         ; 后面使用 vla 方法将选择集生成面域<br />           )<br />         (progn<br />           ;;选择集的话用 copy 命令，单个实体也可以用 vla 方法<br />           (command ".copy" e1 "" rd rd) ;_用副本运算<br />           ;;addregion 返回的 safearray 记录了生成的所有面域<br />           ;;如果用选择集还要判断是非生成面域<br />           (vla-addregion<br />             ms<br />             (vlax-make-variant<br />               (vlax-safearray-fill<br />                 (vlax-make-safearray vlax-vbobject '(0 . 0))<br />                 (list (vlax-ename->vla-object (entlast)))<br />               )<br />             )<br />           )<br />           ;;布尔运算，vla 操作不当会很危险<br />           ;;前面使用选择集的情况下要判断 addregion 是否生成才进行下面的运算<br />           (vla-boolean<br />             reg1<br />             acIntersection<br />             (vlax-ename->vla-object (entlast))<br />           )<br />           (setq area1 (vlax-get-property reg 'area))<br />           (princ "\n面积差 = ")<br />           (princ (- area area1)) ;_ 生成的弧线减去原线的交叉部分<br />         )<br />       )<br />     )<br />   )<br />   (setvar "osmode" oldosmode)<br />   (setq *error* olderror)<br />   (vla-endundomark doc)<br />   (princ)<br /> )<br />

chinali001

通过老师的指点，我发现自己的差距真是太大了，也给我的思路打开了好多，我想经过完善，一定会取得我预期的效果的，真是谢谢了，我改好了还会让大家看看的，我在这找到好老师了，谢谢你们！！12.21

12.22

通过几天的努力，我的预期目标快达到了。现在就还差添加图层、颜色了，我把我的全部东西发上来，还望老师们有时间帮我指正。代码：(2004-12-24更新)，欢迎指正。
(defun c:sxy(/ r1 r2 o1 o2 o3 x1 y1 p1 p2 h1 lq rq ld rd jd shejidmx  shejidmx1
             areq1 area2 area3 chaoarea qianarea ss ss1 fn_sxy fn  ds dss licheng
             num zbiao xi yi  p3 widh toal ptext1 ptext2 ptext3 ptext4 ptext5 )

  (COMMAND "_LAYER" "n" "设计断面" "c" "7" "设计断面" "l" "continuous" "设计断面" "lw" 0.5 "设计断面" "")
  (COMMAND "_LAYER" "n" "实测断面" "c" "1" "实测断面" "l" "continuous" "实测断面" "lw" 0.2 "实测断面" "")
  (command "-style"  "隧道断面"  "仿宋_GB2312"  0.2  0.75  0.  "n"  "n"  "n" "")

  (setq sblip (getvar "blipmode"))
  (setq scmde (getvar "cmdecho"))
  (setq la (getvar"clayer"))
  (SETQ OSM (GETVAR "OSMODE"))
  (setvar "blipmode" 0)
  (setvar "cmdecho" 0)
  (SETVAR "OSMODE" 0)
  
     
  (setq        r1 (getreal "请输入半径：")
        r2 (+ r1 1.25)
  )
  (setq        o1 (getpoint "请指定上圆心点：")
        x1 (car o1)
        y1 (cadr o1)
       
                                ;指定上圆心点位置
  )
  (setq o2 (mapcar '+ o1 '(-1.083 -0.625 0. )))                        ;指定左下圆心点位置
  
  (setq o3 (mapcar '+ o1 '(1.083 -0.625 0. ))) ;指定右下圆心点位置
  (setq p1 (- (sqrt (- (* r2 r2) (* 1.025 1.025))) 1.083))
                                        ;计算左圆弧起点、右圆弧终点距衬砌中线的平距
  (setq lq (mapcar '+ o1 (list (- p1) -1.65 0. ))
            rq (mapcar '+ o1 (list p1 -1.65 0. ))
      )        ;指定左圆弧起点坐标、指定右圆弧终点坐标
  
  (setq        p2 (* r1 (sin (/ pi 3)))        ;计算上圆弧起终点距衬砌中线平距
        h1 (* r1 (cos (/ pi 3)))        ;计算上圆弧起终点距上圆心高差
  )
  (setq ld (mapcar '+ o1 (list (- p2) h1  0.))
        rd (mapcar '+ o1 (list p2 h1  0.))
      )        ;指定上圆弧左端点坐标、指定上圆弧右端点坐标
  
  (setq jd (mapcar '+ o1 '(0. -1.65  0.)));指定衬砌中线上设计高程处坐标

　(command "pline" o1 o2 o3 "c")        ;绘制圆心三角形
  (setq yx(entlast))
  (command ".chprop" yx "" "la" "设计断面" "")

  
  ;绘制三段圆弧及设计高处底边为一条闭合的多段线
  (command "pline" rq "a" "ce" o2 rd "ce" o1 ld "ce" o3 lq "l" "c" "")
　(setq shejidmx (entlast))
  (command "region" shejidmx "");生成面域
  (setq shejidmx (entlast))
  (command "area"  "o" shejidmx "" )
  (setq area1 (getvar "area"));获取设计断面的面积               
  (command ".chprop" shejidmx "" "la" "设计断面" "")


  


  ;以下绘制实际开挖断面线
(if (not fn_sxy)
  (setq fn_sxy "E:\jkjc\\");此处为断面线数据文件所在路径
)
(SETQ fn_sxy
       (GETFILED
         "选择 .sxy 隧道实际开挖断面线数据文件  Copyright(C)2004.12  Ver2004.12.21"
         fn_sxy
         "sxy"
         4
       )
)
(if fn_sxy
  (progn
    (setq fn (open fn_sxy "r"))
    (while (setq DSS (read-line fn))
      (SETQ DS (READ (STRCAT "(" DSS ")")))
      (setq licheng (car ds)  num (cadr ds)  zbiao  (list(list (- x1 p1) (-  y1 1.65)  0. )))
      
      (repeat num
        (setq DSS (read-line fn))
        (SETQ DS (READ (STRCAT "(" DSS ")")))
        (setq xi (+ x1 (nth 8 ds )) yi (+ (- y1 1.65) ( nth 6 ds )) )
       
        (setq zbiao (cons (list xi yi 0.) zbiao))
      )                                        ;end repeat
        (setq zbiao (cons rq zbiao))
      
        ;绘制实际开挖断面线
        (SETQ P3 (CAR ZBIAO) ZBIAO (CDR ZBIAO) WIDH 0.0)
         (COMMAND "PLINE" P3 "W" WIDH "")
         (repeat (+ num 1)
                 (command (car zbiao))
                (setq zbiao (cdr zbiao))
         );end of repeat
         (command)
         (SETQ ss (ENTLAST))
         (command "pedit" ss "c" "")
         (command "region" ss "");生成面域
         (SETQ ss (ENTLAST))
         (command "area" "o" ss "")
         (setq area2 (getvar "area"));获取实际断面的面积
         (command ".chprop" ss "" "la" "实测断面" "")

      )

         
    )                                        ;end while
    (close fn)
  
)                                        ;end if

  ;以下用于计算超、欠挖面积
  　(command ".copy" ss "" rd rd)　
    (setq ss1(entlast))
    (command ".copy" shejidmx "" rd rd)
    (setq shejidmx1(entlast))
    (command "union" ss1 shejidmx1 "")
    (setq toal(entlast))
    (command "area" "o" toal "")
    (setq area3 (getvar "area"));实际断面线与设计断面线并集的面积
    (setq chaoarea (- area3 area1));超挖面积
    (setq qianarea (- area1 (- area2 chaoarea)));欠挖面积
    (command "erase" toal "")

　
;以下标注各项面积
  (setq ptext1 (mapcar '+ o1 '(0. 0.6  0.)))
  (setq area1 (rtos area1))
  (setq sarea1 (strcat "设计面积为 " area1 " 平方米"))
  (command "text"   "j" "mc" ptext1 0.15  sarea1 "" "");在指定位置标注设计断面的面积
  (setq pt1(entlast))
  (command ".chprop" pt1 "" "la" "设计断面" "")

  
　(setq ptext2 (mapcar '+ o1 '(0. 1.0  0.)))
  (setq area2 (rtos area2))
  (setq area2 (strcat "实际开挖面积为 " area2 " 平方米"))
  (command "text"   "j" "mc" ptext2 0.15  area2 "" "");在指定位置标注实际断面的面积
  (setq pt2(entlast))
  (command ".chprop" pt2 "" "la" "实测断面" "")


  (setq ptext3 (mapcar '+ o1 '(0. 1.4  0.)))
  (setq chaoarea (rtos chaoarea))
  (setq chaoarea (strcat "超挖面积为 " chaoarea " 平方米"))
  (command "text"   "j" "mc" ptext3 0.15  chaoarea "" "");在指定位置标注超挖的面积
  (setq pt3(entlast))
  (command ".chprop" pt3 "" "la" "实测断面" "")



  (setq ptext4 (mapcar '+ o1 '(0. 1.8  0.)))
  (setq qianarea (rtos qianarea))
  (setq qianarea (strcat "欠挖面积为 " qianarea " 平方米"))
  (command "text"   "j" "mc" ptext4 0.15  qianarea "" "");在指定位置标注欠挖的面积
  (setq pt4(entlast))
  (command ".chprop" pt4 "" "la" "实测断面" "")
  


  (setq ptext5 (mapcar '+ o1 '(0. 2.2  0.)))
  (setq licheng (rtos licheng))
  (setq licheng (strcat "本断面里程为： " licheng ))
  (command "text"  "j" "mc" ptext5 0.15  licheng "" "");在指定位置标注本段面的里程
  (setq pt5(entlast))
  (command ".chprop" pt5 "" "la" "设计断面" "")
  
  (setvar "blipmode" sblip)
  (setvar "cmdecho" scmde)
  (SETVAR "CLAYER" LA)
  (SETVAR "OSMODE" OSM)
  )


以下为实际开挖轮廓线数据的样本：
里程　　测点数
数据处理前观测序号　　测点里程　　断面设计高　　测点距设计高程的的高差　测点位于中线的左\右边　　测点距中线平距　　　实测半径
        79248 　9
9        79247.478        364.122        1.497        Z        -5.794        6.893
8        79247.633        364.124        2.981        Z        -5.581        6.945
7        79247.716        364.125        5.321        Z        -4.424        5.748
6        79248.010        364.130        6.970        Z        -2.561        5.904
5        79247.809        364.127        7.394        Z        -0.065        5.744
1        79248.151        364.132        7.093        Y        1.774        5.724
2        79249.123        364.146        5.711        Y        4.106        5.775
3        79248.599        364.138        2.604        Y        5.849        7.109
4        79248.260        364.133        0.789        Y        6.064        7.152

请指点迷津，多谢！附上我用此程序生成的图形。