找回密码
 立即注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

查看: 1887|回复: 5

[每日一码] Cass再开发

[复制链接]
发表于 2016-6-1 21:07:42 | 显示全部楼层 |阅读模式

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

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

×
;;;高程差值,根据两已知高程点,计算期间任意差差值点
(vl-load-com)
(setvar "cmdecho" 0)
(defun c:i** ()
    (setq osmode-save (getvar "osmode"))
    (setvar "osmode" 64)
    (setq **1 (car (entsel "\nSelect the first **:")))
    (setq pt1 (cdr (assoc 10 (entget **1))))
    (setq h1 (last pt1))
    (setq pt1 (reverse (cdr (reverse pt1))))

    (setq **2 (car (entsel "\nSelect the second **:")))
    (setq pt2 (cdr (assoc 10 (entget **2))))
    (setq h2 (last pt2))
    (setq pt2 (reverse (cdr (reverse pt2))))
    (while (and **2 **1)
        (setq pt (getpoint "\nInsert ** postion:"))
        (setq pt (reverse (cdr (reverse pt))))
        (setq d1 (distance pt1 pt))
        (setq dis (+ d1 (distance pt pt2)))
        (setq dis2 (distance pt1 pt))
        (setq dh12 (- h2 h1))
        (setq h (+ h1 (* dh12 (/ dis2 dis))))
        (setq pt (list (car pt) (cadr pt) h))
        (setvar "osmode" 0)
        (command "insert"
                 "GC200"
                 pt
                 0.2
                 0.2
                 0.2
                 (rtos h 2 2)
                 ""
        )
        (setq **1 nil
              **2 nil
        )
        (setvar "osmode" 64)
        (setq **1 (car (entsel "\nSelect the first **:")))
        (setq pt1 (cdr (assoc 10 (entget **1))))
        (setq h1 (last pt1))
        (setq pt1 (reverse (cdr (reverse pt1))))
        (setq **2 (car (entsel "\nSelect the second **:")))
        (setq pt2 (cdr (assoc 10 (entget **2))))
        (setq h2 (last pt2))
        (setq pt2 (reverse (cdr (reverse pt2))))
    )
    (setvar "osmode" osmode-save)

)
;;;根据cass方格网计算的高程求差,并标注。

(defun c:get-cha ()
    (setq entlst1 (entget (car (entsel "\n选择注记1:"))))
    (setq entlst2 (entget (car (entsel "n\选择注记2:"))))
    (while (and entlst1 entlst2)
        (setq str1 (cdr (assoc 1 entlst1)))
        (setq str2 (cdr (assoc 1 entlst2)))
        (setq pt1 (cdr (assoc 10 entlst1)))
        (setq pt2 (cdr (assoc 10 entlst2)))
        (setq num1 (atof (substr str1 3)))
        (setq num2 (atof (substr str2 3)))
        (setq cha (- num1 num2))
        (if (> cha 0.0)
            (setq str "挖方=")
            (setq str "填方=")
        )
        (setq str (strcat str (rtos cha 2 1)))
        (setq pt (polar pt2 (angle pt1 pt2) (distance pt1 pt2)))
        (command "text" pt 1.5 0.0 str "")
        (setq entlst1 (entget (car (entsel "\n选择注记1:"))))
        (setq entlst2 (entget (car (entsel "n\选择注记2:"))))
    )
)

;;;取得高程点形成cass.dat文件
(defun c:get**        ()
    (setq cc (getfiled "选择点文件名"
                       "E:\\土石方工程量计算\\1号场平"
                       "dat"
                       1
             )
    )
    (setq ff (open cc "w"))
    (setq num 1)
    (setq str (getstring "加入编号吗(Y/N)"))
    (if        (= (strcase str) "Y")
        (setq numhead (getstring "点号头字母:"))
        (setq numhead "pt")
    )
    (setq pt (getpoint "\n选择区域一角:"))
    (setq ss (ssget "C" pt (getcorner pt "\n对角:") '((0 . "INSERT"))))
    (setq sslen (sslength ss))

    (setq i 0)
    (repeat sslen
        (setq e1 (ssname ss i))
        (setq pt (cdr (assoc 10 (entget e1))))
        (print (1+ i) ff)
        (princ ",," ff)
        (princ (rtos (car pt) 2 3) ff)
        (princ "," ff)
        (princ (rtos (cadr pt) 2 3) ff)
        (princ "," ff)
        (princ (rtos (caddr pt) 2 3) ff)
        (setq i (1+ i))
    )
    (princ)
    (close ff)

)

;;根据等高线差插值高程点
(defun c:dgx2** ()
    (command "layer" "m" "NH**" "" "")
    (setq ent1 (entsel "\nSelect the first DGX:"))
    (setq pt1  (cadr ent1)
          ent1 (entget (car ent1))
    )
    (setq pt1 (reverse (cdr (reverse pt1))))
    (print pt1)
    (setq entname (cdr (assoc 0 ent1)))

    (if        (= entname "POLYLINE")
        (setq h1 (last (assoc 10 ent1)))
    )
    (if        (= entname "LWPOLYLINE")
        (setq h1 (cdr (assoc 38 ent1)))
    )
;;;
    (setq ent2 (entsel "\nSelect the Second DGX:"))
    (setq pt2  (cadr ent2)
          ent2 (entget (car ent2))
    )
    (setq pt2 (reverse (cdr (reverse pt2))))
    (print pt2)
    (setq entname (cdr (assoc 0 ent2)))

    (if        (= entname "POLYLINE")
        (setq h2 (last (assoc 10 ent2)))
    )
    (if        (= entname "LWPOLYLINE")
        (setq h2 (cdr (assoc 38 ent2)))
    )
;;;
    (setq pt (getpoint "\nInsert ** postion:"))
    (print "pt=")
    (princ pt)
;;;    (setq pt (reverse (cdr (reverse pt))))
    (setq d1 (distance pt1 pt))
    (setq dis (+ d1 (distance pt pt2)))
    (setq dis2 (distance pt1 pt))
    (setq dh12 (- h2 h1))
    (setq h (+ h1 (* dh12 (/ dis2 dis))))
    (setq pt (list (car pt) (cadr pt) h))
    (command "insert" "GC200" pt 1.0 1.0 0.0 (rtos h 2 2) "")
    (command "layer" "OFF" "NH**" "" "")
)

;;三点确定平面上插任意点
;;无返回值


(defun c:isjx ()
    (setq s-osmode (getvar "osmode"))
    (setvar "osmode" 559)
    (setq ent (car (entsel "\nSelect Plane or SJX:")))
    (setq pt (getpoint "\nSelect insertpoint:"))
    (while (and ent pt)
        (setq obj (vlax-ename->vla-object ent))
        (setq pts (vla-get-coordinates obj))
        (setq pts (vlax-variant-value pts))
        (setq pts (vlax-safearray->list pts))
        (print pts)
        (setq len (/ (length pts) 3))
        (setq i 0)
        (setq ptlst nil)
        (repeat        len
            (setq e1  (car pts)
                  pts (cdr pts)
                  e2  (car pts)
                  pts (cdr pts)
                  e3  (car pts)
                  pts (cdr pts)
            )
            (setq ptlst (cons (list e1 e2 e3) ptlst))
        )
        (setq xsh (jsxsh ptlst))
        (setq pt1 (car ptlst))
        (setq x1 (car pt1)
              y1 (cadr pt1)
              z1 (caddr pt1)
        )
        (setq A        (car xsh)
              B        (cadr xsh)
              C        (caddr xsh)
              D (last xsh)
        )
        (setq x        (car pt)
              y        (cadr pt)
        )
        (setq z (/ (+ (* A x) (* B y) D) (* -1.0 C)))
        (setq pt (list x y z))
;;;
        (setvar "osmode" 0)
        (command "insert" "GC200" pt 1.0 1.0 0.0 (rtos z 2 2) "")
        (setq ent nil
              pt  nil
        )
        (setq ent (car (entsel "\nSelect Plane or SJX:")))
        (setvar "osmode" 559)
        (setq pt (getpoint "\nSelect insertpoint:"))
       
    )

    (setvar "osmode" s-osmode)
    (princ)

)

;;选择line线,在其两端插入高程点

(defun c:iline ()
    (setq s-osmode (getvar "osmode"))
    (setvar "osmode" 0)
    (setq ent (car (entsel "\nSelect line:")))
    (setq pt1 (cdr (assoc 10 (entget ent))))
    (setq z1 (last pt1))
    (setq pt2 (cdr (assoc 11 (entget ent))))
    (setq z2 (last pt2))
    (while ent
        (command "insert" "GC200" pt1 1.0 1.0 0.0 (rtos z1 2 2) "")
        (command "insert" "GC200" pt2 1.0 1.0 0.0 (rtos z2 2 2) "")
        (setq ent (car (entsel "\nSelect line:")))
        (setq pt1 (cdr (assoc 10 (entget ent))))
        (setq z1 (last pt1))
        (setq pt2 (cdr (assoc 11 (entget ent))))
        (setq z2 (last pt2))
    )
    (setvar "osmode" s-osmode)
)



;;;计算开挖边界线
;;;根据两组三角网计算两个面的交线

(vl-load-com)
(prompt "getjx")
(defun c:getjx ()
    (setq lname1 "sjw0")                ;(strcase (getstring "\n第一层三角网图层名:")))
    (setq lname2 "sjw1")                ;(strcase (getstring "\n第二层三角网图层名:")))
    (setq pt (getpoint "\n选择区域一角:"))
    (setq ss (ssget "C"
                    pt
                    (getcorner pt "\n对角:")
;;;                    '((0 . "3DPOLYLINE"))
             )
    )
    (setq tongji 0)
    (setq sslen (sslength ss))
    (setq sjw1 nil
          sjw2 nil
          i 0
          sjwlst1 nil
          sjwlst2 nil
          triabcdlst1
             nil
          triabcdlst2
             nil
          maxmin1 nil
          maxmin2 nil
    )
    (repeat sslen
        (setq e (ssname ss i))
        (setq lname (cdr (assoc 8 (entget e))))
        (if (and (= lname lname1)
                 (= (cdr (assoc 0 (entget e))) "POLYLINE")
            )
            (progn
                (setq sjw1 (cons e sjw1))
                (setq sjx3dpt (get3dpoint e))
                (setq sjwlst1 (cons sjx3dpt sjwlst1))
                (setq triabcdlst1 (cons (jsxsh sjx3dpt) triabcdlst1))
                (setq maxmin1 (cons (getmaxmin sjx3dpt) maxmin1))
            )
        )
        (if (and (= lname lname2)
                 (= (cdr (assoc 0 (entget e))) "POLYLINE")
            )
            (progn
                (setq sjw2 (cons e sjw2))
                (setq sjx3dpt2 (get3dpoint e))
                (setq sjwlst2 (cons sjx3dpt2 sjwlst2))
;;;计算系数abcd->triabcdlst((abcd) ...)
                (setq triabcdlst2 (cons (jsxsh sjx3dpt2) triabcdlst2))
;;;计算极值maxmin->maxmin((xmax ymax zmax xmin ymin zmin)...)
                (setq maxmin2 (cons (getmaxmin sjx3dpt2) maxmin2))
            )
        )
        (setq i (1+ i))
    )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;;依第一三角网为依据
    (setq sjx nil)
    ;;从sjw1中取出一个三角形sjx
    (while sjw1
        (setq sjx  (car sjw1)
              sjw1 (cdr sjw1)
        )
;;;        (setq sjxobj (vlax-ename->vla-object sjx))
;;;        (setq sjxlw (vla-get-lineweight sjxobj))
;;;        (vla-put-lineweight sjxobj acLnWt030)
;;;        (vla-update sjxobj)

        (setq sjxpts  (car sjwlst1)
              sjwlst1 (cdr sjwlst1)
              mm1     (car maxmin1)
              maxmin1 (cdr maxmin1)
        )
        (setq
            x2 (car mm1)
            y2 (cadr mm1)
            z2 (caddr mm1)
            x1 (nth 3 mm1)
            y1 (nth 4 mm1)
            z1 (nth 5 mm1)
        )
        (setq abcd          (car triabcdlst1)
              triabcdlst1 (cdr triabcdlst1)
        )
        ;;遍sjw2中三角形,如果sjxi与sjx相交或相互包含,求交线,如果有绘出,否则从sjw2取下一三角形。
        (setq i 0)
        (setq len2 (length sjw2))
        (repeat        len2
;;;            (setq sjxi (nth i sjw2))
;;;            (setq sjxiobj (vlax-ename->vla-object sjxi))
;;;            (setq sjxilw (vla-get-lineweight sjxiobj))
;;;            (vla-put-lineweight sjxiobj acLnWt030)
;;;            (vla-update sjxiobj)



            (setq mm2 (nth i maxmin2))
            (setq
                xi2 (car mm2)
                yi2 (cadr mm2)
                zi2 (caddr mm2)
                xi1 (nth 3 mm2)
                yi1 (nth 4 mm2)
                zi1 (nth 5 mm2)
            )

;;;如果两个三角形平面投影相交
            (if        (and (or
;;;                         (> z2 zi1 z1)
;;;                         (> z2 zi2 z1)
                         (and (> x2 xi2 x1) (> y2 yi1 y1))
                         (and (> x2 xi1 x1) (> y2 yi1 y1))
                         (and (> x2 xi1 x1) (> y2 yi2 y1))
                         (and (> x2 xi2 x1) (> y2 yi2 y1))
                         (and (> xi2 x2 xi1) (> yi2 y2 yi1))
                         (and (> xi2 x2 xi1) (> yi2 y1 yi1))
                         (and (> xi2 x1 xi1) (> yi2 y1 yi1))
                         (and (> xi2 x1 xi1) (> yi2 y2 yi1))
;;;cross
                         (and (> xi2 x2)
                              (> y2 yi2)
                              (> x2 xi1)
                              (> yi1 y1)
                         )
                         (and (> x2 xi2)
                              (> yi2 y2)
                              (> xi1 x1)
                              (> y1 yi1)
                         )
;;;                         (and (> zi2 z1) (> z1 zi1))
                     )
                     (or
                         (> z2 zi1 z1)
                         (> z2 zi2 z1)
                         (and (> zi2 z2) (> z1 zi1))
                     )
                )
;;; 计算交点
                (progn
;;;求sjxi的边与sjx的交点。
                    (setq sjxipts (nth i sjwlst2))
                    (setq abcdi (nth i triabcdlst2))
                    (setq flag1        0
                          flag2        0
                          flag3        0
                          flag 0
                    )
                    (setq pt1 nil
                          pt2 nil
                          pt3 nil
                    )
                    (setq
                        pt1 (getcpt (car sjxipts) (cadr sjxipts) abcd)
                    )
                    ;;(command "donut" 0.1  0.5 pt1 "")
                    (setq pt2
                             (getcpt (cadr sjxipts) (caddr sjxipts) abcd)
                    )
                    ;;(command "donut" 0.1  0.5 pt2 "")
                    (setq pt3
                             (getcpt (caddr sjxipts) (car sjxipts) abcd)
                    )
                    ;;(command "donut" 0.1  0.5 pt3 "")
;;;判断pt1-3是否在sjx内。
                    (if        (ptinsjx pt1 sjxpts)
                        (setq flag1 1)
                    )
                    (if        (ptinsjx pt2 sjxpts)
                        (setq flag2 2)
                    )
                    (if        (ptinsjx pt3 sjxpts)
                        (setq flag3 4)
                    )
;;;按位与计算
                    (setq flag (mulor (list flag1 flag2 flag3)))

;;;求sjx的边与sjxi的交点。

                    (setq flag1i 0
                          flag2i 0
                          flag3i 0
                          flagi        0
                    )
                    (setq pt1i nil
                          pt2i nil
                          pt3i nil
                    )
                    (setq
                        pt1i (getcpt (car sjxpts) (cadr sjxpts) abcdi)
                    )
                    ;;(command "circle"  pt1i 1.0 "")
                    (setq pt2i
                             (getcpt (cadr sjxpts) (caddr sjxpts) abcdi)
                    )
                    ;;(command "circle"  pt2i 1.0 "")
                    (setq pt3i
                             (getcpt (caddr sjxpts) (car sjxpts) abcdi)
                    )
                    ;;(command "circle"  pt3i 1.0 "")
;;;判断pt1-3是否在sjxi内。
                    (if        (ptinsjx pt1i sjxipts)
                        (setq flag1i 1)
                    )
                    (if        (ptinsjx pt2i sjxipts)
                        (setq flag2i 2)
                    )
                    (if        (ptinsjx pt3i sjxipts)
                        (setq flag3i 4)
                    )
                                        ;按位与计算
                    (setq flagi (mulor (list flag1i flag2i flag3i)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;根据线面交点在三角形内的不同情况进行分析。

                    (cond
;;; sjxi 与 sjx 相互无实交点。
                        ((and (= flagi 0) (= flag 0))
                         (print "no point")
                         (setq tongji (1+ tongji))
                        )
;;; sjx的边 与 sjxi面有交点
                        ((and (= flagi 0) (/= flag 0))
                         (cond
                             ((= flag 3)
                              (command "line" pt1 pt2 "")
                             )
                             ((= flag 5)
                              (command "line" pt1 pt3 "")
                             )
                             ((= flag 6)
                              (command "line" pt2 pt3 "")
                             )
                         )
                        )
;;; sjxi的边与sjx面有交点
                        ((and (/= flagi 0) (= flag 0))
                         (cond
                             ((= flagi 3)
                              (command "line" pt1i pt2i "")
                             )
                             ((= flagi 5)
                              (command "line" pt1i pt3i "")
                             )
                             ((= flagi 6)
                              (command "line" pt2i pt3i "")
                             )
                         )
                        )
;;;当sjxi面与sjx面交错开,各有一个交点。
                        ((and (/= flagi 0) (/= flag 0))
                         (cond
                             ((= flagi 1)
                              (cond
                                  ((= flag 1)
                                   (command "line" pt1i pt1 "")
                                  )
                                  ((= flag 2)
                                   (command "line" pt1i pt2 "")
                                  )
                                  ((= flag 4)
                                   (command "line" pt1i pt3 "")
                                  )
                              )
                             )
                             ((= flagi 2)
                              (cond
                                  ((= flag 1)
                                   (command "line" pt2i pt1 "")
                                  )
                                  ((= flag 2)
                                   (command "line" pt2i pt2 "")
                                  )
                                  ((= flag 4)
                                   (command "line" pt2i pt3 "")
                                  )
                              )
                             )

                             ((= flagi 4)
                              (cond
                                  ((= flag 1)
                                   (command "line" pt3i pt1 "")
                                  )
                                  ((= flag 2)
                                   (command "line" pt3i pt2 "")
                                  )
                                  ((= flag 4)
                                   (command "line" pt3i pt3 "")
                                  )
                              )
                             )
                         )
                        )
                    )
;;; end cond

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
                )
;;;endprogn
            )
;;; end if
            (setq i (1+ i))
;;;            (vla-put-lineweight sjxiobj sjxilw)
;;;            (vla-update sjxiobj)
        )
;;;        (vla-put-lineweight sjxobj sjxlw)
;;;        (vla-update sjxobj)
;;;end repeat

    )
;;;end while
    (print "no point=")
    (princ tongji)

)

;;;求三角形实体的坐标表
;;; e-三角形实体,返回值(pt1 pt2 pt3)
(defun get3dpoint (e / sjxpt)
    (setq sjxpt        (vlax-safearray->list
                    (vlax-variant-value
                        (vla-get-coordinates
                            (vlax-ename->vla-object e)

                        )
                    )
                )
    )

    (setq sjxpt (reverse (list->points sjxpt)))
)


;;;计算3d点表的极值
(defun getmaxmin (3dlst)
    (list (apply 'max (mapcar 'car 3dlst))
          (apply 'max (mapcar 'cadr 3dlst))
          (apply 'max (mapcar 'caddr 3dlst))
          (apply 'min (mapcar 'car 3dlst))
          (apply 'min (mapcar 'cadr 3dlst))
          (apply 'min (mapcar 'caddr 3dlst))
    )
)

;;; 数字列表转化为坐标表3d
;;; (a b c d e f g h i...)->((a b c) (d e f) (g h i)...)
(defun list->points (numlst / x y z tmp)
    (setq count (length numlst))
    (repeat (/ count 3)
        (setq x        (car numlst)
              y        (cadr numlst)
              z        (caddr numlst)
        )
        (setq numlst (cdddr numlst))
        (setq tmp (cons (list x y z) tmp))
    )
    tmp
)

;;;定义or函数(or int1 int2 ...)

(defun mulor (intlst / e1)
    (if        (>= (length intlst) 2)
        (progn
            (setq e1         (car intlst)
                  intlst (cdr intlst)
            )
            (while intlst
                (setq
                    e1 (boole 7
                              e1
                              (car intlst)
                       )
                )
                (setq
                    intlst (cdr intlst)
                )
            )
        )
    )
    e1
)


;;;根据两点建立空间直线方程,并求解与面Ax+By+Cz+D=0的交点
;;返回值为交点pt,无交点nil

(defun getcpt (pt1  pt2         abcd /           x1        y1   z1          x2   y2   z2         a
               b    c         d    dx   dy        dz   dxdy dzdy AA   BB         x
               y    z         pt   tt   d12        d1p  d2p
              )
    (setq pt  nil
          d12 0.0
          d1p 0.0
          d2p 0.0
    )
    (setq x1 (car pt1)
          y1 (cadr pt1)
          z1 (caddr pt1)
    )
    (setq x2 (car pt2)
          y2 (cadr pt2)
          z2 (caddr pt2)
    )
    (setq a (car abcd)
          b (cadr abcd)
          c (caddr abcd)
          d (cadddr abcd)
    )
    (setq m (- x2 x1)
          n (- y2 y1)
          p (- z2 z1)
    )
    (setq AA (+        (* a m)
                (* b n)
                (* c p)
             )
          BB (+        (* a x1)
                (* b y1)
                (* c z1)
                d
             )
    )
    (if        (> (abs aa) 0.00001)
        (setq tt (/ (* bb -1) aa)
              x         (+ x1 (* m tt))
              y         (+ y1 (* n tt))
              z         (+ z1 (* p tt))
              pt (list x y z)
        )
    )
;;;pt 是否在 pt1与 pt2之间,如果在期间,有实交点,否则为虚交点。
    (if        (> x1 x2)
;;;x1>x2
        (if (or (<= x x2) (>= x x1))
            (setq pt nil)
        )
;;;x1<x2
        (if (or (<= x x1) (>= x x2))
            (setq pt nil)
        )
    )
    pt
)

;;;判断点pt是否在三角形sjx内,如果在返回t,否则返回nil。       

(defun ptinsjx (pt sjx / pt1 pt2 pt3 yn)
    (if        pt
        (progn
            (setq pt1 (car sjx)
                  pt2 (cadr sjx)
                  pt3 (caddr sjx)
            )
            (if        (and (>= (sameside pt1 pt2 pt3 pt) 0.0)
                     (>= (sameside pt2 pt3 pt1 pt) 0.0)
                     (>= (sameside pt3 pt1 pt2 pt) 0.0)
                )
                (setq yn t)
            )
        )
        (setq yn nil)
    )
)


;;;判断pt3与pt是否在pt1-pt2的同一侧,如果同侧返回值>=0,否则<0.
(defun sameside        (pt1 pt2 pt3 pt / ab ac ap v1 v2)
    (setq ab (vector3 pt1 pt2)
          ac (vector3 pt1 pt3)
          ap (vector3 pt1 pt)
    )
    (setq v1 (cross ab ac)
          v2 (cross ab ap)
    )
    (dot v1 v2)
)

;;;根据向量两端坐标计算向量分量

(defun vector3 (pt1 pt2)
    (mapcar '- pt2 pt1)
)

;;;向量叉积计算
;;;  | i  j  k|
;;;  |x1 y1 z1|=axb
;;;  |x2 y2 z2|

(defun cross (a b / x1 y1 z1 x2 y2 z2)
    (setq x1 (car a)
          y1 (cadr a)
          z1 (caddr a)
          x2 (car b)
          y2 (cadr b)
          z2 (caddr b)
    )
    (list (- (* y1 z2) (* y2 z1))
          (- (* x2 z1) (* x1 z2))
          (- (* x1 y2) (* x2 y1))
    )
)


;;; 平面方程Ax+By+Cz+D=0的系数计算
;;; 返回值(A B C D)

(defun jsxsh (ptlst / pt1 pt2 pt3 x1 y1 z1 x2 y2 z2 x3 y3 z3 a b c d)
    (setq pt1 (car ptlst)
          pt2 (cadr ptlst)
          pt3 (caddr ptlst)
    )
    (setq x1 (car pt1)
          y1 (cadr pt1)
          z1 (caddr pt1)
    )
    (setq ab (vector3 pt1 pt2)
          ac (vector3 pt1 pt3)
    )
    (setq v1 (cross ab ac))
    (setq A (car v1)
          B (cadr v1)
          C (caddr v1)
    )
    (setq D (* -1.0
               (+ (* A x1) (* B y1) (* C z1))
            )
    )
    (list A B C D)
)

;;;点积计算
(defun dot (r1 r2)
    (+ (* (car r1) (car r2))
       (* (cadr r1) (cadr r2))
       (* (caddr r1) (caddr r2))
    )
)


(defun 3d->2d (pt)
    (list (car pt) (cadr pt))
    )

;;三角网转化为3Dface
;;无返回值


(defun c:s23df()
    (setvar "osmode" 0)
    (setq pt (getpoint "\n选择区域一角:"))
    (setq sssjw (ssget "C" pt (getcorner pt "\n对角:")'((8 . "SJW"))))
    (setq sslen (sslength sssjw)
          i 0)
    (print "sslen= ") (princ sslen)
    (repeat sslen
        ;;;提取三角形三点
        (setq sjx (ssname sssjw i))
        (setq obj (vlax-ename->vla-object sjx))
        (setq pts (vla-get-coordinates obj))
        (setq pts (vlax-variant-value pts))
        (setq pts (vlax-safearray->list pts))
        (setq i (1+ i))
        ;;;绘制3dface
        (setq pt1 (list (nth 0 pts) (nth 1 pts) (nth 2 pts))
              pt2 (list (nth 3 pts) (nth 4 pts) (nth 5 pts))
              pt3 (list (nth 6 pts) (nth 7 pts) (nth 8 pts)))
        (command "3dface" pt1 pt2 pt3 "" "")
    )
)


;;;根据两个数字text差,offset线段

(defun c:toffset ()
    (setq entlst1 (entget (car (entsel "\n选择注记1:"))))
    (setq entlst2 (entget (car (entsel "n\选择注记2:"))))
    (while (and entlst1 entlst2)
        (setq str1 (cdr (assoc 1 entlst1)))
        (setq str2 (cdr (assoc 1 entlst2)))
        (setq pt1 (cdr (assoc 10 entlst1)))
        (setq pt2 (cdr (assoc 10 entlst2)))
        (setq num1 (atof str1))
        (setq num2 (atof str2))
        (setq cha (- num1 num2))
        (setq ent (car (entsel "\n选择offset对象:")))
        (setq pt (getpoint "\n偏移方向:"))
        (command "offset" cha ent pt "")
        (setq entlst1 (entget (car (entsel "\n选择注记1:"))))
        (setq entlst2 (entget (car (entsel "n\选择注记2:"))))
    )
)





;;;取得多段线点形成**.txt文件,用于平差易坐标转换计算
(defun c:gplpts()
    (setq cc (getfiled "选择点文件名"
                       "E:\\土石方工程量计算\\1号场平"
                       "txt"
                       1
             )
    )
    (setq ff (open cc "w"))
    (setq lineorder 0) ;;线顺序号
    (setq pt (getpoint "\n选择区域一角:"))
    (setq ss (ssget "C" pt (getcorner pt "\n对角:") '((0 . "LWPOLYLINE"))))
    (setq sslen (sslength ss))
    (setq ent (ssname ss lineorder))
    (print '[EARTHKNOWNDATA] ff)
    (setq count 1)

    (while ent
        (setq str1 (strcat (rtos (1+ lineorder) 2 0) "-"))
        (setq obj (vlax-ename->vla-object ent))
        (setq pts (vla-get-coordinates obj))
        (setq pts (vlax-variant-value pts))
        (setq pts (vlax-safearray->list pts))
        (setq len (/ (length pts) 2))
        (setq i 1)
        (setq ptlst nil)
        (repeat        len
            (setq e1  (car pts)
                  pts (cdr pts)
                  e2  (car pts)
                  pts (cdr pts)
            )
            (setq str2 (rtos i 2 0))
            (setq i (1+ i))
            (setq ptlst (cons (list e2 e1) ptlst))
;;;            (print count ff)
;;;            (princ "," ff)
            (print (strcat str1 str2) ff)
            (princ "," ff)
            (princ (rtos e2 2 3) ff)
            (princ "," ff)
            (princ (rtos e1 2 3) ff)
            (princ "," ff)
            (setq count (1+ count))
            )
        (setq lineorder (1+ lineorder))
        (setq ent (ssname ss lineorder))
    )
;;;    (print "[EARTHUNKNOWNDATA]" ff)

    (close ff)(princ)

)

;;                        | x1 y1 1 |
;;计算三角网体积,Ssjx=0.5*| x2 y2 1 |=0.5*(x1*y2+x2*y3+x3*y1-x3*y2-x2*y1-x1*y3),点从上到下为逆时针排列,否则为负值
;;                        | x3 y3 1 |
;;无返回值


(defun c:svol ()
    (setq s-osmode (getvar "osmode"))
    (setvar "osmode" 559)
    (setq ent (car (entsel "\nSelect Plane or SJX:")))
    (setq z0 0.0);;(getreal "\nInput base gch:"))
    (setq obj (vlax-ename->vla-object ent))
    (setq pts (vla-get-coordinates obj))
    (setq pts (vlax-variant-value pts))
    (setq pts (vlax-safearray->list pts))
    (print pts)
    (setq len (/ (length pts) 3))
    (setq ptlst nil)
    (setq jzhgch 0.0);;高程均值
    (setq pmax nil pmin nil zmax -0.00004 zmin 10000000.0);;z最大最小
    (setq i 0)
    (repeat len
        (setq x  (car pts)
              pts (cdr pts)
              y  (car pts)
              pts (cdr pts)
              z  (car pts)
              pts (cdr pts)
              )
        (if (> z zmax) (setq zmax z imax i))
        (if (< z zmin) (setq zmin z imin i))
        (setq ptlst (cons (list x y  z) ptlst))
        (setq jzhgch (+ jzhgch z))
        (setq i (1+ i))
    )
    (setq ptlst (reverse ptlst))
    (setq p1 (nth imin ptlst);;最低点
          p3 (nth imax ptlst));;最高点
    (cond
        ((= imax 0)
         (if (= imin 1) (setq p2 (nth 2 ptlst)))
         (if (= imin 2) (setq p2 (nth 1 ptlst)))
         )
        ((= imax 1)
         (if (= imin 0) (setq p2 (nth 2 ptlst)))
         (if (= imin 2) (setq p2 (nth 0 ptlst)))
         )
        ((= imax 2)
         (if (= imin 0) (setq p2 (nth 1 ptlst)))
         (if (= imin 1) (setq p2 (nth 0 ptlst)))
         )
        )
    (setq jzhgch (/ jzhgch 3.0))
;;                        | x1 y1 1 |
;;计算三角网体积,Ssjx=0.5*| x2 y2 1 |=0.5*(x1*y2+x2*y3+x3*y1-x3*y2-x2*y1-x1*y3),点从上到下为逆时针排列,否则为负值
;;                        | x3 y3 1 |
    (setq x1 (car p1) y1 (cadr p1) z1 (caddr p1)
          x2 (car p2) y2 (cadr p2) z2 (caddr p2)
          x3 (car p3) y3 (cadr p3) z3 (caddr p3))
;;; 构成侧面点p2'(x2 y2 z1)  p2(x2 y2 z2)  p3 (x3 y3 z3) p3'(x3 y3 z1)
    (setq p2p (list x2 y2 z1)
          p3p (list x3 y3 z1))
    ;; 求侧面积按梯形求解
    (setq ca (* (+ (- z2 z1) (- z3 z1)) (distance p2p p3p) 0.5))
    ;; 求最低点到侧面距离
    (setq pts (list p3 p2 p2p))
    (setq abcd (jsxsh pts))
    (setq a (car abcd)
          b (cadr abcd)
          c (caddr abcd)
          d (last abcd))
    (setq dis (abs (/ (+ (* x1 a) (* y1 b) (* z1 c) d) (sqrt (+ (* a a) (* b b) (* c c))))))
    ;;计算体积
    (setq v1 (/ (* ca dis) 3.0))
    (setq v2 (* (abs (* 0.5
                          (- (+ (* x1 y2) (* x2 y3) (* x3 y1))
                             (+ (* x3 y2) (* x2 y1) (* x1 y3)))
                          ))
                (- z1 z0)
                ))
    (alert (strcat "SJW Volume1 = " (rtos (+ v1 v2) 2 6)))

    (setq v2 (* (abs (* 0.5
                          (- (+ (* x1 y2) (* x2 y3) (* x3 y1))
                             (+ (* x3 y2) (* x2 y1) (* x1 y3)))
                          ))
                (- jzhgch z0)
                ))
    (alert (strcat "SJW Volume2 = " (rtos v2 2 6)))


    (setvar "osmode" s-osmode)
    (princ)

)


;;;三角网及方格网法边界预处理
;;;根据给定的轮廓线分离新三角网,新形成的三角形顶点根据原三角网差值高程点GC200

(defun c:ibd()
    (setq pts (db (car (entsel "\nSelect the border:"))))
    (setq i 0)
    (setq pt1 (nth i pts))
    (setq pt1x (car pt1) pt1y (cadr pt1) pt1z (caddr pt1))
    (setq pt2 (nth (1+ i) pts))0
    (setq pt2x (car pt2) pt2y (cadr pt2) pt2z (caddr pt2))
    (while (and pt1 pt2)
;;;        (command "circle" pt1 1.0 "")(command "circle" pt2 2.0 "")
        (setq ss nil)
        (setq ss (ssget "C" pt1 pt2 '((8 . "SJW"))))
        (if ss (progn (print "sjws =") (princ (sslength ss))))
        ;;处理边界开始。。。
        (setq ii 0)
        (setq cpts nil) ;;交点表 ((sjxent (cpt flag) f0 f1 f2)...)
        (repeat (sslength ss)
            ;;在三角网ss中取出三角形si,并提取三维顶点svers。
            (setq si (ssname ss ii))
            (setq svers (gettrivers si))
            (setq p0 (nth 0 svers)
                  p1 (nth 1 svers)
                  p2 (nth 2 svers))
            ;;判断该三角形是否与pt1 pt2直线相交
            (setq f0 (pltest p0 (list pt1 pt2)))
            (setq f1 (pltest p1 (list pt1 pt2)))
            (setq f2 (pltest p2 (list pt1 pt2)))
            (cond
                ;;;没有交点
                ((or (and (< f0 0.0) (< f1 0.0) (< f2 0.0))
                     (and (> f0 0.0) (> f1 0.0) (> f2 0.0))
                     )
                 )
                ;;;有两个交点,一个交点在三角形的一条边上,一个交点位于三角形的顶点。
                ((and (= f0 0.0) (> f1 0.0) (< f2 0.0))
                 (setq cpt1 (ljs-inters p1 p2 pt1 pt2 "12"))
                 (setq cpts (cons (list si (list p0 "p0") f0 f1 f2) cpts))
                 (setq cpts (cons (list si cpt1 f0 f1 f2) cpts))
                 )
                ((and (= f0 0.0) (< f1 0.0) (> f2 0.0))
                 (setq cpt1 (ljs-inters p1 p2 pt1 pt2 "12"))

                 (setq cpts (cons (list si (list p0 "p0") f0 f1 f2) cpts))
                 (setq cpts (cons (list si cpt1 f0 f1 f2) cpts))
                 )
                ((and (= f1 0.0) (> f0 0.0) (< f2 0.0))
                 (setq cpt1 (ljs-inters p0 p2 pt1 pt2 "02"))

                 (setq cpts (cons (list si (list p1 "p1") f0 f1 f2) cpts))
                 (setq cpts (cons (list si cpt1 f0 f1 f2) cpts))
                 )     
                ((and (= f1 0.0) (< f0 0.0) (> f2 0.0))
                 (setq cpt1 (ljs-inters p0 p2 pt1 pt2 "02"))
                 
                 (setq cpts (cons (list si (list p1 "p1") f0 f1 f2) cpts))
                 (setq cpts (cons (list si cpt1 f0 f1 f2) cpts))
                 )
                ((and (= f2 0.0) (> f0 0.0) (< f1 0.0))
                 (setq cpt1 (ljs-inters p0 p1 pt1 pt2 "01"))
                 
                 (setq cpts (cons (list si (list p2 "p2") f0 f1 f2) cpts))
                 (setq cpts (cons (list si cpt1 f0 f1 f2) cpts))
                 )  
                ((and (= f2 0.0) (< f0 0.0) (> f1 0.0))
                 (setq cpt1 (ljs-inters p0 p1 pt1 pt2 "01"))

                 (setq cpts (cons (list si (list p2 "p2") f0 f1 f2) cpts))
                 (setq cpts (cons (list si cpt1 f0 f1 f2) cpts))
                 )   
                ;;;有两个交点,分别在两条边上。
                ((and (> f0 0.0) (< f1 0.0) (< f2 0.0))
                 (setq cpt1 (ljs-inters p0 p1 pt1 pt2 "01"))
                 (setq cpt2 (ljs-inters p0 p2 pt1 pt2 "02"))
                 (setq cpts (cons (list si cpt1 f0 f1 f2) cpts))
                 (setq cpts (cons (list si cpt2 f0 f1 f2) cpts))
                 )
                ((and (> f1 0.0) (< f2 0.0) (< f0 0.0))
                 (setq cpt1 (ljs-inters p1 p2 pt1 pt2 "12"))
                 (setq cpt2 (ljs-inters p1 p0 pt1 pt2 "01"))
                 (setq cpts (cons (list si cpt1 f0 f1 f2) cpts))
                 (setq cpts (cons (list si cpt2 f0 f1 f2) cpts))
                 )
                ((and (> f2 0.0) (< f0 0.0) (< f1 0.0))
                 (setq cpt1 (ljs-inters p2 p0 pt1 pt2 "02"))
                 (setq cpt2 (ljs-inters p2 p1 pt1 pt2 "12"))
                 (setq cpts (cons (list si cpt1 f0 f1 f2) cpts))
                 (setq cpts (cons (list si cpt2 f0 f1 f2) cpts))
                 )
                ((and (< f0 0.0) (> f1 0.0) (> f2 0.0))
                 (setq cpt1 (ljs-inters p0 p1 pt1 pt2 "01"))
                 (setq cpt2 (ljs-inters p0 p2 pt1 pt2 "02"))
                 (setq cpts (cons (list si cpt1 f0 f1 f2) cpts))
                 (setq cpts (cons (list si cpt2 f0 f1 f2) cpts))
                 )
                ((and (< f1 0.0) (> f2 0.0) (> f0 0.0))
                 (setq cpt1 (ljs-inters p1 p2 pt1 pt2 "12"))
                 (setq cpt2 (ljs-inters p1 p0 pt1 pt2 "01"))
                 (setq cpts (cons (list si cpt1 f0 f1 f2) cpts))
                 (setq cpts (cons (list si cpt2 f0 f1 f2) cpts))
                 )
                ((and (< f2 0.0) (> f0 0.0) (> f1 0.0))
                 (setq cpt1 (ljs-inters p2 p0 pt1 pt2 "02"))
                 (setq cpt2 (ljs-inters p2 p1 pt1 pt2 "12"))
                 (setq cpts (cons (list si cpt1 f0 f1 f2) cpts))
                 (setq cpts (cons (list si cpt2 f0 f1 f2) cpts))
                 )
                ;;;一条边在直线上
                ((and (= f0 0.0) (= f1 0.0) (> f2 0.0))
                 (setq cpts (cons (list ss (list p0 "p0") f0 f1 f2) cpts))
                 (setq cpts (cons (list ss (list p1 "p1") f0 f1 f2) cpts))
                 )
                ((and (> f0 0.0) (= f1 0.0) (= f2 0.0))
                 (setq cpts (cons (list ss (list p1 "p1") f0 f1 f2) cpts))
                 (setq cpts (cons (list ss (list p2 "p2") f0 f1 f2) cpts))
                 )
                ((and (= f0 0.0) (> f1 0.0) (= f2 0.0))
                 (setq cpts (cons (list ss (list p0 "p0") f0 f1 f2) cpts))
                 (setq cpts (cons (list ss (list p2 "p2") f0 f1 f2) cpts))
                 )
                ((and (= f0 0.0) (= f1 0.0) (< f2 0.0))
                 (setq cpts (cons (list ss (list p0 "p0") f0 f1 f2) cpts))
                 (setq cpts (cons (list ss (list p1 "p1") f0 f1 f2) cpts))
                 )
                ((and (< f0 0.0) (= f1 0.0) (= f2 0.0))
                 (setq cpts (cons (list ss (list p1 "p1") f0 f1 f2) cpts))
                 (setq cpts (cons (list ss (list p2 "p2") f0 f1 f2) cpts))
                 )
                ((and (= f0 0.0) (< f1 0.0) (= f2 0.0))
                 (setq cpts (cons (list ss (list p0 "p0") f0 f1 f2) cpts))
                 (setq cpts (cons (list ss (list p2 "p2") f0 f1 f2) cpts))
                 )
            ) ;;; end cond
            (setq ii (1+ ii))
               
            
            
        ) ;;;  end repeat求交点结束
       
;;;        构造新三角形...
        (setq cpts (reverse cpts))
        (setq ii 0)
        (command "circle" pt1 1.0 "")(setq c4 (entlast))
        (while (< ii (length cpts))
            (setq s1 (nth ii cpts)
                  s2 (nth (1+ ii) cpts))

            (setq ent (car s1)       ;; 三角形
                   cp1 (caadr s1)     ;; 交点一3d
                   flag1 (cadadr s1)  ;; 交点一的类型 实交点=边编号<"12"|"01"|"12">
                  f0 (caddr s1)      ;; p0点与边界线段位置关系
                  f1 (cadddr s1)     ;; p1点与边界线段位置关系
                  f2 (last s1))      ;; p2点与边界线段位置关系
            (setq cp2 (caadr s2)
                  flag2 (cadadr s2))
            (setq sjxvers (gettrivers ent)) ;; 区三角形三维顶点p1 p2 p3
            (setq p0 (car sjxvers)
                  p1 (cadr sjxvers)
                  p2 (caddr sjxvers))
            (command "circle" p0 0.5 "")(setq c1 (entlast))
            (command "circle" p1 1.0 "")(setq c2 (entlast))
            (command "circle" p2 1.5 "")(setq c3 (entlast))
            
            (setq abcd (jsxsh sjxvers))
            (setq a (car abcd)
                  b (cadr abcd)
                  c (caddr abcd)
                  d (cadddr abcd))

            (setq pt1 (list pt1x pt1y
                             (/ (+ (* a pt1x) (* b pt1y)  d)
                                (* -1.0 c)))
                  )
            (setq pt2 (list pt2x pt2y
                             (/ (+ (* a pt2x) (* b pt2y)  d)
                                (* -1.0 c)))
                  )
            
            (cond
                ;;;一个实交点,一个虚交点
                ;;;(1)
                ((= flag1 nil)
                 (cond
                     ((and (= flag2 "01") (> f1 0) (ptinsjx pt1 sjxvers))
                      (command "3dpoly" pt1 p0 cp2 "c" "")
                      (command "3dpoly" pt1 cp2 p1 "c" "")
                      (command "3dpoly" pt1 p1 p2 "c" "")
                      (command "3dpoly" pt1 p2 p0  "c" ""))
                     ((and (= flag2 "12") (> f2 0) (ptinsjx pt1 sjxvers))
                      (command "3dpoly" pt1 cp2 p2 "c" "")
                      (command "3dpoly" pt1 p2 p0 "c" "")
                      (command "3dpoly" pt1 p0 p1 "c" "")
                      (command "3dpoly" pt1 p1 cp2 "c" ""))
                     ((and (= flag2 "02") (> f0 0) (ptinsjx pt1 sjxvers))
                      (command "3dpoly" pt1 cp2 p2 "c" "")
                      (command "3dpoly" pt1 p2 p1 "c" "")
                      (command "3dpoly" pt1 p1 p0 "c" "")
                      (command "3dpoly" pt1 p0 cp2 "c" ""))
                     
                     ((and (= flag2 "02") (< f0 0) (ptinsjx pt1 sjxvers))
                      (command "3dpoly" pt1 cp2 p2 "c" "")
                      (command "3dpoly" pt1 p2 p1 "c" "")
                      (command "3dpoly" pt1 p1 p0 "c" "")
                      (command "3dpoly" pt1 p0 cp2 "c" ""))
                     ((and (= flag2 "12") (< f2 0) (ptinsjx pt1 sjxvers))
                      (command "3dpoly" pt1 cp2 p1 "c" "")
                      (command "3dpoly" pt1 p1 p0 "c" "")
                      (command "3dpoly" pt1 p0 p2 "c" "")
                      (command "3dpoly" pt1 p2 cp2 "c" ""))
                     ((and (= flag2 "01") (< f1 0) (ptinsjx pt1 sjxvers))
                      (command "3dpoly" pt1 cp2 p0 "c" "")
                      (command "3dpoly" pt1 p0 p2 "c" "")
                      (command "3dpoly" pt1 p2 p1 "c" "")
                      (command "3dpoly" pt1 p1 cp2 "c" ""))
                     ;;;(3)
                     ((and (= flag2 "01") (> f1 0) (ptinsjx pt2 sjxvers))
                      (command "3dpoly" pt2 p0 cp2 "c" "")
                      (command "3dpoly" pt2 cp2 p1 "c" "")
                      (command "3dpoly" pt2 p1 p2 "c" "")
                      (command "3dpoly" pt2 p2 p0  "c" ""))
                     ;;;;;;
                     ((and (= flag2 "12") (> f2 0) (ptinsjx pt2 sjxvers))
                      (command "3dpoly" pt2 cp2 p2 "c" "")
                      (command "3dpoly" pt2 p2 p0 "c" "")
                      (command "3dpoly" pt2 p0 p1 "c" "")
                      (command "3dpoly" pt2 p1 cp2 "c" ""))
                     ((and (= flag2 "02") (> f0 0) (ptinsjx pt2 sjxvers))
                      (command "3dpoly" pt2 cp2 p2 "c" "")
                      (command "3dpoly" pt2 p2 p1 "c" "")
                      (command "3dpoly" pt2 p1 p0 "c" "")
                      (command "3dpoly" pt2 p0 cp2 "c" ""))
                     
                     ((and (= flag2 "02") (< f0 0) (ptinsjx pt2 sjxvers))
                      (command "3dpoly" pt2 cp2 p2 "c" "")
                      (command "3dpoly" pt2 p2 p1 "c" "")
                      (command "3dpoly" pt2 p1 p0 "c" "")
                      (command "3dpoly" pt2 p0 cp2 "c" ""))
                     ((and (= flag2 "12") (< f2 0) (ptinsjx pt2 sjxvers))
                      (command "3dpoly" pt2 cp2 p1 "c" "")
                      (command "3dpoly" pt2 p1 p0 "c" "")
                      (command "3dpoly" pt2 p0 p2 "c" "")
                      (command "3dpoly" pt2 p2 cp2 "c" ""))
                     ((and (= flag2 "01") (< f1 0) (ptinsjx pt2 sjxvers))
                      (command "3dpoly" pt2 cp2 p0 "c" "")
                      (command "3dpoly" pt2 p0 p2 "c" "")
                      (command "3dpoly" pt2 p2 p1 "c" "")
                      (command "3dpoly" pt2 p1 cp2 "c" ""))
                     )
                 )
;;;                (2)
                ((= flag2 nil)
                 (cond
                   ;;;;;;;;;;;;;;;;;;;;;;
                     ((and (= flag1 "01") (> f1 0) (ptinsjx pt1 sjxvers))
                      (command "3dpoly" pt1 p0 cp1 "c" "")
                      (command "3dpoly" pt1 cp1 p1 "c" "")
                      (command "3dpoly" pt1 p1 p2 "c" "")
                      (command "3dpoly" pt1 p2 p0  "c" ""))
                     ((and (= flag1 "12") (> f2 0) (ptinsjx pt1 sjxvers))
                      (command "3dpoly" pt1 cp1 p2 "c" "")
                      (command "3dpoly" pt1 p2 p0 "c" "")
                      (command "3dpoly" pt1 p0 p1 "c" "")
                      (command "3dpoly" pt1 p1 cp1 "c" ""))
                     ((and (= flag1 "02") (> f0 0) (ptinsjx pt1 sjxvers))
                      (command "3dpoly" pt1 cp1 p0 "c" "")
                      (command "3dpoly" pt1 p0 p1 "c" "")
                      (command "3dpoly" pt1 p1 p2 "c" "")
                      (command "3dpoly" pt1 p2 cp1 "c" ""))
                     ((and (= flag1 "02") (< f0 0) (ptinsjx pt1 sjxvers))
                      (command "3dpoly" pt1 cp1 p2 "c" "")
                      (command "3dpoly" pt1 p2 p1 "c" "")
                      (command "3dpoly" pt1 p1 p0 "c" "")
                      (command "3dpoly" pt1 p0 cp1 "c" ""))
                     ((and (= flag1 "12") (< f2 0) (ptinsjx pt1 sjxvers))
                      (command "3dpoly" pt1 cp1 p1 "c" "")
                      (command "3dpoly" pt1 p1 p0 "c" "")
                      (command "3dpoly" pt1 p0 p2 "c" "")
                      (command "3dpoly" pt1 p2 cp1 "c" ""))
                     ((and (= flag1 "01") (< f1 0) (ptinsjx pt1 sjxvers))
                      (command "3dpoly" pt1 cp1 p0 "c" "")
                      (command "3dpoly" pt1 p0 p2 "c" "")
                      (command "3dpoly" pt1 p2 p1 "c" "")
                      (command "3dpoly" pt1 p1 cp1 "c" ""))
                     ;;;(4);
                     ((and (= flag1 "01") (> f1 0) (ptinsjx pt2 sjxvers))
                      (command "3dpoly" pt2 p0 cp1 "c" "")
                      (command "3dpoly" pt2 cp1 p1 "c" "")
                      (command "3dpoly" pt2 p1 p2 "c" "")
                      (command "3dpoly" pt2 p2 p0  "c" ""))
                     ((and (= flag1 "12") (> f2 0) (ptinsjx pt2 sjxvers))
                      (command "3dpoly" pt2 cp1 p2 "c" "")
                      (command "3dpoly" pt2 p2 p0 "c" "")
                      (command "3dpoly" pt2 p0 p1 "c" "")
                      (command "3dpoly" pt2 p1 cp1 "c" ""))
                     ((and (= flag1 "02") (> f0 0) (ptinsjx pt2 sjxvers))
                      (command "3dpoly" pt2 cp1 p0 "c" "")
                      (command "3dpoly" pt2 p0 p1 "c" "")
                      (command "3dpoly" pt2 p1 p2 "c" "")
                      (command "3dpoly" pt2 p2 cp1 "c" ""))
                     ((and (= flag1 "02") (< f0 0) (ptinsjx pt2 sjxvers))
                      (command "3dpoly" pt2 cp1 p2 "c" "")
                      (command "3dpoly" pt2 p2 p1 "c" "")
                      (command "3dpoly" pt2 p1 p0 "c" "")
                      (command "3dpoly" pt2 p0 cp1 "c" ""))
                     ((and (= flag1 "12") (< f2 0) (ptinsjx pt2 sjxvers))
                      (command "3dpoly" pt2 cp1 p1 "c" "")
                      (command "3dpoly" pt2 p1 p0 "c" "")
                      (command "3dpoly" pt2 p0 p2 "c" "")
                      (command "3dpoly" pt2 p2 cp1 "c" ""))
                     ((and (= flag1 "01") (< f1 0) (ptinsjx pt2 sjxvers))
                      (command "3dpoly" pt2 cp1 p0 "c" "")
                      (command "3dpoly" pt2 p0 p2 "c" "")
                      (command "3dpoly" pt2 p2 p1 "c" "")
                      (command "3dpoly" pt2 p1 cp1 "c" ""))
                     )
                 )
                ;;;两实交点
                ((and (= flag1 "01") (= flag2 "02") (> f0 0.0))
                 (command "3dpoly" p0 cp1 cp2 "c" "")
                 (command "3dpoly" cp1 p2 cp2 "c" "")
                 (command "3dpoly" p1 p2 cp1 "c" "")
                 )
                ((and (= flag1 "02") (= flag2 "01") (> f0 0.0))
                 (command "3dpoly" p0 cp2  cp1"c" "")
                 (command "3dpoly" cp1 cp2 p2 "c" "")
                 (command "3dpoly" p1 p2 cp2 "c" "")
                 )
                ((and (= flag1 "01") (= flag2 "02") (< f0 0.0))
                 (command "3dpoly" p0 cp2 cp1 "c" "")
                 (command "3dpoly" cp1 cp2 p2 "c" "")
                 (command "3dpoly" p1 cp1 p2 "c" "")
                 )
                ((and (= flag1 "02") (= flag2 "01") (< f0 0.0))
                 (command "3dpoly" p0 cp1  cp2"c" "")
                 (command "3dpoly" cp1 p2 cp2 "c" "")
                 (command "3dpoly" p1 cp2 p2 "c" "")
                 )

                ;;;;;
                ((and (= flag1 "02") (= flag2 "12") (> f2 0.0))
                 (command "3dpoly" p2 cp1 cp2 "c" "")
                 (command "3dpoly" cp1 p1 cp2 "c" "")
                 (command "3dpoly" p0 p1 cp1 "c" "")
                 )
                ((and (= flag1 "12") (= flag2 "02") (> f2 0.0))
                 (command "3dpoly" p2 cp2 cp1"c" "")
                 (command "3dpoly" cp1 cp2 p1 "c" "")
                 (command "3dpoly" p1 cp2 p0 "c" "")
                 )
                ((and (= flag1 "02") (= flag2 "12") (< f2 0.0))
                 (command "3dpoly" p2 cp2 cp1 "c" "")
                 (command "3dpoly" cp1 cp2 p1 "c" "")
                 (command "3dpoly" p0 cp1 p1 "c" "")
                 )
                ((and (= flag1 "12") (= flag2 "02") (< f2 0.0))
                 (command "3dpoly" p2 cp1  cp2"c" "")
                 (command "3dpoly" cp1 p1 cp2 "c" "")
                 (command "3dpoly" p1 p0 cp2 "c" "")
                 )
                ;;;;
                ((and (= flag1 "12") (= flag2 "01") (> f1 0.0))
                 (command "3dpoly" p1 cp1 cp2 "c" "")
                 (command "3dpoly" cp1 p0 cp2 "c" "")
                 (command "3dpoly" p2 p0 cp1 "c" "")
                 )
                ((and (= flag1 "01") (= flag2 "12") (> f1 0.0))
                 (command "3dpoly" p1 cp2 cp1"c" "")
                 (command "3dpoly" cp1 cp2 p0 "c" "")
                 (command "3dpoly" p0 cp2 p2 "c" "")
                 )
                ((and (= flag1 "12") (= flag2 "01") (< f1 0.0))
                 (command "3dpoly" p1 cp2 cp1 "c" "")
                 (command "3dpoly" cp1 cp2 p0 "c" "")
                 (command "3dpoly" p0 p2 cp1 "c" "")
                 )
                ((and (= flag1 "01") (= flag2 "12") (< f1 0.0))
                 (command "3dpoly" p1 cp1  cp2"c" "")
                 (command "3dpoly" cp1 p0 cp2 "c" "")
                 (command "3dpoly" p2 cp2 p0 "c" "")
                 )
                ;;;; 边在线上
                ;;; 有一个交点
                ((and (= flag1 "p0") (= flag2 "12") (> f2 0.0))
                 (command "3dpoly" p0 p1 cp2 "c" "")
                 (command "3dpoly" p0 cp2 p2 "c" "")
                 )
                ((and (= flag1 "p0") (= flag2 "12") (< f2 0.0))
                 (command "3dpoly" p0 p2 cp2 "c" "")
                 (command "3dpoly" p0 cp2 p1 "c" "")
                 )
                ((and (= flag1 "p1") (= flag2 "02") (> f0 0.0))
                 (command "3dpoly" p1 p2 cp2 "c" "")
                 (command "3dpoly" p1 cp2 p0 "c" "")
                 )
                ((and (= flag1 "p1") (= flag2 "02") (< f0 0.0))
                 (command "3dpoly" p1 p0 cp2 "c" "")
                 (command "3dpoly" p1 cp2 p2 "c" "")
                 )
                ((and (= flag1 "p2") (= flag2 "01") (> f1 0.0))
                 (command "3dpoly" p2 p0 cp2 "c" "")
                 (command "3dpoly" p2 cp2 p1 "c" "")
                 )
                ((and (= flag1 "p2") (= flag2 "01") (< f1 0.0))
                 (command "3dpoly" p2 p1 cp2 "c" "")
                 (command "3dpoly" p2 cp2 p0 "c" "")
                 )

                ;;;;;;;;;;
                ((and (= flag2 "p0") (= flag1 "12") (> f2 0.0))
                 (command "3dpoly" p0 p1 cp1 "c" "")
                 (command "3dpoly" p0 cp1 p2 "c" "")
                 )
                ((and (= flag2 "p0") (= flag1 "12") (< f2 0.0))
                 (command "3dpoly" p0 p2 cp1 "c" "")
                 (command "3dpoly" p0 cp1 p1 "c" "")
                 )
                ((and (= flag2 "p1") (= flag1 "02") (> f0 0.0))
                 (command "3dpoly" p1 p2 cp1 "c" "")
                 (command "3dpoly" p1 cp1 p0 "c" "")
                 )
                ((and (= flag2 "p1") (= flag1 "02") (< f0 0.0))
                 (command "3dpoly" p1 p0 cp1 "c" "")
                 (command "3dpoly" p1 cp1 p2 "c" "")
                 )
                ((and (= flag2 "p2") (= flag1 "01") (> f1 0.0))
                 (command "3dpoly" p2 p0 cp1 "c" "")
                 (command "3dpoly" p2 cp1 p1 "c" "")
                 )
                ((and (= flag2 "p2") (= flag1 "01") (< f1 0.0))
                 (command "3dpoly" p2 p1 cp1 "c" "")
                 (command "3dpoly" p2 cp1 p0 "c" "")
                 )


               
       
            )
            (entdel c1)
            (entdel c2)
            (entdel c3)
            (setq ii (+ ii 2))
        ) ;;;  end repeat
        (entdel c4)
        (setq pt1 nil pt2 nil)
        (setq i (1+ i))
        (setq pt1 (nth i pts))
        (setq pt2 (nth (1+ i) pts))
    )
    (print "\n边界处理完成。")
    (princ)
)



;;; 自定义求交点程序
;;; 求p1p2与p3p4的交点
(defun ljs-inters(p1 p2 p3 p4 ff / z1 z2 cpt d0 d1 dz cz flag)
    (setq z1 (caddr p1)
          z2 (caddr p2)
          p1 (reverse (cdr (reverse p1)))
          p2 (reverse (cdr (reverse p2)))
;;;          p3 (reverse (cdr (reverse p3)))
;;;          p4 (reverse (cdr (reverse p4)))
          )
    (setq cpt (inters p1 p2 p3 p4))
    (if cpt
        (progn
            (setq d0 (distance p1 p2)
                  d1 (distance p1 cpt)
                  dz (- z2 z1)
                  cz (+ z1 (* dz (/ d1 d0)))
             )
            (setq cpt (reverse(cons cz (reverse cpt)))
                  flag ff)
        )
        ;;; 虚交点
        (progn
            (setq cpt (inters p1 p2 p3 p4 nil))
            (setq d0 (distance p1 p2)
                  d1 (distance p1 cpt)
                  dz (- z2 z1)
                  cz (+ z1 (* dz (/ d1 d0)))
            )
            (setq cpt (reverse(cons cz (reverse cpt)))
                  flag nil)
        )
    )
    (list cpt flag)
)

             
;;;取三角形entsjx的三维顶点表ptlst=(x y z)

(defun gettrivers (entsjx / pts len ptlst i)
    (setq pts (vlax-safearray->list
                  (vlax-variant-value
                      (vla-get-coordinates
                          (vlax-ename->vla-object entsjx)))))
    (setq len (/ (length pts) 3))
    (setq ptlst nil)
    (setq i 0)
    (repeat len
        (setq ptlst (cons (list (nth i pts)
                                (nth (1+ i) pts)
                                (nth (+ i 2) pts)
                                ) ptlst) )
        (setq i (+ i 3))
    )
    ptlst
)


;;;点线正负区测试,即判断点位于直线那一侧:
;;;           |x  y  1|       p>0 在正区
;;;    F(x,y)=|x1 y1 1| = p,  p=0 在直线上
;;;           |x2 y2 1|       p<0 在负区

;;;函数:(pltest pt line)
;;;
;;;功能:测试点pt(2d) 在直线line(2d)的那一侧
;;;
;;;参数:pt-被测试的点(2d or 3d),line 直线(pt1 pt2)
;;;
;;;返回值:real数值

(defun pltest (pt line / x y x1 y1 x2 y2)
    (setq x (car pt) y (cadr pt))
    (setq x1 (caar line) y1 (cadar line))
    (setq x2 (caadr line) y2 (cadadr line))
    (- (+ (* x y1) (* x1 y2) (* x2 y))
       (+ (* x1 y) (* x y2) (* x2 y1)))
)

;;; point 3d->2d
(defun 3d->2d (pt)
    (list (car pt) (cadr pt))
)


评分

参与人数 1D豆 +5 贡献 +1 收起 理由
newer + 5 + 1 很给力!经验;技术要点;资料分享奖!

查看全部评分

论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!

已领礼包: 40个

财富等级: 招财进宝

发表于 2016-6-1 21:11:14 | 显示全部楼层
感谢对论坛的支持, 希望学下如何贴LISP代码,把代码放到 [co**de].....[/code] (星号去掉)或者点 代码按钮发布。

另外,如果发现代码里面有表情符,到 发帖界面下面的 附加选项里面把 去掉表情符选项勾上。
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2016-8-18 00:02:07 | 显示全部楼层
:)不错不错,值得借鉴
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2018-1-15 12:05:03 | 显示全部楼层
谢谢分享谢谢分享谢谢分享谢谢分享谢谢分享谢谢分享谢谢分享
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 1个

财富等级: 恭喜发财

发表于 2018-5-3 15:08:17 | 显示全部楼层
下载后,才发现有了
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 1个

财富等级: 恭喜发财

发表于 2018-5-3 15:26:57 | 显示全部楼层
顶个,新手学习了。
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

QQ|申请友链|Archiver|手机版|小黑屋|辽公网安备|晓东CAD家园 ( 辽ICP备15016793号 )

GMT+8, 2024-3-29 01:39 , Processed in 0.445598 second(s), 46 queries , Gzip On.

Powered by Discuz! X3.5

© 2001-2024 Discuz! Team.

快速回复 返回顶部 返回列表