图元在不封闭区域相对居中
本帖最后由 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)
(ifp
(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)
(whilejd
(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
)
(ifpt
(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 "请在区域内点击一点开始求相对居中点"))
(setqjzd ($xiang-dui-ju-zhong-dian$
pt
(list (cons "射线条数" 48)
(cons "绘制射线" "1")
(CONS "取样次数" 2)
(CONS "保留面域" t)
)
)
)
(SETQ PT-NEW (cdr (assoc "居中点坐标" jzd)))
(princ)
) 感谢分享，这一般用在什么声景？ 感谢分享，这一般用在什么声景？ 感谢分享。。 建议明经版主给dcl1214 开一个像猫老师，高飞大师等等大佬们一样的专栏:lol 感谢分享
页:
[1]