- page 148

Info

File

Tác giả: ro88
Bài viết gốc: 224680
Tên lệnh: van van

{Nhờ chỉnh sửa}Lisp phun điểm tọa độ lên Cad

;----------------------------------------------------------------------------
;;; COMMAND: RD
;;; This command read datafile & draw line with elevation
;;; Datafile structure : North East Height
;----------------------------------------------------------------------------
(if (not ai_utils)(load "ai_utils"))
(if (not my_utils)(load "my_utils"))

Download lisp

Filename: 224680_van_van.lsp

Tác giả: hiepttr
Bài viết gốc: 270155
Tên lệnh: tkt

lisp tính tổng chiều dài các line hay pline

Rảnh nên làm bậy, bác Bình đừng quở nhé ! :D

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/3778-lisp-tinh-tong-chieu-dai-cac-line-hay-pline/
;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Sua theo yeu cau cua Khang (Cadviet) de thong ke thep co cong them doan noi = 30\40*d khi Lthanh >1170mm, luu y ham add_mline ko sua vi thep thuong ko ve bang mline

(defun add_mline ()
(foreach e_record_sub...
>>

Rảnh nên làm bậy, bác Bình đừng quở nhé ! :D

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/3778-lisp-tinh-tong-chieu-dai-cac-line-hay-pline/
;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Sua theo yeu cau cua Khang (Cadviet) de thong ke thep co cong them doan noi = 30\40*d khi Lthanh >1170mm, luu y ham add_mline ko sua vi thep thuong ko ve bang mline

(defun add_mline ()
(foreach e_record_sub e_record
(cond ((= 10 (car e_record_sub))
(setq pt1 (cdr e_record_sub)
mline_len 0.0
)
)
((= 11 (car e_record_sub))
(setq pt2 (cdr e_record_sub)
mline_len (+ mline_len (distance pt2 pt1))
pt1 pt2
)
)
)
)
(setq tot_len (+ tot_len mline_len))
(ssdel e_name ss)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Doi ten lenh thanh TKT = thong ke thep de khoi lan lon !


(defun C:TKT (/ tot_len ss e_name e_record e_type dk hs len_i)
(princ "\nCADViet.com © 2007")
(setq cmd (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq tot_len 0.0)
(setq ss (ssget))
(initget 1)
(setq dk (getreal "\nNhap duong kinh thanh thep (mm): "))
(initget 1 "30d 40d")
(setq hs (atof (getkword "\nNhap chieu dai doan noi <30d/40d>: ")))
(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 len_i (getvar "PERIMETER"))
(setq len_i (+ (* hs dk (fix (/ len_i 1170))) len_i))
(setq tot_len (+ tot_len len_i))
(ssdel e_name ss)
)
((wcmatch e_type "MLINE") (add_mline))
(e_type (ssdel e_name ss))
)
)
(prompt (strcat "\nTong chieu dai thep (da tinh phan moi noi): " (rtos tot_len 2 2)))
(princ)
)
(setvar "cmdecho" cmd)
(princ)

Download lisp

Filename: 270155_tkt.lsp

Tác giả: Doan Van Ha
Bài viết gốc: 270313
Tên lệnh: ha

đo chiều dài đường cong tại hai điểm bất kỳ

Anh có thể cho xuất ra text sẵn có và đổi thành màu đỏ được ko ạ?

Đây bạn.

(defun C:HA( / obj1 obj2 p1 p2)
 (vl-load-com)
 (setq obj1 (car (entsel "\nChon duong cong: "))
       p1 (getpoint "\nP1: ")
  p2 (getpoint p1 "\nP2: ")
       obj2 (vlax-ename->vla-object (car (entsel...
>>

Anh có thể cho xuất ra text sẵn có và đổi thành màu đỏ được ko ạ?

Đây bạn.

(defun C:HA( / obj1 obj2 p1 p2)
 (vl-load-com)
 (setq obj1 (car (entsel "\nChon duong cong: "))
       p1 (getpoint "\nP1: ")
  p2 (getpoint p1 "\nP2: ")
       obj2 (vlax-ename->vla-object (car (entsel "\nChon text: "))))
 (vla-put-TextString obj2 (rtos (abs (- (vlax-curve-getDistAtPoint obj1 p1) (vlax-curve-getDistAtPoint obj1 p2))) 2))
 (vla-put-Color obj2 1)
 (princ))

Download lisp

Filename: 270313_ha.lsp

Tác giả: quansla
Bài viết gốc: 270278
Tên lệnh: bienda1

Sửa lisp xuất tọa độ Pline

bạn, mình đã sửa lại lisp Pline nhé, "CSV" để mình nghiên cứu thêm, hay bác Hà có thể sửa lại ngay trong Code được không ah, Thanks bác

List Pline
(tên lệnh bienda1)

(defun c:bienda1 (/ dt tenfile f lst lst2 i ls )
(vl-load-com)
(while (and(setq dt (ssget '((0 . "LWPOLYLINE"))))
(setq tenfile (getfiled "\nChon ten file" "" "csv" 1)))

(setq dt (ssname dt 0))
(setq f (open tenfile "w"))
(setq lst (acet-geom-vertex-list...

Download lisp

Filename: 270278_bienda1.lsp

Tác giả: quansla
Bài viết gốc: 270278
Tên lệnh: bienda2

Sửa lisp xuất tọa độ Pline

Download lisp

Filename: 270278_bienda2.lsp

Tác giả: quansla
Bài viết gốc: 270523
Tên lệnh: thunghiem

lisp đánh số thứ tự khung tên này. Thanks all!

Dùng tạm trước khi tìm thấy của Bác Hà nhé bạn
Tên lệnh Thunghiem (đặt lại nếu muón nhé)

(defun c:thunghiem(/ ss x y px py j i xuly NumBe )
(setq text 1)
(defun xuly(text /)
(if (< text 10) (strcat "0" (rtos text 2 0)) (rtos text 2 0)))
(vl-load-com)
(setq ss (acet-ss-to-list(ssget '(( 0 . "insert")(2 . "BB3")))))
(setq ss (vl-sort ss '(lambda (x y)
(if (not (equal
(cadr (setq px...

Download lisp

Filename: 270523_thunghiem.lsp

Tác giả: huunhantvxdts
Bài viết gốc: 270572
Tên lệnh: rdt

[Đã xong]Rải đối tượng theo đường dẫn Dynamic

Chức năng rải đối tượng theo đường dẫn thì có nhiều cách, nhiều lisp.
Lisp của bác Duy thì có nhiều chứng năng, đáp ứng đầy đủ yêu cầu người dùng.
hochoaivandot xin post thêm 1 lisp nữa. Lisp này chỉ được cái là nó Dynamic nên vui vui mắt thôi.
Mình không theo dõi diễn đàn nhiều sợ đã có người...
>>

Chức năng rải đối tượng theo đường dẫn thì có nhiều cách, nhiều lisp.
Lisp của bác Duy thì có nhiều chứng năng, đáp ứng đầy đủ yêu cầu người dùng.
hochoaivandot xin post thêm 1 lisp nữa. Lisp này chỉ được cái là nó Dynamic nên vui vui mắt thôi.
Mình không theo dõi diễn đàn nhiều sợ đã có người post lisp như thế này rồi. Nếu trùng lặp thì các mod xoá topic giúp nhé.

(defun LM:PolyCentroid ( e / l )
(foreach x (setq e (entget e))
(if (= 10 (car x)) (setq l (cons (cdr x) l)))
)
(
(lambda ( a )
(if (not (equal 0.0 a 1e-8))
(trans
(mapcar '/
(apply 'mapcar
(cons '+
(mapcar
(function
(lambda ( a b )
(
(lambda ( m )
(mapcar
(function
(lambda ( c d ) (* (+ c d) m))
)
a b
)
)
(- (* (car a) (cadr B)) (* (car B) (cadr a)))
)
)
)
l (cons (last l) l)
)
)
)
(list a a)
)
(cdr (assoc 210 e)) 0
)
)
)
(* 3.0
(apply '+
(mapcar
(function
(lambda ( a b )
(- (* (car a) (cadr B)) (* (car B) (cadr a)))
)
)
l (cons (last l) l)
)
)
)
)
)
(defun LM:SSBoundingBox ( ss / i l1 l2 ll ur )
(repeat (setq i (sslength ss))
(vla-getboundingbox (vlax-ename->vla-object (ssname ss (setq i (1- i)))) 'll 'ur)
(setq l1 (cons (vlax-safearray->list ll) l1)
l2 (cons (vlax-safearray->list ur) l2)
)
)
(mapcar '(lambda ( a b ) (apply 'mapcar (cons a B))) '(min max) (list l1 l2))
)
(defun GetCenterSs (ss / bb e kq)
(setq bb (LM:SSBoundingBox ss))
(setq e (entmakex
(list
(cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 4)
(cons 70 1)
(list 10 (caar bb) (cadar bb))
(list 10 (caadr bb) (cadar bb))
(list 10 (caadr bb) (cadadr bb))
(list 10 (caar bb) (cadadr bb))
)
))
(if e (setq kq (LM:PolyCentroid e)))
(entdel e)
kq
)
(defun ss-union ( s1 s2 / si )
(cond
( (null s1) s2)
( (null s2) s1)
( t
(repeat (setq si (sslength s1))
(ssadd (ssname s1 (setq si (1- si))) s2)
)
s2
)
)
)
(defun dxf (code e) (cdr (assoc code (entget e))))
(defun ss2ent(ss / sodt index lstent ent)
(setq
sodt (if ss (sslength ss) 0)
index 0
)
(repeat sodt
(setq
ent (ssname ss index)
index (1+ index)
lstent (cons ent lstent)
)
)
(reverse lstent)
)
(defun MakeLine (PT1 PT2 Layer Color)
(entmakex (list '(0 . "LINE")
(cons 8 (if Layer Layer (getvar "Clayer")))
(cons 62 (if Color Color 256))
(cons 10 PT1) (cons 11 PT2))))
(defun InsertObjTanCurve(en ss_Obj pt_iso pt / obj_en pt_iso_vla pt_vla att ss e obj newobj)
(setq
obj_en (vlax-ename->vla-object en)
pt_iso_vla (vlax-3D-point pt_iso)
pt_vla (vlax-3D-point pt)
)
(setq att (angle pt (polar pt (angle '(0 0 0) (vlax-curve-getFirstDeriv obj_en (vlax-curve-getParamAtPoint obj_en pt))) 2)))
(setq ss (ssadd))
(repeat (setq n (sslength ss_Obj))
(setq e (ssname ss_Obj (setq n (1- n))))
(setq obj (vlax-ename->vla-object e))
(setq newobj (vla-copy obj))
(vla-move newobj pt_iso_vla pt_vla)
(vla-rotate newobj pt_vla att)
(setq ss (ssadd (vlax-vla-object->ename newobj) ss))
)
ss
)
(defun GetDir (en pt1 pt2 / dis1 dis2 dis)
(setq
dis1 (vlax-curve-getDistAtPoint en pt1)
dis2 (vlax-curve-getDistAtPoint en pt2)
dis (- dis2 dis1)
)
(if (/= dis 0) (/ dis (abs dis)) 1)
)
(defun MeDyn (en ss_Obj ptiso pt1 dis ptcuoi / ss dis1 disn sumdis dir time i pt obj1 obj_en ss_obj1)
(setvar "osmode" 0)
(setq
ss (ssadd)
obj_en (vlax-ename->vla-object en)
dis1 (vlax-curve-getDistAtPoint obj_en pt1)
disn (vlax-curve-getDistAtPoint obj_en ptcuoi)
sumdis (- disn dis1)
dir (if (/= sumdis 0) (/ sumdis (abs sumdis)) 1)
time (if (/= sumdis 0) (1+ (fix (/ (abs sumdis) dis))) 1)
i 0
)
(repeat time
(setq
pt (vlax-curve-getPointAtDist obj_en (+ dis1 (* i dis dir)))
ss_obj1 (InsertObjTanCurve en ss_Obj ptiso pt)
)
(setq ss (ss-union ss ss_obj1))
(setq i (1+ i))
)
ss
)
(defun ST:SS->List-Vla (ss / n e l)
(setq n (sslength ss))
(while (setq e (ssname ss (setq n (1- n))))
(setq l (cons (vlax-ename->vla-object e) l))
)
)
(defun ST:Ss-Delete (ss / i)
(mapcar 'vla-delete (ST:SS->List-Vla ss))
)
(defun GetMid (pt1 pt2) (polar pt1 (angle pt1 pt2) (* 0.5 (distance pt1 pt2))))
(defun C:rdt(/ en obj_en ss_Obj ptiso data dir dis dis1 dis2 e err gr gr_fl n nmax nx oldos pt1 pt2 ptcuoi ptisodef ss1 temperr txt)
(defun Bdraw()
(setq OldOs (getvar "osmode"))
(setvar "osmode" 15359)
(setvar "cmdecho" 0)
(setvar "INSUNITS" 0)
(setq temperr *error*)
(setq *error* err)
)
(defun Edraw()
(setvar "cmdecho" 1)
(if OldOs (setvar "osmode" OldOs))
(if temperr (setq *error* temperr))
(princ)
)
(defun err (msg)
(if OldOs (setvar "osmode" OldOs))
(setvar "cmdecho" 1)
(if ss1 (ST:ss-delete ss1))
(if temperr (setq *error* temperr))
)
(Bdraw)
(setq en (car (entsel "\nTim")))
(setq obj_en (vlax-ename->vla-object en))
(setq ss_Obj (ssget) n (sslength ss_Obj))
(cond
((and (= n 1) (= (dxf 0 (setq e (ssname ss_Obj 0))) "INSERT")) (setq ptisoDef (dxf 10 e) txt "<Diem chen Block>"))
((and (= n 1) (= (dxf 0 (setq e (ssname ss_Obj 0))) "*TEXT")) (setq ptisoDef (dxf 10 e) txt "<Diem chen Text>"))
((and (= n 1) (= (dxf 0 (setq e (ssname ss_Obj 0))) "LINE")) (setq ptisoDef (GetMid (dxf 10 e) (dxf 11 e)) txt "<Diem giua Line>"))
(t (setq ptisoDef (GetCenterSs ss_Obj) txt "<Tam cua doi tuong>"))
)
(setq ptiso (getpoint (strcat "\nBase point" txt)))
(if (not ptiso) (setq ptiso ptisoDef))
(setq
ss1 nil
pt1 (vlax-curve-getClosestPointTo en (getpoint "Diem goc"))
pt2 (vlax-curve-getClosestPointTo en (getpoint pt1 "diem tiep"))
dis1 (vlax-curve-getDistAtPoint en pt1)
dis2 (vlax-curve-getDistAtPoint en pt2)
dis (abs (- dis1 dis2))
)
(prompt "\nPick \U+0111i\U+1EC3m cu\U+1ED1i:")
(while
(progn
(setq
gr (grread t 15 0)
gr_fl (car gr)
data (cadr gr)
)
(cond
((and (= 5 gr_fl) (listp data))
(progn
(if ss1 (ST:Ss-Delete ss1))
(setq ss1 (MeDyn en ss_Obj ptiso pt1 dis (vlax-curve-getClosestPointTo en data)))
)
t
)
((= 2 gr_fl)
(cond
((vl-position data '(78 110)) ; C/c Curve Aligned
(progn

(if ss1 (ST:Ss-Delete ss1))
(if (not dir) (setq dir (GetDir en pt1 pt2)))
(setq
nmax (fix (abs (/ (- (abs (- (vlax-curve-getDistAtParam en (vlax-curve-getStartParam en)) (vlax-curve-getDistAtParam en (vlax-curve-getEndParam en)))) dis1) dis dir)))
nx (getint (strcat "Copy m\U+1EA5y l\U+1EA7n <Max:" (itoa nmax) ">:"))
)
(if (not nx) (setq nx nmax))
(setq ptcuoi (vlax-curve-getPointAtDist en (+ dis1 (* nx dis dir))))
(MeDyn en ss_Obj ptiso pt1 dis ptcuoi)
)
))
nil
)
((and (= 3 gr_fl) (listp data))
(progn
(if ss1 (ST:Ss-Delete ss1))
(setq ss1 (MeDyn en ss_Obj ptiso pt1 dis (vlax-curve-getClosestPointTo en data)))
)
nil
)
)
)
)
(Edraw)
)

Mình đang sử dụng lisp này để viết ứng dụng rải hố ga đang bị vướng mắc nhờ mọi người giúp đỡ.

ở đây mình chỉ sử dụng rải đối tượng là 1 Block thôi nên muốn công tác chọn đối tượng để rải chỉ 1 lần nghĩa là muốn thay hàm ssget bằng hàm entsel

Đoạn lisp cần giúp đỡ

(setq en (car (entsel "\nTim")))

(setq obj_en (vlax-ename->vla-object en))

Lisp cũ
(setq ss_Obj (ssget))

muốn thay

(setq ss_Obj (entsel "\nChon Block ho ga"))

Đây là lisp mình đã sửa lại

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/71521-da-xong-rai-doi-tuong-theo-duong-dan-dynamic/

 (defun LM:PolyCentroid ( e / l )
(foreach x (setq e (entget e))
(if (= 10 (car x)) (setq l (cons (cdr x) l)))
)
(
(lambda ( a )
(if (not (equal 0.0 a 1e-8))
(trans
(mapcar '/
(apply 'mapcar
(cons '+
(mapcar
(function
(lambda ( a b )
(
(lambda ( m )
(mapcar
(function
(lambda ( c d ) (* (+ c d) m))
)
a b
)
)
(- (* (car a) (cadr B)) (* (car B) (cadr a)))
)
)
)
l (cons (last l) l)
)
)
)
(list a a)
)
(cdr (assoc 210 e)) 0
)
)
)
(* 3.0
(apply '+
(mapcar
(function
(lambda ( a b )
(- (* (car a) (cadr B)) (* (car B) (cadr a)))
)
)
l (cons (last l) l)
)
)
)
)
)
(defun LM:SSBoundingBox ( ss / i l1 l2 ll ur )
(repeat (setq i (sslength ss))
(vla-getboundingbox (vlax-ename->vla-object (ssname ss (setq i (1- i)))) 'll 'ur)
(setq l1 (cons (vlax-safearray->list ll) l1)
l2 (cons (vlax-safearray->list ur) l2)
)
)
(mapcar '(lambda ( a b ) (apply 'mapcar (cons a B))) '(min max) (list l1 l2))
)
(defun GetCenterSs (ss / bb e kq)
(setq bb (LM:SSBoundingBox ss))
(setq e (entmakex
(list
(cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 4)
(cons 70 1)
(list 10 (caar bb) (cadar bb))
(list 10 (caadr bb) (cadar bb))
(list 10 (caadr bb) (cadadr bb))
(list 10 (caar bb) (cadadr bb))
)
))
(if e (setq kq (LM:PolyCentroid e)))
(entdel e)
kq
)
(defun ss-union ( s1 s2 / si )
(cond
( (null s1) s2)
( (null s2) s1)
( t
(repeat (setq si (sslength s1))
(ssadd (ssname s1 (setq si (1- si))) s2)
)
s2
)
)
)
(defun dxf (code e) (cdr (assoc code (entget e))))
(defun ss2ent(ss / sodt index lstent ent)
(setq
sodt (if ss (sslength ss) 0)
index 0
)
(repeat sodt
(setq
ent (ssname ss index)
index (1+ index)
lstent (cons ent lstent)
)
)
(reverse lstent)
)
(defun MakeLine (PT1 PT2 Layer Color)
(entmakex (list '(0 . "LINE")
(cons 8 (if Layer Layer (getvar "Clayer")))
(cons 62 (if Color Color 256))
(cons 10 PT1) (cons 11 PT2))))
(defun InsertObjTanCurve(en ss_Obj pt_iso pt / obj_en pt_iso_vla pt_vla att ss e obj newobj)
(setq
obj_en (vlax-ename->vla-object en)
pt_iso_vla (vlax-3D-point pt_iso)
pt_vla (vlax-3D-point pt)
)
(setq att (angle pt (polar pt (angle '(0 0 0) (vlax-curve-getFirstDeriv obj_en (vlax-curve-getParamAtPoint obj_en pt))) 2)))
(setq ss (ssadd))
(repeat (setq n (sslength ss_Obj))
(setq e (ssname ss_Obj (setq n (1- n))))
(setq obj (vlax-ename->vla-object e))
(setq newobj (vla-copy obj))
(vla-move newobj pt_iso_vla pt_vla)
(vla-rotate newobj pt_vla att)
(setq ss (ssadd (vlax-vla-object->ename newobj) ss))
)
ss
)
(defun GetDir (en pt1 pt2 / dis1 dis2 dis)
(setq
dis1 (vlax-curve-getDistAtPoint en pt1)
dis2 (vlax-curve-getDistAtPoint en pt2)
dis (- dis2 dis1)
)
(if (/= dis 0) (/ dis (abs dis)) 1)
)
(defun MeDyn (en ss_Obj ptiso pt1 dis ptcuoi / ss dis1 disn sumdis dir time i pt obj1 obj_en ss_obj1)
(setvar "osmode" 0)
(setq
ss (ssadd)
obj_en (vlax-ename->vla-object en)
dis1 (vlax-curve-getDistAtPoint obj_en pt1)
disn (vlax-curve-getDistAtPoint obj_en ptcuoi)
sumdis (- disn dis1)
dir (if (/= sumdis 0) (/ sumdis (abs sumdis)) 1)
time (if (/= sumdis 0) (1+ (fix (/ (abs sumdis) dis))) 1)
i 0
)
(repeat time
(setq
pt (vlax-curve-getPointAtDist obj_en (+ dis1 (* i dis dir)))
ss_obj1 (InsertObjTanCurve en ss_Obj ptiso pt)
)
(setq ss (ss-union ss ss_obj1))
(setq i (1+ i))
)
ss
)
(defun ST:SS->List-Vla (ss / n e l)
(setq n (sslength ss))
(while (setq e (ssname ss (setq n (1- n))))
(setq l (cons (vlax-ename->vla-object e) l))
)
)
(defun ST:Ss-Delete (ss / i)
(mapcar 'vla-delete (ST:SS->List-Vla ss))
)
(defun GetMid (pt1 pt2) (polar pt1 (angle pt1 pt2) (* 0.5 (distance pt1 pt2))))
(defun C:rdt(/ en ent obj_en ss_Obj ptiso data dir dis dis1 dis2 e err gr gr_fl n nmax nx oldos pt1 pt2 ptcuoi ptisodef ss1 temperr txt)
(defun Bdraw()
(setq OldOs (getvar "osmode"))
(setvar "osmode" 15359)
(setvar "cmdecho" 0)
(setvar "INSUNITS" 0)
(setq temperr *error*)
(setq *error* err)
)
(defun Edraw()
(setvar "cmdecho" 1)
(if OldOs (setvar "osmode" OldOs))
(if temperr (setq *error* temperr))
(princ)
)
(defun err (msg)
(if OldOs (setvar "osmode" OldOs))
(setvar "cmdecho" 1)
(if ss1 (ST:ss-delete ss1))
(if temperr (setq *error* temperr))
)
(Bdraw)
(setq en (car (entsel "\nDuong tim cong:")))
(setq obj_en (vlax-ename->vla-object en))
;(setq ent (car (entsel "\nChon Block ho ga:")))
(prompt "\nChon Block ho ga:")
(setq ss_Obj (ssget))
;(setq ss_Obj (vlax-ename->vla-object ent))
;(setq ptisoDef (dxf 10 ent))
(setq e (ssname ss_Obj 0))
(setq ptiso (dxf 10 e))
(setq
ss1 nil
pt1 (vlax-curve-getClosestPointTo en (getpoint "\nDiem goc")))
(initget 1 "D K")
(setq luachon (getkword "\nLua chon phuong phap rai pick diem tiep theo/Khoang cach rai:<D or K>"))
(if (or (= luachon "D") (= luachon "d"))
(progn
(setq
pt2 (vlax-curve-getClosestPointTo en (getpoint pt1 "\nDiem tiep theo"))
dis1 (vlax-curve-getDistAtPoint en pt1)
dis2 (vlax-curve-getDistAtPoint en pt2)
dis (abs (- dis1 dis2))
)
)
(setq dis (getreal "\nKhoang cach rai:"))
)
(prompt "\nPick diem cuoi:")
(while
(progn
(setq
gr (grread t 15 0)
gr_fl (car gr)
data (cadr gr)
)
(cond
((and (= 5 gr_fl) (listp data))
(progn
(if ss1 (ST:Ss-Delete ss1))
(setq ss1 (MeDyn en ss_Obj ptiso pt1 dis (vlax-curve-getClosestPointTo en data)))
)
t
)
((= 2 gr_fl)
(cond
((vl-position data '(78 110)) ; C/c Curve Aligned
(progn

(if ss1 (ST:Ss-Delete ss1))
(if (not dir) (setq dir (GetDir en pt1 pt2)))
(setq
nmax (fix (abs (/ (- (abs (- (vlax-curve-getDistAtParam en (vlax-curve-getStartParam en)) (vlax-curve-getDistAtParam en (vlax-curve-getEndParam en)))) dis1) dis dir)))
nx (getint (strcat "Copy m\U+1EA5y l\U+1EA7n <Max:" (itoa nmax) ">:"))
)
(if (not nx) (setq nx nmax))
(setq ptcuoi (vlax-curve-getPointAtDist en (+ dis1 (* nx dis dir))))
(MeDyn en ss_Obj ptiso pt1 dis ptcuoi)
)
))
nil
)
((and (= 3 gr_fl) (listp data))
(progn
(if ss1 (ST:Ss-Delete ss1))
(setq ss1 (MeDyn en ss_Obj ptiso pt1 dis (vlax-curve-getClosestPointTo en data)))
)
nil
)
)
)
)
(Edraw)
)

Download lisp

Filename: 270572_rdt.lsp

Tác giả: phamthanhbinh
Bài viết gốc: 107028
Tên lệnh: chsize

Viết lisp theo yêu cầu [phần 2]

Bạn xài thử cái này và hãy so sánh nó với cái trước để tìm sự khác biệt trong đó bạn nhé. Mình cũng chỉ xào nấu lại thôi mà. Gia vị thì cứ tùy miệng thôi. Hề hề hề....

PS: Vì là xào nấu lại nên vẫn còn những tàn dư của code cũ mà mình chưa sửa vì nó không ảnh hưởng gì nhiều tới kết quả. Rất mong bạn cố gắng xử lý nốt các thằng vô tích sự ấy nhé.

Download lisp

Filename: 107028_chsize.lsp

Tác giả: ketxu
Bài viết gốc: 270947
Tên lệnh: mt2p

viết Lisp dời text về vị trí điểm point gần nhất

Ket đang rất mệt, nên code nhanh cho bạn như vầy thôi, hi vọng bạn dùng đc. Nếu lỗi đâu bạn nhờ các bác khác nhá ^^. Lần sau nếu có yêu CV xin đừng thay tên đổi họ nhiều quá ^^

(defun c:mt2p(/ lst lstData lstT lstP p)
	(and
		(setq ss (ssget (list (cons 0 "TEXT,POINT"))))
		(setq lstData (mapcar 'entget (acet-ss-to-list ss)))
		(foreach e lstData (if (= (cdadr e) "TEXT") (setq lstT (cons e lstT))(setq...
>>

(defun c:mt2p(/ lst lstData lstT lstP p)
	(and
		(setq ss (ssget (list (cons 0 "TEXT,POINT"))))
		(setq lstData (mapcar 'entget (acet-ss-to-list ss)))
		(foreach e lstData (if (= (cdadr e) "TEXT") (setq lstT (cons e lstT))(setq lstP (cons e lstP))))
	)
	(foreach oT lstT
		(setq p (acet-dxf 11 oT))
		(setq lstP (vl-sort lstP '(lambda(x y)(< (distance (acet-dxf 10 x) p)(distance (acet-dxf 10 y) p)))))
		(entmod (append oT (list (cons 11 (acet-dxf 10 (car lstP))))))
		(setq lstP (cdr lstP))
	)
)

Download lisp

Filename: 270947_mt2p.lsp

Tác giả: phamthanhbinh
Bài viết gốc: 271068
Tên lệnh: movt

viết Lisp dời text về vị trí điểm point gần nhất

Ok. Đúng ý của mình rồi. Cảm ơn Bác Ket nhiều nhé! Bác Ket nhiệt tình thật, Cảm ơn bác nhiều!

Hề hề hề,

Dựa trên cái lisp của bác Ketxu, mình sửa lại một chút, hy vọng lisp sẽ chạy nhanh hơn khi bản vẽ có nhiều text và point cần hiệu chỉnh.

>>

Ok. Đúng ý của mình rồi. Cảm ơn Bác Ket nhiều nhé! Bác Ket nhiệt tình thật, Cảm ơn bác nhiều!

Hề hề hề,

Dựa trên cái lisp của bác Ketxu, mình sửa lại một chút, hy vọng lisp sẽ chạy nhanh hơn khi bản vẽ có nhiều text và point cần hiệu chỉnh.

(defun c:movt (/ oldos sslst box polst p)
(vl-load-com)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(command "undo" "be")
(setq sslst (mapcar 'entget (acet-ss-to-list (ssget (list (cons 0 "text"))))))
(foreach e sslst
(setq box (acet-ent-geomextents (cdr (assoc -1 e)))
polst (mapcar 'entget (acet-ss-to-list (ssget "c" (car box) (cadr box) (list (cons 0 "point")))))
p (cdr (assoc 11 e))  )
(if polst
 (progn
(setq polst (vl-sort polst '(lambda (x y) (< (distance (cdr (assoc 10 x)) p) (distance (cdr (assoc 10 y)) p))))  )
 (entmod (subst (cons 11 (cdr (assoc 10 (car polst)))) (assoc 11 e) e) )
 )
)
)
(command "undo" "e")
(setvar "osmode" oldos)
(princ)
)

(vl-load-com)

(setq oldos (getvar "osmode"))

Download lisp

Filename: 271068_movt.lsp

Tác giả: tvgtyb08
Bài viết gốc: 136577
Tên lệnh: menutvgtyb08

Mình muốn chuyển từ *.lsp sang *.vlxthi làm the nao?

Các anh ơi chuyển giúp em lisp này sang VLX với, em chuyển nó toàn báo lỗi và ra định dạng *.PRV

Download lisp

Filename: 136577_menutvgtyb08.lsp

Tác giả: phamthanhbinh
Bài viết gốc: 271191
Tên lệnh: vhhmd

Nhờ viết lisp vẽ thống kê hư hỏng cục bộ mặt đường

mọi người bớt chút thời gian giúp em với ạ :mellow: . Cảm ơn

Hề hề hề,

Thiệt tình là mình chả muốn làm cái ni do chả hiểu hết ý bạn. Song thấy bạn cần nên đành đoán mò theo hình vẽ mà làm vậy.

Đây chỉ là bản nháp nên có thể chưa đúng ý bạn, bạn có thể tự chỉnh lại về...

mọi người bớt chút thời gian giúp em với ạ :mellow: . Cảm ơn

Hề hề hề,

Thiệt tình là mình chả muốn làm cái ni do chả hiểu hết ý bạn. Song thấy bạn cần nên đành đoán mò theo hình vẽ mà làm vậy.

Đây chỉ là bản nháp nên có thể chưa đúng ý bạn, bạn có thể tự chỉnh lại về kiểu hatch cũng như màu sắc mà bạn muốn.

Bạn hãy dùng thử coi đã ưng cái bụng chưa nhé. Nếu chưa ưng thì post lên nói rõ vì sao chưa ưng. Cố gắng trình bày cho rõ ràng để may ra mình có thể hiểu mà sửa theo ý bạn.

(defun c:vhhmd (/ oldos p h e e1 olcol fn f dlst ln lst)
(vl-load-com)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(command "undo" "be")
(setq p (getpoint "\n Chon diem bat dau ve")
          h (getreal "\n Nhap chieu rong mat duong: ") )
(if (not h) (setq h 7))
(command "line" p (polar p 0 100) "")
(setq e (entlast))
(command "copy" e "" p (polar p (/ pi 2) h))
(if (not (tblsearch "ltype" "center2"))
    (command "linetype" "l" "center2" "")
)
(command "linetype" "s" "center2" "")
(setq olcol (getvar "cecolor"))
(setvar "cecolor" "6")
(command "line" (polar p (/ pi 2) (/ h 2.0)) (list (+ (car p) 100) (+ (cadr p) (/ h 2.0))) "")
(setvar "cecolor" olcol)
(command "linetype" "s" "bylayer" "")
(setq  fn (getfiled "Select Data File" "" "txt" 0)
            f (open fn "r")
            dlst (list)
)
(while (setq ln (read-line f))
      (setq dlst (append dlst (list ln)))
)
(foreach d dlst
    (setq lst (separate d "\t"))
    (command "rectangle" (list (+ (car p) (atof (nth 0 lst))) (+ (cadr p) (atof (nth 2 lst))))
                                           (list (+ (car p) (atof (nth 1 lst))) (+ (cadr p) (atof (nth 2 lst)) (atof (nth 3 lst))))  )
    (setq e1 (entlast))
    (if (= (nth 4 lst) "1")
         (command "hatch" "ansi31" 10 0 e1 "")
         (command "hatch" "ansi31" 10 90 e1 "")
    )
   (command "text" "j" "mc" (list (+ (car p) (/ (abs (- (atof (nth 0 lst)) (atof (nth 1 lst)))) 2) (atof (nth 0 lst))) 
                                                      (+ (cadr p) (atof (nth 2 lst)) (/ (atof (nth 3 lst)) 2))) 1 0
                                                      (strcat (nth 3 lst) " x " (rtos (abs (- (atof (nth 0 lst)) (atof (nth 1 lst)))) 2 0)))
    (if (<= (atof (nth 2 lst)) (/ h 2))
        (progn
              (command "text" "j" "mc" (list (+ (car p) (atof (nth 0 lst))) (- (cadr p) 2)) 1 270 (nth 0 lst))
              (command "text" "j" "mc" (list (+ (car p) (atof (nth 1 lst))) (- (cadr p) 2)) 1 270 (nth 1 lst))
        )
        (progn
              (command "text" "j" "mc" (list (+ (car p) (atof (nth 0 lst))) (+ (cadr p) h 2)) 1 270 (nth 0 lst))
              (command "text" "j" "mc" (list (+ (car p) (atof (nth 1 lst))) (+ (cadr p) h 2)) 1 270 (nth 1 lst))
        )
    )
)
(command "undo" "e")
(setvar "osmode" oldos)
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun Separate (S sym / i L ch)
(setq i 0 L nil)
(while (< i (strlen S))
 (setq i (1+ i) ch (substr S i 1))
 (if (= ch sym) (progn
(setq
     L (append L (list (substr S 1 (- i 1))))
     S (substr S (1+ i) (- (strlen S) i))
     i 0
)
      )) 
)
(append L (list S))
)

Download lisp

Filename: 271191_vhhmd.lsp

Tác giả: Nguyen Hoanh
Bài viết gốc: 19430
Tên lệnh: ht

Viết Lisp theo yêu cầu

Chẳng hiểu bạn cần lisp gì.
file dwg này không nói lên điều gì giống với:
Trên diễn đàn đã có đoạn list nối các điểm chèn text bằng các đoạn thẳng. Trên cơ sở ý tưởng đó các Bác cải tiến lại giúp em lệnh Copy 1 đối tượng có sãn vào các điểm chèn text.
Trên màn hình có các đối tượng là text có ghi các mã điểm (mã điểm có thể định dạng theo: 001, 002, 003 hoặc...

Download lisp

Filename: 19430_ht.lsp

Tác giả: HungDHXD
Bài viết gốc: 246759
Tên lệnh: 6

VBA cho AutoCad-Hãy cùng tham gia trao đổi

Mình thấy trong Lisp có hàm ssget ( chọn đối tượng ) --> trong vba không có --> mình thử xây dựng 1 hàm gần giống như kiểu ssget như sau :

Sub ssget()
    Dim ssetObj As AcadSelectionSet
    Dim entity As AcadEntity
        Set ssetObj = ThisDrawing.PickfirstSelectionSet
        If ssetObj.Count Then
            ...........................
        Else
            Set ssetObj =...
>>

Mình thấy trong Lisp có hàm ssget ( chọn đối tượng ) --> trong vba không có --> mình thử xây dựng 1 hàm gần giống như kiểu ssget như sau :

Sub ssget()
    Dim ssetObj As AcadSelectionSet
    Dim entity As AcadEntity
        Set ssetObj = ThisDrawing.PickfirstSelectionSet
        If ssetObj.Count Then
            ...........................
        Else
            Set ssetObj = ThisDrawing.SelectionSets.Add("#")
            If Err <> 0 Then
               Set ssetObj = ThisDrawing.SelectionSets("#"): ssetObj.Clear
            End If
        ssetObj.SelectOnScreen
        ...............................
End Sub

Nếu mà code trên chạy trong môi trường vba thì không vấn đề gì : * thuộc tính pickfirstSelectionset hoạt động bình thường

nhưng nếu ta thử gọi macro trên bằng lisp thì thuộc tính pickfristSelectionset không thể hoạt động : hàm báo lỗi nil

(defun C:6()
      (command "-vbarun" "ssget")
)

---> Mình vẫn chưa tìm ra được nguyên nhân và cách khắc phục, mong các bạn yêu thích vba trong autocad chia sẻ ,trao đổi thêm về vấn để trên !

thanks! <----------- cảm ơn mọi người đã dành thời gian đọc bài viết của mình

Download lisp

Filename: 246759_6.lsp

Tác giả: phamthanhbinh
Bài viết gốc: 53892
Tên lệnh: xdl2

Nhờ các bác Viết Lisp kiểm tra Overlay của Polyline

Chào bạn Truongbv,
Mình mới làm đuợc một phần yêu cầu của bạn là phát hiện và đánh dấu các polyline trùng nhau hoàn toàn. Việc tìm và đánh dấu các polyline trùng nhau một phần khó hơn và mình đang thử làm. Bạn hãy thử đoạn líp này và cho mình biết ý kiến nhé.

Lệnh chạy líp là xdl2 bạn nhé.

Download lisp

Filename: 53892_xdl2.lsp

Tác giả: tdvn
Bài viết gốc: 55218
Tên lệnh: wbreak

muốn chia 1 đoạn cong thành nhiều đoạn cong

Bạn xem thử, ðổi màu cũng ðc nhýng xem ra cũng không hay lắm. Mình thêm point cho bạn

Download lisp

Filename: 55218_wbreak.lsp

Tác giả: phamthanhbinh
Bài viết gốc: 52187
Tên lệnh: ao

Viết Lisp theo yêu cầu

Đây bạn:

Bạn hãy so sánh cái lisp này và cái lisp trước sẽ hiểu cái mình đã hướng dẫn bạn. Nếu bạn làm đúng thì không có chuyện cad không hiểu lệnh AO được bạn a.
Bạn hãy cố gắng tìm hiểu kỹ hơn về lisp và thông qua các đoạn lisp bạn đã có. Cần phải hiểu rõ về các lisp này thì việc ứng dụng và hiệu chỉnh nó mới có hiệu quả cho công việc của bạn....

Download lisp

Filename: 52187_ao.lsp

Tác giả: gia_bach
Bài viết gốc: 66055
Tên lệnh: hatcharea

Em đang học Lisp, nhờ các anh sửa júp em đoạn mã bị lỗi !!!!!

Chào leejang
Từ phiên bản Cad 2006, đối tuợng Hatch mới có thuộc tính Diện tích.
Nếu bạn sử dụng phiên bản Cad 2005 trở về truớc thì pótay.
bạn chạy thử Lisp này (cho phiên bản Cad 2006 đến nay):

Download lisp

Filename: 66055_hatcharea.lsp

Tác giả: hochoaivandot
Bài viết gốc: 272466
Tên lệnh: ttt

help lisp vẽ đường tròn chỉ 1 cái pick

(defun MakeText (point string Height Wid 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 41 Wid)
                                    (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 C:ttt(/ dia disadd pleft pright pup pdown p1)
   (if (not dia0) (setq dia0 30.0))
   (setq dia (getdist (strcat "\nNhap duong kinh: <" (rtos dia0 2 2) ">:")))
   (if (not dia)
       (setq dia dia0)
       (setq dia0 dia)
   )
   (setq disadd (/ dia 10.0))
   (while (setq p1 (getpoint "Pick diem"))
       (setq pleft (polar p1 pi (+ (* 0.5 dia) disadd)))
       (setq pright (polar p1 0 (+ (* 0.5 dia) disadd)))
       (setq pup (polar p1 (/ pi 2) (+ (* 0.5 dia) disadd)))
       (setq pdown (polar p1 (/ pi -2) (+ (* 0.5 dia) disadd)))
       (entmake (list (cons 0 "CIRCLE") (cons 10 p1) (cons 40 (/ dia 2.0))))
       (entmake (list (cons 0 "LINE") (cons 10 pleft) (cons 11 pright)))
       (entmake (list (cons 0 "LINE") (cons 10 pup) (cons 11 pdown)))
       (MakeText p1 (strcat "D" (rtos dia 2 0)) (/ dia 3.0) 0.7 0 "BC" nil nil nil nil)
   )
   (princ "Viet boi hochoaivandot-Cadviet.com")
)

Bạn thử có đúng ý không nhé.

Tên lệnh TTT

Download lisp

Filename: 272466_ttt.lsp

Tác giả: Doan Van Ha
Bài viết gốc: 272792
Tên lệnh: ket ptb dvh

[Yêu cầu] viết Lisp dời text về vị trí điểm point gần nhất

Thể theo y/c của bác PhamThanhBinh và bạn Hochoaihetdot cùng chủ topic, tôi viết lại Lisp này để sử dụng thuận tiện hơn.

Tốc độ tương đương Lisp bác Bình nhưng sẽ không để "lọt lưới".

Đã test trên bản vẽ (đính kèm) gồm 5000 Texts và 5000 Points thì Lisp của tôi và của bác Bình đều mất tầm 15".

Có thể phân mảnh nhỏ dần để tăng tốc độ, nhưng khá rắc rối nên...

Thể theo y/c của bác PhamThanhBinh và bạn Hochoaihetdot cùng chủ topic, tôi viết lại Lisp này để sử dụng thuận tiện hơn.

Tốc độ tương đương Lisp bác Bình nhưng sẽ không để "lọt lưới".

Đã test trên bản vẽ (đính kèm) gồm 5000 Texts và 5000 Points thì Lisp của tôi và của bác Bình đều mất tầm 15".

Có thể phân mảnh nhỏ dần để tăng tốc độ, nhưng khá rắc rối nên làm biếng lắm.

Các bạn test cho vui nhé!

File Cad::

http://www.cadviet.com/upfiles/3/67029_tim_diem_gan_text.dwg

File Lisp (gồm 3 LisP của KET, PTB, DVH):

;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/90291-yeu-cau-viet-lisp-doi-text-ve-vi-tri-diem-point-gan-nhat/
;by Ketxu, khoang 4'15" cho 5000 Texts + 5000 Points.
(defun C:KET(/ lst lstData lstT lstP p)
 (and
  (setq ss (ssget (list (cons 0 "TEXT,POINT"))))
  (setq time (getvar "millisecs"))
  (not (command "undo" "be"))
  (setq lstData (mapcar 'entget (acet-ss-to-list ss)))
  (foreach e lstData
   (if (= (cdadr e) "TEXT")
    (setq lstT (cons e lstT)) (setq lstP (cons e lstP)))))
 (foreach oT lstT
  (setq p (acet-dxf 11 oT))
  (setq lstP (vl-sort lstP '(lambda(x y)(< (distance (acet-dxf 10 x) p)(distance (acet-dxf 10 y) p)))))
  (entmod (append oT (list (cons 11 (acet-dxf 10 (car lstP))))))
  (setq lstP (cdr lstP)))
 (command "undo" "e")
 (setq phut (/ (- (getvar "millisecs") time) 60000.0))
 (princ (strcat "\nThoi gian chay chuong trinh: " (itoa (fix phut)) "'" (itoa (fix (* 60 (- phut (fix phut))))) "\"."))
 (princ))
;by PhamThanhBinh, khoang 15" cho 5000 Texts + 5000 Points.
(defun C:PTB (/ oldos sslst box polst p)
 (setq sslst (mapcar 'entget (acet-ss-to-list (ssget (list (cons 0 "text"))))))
 (setq time (getvar "millisecs"))
 (command "undo" "be")
 (foreach e sslst
  (setq box (acet-ent-geomextents (cdr (assoc -1 e)))
        polst (mapcar 'entget (acet-ss-to-list (ssget "c" (car box) (cadr box) (list (cons 0 "point")))))
        p (cdr (assoc 11 e)))
  (if polst
   (progn
    (setq polst (vl-sort polst '(lambda (x y) (< (distance (cdr (assoc 10 x)) p) (distance (cdr (assoc 10 y)) p)))))
    (entmod (subst (cons 11 (cdr (assoc 10 (car polst)))) (assoc 11 e) e)))))
 (command "undo" "e")
 (setq phut (/ (- (getvar "millisecs") time) 60000.0))
 (princ (strcat "\nThoi gian chay chuong trinh: " (itoa (fix phut)) "'" (itoa (fix (* 60 (- phut (fix phut))))) "\"."))
 (princ))
;by DoanVanHa, khoang 15" cho 5000 Texts + 5000 Points.
(defun C:DVH(/ ss time lst1 lst2 p1 p2 dis lst3 phut)
 (and
  (setq ss (ssget (list (cons 0 "TEXT,POINT"))))
  (setq time (getvar "millisecs"))
  (not (command "undo" "be"))
  (foreach e (mapcar 'entget (acet-ss-to-list ss))
   (if (= (cdadr e) "TEXT")
    (setq lst1 (cons (list (cdr (assoc -1 e)) (cdr (assoc 11 e))) lst1)) (setq lst2 (cons (cdr (assoc 10 e)) lst2))))
  (= (length lst1) (length lst2))
  (foreach n lst1
   (setq ent1 (car n)
         p1 (cadr n)
p2 (car lst2)
lst3 (list ent1 p1 p2 (distance p1 p2)))
   (foreach p2 lst2
    (if (< (setq dis (distance p1 p2)) (cadddr lst3))
     (setq lst3 (list ent1 p1 p2 dis))))
   (entmod (subst (cons 11 (setq p2 (caddr lst3))) (cons 11 (cadr lst3)) (entget (car lst3))))
   (setq lst2 (vl-remove p2 lst2)))
   (not (command "undo" "e")))
 (setq phut (/ (- (getvar "millisecs") time) 60000.0))
 (princ (strcat "\nThoi gian chay chuong trinh: " (itoa (fix phut)) "'" (itoa (fix (* 60 (- phut (fix phut))))) "\"."))
 (princ))

Download lisp

Filename: 272792_ket_ptb_dvh.lsp

Trang 148/330