Jump to content
InfoFile
Tác giả: Nguyen Hoanh
Bài viết gốc: 416775
Tên lệnh: setuniform setany
Set Uniformly Scale To Block

Đúng như Cuongtk2, vấn đề là Ken Cooper cũng đang nhầm lẫn. Cái này phải set ở cấp độ Block Definition(Object) chứ không phải ở cấp độ Insert (Entity)

 

Bạn thử lisp sau đây, mình đã test chạy trên máy mình, set toàn bộ các block trong bản...

>>

Đúng như Cuongtk2, vấn đề là Ken Cooper cũng đang nhầm lẫn. Cái này phải set ở cấp độ Block Definition(Object) chứ không phải ở cấp độ Insert (Entity)

 

Bạn thử lisp sau đây, mình đã test chạy trên máy mình, set toàn bộ các block trong bản vẽ.

 

(defun c:SetUniform ( / obj )

  (vlax-for obj (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))
    (vla-put-blockscaling obj acUniform)
  )
  (princ)
)
 
(defun c:SetAny ( / obj )
  (vlax-for obj (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))
    (vla-put-blockscaling obj acAny)
  )
  (princ)
)

<<

Filename: 416775_setuniform_setany.lsp
Tác giả: Tue_NV
Bài viết gốc: 135267
Tên lệnh: smake
Viết lisp theo yêu cầu [phần 2]

Của bạn đây :
Tue_NV viết theo cách dễ hiểu nhất cho bạn.
Việc còn lại của bạn là gán Layer cho LINE, PLINE, Hatch att và gom chúng trong 1 Block

Hy vọng bạn làm được

Filename: 135267_smake.lsp
Tác giả: vodoifx
Bài viết gốc: 413481
Tên lệnh: mpl
Entmod Pline Theo Hình Dạng Của Pline Mẫu ( Vẫn Giữ Nguyên Entity Name)

Em có muốn viết 1 lisp sửa Pline theo 1 pline mẫu nhưng vẫn giữ nguyên  Entity name (theo em hiểu thì thằng này giống IDobject)  của đối tượng sửa nhưng khả năng có hạn nên chưa thể viết được, Mong các anh giúp đỡ em.

 

Lý do:

Một số phần mềm thiết kế đường (NovA) quản lý đối tượng qua ID object. Em...

>>

Em có muốn viết 1 lisp sửa Pline theo 1 pline mẫu nhưng vẫn giữ nguyên  Entity name (theo em hiểu thì thằng này giống IDobject)  của đối tượng sửa nhưng khả năng có hạn nên chưa thể viết được, Mong các anh giúp đỡ em.

 

Lý do:

Một số phần mềm thiết kế đường (NovA) quản lý đối tượng qua ID object. Em muốn sửa nhanh những đối tượng đó để không ảnh hưởng đến việc sử dụng phần mềm sau này.

32345708423_e9210a25f3.jpg

 

32315688674_c235b82a37.jpg

 

Sau khi tham khảo lisp của  bác Manh và bác Thai đã hoàn thành.

 

(defun LM:LWVertices (e)
(if (setq e (member (assoc 10 e) e))
(cons (list (assoc 10 e) (assoc 40 e) (assoc 41 e) (assoc 42 e))
(LM:LWVertices (cdr e)))))
;;-----------------------------------
(defun c:mpl (/ e1 e2 h1 h2 l1 l2 z1 z2)
(if (and (setq e1 (car (entsel "\nPline goc de sao chep Vertex: ")))
(eq (cdr (assoc 0 (entget e1))) "LWPOLYLINE")
(setq e2 (car (entsel "\nPline can update Vertex: ")))
(if (= (cdr (assoc 0 (entget e2))) "POLYLINE")
(progn
(setq DKCV T PLSTLAST (getvar "PLINETYPE"))
(setvar "PLINETYPE" 1)
(vl-cmdf "convert" "P" "S" e2 "")
(setvar "PLINETYPE" PLSTLAST)
))
(eq (cdr (assoc 0 (entget e2))) "LWPOLYLINE"))
(progn (setq e1 (entget e1)
h1 (reverse (member (assoc 39 e1) (reverse e1)))
l1 (LM:LWVertices e1)
z1 (assoc 210 e1))
(setq e2 (entget e2)
h2 (reverse (member (assoc 39 e2) (reverse e2)))
l2 (LM:LWVertices e2)
z2 (assoc 210 e2))
(setq e2 (append h2 (mapcar 'car l1) (list z2))
e2 (subst (cons 90 (length l1)) (assoc 90 e2) e2))
(entmod e2)))
(princ))


<<

Filename: 413481_mpl.lsp
Tác giả: Nguyen Hoanh
Bài viết gốc: 74181
Tên lệnh: p2c
Text này bị sao vậy nhỉ?

Bạn dùng lisp P2C dưới đây để biến text đó thành text bình thường.


Filename: 74181_p2c.lsp
Tác giả: hihi.hehe
Bài viết gốc: 386607
Tên lệnh: gd
Lisp Lọc Đường Thẳng Theo Độ Dốc!

 

Dùng cái này xem.

hehe hay quá, đúng cái mình cần rồi. Với cả hiện tại mình có cái lisp này để ghi độ dốc cho polyline, nhưng chỉ chọn được một đối tượng polyline, các bạn có thể giúp mình chỉnh sửa chọn được nhiều polyline (nếu là nhiều line được thì càng tốt)...

>>

 

Dùng cái này xem.

hehe hay quá, đúng cái mình cần rồi. Với cả hiện tại mình có cái lisp này để ghi độ dốc cho polyline, nhưng chỉ chọn được một đối tượng polyline, các bạn có thể giúp mình chỉnh sửa chọn được nhiều polyline (nếu là nhiều line được thì càng tốt) không ạ.

(defun c:gd (/ entpl p1 cao_text sp ep ang dodoc thap_phan)
(vl-load-com)
(setq entpl (entsel "\n Hay chon polyline can ghi do doc")
      entob (vlax-ename->vla-object (car entpl))
)
(setq x (getreal "\n Hay nhap ty le theo truc x: ")
      y (getreal "\n Hay nhap ty le theo truc y: "))
(setq cao_text (getreal "\n Hay nhap chieu cao text: ")
      h (getreal "\n Hay nhap khoang cach tu text toi pline: ")
      i 0
      thap_phan 2
      p1 (cadr entpl)
      ent (car entpl)
      m (vlax-curve-getendparam ent))
(while (< i m)
(setq sp (vlax-curve-getPointatparam ent i)
      ep (vlax-curve-getPointatparam ent (1+ i))
      ang (angle sp ep)
      x1 (car sp)
      y1 (cadr sp)
      x2 (car ep)
      y2 (cadr ep)
      dodoc (* (abs (/ (/ (- y2 y1) y) (/ (- x2 x1) x 100))) )
      dodoc (strcat (rtos dodoc 2 thap_phan) ))
(if (< (car sp) (car ep))
    (progn
    (setq pt (vlax-curve-getpointatparam ent (+ i 0.1)))
    (command "_.text" (list (- (car pt) (* h (sin ang))) (+ (cadr pt) (* h (cos ang)))) cao_text (/ (* ang 180) pi)(strcat dodoc))
    )
    (if (> (car sp) (car ep))
    (progn
    (setq pt (vlax-curve-getpointatparam ent (+ i 0.9)))
    (command "_.text" (list (+ (car pt) (* h (sin ang))) (+ (cadr pt) (* h (cos ang)))) cao_text (+ 180 (/ (* ang 180) pi)) (strcat dodoc))
    )
    (progn
    (setq pt (vlax-curve-getpointatparam ent (+ i 0.5)))
    (command "_.text" (list (+ (car pt) h) (cadr pt)) cao_text 90 (strcat dodoc))
    )
    )
)
(setq i (1+ i))

<<

Filename: 386607_gd.lsp
Tác giả: 18011985
Bài viết gốc: 417404
Tên lệnh: ax
Lisp Tính Diện Tích (Có Lọc Hình Pick Trùng)

Mình viết đoạn code để lọc hình pick trùng nhưng thỉnh thoảng vẫn trả kết quả sai. Mong các bạn góp ý chỉnh sửa

(defun c:ax (/ I a1 FOD KT dtlist tglist k)
  (defun kiemtra (z1 z2 z3 / i itest atest ctest)
    (setq i 0)
    (setq itest (-(length z2)1))
    (while (<= i itest)
      (setq atest (vlax-get z1 'Area))
      (setq ctest...
>>

Mình viết đoạn code để lọc hình pick trùng nhưng thỉnh thoảng vẫn trả kết quả sai. Mong các bạn góp ý chỉnh sửa

(defun c:ax (/ I a1 FOD KT dtlist tglist k)
  (defun kiemtra (z1 z2 z3 / i itest atest ctest)
    (setq i 0)
    (setq itest (-(length z2)1))
    (while (<= i itest)
      (setq atest (vlax-get z1 'Area))
      (setq ctest (vlax-get z1 'Centroid))
      (if (and (equal atest (nth i z2)0.0001)
      (equal (car ctest) (car (nth i z3))0.0001)
      (equal (cadr ctest) (cadr (nth i z3)))0.0001)
(progn
 (setq k 1)
 (setq i (+ itest 1))
 )
(progn
(setq k 0)
 )
)
      (setq i (+ i 1))
      (Setq atest nil)
      (Setq ctest nil)
      )
    (if (= k 1) (alert "trung roi") (alert "ok"))
      
    );end kiem tra
  (setq i 0)
  (setq k 0)
  (while (setq a1 (getpoint "\n Chon diem:" ))
    (if (eq i 0)
      (progn
(command "-boundary" "a" "o" "r" "" a1 "")
(setq FOD (vlax-ename->vla-object (entlast)))
(setq dtlist (append dtlist (list (vlax-get FOD 'Area))))
(setq tglist (append tglist (list (vlax-get FOD 'Centroid))))
(command "erase" (entlast) "")
);end progn
      (progn
(command "-boundary" "a" "o" "r" "" a1 "")
(setq KT (vlax-ename->vla-object (entlast)))
(kiemtra KT dtlist tglist)
(if (= k 0)
 (progn
   (setq dtlist (append dtlist (list(vlax-get KT 'Area))))
   (setq tglist (append tglist (list(vlax-get KT 'Centroid))))
   )
 )
(command "erase" (entlast) "")
;(setq i (+ i 1))
);end progn
      );end if
    (setq i (+ i 1))
    );end while
  (princ dtlist)
  ); end defun
 
;;;;      

<<

Filename: 417404_ax.lsp
Tác giả: quansla
Bài viết gốc: 417101
Tên lệnh: thunghiem
Viết Lisp Tính Cao Độ Ga Dựa Vào Mặt Bằng Tim, Bề Rộng Đường
Giản lược thế, khó hình dung quá, mà có ai đào tạo gì đâu mà thầy với chả tớ
1. Đường tim màu đỏ lúc nào cũng đứt đoạn à (hay là cả Tim là 1 Polyline dài ngoằng có cả cong, cả thẳng, cần đoạn nào thì Pick điểm trên nó); Tim đó lúc nào cũng bị "là phẳng" (làm đồng phẳng rồi à) bắt buộc nhập thủ công cao độ đầu + cuối sao.
2. Hố ga cần tính là Tâm của hai đường chéo cái...
>>
Giản lược thế, khó hình dung quá, mà có ai đào tạo gì đâu mà thầy với chả tớ
1. Đường tim màu đỏ lúc nào cũng đứt đoạn à (hay là cả Tim là 1 Polyline dài ngoằng có cả cong, cả thẳng, cần đoạn nào thì Pick điểm trên nó); Tim đó lúc nào cũng bị "là phẳng" (làm đồng phẳng rồi à) bắt buộc nhập thủ công cao độ đầu + cuối sao.
2. Hố ga cần tính là Tâm của hai đường chéo cái hình chữ nhật trắng ấy à, Hố ga có trước chỉ xác định cao độ rồi Insert ATT tại đúng vị trí đó, hay Pick vào đâu thì insert hố ga và ATT vào đấy
3. ATT đó đâu?
4. Nội suy cao độ hố ga theo phương án nào: đơn giản nhất là: nội sung tuyến tính (nội suy 1 chiều, theo phương của đoạn thẳng TIM màu đỏ); cách này bắt buộc các thông số sau bảo đảm: Tim màu đỏ là 1 đoạn thẳng (hoặc 1 phần đoạn thẳng) không chứa đoạn cong; hố ga bất kỳ cùng thuộc 1 đường gióng Vuông góc với tim luôn sẽ có cao độ nội suy bằng nhau;
còn nếu có cách nội suy khác thì đề nghị làm rõ thêm

Chủ thớt nên cho file kết quả đê, và cả cách tính nữa nhé


chu y : LISP HOAT DONG SAI KHI PICK VI TRI HO GA NAM NGOAI GIOI HAN DOAN THANG DUONG TIM
(defun c:thunghiem( / caodocuoi caododau dodoc dt duong_tim kqnoisuy L obj p p0 tongL)
(vl-load-com)
(defun dxf (n ent) (cdr(assoc n ent)))
(defun get_cao_do(flag / caodo num)
(princ "\nChon cao do diem")
(setq num
(cond
((and (setq caodo (car(entsel (acet-str-format "\nNhap cao do diem thu %1" flag))))
(member (type (setq num (read (dxf 1 (entget caodo))))) '(REAL INT)))
num)
((getreal (acet-str-format "\nNhap cao do diem thu %1" flag)))
(T (princ "\nBan chua chon duoc cao do"))))
num)

(if (and
(setq duong_tim (entsel"/nChon duong thang tam"))
(if (wcmatch (dxf 0 (entget (car duong_tim))) "*LINE") (setq dt (car duong_tim)))
(setq obj (vlax-ename->vla-object dt))
(setq caododau (get_cao_do 1))
(setq caodocuoi (get_cao_do 2))
)
(while (setq p (getpoint "\nNhap toa do ho ga"))
(setq dodoc (* 100 (/ (- caodocuoi caododau) (setq tongL (vlax-curve-getdistatparam obj (vlax-curve-getendparam obj))))))
(setq L (vlax-curve-getdistatpoint obj (setq p0 (vlax-curve-getclosestpointto obj p))))
(setq kqnoisuy (+ caododau (* (/ L tongL) (- caodocuoi caododau))))
(entmakex
(list
(cons 0 "TEXT")
'(100 . "AcDbEntity")
'(100 . "AcDbText")
(cons 10 p)
(cons 8 "caodo_hoga")
(cons 11 p)
(cons 1 (acet-str-format "Do doc %1 ; Cos HG: %2" dodoc kqnoisuy))
(cons 40 (* 0.01 tongL))
'(71 . 0)
'(72 . 0)
'(73 . 0)))
))
(princ))

<<

Filename: 417101_thunghiem.lsp
Tác giả: 18011985
Bài viết gốc: 417418
Tên lệnh: tt+%C2%A0
Lisp Tính Diện Tích (Có Lọc Hình Pick Trùng)

Cảm ơn các bài trao đổi của các bác. Các bác test giúp em nhé. Lệnh Vla-delete cad2012 không thực hiện được các bác sửa dùm em.

(defun c:tt  (/ i item lst obj pt)
(vl-load-com)
  (setq i 0)
  (while (setq pt (getpoint "\nChon diem:"))
    (cond ((= i 0)
  (progn
    (vl-cmdf "-boundary" "a" "o" "r" "" pt "")
    (setq obj (vlax-ename->vla-object (entlast)))
 ...
>>

Cảm ơn các bài trao đổi của các bác. Các bác test giúp em nhé. Lệnh Vla-delete cad2012 không thực hiện được các bác sửa dùm em.

(defun c:tt  (/ i item lst obj pt)
(vl-load-com)
  (setq i 0)
  (while (setq pt (getpoint "\nChon diem:"))
    (cond ((= i 0)
  (progn
    (vl-cmdf "-boundary" "a" "o" "r" "" pt "")
    (setq obj (vlax-ename->vla-object (entlast)))
    (setq item (cons (vlax-get obj 'Centroid) (vlax-get obj 'Area)))
    ;(vla-delete obj)
    (setq lst (cons item lst))
    )
  )
 ((/= i 0)
  (progn
    (vl-cmdf "-boundary" "a" "o" "r" "" pt "")
    (setq obj (vlax-ename->vla-object (entlast)))
    (setq item (cons (vlax-get obj 'Centroid) (vlax-get obj 'Area)))
    (if (/=(member item lst)nil)
      (alert "trung roi...")
      (setq lst (cons item lst)))
    ;(vla-delete obj)
    )
  )
 )
    (setq i (1+ i))
    )
  
  lst)

<<

Filename: 417418_tt+%C2%A0.lsp
Tác giả: quansla
Bài viết gốc: 417479
Tên lệnh: cxt
Lisp Trích Xuất Giá Trị Trong Dimension Ra Mtext

Chào các bác
em muốn trích xuất giá trị ghi trong dimension và kéo thẳng lên phía trên thành dạng mtext như file cad đính kèm.
https://drive.google.com/open?id=0B_ToehCkY5kzWkxNYjFTWXdIMnM
Nhờ các bác giúp vì hiện tại em đang làm rất thủ công là...

>>

Chào các bác
em muốn trích xuất giá trị ghi trong dimension và kéo thẳng lên phía trên thành dạng mtext như file cad đính kèm.
https://drive.google.com/open?id=0B_ToehCkY5kzWkxNYjFTWXdIMnM
Nhờ các bác giúp vì hiện tại em đang làm rất thủ công là copy cái dimension ra và explore để lấy giá trị trong dim, mà công việc của em làm điều này rất nhiều lần, khiến em mất rất nhiều thời gian.
Lisp e muốn như này:
Gõ lệnh cxt
Pick chọn vào giá trị ghi trong dimension và kéo thẳng lên pick vào điểm bất kì muốn đặt giá trị mtext.
Mong các bác giúp đỡ.
Thanks !


Đây cơ mà Khi Pick, chú ý Pick vào đúng MTEXT của DIM nhé, thì LÍP mới hoạt động
(defun c:cxt(/ dt ent p)
  (vl-load-com)
  (if (setq dt (car(nentsel "\Pick DIM")))
    (progn
      (setq ent (entget dt))
      
      (setq p (getpoint (dxf 10 ent) "\nChon diem moi"))
      (entmakex
	(append
	  (list
	    '(0 . "MTEXT")
	    '(100 . "AcDbEntity")
	    '(100 . "AcDbMText"))
	  (vl-remove-if-not '(lambda(x) (member (car x) '(8 7 1 62 40 41 42 43 50 70 71 72 73)))  ent)
	  (list (cons 10 p))
	  )
      )
      ))
  (princ))

<<

Filename: 417479_cxt.lsp
Tác giả: quansla
Bài viết gốc: 417472
Tên lệnh: thunghiem
Tạo Lisp Bóc Khối Lượng Ống Gió

Chào bạn quansla, cảm ơn vì đã phản hồi. Bạn cần file bản vẽ hay sao vậy?. ý tưởng của bạn về việc Dim chiều dài ống trước sau đó pick chọn để lấy thông số cũng hay, nhưng ví dú mình muốn lisp cho phép thực hiện thao tác đo bằng cách kích 2 điểm để lấy giá trị chiều dài L trước được ko?, khi đó mình...

>>

Chào bạn quansla, cảm ơn vì đã phản hồi. Bạn cần file bản vẽ hay sao vậy?. ý tưởng của bạn về việc Dim chiều dài ống trước sau đó pick chọn để lấy thông số cũng hay, nhưng ví dú mình muốn lisp cho phép thực hiện thao tác đo bằng cách kích 2 điểm để lấy giá trị chiều dài L trước được ko?, khi đó mình không cần phải DIM trước.

 
Được nhưng vẫn cần FILE bản vẽ, bạn đưa lên đây đi; chứ biết bạn có file thế nào, dữ liệu đầu vào thế nào, đầu ra cho kết quả vào đâu, giá trị chiều dài, pick điểm được kích thước mm, hay m; file thôi mà khó khăn thế?
(defun loc_thong_tin_str(str / pos str1 str2)
  ;(loc_thong_tin_str "300x200")
  (vl-load-com)
  (if (setq pos (vl-string-search "x" str)) (setq str1 (substr str 1 pos) str2 (substr str (+ 2 pos) 8)))
  (list str1 str2)
  )
 
(defun loc_tap_ss(ss lst / lst2 name r r2)
  ;(setq lst '("TEXT" "MTEXT" "DIMENSION"))
  ;(loc_tap_ss ss '("TEXT" "MTEXT" "DIMENSION"))
  ;(setq dt (car ss))
  (setq lst2 (mapcar 'list lst))
  (foreach dt ss
    (if (member (setq name (dxf 0 (entget dt))) lst)
      (progn
(setq r (assoc name lst2))
(setq r2 (append r (list dt)))
(setq lst2 (subst r2 r lst2))
)))
  lst2
  )
 
(defun dxf (n ent) (cdr(assoc n ent)))
 
(defun c:thunghiem(/ e1 e2 ent kqdientich l l1 lst r1 ss str)
  (if (and (setq ss (acet-ss-to-list (ssget '(( 0 . "*TEXT,*DIM*")))))
  (setq lst (loc_tap_ss ss '("TEXT" "DIMENSION"))))    
    (progn
      (if (> (length (car lst)) 1)
(setq e1 (last(car lst)) str (dxf 1 (entget e1)))
(setq str ""))
      (if (> (length (last lst)) 1)
  (setq e2 (cadr(last lst))
L1 (if (= "" (dxf 1 (setq ent (entget e2)))) (dxf 42 ent) (atoi (dxf 1 ent))))
(setq L1 -100.0))
      (if (= str "") (setq str (getstring "/nNhap lai tiet dien ong dang 200x300")))
      (if (< L1 0) (setq L1 (getdist "/nNhap lai chieu dai ong L= <0.00>")))
      (if (setq L (getreal (acet-str-format "Chon chieu dai ong %1  L=<%2>" str L1)))
(setq L1 L))
      (if (>= L1 1000) (setq L1 (* L1 0.001)))
      (setq kqDientich (* 1e-6 (apply '* (mapcar 'read (setq r1 (loc_thong_tin_str str)))) L1))
      (alert (acet-str-format "Gia tri tinh toan S= (%1*%2)*%3m=%4 m2" (read (car r1)) (read (cadr r1)) L1 kqDientich))
      )
    )
  (princ)
  )

<<

Filename: 417472_thunghiem.lsp
Tác giả: quangthanhdu
Bài viết gốc: 417296
Tên lệnh: vdc
Xin lisp vẽ đường chéo

Sưu tầm.... chỉ vẽ được từng hình... dùng tạm nhé.

(defun c:vdc (/ pnt1 pnt2 pnt3 pnt4  lst e len n e1)

	(setq e (entget (car (entsel))))
	;get the entity list

	(setq len (length e))
	;get the length of the list

	(setq n 0)
	;set counter to zero
	(setq lst nil)
	(repeat len
	;repeat for the length of the entity list

	  (setq e1 (car (nth n e)))
	  ;get each item in the entity list
	  ;and strip the entity code number

	  (if (= e1...
>>

Sưu tầm.... chỉ vẽ được từng hình... dùng tạm nhé.

(defun c:vdc (/ pnt1 pnt2 pnt3 pnt4  lst e len n e1)

	(setq e (entget (car (entsel))))
	;get the entity list

	(setq len (length e))
	;get the length of the list

	(setq n 0)
	;set counter to zero
	(setq lst nil)
	(repeat len
	;repeat for the length of the entity list

	  (setq e1 (car (nth n e)))
	  ;get each item in the entity list
	  ;and strip the entity code number

	  (if (= e1 10)
	  ;check for code 10 (vertex)

	    (progn
	    ;if it's group 10 do the following

		(terpri)
		  ;new line
		(setq lst (if lst (append lst (list(cdr (nth n e))))(list(cdr (nth n e)))))	  
	    );progn

	  );if
	  (setq n (1+ n))
	  ;increment the counter

	);repeat
  (mapcar 'set '(pnt1 pnt2 pnt3 pnt4) lst)
  
	        (setq pnt1 (strcat(rtos(car pnt1))"," (rtos(cadr pnt1)) ",0"))
	      
		(setq pnt2 (strcat(rtos(car pnt2)) ","(rtos(cadr pnt2))",0"))

		(setq pnt3 (strcat(rtos(car pnt3)) ","(rtos(cadr pnt3))",0"))

		(setq pnt4 (strcat(rtos(car pnt4)) ","(rtos(cadr pnt4))",0"))

(command "line" pnt1 pnt3 "")
(command "line" pnt2 pnt4 "")
  (princ)
);defun
(princ)

<<

Filename: 417296_vdc.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 237480
Tên lệnh: vht
Code lisp như thế nào để hạn chế lỗi cho người dùng?

Chúng ta trở lại với bài vẽ Circle bằng 1 lỗi khác. Lỗi này thường ít được để ý và nếu không để ý thì sẽ khó phát hiện.

Mời mọi người tìm lỗi sau đây, và đề xuất phương án bẫy lỗi.

.

(defun C:VHT( / p r)
 (if
  (and
   (not (initget 1))
   (setq p (getpoint "\nSpecify center point for circle: "))
   (not (initget 7))
 ...
>>

Chúng ta trở lại với bài vẽ Circle bằng 1 lỗi khác. Lỗi này thường ít được để ý và nếu không để ý thì sẽ khó phát hiện.

Mời mọi người tìm lỗi sau đây, và đề xuất phương án bẫy lỗi.

.

(defun C:VHT( / p r)
 (if
  (and
   (not (initget 1))
   (setq p (getpoint "\nSpecify center point for circle: "))
   (not (initget 7))
   (setq r (getdist p "\nSpecify radius of circle: ")))
  (entmake (list '(0 . "Circle") (cons 10 p) (cons 40 r))))
 (princ))
 


<<

Filename: 237480_vht.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 400072
Tên lệnh: test%C2%A0
Nhờ Chỉnh Lisp Cắt Thép Dầm Momen

Hỏi không được, thôi làm đại:

(defun c:test  (/ Make-Line ang bv cdi hbv hcd len msp pd3 po1 po2 po3 po4 pt1 pt2 pt3 pt4)
 (defun Make-Line  (p1 p2 lay)
  (entmakex (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2) (cons 8 lay))))
 (vl-load-com)
 (setq msp (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))
       cdi (* (getvar "DIMTXT") (getvar...
>>

Hỏi không được, thôi làm đại:

(defun c:test  (/ Make-Line ang bv cdi hbv hcd len msp pd3 po1 po2 po3 po4 pt1 pt2 pt3 pt4)
 (defun Make-Line  (p1 p2 lay)
  (entmakex (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2) (cons 8 lay))))
 (vl-load-com)
 (setq msp (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))
       cdi (* (getvar "DIMTXT") (getvar "DIMSCALE")))
 (if (and (setq pt1 (getpoint "\nDiem p1: "))
          (setq pt2 (getpoint "\nDiem p2: "))
          (setq pt3 (getpoint "\nDiem p3: "))
          (setq pt4 (getpoint "\nDiem p4: "))
          (setq hcd (getdist "\nChieu cao dam: "))
          (setq hbv (getdist "\nChieu day bt bao ve: ")))
  (progn (setq po1 (polar pt3 (* pi 1.0) hcd)
               po2 (polar po1 (* pi (/ 30 180.0)) 70)
               po3 (polar pt4 (* pi 0.0) hcd)
               po4 (polar po3 (* pi (/ 150 180.0)) 70)
               ang (angle pt1 pt2)
               pd3 (polar pt1 (+ ang (* pi 1.5)) (* cdi 4)))
         (Make-Line po1 po2 "CAT-THEP")
         (Make-Line po3 po4 "CAT-THEP")
         (mapcar (function (lambda (x y z) (vla-adddimaligned msp x y z)))
                 (mapcar 'vlax-3d-point (list pt1 pt2 (polar po1 (* pi 1.5) hbv)))
                 (mapcar 'vlax-3d-point
                         (list (polar po1 (* pi 1.5) hbv) (polar po3 (* pi 1.5) hbv) (polar po3 (* pi 1.5) hbv)))
                 (mapcar 'vlax-3d-point (list pd3 pd3 pd3)))))
 (princ))

<<

Filename: 400072_test%C2%A0.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 418122
Tên lệnh: ha
Hàm Tìm Điểm

Quick Code

(defun C:HA(/ p e lst lstT lstP lstYT1 lstYP1 lstYT2 lstYP2)
 (if
  (and
   (setq p (getpoint "\nPick point: "))
   (setq e (car (entsel "\nChon Pline: "))))
  (progn
   (setq lst (mapcar 'cdr (vl-remove-if-not '(lambda(x) (= (car x) 10)) (entget e))))
   (setq lstT (vl-remove-if '(lambda(x) (> (car x) (car p))) lst))
   (setq lstP (vl-remove-if '(lambda(x) (<...
>>

Quick Code

(defun C:HA(/ p e lst lstT lstP lstYT1 lstYP1 lstYT2 lstYP2)
 (if
  (and
   (setq p (getpoint "\nPick point: "))
   (setq e (car (entsel "\nChon Pline: "))))
  (progn
   (setq lst (mapcar 'cdr (vl-remove-if-not '(lambda(x) (= (car x) 10)) (entget e))))
   (setq lstT (vl-remove-if '(lambda(x) (> (car x) (car p))) lst))
   (setq lstP (vl-remove-if '(lambda(x) (< (car x) (car p))) lst))
   (setq lstYT1 (vl-sort lstT '(lambda(e1 e2) (< (cadr e1) (cadr e2)))))
   (setq lstYP1 (vl-sort lstP '(lambda(e1 e2) (< (cadr e1) (cadr e2)))))
   (setq lstYT2 (vl-remove-if-not '(lambda(e) (equal (cadr e) (cadr (car lstYT1)) 1E-3)) lstYT1))
   (setq lstYP2 (vl-remove-if-not '(lambda(e) (equal (cadr e) (cadr (car lstYP1)) 1E-3)) lstYP1))
   (MPoint (car (vl-sort lstYT2 '(lambda(e1 e2) (< (car e1) (car e2))))))
   (MPoint (car (vl-sort lstYP2 '(lambda(e1 e2) (> (car e1) (car e2))))))))
 (princ))  
(defun MPoint(p)
 (entmake (list (cons 0 "POINT") (cons 10 p))))

<<

Filename: 418122_ha.lsp
Tác giả: cuongtk2
Bài viết gốc: 418134
Tên lệnh: test
Lisp bẻ và nối đối tượng
Break 2 đường tại vị trí giao nhau
(defun c:test ( / ss ent1 ent2 inter)
(setq ss (ssget))
(setq ent1  (ssname ss 0)
      ent2  (ssname ss 1))
(setq inter  (vla-intersectwith
      (vlax-ename->vla-object ent1)
      (vlax-ename->vla-object ent2) acExtendBoth)
      inter (safearray-value (variant-value inter)))
(command "break" ent1  inter inter)
(command "break" ent2...
>>
Break 2 đường tại vị trí giao nhau
(defun c:test ( / ss ent1 ent2 inter)
(setq ss (ssget))
(setq ent1  (ssname ss 0)
      ent2  (ssname ss 1))
(setq inter  (vla-intersectwith
      (vlax-ename->vla-object ent1)
      (vlax-ename->vla-object ent2) acExtendBoth)
      inter (safearray-value (variant-value inter)))
(command "break" ent1  inter inter)
(command "break" ent2 inter inter)
)
<<

Filename: 418134_test.lsp
Tác giả: Tue_NV
Bài viết gốc: 418277
Tên lệnh: chiaspl
Chia Spline Thành Polyline Với Khoảng Cách Đỉnh Bằng Nhau.

Chào các bạn,

 

Nhờ các bạn giúp mình làm một lisp biến Spline thành Polyline với khoảng cách các đỉnh bằng nhau theo kích thước người dùng nhập vào, nội dung lisp như sau:

 

+Chạy lisp

- Lisp yêu cầu chọn spline cần chia

+Chọn spline (xem lưu ý bên dưới)

- Lisp yêu cầu...

>>

Chào các bạn,

 

Nhờ các bạn giúp mình làm một lisp biến Spline thành Polyline với khoảng cách các đỉnh bằng nhau theo kích thước người dùng nhập vào, nội dung lisp như sau:

 

+Chạy lisp

- Lisp yêu cầu chọn spline cần chia

+Chọn spline (xem lưu ý bên dưới)

- Lisp yêu cầu nhập khoảng cách giữa các đỉnh

+Nhập số giá trị độ dài các đỉnh (ví dụ: 1750 như file đính kèm)

- Lisp sẽ tự động chuyển spline gốc thành polyline theo yêu cầu như hình minh họa bên dưới

 

Lưu ý:

Điểm bắt đầu chia spline có thể xác định bởi vị trí chuột chọn vào đường spline đó:

Ví dụ: nếu điểm chọn spline gần điểm A thì nó bắt đầu chia đường 1750 từ A cho đến B (phần thừa sẽ ở phía Điểm B và ngược lại).

 

1969_spline_to_polyline_1.jpg

 

File cad minh họa

http://www.cadviet.com/upfiles/7/1969_spline_to_polyline.dwg

 

Trân trọng cảm ơn!

Bạn chạy thử 

(defun Tue-list-tach (lst count / i j Lst-tinh Reslis)
 ;;;;;Ex: (Tue-list-tach '(1 5 4 6 3 5) 2)--> ((1 5) (4 6) (3 5))
 ;;;;;;;;;(Tue-list-tach '(1 5 4 6 3 5) 3)--> ((1 5 4) (6 3 5))
 ;;;;;;;;;(Tue-list-tach '(1 5 4 6 3 5) 5)--> nil
   (setq i 0 j 0)
   (while (and (< i (/ (length lst) count)) (= (rem (length lst) count) 0))
(Repeat count
 (setq Lst-tinh (append Lst-tinh (list (nth j lst)) ))
 (setq j (1+ j))  
)
         (setq Reslis (append Reslis (list Lst-tinh))
      Lst-tinh nil)
     (setq i (1+ i))
    )
 Reslis
)
(defun Tue-make-Circle (lst / tam R _col _Lay _lstphu);;;Tue-make-Layer
;;;ex: (Tue-make-Circle (list (getpoint "\nNhap tam Circle:") (getdist "Nhap R :") ) )
;;;;;;;(Tue-make-Circle (list (getpoint "\nNhap tam Circle:") (getdist "Nhap R :") 1 ) )
;;;;;;;(Tue-make-Circle (list (getpoint "\nNhap tam Circle:") (getdist "Nhap R :") 1 "LAY") )
(mapcar 'set '(tam R _col _Lay _lstphu) lst)
(entmakex(append 
    (list '(0 . "Circle")  
  (cons 10 tam) 
  (cons 40 R) 
    )
    (if _col (list (cons 62 _col)) )
    (if _Lay
(if (tblsearch "Layer" _Lay) 
  (list (cons 8  _Lay)) 
  (list (cons 8 (Tue-make-Layer _Lay _col)))
)
    )
   _lstphu
)
)
)
(defun Tue-geom-inters(e1 e2 flag / Lst_tong Lst);;;Tue-list-tach
 ;;; flag= 0 : acExtendNone Does not extend either object.
 ;;; flag= 1 : acExtendThisEntity Extends the base object.
 ;;; flag= 2 : acExtendOtherEntity Extends the object passed as an argument.
 ;;; flag= 3 : acExtendBoth  Extends both objects.
 
;;Ex: (Tue-geom-inters (ssname (TUE-SS-ENTSEL '((0 . "*LINE,ARC,CIRCLE,ELLIPSE")) "\npick chon doi tuong thu 1 :") 0)
;;;;;;(ssname (TUE-SS-ENTSEL '((0 . "*LINE,ARC,CIRCLE,ELLIPSE")) "\npick chon doi tuong thu 2 :") 0) 0)
  (if (= (type e1) 'ENAME) (setq e1 (vlax-ename->vla-object e1)))
  (if (= (type e2) 'ENAME) (setq e2 (vlax-ename->vla-object e2)))
  (Tue-list-tach (vlax-invoke e1 'IntersectWith e2 flag) 3)
)
(defun Tue-make-LWPLINE(lst-pt layer)
(entmakex
  (apply 'append 
   (cons
     (list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 90 (length lst-pt))
(cons 8 Layer)
'(70 . 0)
)
     (mapcar 'list (mapcar (function (lambda (a) (cons 10 a))) lst-pt) ) ;_ mapcar
     ) ;_ cons
  ) ;_ apply
)
)
(DEFUN C:CHIAspl()
  (SETQ spl (car(entsel "\nChon Spline can chia :")))
  (setq diemchia (getpoint "\nDiem bat dau chia :"))
  (setq kchia (getdist "\nKhoang chia :"))
  (if (< (distance diemchia (vlax-curve-getStartPoint spl)) (distance diemchia (vlax-curve-getendPoint spl)))
     (setq diemchia (vlax-curve-getStartPoint spl) HUONG T dss (vlax-curve-getendPoint spl))
     (setq diemchia (vlax-curve-getendPoint spl) HUONG NIL dss (vlax-curve-getStartPoint spl))
   )
   (setq lst-diem (list diemchia ))
  
  (while (<= kchia (distance diemchia dss))
       (setq circle (Tue-make-Circle (list diemchia kchia ) ))
       (SETQ GIAODIEM (Tue-geom-inters circle spl 0))
       (setq diemchia1 (car GIAODIEM)) (setq diemchia2 (caDr GIAODIEM))
       (IF (= (LENGTH giaodiem) 1)  (setq diemchia (car giaodiem))
(progn
            (IF HUONG (IF (> (VLAX-CURVE-GETPARAMATPOINT SPL diemchia1) (VLAX-CURVE-GETPARAMATPOINT SPL diemchia2))
(setq diemchia diemchia1) (setq diemchia diemchia2)
      )
(IF (> (VLAX-CURVE-GETPARAMATPOINT SPL diemchia1) (VLAX-CURVE-GETPARAMATPOINT SPL diemchia2))
(setq diemchia diemchia2) (setq diemchia diemchia1)
      )
   )
 )
     )
(entdel circle) (setq lst-diem (append lst-diem (list diemchia )))
       
  )
(Tue-make-LWPLINE (append lst-diem (list dss)) "0")
 
 
 
 )

<<

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

Chào các bác!

Em đang tập làm quen và muốn nắm bắt được phương thức sử dụng hàm Grread kết hợp hàm Grdraw để hiển thị cho trực quan mà đang loay hoay mãi.

Em đang viết chương trình nội suy từ 2 điểm đã biết tọa độ. Khi chọn xong 2 điểm có độ cao, khi di chuyển con chuột đến đâu thì hiển thị độ cao điểm nội suy đến đó. Khi Pick vào màn hình thì nó sẽ ghi Text và cho...

>>

Chào các bác!

Em đang tập làm quen và muốn nắm bắt được phương thức sử dụng hàm Grread kết hợp hàm Grdraw để hiển thị cho trực quan mà đang loay hoay mãi.

Em đang viết chương trình nội suy từ 2 điểm đã biết tọa độ. Khi chọn xong 2 điểm có độ cao, khi di chuyển con chuột đến đâu thì hiển thị độ cao điểm nội suy đến đó. Khi Pick vào màn hình thì nó sẽ ghi Text và cho mình tiếp tục chọn điểm tiếp theo để Pick (lại tiếp tục di chuyển con chuột và hiển thị độ cao điểm nội suy). Thêm một phương thức nữa là có thể sử dụng được Osnap khi chọn điểm Pick (Em biết phần này không dễ dàng chút nào nhưng cứ mạn phép xin được chỉ giáo điều đó)

Em chỉ làm được đến phần Pick vào màn hình thì nó ghi kết quả nội suy độ cao chứ không cho chọn liên tiếp. Rất mong các bác chỉ giáo cho phương thức thực hiện với ạ! Em cảm ơn các bác nhiều!

(vl-load-com)
(defun c:00 (/ CAOCHU	CAODO1 CAODO2 CAODO3 CHIEUCAO ENAMET1 ENAMET2
	       PT1A PT2A PTGR PT_I SLE TDO1 TDO2 TEXT X1 X2 Y1 Y2
	      )
  (defun *error* (msg)
    (if	Olmode
      (setvar 'osmode Olmode)
    )
    (if	(not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
      (princ (strcat "\nError: " msg))
    )
    (princ)
  )
  (setq Olmode (getvar "OSMODE"))
  (setvar "OSMODE" 0)
  (_layer2 "TNS" 6)
  (setq sle 2)

  (if
    (and
      (setq EnameT1
	     (car
	       (entsel "\nCh\U+1ECDn Text th\U+1EE9 nh\U+1EA5t: ")
	     )
      )
      (setq EnameT2 (car (entsel "\nCh\U+1ECDn Text th\U+1EE9 hai ")))
    )
     (progn
       (setq Tdo1 (TD:Text-Base EnameT1))
       (setq Caodo1 (cdr (assoc 1 (entget EnameT1))))
       (setq x1 (car Tdo1))
       (setq y1 (cadr Tdo1))
       (setq Caochu (cdr (assoc 40 (entget EnameT1))))
       (setq Pt1A (list x1 y1 (atof Caodo1)))

       (setq Tdo2 (TD:Text-Base EnameT2))
       (setq Caodo2 (cdr (assoc 1 (entget EnameT2))))
       (setq x2 (car Tdo2))
       (setq y2 (cadr Tdo2))
       (setq Pt2A (list x2 y2 (atof Caodo2)))
       (prompt "\nV\U+1ECB tr\U+00ED ch\U+00E8n : ")
       (setvar "OSMODE" 0)
       (while (member (car (setq ptgr (grread 't 5 0))) '(5 2))
	 (if text
	   (progn
	     (setq PntPick (trans (cadr ptgr) 1 0))
	     (if (= (CheckPntbetween2Pnt
		      Pt1A
		      Pt2A
		      PntPick
		    )
		    1
		 )
	       (setq Caodo3
		      (NSG2D Pt1A Pt2A PntPick)
	       )
	       (setq Caodo3
		      (NSN2D Pt1A Pt2A PntPick)
	       )
	     )
	     (vlax-put text
		       'InsertionPoint
		       (mapcar '+ PntPick '(0.1 0.1 0.0))
	     )
	     (vlax-put
	       text
	       'TextString
	       (rtos Caodo3 2 3)
	     )
	     (redraw)
	     (grdraw Pt1A PntPick 7 1)
	     (grdraw Pt2A PntPick 7 1)
	   )
	   (setq text (vlax-ename->vla-object
			(MakeText Pt2A
				  (rtos (caddr Pt2A) 2 3)
				  Caochu
				  0
				  "L"
				  "TNS"
				  nil
				  nil
			)
		      )
	   )
	 )
       )
     )
  )
  (redraw)
  (setvar "OSMODE" Olmode)
  (princ)
)

(defun NSG2D (P1 P2 P / D D1 D2 DH DHZ PT1 PT2 PT3 Z1 Z2 Z3);;;;NOI SUY GIUA 2 DIEM
  (setq pt1 (TachXY P1))
  (setq pt2 (TachXY P2))
  (setq pt3 (TachXY P))
  (setq Z1 (caddr P1))
  (setq Z2 (caddr P2))
  (setq d1 (distance pt1 pt3))
  (setq d2 (distance pt2 pt3))
  (setq d (+ d1 d2))
  (setq dh (- Z2 Z1))
  (setq dhz (* dh (/ d1 d)))
  (setq Z3 (+ Z1 dhz))
  Z3
)




(defun NSN2D (P1 P2 P /	D13 D23	DELTAZ12 DELTAZ13 KC12 KC13 KC23 PT1
	      PT2 PT3 Z3
	     ) ;;;;NOI SUY NGOAI 2 DIEM
  (setq d13 (distance (TachXY P1) (TachXY P)))
  (setq d23 (distance (TachXY P2) (TachXY P)))
  (if (< d13 d23)
    (progn
      (setq pt1 P1)
      (setq pt2 P2)
      (setq pt3 P)
    )
    (progn
      (setq pt1 P2)
      (setq pt2 P1)
      (setq pt3 P)
    )
  )
  (setq KC12 (distance (TachXY Pt1) (TachXY Pt2)))
  (setq KC13 (distance (TachXY Pt1) (TachXY Pt3)))
  (setq KC23 (distance (TachXY Pt2) (TachXY Pt3)))
  (setq DeltaZ12 (- (caddr Pt1) (caddr Pt2)))
  (setq DeltaZ13 (/ (* KC13 DeltaZ12) KC12))
  (setq Z3 (+ (caddr Pt1) DeltaZ13))
  Z3
)





(defun TachXY (Pnt /)
  (setq Pt (list (car Pnt) (cadr Pnt)))
  pt
)





;;;;LAY TOA DO TEXT
(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
  )
)

(defun _layer2 (name colour)
  (if (null (tblsearch "LAYER" name))
    (entmake
      (list
	'(0 . "LAYER")
	'(100 . "AcDbSymbolTableRecord")
	'(100 . "AcDbLayerTableRecord")
	'(70 . 0)
	(cons 2 name)
	(cons 62 colour)
      )
    )
  )
)


(defun MakeText
       (point string Height Ang justify Layer Style Color / Lst)
 ; Ang: Radial
  (setq	Lst	(list '(0 . "TEXT")
		      (cons 10 point)
		      (cons 40 Height)
		      (cons 8
			    (if	Layer
			      Layer
			      (getvar "CLAYER")
			    )
		      )
		      (cons 1 string)
		      (if Ang
			(cons 50 Ang)
		      )
		      (cons 7
			    (if	Style
			      Style
			      (getvar "Textstyle")
			    )
		      )
		      (cons 62
			    (if	Color
			      Color
			      256
			    )
		      )
		)
	justify	(strcase justify)
  )
  (cond
    ((= justify "C")
     (setq Lst (append Lst (list (cons 72 1) (cons 11 point))))
    )
    ((= justify "L")
     (setq
       Lst
	(append Lst (list (cons 72 0) (cons 73 0) (cons 10 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)
)


;;;;KIEM TRA DIEM NAM GIUA 2 DIEM
(defun CheckPntbetween2Pnt
       (P1 P2 P / KC1 KC12 KC2 OBJL_NEW P1A P2A PT VLALINE)
  (setq P1a (TachXY P1))
  (setq P2a (TachXY P2))
  (setq ObjL_New (MakeLine P1a P2a nil nil nil nil nil))
  (setq VlaLine (vlax-ename->vla-object ObjL_New))
  (setq Pt (vlax-curve-getClosestPointTo VlaLine P T))
  (setq KC1 (distance P1a Pt))
  (setq KC2 (distance P2a Pt))
  (setq KC12 (distance P1a P2a))
  (entdel ObjL_New)
  (if (equal (+ KC1 KC2) KC12 0.001)
    (setq KQ 1)
    (setq KQ 2)
  )
  KQ
)

(defun MakeLine	(PT1 PT2 Linetype LTScale Layer Color xdata)
  (entmakex (list '(0 . "LINE")
		  (cons	8
			(if Layer
			  Layer
			  (getvar "Clayer")
			)
		  )
		  (cons	6
			(if Linetype
			  Linetype
			  "bylayer"
			)
		  )
		  (cons	48
			(if LTScale
			  LTScale
			  1
			)
		  )
		  (cons	62
			(if Color
			  Color
			  256
			)
		  )
		  (cons 10 PT1)
		  (cons 11 PT2)
		  (cons	-3
			(if xdata
			  (list xdata)
			  nil
			)
		  )
	    )
  )
)




http://www.mediafire.com/file/c7bxd0xwwi35agh/NOI+SUY+DIEM+DO+CAO.LSP


<<

Filename: 414384_00.lsp
Tác giả: buithengan1
Bài viết gốc: 418386
Tên lệnh: tg
Lisp Đo Chiều Dài Đoạn Thẳng Ghi Lên Text Chọn

Mình có lisp này nhưng ko biết vì sao sử dụng trên cad 2018 bị lỗi. ai biết sửa lỗi giúp mình với cảm ơn nhiều

cad nó báo lỗi này

 

 52064_12312.jpg

(defun C:tg (/ tot_len ss e_name e_record e_type Tkq obn obd)
(while
  (setq tot_len 0.0)

  (setq ss (ssget))

  (if (null ss)

    (exit)

  )

  (while (> (sslength...
>>

Mình có lisp này nhưng ko biết vì sao sử dụng trên cad 2018 bị lỗi. ai biết sửa lỗi giúp mình với cảm ơn nhiều

cad nó báo lỗi này

 

 52064_12312.jpg

(defun C:tg (/ tot_len ss e_name e_record e_type Tkq obn obd)
(while
  (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 "Thay cho so : ")))
(while (= en nil)
(setq en (car (entsel "Thay cho so : ")))
)
(setq elst (entget en))
(setq elstold (assoc 1 elst)) 
(setq elstnew (cons 1 (rtos tot_len 2 2)))
(setq elst (subst elstnew elstold elst))
(entmod elst)
(setq elst nil)
(setq dtl nil)
(command "_change" en "" "p" "c" "1" "")
;(START_PG)
	;(setq obd (vlax-ename->vla-object (car (nentsel "\nChon text ghi chieu dai"))))
	;(vla-put-textstring obd (rtos tot_len 2 2))
;(END_PG)
  ;(princ)
  )
  )
;;;;;
  

<<

Filename: 418386_tg.lsp
Tác giả: q288
Bài viết gốc: 61115
Tên lệnh: ar ar2 vd
Viết Lisp theo yêu cầu


Code của bạn bị lỗi về vùng nhìn, do k biết cái boundary của bạn to nhỏ thế nào nên đành phải zoom toàn bộ bản vẽ lên.
Còn về osnap thì nếu ct chạy suông sẻ osnap vẫn trở về như lúc trước khi chạy ct.
Mình sửa ct của bạn như sau: (vẫn giữ nguyên lệnh của bạn, chỉ thêm mấy dòng zoom và mấy chỗ có osmode)


Filename: 61115_ar_ar2_vd.lsp
Tác giả: q288
Bài viết gốc: 61564
Tên lệnh: ar ar2 vd
Viết Lisp theo yêu cầu


Lần này k xong thì mình cũng pótay.com luôn.


Filename: 61564_ar_ar2_vd.lsp

Trang 219/303

219