Chuyển đến nội dung
Diễn đàn CADViet
Đăng nhập để thực hiện theo  
Thaistreetz

Lisp ghi chiều dài đoạn thẳng theo Scale factor của Dimstyle hiện thời

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

 Các bác giúp em bổ sung thêm tính năng đo nhanh tất cả các đường line hay PLine có đường gióng như mình đo bình thường được ko ạ. nó sẽ là lệnh tắt của cách đo D1, D3. Mình gõ lệnh đo rồi quét tất cả các đường đó, nó sẽ cho kết quả với kiểu đo của dim hiện tại. Em chân thành cảm ơn

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

topic của mình đây mà. cũng là bài viết thứ 2 trên cadviet của mình. hồi đó đuợc bác PhamThanhBinh viết cho cái lisp này mừng cả 1 ngày.

Mình sửa lại 1 chút lisp của bác Bình cho fù hợp với nhu cầu của bạn đây.

(defun C:TL( / Length1 SSdelete MakePoint GET-M2P MakeText
HT I K LST LST1 LSTL LSTP OSMLAST OTHLAST PT PT0 PT1 SS SSMOVE SSNX SSP TBSS)
(vl-load-com)
(defun MakeText (point string Height Ang justify Style Layer Color xdata / Lst); Ang: Radial
(setq Lst (list '(0 . "TEXT")
(cons 8 (if Layer Layer (getvar "Clayer")))
(cons 62 (if Color Color 256))
(cons 10 point)
(cons 40 Height)
(cons 1 string)
(if Ang (cons 50 Ang))
(cons 7 (if Style Style (getvar "Textstyle")))
(cons -3 (if xdata (list xdata) nil)))
justify (strcase justify))
(cond ((= justify "C") (setq Lst (append Lst (list (cons 72 1) (cons 11 point)))))
((= justify "R") (setq Lst (append Lst (list (cons 72 2) (cons 11 point)))))
((= justify "M") (setq Lst (append Lst (list (cons 72 4) (cons 11 point)))))
((= justify "TL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 3)))))
((= justify "TC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 3)))))
((= justify "TR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 3)))))	
((= justify "ML") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 2)))))
((= justify "MC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 2)))))
((= justify "MR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 2)))))
((= justify "BL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 1)))))
((= justify "BC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 1)))))
((= justify "BR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 1))))))
(entmakex Lst))
(defun SSdelete (SS / )	(setq SS (acet-ss-to-list SS))(foreach SSN SS (entdel SSN)))
(defun Length1(e) (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)))
(defun GET-M2P (PT1 PT2) (polar PT1 (angle PT1 PT2) (* 0.5 (distance PT1 PT2))));end
(defun MakePoint (point layer color)
(entmakex (list '(0 . "POINT")'(100 . "AcDbEntity")
(cons 8 (if Layer Layer (getvar "Clayer")))
(cons 62 (if Color Color 256))
'(100 . "AcDbPoint")(cons 10 point))))
(setq lst '() lst1 '() lstL '() k (getvar "dimlfac") ssmove (ssadd))
(setq ss (ssget (list (cons 0 "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE"))) i 0)
(repeat (sslength ss)
(if (= 1 (car (setq ssnx (car(ssnamex ss i)))))
(if lst1(progn
(setq ssp (ssadd))
(foreach ssn lst1	(setq ssp(ssadd(MakePoint(get-m2p(car(setq lstp(ACET-GEOM-EXTENTS ssn)))(cadr lstp))nil 250)ssp)))
(setq tbss (ACET-GEOM-SS-EXTENTS-FAST ssp))(ssdelete ssp)
(if (>(abs(-(car(car tbss))(car(cadr tbss))))(abs(-(cadr(car tbss))(cadr(cadr tbss)))))
(setq lst1 (vl-sort lst1 '(lambda (e1 e2)
(< (car (get-m2p(car(setq lstp(ACET-GEOM-EXTENTS e1)))(cadr lstp)))
(car (get-m2p(car(setq lstp(ACET-GEOM-EXTENTS e2)))(cadr lstp))))))) ;;; hang
(setq lst1 (vl-sort lst1 '(lambda (e1 e2)
(> (cadr(get-m2p(car(setq lstp(ACET-GEOM-EXTENTS e1)))(cadr lstp)))
(cadr(get-m2p(car(setq lstp(ACET-GEOM-EXTENTS e2)))(cadr lstp)))))))) ;;; cot
(setq lst (append (list (cadr ssnx)) lst1) lst1 '()))
(setq lst (append (list (cadr ssnx)) lst)))
(setq lst1 (append (list (cadr ssnx)) lst1)))
(setq i (1+ i)))
(if lst1 (progn
(setq ssp (ssadd))
(foreach ssn lst1	(setq ssp(ssadd(MakePoint(get-m2p(car(setq lstp(ACET-GEOM-EXTENTS ssn)))(cadr lstp))nil 250)ssp)))
(setq tbss (ACET-GEOM-SS-EXTENTS-FAST ssp))(ssdelete ssp)
(if (>(abs(-(car(car tbss))(car(cadr tbss))))(abs(-(cadr(car tbss))(cadr(cadr tbss)))))
(setq lst1 (vl-sort lst1 '(lambda (e1 e2)
(> (car (get-m2p(car(setq lstp(ACET-GEOM-EXTENTS e1)))(cadr lstp)))
(car (get-m2p(car(setq lstp(ACET-GEOM-EXTENTS e2)))(cadr lstp))))))) ;;; hang
(setq lst1 (vl-sort lst1 '(lambda (e1 e2)
(< (cadr(get-m2p(car(setq lstp(ACET-GEOM-EXTENTS e1)))(cadr lstp)))
(cadr(get-m2p(car(setq lstp(ACET-GEOM-EXTENTS e2)))(cadr lstp)))))))))) ;;; cot
(if (setq lst(append lst1 lst)) (progn
(setq ht (getreal "nhap chieu cao text: ") pt (cadr (grread 't 15 0)) pt0 pt i 0)	
(foreach ll (reverse lst)
(setq ssmove (ssadd (maketext pt (itoa(setq i (1+ i))) ht 0 "C" nil nil nil nil) ssmove)
ssmove (ssadd (maketext (polar pt 0 (* 5 ht)) (rtos (* k(length1 ll)) 2 3) ht 0 "R" nil nil nil nil) ssmove)
pt (list (car pt) (- (cadr pt) (* 1.5 ht)))))
(acet-ss-redraw ssmove 2)
(setq OTHLAST (getvar "orthomode")) (setvar "orthomode" 0)
(if (setq pt1 (acet-ss-drag-move ssmove pt0 "\nChon diem dat bang"))
(progn (vl-cmdf "move" ssmove "" pt0 pt1) (setvar "orthomode" OTHLAST))
(ssdelete ssmove))))
(print "free lisp from cadviet.com") (princ))
Bạn chú ý:

- sau khi gõ lệnh bạn có thể chon theo cả 2 cách như bạn yêu cầu. nghĩa là bạn có thể chọn kiểu như thế này: ...chọn 1 tập hợp -> rồi pick...pick -> rồi lại chọn tập hợp -> rồi lại pick pick...rồi...rồi...

- Chương trình sẽ tự nhận diện tập hợp đối tượng của bạn, nhóm đối tượng nào chọn trước, nhóm đối tượng nào chọn sau, các phần tử trong 1 tập hợp là hàng hay là cột để tự sắp xếp theo X hoặc Y.

- mình ngại kẻ bảng nên kết quả nhìn hơi xấu. thôi, cái này bạn tự làm đê.

@Ketxu: ai lại dich tên tớ thế dry.gif. dịch là Thái bụi cậu ạ laugh.gif

 

ai giúp kẻ bảng cho lisp này không ạ, thêm phần tính tổng nửa được không? em cảm ơn các bác nhiều

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

Đăng nhập để thực hiện theo  

×