Chuyển đến nội dung
Diễn đàn CADViet
huunhantvxdts

[yêu cầu] Lisp đo khoảng cách các điểm trên polyline

Các bài được khuyến nghị

141736_0101.gifĐúng là Cad2008 lệnh Pedit không có chức năng đảo ngược (Reverse). Bạn dùng cái sửa lại ở trên, pick chuột phía nào thì Dim về phía đó.

  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác


(defun c:dpl ( / *error* cen d doc e l pi/2 rl rm s spc)

(defun *error* (msg)
(and doc (vla-endundomark doc))
(if (and msg
(not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*,"))
)
(princ (strcat "\nError: " msg))
)
)

(setq doc (vla-get-activedocument (vlax-get-acad-object))
spc (vlax-get doc
(if (eq (getvar 'CVPORT) 1)
'Paperspace
'Modelspace
)
)
)
(if (setq e (ssget "_+.:E:S" '((0 . "*POLYLINE"))))
(progn
(setq l (_Lw->lst (ssname e 0))
rl (vl-remove-if '(lambda (x) (equal 0.0 (caddr x) 1e-8)) l)
rm (if rl
(apply
(function min)
(mapcar
(function
(lambda (x)
(LM:BulgeRadius (car x) (cadr x) (caddr x))
)
)
rl
)
)
)
pi/2 (/ pi 2)
)
(while (and (setq d (getdist (caar l) "\nSpecify Offset Distance: "))
(if rm (>= d rm)))
(princ (strcat "\nOffset Distance must: < [" (rtos rm 2 2) "]: ")))
(initget "Left Right")
(setq *ans*
(cond
(
(getkword
(strcat "\nChoose [Left/Right] <"
(setq *ans*
(cond (*ans*) ("Left"))
)
">: "
)
)
)
(*ans*)
)
)
(if (= "Left" *ans*) (setq s +) (setq s -))
(vla-startundomark doc)
(foreach x l
(if (= 0 (caddr x))
(_DimAligned spc (car x) (cadr x) (polar (cadddr x) (s (last x) pi/2) d))
(progn
(setq cen (LM:BulgeCenter (car x) (cadr x) (caddr x)))
(_DimArc spc cen (car x) (cadr x) (polar (cadddr x) (s (last x) pi/2) d))
(_DimRadial spc cen (cadddr x)))
)
)
(*error* nil)
)
)
(princ)
)

;;=========================== Sub Function ==============================;;

;; Bulge Center - Lee Mac
;; p1 - start vertex
;; p2 - end vertex
;; b - bulge
;; Returns the center of the arc described by the given bulge and vertices

(defun LM:BulgeCenter ( p1 p2 b )
(polar p1
(+ (angle p1 p2) (- (/ pi 2) (* 2 (atan b))))
(/ (* (distance p1 p2) (1+ (* b b))) 4 b)
)
)

;; Bulge Radius - Lee Mac
;; p1 - start vertex
;; p2 - end vertex
;; b - bulge
;; Returns the radius of the arc described by the given bulge and vertices

(defun LM:BulgeRadius ( p1 p2 b )
(/ (* (distance p1 p2) (1+ (* b b))) 4 (abs b))
)

(defun _Lw->lst (e / a b lst mid o p1 p2 pr)
(setq o (vlax-ename->vla-object e)
pr -1
)
(repeat (fix (vlax-curve-getEndParam o))
(setq
p1 (vlax-curve-getpointatparam o (setq pr (1+ pr)))
p2 (vlax-curve-getpointatparam o (1+ pr))
mid (vlax-curve-getpointatparam o (+ pr 0.5))
b (vla-getbulge o pr)
a (angle p1 p2)
lst (cons (list p1 p2 b mid a) lst)
)
)
(reverse lst)
)

(defun _DimArc (spc cen p1 p2 pt)
(vlax-invoke spc 'addDimArc cen p1 p2 pt)
)

(defun _DimRadial (spc cen pt)
(vlax-invoke spc 'AddDimRadial cen pt (/ (distance cen pt) -2.0))
)

(defun _DimAligned (spc p1 p2 pt)
(vlax-invoke spc 'adddimaligned p1 p2 pt)
)

(vl-load-com)

 

Chỉnh sửa theo snowman.hms
  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

biến đầu vào dis của các bạn phải nhỏ hơn bán kính của cung tròn nhỏ nhất nếu không sẽ dẫn đến kết quả không mong muốn (khi dis> Rmin) :)

  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Mình đang sử dụng cad2008 mà

Bạn xem lại

 

Sorry! Do mình làm trên 2 CAD2008 và 2012, buồn ngủ nữa nên test CAD2012 cứ tưởng là test trên CAD 2008

code mình sửa

 

(defun c:dopl(/ ghidim acadObj doc modelSpace e ddat)
(defun ghidim(e ddat i / dis lst-dim)
       (setq obj (vlax-ename->vla-object e))
       (setq dis (distance ddat (vlax-curve-getclosestpointto e ddat t)))
     (Repeat (fix (vlax-curve-getEndParam e))
       (if (= 0 (vla-GetBulge obj i))
      (vla-AddDimAligned modelSpace
                    (vlax-3d-point (vlax-curve-getpointatparam e i)) (vlax-3d-point (vlax-curve-getpointatparam e (1+ i)) )
                    (vlax-3d-point (polar (vlax-curve-getpointatparam e (+ i 0.5))
                           (- (angle '(0 0 0) (vlax-curve-getFirstDeriv e (+ i 0.5))) (/ pi 2.0)) dis)
                    )
      )
(progn
 (vla-adddimradial modelSpace (vlax-3d-point (mapcar '+ (vlax-curve-getpointatparam e (+ i 0.5)) (vlax-curve-getSecondDeriv e (+ i 0.5)))) 
  (vlax-3d-point (vlax-curve-getpointatparam e (+ i 0.5))) 0.0
 ) (setq lst-dim (append lst-dim (list (entlast))))
          (vla-AddDimArc modelSpace (vlax-3d-point (mapcar '+ (vlax-curve-getpointatparam e (+ i 0.5)) (vlax-curve-getSecondDeriv e (+ i 0.5))))
                    (vlax-3d-point (vlax-curve-getpointatparam e i)) (vlax-3d-point (vlax-curve-getpointatparam e (1+ i)) )
                    (vlax-3d-point (polar (vlax-curve-getpointatparam e (+ i 0.5))
                           (- (angle '(0 0 0) (vlax-curve-getFirstDeriv e (+ i 0.5))) (/ pi 2.0)) dis)
                    )
          )
)
        );if
(setq lst-dim (append lst-dim (list (entlast))))
    (setq i (1+ i))
    );Repeat
lst-dim
)
    (setq acadObj (vlax-get-acad-object))
    (setq doc (vla-get-ActiveDocument acadObj))
 
    (setq modelSpace (vla-get-ModelSpace doc))
  (if (and (setq e (car(entsel "\n Chon Pline : "))) (setq ddat (getpoint (vlax-curve-getstartpoint e) "\nDist (Pick diem) :")))
     (progn
(setq lst-dim (ghidim e ddat 0))
(initget "Y N")
(if (= "Y" (getkword "\nBan muon ghi dim theo huong nguoc lai <Y/N>")) (progn
   (mapcar 'entdel lst-dim) ;(command "._pedit" e "R" "") 
   (ghidim (Rpl e) ddat 0)
))
  );progn
 );if
(princ)
)
(defun rpl (p-ent)
(setq again nil)
;;;;(setq p-ent nil)
;;;;;;;;;;;(prompt "\nSelect a polyline: ")
;;;;;;(while (not p-ent)
;;;;(setq p-ent (car (entsel)))
(if (not p-ent)
(progn
(if (and (/= (dxf 0 p-ent) "POLYLINE")
(/= (dxf 0 p-ent) "LWPOLYLINE")
) ;_ end of and
(progn
(prompt "\nNot a polyline, select again:"
) ;_ end of prompt
(setq p-ent nil)
) ; progn
) ;_ end of if
) ;_ end of progn
) ;_ end of if
;;;;) ;_ end of while
(setq etype (dxf 0 p-ent)
x-ent p-ent
is-closed (dxf 70 p-ent)
) ; setq
(if (= etype "LWPOLYLINE")
(progn
(setq num-vert (dxf 90 p-ent)
elist (entget p-ent)
elist (member (assoc 10 elist) elist)
vvlist nil
) ; setq
(repeat num-vert
(setq vlist (list (cdr (assoc 10 elist))))
(setq vlist
(append vlist
(list (cdr (assoc 42 elist)))
) ;_ end of append
) ;_ end of setq
(setq vvlist (append vvlist
(list vlist)
) ;_ end of append
) ;_ end of setq
(setq elist (cdr elist)
elist (member (assoc 10 elist) elist)
) ; setq
) ; repeat
) ; progn lwpolyline
(progn
(setq vvlist nil
p-ent (entnext p-ent)
) ; setq
(while (/= "SEQEND"
(cdr
(assoc 0 (entget p-ent))
) ;_ end of cdr
) ;_ end of /=
(setq vlist (list (dxf 10 p-ent)))
(setq vlist (append vlist
(list (dxf 42 p-ent))
) ;_ end of append
) ;_ end of setq
(setq vvlist (append vvlist
(list vlist)
) ;_ end of append
) ;_ end of setq
(setq p-ent (entnext p-ent))
) ; while
) ; progn polyline
) ; if
(setq p-list (mapcar 'car vvlist)
p-list (reverse p-list)
b-list (mapcar 'cadr vvlist)
b-list (reverse b-list)
b-first (car b-list)
b-list (cdr b-list)
b-list (append b-list (list b-first))
b-list (mapcar '- b-list)
) ; setq
(setq enlist (list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 90 (length p-list))
(cons 70 (dxf 70 x-ent))
(cons 8 (dxf 8 x-ent))
) ; list
) ; setq
(setq elst nil)
(repeat (length p-list)
(setq
elst (append elst
(list (cons 10 (car p-list)))
) ;_ end of append
) ; setq
(setq
elst (append elst
(list (cons 42 (car b-list)))
) ;_ end of append
) ; setq
(setq p-list (cdr p-list))
(setq b-list (cdr b-list))
) ; repeat
(setq enlist (append enlist elst))
(entdel x-ent)
(entmakex enlist)
;;;;;(prompt "\nPolyline direction is reversed.\n ")
;;;;(princ)
);rpl
(defun dxf (code ename)
(cdr (assoc code (entget ename)))
) 
  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Tạo một tài khoản hoặc đăng nhập để nhận xét

Bạn cần phải là một thành viên để lại một bình luận

Tạo tài khoản

Đăng ký một tài khoản mới trong cộng đồng của chúng tôi. Điều đó dễ mà.

Đăng ký tài khoản mới

Đăng nhập

Bạn có sẵn sàng để tạo một tài khoản ? Đăng nhập tại đây.

Đăng nhập ngay


×