Jump to content
InfoFile
Tác giả: Bee
Bài viết gốc: 408374
Tên lệnh: mac
Xoay text thuộc tính trong block

Tong một bản vẽ có nhiều trục (nhiếu att block) theo mình nghĩ lsp nên chọn những att block nào cần thay góc quay thôi 

(có những att block ở những vị trí khác nhưng trong cùng một bản vẽ có khi không cần thay góc quay)

Mình đã gửi file cho bạn rồi đó. 

 

>>

Tong một bản vẽ có nhiều trục (nhiếu att block) theo mình nghĩ lsp nên chọn những att block nào cần thay góc quay thôi 

(có những att block ở những vị trí khác nhưng trong cùng một bản vẽ có khi không cần thay góc quay)

Mình đã gửi file cho bạn rồi đó. 

 

"Vay co cach nao lam cho no trung voi tam duong tron khong vay ban? Boi vi att block nay do nguoi khac tao truoc do roi. "

Uhm trong block đấy là ellip mà. không phải đường tròn. Mình có sửa code lại đây. Có bản vẽ khám bênh mới chính xác được. Lisp này là move att vào tâm thôi không xoay att. Muốn xoay thì dùng lisp XO hoặc torrient tùy bạn. Dùng kết hợp 2 lisp. Còn muốn add thêm xoay att vào lisp của mình thì để sau thứ 3 mình semina xong sẽ sửa lại lisp.

Thử lisp mới và ngồi xem nhé. ^_^

(defun c:MAC (/ acdoc mspace blk center temp)
  (setq acdoc (vla-get-activedocument (vlax-get-acad-object)))
  (setq mspace (vla-get-modelspace acdoc))
  (if (setq blk (car (entsel "\nChon block: ")))
    (progn
      (vlax-for	blks (vla-get-blocks acdoc)
	(if (wcmatch (vla-get-Name blks) (cdr (assoc 2 (entget blk))))
	  (progn
	    (vlax-for obj blks
	      (if (or (= (vla-get-ObjectName obj) "AcDbCircle")
		      (= (vla-get-ObjectName obj) "AcDbEllipse")
                      (= (vla-get-ObjectName obj) "AcDbArc")
		      )
		(setq center (vlax-get obj 'Center))
	      )
	    )
	   
	    (vlax-for obj blks
	      (if
		(= (vla-get-ObjectName obj) "AcDbAttributeDefinition")
		 (progn
		   ;(vla-put-Rotation obj 0.0)
		   (vla-put-Alignment obj acAlignmentMiddleCenter)
		   (vla-put-TextAlignmentPoint
		     obj
		     (vlax-3d-point center)
		   )
		 )			;progn
	      )				;if
	    )				;vlax-for obj
	  )				;progn then
	)				;if
      )					;vlax-for blks
      (setq temp (vla-insertblock
		   mspace
		   (vlax-3d-point '(0. 0. 0.))
		   (cdr (assoc 2 (entget blk)))
		   1
		   1
		   1
		   0
		 )
      )
      (vla-sendcommand
	acdoc
	(strcat	"ATTSYNC\n"
		"Name\n"
		""
		(cdr (assoc 2 (entget blk)))
		"\n"
		""
	)
      )
      (vla-delete temp)
    )					;progn
    (princ "\nBan da khong chon block.")
  )					;if
  (princ)
)					;defun

;;;END CODE VISUAL LISP HERE

<<

Filename: 408374_mac.lsp
Tác giả: Bee
Bài viết gốc: 408453
Tên lệnh: test
Nhờ Viết Lisp Chuyển Layer Cho Leader Và Text

e up load bản vẽ của e lên ạ. mong mọi người viết giúp e 1 lisp mà khi mình sử dụng thì: 

1. leader hình mũi tên(closed filled) sẽ chuyển hết về layer "14.Dimhh"; 

2. leader hình tròn (Dot blank) sẽ chuyển hết về layer "15.Dimct". 

3. các text thuộc text style "Text 1.5" và "Text 1.8"...

>>

e up load bản vẽ của e lên ạ. mong mọi người viết giúp e 1 lisp mà khi mình sử dụng thì: 

1. leader hình mũi tên(closed filled) sẽ chuyển hết về layer "14.Dimhh"; 

2. leader hình tròn (Dot blank) sẽ chuyển hết về layer "15.Dimct". 

3. các text thuộc text style "Text 1.5" và "Text 1.8" sẽ chuyển về layer "06.Text1.8"; 

4. text thuộc text style "Text 2.5" và "Text 3.0" sẽ chuyển về layer "07.Text3.0". 

các layer và các style đã có sẵn trong bản vẽ, nhưng e ko up bản vẽ lên được (cứ báo Đang upload. Xin chờ). e cảm ơn ạ

Uhm, thử lisp này xem ^_^

(defun c:test ()
  (setq acdoc (vla-get-activedocument (vlax-get-acad-object)))
  (vlax-for blks (vla-get-blocks acdoc)
    (vlax-for obj blks
      (if (wcmatch (vla-get-ObjectName obj) "AcDbLeader")
	(progn
	  (if (wcmatch (vla-get-ArrowheadBlock obj) "")
	    (vla-put-Layer obj "14.Dimhh")
	    )
	  (if (wcmatch (vla-get-ArrowheadBlock obj) "DotBlank")
	    (vla-put-Layer obj "15.Dimct")
	    )
	  )
	)
      (if (and (wcmatch (vla-get-ObjectName obj) "*TEXT")
	       (or (wcmatch (vla-get-StyleName obj) "Text 1.5")
		   (wcmatch (vla-get-StyleName obj) "Text 1.8")
		   )
	       )
	(vla-put-Layer obj "06.Text1.8")
	)
      (if (and (wcmatch (vla-get-Name obj) "*TEXT")
	       (or (wcmatch (vla-get-StyleName obj) "Text 2.5")
		   (wcmatch (vla-get-StyleName obj) "Text 3.0")
		   )
	       )
	(vla-put-Layer obj "07.Text3.0")
	)
      );vlax-for obj
    );vlax-for blks
  (princ)
  )

<<

Filename: 408453_test.lsp
Tác giả: Bee
Bài viết gốc: 408452
Tên lệnh: xom
Xoay text thuộc tính trong block

Nếu kết hợp vừa move vào tâm và xoay luôn thì còn gì bằng nữa. Tuyệt vời

Mong tin từ bạn. 

Trong 1 bản vẽ thì có nhiều att block, lsp nên chọn những đối tượng att block nào cần move và xoay thôi thì hay hơn

bởi vì có những cái không cần tác đến chúng.

Uhm, không...

>>

Nếu kết hợp vừa move vào tâm và xoay luôn thì còn gì bằng nữa. Tuyệt vời

Mong tin từ bạn. 

Trong 1 bản vẽ thì có nhiều att block, lsp nên chọn những đối tượng att block nào cần move và xoay thôi thì hay hơn

bởi vì có những cái không cần tác đến chúng.

Uhm, không sửa block gốc thì sài tạm cái này tổng hợp mấy cái cho nhanh vậy ^_^

(defun c:XOM (/ ss ss1 center n i ent lst lse)
  (c:torient)
  (setq ss (ssget "_P"))
  (setq n 0)
  (repeat (sslength ss)
    (command "_explode" (ssname ss n))
    (setq ss1 (ssget "_P"))
    (setq center nil)
    (setq i 0)
    (while (not center)
      (if (or (eq (cdr (assoc 0 (entget (ssname ss1 i)))) "CIRCLE")
	      (eq (cdr (assoc 0 (entget (ssname ss1 i)))) "ELLIPSE")
	      )
	(setq center (cdr (assoc 10 (entget (ssname ss1 i)))))
      )
      (setq i (1+ i))
    )
    (command "undo" "")
    (setq ent (ssname ss n)
	  ent (entnext ent)
	  lst (list (cons 71 0)
		    (cons 72 1)
		    (cons 11 center)
	      )
	  lse (entget ent)
    )
    (mapcar '(lambda (x) (entmod (subst x (assoc (car x) lse) lse)))
	    lst
    )
    (entupd ent)
    (setq n (1+ n))
  )
  (princ)
) 

Đúng ý nhé. Chén thôi. ^_^


<<

Filename: 408452_xom.lsp
Tác giả: Bee
Bài viết gốc: 408461
Tên lệnh: test
Nhờ Viết Lisp Chuyển Layer Cho Leader Và Text

không được bác ah, cad nó báo Command: test
; error: ActiveX Server returned the error: unknown name: Name
Command:

Thay "*TEXT" trong code bằng "AcDbText" là ngon. ^_^

(defun c:test ()
  (setq acdoc...
>>

không được bác ah, cad nó báo Command: test
; error: ActiveX Server returned the error: unknown name: Name
Command:

Thay "*TEXT" trong code bằng "AcDbText" là ngon. ^_^

(defun c:test ()
  (setq acdoc (vla-get-activedocument (vlax-get-acad-object)))
  (vlax-for blks (vla-get-blocks acdoc)
    (vlax-for obj blks
      (if (wcmatch (vla-get-ObjectName obj) "AcDbLeader")
	(progn
	  (if (wcmatch (vla-get-ArrowheadBlock obj) "")
	    (vla-put-Layer obj "14.Dimhh")
	    )
	  (if (wcmatch (vla-get-ArrowheadBlock obj) "DotBlank")
	    (vla-put-Layer obj "15.Dimct")
	    )
	  )
	)
      (if (and (wcmatch (vla-get-ObjectName obj) "AcDbText")
	       (or (wcmatch (vla-get-StyleName obj) "Text 1.5")
		   (wcmatch (vla-get-StyleName obj) "Text 1.8")
		   )
	       )
	(vla-put-Layer obj "06.Text1.8")
	)
      (if (and (wcmatch (vla-get-ObjectName obj) "AcDbText")
	       (or (wcmatch (vla-get-StyleName obj) "Text 2.5")
		   (wcmatch (vla-get-StyleName obj) "Text 3.0")
		   )
	       )
	(vla-put-Layer obj "07.Text3.0")
	)
      );vlax-for obj
    );vlax-for blks
  (princ)
  )

<<

Filename: 408461_test.lsp
Tác giả: Bee
Bài viết gốc: 408462
Tên lệnh: xom
Xoay text thuộc tính trong block

Thanks bạn !

Cái này cũng giống với lệnh torient nhưng sau khi quay đi 1 góc nó cũng bị lệch tâm ah bạn ơi ! 

Đã test bản vẽ của bạn. Ok nhé ^_^

(defun c:XOM (/ ss ss1 center n i ent lse)
  (c:torient)
  (setq ss (ssget "_P"))
  (command "_justifytext" ss "" "MC")
  (setq n 0)
 ...
>>

Thanks bạn !

Cái này cũng giống với lệnh torient nhưng sau khi quay đi 1 góc nó cũng bị lệch tâm ah bạn ơi ! 

Đã test bản vẽ của bạn. Ok nhé ^_^

(defun c:XOM (/ ss ss1 center n i ent lse)
  (c:torient)
  (setq ss (ssget "_P"))
  (command "_justifytext" ss "" "MC")
  (setq n 0)
  (repeat (sslength ss)
    (command "_explode" (ssname ss n))
    (setq ss1 (ssget "_P"))
    (setq center nil)
    (setq i 0)
    (while (not center)
      (if (or (eq (cdr (assoc 0 (entget (ssname ss1 i)))) "CIRCLE")
	      (eq (cdr (assoc 0 (entget (ssname ss1 i)))) "ELLIPSE")
	  )
	(setq center (cdr (assoc 10 (entget (ssname ss1 i)))))
      )
      (setq i (1+ i))
    )
    (command "undo" "")
    (setq ent (ssname ss n)
	  ent (entnext ent)
	  lse (entget ent)
    )
    (entmod (subst (cons 11 center) (assoc 11 lse) lse))
    (entupd ent)
    (setq n (1+ n))
  )
  (princ)
)

<<

Filename: 408462_xom.lsp
Tác giả: duy782006
Bài viết gốc: 408472
Tên lệnh: vc
Nhờ Sửa Lips

Điểm nút đỉnh thửa thể hiện bằng đối tượng gì (point, block)?

Tạm thời sửa màu text và tạo point tại đỉnh các việc khác thì chờ người khác nhé.

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=2265&st=60
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Chuong trinh danh so va lap bang toa do ho so thua dat dia...
>>

Điểm nút đỉnh thửa thể hiện bằng đối tượng gì (point, block)?

Tạm thời sửa màu text và tạo point tại đỉnh các việc khác thì chờ người khác nhé.

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=2265&st=60
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Chuong trinh danh so va lap bang toa do ho so thua dat dia chinh
;;;Bang toa do tao thanh block, duoc dat ten theo so thu tu 1, 2, 3...
;;;Chap nhan cac doi tuong la Region, Polyline, Line va Arc khep kin
;;;Written by ssg and elleHCSC - January 2009 - www.cadviet.com 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;WELCOME TO NEW YEAR 2009
;;;WISH ALL CADVIET MEMBERS AND FAMILY
;;;HAVE HAPPY, HEALTH AND PROSPEROUS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;




;;;PUBLIC FUNCTIONS
;;;-------------------------------------------------------------------------------
(Defun DTR(x) (/ (* x pi) 180) ) ;;;change degree to radian, return REAL
;;;-------------------------------------------------------------------------------
(defun lineP (p0 a r / p1) ;;;Line polar: point, degree angle, radius
    (setq p1 (polar p0 (dtr a) r))
    (command "line" p0 p1 "")
)
;;;-------------------------------------------------------------------------------
(defun linePX (p0 x) (lineP p0 0 x)) ;;;Horizontal line: length x, from p0
;;;-------------------------------------------------------------------------------
(defun linePY (p0 y) (lineP p0 90 y)) ;;;Vertical line: length y, from p0
;;;-------------------------------------------------------------------------------
(defun getVert (e / i L) ;;;Return list of all vertex from pline e
(setq i 0 L nil)
(vl-load-com)
(repeat (fix (+ (vlax-curve-getEndParam e) 1))
    (setq L (append L (list (vlax-curve-getPointAtParam e i))))
    (setq i (1+ i))
)
L
)
;;;-------------------------------------------------------------------------------
(defun wtxtMC (txt p h) ;;;Write text Middle Center, specify text, point, height
(entmake (list (cons 0  "TEXT") (cons 7 (getvar "textstyle"))
    (cons 1 txt) (cons 10 p) (cons 11 p) (cons 40 h) (cons 72 1) (cons 73  2)))
)
;;;-------------------------------------------------------------------------------
(defun Collect(e / e2 SS) ;;;Selection set from e to entlast
(setq SS (ssadd))
(ssadd e SS)
(while (setq e2 (entnext e)) (ssadd e2 SS) (setq e e2))
SS
)
;;;-------------------------------------------------------------------------------
(defun Collect1(e / ss)
;;;Selection set after e to entlast. If e nil, select all from fist entity of drawing.
(if (= e nil) (setq ss (collect (entnext)))
	(progn (setq ss (collect e)) (ssdel e ss))
)
)
;;;-------------------------------------------------------------------------------

;;;PRIVATE FUNCTIONS
;;;-------------------------------------------------------------------------------
(defun txt1(txtL / p1 p2 p3 p4 pL i) ;;;Write texts in 1 row
(setq
    p1 (list (+ (car p0) (* 2 h)) (- (cadr p0) (* 1.5 h)))
    p2 (polar p1 0 (* 8 h))
    p3 (polar p2 0 (* 12 h))
    p4 (polar p3 0 (* 10 h))
    pL (list p1 p2 p3 p4)
    i 0
)
(repeat 4
    (wtxtMC (nth i txtL) (nth i pL) h)
    (setq i (1+ i))
)
)
;;;-------------------------------------------------------------------------------
(defun txt2(txtL / p1 p2 p3 p4 pL i) ;;;Write texts in 1 row
(setq
    p1 (list (+ (car p0) (* 2 h)) (- (cadr p0) (* 1.5 h)))
    p2 (polar p1 0 (* 8 h))
    p3 (polar p2 0 (* 12 h))
    p4 (polar p3 0 (* 10 h))
	p4 (polar p4 (* 0.5 pi) (* 1.5 h))
    pL (list p1 p2 p3 p4)
    i 0
)
(repeat 4
    (wtxtMC (nth i txtL) (nth i pL) h)
    (setq i (1+ i))
)
)
;;;-------------------------------------------------------------------------------


;;;MAIN PROGRAM
;;;-------------------------------------------------------------------------------
(defun C:VC( / h p et p0 p00 p01 p02 pt pvL n j pv num txtL ss bn ntp)
;;;Vertex Co-ordinate

;;;GET TEXT HEIGHT
(if (not h0) (setq h0 1))
(setq h (getreal (strcat "\nChon chieu cao text <" (rtos h0) ">:")))
(if (not h) (setq h h0) (setq h0 h))

;;;GET DECIMAL PRECISION
(if (not ntp0) (setq ntp0 2))
(setq ntp (getint (strcat "\nSo chu so thap phan <" (itoa ntp0) ">:")))
(if (not ntp) (setq ntp ntp0) (setq ntp0 ntp))

;;;PICK & BASE POINT
(setq p (getpoint "\nPick 1 diem giua mien kin:"))
(command "boundary" p "")
(setq et (entlast))
(redraw et 3)
(setq
    p00 (getpoint "\nDiem chuan bang toa do (phia tren ben trai):")
    p0 p00
	p01 (polar p00 (* 1.5 pi) (* h 3))
    pvL (reverse (getvert et))
	n (length pvL)
	p02 (polar p01 (* 1.5 pi) (* n h 3))
    oldos (getvar "osmode")
)
(setvar "osmode" 0)

;;;HEADER
(linepx p0 (* 38 h))
(command "copy" "L" "" "m" p00 p01 p02 "")
(linepy p0 (* (+ n 1) -3 h))
(command "copy" "L" "" "m" p0 
    (list(+ (car p0) (* 4 h)) (cadr p0))
	(list(+ (car p0) (* 16 h)) (cadr p0))
    (list(+ (car p0) (* 28 h)) (cadr p0))
    (list(+ (car p0) (* 38 h)) (cadr p0))
	""
)

(txt1 (list "TT" "X (m)" "Y (m)" "S (m)"))
(setq p0 (polar p0 (* 1.5 pi) (* 3 h)))

;;;MAKE RECORDS
(setq j 0 pt nil)
(repeat n
    (setq
        pv (nth j pvL)
        num (itoa (1+ j))
	)
	(if pt (setq S (rtos (distance pt pv) 2 ntp)) (setq S ""))
    (setq txtL (list num (rtos (cadr pv) 2 ntp) (rtos (car pv) 2 ntp) S))
    (txt2 txtL)
    (setq p0 (polar p0 (* 1.5 pi) (* 3 h)))
	(setq pt pv)
    (setq j (1+ j))
	(if (= j (- n 1)) (setq j 0))
)

;;;MAKE BLOCK
(setq ss (collect1 et))
(setq bn "1")
(while (tblsearch "block" bn) (setq bn (itoa (1+ (atoi bn)))))
(command "block" bn p00 ss "")
(command "insert" bn p00 "" "" "")

;;;WRITE POINT NAME
(setq j 0)
(repeat (1- n)
    (setq
        pv (nth j pvL)
        num (itoa (1+ j))
    )
    (wtxtMC num (polar pv 0 h) h)
(command "point" pv)
    (setq j (1+ j))
)

;;;GHI CANH THUA
(ghicanh et)
(command "erase" et "")

;;;FINISH
(setvar "osmode" oldos)
(princ)
)
;;;-------------------------------------------------------------------------------



;;;PHAN BO SUNG CUA elleHCSC
;;;------------------------------------------------------------------------------------
(defun Text_canh_TCA (S p a) ;;;Entmake text S at p with angle A - Top Center
(if (/= p nil)
(entmake (list
(cons 0 "TEXT")
(cons 62 6)
(cons 10 p)
(cons 40 h)
(cons 1 S)
(cons 50 a)
(cons 41 0.7)
(cons 51 (DTR 18))
(cons 7 (getvar "textstyle"))
(cons 72 1)
(cons 11 p)
(cons 73 3)
)
)
)
)
;;;------------------------------------------------------------------------------------
(defun Text_canh_BCA (S p a) ;;;Entmake text S at p with angle A - Bottom Center
(if (/= p nil)
(entmake (list
(cons 0 "TEXT")
(cons 62 6)
(cons 10 p)
(cons 40 h)
(cons 1 S)
(cons 50 a)
(cons 41 0.7)
(cons 51 (DTR 18))
(cons 7 (getvar "textstyle"))
(cons 72 1)
(cons 11 p)
(cons 73 1)
)
)
)
)
;;;-------------------------------------------------------------------------------
(defun Ghicanh (e / i pvL k p1 p2 dist rad x_mp y_mp mp)
(setq
i 0
pvL (reverse (getvert e))
k (1- (length pvL))
)
(repeat k
(setq
p1 (nth i pvL)
p2 (nth (+ i 1) pvL)
dist (distance p1 p2)
rad (angle p1 p2)
x_mp (* (+ (car p1) (car p2)) 0.5)
y_mp (* (+ (cadr p1) (cadr p2)) 0.5)
mp (list x_mp y_mp)
)
(if (and (> rad (* 0.5 pi)) (<= rad (* 1.5 pi)))
(setq mp (polar mp (+ rad (* 0.5 pi)) (* 0.3 h) ))
)
(if (and (> rad (* 0.5 pi)) (<= rad (* 1.5 pi)))
(progn
(setq rad (+ rad pi))
(Text_canh_TCA (rtos dist 2 2) mp rad)
)
(Text_canh_BCA (rtos dist 2 2) mp rad)
)
(setq i (1+ i))
);; repeat k;
)
;;;--------------------------


<<

Filename: 408472_vc.lsp
Tác giả: Bee
Bài viết gốc: 408455
Tên lệnh: dimsum
Tính Tổng Chiều Dài Dim

chào các pro , hiện e có 1 vấn đề nhỏ, đó là có thể có cách nào tính tổng các giá trị chiều dài trong Dim ko? thanks all

Search thôi.

(defun c:DimSum (/ #SSList)
  (and (setq #SSList (AT:SS->List (ssget '((0 . "DIMENSION"))) T))
       (alert
         (strcat "Total Distance: "
                ...
>>

chào các pro , hiện e có 1 vấn đề nhỏ, đó là có thể có cách nào tính tổng các giá trị chiều dài trong Dim ko? thanks all

Search thôi.

(defun c:DimSum (/ #SSList)
  (and (setq #SSList (AT:SS->List (ssget '((0 . "DIMENSION"))) T))
       (alert
         (strcat "Total Distance: "
                 (vl-princ-to-string
                   (apply '+ (mapcar 'vla-get-measurement #SSList))
                 ) ;_ vl-princ-to-string
                 "'"
         ) ;_ strcat
       ) ;_ alert
  ) ;_ and
  (princ)
) ;_ defun
;;; Convert selection set to list of ename or vla objects
;;; #Selection - SSGET selection set
;;; #VLAList - T for vla objects, nil for ename
;;; Alan J. Thompson, 04.20.09
(defun AT:SS->List (#Selection #VlaList / #List)
  (and #Selection
       (setq #List (vl-remove-if
                     'listp
                     (mapcar 'cadr (ssnamex #Selection))
                   ) ;_ vl-remove-if
       ) ;_ setq
       #VlaList
       (setq #List (mapcar 'vlax-ename->vla-object #List))
  ) ;_ and
  #List
) ;_ defun

<<

Filename: 408455_dimsum.lsp
Tác giả: duy782006
Bài viết gốc: 408495
Tên lệnh: vc
Nhờ Sửa Lips

Sửa lại cho phép bạn chọn bán kính vòng tròn nút.

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=2265&st=60
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Chuong trinh danh so va lap bang toa do ho so thua dat dia chinh
;;;Bang toa do tao thanh block, duoc dat ten theo so thu tu 1, 2, 3...
;;;Chap nhan cac doi tuong la Region, Polyline, Line va Arc khep...
>>

Sửa lại cho phép bạn chọn bán kính vòng tròn nút.

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=2265&st=60
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Chuong trinh danh so va lap bang toa do ho so thua dat dia chinh
;;;Bang toa do tao thanh block, duoc dat ten theo so thu tu 1, 2, 3...
;;;Chap nhan cac doi tuong la Region, Polyline, Line va Arc khep kin
;;;Written by ssg and elleHCSC - January 2009 - www.cadviet.com 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;WELCOME TO NEW YEAR 2009
;;;WISH ALL CADVIET MEMBERS AND FAMILY
;;;HAVE HAPPY, HEALTH AND PROSPEROUS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;




;;;PUBLIC FUNCTIONS
;;;-------------------------------------------------------------------------------
(Defun DTR(x) (/ (* x pi) 180) ) ;;;change degree to radian, return REAL
;;;-------------------------------------------------------------------------------
(defun lineP (p0 a r / p1) ;;;Line polar: point, degree angle, radius
    (setq p1 (polar p0 (dtr a) r))
    (command "line" p0 p1 "")
)
;;;-------------------------------------------------------------------------------
(defun linePX (p0 x) (lineP p0 0 x)) ;;;Horizontal line: length x, from p0
;;;-------------------------------------------------------------------------------
(defun linePY (p0 y) (lineP p0 90 y)) ;;;Vertical line: length y, from p0
;;;-------------------------------------------------------------------------------
(defun getVert (e / i L) ;;;Return list of all vertex from pline e
(setq i 0 L nil)
(vl-load-com)
(repeat (fix (+ (vlax-curve-getEndParam e) 1))
    (setq L (append L (list (vlax-curve-getPointAtParam e i))))
    (setq i (1+ i))
)
L
)
;;;-------------------------------------------------------------------------------
(defun wtxtMC (txt p h) ;;;Write text Middle Center, specify text, point, height
(entmake (list (cons 0  "TEXT") (cons 7 (getvar "textstyle"))
    (cons 1 txt) (cons 10 p) (cons 11 p) (cons 40 h) (cons 72 1) (cons 73  2)))
)
;;;-------------------------------------------------------------------------------
(defun Collect(e / e2 SS) ;;;Selection set from e to entlast
(setq SS (ssadd))
(ssadd e SS)
(while (setq e2 (entnext e)) (ssadd e2 SS) (setq e e2))
SS
)
;;;-------------------------------------------------------------------------------
(defun Collect1(e / ss)
;;;Selection set after e to entlast. If e nil, select all from fist entity of drawing.
(if (= e nil) (setq ss (collect (entnext)))
	(progn (setq ss (collect e)) (ssdel e ss))
)
)
;;;-------------------------------------------------------------------------------

;;;PRIVATE FUNCTIONS
;;;-------------------------------------------------------------------------------
(defun txt1(txtL / p1 p2 p3 p4 pL i) ;;;Write texts in 1 row
(setq
    p1 (list (+ (car p0) (* 2 h)) (- (cadr p0) (* 1.5 h)))
    p2 (polar p1 0 (* 8 h))
    p3 (polar p2 0 (* 12 h))
    p4 (polar p3 0 (* 10 h))
    pL (list p1 p2 p3 p4)
    i 0
)
(repeat 4
    (wtxtMC (nth i txtL) (nth i pL) h)
    (setq i (1+ i))
)
)
;;;-------------------------------------------------------------------------------
(defun txt2(txtL / p1 p2 p3 p4 pL i) ;;;Write texts in 1 row
(setq
    p1 (list (+ (car p0) (* 2 h)) (- (cadr p0) (* 1.5 h)))
    p2 (polar p1 0 (* 8 h))
    p3 (polar p2 0 (* 12 h))
    p4 (polar p3 0 (* 10 h))
	p4 (polar p4 (* 0.5 pi) (* 1.5 h))
    pL (list p1 p2 p3 p4)
    i 0
)
(repeat 4
    (wtxtMC (nth i txtL) (nth i pL) h)
    (setq i (1+ i))
)
)
;;;-------------------------------------------------------------------------------


;;;MAIN PROGRAM
;;;-------------------------------------------------------------------------------
(defun C:VC( / h p et p0 p00 p01 p02 ra0 pt pvL n j pv num txtL ss bn ntp)
;;;Vertex Co-ordinate

;;;GET TEXT HEIGHT
(if (not h0) (setq h0 1))
(setq h (getreal (strcat "\nChon chieu cao text <" (rtos h0) ">:")))
(if (not h) (setq h h0) (setq h0 h))

;;;GET DECIMAL PRECISION
(if (not ntp0) (setq ntp0 2))
(setq ntp (getint (strcat "\nSo chu so thap phan <" (itoa ntp0) ">:")))
(if (not ntp) (setq ntp ntp0) (setq ntp0 ntp))

;;;GET RADIUS 
(if (not ra0) (setq ra0 0.1))
(setq hr (getreal (strcat "\nChon ban kinh nut dinh ranh <" (rtos ra0) ">:")))
(if (not hr) (setq hr ra0) (setq ra0 hr))

;;;PICK & BASE POINT
(setq p (getpoint "\nPick 1 diem giua mien kin:"))
(command "boundary" p "")
(setq et (entlast))
(redraw et 3)
(setq
    p00 (getpoint "\nDiem chuan bang toa do (phia tren ben trai):")
    p0 p00
	p01 (polar p00 (* 1.5 pi) (* h 3))
    pvL (reverse (getvert et))
	n (length pvL)
	p02 (polar p01 (* 1.5 pi) (* n h 3))
    oldos (getvar "osmode")
)
(setvar "osmode" 0)

;;;HEADER
(linepx p0 (* 38 h))
(command "copy" "L" "" "m" p00 p01 p02 "")
(linepy p0 (* (+ n 1) -3 h))
(command "copy" "L" "" "m" p0 
    (list(+ (car p0) (* 4 h)) (cadr p0))
	(list(+ (car p0) (* 16 h)) (cadr p0))
    (list(+ (car p0) (* 28 h)) (cadr p0))
    (list(+ (car p0) (* 38 h)) (cadr p0))
	""
)

(txt1 (list "TT" "X (m)" "Y (m)" "S (m)"))
(setq p0 (polar p0 (* 1.5 pi) (* 3 h)))

;;;MAKE RECORDS
(setq j 0 pt nil)
(repeat n
    (setq
        pv (nth j pvL)
        num (itoa (1+ j))
	)
	(if pt (setq S (rtos (distance pt pv) 2 ntp)) (setq S ""))
    (setq txtL (list num (rtos (cadr pv) 2 ntp) (rtos (car pv) 2 ntp) S))
    (txt2 txtL)
    (setq p0 (polar p0 (* 1.5 pi) (* 3 h)))
	(setq pt pv)
    (setq j (1+ j))
	(if (= j (- n 1)) (setq j 0))
)

;;;MAKE BLOCK
(setq ss (collect1 et))
(setq bn "1")
(while (tblsearch "block" bn) (setq bn (itoa (1+ (atoi bn)))))
(command "block" bn p00 ss "")
(command "insert" bn p00 "" "" "")

;;;WRITE POINT NAME
(setq j 0)
(repeat (1- n)
    (setq
        pv (nth j pvL)
        num (itoa (1+ j))
    )
    (wtxtMC num (polar pv 0 h) h)
(command ".circle" pv hr)
    (setq j (1+ j))
)

;;;GHI CANH THUA
(ghicanh et)
(command "erase" et "")

;;;FINISH
(setvar "osmode" oldos)
(princ)
)
;;;-------------------------------------------------------------------------------



;;;PHAN BO SUNG CUA elleHCSC
;;;------------------------------------------------------------------------------------
(defun Text_canh_TCA (S p a) ;;;Entmake text S at p with angle A - Top Center
(if (/= p nil)
(entmake (list
(cons 0 "TEXT")
(cons 62 6)
(cons 10 p)
(cons 40 h)
(cons 1 S)
(cons 50 a)
(cons 41 0.7)
(cons 51 (DTR 18))
(cons 7 (getvar "textstyle"))
(cons 72 1)
(cons 11 p)
(cons 73 3)
)
)
)
)
;;;------------------------------------------------------------------------------------
(defun Text_canh_BCA (S p a) ;;;Entmake text S at p with angle A - Bottom Center
(if (/= p nil)
(entmake (list
(cons 0 "TEXT")
(cons 62 6)
(cons 10 p)
(cons 40 h)
(cons 1 S)
(cons 50 a)
(cons 41 0.7)
(cons 51 (DTR 18))
(cons 7 (getvar "textstyle"))
(cons 72 1)
(cons 11 p)
(cons 73 1)
)
)
)
)
;;;-------------------------------------------------------------------------------
(defun Ghicanh (e / i pvL k p1 p2 dist rad x_mp y_mp mp)
(setq
i 0
pvL (reverse (getvert e))
k (1- (length pvL))
)
(repeat k
(setq
p1 (nth i pvL)
p2 (nth (+ i 1) pvL)
dist (distance p1 p2)
rad (angle p1 p2)
x_mp (* (+ (car p1) (car p2)) 0.5)
y_mp (* (+ (cadr p1) (cadr p2)) 0.5)
mp (list x_mp y_mp)
)
(if (and (> rad (* 0.5 pi)) (<= rad (* 1.5 pi)))
(setq mp (polar mp (+ rad (* 0.5 pi)) (* 0.3 h) ))
)
(if (and (> rad (* 0.5 pi)) (<= rad (* 1.5 pi)))
(progn
(setq rad (+ rad pi))
(Text_canh_TCA (rtos dist 2 2) mp rad)
)
(Text_canh_BCA (rtos dist 2 2) mp rad)
)
(setq i (1+ i))
);; repeat k;
)
;;;--------------------------


<<

Filename: 408495_vc.lsp
Tác giả: hiepttr
Bài viết gốc: 408507
Tên lệnh: ddd
Nhờ Mọi Người Viết Giùm Lisp Lấy Cao Độ Trên Trắc Dọc

Lâu ngày vào lại forum, mần tới cho bạn :D

;;;lisp dien cao do TD
(defun c:ddd( / lst_va old base_pt base_text  base_h dg p p1 p2 dong lst_dong ob_dong lst_giao pt_int cont_text)
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(1 0))
(setq base_pt (getpoint "\n Chon diem chuan: "))
(mapcar 'setvar lst_va '(0 0))
(prompt "\n Chon text cao do tuong ung diem chuan <enter de nhap>: ")
(setq...
>>

Lâu ngày vào lại forum, mần tới cho bạn :D

;;;lisp dien cao do TD
(defun c:ddd( / lst_va old base_pt base_text  base_h dg p p1 p2 dong lst_dong ob_dong lst_giao pt_int cont_text)
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(1 0))
(setq base_pt (getpoint "\n Chon diem chuan: "))
(mapcar 'setvar lst_va '(0 0))
(prompt "\n Chon text cao do tuong ung diem chuan <enter de nhap>: ")
(setq base_text (ssget "+.:E:S" '((0 . "*TEXT"))))
(cond 
	((and base_text 
		(setq base_h (distof (cdr (assoc 1 (entget (ssname base_text 0))))))
		))
	(t (setq base_h (getreal "\n Nhap cao do diem chuan: ")))
)
(setq dg (car (entsel "\nPick duong can lay cao do: ")))
(setq dg (vlax-ename->vla-object dg))
;;;;==========
(mapcar 'setvar lst_va '(3 0))
(setq p (getpoint "\nChon diem dat cao do: ")
		p1 (list (- (car p) 1000) (cadr p) 0)
		p2 (list (+ (car p) 1000) (cadr p) 0)
		)
	(grvecs (list 1 p1 p2))
(prompt "\n Chon (cac) duong dong: ")
(setq dong (ssget '((0 . "LINE"))))
(setq lst_dong (vl-remove-if 'listp (mapcar 'cadr (ssnamex dong))))
(setq #tl (NGT #tl 1000 getreal "Nhap ti le dung"))
(if (and 
		base_pt
		base_h
		dg
		p
		lst_dong
		tl
		)
	(foreach elem lst_dong
		(setq ob_dong (vlax-ename->vla-object elem))
		(cond ((setq lst_giao (H:inter-group3 ob_dong dg))
			(setq pt_int (car lst_giao)
					cont_text (rtos (+ base_h (/ (* 1000 (- (cadr pt_int) (cadr base_pt))) tl)) 2 2)
				)
			  (MakeText (list (car pt_int) (cadr p)) cont_text 0.25 (/ pi 2) "MC" "Text Dim" nil 3 nil)
			)
		)
	)
	(princ "\n *** Dau vao chua dung ***")
)
(mapcar 'setvar lst_va old)
(princ)
)
;===================================|;
(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)
);end
;=================================
(defun H:inter-group3(ob1 ob2 / modul res)
(cond 
	((null (setq modul (vlax-invoke ob1 'intersectwith ob2 acExtendThisEntity))) nil)
	((= (length modul) 3) (list modul))
	(t 
		(while (> (length modul) 0)
			(setq	res (cons (list (car modul) (cadr modul) (caddr modul)) res)
					modul (cdddr modul)
			)
		)
		(reverse res)
	)
)
)
;;;;===================================================================
(defun NGT(a mac_dinh ham str_nhac / modul)
;;Nhan gia tri
(or a (setq a mac_dinh))
(setq a (cond
	((= "" (setq modul (ham (strcat "\n" str_nhac " <" (vl-princ-to-string a) ">: ")))) a)
	(modul)
	(a)
	)
	)
)

<<

Filename: 408507_ddd.lsp
Tác giả: duy782006
Bài viết gốc: 408519
Tên lệnh: vc
Nhờ Sửa Lips

Đã thêm lựa chọn pick điểm hay chọn đối tượng. Không biết lỗi chổ nào mà bảng kê và pline bị dính chùm. Mình đang cày 30/10 nên tạm gác lại đã khi nào rỗi hoặc bác nào rỗi thì xem giúp cho bạn nhé.

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/166158-nho-sua-lips/
;; free lisp from cadviet.com
;;; this lisp was downloaded from...
>>

Đã thêm lựa chọn pick điểm hay chọn đối tượng. Không biết lỗi chổ nào mà bảng kê và pline bị dính chùm. Mình đang cày 30/10 nên tạm gác lại đã khi nào rỗi hoặc bác nào rỗi thì xem giúp cho bạn nhé.

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/166158-nho-sua-lips/
;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=2265&st=60
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Chuong trinh danh so va lap bang toa do ho so thua dat dia chinh
;;;Bang toa do tao thanh block, duoc dat ten theo so thu tu 1, 2, 3...
;;;Chap nhan cac doi tuong la Region, Polyline, Line va Arc khep kin
;;;Written by ssg and elleHCSC - January 2009 - www.cadviet.com 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;WELCOME TO NEW YEAR 2009
;;;WISH ALL CADVIET MEMBERS AND FAMILY
;;;HAVE HAPPY, HEALTH AND PROSPEROUS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;




;;;PUBLIC FUNCTIONS
;;;-------------------------------------------------------------------------------
(Defun DTR(x) (/ (* x pi) 180) ) ;;;change degree to radian, return REAL
;;;-------------------------------------------------------------------------------
(defun lineP (p0 a r / p1) ;;;Line polar: point, degree angle, radius
    (setq p1 (polar p0 (dtr a) r))
    (command "line" p0 p1 "")
)
;;;-------------------------------------------------------------------------------
(defun linePX (p0 x) (lineP p0 0 x)) ;;;Horizontal line: length x, from p0
;;;-------------------------------------------------------------------------------
(defun linePY (p0 y) (lineP p0 90 y)) ;;;Vertical line: length y, from p0
;;;-------------------------------------------------------------------------------
(defun getVert (e / i L) ;;;Return list of all vertex from pline e
(setq i 0 L nil)
(vl-load-com)
(repeat (fix (+ (vlax-curve-getEndParam e) 1))
    (setq L (append L (list (vlax-curve-getPointAtParam e i))))
    (setq i (1+ i))
)
L
)
;;;-------------------------------------------------------------------------------
(defun wtxtMC (txt p h) ;;;Write text Middle Center, specify text, point, height
(entmake (list (cons 0  "TEXT") (cons 7 (getvar "textstyle"))
    (cons 1 txt) (cons 10 p) (cons 11 p) (cons 40 h) (cons 72 1) (cons 73  2)))
)
;;;-------------------------------------------------------------------------------
(defun Collect(e / e2 SS) ;;;Selection set from e to entlast
(setq SS (ssadd))
(ssadd e SS)
(while (setq e2 (entnext e)) (ssadd e2 SS) (setq e e2))
SS
)
;;;-------------------------------------------------------------------------------
(defun Collect1(e / ss)
;;;Selection set after e to entlast. If e nil, select all from fist entity of drawing.
(if (= e nil) (setq ss (collect (entnext)))
	(progn (setq ss (collect e)) (ssdel e ss))
)
)
;;;-------------------------------------------------------------------------------

;;;PRIVATE FUNCTIONS
;;;-------------------------------------------------------------------------------
(defun txt1(txtL / p1 p2 p3 p4 pL i) ;;;Write texts in 1 row
(setq
    p1 (list (+ (car p0) (* 2 h)) (- (cadr p0) (* 1.5 h)))
    p2 (polar p1 0 (* 8 h))
    p3 (polar p2 0 (* 12 h))
    p4 (polar p3 0 (* 10 h))
    pL (list p1 p2 p3 p4)
    i 0
)
(repeat 4
    (wtxtMC (nth i txtL) (nth i pL) h)
    (setq i (1+ i))
)
)
;;;-------------------------------------------------------------------------------
(defun txt2(txtL / p1 p2 p3 p4 pL i) ;;;Write texts in 1 row
(setq
    p1 (list (+ (car p0) (* 2 h)) (- (cadr p0) (* 1.5 h)))
    p2 (polar p1 0 (* 8 h))
    p3 (polar p2 0 (* 12 h))
    p4 (polar p3 0 (* 10 h))
	p4 (polar p4 (* 0.5 pi) (* 1.5 h))
    pL (list p1 p2 p3 p4)
    i 0
)
(repeat 4
    (wtxtMC (nth i txtL) (nth i pL) h)
    (setq i (1+ i))
)
)
;;;-------------------------------------------------------------------------------


;;;MAIN PROGRAM
;;;-------------------------------------------------------------------------------
(defun C:VC( / h p et p0 p00 p01 p02 ra0 pt pvL n j pv num txtL ss bn ntp)
;;;Vertex Co-ordinate

;;;GET TEXT HEIGHT
(if (not h0) (setq h0 1))
(setq h (getreal (strcat "\nChon chieu cao text <" (rtos h0) ">:")))
(if (not h) (setq h h0) (setq h0 h))

;;;GET DECIMAL PRECISION
(if (not ntp0) (setq ntp0 2))
(setq ntp (getint (strcat "\nSo chu so thap phan <" (itoa ntp0) ">:")))
(if (not ntp) (setq ntp ntp0) (setq ntp0 ntp))

;;;GET RADIUS 
(if (not ra0) (setq ra0 0.1))
(setq hr (getreal (strcat "\nChon ban kinh nut dinh ranh <" (rtos ra0) ">:")))
(if (not hr) (setq hr ra0) (setq ra0 hr))






;;;PICK & BASE POINT


  (initget 1 "P S ")
  (setq ob (getkword "\nChon khu dat bang cach [Pick diem trong mien/ Select pline]: "))
  (cond
    ((= ob "P")
(setq p (getpoint "\nPick 1 diem giua mien kin:"))
(command "boundary" p "")
(setq et (entlast))
     )
    ((= ob "S")
(setq et (car (duy:c_dtuong<mtvdt "LWPOLYLINE" "can thong ke")))
(command ".copy" et "" "_non" (list 0 0) "_non" (list 0 0) "")
     )
    )


(redraw et 3)
(setq
    p00 (getpoint "\nDiem chuan bang toa do (phia tren ben trai):")
    p0 p00
	p01 (polar p00 (* 1.5 pi) (* h 3))
    pvL (reverse (getvert et))
	n (length pvL)
	p02 (polar p01 (* 1.5 pi) (* n h 3))
    oldos (getvar "osmode")
)
(setvar "osmode" 0)

;;;HEADER
(linepx p0 (* 38 h))
(command "copy" "L" "" "m" p00 p01 p02 "")
(linepy p0 (* (+ n 1) -3 h))
(command "copy" "L" "" "m" p0 
    (list(+ (car p0) (* 4 h)) (cadr p0))
	(list(+ (car p0) (* 16 h)) (cadr p0))
    (list(+ (car p0) (* 28 h)) (cadr p0))
    (list(+ (car p0) (* 38 h)) (cadr p0))
	""
)

(txt1 (list "TT" "X (m)" "Y (m)" "S (m)"))
(setq p0 (polar p0 (* 1.5 pi) (* 3 h)))

;;;MAKE RECORDS
(setq j 0 pt nil)
(repeat n
    (setq
        pv (nth j pvL)
        num (itoa (1+ j))
	)
	(if pt (setq S (rtos (distance pt pv) 2 ntp)) (setq S ""))
    (setq txtL (list num (rtos (cadr pv) 2 ntp) (rtos (car pv) 2 ntp) S))
    (txt2 txtL)
    (setq p0 (polar p0 (* 1.5 pi) (* 3 h)))
	(setq pt pv)
    (setq j (1+ j))
	(if (= j (- n 1)) (setq j 0))
)

;;;MAKE BLOCK
(setq ss (collect1 et))
(setq bn "1")
(while (tblsearch "block" bn) (setq bn (itoa (1+ (atoi bn)))))
(command "block" bn p00 ss "")
(command "insert" bn p00 "" "" "")

;;;WRITE POINT NAME
(setq j 0)
(repeat (1- n)
    (setq
        pv (nth j pvL)
        num (itoa (1+ j))
    )
    (wtxtMC num (polar pv 0 h) h)
(command ".circle" pv hr)
    (setq j (1+ j))
)

;;;GHI CANH THUA
(ghicanh et)
(command "erase" et "")

;;;FINISH
(setvar "osmode" oldos)
(princ)
)
;;;-------------------------------------------------------------------------------



;;;PHAN BO SUNG CUA elleHCSC
;;;------------------------------------------------------------------------------------
(defun Text_canh_TCA (S p a) ;;;Entmake text S at p with angle A - Top Center
(if (/= p nil)
(entmake (list
(cons 0 "TEXT")
(cons 62 6)
(cons 10 p)
(cons 40 h)
(cons 1 S)
(cons 50 a)
(cons 41 0.7)
(cons 51 (DTR 18))
(cons 7 (getvar "textstyle"))
(cons 72 1)
(cons 11 p)
(cons 73 3)
)
)
)
)
;;;------------------------------------------------------------------------------------
(defun Text_canh_BCA (S p a) ;;;Entmake text S at p with angle A - Bottom Center
(if (/= p nil)
(entmake (list
(cons 0 "TEXT")
(cons 62 6)
(cons 10 p)
(cons 40 h)
(cons 1 S)
(cons 50 a)
(cons 41 0.7)
(cons 51 (DTR 18))
(cons 7 (getvar "textstyle"))
(cons 72 1)
(cons 11 p)
(cons 73 1)
)
)
)
)
;;;-------------------------------------------------------------------------------
(defun Ghicanh (e / i pvL k p1 p2 dist rad x_mp y_mp mp)
(setq
i 0
pvL (reverse (getvert e))
k (1- (length pvL))
)
(repeat k
(setq
p1 (nth i pvL)
p2 (nth (+ i 1) pvL)
dist (distance p1 p2)
rad (angle p1 p2)
x_mp (* (+ (car p1) (car p2)) 0.5)
y_mp (* (+ (cadr p1) (cadr p2)) 0.5)
mp (list x_mp y_mp)
)
(if (and (> rad (* 0.5 pi)) (<= rad (* 1.5 pi)))
(setq mp (polar mp (+ rad (* 0.5 pi)) (* 0.3 h) ))
)
(if (and (> rad (* 0.5 pi)) (<= rad (* 1.5 pi)))
(progn
(setq rad (+ rad pi))
(Text_canh_TCA (rtos dist 2 2) mp rad)
)
(Text_canh_BCA (rtos dist 2 2) mp rad)
)
(setq i (1+ i))
);; repeat k;
)
;;;--------------------------

;duy82006 them phan chon pline
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Chon mot doi tuong theo kieu
;;;Cu phap su dung (duy:c_dtuong<mtvdt kieu mdich)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(Defun duy:c_dtuong<mtvdt (kieu mdich / kieu mdich dchon)
(princ (strcat "\nChon " kieu mdich " !"))
(setq dchon (entsel))
(while
(or
(null (car dchon))
(and (/= kieu (cdr (assoc 0 (entget (car dchon)))))
)
)
(princ (strcat "\nChon doi tuong khong thanh cong. Chon doi tuong " kieu mdich " !"))
(setq dchon (entsel))
)
dchon)



<<

Filename: 408519_vc.lsp
Tác giả: Bee
Bài viết gốc: 408515
Tên lệnh: test
Giúp Đỡ [Lisp] Tự Động Vẽ Đầu Mũi Khoan

Chào tất cả anh em trong diễn đàn

mình có một bài toán mong các anh em giúp đỡ

yêu cầu bài toán:

1. có một đoạn thẳng mình muốn tạo ra một tam giác cân góc 60 độ chỉ với 2 click . 

      click 1: chọn đường thẳng

      click 2 : chon miền đặt điểm...

>>

Chào tất cả anh em trong diễn đàn

mình có một bài toán mong các anh em giúp đỡ

yêu cầu bài toán:

1. có một đoạn thẳng mình muốn tạo ra một tam giác cân góc 60 độ chỉ với 2 click . 

      click 1: chọn đường thẳng

      click 2 : chon miền đặt điểm đỉnh của tam giác

2. tự động tạo ra lỗ khoan bằng cách nhập tọa độ 2 điểm trên màn hinh mà khoảng cách giữa hai điểm đó chính là chiều sâu của mũi khoan sau đó chương chình yêu cầu nhập đường kính mũi khoan

......

mình muốn 2 bài toán trên gộp thành một chương trình với 2 lựa chọn

mình đã upload hình ảnh mô tả bài toán ở dưới. rất mong các anh em giúp đỡ.

 

https://drive.google.com/file/d/0Byp-qz2acPIgcF9fV2FPZDc3VUk/view?usp=sharing

Mềnh chả biết mũi khoan là gì nhưng thấy bài toàn giải hay hay nên nghịch chơi. Thử lisp này nhé. ^_^

;;;Found Internet
(defun Point_per (P1 P2 P3 / X1 X2 X3 Y1 Y2 Y3 Z1 Z2 Z3 T4)
  (setq	X1 (car P1)
	X2 (car P2)
	X3 (car P3)
	Y1 (cadr P1)
	Y2 (cadr P2)
	Y3 (cadr P3)
	Z1 (caddr P1)
	Z2 (caddr P2)
	Z3 (caddr P3)
	T4 (/ (+ (* (- X2 X1) (- X3 X1))
		 (* (- Y2 Y1) (- Y3 Y1))
		 (* (- Z2 Z1) (- Z3 Z1))
	      )
	      (+ (* (- X2 X1) (- X2 X1))
		 (* (- Y2 Y1) (- Y2 Y1))
		 (* (- Z2 Z1) (- Z2 Z1))
	      )
	   )
  )
  (list	(+ X1 (* T4 (- X2 X1)))
	(+ Y1 (* T4 (- Y2 Y1)))
	(+ Z1 (* T4 (- Z2 Z1)))
  )
)
;;;My funtions
(defun ve_mui_khoan ( / a p10 p11 pt pt1 pt2 pt_0)
  (setq a (car (entsel "\nChon doan thang: ")))
  (if a
    (progn
      (setq p10 (cdr (assoc 10 (entget a))))
      (setq p11 (cdr (assoc 11 (entget a))))
      (setq pt (polar p10 (angle p10 p11) (/ (distance p10 p11) 2)))
      (setq pt1 (getpoint "\nChon diem bat ky: "))
      (setq pt2 (Point_per p10 p11 pt1))
      (setq pt_0 (polar	pt
			(angle pt2 pt1)
			(/ (* (distance p10 p11) (sqrt 3)) 6)
		 )
      )
      (command "_polygon" "3" "_none" pt_0 "I" p10)
    )
  )
)
(defun ve_lo_khoan (/ p1 p2 d p3 p4 p5 p6 p7 ang)
  (setq p1 (getpoint "\nChon diem 1: "))
  (setq p2 (getpoint p1 "\nChon diem 2: "))
  (setq d (getreal "\nChon duong kinh: "))
  (setq p3 (polar p1 (+ (setq ang (angle p1 p2)) (* pi 0.5)) (/ d 2))
	p4 (polar p3 (+ ang (* pi 1.5)) d)
	p5 (polar p4 ang (distance p1 p2))
	p6 (polar p5 (+ ang (* pi 0.5)) d)
	p7 (polar p2 (angle p1 p2) (/ (* d (sqrt 3)) 6))
	)
  (command "line" "_non" p3 "_non" p4 "_non" p5 "_non" p6 "_non" p3 ""
	   "line" "_non" p6 "_non" p7 "_non" p5 "")
  )
(defun c:test ()
  (initget 1 "M L ")
  (setq ob (getkword "\nChon ve mui khoan hoac ve lo khoan [Mui/Lo]: "))
  (cond
    ((= ob "M")
     (ve_mui_khoan)
     )
    ((= ob "L")
     (ve_lo_khoan)
     )
    );#cond
  (princ)
  )

Lệnh test nhé.


<<

Filename: 408515_test.lsp
Tác giả: thanhduan2407
Bài viết gốc: 386669
Tên lệnh: 90
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

Các bác cho em hỏi chút!

Em muốn rời text một đoạn theo hướng vuông góc với Polyline nhưng cứ bị mắc lỗi mà em không biết lỗi ở đâu?

Mong các bác chỉ giáo giúp em với ạ. Cảm ơn các bác nhiều!

Các bác cho em hỏi chút!

Em muốn rời text một đoạn theo hướng vuông góc với Polyline nhưng cứ bị mắc lỗi mà em không biết lỗi ở đâu?

Mong các bác chỉ giáo giúp em với ạ. Cảm ơn các bác nhiều!

http://www.cadviet.com/upfiles/5/36665_test.dwg

(defun C:90 (/	       ACDOC	 ANG2	   CAODO     LTSTEXT
	     MSP       OBJNEWTUYEN	   PNTNEW    PNT_MOVE
	     PNT_T     PNT_T_VG	 SS	   SSOBJ     VLAOBJ
	    )
  (setvar "CMDECHO" 0)
  (defun *error* (msg)
    (if	Olmode
      (setvar 'osmode Olmode)
    )
    (if	(not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
      (princ (strcat "\nError: " msg))
    )
    (princ)
  )
  (setq Olmode (getvar "OSMODE"))
  (setq	ssObj
	 (ssget "_:E:S:L" (list '(0 . "*POLYLINE,LWPOLYLINE")))
  )
  (setq ObjNewTuyen (ssname ssObj 0))
  (setq VlaObj (vlax-ename->vla-object ObjNewTuyen))
  (setvar "OSMODE" 0)
  (Alert "Quet chon Text")
  (setq ss (ssget (list (cons 0 "TEXT"))))
  (setq LtsText (LM:ss->ent ss))
  
 
  (foreach e LtsText
    (setq Pnt_T (TD:Text-Base e))
    (setq Caodo (atof (cdr (assoc 1 (entget e)))))
    (progn
      (setq Pnt_T_VG
	     (vlax-curve-getClosestPointTo
	       ObjNewTuyen
	       Pnt_T
	     )
      )
      (setq
	ang2
	 (angle	'(0 0)
		(Vlax-curve-getfirstderiv
		  ObjNewTuyen
		  (vlax-curve-getParamAtPoint ObjNewTuyen Pnt_T_VG)
		)
	 )
      )

      (setq PntNew (polar Pnt_T (+ ang2 (/ pi 2)) 10.0))
      (setq Pnt_Move (list (car PntNew) (cadr PntNew) Caodo))
      (vla-move	(vlax-ename->vla-object e)
		(vlax-3d-point Pnt_T)
		(vlax-3d-point Pnt_Move)
      )
      
    )
  )
  (setvar "OSMODE" olmode)
  (princ)
)


(defun LM:ss->ent (ss / i l)
  (if ss
    (repeat (setq i (sslength ss))
      (setq l (cons (ssname ss (setq i (1- i))) l))
    )
  )
)
(defun TachXY (Pnt /)
  (setq Pt (list (car Pnt) (cadr Pnt)))
  pt
)

(defun TD:Text-Base (ent / MA71 MA72 X11)
  (setq Ma10 (cdr (assoc 10 (entget ent))))
  (setq Ma11 (cdr (assoc 11 (entget ent))))
  (setq X11 (car Ma11))
  (setq Ma71 (cdr (assoc 71 (entget ent))))
  (setq Ma72 (cdr (assoc 72 (entget ent))))
  (if (or (and (= Ma71 0) (= Ma72 0) (= X11 0))
	  (and (= Ma71 0) (= Ma72 3))
	  (and (= Ma71 0) (= Ma72 5))
      )
    Ma10
    Ma11
  )
)


<<

Filename: 386669_90.lsp
Tác giả: ketxu
Bài viết gốc: 408597
Tên lệnh: qb
Tạo Block Siêu Nhanh

- : lệnh ở phiên bản không hộp thoại
_ : lệnh ở phiên bản tiếng Anh

Nếu bạn cần code thì quick code đây :

(defun c:QB (/ ss n p)
	(while (and (setq n (getstring T "\Block name :"))(tblsearch "BLOCK" n)))
	(setq ss (ssget "_:L"))
	(setq p (getpoint "\n Specify insertion point :"))
	(vl-cmdf "_.-Block" n "_non" p ss "")
	(vl-cmdf "_.-insert" n "non" p "" "" "")
	(princ)
)

Filename: 408597_qb.lsp
Tác giả: ryback
Bài viết gốc: 408581
Tên lệnh: xtl
Nhờ Vả Sửa Lisp, Thêm Tùy Chọn Cài Đặt Các Thông Số!

Xin chào anh em chú bác trên diễn đàn, giờ mình có vấn đề này đang cần ạ.

Chả là mình có cái lisp vẽ taluy khá là ưng ý của 1 bạn nào đó trên diễn đàn rồi, nhưng giờ mình có 1 yêu cầu nho nhỏ như thế này. Đó là các đường ta luy này có các thông số như chiều dài các đường, khoảng cách các đường, số đường ngắn/số đường dài, ... Nhưng mình đặt cố định trong lisp rồi,...

>>

Xin chào anh em chú bác trên diễn đàn, giờ mình có vấn đề này đang cần ạ.

Chả là mình có cái lisp vẽ taluy khá là ưng ý của 1 bạn nào đó trên diễn đàn rồi, nhưng giờ mình có 1 yêu cầu nho nhỏ như thế này. Đó là các đường ta luy này có các thông số như chiều dài các đường, khoảng cách các đường, số đường ngắn/số đường dài, ... Nhưng mình đặt cố định trong lisp rồi, nên muốn sửa thì phải sửa trong file lsp, cũng có một chút bất tiện. Giờ mình muốn thêm một lệnh cài đặt các thông số này, xong sau đó khi thực hiện lệnh vẽ taluy thì sẽ dùng các thông số đó để vẽ, nếu muốn thay đổi thì thực hiện lại lệnh cài đặt trên.

Mong các cao nhân trên diễn đàn giúp đỡ mình một chút ạ, hehe!

(defun c:xtl (/)
  (setvar "CMDECHO" 0)
  (setq osmode (getvar "osmode"))
  (setvar "osmode" 0)
  (setvar "unitmode" 0)
  (setvar "dimzin" 0)
  (setvar "blipmode" 0)
  (setvar "aunits" 0)
  (setvar "angbase" (/ pi 2))
  (setvar "angdir" 1)
  (setq layerp (getvar "clayer"))
  (command "-color" "Bylayer")
  (if (not (tblsearch "layer" "BATTER"))
    (command "-layer" "n" "BATTER" "color" "8" "BATTER" "s" "BATTER" \n)
    (command "-layer" "s" "BATTER" \n)
  )

  (if (not lint)
    (setq lint 10.0)
  )
  ;(setq    int (getdist (strcat "\nNhap khoang cach chia taluy <"
                 ;(rtos lint 2 3)
                 ;">: "
             
        
  
  ;(if int
    ;(setq lint int)
    ;(setq int lint)
  
;(neu muon nhap bang tay khoang cach giua cac duong thi kich hoat cac dong lenh o tren)
  (command "line" (list 0.0 0.0) (list 0.0 0.0001) "")
  (if (tblsearch "block" "tadtick")
    (command "block" "tadtick" "y" (list 0.0 0.0) (entlast) "")
    (command "block" "tadtick" (list 0.0 0.0) (entlast) "")
  )
  (while (setq refent (entsel "\nChon doi tuong can rai taluy : "))
    (command "undo" "group")
    (redraw (car refent) 3)
    (initget 1 "daO daP")
    (setq
      reply (getkword "\nChon kieu taluy Nen Da[O] hay Nen Da[P]: ")
    )
    (print "\n")
    (print "Chon cac doi tuong can batter :")
    (setq s (ssget))
    (command "measure" refent "b" "tadtick" "y" 1) ;so cuoi la khoang cach giua cac duong (neu muon nhap bang tay thi thay = int, va kich hoat cac dong lenh o tren)
    (setq p  (ssget "p")
      cn 0
    )
    (if    s
      (progn
    (while (< cn (sslength p))
(setq en (entget (ssname p cn))
p0 (cdr (assoc 10 en))
pt1 p0
pt2 nil
b (cdr (assoc 50 en))
)
(entdel (ssname p cn))
(setq p1 (polar p0 (+ (/ pi 2) b ) 0.0001))
      (command "line" p0 p1 "")
      (command "extend" s "" (list (entlast) p1) "")
      (setq xent (entget (entlast)))
      (setq    xdist
         (distance (cdr (assoc 10 xent)) (cdr (assoc 11 xent)))
      )
      (if (not (equal xdist 0.0001 0.0001))
        (setq pt2 (cdr (assoc 11 xent)))
        (progn
          (command "extend" s "" (list (entlast) p0) "")
          (setq xent (entget (entlast)))
          (setq xdist (distance (cdr (assoc 10 xent))
                    (cdr (assoc 11 xent))
              )
          )
          (if (not (equal xdist 0.0001 0.0001))
        (setq pt2 (cdr (assoc 10 xent)))
          )
        )
      )
      (entdel (entlast))
      (if pt2
        (if    (= reply "daP")
          (if (= (rem cn 2) 0) ;(so sau chu cn - 1) la so duong ngan
        ;(command "line" pt1 pt2 "")
        (command
          "line"
          pt1
          (polar pt1 (angle pt1 pt2) (/ (distance pt1 pt2) 1.25)) ;so cuoi la ty le giua duong duong dai va full (1/n)
          ""
        )
        (command
          "line"
          pt1
          (polar pt1 (angle pt1 pt2) (/ (distance pt1 pt2) 2.5)) ;so cuoi la ty le giua duong ngan va full (1/n)
          ""
        )
          )
          (if (= (rem cn 2) 0) ;(so sau chu cn - 1) la so duong ngan
        ;(command "line" pt2 pt1 "")
        (command
          "line"
          pt2
          (polar pt2 (angle pt2 pt1) (/ (distance pt2 pt1) 1.25)) ;so cuoi la ty le giua duong dai va full (1/n)
          ""
        )
        (command
          "line"
          pt2
          (polar pt2 (angle pt2 pt1) (/ (distance pt2 pt1) 2.5)) ;so cuoi la ty le giua duong ngan va full (1/n)
          ""
        )
          )
        )
      )
      (setq cn (1+ cn))
    )
      )
    )
    (command "undo" "en")
  )
  (setvar "blipmode" 0)
  (setvar "osmode" osmode)
  (setvar "clayer" layerp)    
  (princ)
)

<<

Filename: 408581_xtl.lsp
Tác giả: Bee
Bài viết gốc: 408614
Tên lệnh: test
Nhờ Viết Lisp Tính Khối Lượng Khuôn

https://drive.google.com/file/d/0B-gIuhLk2Nw1OEI4U0NPLXdVRmM/view?usp=sharing

 

Xin chào anh em trên diễn đàn

Mình muốn nhờ anh em viết cho một lisp tính khối lượng khuôn. Yêu cầu cụ thể mình có ghi trong file ảnh...

>>

https://drive.google.com/file/d/0B-gIuhLk2Nw1OEI4U0NPLXdVRmM/view?usp=sharing

 

Xin chào anh em trên diễn đàn

Mình muốn nhờ anh em viết cho một lisp tính khối lượng khuôn. Yêu cầu cụ thể mình có ghi trong file ảnh đính kèm.

Mong anh em giúp đỡ.

Thanks

Thử lisp này nhé.

(defun c:test (/ pt d obj area m)
  (if (setq pt (getpoint "\nChon point bat ky: "))
    (progn
      (setq d nil)
      (while (not (setq d (getreal "\nChon chieu dai khuon: "))))
      (command "-hatch" pt "")
      (setq obj (vlax-ename->vla-object (entlast)))
      (setq area (vlax-get Obj "Area"))
      (setq m (rtos (/ (* (* area d) 7.86) 1000000.) 2 2))
      (vla-AddText
	(vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))
	m
	(vlax-3d-point pt)
	(getvar 'textsize)
	)
      (vla-delete obj)
      )
    (princ "\nBan da khong chon diem bat ky.")
    )
  (princ)
  )


<<

Filename: 408614_test.lsp
Tác giả: ductrunggtvt
Bài viết gốc: 408704
Tên lệnh: tg
Nhờ Sửa Lisp Tính Tổng Chiều Dài Đối Tượng

Hiện tại mình đang có lisp tính tổng chiều dài đối tượng line, Pline, tính xong thay thế giá trị vào 1 dtext đã có.

Bây giờ mình muốn tính chiều dài xong CỘNG và THAY THẾ vào dtext đã có. nhờ mọi người giúp đỡ

;----------------------------TG-tinh tong chieu dai doi tuong----------------------------------
(defun C:tg (/ tot_len ss e_name e_record e_type)
(princ "\nCADViet.com (c) 2007")
(setq tot_len...

>>

Hiện tại mình đang có lisp tính tổng chiều dài đối tượng line, Pline, tính xong thay thế giá trị vào 1 dtext đã có.

Bây giờ mình muốn tính chiều dài xong CỘNG và THAY THẾ vào dtext đã có. nhờ mọi người giúp đỡ

;----------------------------TG-tinh tong chieu dai doi tuong----------------------------------
(defun C:tg (/ tot_len ss e_name e_record e_type)
(princ "\nCADViet.com (c) 2007")
(setq tot_len 0.0)
(setq ss (ssget))
(if (null ss)
(exit))
(while (> (sslength ss) 0)
(setq e_name (ssname ss 0))
(setq e_record (entget e_name))
(setq e_type (cdr (assoc '0 e_record)))
(cond ((wcmatch e_type "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")
(command "lengthen" e_name "")
(setq tot_len (+ tot_len (getvar "PERIMETER")))
(ssdel e_name ss)
)
((wcmatch e_type "MLINE") (add_mline))
(e_type (ssdel e_name ss))
)
)
(prompt (strcat "\nTotal length is: " (rtos tot_len 2 2)))
(setq tt (rtos tot_len 2 2))
(setq en (car (entsel "\nChon text thay so : ")))
(setq elst (entget en))
(setq elst (subst (cons 1 tt) (assoc 1 elst) elst))
;(setq elst (subst (cons 1 (strcat "L= " tt)) (assoc 1 elst) elst))
(setq elst (append elst '((62 . 4))));7 trang
(prin1 elst)
(entmod elst)
(princ)
)
(princ "\ntg - free lisp from www.cadviet.com")
(princ)
;


<<

Filename: 408704_tg.lsp
Tác giả: hainguyen2014
Bài viết gốc: 408721
Tên lệnh: tg
Nhờ Sửa Lisp Tính Tổng Chiều Dài Đối Tượng

Đã sửa lại theo yêu cầu của bạn! Chúc vui vẻ!

 

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/166250-nho-sua-lisp-tinh-tong-chieu-dai-doi-tuong/
;----------------------------TG-tinh tong chieu dai doi tuong----------------------------------

(defun C:tg (/ tot_len ss e_name e_record e_type)

(princ "\nCADViet.com (c) 2007")

(setq tot_len 0.0)

(setq ss...

>>

Đã sửa lại theo yêu cầu của bạn! Chúc vui vẻ!

 

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/166250-nho-sua-lisp-tinh-tong-chieu-dai-doi-tuong/
;----------------------------TG-tinh tong chieu dai doi tuong----------------------------------

(defun C:tg (/ tot_len ss e_name e_record e_type)

(princ "\nCADViet.com (c) 2007")

(setq tot_len 0.0)

(setq ss (ssget))

(if (null ss)

(exit))

(while (> (sslength ss) 0)

(setq e_name (ssname ss 0))

(setq e_record (entget e_name))

(setq e_type (cdr (assoc '0 e_record)))

(cond ((wcmatch e_type "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")

(command "lengthen" e_name "")

(setq tot_len (+ tot_len (getvar "PERIMETER")))

(ssdel e_name ss)

)

((wcmatch e_type "MLINE") (add_mline))

(e_type (ssdel e_name ss))

)

)

(prompt (strcat "\nTotal length is: " (rtos tot_len 2 2)))

(setq en (car (entsel "\nChon text thay so : ")))

(setq elst (entget en))

(setq gt (atof (cdr (assoc 1 elst))))

(setq tot_len (+ tot_len gt))

(setq tt (rtos tot_len 2 2))

(setq elst (subst (cons 1 tt) (assoc 1 elst) elst))

;(setq elst (subst (cons 1 (strcat "L= " tt)) (assoc 1 elst) elst))

(setq elst (append elst '((62 . 4))));7 trang

(prin1 elst)

(entmod elst)

(princ)

)

(princ "\ntg - free lisp from www.cadviet.com")

(princ)

;


<<

Filename: 408721_tg.lsp
Tác giả: Bee
Bài viết gốc: 408769
Tên lệnh: hehehe
Nhờ Tư Vấn Lisp Chuyển Polyline Sang Arc

Cảm ơn bác đã trả lời. 

 

Vậy thì đen thật bác ạ. :ph34r:

 

Em có thể phá các pline đó sau đó lấy các tập hợp điểm trùng nhau, dựa vào các tập hợp điểm đó vẽ các đoạn acr ngắn được không bác.

Mong được bác tư vấn tiếp :)

 

Cảm ơn Bee rất...

>>

Cảm ơn bác đã trả lời. 

 

Vậy thì đen thật bác ạ. :ph34r:

 

Em có thể phá các pline đó sau đó lấy các tập hợp điểm trùng nhau, dựa vào các tập hợp điểm đó vẽ các đoạn acr ngắn được không bác.

Mong được bác tư vấn tiếp :)

 

Cảm ơn Bee rất nhiều.

Explode pline thì không cần. Code này của 1 đồng chí Russia :D

Thử nghịch xem nhé. Chuyển các segment là line thành arc segment. Nhớ di chuột ít thôi nhé ^_^

(defun c:hehehe ( / massoclst nthmassocsubst v^v unit _ilp doc lw enx gr enxb p1 p2 p3 b i n )

  (vl-load-com)

  (defun massoclst ( key lst )
    (if (assoc key lst) (cons (assoc key lst) (massoclst key (cdr (member (assoc key lst) lst)))))
  )

  (defun nthmassocsubst ( n key value lst / k slst p j plst m tst pslst )
    (setq k (length (setq slst (member (assoc key lst) lst))))
    (setq p (- (length lst) k))
    (setq j -1)
    (repeat p
      (setq plst (cons (nth (setq j (1+ j)) lst) plst))
    )
    (setq plst (reverse plst))
    (setq j -1)
    (setq m -1)
    (repeat k
      (setq j (1+ j))
      (if (equal (assoc key (member (nth j slst) slst)) (nth j slst) 1e-6)
        (setq m (1+ m))
      )
      (if (and (not tst) (= n m))
        (setq pslst (cons (cons key value) pslst) tst t)
        (setq pslst (cons (nth j slst) pslst))
      )
    )
    (setq pslst (reverse pslst))
    (append plst pslst)
  )

  (defun v^v ( u v )
    (mapcar '(lambda ( s1 s2 a b ) (+ ((eval s1) (* (nth a u) (nth b v))) ((eval s2) (* (nth a v) (nth b u))))) '(+ - +) '(- + -) '(1 0 0) '(2 2 1))
  )

  (defun unit ( v )
    (mapcar '(lambda ( x ) (/ x (distance '(0.0 0.0 0.0) v))) v)
  )

  (defun _ilp ( p1 p2 o nor / p1p p2p op tp pp p )
    (if (not (equal (v^v nor (unit (mapcar '- p2 p1))) '(0.0 0.0 0.0) 1e-7))
      (progn
        (setq p1p (trans p1 0 (v^v nor (unit (mapcar '- p2 p1))))
              p2p (trans p2 0 (v^v nor (unit (mapcar '- p2 p1))))
              op  (trans o 0 (v^v nor (unit (mapcar '- p2 p1))))
              op  (list (car op) (cadr op) (caddr p1p))
              tp  (polar op (+ (* 0.5 pi) (angle '(0.0 0.0 0.0) (trans nor 0 (v^v nor (unit (mapcar '- p2 p1)))))) 1.0)
        )
        (if (inters p1p p2p op tp nil)
          (progn
            (setq p (trans (inters p1p p2p op tp nil) (v^v nor (unit (mapcar '- p2 p1))) 0))
            p
          )
          nil
        )
      )
      (progn
        (setq pp (list (car (trans p1 0 nor)) (cadr (trans p1 0 nor)) (caddr (trans o 0 nor))))
        (setq p (trans pp nor 0))
        p
      )
    )
  )

  (or doc (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))))
  (vla-startundomark doc)
  (if (and (setq lw (entsel "\nPick LWPOLYLINE..."))
          (= (cdr (assoc 0 (setq enx (entget (car lw))))) "LWPOLYLINE")
      )
    (progn
      (setq i (fix (vlax-curve-getParamAtPoint
                  (car lw)
                  (vlax-curve-getClosestPointToProjection (car lw) (trans (cadr lw) 1 0) '(0.0 0.0 1.0))
                  ) ;_  vlax-curve-getParamAtPoint
              ) ;_  fix
           p1 (vlax-curve-getPointAtParam (car lw) i)
           p3 (vlax-curve-getPointAtParam (car lw) (1+ i))
           lw (car lw)
      )
      (setq enxb (massoclst 42 enx))
      (while (= 5 (car (setq gr (grread t))))
        (setq p2 (_ilp (trans (cadr gr) 1 0) (mapcar '+ (trans (cadr gr) 1 0) '(0.0 0.0 1.0)) p1 (cdr (assoc 210 (entget lw)))))
        (setq b ((lambda (a) (/ (sin a) (cos a)))
                (/ (- (angle (trans p2 0 lw) (trans p3 0 lw)) (angle (trans p1 0 lw) (trans p2 0 lw))) 2.0)
               )
        )
        (setq n -1)
        (foreach dxf42 enxb
          (setq n (1+ n))
          (if (= n i)
            (setq enx (nthmassocsubst n 42 b enx))
            (setq enx (nthmassocsubst n 42 (+ (cdr dxf42) b) enx))
          )
        )
        (entupd (cdr (assoc -1 (entmod enx))))
      )
    )
    (prompt "\n Nothing selected or picked object not a LWPOLYLINE ")
  )
  (vla-endundomark doc)
  (princ)
)

<<

Filename: 408769_hehehe.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 408803
Tên lệnh: msw
Nhờ Các Cao Thủ Sửa Lisp Giúp
Bạn thử cái này xem:
(defun c:msw (/ ob)
(initget 1 "16 20 24 30 MSWC(16) MSWC(20) MSWC(24) MSWC(30)")
(setq ob (getkword "\nChon loai : "))
(cond ((wcmatch ob "*16*") (screw_plug_16))
((wcmatch ob "*20*") (screw_plug_20))
((wcmatch ob "*24*") (screw_plug_24))
((wcmatch ob "*30*") (screw_plug_30)))
(princ))

Filename: 408803_msw.lsp
Tác giả: Bee
Bài viết gốc: 408874
Tên lệnh: test
Nhờ Viết Lisp Cộng Các Số Trong Text (Hoặc Mtext) Và Output Sang Một Mtext Khác

Nhờ các cao thủ viết giúp mình lisp như tựa đề.

Ví dụ cụ thể:

Trên bản vẽ có sẵn 2 hoặc nhiều text (hoặc mtext), chẳng hạn 2(text), 3(mtext) và 4(text).

Mình gõ lệnh (ví dụ "cộng"), click chọn vào 2, 3, và 4, sẽ được kết quả là 9, và output ra 1 mtext. Mình sẽ click chọn vị trí để output...

>>

Nhờ các cao thủ viết giúp mình lisp như tựa đề.

Ví dụ cụ thể:

Trên bản vẽ có sẵn 2 hoặc nhiều text (hoặc mtext), chẳng hạn 2(text), 3(mtext) và 4(text).

Mình gõ lệnh (ví dụ "cộng"), click chọn vào 2, 3, và 4, sẽ được kết quả là 9, và output ra 1 mtext. Mình sẽ click chọn vị trí để output mtext này trên bản vẽ.

Cảm ơn nhiều! :D

Test thử tí. ^_^

(defun c:test  ()
  (if (not (setq ss (ssget '((0 . "*TEXT")))))
    (princ "\nBan da khong chon TEXT.")
    (progn
      (setq n 0)
      (setq sum 0)
      (repeat (sslength ss)
        (setq value (cdr (assoc 1 (entget (ssname ss n)))))
        (setq value (ATOI value))
        (setq sum (+ sum value))
        (setq n (1+ n))
        ) ;progn
      (setq pt (getpoint "\nChon diem chen text: "))
      (entmake
        (list
          (cons 0 "TEXT")
          (cons 10 pt)
          (cons 40 (cdr (assoc 40 (entget (ssname ss 0)))))
          (cons 7 (cdr (assoc 7 (entget (ssname ss 0)))))
          (cons 1 (rtos sum 2 2))
          (cons 50 0)
          )
        )
      )
    )
  (princ)
  )

 ;|«Visual LISP© Format Options»
;*** DO NOT add text below the comment! ***|;


<<

Filename: 408874_test.lsp

Trang 212/330

212