Jump to content
InfoFile
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"))
>>

;----------------------------------------------------------------------------
;;; 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"))
;----------------------------------------------------------------------------
(defun strltrim (s)
(cond
((eq s "") s)
((or(= " " (substr s 1 1))(= " " (substr s 1 1))) s)
(t (strltrim (substr s 2)))
)
)
(defun tabltrim (s)
(cond
((eq s "") s)
((or(= " " (substr s 1 1))(= " " (substr s 1 1))) (tabltrim (substr s 2)))
(t s)
)
)
;----------------------------------------------------------------------------
;; Subfunction for change 1 data-line to list
(defun linetopoint(line)
(setq y (read line)
line (tabltrim line)
line (strltrim line)
x (read line)
line (strltrim (tabltrim line))
z (read line)
)
(setq point (list x y z))
)
;;;-----------------------------------------------
;; Subfunction for read data from 1 file and change to list
(defun read_fs()
(setq dlist nil)
(setq datafile (GETFILED "TUAN - Select data-file " (GETVAR "dwgprefix") "*" 2))
(setq filename datafile)
(princ (strcat "\nPlease, wait!. READ & DRAW is reading data from " filename))
(if (setq f (open filename "r"))
(progn
(while (setq pl (read-line f))
(setq p (linetopoint pl) dlist (cons p dlist))
)
(close f)
)
)
(reverse dlist)
)
;---------------------------------------------------
;(defun C:van ( / li)
; (rd nil)
; (princ)
;)
(defun c:van ( / li n i li htext)
(setvar "cmdecho" 0)
(setvar "blipmode" 0)
(Setq ts (tblsearch "STYLE" (GETVAR "TEXTSTYLE")))
(setq tsize (cdr(assoc '40 ts)))
(INITGET +3)
(if (= tsize 0)(setq h (getreal "\nHeigth of text :"))(setq h tsize))
(initget)
(setq tr (getreal "\nRotation of text <0>:"))
(if (= tr nil) (setq tr 0))
;-------------------------------------------
(initget "y n Y N")
(setq yn (getkword "\nDo you want to draw in 3D <y/n> ?<y>"))
(if (= yn nil)(setq yn "Y"))
(if (= (strcase yn) "N")(setq yn "N")(setq yn "Y"))
;-------------------------------------------
;(initget "y n Y N")
;(setq ynl (getkword "\nDo you want to connect each to other <y/n> ?<y>"))
;(if (= ynl nil)(setq ynl "Y"))
;(if (= (strcase ynl) "N")(setq ynl "N")(setq ynl "Y"))
;-------------------------------------------
;(initget "y n Y N")
;(setq ynd (getkword "\nDo you want to insert donut at each point <y/n> ?<y>"))
;(if (= ynd nil)(setq ynd "Y"))
;(if (= (strcase ynd) "N")(setq ynd "N")(setq ynd "Y"))
;-------------------------------------------
;(initget "y n Y N")
;(setq ynC (getkword "\nDo you want to insert coconut at each point <y/n> ?<y>"))
;(if (= ynC nil)(setq ynC "Y"))
;(if (= (strcase ynC) "N")(setq ynC "N")(setq ynC "Y"))
;-------------------------------------------
;(initget "y n Y N")
;(setq ynTD (getkword "\nDo you want to insert TD at each point <y/n> ?<y>"))
;(if (= ynTD nil)(setq ynTD "Y"))
;(if (= (strcase ynTD) "N")(setq ynTD "N")(setq ynTD "Y"))
;-------------------------------------------
;(initget "y n Y N")
;(setq ynCL (getkword "\nDo you want to insert CL at each point <y/n> ?<y>"))
;(if (= ynCL nil)(setq ynCL "Y"))
;(if (= (strcase ynCL) "N")(setq ynCL "N")(setq ynCL "Y"))
;-------------------------------------------
(setq tb (* h 0.50))
(setq li (read_fs) n (length li) i -1 ipold (list 0 0 0))
;(print li)
(ai_undo_on) ; Turn UNDO on
(command "_.UNDO" "_GROUP")
(setq o_osmode (getvar "osmode"))
(setvar "osmode" 0)
;(COMMAND "insert" "DONUT" "0,0")
(command)
(repeat n
(setq i (1+ i) ip (nth i li) htext (zrtos (last ip) 2))
(setq ip1 (list (car ip) (cadr ip) 0.00))
(setq zi (atof htext))
(cond
((and( > zi 1000)(< zi 2000))(command "insert" "bienbao" ip1 tb tb 0))
((and( > zi 2000)(< zi 3000))(command "insert" "buiram" ip1 tb tb 0))
((and( > zi 3000)(< zi 4000))(command "insert" "cayanqua" ip1 tb tb 0))
((and( > zi 4000)(< zi 5000))(command "insert" "caycothu" ip1 tb tb 0))
((and( > zi 5000)(< zi 6000))(command "insert" "caydua" ip1 tb tb 0))
((and( > zi 6000)(< zi 7000))(command "insert" "caylua" ip1 tb tb 0))
((and( > zi 7000)(< zi 8000))(command "insert" "caymia" ip1 tb tb 0))
((and( > zi 8000)(< zi 9000))(command "insert" "caynhon" ip1 tb tb 0))
((and( > zi 9000)(< zi 10000))(command "insert" "caythong" ip1 tb tb 0))
((and( > zi 10000)(< zi 11000))(command "insert" "caytre" ip1 tb tb 0))
((and( > zi 11000)(< zi 12000))(command "insert" "cocchuyen" ip1 tb tb 0))
((and( > zi 12000)(< zi 13000))(command "insert" "dadoclap" ip1 tb tb 0))
((and( > zi 13000)(< zi 14000))(command "insert" "g1" ip1 tb tb 0))
((and( > zi 14000)(< zi 15000))(command "insert" "g2" ip1 tb tb 0))
((and( > zi 15000)(< zi 16000))(command "insert" "g3" ip1 tb tb 0))
((and( > zi 16000)(< zi 17000))(command "insert" "g4" ip1 tb tb 0))
((and( > zi 17000)(< zi 18000))(command "insert" "g5" ip1 tb tb 0))
((and( > zi 18000)(< zi 19000))(command "insert" "gieng" ip1 tb tb 0))
((and( > zi 19000)(< zi 20000))(command "insert" "hoamau" ip1 tb tb 0))
((and( > zi 20000)(< zi 21000))(command "insert" "leduong" ip1 tb tb 0))
((and( > zi 21000)(< zi 22000))(command "insert" "moma" ip1 tb tb 0))
((and( > zi 22000)(< zi 23000))(command "insert" "rao" ip1 tb tb 0))
((and( > zi 23000)(< zi 24000))(command "insert" "raumau" ip1 tb tb 0))
((and( > zi 24000)(< zi 25000))(command "insert" "sl" ip1 tb tb 0))
((and( > zi 25000)(< zi 26000))(command "insert" "t1" ip1 tb tb 0))
((and( > zi 26000)(< zi 27000))(command "insert" "t2" ip1 tb tb 0))
((and( > zi 27000)(< zi 28000))(command "insert" "t3" ip1 tb tb 0))
((and( > zi 28000)(< zi 29000))(command "insert" "t4" ip1 tb tb 0))
((and( > zi 29000)(< zi 30000))(command "insert" "tuong" ip1 tb tb 0))
((and( > zi 30000)(< zi 31000))(command "insert" "tram" ip1 tb tb 0))
((and( > zi 31000)(< zi 32000))(command "insert" "trucaothe" ip1 tb tb 0))
((and( > zi 32000)(< zi 33000))(command "insert" "truco" ip1 tb tb 0))
((and( > zi 33000)(< zi 34000))(command "insert" "truden" ip1 tb tb 0))
((and( > zi 34000)(< zi 35000))(command "insert" "trudendoi" ip1 tb tb 0))
((and( > zi 35000)(< zi 36000))(command "insert" "trudien1" ip1 tb tb 0))
((and( > zi 36000)(< zi 37000))(command "insert" "truttin" ip1 tb tb 0))
((and( > zi 37000)(< zi 38000))(command "insert" "2tuong" ip1 tb tb 0))
((and( > zi 38000)(< zi 39000))(command "insert" "3tuong" ip1 tb tb 0))
((and( > zi 39000)(< zi 40000))(command "insert" "2rao" ip1 tb tb 0))
((and( > zi 40000)(< zi 41000))(command "insert" "3rao" ip1 tb tb 0))
((and( > zi 41000)(< zi 42000))(command "insert" "T1T2" ip1 tb tb 0))
((and( > zi 42000)(< zi 43000))(command "insert" "G1G2" ip1 tb tb 0))
((and( > zi 43000)(< zi 44000))(command "insert" "Cong" ip1 tb tb 0))
((and( > zi 44000)(< zi 45000))(command "insert" "Hangcay" ip1 tb tb 0))
((and( > zi 45000)(< zi 46000))(command "insert" "Ao" ip1 tb tb 0))
((and( > zi 46000)(< zi 47000))(command "insert" "Raokhac" ip1 tb tb 0))
((and( > zi 47000)(< zi 48000))(command "insert" "trudien2" ip1 tb tb 0))
((and( > zi 48000)(< zi 49000))(command "insert" "chanbc" ip1 tb tb 0))
((and( > zi 49000)(< zi 50000))(command "insert" "tuongkhac" ip1 tb tb 0))
((and( > zi 50000)(< zi 51000))(command "insert" "lekhac" ip1 tb tb 0))
)
;(setq ip (list (car ip) (cadr ip) 0)))
;(if (= ynl "Y")(if (> i 1)(command "line" ipold ip "")))
; (if (= ynd "Y")(command "insert" "donut" ip tb tb 0))
;(if (= ynC "Y")(command "insert" "coconut" ip tb tb 0))
;(if (= ynTD "Y")(command "insert" "TD" ip tb tb 0))
;(if (= ynCL "Y")(command "insert" "CL" ip tb tb 0))
(cond
((< zi 1000)(setq ri (- (atof htext) 00.0)))
((and( > zi 1000)(< zi 2000))(setq ri (- (atof htext) 1000.0)))
((and( > zi 2000)(< zi 3000))(setq ri (- (atof htext) 2000.0)))
((and( > zi 3000)(< zi 4000))(setq ri (- (atof htext) 3000.0)))
((and( > zi 4000)(< zi 5000))(setq ri (- (atof htext) 4000.0)))
((and( > zi 5000)(< zi 6000))(setq ri (- (atof htext) 5000.0)))
((and( > zi 6000)(< zi 7000))(setq ri (- (atof htext) 6000.0)))
((and( > zi 7000)(< zi 8000))(setq ri (- (atof htext) 7000.0)))
((and( > zi 8000)(< zi 9000))(setq ri (- (atof htext) 8000.0)))
((and( > zi 9000)(< zi 10000))(setq ri (- (atof htext) 9000.0)))
((and( > zi 10000)(< zi 11000))(setq ri (- (atof htext) 10000.0)))
((and( > zi 11000)(< zi 12000))(setq ri (- (atof htext) 11000.0)))
((and( > zi 12000)(< zi 13000))(setq ri (- (atof htext) 12000.0)))
((and( > zi 13000)(< zi 14000))(setq ri (- (atof htext) 13000.0)))
((and( > zi 14000)(< zi 15000))(setq ri (- (atof htext) 14000.0)))
((and( > zi 15000)(< zi 16000))(setq ri (- (atof htext) 15000.0)))
((and( > zi 16000)(< zi 17000))(setq ri (- (atof htext) 16000.0)))
((and( > zi 17000)(< zi 18000))(setq ri (- (atof htext) 17000.0)))
((and( > zi 18000)(< zi 19000))(setq ri (- (atof htext) 18000.0)))
((and( > zi 19000)(< zi 20000))(setq ri (- (atof htext) 19000.0)))
((and( > zi 20000)(< zi 21000))(setq ri (- (atof htext) 20000.0)))
((and( > zi 21000)(< zi 22000))(setq ri (- (atof htext) 21000.0)))
((and( > zi 22000)(< zi 23000))(setq ri (- (atof htext) 22000.0)))
((and( > zi 23000)(< zi 24000))(setq ri (- (atof htext) 23000.0)))
((and( > zi 24000)(< zi 25000))(setq ri (- (atof htext) 24000.0)))
((and( > zi 25000)(< zi 26000))(setq ri (- (atof htext) 25000.0)))
((and( > zi 26000)(< zi 27000))(setq ri (- (atof htext) 26000.0)))
((and( > zi 27000)(< zi 28000))(setq ri (- (atof htext) 27000.0)))
((and( > zi 28000)(< zi 29000))(setq ri (- (atof htext) 28000.0)))
((and( > zi 29000)(< zi 30000))(setq ri (- (atof htext) 29000.0)))
((and( > zi 30000)(< zi 31000))(setq ri (- (atof htext) 30000.0)))
((and( > zi 31000)(< zi 32000))(setq ri (- (atof htext) 31000.0)))
((and( > zi 32000)(< zi 33000))(setq ri (- (atof htext) 32000.0)))
((and( > zi 33000)(< zi 34000))(setq ri (- (atof htext) 33000.0)))
((and( > zi 34000)(< zi 35000))(setq ri (- (atof htext) 34000.0)))
((and( > zi 35000)(< zi 36000))(setq ri (- (atof htext) 35000.0)))
((and( > zi 36000)(< zi 37000))(setq ri (- (atof htext) 36000.0)))
((and( > zi 37000)(< zi 38000))(setq ri (- (atof htext) 37000.0)))
((and( > zi 38000)(< zi 39000))(setq ri (- (atof htext) 38000.0)))
((and( > zi 39000)(< zi 40000))(setq ri (- (atof htext) 39000.0)))
((and( > zi 40000)(< zi 41000))(setq ri (- (atof htext) 40000.0)))
((and( > zi 41000)(< zi 42000))(setq ri (- (atof htext) 41000.0)))
((and( > zi 42000)(< zi 43000))(setq ri (- (atof htext) 42000.0)))
((and( > zi 43000)(< zi 44000))(setq ri (- (atof htext) 43000.0)))
((and( > zi 44000)(< zi 45000))(setq ri (- (atof htext) 44000.0)))
((and( > zi 45000)(< zi 46000))(setq ri (- (atof htext) 45000.0)))
((and( > zi 46000)(< zi 47000))(setq ri (- (atof htext) 46000.0)))
((and( > zi 47000)(< zi 48000))(setq ri (- (atof htext) 47000.0)))
((and( > zi 48000)(< zi 49000))(setq ri (- (atof htext) 48000.0)))
((and( > zi 49000)(< zi 50000))(setq ri (- (atof htext) 49000.0)))
((and( > zi 50000)(< zi 51000))(setq ri (- (atof htext) 50000.0)))
)
(if (> (atof htext) 1000)(setq htext (zrtos ri 2)))
(if (= yn "N")(setq ip (list (car ip) (cadr ip) 0.00))(setq ip (list (car ip) (cadr ip) ri)))
(print ip)
(if (= tsize 0)
(COMMAND "text" "j" "c" ip h tr htext)
(COMMAND "text" "j" "c" ip tr htext)
)
(command "insert" "donut" ip tb tb 0) ;(neu su dung YN donut thi xoa ca hang nay)
;(setq ipold ip)
)
(setvar "osmode" o_osmode)
(command "_.UNDO" "_E")
(ai_undo_off)
(princ "\nThank you for using this command")
(princ)
)
;;;--------------------------------------------------------------------------------
(princ " READ & DRAW loaded.")
(princ )







Mình có lisp phun điểm này nhờ các Anh/Chị,sửa dùm với.
Lisp chạy tốt nhưng bị hạn chế là chỉ chạy được tới 99,xxx. Chỉ được 2 số nguyên tới 100,xxx là ko hiểu
Nhờ các Anh/ Chị sửa dùm
Lệnh: RD
chiều cao text:
Góc quay(0):
Do you want to draw in 3D (y/n)?
Thêm dòng này: Số thập phân :

copy lisp vào support của Cad và phải có dấu chấm vàng trong bản vẽ bên dưới thì lisp mới chạy được
Dưới đây là file TxT và file mẫu do lisp chạy được.http://www.cadviet.c.../73751_text.dwg
http://www.cadviet.c...751_datlanh.txt
<<

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)

<<

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))
 

<<

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...
>>
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 dt)
lst2 (append '((0 0 0)) (reverse (cdr (reverse lst)))))
(setq ls (mapcar '(lambda(x y)
(list
(- (car x) (car y))
(- (cadr x) (cadr y))
))
lst
lst2
))
(princ
(strcat "A" (rtos (car (car ls)) 2 4) "," (rtos (cadr (car ls)) 2 4) "\n")
f
)
(foreach i (cdr ls)
(princ
(strcat "B" (rtos (car i) 2 4) "," (rtos (cadr i) 2 4) "\n")
f
))
(close f)
)
(princ)
)




Lisp đường tròn

(defun c:bienda2 (/ dt tenfile f ls i ent ss )
  (vl-load-com)
  (if (and (setq ss (acet-ss-to-list(ssget '((0 . "circle")))))
  (setq tenfile (getfiled "\nChon ten file" "" "csv" 1)))
    (progn      
      (setq f (open tenfile "w"))
      (setq ls '())      
      (princ "X,Y,Radius\n" f)      ;;;; co the bo dong nay di
      (foreach dt ss
(setq ls
      (append ls
      (list (list
      (car (acet-dxf 10 (setq ent (entget dt))))
      (cadr (acet-dxf 10 ent))
      (acet-dxf 40 ent)
      )))))
      (foreach i ls
(princ (strcat (rtos (car i) 2 4)
      ","
      (rtos (cadr i) 2 4)
      ","
      (rtos (caddr i) 2 4)
      "\n"
      )
      f
      ))
      (close f)
    )
    (prompt "\nChua lam gi")
    )
  (princ)
  )

 


P/s Về giáo trình AutoLisp, bạn tham khảo trên mạng nhé, mình trước cũng tìm vậy thôi, tìm với google.com từ khoá "giáo trình AutoLisp" . Hình như có cuốn thầy Lộc khá hay và dễ hiểu, mình không nhớ rõ nữa
<<

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
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...
>>
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 dt)
lst2 (append '((0 0 0)) (reverse (cdr (reverse lst)))))
(setq ls (mapcar '(lambda(x y)
(list
(- (car x) (car y))
(- (cadr x) (cadr y))
))
lst
lst2
))
(princ
(strcat "A" (rtos (car (car ls)) 2 4) "," (rtos (cadr (car ls)) 2 4) "\n")
f
)
(foreach i (cdr ls)
(princ
(strcat "B" (rtos (car i) 2 4) "," (rtos (cadr i) 2 4) "\n")
f
))
(close f)
)
(princ)
)




Lisp đường tròn

(defun c:bienda2 (/ dt tenfile f ls i ent ss )
  (vl-load-com)
  (if (and (setq ss (acet-ss-to-list(ssget '((0 . "circle")))))
  (setq tenfile (getfiled "\nChon ten file" "" "csv" 1)))
    (progn      
      (setq f (open tenfile "w"))
      (setq ls '())      
      (princ "X,Y,Radius\n" f)      ;;;; co the bo dong nay di
      (foreach dt ss
(setq ls
      (append ls
      (list (list
      (car (acet-dxf 10 (setq ent (entget dt))))
      (cadr (acet-dxf 10 ent))
      (acet-dxf 40 ent)
      )))))
      (foreach i ls
(princ (strcat (rtos (car i) 2 4)
      ","
      (rtos (cadr i) 2 4)
      ","
      (rtos (caddr i) 2 4)
      "\n"
      )
      f
      ))
      (close f)
    )
    (prompt "\nChua lam gi")
    )
  (princ)
  )

 


P/s Về giáo trình AutoLisp, bạn tham khảo trên mạng nhé, mình trước cũng tìm vậy thôi, tìm với google.com từ khoá "giáo trình AutoLisp" . Hình như có cuốn thầy Lộc khá hay và dễ hiểu, mình không nhớ rõ nữa
<<

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...

>>

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 (cdr(assoc 10 (entget x)))))
   (cadr (setq py (cdr(assoc 10 (entget y)))))
   1E-3))
  (> (cadr px) (cadr py))
  (< (car px) (car py))
  )
)))
  (setq j
(cond
  ((getint "\nChon so bat dau<1>"))
  (1)))
  (setq NumBe j j (1- j))
  (foreach i ss
    (while (/= (cdr(assoc 0 (entget (entnext i)))) "SEQEND")
      (if (entnext i) (setq i (entnext i) ent (entget i)))
      (if (and (setq i (entnext i)ent (entget i))
      (= "ATTRIB" (cdr(assoc 0 ent)))
      (= "00" (cdr(assoc 2 ent))))
(entmod(subst (cons 1 (xuly (setq j (1+ j)) )) (assoc 1 ent) ent))
))
    )
  (prompt (strcat "\nDa danh so tu "(rtos NumBe 2 0) " den " (rtos j 2 0)))
  (princ)
  )

Yêu cầu cần cài Express Tools


<<

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é.
 
Rdt.gif
 

 (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)
)


<<

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é.

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...
>>

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 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))
	)
)

<<

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"))

<<

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

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))
)

<<

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...
>>

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 1), 2), 3) .v. .v.)
Tiện ích sẽ thực hiện: khi chọn các text ghi các mã điểm này, lọc các text trong cùng một layer, hỏi mã điểm sau đó chọn 1 đối tượng và copy đối tượng này vào các điểm chèn của text thứ tự của người sử dụng nhập vào
ví dụ: người sử dụng type tại dòng command : nối điểm 001,002,003 . chọn đối tượng cần copy, chọn base point, sau đó nó sẽ copy đối tượng được chọn vào các điểm 001,002,003.
Cái này em dùng để làm hoàn công vị trí cọc đóng, cọc khoan...từ file số liệu đo của các bác trắc địa. Mỗi lần phải ngồi copy vài trăm cọc, mà các cọc lại có tiết diện khác nhau nên phải tìm vị trí của nó trên bản vẽ cũng rất mất công.
Thanks các bác nhiều.
bạn cần giải thích rõ hơn về layer và hỏi mã điểm.


Nếu bạn chỉ cần 1 lisp highlight các text có giá trị mà bạn cần tìm thì bạn dùng lệnh ht của lisp sau đây:

<<

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 


<<

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é.

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

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....
>>

Đâ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. Nếu bạn không hiểu rõ tác dụng của từng dòng code thì nhiều lúc sẽ mang họa vì dùng lisp đấy bạn ạ.
Thực ra trong đoạn lisp trên dòng code: p1 (assoc 10 list1) là thừa. Song vì nó không gấy hại nên mình cũng không sửa nó bạn ạ. Bạn có thể vô hiệu hóa nó mà không ảnh hưởng gì tới kết quả của bạn.
Chúc bạn thành công.
<<

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):

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...

>>

(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


<<

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))
 

<<

Filename: 272792_ket_ptb_dvh.lsp

Trang 148/330

148