[编程交流] 由质心偏移-需要帮助

(vla-getentity util 'plineObj 'pickPt "\nSelect a polyline:\n")

(setq plineObj (vlax-ename->vla-object (entlast)))

;; ALGEB-AREA
;; Returns the algebraic area of the triangle defined by three 2d points
;; the area is negative if points are clockwise
(defun algeb-area (p1 p2 p3)
 (/ (-        (* (- (car p2) (car p1))
   (- (cadr p3) (cadr p1))
)
(* (- (car p3) (car p1))
   (- (cadr p2) (cadr p1))
)
    )
    2.0
 )
)
;; TRIANGLE-CENTROID
;; Returns the centroid of a triangle defined by 3 points
(defun triangle-centroid (p1 p2 p3)
 (mapcar '(lambda (x1 x2 x3)
     (/ (+ x1 x2 x3) 3.0)
   )
  p1
  p2
  p3
 )
)
;; POLYARC-CENTROID
;; Returns a list which first item is the centroid of a 'polyarc'
;; and the second its algeraic area
;;
;; Arguments
;; bu : polyarc bulge
;; p1 : start point
;; p2 : end point
(defun polyarc-centroid        (bu p1 p2 / ang rad cen area dist cg)
 (setq        ang  (* 2 (atan bu))
rad  (/        (distance p1 p2)
        (* 2 (sin ang))
     )
cen  (polar p1
            (+ (angle p1 p2) (- (/ pi 2) ang))
            rad
     )
area (/ (* rad rad (- (* 2 ang) (sin (* 2 ang)))) 2.0)
dist (/ (expt (distance p1 p2) 3) (* 12 area))
cg   (polar cen
            (- (angle p1 p2) (/ pi 2))
            dist
     )
 )
 (list cg area)
)
;; PLINE-CENTROID
;; Returns the WCS coordinates of a lwpolyline centroid
;;
;; Argument
;; pl : the lwpolyline ename
(defun pline-centroid (pl / elst lst tot cen p0 area cen)
 (setq elst (entget pl))
 (while (setq elst (member (assoc 10 elst) elst))
   (setq lst  (cons (cons (cdar elst) (cdr (assoc 42 elst))) lst)
  elst (cdr elst)
   )
 )
 (setq        lst (reverse lst)
tot 0.0
cen '(0.0 0.0)
p0  (caar lst)
 )
 (if (/= 0 (cdar lst))
   (setq p-c (polyarc-centroid (cdar lst) p0 (caadr lst))
  cen (mapcar '(lambda (x) (* x (cadr p-c))) (car p-c))
  tot (cadr p-c)
   )
 )
 (setq lst (cdr lst))
 (if (equal (car (last lst)) p0 1e-9)
   (setq lst (reverse (cdr (reverse lst))))
 )
 (while (cadr lst)
   (setq area (algeb-area p0 (caar lst) (caadr lst))
  cen  (mapcar '(lambda (x1 x2) (+ x1 (* x2 area)))
               cen
               (triangle-centroid p0 (caar lst) (caadr lst))
       )
  tot  (+ area tot)
   )
   (if        (/= 0 (cdar lst))
     (setq p-c        (polyarc-centroid (cdar lst) (caar lst) (caadr lst))
    cen        (mapcar        '(lambda (x1 x2) (+ x1 (* x2 (cadr p-c))))
                cen
                (car p-c)
        )
    tot        (+ tot (cadr p-c))
     )
   )
   (setq lst (cdr lst))
 )
 (if (/= 0 (cdar lst))
   (setq p-c (polyarc-centroid (cdar lst) (caar lst) p0)
  cen (mapcar '(lambda (x1 x2) (+ x1 (* x2 (cadr p-c))))
              cen
              (car p-c)
      )
  tot (+ tot (cadr p-c))
   )
 )
 (trans (list (/ (car cen) tot)
       (/ (cadr cen) tot)
       (cdr (assoc 38 (entget pl)))
 )
 pl
 0
 )
)

;; PLINE-ALGEBRAIC-AREA (gile)
;; Returns the algebraic area of the polyline
;; the area is negative if the polyline is clockwise
;;
;; Argument: a polyline ename
(defun Pline-Algebraic-Area (pl / elst lst tot)
 (setq elst (entget pl))
 (while (setq elst (member (assoc 10 elst) elst))
   (setq lst  (cons (cons (cdar elst) (cdr (assoc 42 elst))) lst)
     elst (cdr elst)
   )
 )
 (setq    lst (reverse lst)
   tot 0.0
   p0  (caar lst)
 )
 (if (/= 0 (cdar lst))
   (setq tot (polyarc-algeb-area (cdar lst) p0 (caadr lst))
   )
 )
 (setq lst (cdr lst))
 (if (equal (car (last lst)) p0 1e-9)
   (setq lst (reverse (cdr (reverse lst))))
 )
 (while (cadr lst)
   (setq tot  (+ (triangle-algeb-area p0 (caar lst) (caadr lst)) tot))
   (if    (/= 0 (cdar lst))
     (setq tot    (+ tot (polyarc-algeb-area (cdar lst) (caar lst) (caadr lst))))
   )
   (setq lst (cdr lst))
 )
 (if (/= 0 (cdar lst))
   (setq tot (+ tot (polyarc-algeb-area (cdar lst) (caar lst) p0)))
 )
 tot
)
;; TRIANGLE-ALGEB-AREA (gile)
;; Returns the algebraic area of the triangle defined by three 2d points
;; the area is negative if points are clockwise
;;
;; Arguments: three 2d points
(defun triangle-algeb-area (p1 p2 p3)
 (/ (-    (* (- (car p2) (car p1))
      (- (cadr p3) (cadr p1))
   )
   (* (- (car p3) (car p1))
      (- (cadr p2) (cadr p1))
   )
    )
    2.0
 )
)
;; POLYARC-ALGEB-AREA (gile)
;; Returns the algeraic area of a 'polyarc'
;;
;; Arguments
;; bu : polyarc bulge
;; p1 : start point
;; p2 : end point
(defun polyarc-algeb-area    (bu p1 p2 / ang rad)
 (setq    ang  (* 2 (atan bu))
   rad  (/    (distance p1 p2)
       (* 2 (sin ang))
        )
 )
 (/ (* rad rad (- (* 2 ang) (sin (* 2 ang)))) 2.0)
)
;; InsideOffset (gile)
;; Offset inside a closed polyline
;;
;; Arguments
;; pl: a polyline (ename or vla-object)
;; dist: offset distance
;;
;; Returns a variant
;; (an array of the newly created objects resulting from the offset).
(defun InsideOffset (pl dist / obj)
 (vl-load-com)
 (if (= (type pl) 'ENAME)
   (setq obj (vlax-ename->vla-object pl))
   (setq obj pl
         pl  (vlax-vla-object->ename obj)
   )
 )
 (vla-offset obj
             (if (minusp (Pline-Algebraic-Area pl))
               dist
               (- dist)
             )
 )
)

;;; Offset inside of selected objects
;;; Alan J. Thompson, 09.12.09
(defun c:OffIn (/ #Dist #SSGet #Pline #Offset)
 (vl-load-com)
 (initget 6)
 (cond
   ((and (setq #Dist (getdist "\nSpecify offset distance: "))
         (setq #SSGet (ssget ":L" '((0 . "LINE,LWPOLYLINE,ARC"))))
    ) ;_ and
    (if (zerop (getvar "peditaccept"))
      (vl-cmdf "_.pedit" "_m" #SSGet "" "_y" "_j" "" "")
      (vl-cmdf "_.pedit" "_m" #SSGet "" "_j" "" "")
    ) ;_ if
    (if (not (vl-catch-all-error-p
               (setq
                 #Offset
                  (vl-catch-all-apply
                    'vla-offset
                    (list (setq
                            #Pline (vlax-ename->vla-object (entlast))
                          ) ;_ setq
                          (abs #Dist)
                    ) ;_ list
                  ) ;_ vl-catch-all-apply
               ) ;_ setq
             ) ;_ vl-catch-all-error-p
        ) ;_ not
      (if (> (vla-get-area
               (setq #Offset (car (vlax-safearray->list
                                    (vlax-variant-value #Offset)
                                  ) ;_ vlax-safearray->list
                             ) ;_ car
               ) ;_ setq
             ) ;_ vla-get-area
             (vla-get-area #Pline)
          ) ;_ >
        (progn
          (vla-delete #Offset)
          (if (not (vl-catch-all-error-p
                     (setq #Offset (vl-catch-all-apply
                                     'vla-offset
                                     (list #Pline (- (abs #Dist)))
                                   ) ;_ vl-catch-all-apply
                     ) ;_ setq
                   ) ;_ vl-catch-all-error-p
              ) ;_ not
            (setq #Offset (car (vlax-safearray->list
                                 (vlax-variant-value #Offset)
                               ) ;_ vlax-safearray->list
                          ) ;_ car
            ) ;_ setq
            (setq #Offset nil)
          ) ;_ if
        ) ;_ progn
      ) ;_ if
      (alert "Item cannot be offset.")
    ) ;_ if
    (and #Pline (vla-explode #Pline))
   )
 ) ;_ cond
 (princ)
) ;_ defun