图元在不封闭区域相对居中_CAD中文技术交流网

图元在不封闭区域相对居中

本帖最后由 dcl1214 于 2025-8-24 16:31 编辑

(defun $xiang-dui-ju-zhong-dian$ (pt lst
/ $addline$
$addpoint$
$point->polyline->reg->centroid$
$she-xian-qiu-jiao-dian$
acdocument area
document e-dbx
e-my i
jds my
qycs to
zx
)
;求质心，求居中点
(defun $point->Polyline->reg->centroid$
(pts0 lst /
Area centroid
doc ent ent-my
ent-polay mp
obj obj1 obj2
pts tmp
)
;坐标集求质心
(setq pts pts0)
(setq pts (vl-remove nil pts))
(setq pts (mapcar (function (lambda (a) (list (car a) (cadr a))))
pts
)
)
(SETQ pts (APPLY 'APPEND pts))
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
(if (= (getvar 'ctab) "Model")
(setq mp (vla-get-modelSpace doc))
(setq mp (vla-get-paperSpace doc))
)
(and pts
(setq tmp (vl-catch-all-apply
'vlax-make-safearray
(LIST vlax-vbDouble
(cons 0 (- (length pts) 1))
)
)
)
(vl-catch-all-apply 'vlax-safearray-fill (LIST tmp pts))
)
(and doc
tmp
(setq
obj1
(vl-catch-all-apply
'vla-addLightweightPolyline
(LIST mp tmp)
)
)
(not (vl-catch-all-error-p obj1))
(progn (vl-catch-all-apply 'vla-Put-CLOSED (LIST obj1 1)) t)
(setq
OBJ2 (vl-catch-all-apply
'vla-addRegion
(list
mp
(vl-catch-all-apply
'vlax-make-variant
(list
(vl-catch-all-apply
'vlax-safearray-fill
(list
(vlax-make-safearray vlax-vbObject '(0 . 0))
(list obj1)
)
)
)
)
)
)
)
(not (vl-catch-all-error-p OBJ2))
(setq obj (car (vlax-safearray->list (vlax-variant-value obj2))))
(not (vl-catch-all-error-p obj))
(setq
centroid (vlax-safearray->list
(vlax-variant-value
(vla-get-Centroid
obj
)
)
)
)
(setq Area (vla-get-Area obj))
)
(vl-catch-all-apply 'vla-put-color (list obj 1))
(and obj (setq ent-my (vlax-vla-object->ename obj)))
(and obj1 (setq ent-polay (vlax-vla-object->ename obj1)))
(and ent-polay (entdel ent-polay))
(list
(cons "边界坐标" pts0)
(cons "面域" ent-my)
(cons "质心" centroid)
(cons "面积" Area)
)
)
(defun $addline$ (p1 p2)
(if (and p1 p2)
(vla-addline
(vla-Get-ModelSpace
(vla-get-ActiveDocument
(vlax-get-acad-object)
)
)
(vlax-3D-Point p1)
(vlax-3D-Point p2)
)
)
)
(defun $addpoint$ (p)
(if p
(VLA-addpoint
(vla-get-ModelSpace
(vla-get-ActiveDocument (vlax-get-acad-object))
)
(VLAX-3D-POINT p)
)
)
)
(defun $she-xian-qiu-jiao-dian$
(pt lst /
$intersectwith$ a
$addpoint$ e
generaterays GetScreenCoords
gr i is
jd jd-nots jds
line ll lmts
maxdist on osmode
p pts pts-new
ray-count rays ss
ur
)
;射线求交点
(defun $IntersectWith$ (ent1 ent2 / jd obj1 obj2 ss sss)
(setq
obj1 (vl-catch-all-apply 'vlax-ename->vla-object (list ent1))
)
(setq
obj2 (vl-catch-all-apply 'vlax-ename->vla-object (list ent2))
)
(if (vl-catch-all-error-p obj1)
(setq obj1 nil)
)
(if (vl-catch-all-error-p obj2)
(setq obj2 nil)
)
(if (and obj1 obj2)
(setq jd (vl-catch-all-apply
'vlax-invoke
(list
obj1
'IntersectWith
obj2
acExtendNone
)
)
)
)
(if (vl-catch-all-error-p jd)
(setq jd nil)
)
(if jd
(if (> (length jd) 3)
(progn (setq sss nil)
(while jd
(setq ss nil)
(setq
ss (list (car jd) (cadr jd) (caddr jd))
)
(setq sss (cons ss sss))
(setq jd (cdddr jd))
)
(setq jd (reverse sss))
)
(setq jd (list jd))
)
)
jd
)
(defun GetScreenCoords (/ c03 c08 c04 c07 c06 c09 c01 c02)
; 取得当前绘图区屏幕的左下角和右上角的坐标
(setq c03 (getvar "viewctr")
c03 (trans c03 1 2)
c08 (getvar "viewsize")
c04 (getvar "screensize")
c07 (car c04)
c06 (cadr c04)
c09 (/ (* c08 c07) c06)
c01 (list (- (car c03) (* 0.5 c09)) (- (cadr c03) (* 0.5 c08)))
c02 (list (+ (car c03) (* 0.5 c09)) (+ (cadr c03) (* 0.5 c08)))
c01 (trans c01 2 1)
c02 (trans c02 2 1)
)
(list c01 c02)
)
(defun GenerateRays (center dist count / ang step rays)
(setq ang 0.0
step (/ 360.0 count)
)
(repeat count
(setq rays (cons (polar center (* ang (/ pi 180)) dist) rays)
ang (+ ang step)
)
)
rays
)
(if pt
(progn
(setq ray-count (cdr (assoc "射线条数" lst)))
(if (and ray-count (= (type ray-count) 'int))
()
(setq ray-count 72)
)
(or ray-count (setq ray-count 36))
(setq lmts (GetScreenCoords))
(setq maxdist (distance (car lmts) (cadr lmts))
rays (GenerateRays pt maxdist ray-count)
pts nil
)
(setq i 0)
(setq jd-nots nil)
(foreach ray rays
(setq jd nil)
(if
(and (setq
ss (ssget
"F"
(list pt ray)
(list
;(cons -4 "<AND")
(cons 0 "CIRCLE,LINE,*line,ellipse,arc,SPLINE")
;(cons -4 "<NOT")
;(CONS 8 "tishi")
;(cons -4 "NOT>")
;(cons -4 "AND>")
)
)
)
(setq e (cadar (ssnamex ss)))
(setq p (trans (cadar (cdddar (ssnamex ss))) 0 1))
)
(progn
(setq jd nil)
(setq line ($addline$ pt ray))
(setq line (vlax-vla-object->ename line))
(setq
jds (vl-catch-all-apply
(function
(lambda ()
($IntersectWith$ e line)
)
)
)
)
(IF JDS
()
(progn
(setq jd-nots (cons (list pt ray) jd-nots))
)
)
(entdel line)
(if (vl-catch-all-error-p jds)
(setq jds nil)
)
(setq jds
(vl-sort jds
(function (lambda (e1 e2)
(< (distance e1 pt)
(distance e1 pt)
)
)
)
)
)
(setq jd (car jds))
(if (vl-catch-all-error-p jd)
(setq jd nil)
)
(if jd
(setq
pts (cons (cons i jd) pts)
)
)
)
(PRINT "ssget没有搜索到图元") ;ssget没有搜索到图形
)
(setq i (1+ i))
(setq ss nil)
)
(setq pts (mapcar 'cdr pts))
)
)
pts
)
(if pt
(progn
(setq Document (vla-get-ActiveDocument (vlax-get-acad-object)))
(vla-StartUndoMark Document)
(setq qycs (cdr (assoc "取样次数" lst)))
(if (and qycs (= (type qycs) 'int))
()
(setq qycs 2)
)
(or qycs (setq qycs 1))
(setq i 1)
(setq to t)
(while (and to (<= i qycs))
(setq my
(vl-catch-all-apply
(function
(lambda (/ jds my)
(setq
jds ($she-xian-qiu-jiao-dian$ pt LST)
)
(setq my ($point->Polyline->reg->centroid$ jds nil))
my
)
)
)
)
(if (vl-catch-all-error-p my)
(setq my nil)
)
(setq zx (cdr (assoc "质心" my)))
(setq e-my (cdr (assoc "面域" my)))
(setq area (cdr (assoc "面积" my)))
(setq jds (cdr (assoc "边界坐标" my)))
(if (/= i qycs)
(if (and e-my (entget e-my))
(entdel e-my)
)
)
(if zx
(setq pt zx)
(setq to nil) ;第一次如果失败了，后面就不用再跑了，直接让while跳出循环
)
(setq i (1+ i))
)
(vla-EndUndoMark Document)
)
)
(if zx
(setq zx (list (car zx) (cadr zx) 0))
)
(if (vl-position (cdr (assoc "绘制射线" lst)) (list "1" "是"))
(progn (vl-catch-all-apply
'vla-add
(list (vla-get-Layers
(setq AcDocument
(vla-get-ActiveDocument
(vlax-get-acad-object)
)
)
)
"tishi"
)
)
(mapcar
(function
(lambda (a / obj)
(setq obj ($addline$ zx A))
(vl-catch-all-apply 'vla-put-layer (list obj "tishi"))
(vla-put-color obj 3)
)
)
jds
)
)
)
(if (cdr (assoc "保留面域" lst))
()
(progn (entdel e-my) (setq e-my nil))
)
(list
(cons "面域" e-my)
(cons "边界坐标" jds)
(cons "居中点坐标" zx)
(cons "质心" zx)
(cons "面积" area)
)
)
(DEFUN C:tt (/ *ERROR* PT-NEW jzd)
(DEFUN *ERROR* (S) (PRINT))
(setq pt (GETPOINT "请在区域内点击一点开始求相对居中点"))
(setq jzd ($xiang-dui-ju-zhong-dian$
pt
(list (cons "射线条数" 48)
(cons "绘制射线" "1")
(CONS "取样次数" 2)
(CONS "保留面域" t)
)
)
)
(SETQ PT-NEW (cdr (assoc "居中点坐标" jzd)))
(princ)
)

(defun $xiang-dui-ju-zhong-dian$ (pt       lst 
          /       $addline$ 
          $addpoint$ 
          $point->polyline->reg->centroid$ 
          $she-xian-qiu-jiao-dian$ 
          acdocument     area 
          document     e-dbx 
          e-my       i 
          jds       my 
          qycs       to 
          zx 
         ) 
          ;求质心，求居中点 
  (defun $point->Polyline->reg->centroid$ 
            (pts0     lst     / 
             Area     centroid 
             doc     ent     ent-my 
             ent-polay     mp 
             obj     obj1     obj2 
             pts     tmp 
            ) 
          ;坐标集求质心 
    (setq pts pts0) 
    (setq pts (vl-remove nil pts)) 
    (setq pts (mapcar (function (lambda (a) (list (car a) (cadr a)))) 
          pts 
        ) 
    ) 
    (SETQ pts (APPLY 'APPEND pts)) 
    (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))) 
    (if  (= (getvar 'ctab) "Model") 
      (setq mp (vla-get-modelSpace doc)) 
      (setq mp (vla-get-paperSpace doc)) 
    ) 
    (and pts 
   (setq tmp (vl-catch-all-apply 
         'vlax-make-safearray 
         (LIST vlax-vbDouble 
         (cons 0 (- (length pts) 1)) 
         ) 
       ) 
   ) 
   (vl-catch-all-apply 'vlax-safearray-fill (LIST tmp pts)) 
    ) 
    (and doc 
   tmp 
   (setq 
     obj1 
      (vl-catch-all-apply 
        'vla-addLightweightPolyline 
        (LIST mp tmp) 
      ) 
   ) 
   (not (vl-catch-all-error-p obj1)) 
   (progn (vl-catch-all-apply 'vla-Put-CLOSED (LIST obj1 1)) t) 
   (setq 
     OBJ2  (vl-catch-all-apply 
      'vla-addRegion 
      (list 
        mp 
        (vl-catch-all-apply 
          'vlax-make-variant 
          (list 
      (vl-catch-all-apply 
        'vlax-safearray-fill 
        (list 
          (vlax-make-safearray vlax-vbObject '(0 . 0)) 
          (list obj1) 
        ) 
      ) 
          ) 
        ) 
      ) 
    ) 
   ) 
   (not (vl-catch-all-error-p OBJ2)) 
   (setq obj (car (vlax-safearray->list (vlax-variant-value obj2)))) 
   (not (vl-catch-all-error-p obj)) 
   (setq 
     centroid (vlax-safearray->list 
          (vlax-variant-value 
      (vla-get-Centroid 
        obj 
      ) 
          ) 
        ) 
   ) 
   (setq Area (vla-get-Area obj)) 
    ) 
    (vl-catch-all-apply 'vla-put-color (list obj 1)) 
    (and obj (setq ent-my (vlax-vla-object->ename obj))) 
    (and obj1 (setq ent-polay (vlax-vla-object->ename obj1))) 
    (and ent-polay (entdel ent-polay)) 
    (list 
      (cons "边界坐标" pts0) 
      (cons "面域" ent-my) 
      (cons "质心" centroid) 
      (cons "面积" Area) 
    ) 
  ) 
  (defun $addline$ (p1 p2) 
    (if  (and p1 p2) 
      (vla-addline 
  (vla-Get-ModelSpace 
    (vla-get-ActiveDocument 
      (vlax-get-acad-object) 
    ) 
  ) 
  (vlax-3D-Point p1) 
  (vlax-3D-Point p2) 
      ) 
    ) 
  ) 
  (defun $addpoint$ (p) 
    (if  p 
      (VLA-addpoint 
  (vla-get-ModelSpace 
    (vla-get-ActiveDocument (vlax-get-acad-object)) 
  ) 
  (VLAX-3D-POINT p) 
      ) 
    ) 
  ) 
  (defun $she-xian-qiu-jiao-dian$ 
          (pt       lst       / 
           $intersectwith$     a 
           $addpoint$         e 
           generaterays         GetScreenCoords 
           gr       i         is 
           jd       jd-nots   jds 
           line       ll         lmts 
           maxdist   on         osmode 
           p       pts       pts-new 
           ray-count rays      ss 
           ur 
          ) 
          ;射线求交点 
    (defun $IntersectWith$ (ent1 ent2 / jd obj1 obj2 ss sss) 
      (setq 
  obj1 (vl-catch-all-apply 'vlax-ename->vla-object (list ent1)) 
      ) 
      (setq 
  obj2 (vl-catch-all-apply 'vlax-ename->vla-object (list ent2)) 
      ) 
      (if (vl-catch-all-error-p obj1) 
  (setq obj1 nil) 
      ) 
      (if (vl-catch-all-error-p obj2) 
  (setq obj2 nil) 
      ) 
      (if (and obj1 obj2) 
  (setq jd (vl-catch-all-apply 
       'vlax-invoke 
       (list 
         obj1 
         'IntersectWith 
         obj2 
         acExtendNone 
       ) 
     ) 
  ) 
      ) 
      (if (vl-catch-all-error-p jd) 
  (setq jd nil) 
      ) 
      (if jd 
  (if (> (length jd) 3) 
    (progn (setq sss nil) 
     (while  jd 
       (setq ss nil) 
       (setq 
         ss  (list (car jd) (cadr jd) (caddr jd)) 
       ) 
       (setq sss (cons ss sss)) 
       (setq jd (cdddr jd)) 
     ) 
     (setq jd (reverse sss)) 
    ) 
    (setq jd (list jd)) 
  ) 
      ) 
      jd 
    ) 
    (defun GetScreenCoords (/ c03 c08 c04 c07 c06 c09 c01 c02) 
          ; 取得当前绘图区屏幕的左下角和右上角的坐标 
      (setq c03  (getvar "viewctr") 
      c03  (trans c03 1 2) 
      c08  (getvar "viewsize") 
      c04  (getvar "screensize") 
      c07  (car c04) 
      c06  (cadr c04) 
      c09  (/ (* c08 c07) c06) 
      c01  (list (- (car c03) (* 0.5 c09)) (- (cadr c03) (* 0.5 c08))) 
      c02  (list (+ (car c03) (* 0.5 c09)) (+ (cadr c03) (* 0.5 c08))) 
      c01  (trans c01 2 1) 
      c02  (trans c02 2 1) 
      ) 
      (list c01 c02) 
    ) 
    (defun GenerateRays  (center dist count / ang step rays) 
      (setq ang   0.0 
      step (/ 360.0 count) 
      ) 
      (repeat count 
  (setq rays (cons (polar center (* ang (/ pi 180)) dist) rays) 
        ang  (+ ang step) 
  ) 
      ) 
      rays 
    ) 
    (if  pt 
      (progn 
  (setq ray-count (cdr (assoc "射线条数" lst))) 
  (if (and ray-count (= (type ray-count) 'int)) 
    () 
    (setq ray-count 72) 
  ) 
  (or ray-count (setq ray-count 36)) 
  (setq lmts (GetScreenCoords)) 
  (setq maxdist (distance (car lmts) (cadr lmts)) 
        rays    (GenerateRays pt maxdist ray-count) 
        pts     nil 
  ) 
  (setq i 0) 
  (setq jd-nots nil) 
  (foreach ray rays 
    (setq jd nil) 
    (if 
      (and (setq 
       ss (ssget 
      "F" 
      (list pt ray) 
      (list 
          ;(cons -4 "<AND") 
        (cons 0 "CIRCLE,LINE,*line,ellipse,arc,SPLINE") 
          ;(cons -4 "<NOT") 
          ;(CONS 8 "tishi") 
          ;(cons -4 "NOT>") 
          ;(cons -4 "AND>") 
      ) 
          ) 
     ) 
     (setq e (cadar (ssnamex ss))) 
     (setq p (trans (cadar (cdddar (ssnamex ss))) 0 1)) 
      ) 
       (progn 
         (setq jd nil) 
         (setq line ($addline$ pt ray)) 
         (setq line (vlax-vla-object->ename line)) 
         (setq 
     jds (vl-catch-all-apply 
           (function 
       (lambda () 
         ($IntersectWith$ e line) 
       ) 
           ) 
         ) 
         ) 
         (IF JDS 
     () 
     (progn 
       (setq jd-nots (cons (list pt ray) jd-nots)) 
     ) 
         ) 
         (entdel line) 
         (if (vl-catch-all-error-p jds) 
     (setq jds nil) 
         ) 
         (setq jds 
          (vl-sort jds 
             (function (lambda (e1 e2) 
             (< (distance e1 pt) 
                (distance e1 pt) 
             ) 
           ) 
             ) 
          ) 
         ) 
         (setq jd (car jds)) 
         (if (vl-catch-all-error-p jd) 
     (setq jd nil) 
         ) 
         (if jd 
     (setq 
       pts (cons (cons i jd) pts) 
     ) 
         ) 
       ) 
       (PRINT "ssget没有搜索到图元") ;ssget没有搜索到图形 
    ) 
    (setq i (1+ i)) 
    (setq ss nil) 
  ) 
  (setq pts (mapcar 'cdr pts)) 
      ) 
    ) 
    pts 
  ) 
  (if pt 
    (progn 
      (setq Document (vla-get-ActiveDocument (vlax-get-acad-object))) 
      (vla-StartUndoMark Document) 
      (setq qycs (cdr (assoc "取样次数" lst))) 
      (if (and qycs (= (type qycs) 'int)) 
  () 
  (setq qycs 2) 
      ) 
      (or qycs (setq qycs 1)) 
      (setq i 1) 
      (setq to t) 
      (while (and to (<= i qycs)) 
  (setq my 
         (vl-catch-all-apply 
     (function 
       (lambda (/ jds my) 
         (setq 
           jds ($she-xian-qiu-jiao-dian$ pt LST) 
         ) 
         (setq my ($point->Polyline->reg->centroid$ jds nil)) 
         my 
       ) 
     ) 
         ) 
  ) 
  (if (vl-catch-all-error-p my) 
    (setq my nil) 
  ) 
  (setq zx (cdr (assoc "质心" my))) 
  (setq e-my (cdr (assoc "面域" my))) 
  (setq area (cdr (assoc "面积" my))) 
  (setq jds (cdr (assoc "边界坐标" my))) 
  (if (/= i qycs) 
    (if (and e-my (entget e-my)) 
      (entdel e-my) 
    ) 
  ) 
  (if zx 
    (setq pt zx) 
    (setq to nil)      ;第一次如果失败了，后面就不用再跑了，直接让while跳出循环 
  ) 
  (setq i (1+ i)) 
      ) 
      (vla-EndUndoMark Document) 
    ) 
  ) 
  (if zx 
    (setq zx (list (car zx) (cadr zx) 0)) 
  ) 
  (if (vl-position (cdr (assoc "绘制射线" lst)) (list "1" "是")) 
    (progn (vl-catch-all-apply 
       'vla-add 
       (list (vla-get-Layers 
         (setq AcDocument 
          (vla-get-ActiveDocument 
            (vlax-get-acad-object) 
          ) 
         ) 
       ) 
       "tishi" 
       ) 
     ) 
     (mapcar 
       (function 
         (lambda (a / obj) 
     (setq obj ($addline$ zx A)) 
     (vl-catch-all-apply 'vla-put-layer (list obj "tishi")) 
     (vla-put-color obj 3) 
         ) 
       ) 
       jds 
     ) 
    ) 
  ) 
  (if (cdr (assoc "保留面域" lst)) 
    () 
    (progn (entdel e-my) (setq e-my nil)) 
  ) 
  (list 
    (cons "面域" e-my) 
    (cons "边界坐标" jds) 
    (cons "居中点坐标" zx) 
    (cons "质心" zx) 
    (cons "面积" area) 
  ) 
) 
(DEFUN C:tt (/ *ERROR* PT-NEW jzd) 
  (DEFUN *ERROR* (S) (PRINT)) 
  (setq pt (GETPOINT "请在区域内点击一点开始求相对居中点")) 
  (setq  jzd ($xiang-dui-ju-zhong-dian$ 
        pt 
        (list (cons "射线条数" 48) 
        (cons "绘制射线" "1") 
        (CONS "取样次数" 2) 
        (CONS "保留面域" t) 
        ) 
      ) 
  ) 
  (SETQ PT-NEW (cdr (assoc "居中点坐标" jzd))) 
  (princ) 
)

网友答: 感谢分享，这一般用在什么声景？

网友答: 感谢分享，这一般用在什么声景？

网友答: 感谢分享。。

网友答: 建议明经版主给dcl1214 开一个像猫老师，高飞大师等等大佬们一样的专栏

网友答: 感谢分享

上一篇：ACAD，中望，浩辰侧边栏

下一篇：没有了