求大师帮忙看一下关于PL线 "凹位"的判断

lijiao · 发表于 2017-10-20 15:18:57

本帖最后由 lijiao 于 2017-10-20 15:26 编辑

(defun c:aopl (/ AREA AREAS ENT I N PT PT1 PT2 PT3 PTS PTS0 SS VLANAME)
(if (setq ss (ssget '((0 . "*POLYLINE") (70 . 1))))
(progn
(setq i -1)
(repeat (sslength ss)
(setq ent (ssname ss (setq i (1+ i))))
(setq ent (vlax-ename->vla-object ent))
(setq pts (vlax-get ent 'Coordinates ))
(setq pts0 pts)
(setq Area (vlax-get ent 'Area))
(setq vlaname (vlax-get ent 'ObjectName))
(if (= vlaname "AcDb3dPolyline")
(setq n 3)
(setq n 2)
)
(setq pt (getpt pts n))
(setq pts (cadr pt)
pt (car pt))
(setq Areas '())
(while (> (length pts) n)
(setq pt1 (GETPT pts n)
pts (cadr pt1)
pt2 (GETPT pts n)
)
(setq pt3 (append pt (car pt1) (car pt2)))
(vlax-put ent 'Coordinates pt3)
(setq Areas (cons (vlax-get ent 'Area) Areas))
)
(vlax-put ent 'Coordinates pts0)
(if (not (equal Area (apply '+ Areas) 0.001))
(vlax-put ent 'color 1)
)
)
)
)
(princ)
)
(defun getpt (pts n / out)
(repeat n
(setq out (cons (car pts) out)
pts (cdr pts))
)
(list (reverse out) pts)
)

(defun c:aopl (/ AREA AREAS ENT I N PT PT1 PT2 PT3 PTS PTS0 SS VLANAME) 
  (if (setq ss (ssget '((0 . "*POLYLINE") (70 . 1)))) 
    (progn 
      (setq i -1) 
      (repeat (sslength ss) 
        (setq ent (ssname ss (setq i (1+ i)))) 
        (setq ent (vlax-ename->vla-object ent)) 
        (setq pts (vlax-get ent 'Coordinates )) 
        (setq pts0 pts) 
        (setq Area (vlax-get ent 'Area)) 
        (setq vlaname (vlax-get ent 'ObjectName)) 
        (if (= vlaname "AcDb3dPolyline") 
          (setq n 3) 
          (setq n 2) 
          ) 
        (setq pt (getpt pts n)) 
        (setq pts (cadr pt) 
              pt (car pt)) 
        (setq Areas '()) 
        (while (> (length pts) n) 
          (setq pt1 (GETPT pts n) 
                pts (cadr pt1) 
                pt2 (GETPT pts n) 
          ) 
          (setq pt3 (append pt (car pt1) (car pt2))) 
          (vlax-put ent 'Coordinates pt3) 
          (setq Areas (cons (vlax-get ent 'Area) Areas)) 
          ) 
        (vlax-put ent 'Coordinates pts0) 
        (if (not (equal Area (apply '+ Areas) 0.001)) 
          (vlax-put ent 'color 1) 
          ) 
        ) 
      ) 
    ) 
  (princ) 
  ) 
(defun getpt (pts n / out) 
  (repeat n 
    (setq out (cons (car pts) out) 
          pts (cdr pts)) 
    ) 
  (list (reverse out) pts) 
  )

ysq101 · 发表于 2017-10-20 17:37:17

lijiao 发表于 2017-10-20 15:18

还是不能正常运行

ysq101 · 发表于 2017-10-20 17:38:44

llsheng_73 发表于 2017-10-20 13:45
整个多段线方向并不需要这条多段的所有点参与计算，实际上只需要取出四个点（其外接正矩形的四个角点到该 ...

黄大师对于PL线的处理及IF有独特的见解。。。之前我关于PL线程序大多数采用黄大师的子程序

pengfei2010 · 发表于 2017-10-21 09:03:38

回帖是一种美德！感谢楼主的无私分享谢谢

xyp1964 · 发表于 2017-10-21 11:48:38

本帖最后由 xyp1964 于 2017-10-21 13:30 编辑

;; 2017-10-21 tt(凹点标记)
(defun c:tt ()
(setq i -1)
(if (setq ss (ssget '((0 . "*PolyLINE"))))
(while (setq s1 (ssname ss (setq i (1+ i))))
(foreach pt (xyp-AoPtn (xyp-Vertexs s1 0))
(xyp-Cross pt 500 0)
)
)
)
(princ)
)

ysq101 · 发表于 2017-10-21 12:09:56

xyp1964 发表于 2017-10-21 11:48
;; 2017-10-21 tt(凹点标记)
(defun c:tt ()
(setq i -1)

院长的函数库存可真多

LIULISHENG · 发表于 2018-2-6 14:55:13

太强大了学习了

kkq0305 · 发表于 2021-8-8 15:47:08

根据面积判断凹凸

(defun c:vv (/ ent obj ptlst f area)
(vl-load-com)
(setq ent (car (entsel)))
(setq obj (vlax-ename->vla-object ent))
(setq ptlst
(mapcar
'cdr
(vl-remove-if-not '(lambda (x) (= 10 (car x))) (entget ent))
)
)
(setq f
(lambda (lst)
(apply '+
(mapcar
'(lambda (x y)
(* 0.5 (* (- (car y) (car x)) (+ (cadr x) (cadr y))))
)
lst
(append (cdr lst) (list (car lst)))
)
)
)
)
(setq area (f ptlst))
(if (vl-remove-if-not
'(lambda (x) (> (f (vl-remove x ptlst)) area))
ptlst
)
(vla-put-color (vlax-ename->vla-object ent) 1)
)
(princ)
)

ysq101 · 发表于 2021-8-9 17:57:05

kkq0305 发表于 2021-8-8 15:47
根据面积判断凹凸

好家伙...差不多四年才回贴...我早又忘记了

账号		自动登录	找回密码
密码			注册

[提问] 求大师帮忙看一下关于PL线 "凹位"的判断

本帖子中包含更多资源

[提问] 求大师帮忙看一下 关于PL线 "凹位"的判断

本帖子中包含更多资源

[提问] 求大师帮忙看一下关于PL线 "凹位"的判断