Jump to content
InfoFile
Tác giả: toiyeuvietnam
Bài viết gốc: 192945
Tên lệnh: cb pdm vl tm
Nhờ hoàn thiện lisp phun điểm mia địa chính ra Autocad

- hiện tại em phải dùng 5 thao tác riêng biệt để xuất được các điểm đo...

>>

- hiện tại em phải dùng 5 thao tác riêng biệt để xuất được các điểm đo ra ngoài màn hình AutoCAD là:

1: Dùng lệnh chế biến File (CB) để chế biến File từ dạng thô của máy đo sang File tọa độ góc, cạnh dạng .TXT

2; Dùng lệnh phun điểm mia (PDM) để phun tọa độ ra ngoài màn hình AutoCAD.

3: Dùng lệnh vẽ lưới (VL) để xác định góc cạnh, tọa độ của trạm máy.

4: Dùng lệnh lấy trạm máy ™ để lấy tọa độ của trạm máy.

5: Sau đó mới dùng lệnh phun điểm mia (PDM) để phun tọa độ ra ngoài màn hình AutoCAD.

 

Nhờ các anh em trên diễn đàn giúp em hoàn thiện lisp phun tọa độ lên màn hình Autocad là gộp các lisp riêng lẻ thành 1 lệnh chế biến (CB) với nội dung như sau:

Mở AutoCAD ra và gõ lệnh chế biến (CB) sau đó tìm đến đường dẫn chứa File thô trút số liệu từ máy đo ra là có thể xuất tọa độ điểm đo ra ngoài màn hình và chỉ việc nối các điểm mia là xong mà không phải thực hiện từng thao tác như trước nữa!

 

Còn nếu khó và phức tạp quá thì có thể giúp em gộp bước 1 và 2 thành 1 ở trên để phun điểm mia ra và tự làm các bước còn lại theo cách thủ công như cũ.

Cảm ơn các anh em rất nhiều!

ĐÂY LÀ CODE CẦN ANH EM SỬA GIÚP:

 

C

 	;******\\\\\\\\\**chuong trinh che bien cho may TOPCON 223*********\\\\\\\\\\\\\\*********////////
;khong dung chenh cao, chi su dung de thanh lap ban do dia chinh
(defun c:cb (/ 	ch	i   FN  FD sosanh j  	trammay
 	ccmay  tramdh ccguong  canhng hm 	hg 	goctd
 	canhb  gocdung   cd  dem tam
)
 (setq
FN (getfiled "NhËp file nguån : "
  ""
  ""
  4
  	)
 )
 (setq i (strlen FN))
 (setq ch "")
 (while (/= ch "\\")
(setq ch (substr FN i 1))
(setq i (- i 1))
 )
 (setq xuat (substr FN 1 (+ i 1)))
 (setq FD (getstring "Nhap ten file ket qua : "))
 (setq FD (strcat xuat FD))
 (setq FD (open FD "w"))
;  (setq mo (getreal "Nhap sai so MO cua may (giay) : "))
 (if (= mo nil)
(progn (setq mo 0)
(princ "\n")
(princ "  Lay MO=0")
(princ "\n")
)
 )
 (setq mo (/ mo 3600))
 (setq FN (open FN "r"))
 (while (and (setq PR (read-line FN)) (/= PR ""))
(progn
 	(setq i 1)
 	(setq sosanh "")
 	(setq ch "")
 	(while (/= ch " ")
(setq ch (substr PR i 1))
(setq i (+ i 1))
 	)
 	(setq sosanh (substr PR 1 (- i 2)))
 	(cond ((= sosanh "STN")
 	(progn
;///////////////////////lay ten tram may//////////
   	(setq j i)
   	(while (/= ch ",")
  (setq ch (substr PR j 1))
  (setq j (+ j 1))
  (if (or (= ch "`") (= ch " "))
(setq i j)
  )
   	)
   	(setq trammay (substr PR i (- j i 1)))
;//////////////////////lay chieu cao may/////////
   	(setq i j)
   	(while (/= ch "")
  (setq ch (substr PR j 1))
  (setq j (+ j 1))
   	)
   	(setq ccmay (substr PR i (- j i 2)))
   	(write-line (strcat "TR  " trammay) FD)
 	)	;end progn
)	;end cond1
((= sosanh "BS")
 	(progn
;///////////////////////lay ten tram dinh huong//////////
   	(setq j i)
   	(while (/= ch ",")
  (setq ch (substr PR j 1))
  (setq j (+ j 1))
  (if (or (= ch "`") (= ch " "))
(setq i j)
  )
   	)
   	(setq tramdh (substr PR i (- j i 1)))
;//////////////////////lay chieu cao guong/////////
   	(setq i j)
   	(while (/= ch "")
  (setq ch (substr PR j 1))
  (setq j (+ j 1))
   	)
   	(setq ccguong (substr PR i (- j i 2)))
   	(setq tam "bs")
 	)	;end progn
)	;end cond2
((= sosanh "SD")
 	(progn
   	(setq j i)
   	(while (/= ch ",")
  (setq ch (substr PR j 1))
  (setq j (+ j 1))
  (if (= ch " ")
(setq i j)
  )
   	)
   	(setq gocbang (substr PR i (- j i 1)))
;///////////////////////////////
   	(setq i j)
   	(setq j (+ j 2))
   	(setq ch "")
   	(while (/= ch ",")
  (setq ch (substr PR j 1))
  (setq j (+ j 1))
   	)
   	(setq goctd (substr PR i (- j i 1)))
;////////////////////////////////
   	(setq i j)
   	(setq j (+ j 2))
   	(setq ch " ")
   	(while (/= ch "")
  (setq ch (substr PR j 1))
  (setq j (+ j 1))
   	)
   	(setq canhng (substr PR i (- j i 1)))
;/////////////////////////////////////
   	(setq hg (atof ccguong))
   	(setq hm (atof ccmay))
   	(setq gocdung (- (- 90.0 (dpgtod (atof goctd))) mo))
   	(setq gocdung (/ (* gocdung pi) 180))
   	(setq canhng (atof canhng))
   	(setq canhb (* canhng (cos gocdung)))
   	(setq h (+ (- hg hm) (* canhng (sin gocdung))))
   	(setq cd (strlen gocbang))
   	(setq i cd)
   	(setq dem 0)
   	(setq ch "")
   	(while (/= ch ".")
  (setq ch (substr gocbang i 1))
  (setq i (- i 1))
  (setq dem (+ dem 1))
   	)
   	(if (= dem 6)
  (setq gocbang (substr gocbang 1 (- cd 1)))
   	)
   	(if (= tam "bs")
  (write-line
(strcat "DH  "
 	(dd tramdh)
 	(dd gocbang)
 	"  "
 	(rtos canhb 2 3)
)
FD
  )
  (write-line
(strcat (dd stt)
 	(dd gocbang)
 	"	"
 	(rtos canhb 2 3)
)
FD
  )
   	)
 	)	;end progn
)	;end cond3
((= sosanh "SS")
 	(progn
   	(setq j i)
   	(while (/= ch ",")
  (setq ch (substr PR j 1))
  (setq j (+ j 1))
  (if (or (= ch "`") (= ch " "))
(setq i j)
  )
   	)
   	(setq stt (substr PR i (- j i 1)))
   	(setq i j)
   	(while (/= ch "")
  (setq ch (substr PR j 1))
  (setq j (+ j 1))
   	)
   	(setq ccguong (substr PR i (- j i 2)))
   	(setq tam "ss")
 	)	;end progn
)	;end cond4
 	)
) 	;end progn
 ) 	;end while
 (close FN)
 (close FD)
 (princ "\n")
 (princ "\nOK!")
 (princ)
)
------------------------------------------------------------------------------------------------------------------------------------------------------------------
;******chuong trinh phun diem mia cho file duoc che bien tu may TOPCON 223**********
;          	DUNG CHO BAN DO DIA CHINH 	*
;* TR  DCII-04  1014424.593 516275.846   		*
;* TR  DCII-07  1014339.861 516213.914   		*
;* TR  DCII-03  1014491.054  516180.297        	*
;* TR  DCII-06  1014670.141  516433.592     		*
;* TR  DCTI-04   		*
;* DH  DCII-03     		*
;* 1    	355.1447 	66.896        	*
;* 2    	355.1519 	47.576     		*
;* 3    	1.4545   	48.375        	*
;************************************************************************
(defun c:pdm (/    	tam ms  PR   FN	thunhat
  	tentram  caodotram  xtram   ytram	htram
  	tentrammay tendh
 	)
 (bdau)
 (setq tam ())
 (setq ms (getreal "Nhap vao mau so ty le : "))
 (setq
FN (getfiled "NhËp file nguån : "
  ""
  ""
  4
  	)
 )
 (progn
(command "-osnap" "")
(setvar "cmdecho" 0)
(setvar "luprec" 8)
(setvar "pdmode" 0)
(command "-layer" "m" "diem" "c" "red" "" "")
;	(command "-layer" "m" "caodo" "c" "cyan" "" "")
(command "-layer" "m" "sothutu" "c" "magenta" "" "")
(command "-layer" "m" "khongche" "c" "red" "" "")
(setq st (/ ms 1000))
(setq st1 st)
(command "-style" "mota" "txt.shx" st1 "1" "0" "n" "n" "n")
(setq FN (open FN "r"))
(while (and (setq PR (read-line FN)) (/= PR ""))
 	(progn
(setq PR (strcat "(" PR ")"))
(setq PR (read PR))
(setq thunhat (nth 0 PR))
(if
  (numberp thunhat)
(gapsoA)
(gaptramA)
)
 	) 	;end progn
) 	;end while
 ) 	;end progn
;;;;;ket thuc viet lenh
 (close FN)
 (command "zoom" "e")
 (kthuc)
 (princ "\nVAY LA XONG!)*****")
 (princ)
)
(defun gaptramA (/ x y)
 (setq thunhat (convtostr thunhat))
 (if (= thunhat "TR")
(progn
 	(setq ktra (nth 3 PR))
 	(if (/= ktra nil) ;GAP TRAM CHUA TOA DO GOC
(progn
  (setq tentram (convtostr (nth 1 PR)))
  (setq Y (nth 2 PR))
  (setq X ktra)
;   (setq h (nth 4 PR))
  (setq tam (append tam (list (list tentram x y ))))
)   ;GAP TRAM DO THUC TE
(progn
  (setq tentrammay (convtostr (nth 1 PR)))
;   (if (/= (nth 2 PR) nil)
; 	(setq caodotram (nth 2 PR))
; 	(setq caodotram 0)
;   )
  (laytdgoc tentrammay)
  (setq tdtram1 (list (+ xtram (* 2 st)) ytram ))
  (setq xxtram xtram)
  (setq yytram ytram)
  (setq tdtram (list xtram ytram))
  (command "-layer" "s" "khongche" "")
;(command "point" tdtram)
  (command "insert" "cdkc" tdtram st st "")
  (setq sss (strlen tentrammay))
  (setq tdtram2 (list (+ xtram (* 2 st) );(* (/ sss 2) st))
		(- ytram (* 0.65 st))      
  )
  )
;   (command "insert"
; 	"l"
; 	tdtram1
; 	(* st sss)
; 	(* st sss)
; 	""
;   )
  (command "-style"
"mota"
"txt.shx"
st
"1"
"0"
"n"
"n"
"n"
  )
  (command "text" "j" "bl" tdtram1 "" tentrammay)
  (command "-style" "mota" "txt.shx" st1 "1" "0" "n" "n" "n")
;   (command "-layer" "s" "khongche" "")
;   (command "text" "j" "tl" tdtram2 "" (rtos htram 2 2))
)
 	)
) 	;end progn
(if (= thunhat "DH")  ;else
 	(progn
(setq tendh (convtostr (nth 1 PR)))
(laytdgoc tendh)
(setq tddh (list xtram ytram ))
(setq tddh1 (list (+ xtram (* 2 st)) ytram ))
(command "-layer" "s" "khongche" "")
(command "insert" "cdkc" tddh st st "")
;(command "point" tddh)
(setq sss (strlen tendh))
(setq tddh2 (list (+ xtram (* 2 st)); (* (/ sss 2) st))
(- ytram (* 0.65 st))    
 	)
)
;(command "insert"
;  "l"
;  tddh1
;  (* st sss)
;  (* st sss)
;  ""
;)
(command "-style"
  "mota"
  "txt.shx"
  st
  "1"
  "0"
  "n"
  "n"
  "n"
)
(command "text" "j" "bl" tddh1 "" tendh)
(command "-style" "mota" "txt.shx" st1 "1" "0" "n" "n" "n")
; (command "-layer" "s" "khongche" "")
; (command "text" "j" "tl" tddh2 "" (rtos htram 2 1))
 	)
)
 )
)
(defun gapsoA (/ gocbang kc goctd tdx tdy tdz td dentah)
 (setq gocbang (nth 1 PR))
 (setq kc (nth 2 PR))
;  (setq dentah (nth 3 PR))
 (setq gocbang (dpgtod gocbang))
 (setq gocbang (- 360 gocbang))
 (setq gocbang (+ (/ (* gocbang pi) 180) (angle tdtram tddh)))
 (setq tdX (+ xxtram (* kc (cos gocbang))))
 (setq tdY (+ yytram (* kc (sin gocbang))))
;  (if (/= dentah nil)
;	(setq tdz (+ caodotram (nth 2 tdtram) dentah))
;	(setq tdz 0)
;  )
 (setq td (list tdx tdy))
 (setq td1 (list (+ tdx (* 0.5 st)) (+ tdy (* 0.3 st)) ))
 (setq td2 (list (+ tdx (* 0.5 st)) (- tdy (* 0.3 st)) ))
 (command "-layer" "s" "diem" "")
 ;(command "insert" "cdc" td st st "")
 (command "point" td)
 (command "-style"
"mota"
"txt.shx"
(* st 2)
"1"
"0"
"n"
"n"
"n"
 )
 (command "-style" "mota" "txt.shx" st1 "1" "0" "n" "n" "n")
 (command "-layer" "s" "sothutu" "")
 (command "text" td "" thunhat)
;  (command "-style" "mota" "txt.shx" st1 "1" "0" "n" "n" "n")
;  (command "-layer" "s" "caodo" "")
;  (command "text" "tl" td "" (rtos tdz 2 1))
)
------------------------------------------------------------------------------------
chuong trinh tinh toa do diem dua vao goc va canh nhap vao
(defun c:vl ()	;/ diemgoc diemdh goc canh)
 (bdau)
 (command "-layer" "m" "veluoi" "c" "cyan" "" "")
 (command "-layer" "m" "point" "c" "red" "" "")
 (command "-layer" "m" "text" "c" "yellow" "" "")
 (setq diemgoc (getpoint "\nChon diem goc : "))
 (setq diemdh (getpoint "\nChon diem dinh huong : "))
 (setq goc (getreal "\nNhap goc(do.phutgiay) : "))
 (setq canh (getreal "\nNhap chieu dai canh : "))
 (setq tendiem (getstring "Nhap ten diem : "))
 (setq goc2 (dpgtod goc))
 (setq goc1 (/ (* goc2 pi) 180))
 (setq gocbang (- (* 2 pi) goc1))
 (setq gocbang (+ gocbang (angle diemgoc diemdh)))
 (setq x1 (nth 0 diemgoc))
 (setq y1 (nth 1 diemgoc))
 (setq x2 (nth 0 diemdh))
 (setq y2 (nth 1 diemdh))
 (setq x3 (+ x1 (* canh (cos gocbang))))
 (setq y3 (+ y1 (* canh (sin gocbang))))
 (setq td3 (list x3 y3))
 (command "-layer" "s" "point" "")
 (command "point" td3)
 (command "-layer" "s" "veluoi" "")
 (command "line" diemgoc td3 "")
 (command "-layer" "s" "text" "")
 (command "-style" "mota" "txt.shx" 2 "1" "0" "n" "n" "n")
 (command "text" td3 "" tendiem)
 (kthuc)
)
------------------------------------------------------------------------------------
; CHUONG TRINH LAY TOA DO 1 DIEM SAP XEP THEO X : Y : Z XUAT TRANG TEXT
(defun C:TM (/ DIEM)
 (command "osnap" "endpoint")
 (setq DIEM (getpoint "Chon tram may can lay toa do"))
 (princ "\n TOA DO TRAM MAY:   ")
 (princ (rtos (cadr DIEM) 2 3))
 (princ "  ")
 (princ (rtos (car DIEM) 2 3))
 (princ "  ")
 (princ (rtos (caddr DIEM) 2 3))
 (princ)
) 	;END DEFUN
---------------------------------------------------------------------------------------


<<

Filename: 192945_cb_pdm_vl_tm.lsp
Tác giả: cadthanyeu
Bài viết gốc: 37281
Tên lệnh: doi text
đổi thuộc tính cho text

Bạn thử LISP này xem sao :

;;;; Doi thuoc tinh chieu cao va kieu TEXT 
(defun C:doi_text (/ ss lst ent)
 (setq ss (ssget "X" (list (cons 8 "hoten")(cons 0 "TEXT")))
lst (ss2ent...
>>
Bạn thử LISP này xem sao :

;;;; Doi thuoc tinh chieu cao va kieu TEXT 
(defun C:doi_text (/ ss lst ent)
 (setq ss (ssget "X" (list (cons 8 "hoten")(cons 0 "TEXT")))
lst (ss2ent ss))
 (if (not (tblsearch "style" "vnarial"))
(command "-style" "vnarial" "" "" "" "" "" "" "")  )
 (repeat (length lst)
   (setq ent (entget (car lst))
  lst (cdr lst)
  ent (subst (cons 40 5) (assoc 40 ent) ent)
  ent (subst (cons 7 "vnarial") (assoc 7 ent) ent)
   )
   (entmod ent)
 )
 (princ)
)

(defun ss2ent (ss / sodt index lstent)
 (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)
)


<<

Filename: 37281_doi_text.lsp
Tác giả: xvinh
Bài viết gốc: 1294
Tên lệnh: cu cu
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

Các bạn cho tôi hỏi tại sao tôi sau khi tôi sử dụng lisp vẽ cửa chuyển sang lệnh khác thì tất cả các phương thức băt điểm lại tự động bị tắt hết (mở os thì không có cách nào được chọn)? Các bạn chỉ giáo giúp nhé,Càng sớm càng tốt. Xin chân thành cảm ơn! :lol: :lol:

Đoạn Lisp như sau:

 

(defun c:cu()
(setvar "osmode" 512 ) 
(setq p1 (getpoint "\nfirst point...
>>

Các bạn cho tôi hỏi tại sao tôi sau khi tôi sử dụng lisp vẽ cửa chuyển sang lệnh khác thì tất cả các phương thức băt điểm lại tự động bị tắt hết (mở os thì không có cách nào được chọn)? Các bạn chỉ giáo giúp nhé,Càng sớm càng tốt. Xin chân thành cảm ơn! :lol: :lol:

Đoạn Lisp như sau:

 

(defun c:cu()
(setvar "osmode" 512 ) 
(setq p1 (getpoint "\nfirst point :"))
(if (= nil p1)(sdor)(odor))
)
(defun odor ()
(setq p2 (getpoint p1 "\nsecond point width open :"))
(setvar "osmode" 128 ) 
(setq p3 (getpoint p2 "\npick in wall :")
      p31 (polar p1 (angle p2 p3) (distance p2 p3))
)
(setvar "osmode" 0 ) 
(command  "line" p1 p31 "")
(setq s1 (entlast));de copy ve do cua so
(command  "line" p2 p3 "" "trim" "c" p3 p1 "" 
                  (polar p1 (angle p1 p2) (/ (distance p1 p2) 2))
                  (polar p31 (angle p1 p2) (/ (distance p1 p2) 2)) ""
)
(setq sel (strcase (getstring "\nWin Open <Dor> :")))
(cond ((= sel "W")(openwin))
      ((= sel "")(opendor))
      (T (princ))
)
(princ)                            
)
(defun sdor ()
(setvar "osmode" 1 ) 
(setq p1 (getpoint "\nfirst point :"))
(setq p2 (getpoint p1 "\nsecond point width open :"))
(setvar "osmode" 128 ) 
(setq p3 (getpoint p2 "\npick in wall :")
      p31 (polar p1 (angle p2 p3) (distance p2 p3))
)
(setvar "osmode" 0 ) 
(command  "line" p1 p31 "")
(setq s1 (entlast)) ;de copy ve do cua so
(setq sel (strcase (getstring "\nWin Open <Dor> :")))
(cond ((= sel "W")(openwin))
      ((= sel "")(opendor))
      (T (princ))
)
(princ)                            
)
;-----------
(defun opendor ()
(setq ang (getangle (polar p1 (angle p1 p2) (/ (distance p1 p2) 2)) "\ndirection open :")
      nsegdor (getint "\nnumber seg dor 2 4 <1> :")
)
(cond ((= nsegdor 2)(dor2 p1 p2 ang))
      ((= nsegdor 4)(dor4 p1 p2 ang))
      (T (dor p1 p2 ang))
)
)
;----------
(defun dor4 (p1 p2 ang)
(setq p12 (polar p1 (angle p1 p2) (/ (distance p1 p2) 2)))
(setq p112 (polar p1 (angle p1 p12) (/ (distance p1 p12) 2)))
(setq p122 (polar p12 (angle p1 p12) (/ (distance p1 p12) 2)))
(dor p1 p112 ang)(dor p112 p12 ang)(dor p2 p122 ang)(dor p122 p12 ang)
)
;----------
(defun dor2 (p1 p2 ang)
(setq p12 (polar p1 (angle p1 p2) (/ (distance p1 p2) 2)))
(dor p1 p12 ang)(dor p2 p12 ang)
)
;----------
(defun dor (p1 p2 ang)
(setq ps1 (polar p1 (angle p1 p2) 0.5)
      ps2 (polar ps1 ang (distance p1 p2))
      ps3 (polar ps2 (angle p2 p1) 0.5)
)
(command "pline" ps3 ps2 ps1 p1 ps3 ps2 "a" p2 "" ) 
)
;----------
(defun openwin ()
(command "line" p1 p2 "" "line" p31 p3 ""
         "line" (polar p1 (angle p2 p3) (/ (distance p2 p3) 2))
                (polar p2 (angle p2 p3) (/ (distance p2 p3) 2)) ""
)
(setq nsegwin (getint "\nnumber seg win :")
       disseg (/ (distance p1 p2) nsegwin)   
)
(setq lispoiseg nil)
(repeat (- nsegwin 1)
 (setq lispoiseg (append lispoiseg (list (polar p1 (angle p1 p2) (* (- nsegwin 1) disseg))))
         nsegwin (- nsegwin 1)
 )
)
(command "copy" s1 "" "m" p1)
(foreach p lispoiseg (command p))
(command "")
)
(PRINC)


<<

Filename: 1294_cu_cu.lsp
Tác giả: khunglong37
Bài viết gốc: 129357
Tên lệnh: jp
viết lisp nối các đoạn thẳng này hộ em với

Cảm ơn bác ketxu, em đang thử xem, có gì em sẽ hỏi bác tiếp nhé.

Nhưng sử dụng là lệnh jp ah bác

Có người post r đó bạn :) Code tương đối dài, áp dụng với...
>>

Cảm ơn bác ketxu, em đang thử xem, có gì em sẽ hỏi bác tiếp nhé.

Nhưng sử dụng là lệnh jp ah bác

Có người post r đó bạn :) Code tương đối dài, áp dụng với cả arc nhé

 

;;; ;free lisp from cadviet.com @ ....
;;; ======================================================  join polyline 
(defun c:jp ( / ss plines ss2 st fuzz)
(acet-error-init
 (list (list   "cmdecho" 0
             "highlight" nil
             "plinetype" 2
              "limcheck" 0
	"osmode"  0

       );list
       0  ;use undo marks but do not roll back on a cancel
 );list
);acet-error-init

(setq plines (ssget ":l" '(
       (-4 . "         (0 . "ARC")
        (0 . "LINE")
        (-4 . "          (0 . "*POLYLINE")
         (-4 . "") ;8 16 64 not a 3dpoly or 3d/pface mesh
        (-4 . "AND>")
        (0 . "LWPOLYLINE")
       (-4 . "OR>")
                 )
             )
);setq
(if plines
    (setq plines (acet-ss-filter-current-ucs plines T))
);if
(if plines
    (setq plines (car (acet-ss-filter (list plines '(("CURRENTUCS")) T))))
);if
(princ "\n")
(if plines
    (setq ss (convert plines));setq
);if
(if (and ss
         (> (sslength ss) 0)
         plines
    );and
    (mpedit ss) ;after conversion, plines sset is duplicated in ss
    (progn
     (if (not plines)
         (princ "\nNothing selected.")
         (princ "\nNo valid objects selected.")
     );if
    );progn else
);if

(acet-error-restore)
(acet-pljoin2 ss st fuzz)
;(acet-pljoin-get-fuzz-and-mode2)
(princ)
);defun c:jp

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; mpedit functionality and switch cases based on kword input operation

(defun mpedit ( plines / opt newWidth ss flt fuz st na ss2 )

  (initget 0 "Open Close Join Ltype Decurve Fit Spline Width eXit _Open Close Join Ltype Decurve Fit 

Spline Width eXit")
  (setq opt "Join")
;   (setq opt (getkword "\nEnter an option  

: "))
  ;Changed code below to a cond structure to improve readability R.K.
  (cond
   ((= opt "Join")
    (setq flt '((-4 . "                  (0 . "LINE")
                 (0 . "ARC")
                 (-4 . "                   (0 . "*POLYLINE")
                  (-4 . "") ;1 8 16 64
                 (-4 . "AND>")
                (-4 . "OR>")
               )
          flt (list flt
                    "\n1 object is invalid for join."
                    "\n%1 objects are invalid for join."
              );list
          flt (list flt
                    (list "LAYERUNLOCKED")
                    (list "CURRENTUCS")
              );list
           ss (car (acet-ss-filter (list plines flt T)))
    );setq

    (acet-autoload (list "pljoin.lsp" "(acet-pljoin-get-fuzz-and-mode)"))
    (acet-autoload (list "pljoin.lsp" "(acet-pljoin ss st fuz)"))

    (if ss
        (progn
         (setvar "highlight" 0)
         (setq fuz (acet-pljoin-get-fuzz-and-mode2)
                st (cadr fuz)
               fuz (car fuz)
                na (entlast)
         );setq
         (acet-pljoin2 ss st fuz)
         (setq ss2 (acet-ss-new na))
         (setq plines (acet-ss-union (list plines ss2)))
        );progn then
        (princ "\nNo valid objects to join.")
    );if
   );cond Join option
  );cond close
);defun mpedit

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Convert arcs and lines to polylines
;;; ss is retained as a duplicate of the plines selection set because
;;; after conversion, new handles are assigned to what were arcs and lines
(defun convert ( plines / ss count opt )
(if (> (sslength plines) 0)
    (setq opt "Yes")
;     (progn
;      (initget 0 "Yes No _Yes No")
;      (setq opt (getkword "Convert Lines and Arcs to polylines?  : "))
;     );progn then
);if
(if (not opt)
    (setq opt "Yes")
)
(if (and (= opt "Yes")
         (> (sslength plines) 0)
    );and
    (progn ;if yes -- convert lines and arcs to polylines
     (acet-undo-begin)
     (setq ss (ssadd))
     (setq count 0)
     (while (< count (sslength plines))
      (if (or (equal (assoc 0 (entget (ssname plines count))) '(0 . "ARC"))
              (equal (assoc 0 (entget (ssname plines count))) '(0 . "LINE"))
          );or
          (progn
           (command "_.pedit" (ssname plines count) "_yes" "_exit")
           (ssadd (entlast) ss)
          );progn true
          (ssadd (ssname plines count) ss)
      );if
      (setq count (1+ count))
     );while
     (acet-undo-end)
    );progn yes
    (progn ;if no -- do not convert
     (setq ss plines)
     (setq count 0)
     (while (< count (sslength ss))
      (if (or (equal (assoc 0 (entget (ssname ss count))) '(0 . "ARC"))
              (equal (assoc 0 (entget (ssname ss count))) '(0 . "LINE"))
          );or
          (progn
           (ssdel (ssname ss count) ss)
           (setq count (1- count))
          );progn true
      );if
      (setq count (1+ count))
     );while
    );progn no
);if
(if (and ss
         (equal (type ss) 'PICKSET)
         (equal 0 (sslength ss))
    );and
    (setq ss nil)
);if
ss
)
(if (not #acet-pljoin-prec)
   (setq #acet-pljoin-prec 0.0000001)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun acet-pljoin2 ( ss st fuzz / flt )

(setq flt '((-4 . "             (0 . "LINE")
            (0 . "ARC")
            (-4 . "              (0 . "*POLYLINE")
             (-4 . "") ;1 8 16 64
            (-4 . "AND>")
           (-4 . "OR>")
          )
);setq
(if (and (setq ss (acet-pljoin-do-ss-pre-work2 ss flt)) ;convert lines/arcs/heavy plines ..etc.
                                                      ;to lighweight plines
        (setq ss (acet-pljoin-1st-pass2 ss flt))       ;initial pass with pedit command
   );and
   (acet-pljoin-2nd-pass2 ss fuzz st flt) ;where the work is..
);if

);defun acet-pljoin


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Try to join as many as possible before performing the
;hashing.
;
(defun acet-pljoin-1st-pass2 ( ss flt / na )

(acet-spinner)

(setq na (entlast))
(command "_.pedit" (ssname ss 0) "_j" ss "" "_x")

(command "_.select" ss)
(if (not (equal na (entlast)))
    (command (entlast) "")
    (command "")
);if
(setq ss (acet-ss-ssget-filter ss flt));setq
(if (and ss
         (:s_big:)                      ;closest pairs point at each other
         (setq  na (last id)                      ;get some of the data out of id and id2
               na2 (last id2)
                p1 (cadr id)                      ;the real points
                p2 (cadr id2)
         );setq
         (progn                                   ;get the proper entity names from the ename map lst5
          (while (setq c (assoc na lst5))   (setq na (cadr c)));while
          (while (setq c (assoc na2 lst5))  (setq na2 (cadr c)));while
          T
         );progn
         na                                       ;both entities still exist?
         na2

;          (/= 1 (logand 1 (cdr (assoc 70 (entget na)))))
;          (/= 1 (logand 1 (cdr (assoc 70 (entget na2)))))
    );and
    (progn
     ;then attempt a join
     (setq flag nil
           lst5 (acet-pljoin-do-join2 fuzz st na p1 na2 p2 lst5 tmpe1 tmpe2)
           flag (cadr lst5) ;join success?
           lst5 (car lst5)
     );setq return updated entname map and success flag
     (if flag
         (setq ulst (cons id ulst)     ;Then the join succeeded.
               ulst (cons id2 ulst)    ;mark the two as used by adding the them to ulst
         );setq the success
         (setq flst (cons (list id id2) flst)
               flst (cons (list id2 id) flst)
         );setq else join failed so mark as such in flst
     );if
    );progn then
    (progn
     (setq nskip (+ nskip 1));setq

     ;(print '(not (member id ulst)))
     ;(print (not (member id ulst)))
     ;(print '(not (member id2 ulst)))
     ;(print (not (member id2 ulst)))
     ;(print '(not (member (list id id2) flst)))
     ;(print (not (member (list id id2) flst)))
     ;(print '(setq b (assoc id2 lst2)))
     ;(print (setq b (assoc id2 lst2)))
     ;(print '(equal id (cadr B)))
     ;(print (equal id (cadr B)))
     ;(print 'na)
     ;(print na)
     ;(print 'na2)
     ;(print na2)
     ;
     ;(d-point (cadr id) "1")
     ;(d-point (cadr id2) "2")
     ;(princ "\ndecided not to try it.")
     ;(getstring "")
     ;(entdel (entlast))
     ;(entdel (entlast))

    );progn else
);if
(setq n (+ n 1))
);repeat

(if (equal nskip n)
   (setq lst nil);then all were skipped so the job is finished.
);if

(setq lst2 nil);setq ;;;remove the used and non-candidate point data from lst
(setq n 0)
(repeat (length lst)
(setq a (nth n lst));setq
(if (and (not (member n lst3))    ;not a non-candidate
         (not (member a ulst))    ;not used
    );and
    (setq lst2 (cons a lst2))
);if
(setq n (+ n 1))
);repeat

(list lst2 lst5 flst)
);defun acet-pljoin-get-matched-pairs


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;
(defun acet-pljoin-get-closest2 ( p1 lst fuzz g flst / a b c d x1 x2 x3 y1 y2 y3 n j
                                                    lst2 lst3 len2 len3 clst
                              )

;(print "acet-pljoin-get-closest")
;(print "")

(setq   b (cadr p1) ;the real point
       a (car p1)  ;the grid point
);setq

;determine the grid points to examine.
(cond
((equal fuzz 0.0 #acet-pljoin-prec)
 (setq lst2 (list (list (car a) (cadr a))
            );list
 );setq else
);cond #2
(T
 (if (B))
     (setq x1 (car a)
           x2 (acet-calc-round (+ (car a) g) g)
     );setq
     (setq x1 (acet-calc-round (- (car a) g) g)
           x2 (car a)
    );setq
 );if
 (if (B))
     (setq y1 (cadr a)
           y2 (acet-calc-round (+ (cadr a) g) g)
     );setq
     (setq y1 (acet-calc-round (- (cadr a) g) g)
           y2 (cadr a)
     );setq
 );if
 (setq lst2 (list (list x1 y1)
                  (list x2 y1)
                  (list x2 y2)
                  (list x1 y2)
            );list
 );setq
);cond #3
);cond close

(setq    d (* fuzz 2.0)
     len2 (length lst2)
);setq
;;loop through the grid points and check each of the points that fall on each grid point
(setq n 0)
(while (B)
   (setq   c (list (acet-calc-round (car a) g)
                   (acet-calc-round (cadr a) g)
             );list
           d (list (acet-calc-round (car B) g)
                   (acet-calc-round (cadr B) g)
             );list
         lst (cons (list c a 0 na) lst)
         lst (cons (list d b 1 na) lst)
   );setq then
);if

(if (equal n (* (/ n 10) 10)) ;update the spinner once every ten objects
   (acet-spinner)
);if
(setq n (+ n 1));setq
);repeat
;(princ "Done.")

lst
);defun acet-pljoin-round


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun acet-pljoin-get-epoints2 ( na / e1 a b z v )

;(print "acet-pljoin-get-epoints")
;(print "")

(if (and (setq e1 (entget na))
         (setq e1 (acet-lwpline-remove-duplicate-pnts2 e1))
    );and
    (progn
     (setq z (cdr (assoc 38 e1)));setq
     (if (not z) (setq z 0.0))
     (setq v (cdr (assoc 210 e1))
           a (cdr (assoc 10 e1))
           a (list (car a) (cadr a) z)
           a (trans a v 1)
          e1 (reverse e1)
           b (cdr (assoc 10 e1))
           b (list (car B) (cadr B) z)
           b (trans b v 1)
     );setq
     (setq a (list a B))
    );progn then
);if;

;(print "done epoints")

a
);defun acet-pljoin-get-epoints

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Takes an entity list of lwpolylines and modifies the object
;removing neighboring duplicate points. If no duplicated points
;are found then the object will not be passed to (entmod ).
;Returns the new elist when done.
(defun acet-lwpline-remove-duplicate-pnts2 ( e1 / a n lst e2)

(setq n 0)
(repeat (length e1)
(setq a (nth n e1));setq
(cond
((not (equal 10 (car a)))
 (setq e2 (cons a e2))
);cond #1
((not (equal (car lst) a))
 (setq lst (cons a lst)
        e2 (cons a e2)
 );setq
);cond #2
);cond close
(setq n (+ n 1));setq
);repeat
(setq e2 (reverse e2))
(if (and e2
        (not (equal e1 e2))
        lst
   );and
   (progn
    (if (equal 1 (length lst))
        (progn
         (entdel (cdr (assoc -1 e1)))
         (setq e2 nil)
        );progn then single vertex polyline so delete it.
        (progn
         (setq e2 (subst (cons 90 (length lst)) (assoc 90 e2) e2)
         );setq
         (entmod e2)
        );progn else
    );if
   );progn then
);if

e2
);defun acet-lwpline-make-remove-duplicate-pnts

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun acet-pljoin-fillet-with-fuzz2 ( fuzz na p1 tmpe1 na2 p2 tmpe2 /
                                    e1 e2 p1a p2a lst flag flag2 n a
                                    tmpna tmpna2 x y v
                            )

;(print "acet-pljoin-fillet-with-fuzz")
;(print "")


(setq  tmpna (cdr (assoc -1 tmpe1)) ;get the temp entitiy names out of the ent lists
     tmpna2 (cdr (assoc -1 tmpe2))
        lst (acet-pljoin-mod-tmp2 na p1 tmpe1) ;make the temp ent look like the begining or ending 

segment
         e1 (car lst)                         ;the modified temp ent list
       flag (cadr lst)                        ;0 or 1 start or end
        p1a (caddr lst)                       ;segment info sub-list (p1 p2 bulge) where p2 is always the 

endpoint
        lst (acet-pljoin-mod-tmp2 na2 p2 tmpe2)
         e2 (car lst)
      flag2 (cadr lst)                          ;0 or 1 start or end
        p2a (caddr lst)                         ;segment info sub-list (p1 p2 bulge) ;in entity ucs
        lst (acet-geom-intersectwith tmpna tmpna2 3) ;get the intersection list
          v (cdr (assoc 210 e1))
        lst (acet-geom-m-trans lst 0 v) ;trans to entity coord system
);setq

(if lst
   (progn
    (setq x (acet-pljoin-get-best-int2 p1a lst))            ;get the best intersection
    (setq y (acet-pljoin-get-best-int2 p2a lst))            ;get the best intersection
    ;put the best intersections in the list x
    (cond
     ((and x y)
      (setq x (list x y))
     );cond #1
     ;;(x (setq x (list x))) ;commented because both objects must pass the best intersect test
     ;;(y (setq x (list y)))
     (T (setq x nil))
    );cond
    (if (and x
             (setq x (acet-geom-m-trans x v 1))
             (setq x (acet-pljoin-get-closest-int2 p1 p2 x))
             (B))) ;arc segment, so get delta angle from arc_info
);if
(setq n 0)
(repeat (length lst)
(setq a (nth n lst))
(if (equal b 0.0)
   (progn
    ;the it's a line segment
    (if (and (or (equal (angle p1 a) a1 #acet-pljoin-prec)                  (equal (abs (- (angle p1 a) a1))
                        (* 2.0 pi)
                        #acet-pljoin-prec
                 )
             );or
             (or (not d)
                 (< (setq c (distance p2 a)) d)
             );or
        );and
        (progn
         (setq d c
               j n
         );setq
        );progn then
    );if
   );progn then line segment
   (progn
    (if (equal p1 a #acet-pljoin-prec)
        (progn
         (setq a2 (* pi 2.0
                     (/ (abs a1) a1)
                  );mult
         );setq then make it 360 degrees and preserve the sign.
        );progn then
        (progn
         (setq nb (acet-pljoin-calc-new-bulge2 p1 b p2 a)
               a2 (acet-geom-pline-arc-info p1 a nb)
               a2 (caddr a2) ;delta angle
         );setq
        );progn else
    );if
    (setq c (abs (- (abs a2)
                    (abs a1)
                 )
            )
    );setq
    (if (and (>= (* a2 a1) 0.0) ;same sign delta angle
             (or (not d)
                 (:);if
;(entdel (entlast))
;(entdel (entlast))
;(if d (entdel (entlast)));if

d
);defun acet-pljoin-get-best-int

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun acet-pljoin-get-closest-int2 ( p1 p2 lst / n a j d )

(setq n 0)
(repeat (length lst)
(setq a (nth n lst)
     a (+ (distance a p1) (distance a p2))
);setq
(if (or (not d)
       (B)
               e2 (acet-list-put-nth (cons 10 x) e2 p1)
        );setq then
        (setq blg (acet-pljoin-calc-new-bulge2 (cdr (nth p2 e2))
                                             (cdr (nth b e2))
                                             (cdr (nth p1 e2))
                                             x
                  )
               e2 (acet-list-put-nth (cons 42 blg) e2 B)
               e2 (acet-list-put-nth (cons 10 x) e2 p1)
        );setq then
    );if
   );progn else arc segment
);if
(setq e1 (append e2 e1))
(if (equal flag 1)
   (setq e1 (reverse e1))
);if
(entmod e1)

);defun acet-pljoin-fillet-mod-epoint

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Make the temporary ent match the segment of interest to get ready to
;use the intersectwith method.
;Takes an entity name and a point that is on one end of the entity
;and a entity list of a single segment lwpolyline
;modifies the single segment polyline such that it matches the
;first or last segment (depending on the p1 provided) of the
;polyline 'na'
;
(defun acet-pljoin-mod-tmp2 ( na p1 tmpe1 / e1 e2 a b z p2 flag v )

(setq    e1 (entget na)
         v (cdr (assoc 210 e1))
        p1 (trans p1 1 v)
        p1 (list (car p1) (cadr p1))
     tmpe1 (subst (assoc 38 e1)  (assoc 38 tmpe1)  tmpe1)
     tmpe1 (subst (assoc 39 e1)  (assoc 39 tmpe1)  tmpe1)
     tmpe1 (subst (assoc 210 e1) (assoc 210 tmpe1) tmpe1)
         z (cdr (assoc 38 e1))
         a (assoc 10 e1)
);setq

(if (equal (cdr a) p1 #acet-pljoin-prec)
   (progn
    (setq  flag 0
          tmpe1 (reverse tmpe1)
          tmpe1 (subst a (assoc 10 tmpe1) tmpe1)
          tmpe1 (reverse tmpe1)
             e2 (cdr (member (assoc 10 e1) e1))
             p2 (list (car p1) (cadr p1) z)
             p1 (cdr (assoc 10 e2))
             p1 (list (car p1) (cadr p1) z)
          tmpe1 (subst (assoc 10 e2) (assoc 10 tmpe1) tmpe1)
              b (* -1.0 (cdr (assoc 42 e2)))
          tmpe1 (subst (cons 42 B)
                       (assoc 42 tmpe1)
                       tmpe1
                )
    );setq
   );progn then
   (progn
    (setq  flag 1
             e2 (reverse e1)
          tmpe1 (reverse tmpe1)
              a (assoc 10 e2)
             p2 (cdr a)
             p2 (list (car p2) (cadr p2) z)
          tmpe1 (subst a (assoc 10 tmpe1) tmpe1)
             e2 (cdr (member a e2))
             p1 (cdr (assoc 10 e2))
             p1 (list (car p1) (cadr p1) z)
              b (cdr (assoc 42 e2))
          tmpe1 (reverse tmpe1)
          tmpe1 (subst (cons 42 B) (assoc 42 tmpe1) tmpe1)
              a (assoc 10 e2)
          tmpe1 (subst (assoc 10 e2) (assoc 10 tmpe1) tmpe1)
    );setq
   );progn else
);if

(entmod tmpe1)

(list e1 flag (list p1 p2 B))
);defun acet-pljoin-mod-tmp

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Calculates the new bulge formed by moving
;point p2 to p3 and still retaining the same radius and center point.
;
(defun acet-pljoin-calc-new-bulge2 ( p1 b p2 p3 / p4 x r a c b2 info )

(setq c (distance p1 p3))
(if (not (equal c 0.0))
   (progn
    (setq   p4 (acet-geom-midpoint p1 p3)
          info (acet-geom-pline-arc-info p1 p2 B)
             r (cadr info);radius
             x (car info) ;center point
             a (- r
                  (distance x p4)
               )
    );setq
    (setq b2 (/ (* 2.0 a) c)
          b2 (* b2 (/ (abs B) B))
    );setq
    (setq info (acet-geom-pline-arc-info p1 p3 b2))
    (if (not (equal x (car info) #acet-pljoin-prec))
        (progn
         (setq a (- (* r 2.0) a));setq
         (setq b2 (/ (* 2.0 a) c)
               b2 (* b2 (/ (abs B) B))
         );setq
        );progn then
    );if
   );progn then
   (setq b2 0.0)
);if

b2
);defun acet-pljoin-calc-new-bulge


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;- explode all curve fitted and/or splined plines and re-join
;- convert all to light weight plines.
;- turn all arcs and lines into lightweight plines.
;- finally return a selection set of all plines.
(defun acet-pljoin-do-ss-pre-work2 ( ss flt / na ss2 ss3 n w)


(command "_.select" ss "")
(setq ss2 (ssget "_p" '((-4 . "&") (70 . 6)))) ;fit or splined
(command "_.select" ss "")
(setq ss3 (ssget "_p" '((-4 . "")))) ;lines and arcs

(if ss2
   (progn
    (setq n 0)
    (repeat (sslength ss2)
    (setq na (ssname ss2 n)
           w (acet-pljoin-get-width2 na)
    );setq
    (command "_.explode" na)
    (while (wcmatch (getvar "cmdnames") "*EXPLODE*") (command ""))
    (command "_.pedit" (entlast) "_y" "_j" "_p" "")
    (if (not (equal w 0.0))
        (command "_w" w)
    );if
    (command "_x")
    (setq ss (ssdel na ss)
          ss (ssadd (entlast) ss)
    );setq
    (setq n (+ n 1));setq
    );repeat
   );progn then
);if
(command "_.convertpoly" "_light" ss "")
(if ss3
   (progn
    (setq n 0)
    (repeat (sslength ss3)
     (setq na (ssname ss3 n));setq
     (command "_.pedit" na "_y" "_x")
     (setq ss (ssdel na ss)
           ss (ssadd (entlast) ss)
     );setq
    (setq n (+ n 1));setq
   );repeat
  );progn then
);if
(if (equal 0 (sslength ss))
   (setq ss nil)
);if
(setq ss (acet-pljoin-ss-flt2 ss flt))


ss
);defun acet-pljoin-do-ss-pre-work


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;return the with of the heavy polyline provided in 'na'
(defun acet-pljoin-get-width2 ( na / e1 a B)

(if (and (setq e1 (entget na))
        (equal (cdr (assoc 0 e1)) "POLYLINE")
   );and
   (progn
    (setq a (cdr (assoc 40 e1))
          b (cdr (assoc 41 e1))
    );setq
    (while (and (equal a B)
                (setq na (entnext na))
                (setq e1 (entget na))
                (not (equal (cdr (assoc 0 e1)) "SEQEND"))
           );and
     (setq a (cdr (assoc 40 e1))
           b (cdr (assoc 41 e1))
     );setq
    );while
   );progn then
   (setq a 0.0)
);if
a
);defun acet-pljoin-get-width

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun acet-pljoin-ss-flt2 ( ss flt / n na e1 p1 p2 )
(if (and ss
        (> (sslength ss) 0)
   );and
   (progn
    (command "_.select" ss "")
    (setq ss (ssget "_p" flt))
   );progn then
   (setq ss nil)
);if

ss
);defun acet-pljoin-ss-flt


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;prompt for a joinmode setting of "Fillet" or "Add"
(defun acet-pljoinmode2 ( / st )
 (acet-pljoin-init-mode2)
 (initget "Fillet Add Both _Fillet Add Both")
 (setq st (getkword
           (acet-str-format "\nEnter join type  <%1>: " #acet-pljoinmode)
          );getkword
 );setq
 (if st
     (progn
      (setq #acet-pljoinmode st)
      (acet-setvar (list "ACET-PLJOINMODE" #acet-pljoinmode 2))
     );progn
 );if
);defun acet-pljoinmode

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun acet-pljoin-init-mode2 ()
(if (not #acet-pljoinmode)
    (setq #acet-pljoinmode (acet-getvar '("ACET-PLJOINMODE" 2)))
);if
(if (not #acet-pljoinmode)
    (progn
     (setq #acet-pljoinmode "Both")
     (acet-setvar (list "ACET-PLJOINMODE" #acet-pljoinmode 2))
    );progn then
);if
#acet-pljoinmode
);defun acet-pljoin-init-mode

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;prompt for fuzz distance and/or pljoinmode setting.
;return list... (fuzz pljoinmode)
;
(defun acet-pljoin-get-fuzz-and-mode2 ( / st fuzz )
;;;;always say Both first
    (progn
     (setq #acet-pljoinmode "Both")
     (acet-setvar (list "ACET-PLJOINMODE" #acet-pljoinmode 2))
    );progn then
 (if (not #acet-pljoin-fuzz)
     (setq #acet-pljoin-fuzz 0.0)
 );if
 (if (assoc "OSMODE" (car acet:sysvar-list))
     (setvar "OSMODE" (cadr (assoc "OSMODE" (car acet:sysvar-list))))
 );if
 (setq fuzz "")
 (while (equal (type fuzz) 'STR)
;;;;;show status
 (setq st (acet-pljoin-init-mode2))
 (princ (acet-str-format "\n Join Type = %1" st))
 (if (equal "Both" st)
     (princ " (Fillet and Add) ")
 );if
;;;
  (initget "Jointype _Jointype" 4)
  (setq fuzz (getdist
               (acet-str-format "\nEnter fuzz distance or  <%1>: " (rtos #acet-pljoin-fuzz))
             );getdist
  );setq
  (cond
   ((not fuzz)
    (setq fuzz #acet-pljoin-fuzz)
   );cond #1
   ((equal "Jointype" fuzz)
    (acet-pljoinmode2)
   );cond #2
   ((equal (type fuzz) 'REAL)
    (setq #acet-pljoin-fuzz fuzz)
   );cond #3
  );cond close
 );while
 (setvar "osmode" 0)

 (list #acet-pljoin-fuzz #acet-pljoinmode)
);defun acet-pljoin-get-fuzz-and-mode


<<

Filename: 129357_jp.lsp
Tác giả: vetgo
Bài viết gốc: 162935
Tên lệnh: ff
(Yêu cầu) lisp fillet. lấy một đối tuợng chọn làm chuân

Chắc ý của bác ĐVH là :

(defun c:FF(/ e1 e2)
(setq e1 (car(entsel "Doi tuong 1 :")))(redraw e1 3)
(setq e2(car(entsel "Doi tuong 2...
>>

Chắc ý của bác ĐVH là :

(defun c:FF(/ e1 e2)
(setq e1 (car(entsel "Doi tuong 1 :")))(redraw e1 3)
(setq e2(car(entsel "Doi tuong 2 :")))(redraw e2 3)
(vl-cmdf ".MATCHPROP" e1 e2 "")
(initget "U P R T M ")
(setq ans (getstring "uNdo/Polyline/Radius/Trim/mUltiple"))
(cond 
((= (strcase ans) "N")(command ".fillet" ans ""))
((= (strcase ans) "P")(command ".fillet" ans pause))
((wcmatch (strcase ans) "R,T,U")(command ".fillet" ans pause ".fillet" e1 e2))
(T (command ".fillet" e1 e2))
)
)

Chuẩn luôn, nhưng lựa chọn Trim đang có vấn đề, vẫn không lấy được hết các lựa chọn của Cad về lệnh Fillet!


<<

Filename: 162935_ff.lsp
Tác giả: quansla
Bài viết gốc: 398537
Tên lệnh: fg
Đóng Ngoặc Text, Mtext, Dim

Bạn thử cái này xem sao . chú ý trong LISP co đoạn cho phép chỉnh sửa dấu ngoặc bạn có thể thay đổi tuỳ ý (trong mặc định đang là 1) bạn thay số này bằng số 2,3,... sẽ thấy sự thay đổi khi chọn đối tượng

 

 


(defun c:fg (/ ss checkstring SoluongNgoac obj)
(defun checkstring (str N / loc_lst lst r l1 l2 str1 str2)
(setq lst (vl-string->list str)
l1...
>>

Bạn thử cái này xem sao . chú ý trong LISP co đoạn cho phép chỉnh sửa dấu ngoặc bạn có thể thay đổi tuỳ ý (trong mặc định đang là 1) bạn thay số này bằng số 2,3,... sẽ thấy sự thay đổi khi chọn đối tượng

 

 


(defun c:fg (/ ss checkstring SoluongNgoac obj)
(defun checkstring (str N / loc_lst lst r l1 l2 str1 str2)
(setq lst (vl-string->list str)
l1 lst
str1 "" str2 "")
(defun loc_lst (i r / r2)
(setq r2 r)
(while (= (car(member i r2)) i) (setq r2 (cdr(member i r2))))
r2)
(setq r (loc_lst 40 l1)
r (loc_lst 41 (reverse r))
r (reverse r))
(repeat N (setq str1 (strcat str1 "(" )))
(repeat N (setq str2 (strcat str2 ")" )))
(strcat str1 (vl-list->string r) str2)
)

;;;Chinh sua so luong BO Dau Ngoac o day
(setq SoluongNgoac 1)

; (setq obj (vlax-ename->vla-object (car(entsel))))
(if (setq ss (ssget '((0 . "*DIM*,*TEXT"))))
(progn
(vlax-for obj (vla-get-activeselectionset(vla-get-activedocument(vlax-get-acad-object)))
(cond
((wcmatch (vla-get-objectname obj) "*Text*")
(vla-put-textstring obj (checkstring (vla-get-textstring obj) SoluongNgoac)))
((wcmatch (vla-get-objectname obj) "*Dim*")
(if (= (vla-get-textoverride obj) "")
(vla-put-textoverride obj (checkstring(rtos (vla-get-measurement obj)) SoluongNgoac))
(vla-put-textoverride obj (checkstring(vla-get-textoverride obj) SoluongNgoac))
)
)))
)
)
(princ)
)



<<

Filename: 398537_fg.lsp
Tác giả: Duong Nhat Duy
Bài viết gốc: 430350
Tên lệnh: zz
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

Mình muốn viết 1 lisp nhỏ về in ấn và rất cần sợ trợ giúp của các bạn, cụ thể như sau:

Công việc của mình là tổng hợp, in ấn bản vẽ của các bộ môn khác nhau, vì tất cả các bản vẽ đều đã trình bày sẵn layout, nên mình chỉ cần check lại khổ giấy, nét in, ... sau đó publish ra 1 file pdf rồi in ấn = pdf (chứ không phải in = cad).

Về cái vấn đề in ấn này thì...

>>

Mình muốn viết 1 lisp nhỏ về in ấn và rất cần sợ trợ giúp của các bạn, cụ thể như sau:

Công việc của mình là tổng hợp, in ấn bản vẽ của các bộ môn khác nhau, vì tất cả các bản vẽ đều đã trình bày sẵn layout, nên mình chỉ cần check lại khổ giấy, nét in, ... sau đó publish ra 1 file pdf rồi in ấn = pdf (chứ không phải in = cad).

Về cái vấn đề in ấn này thì mình cũng mới tìm hiểu, sau khi mày mò thì viết được cái lisp này, ý nghĩa là tự động setup nét in, khổ giấy của tất cả các layout (chỉ setup chứ không in).

Tuy nhiên còn 1 vấn đề đó là cửa sổ vùng in, mình thử hiệu chỉnh cái thuộc tính PlotOrigin nhưng cửa sổ nó không dịch chuyển theo ý mình muốn. Mình muốn chọn cửa sổ vùng in là từ điểm 0,0 đến 841,594 (vì mình in khổ A1) nhưng chưa biết phải làm thế nào.

Mong được các bạn giúp đỡ. Mình xin cảm ơn !

(defun C:zz ()
  (setq acadobj (vlax-get-acad-object))
  (setq doc (vla-get-ActiveDocument acadobj))
  (vlax-for layout (vla-get-layouts doc)
    (if (/= (vla-get-Name layout) "Model")
      (progn
	(vla-put-Configname layout "DWG To PDF.pc3")
	(vla-put-CanonicalMediaName layout "ISO_A1_(841.00_x_594.00_MM)")
	(vla-put-PaperUnits layout 1)
	(vla-put-PlotHidden layout :vlax-false)
	(vla-put-PlotOrigin layout (vlax-safearray-fill (vlax-make-safearray vlax-vbDouble '(0 . 1)) '(0 0)))
	(vla-put-PlotType layout 4)
	(vla-put-PlotViewportBorders layout :vlax-false)
	(vla-put-PlotViewportsFirst layout :vlax-true)
	(vla-put-PlotWithLineweights layout :vlax-true)
	(vla-put-PlotWithPlotStyles layout :vlax-true)
	(vla-put-ScaleLineweights layout :vlax-false)
	(vla-put-StandardScale layout 0)
	(vla-put-StyleSheet layout "acad.ctb")
	(vla-put-TabOrder layout 3)
	(vla-put-UseStandardScale layout :vlax-true)
	)
      )
    )
  (print)
  )

 


<<

Filename: 430350_zz.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 146465
Tên lệnh: lipo
Hàm polar

Đây là UCS trong bản vẽ của em:

1-10.jpg

Em muốn vẽ 3 đoạn thẳng...

>>

Đây là UCS trong bản vẽ của em:

1-10.jpg

Em muốn vẽ 3 đoạn thẳng liên tiếp nhau từ pt1 đến pt2, trong đó đoạn đầu tiên từ pt1 về hướng pt2, có độ dài là a, và đoạn cuối từ pt2 về hướng pt1 cũng có độ dài là a. Em đã viết một lisp như sau:

;;; Creates a line by an angle and a distance
;;; written by pdle
(defun C:lipo ()
(setq	pt1 (getpoint "\nSpecify the first point: ")
		pt2 (getpoint "\nSpecify the second point: ")
		a   (getreal  "\nThe length of the line: ")
)
(Line pt1 (setq tmp1 (polar pt1 (angle pt1 pt2) a)))
(Line pt2 (setq tmp2 (polar pt2 (angle pt2 pt1) a)))
(Line tmp1 tmp2)
)
(defun Line (1st 2nd) (entmakex (list (cons 0 "LINE") (cons 10 1st) (cons 11 2nd))));;; Create a line by the first and end point

Nhưng khi nhập vào commandline lênh lipo và các tham số của nó thì không vẽ được các đường như mong muốn.

Đây là bản vẽ này: http://www.mediafire.com/?ff58b8kmiy62e6j

 

Tuy nhiên khi em load lisp này vào một bản vẽ 2D bình thường thì nó lại chạy rất ổn!

 

Xin mọi người cho ý kiến, giúp em với ạ !

Theo định nghĩa góc trong hàm polar thì đó là góc tạo với trục X. Bạn kiểm tra lại xem.


<<

Filename: 146465_lipo.lsp
Tác giả: bktec84
Bài viết gốc: 92078
Tên lệnh: chuthichthep
Nhờ các bác viết hộ lisp giúp thống kê thép nhanh hơn.

Không biết bạn vẽ các thanh thép bằng đối tượng gì, tôi hay vẽ bằng Donut nên đã làm theo cách này.

- Chọn điểm chèn

- Chọn các Donut có cùng ký...

>>
Không biết bạn vẽ các thanh thép bằng đối tượng gì, tôi hay vẽ bằng Donut nên đã làm theo cách này.

- Chọn điểm chèn

- Chọn các Donut có cùng ký hiệu

- Chèn Leader.

(defun c:ChuThichThep()
 (setq Pt0 (getpoint "\nChon diem chen: "))
 (prompt "\nChon cac thanh thep can chu thich: ")
 (setq ss (ssget '((-4 . "")))
SSLen (sslength ss)
I -1
J -1)
 (while (setq DoNut (ssname ss (setq I (1+ I))))
(setq Pt1 (cdr (nth 14 (entget donut)))
  Pt2 (cdr (nth 18 (entget donut)))
  Dis (distance Pt1 Pt2)
  Ang (angle Pt1 Pt2)
  Center (polar Pt1 Ang (/ Dis 2))
  PtIns (polar Center (angle Center Pt0) Dis))
(command "qleader" PtIns Pt0)
 )
)

Lưu ý, setting của qleader có Number of points = 2, Annotation = none

Cảm ơn anh nhé. Nhưng ý em là điểm đầu mình chọn là điểm gốc, sau đó chọn các điểm tiếp theo là điểm muốn chỉ đến vị trí thanh thép, vì có khi đối tượng là Line, polyline, block chẩng hạn.

ah mà cai lisp của anh em đã chạy thử rồi nó báo lỗi anh ah. như sau:

Command: CHUTHICHTHEP

Chon diem chen:

Chon cac thanh thep can chu thich:

Select objects: 1 found

Select objects: 1 found, 2 total

Select objects: 1 found, 3 total

Select objects: 1 found, 4 total

Select objects: 1 found, 5 total

Select objects:

; error: bad argument type: 2D/3D point: 0

đây là quá trình em thực hiện như lỗi đúng không anh.

Mong anh giup em theo yêu câu trên của em nhé.


<<

Filename: 92078_chuthichthep.lsp
Tác giả: quickandfine
Bài viết gốc: 203735
Tên lệnh: bt 10
Lisp ghi bước thép với khoảng cách thép đều nhau

Thêm 1 phương án :

(defun C:bt(/ ctc ss)
 (or *ctc* (setq *ctc* 200))
 (initget 6)
 (setq ctc (getint (strcat"\nNhap buoc thep...
>>

Thêm 1 phương án :

(defun C:bt(/ ctc ss)
 (or *ctc* (setq *ctc* 200))
 (initget 6)
 (setq ctc (getint (strcat"\nNhap buoc thep <" (itoa *ctc*) ">:")) )
 (if ctc (setq *ctc* ctc))
 (if (setq ss (ssget"_:L" (list (cons 0 "DIMENSION")) ))
(progn
 	(command "_.undo" "_begin")    
 	(foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
(vla-put-TextOverride (vlax-ename->vla-object ent)
  (strcat (itoa (fix(/ (cdr (assoc 42 (entget ent))) *ctc*)))
"x" (itoa *ctc*) "=<>"))	)
 	(command "_.undo" "_end") (princ)  )))
(defun C:10(/ num ss)
 (if (setq ss (ssget"_:L"))
(progn
 	(command "_.undo" "_begin")
 	(or *num* (setq *num* 15))
 	(initget 4)
 	(setq num (getint (strcat"\nNhap color <" (itoa *num*) ">:")) )
 	(while (not (if num (<= num 256)T) )
(princ "\nGia tri <=256.")
(setq num (getint (strcat"\nNhap color <" (itoa *num*) ">:")) ))
 	(if num (setq *num* num))
 	(foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
(vla-put-Color (vlax-ename->vla-object ent)*num* )	)
 	(command "_.undo" "_end") (princ)  )))

Bác gia_bach ơi bác có thể xem giúp em đoạn lisp trên với. Em mới cài Cad 2008 và khi ghi bước thép cũng như khi đổi màu đối tượng thì nó báo lỗi. Kiểu như sau:

 

Command: bt

 

Nhap buoc thep <200>:

 

Select objects: 1 found

 

Select objects: _.undo Current settings: Auto = On, Control = All, Combine =

Yes

Enter the number of operations to undo or

<1>: _begin

Command: ; error: no function definition: VLAX-ENAME->VLA-OBJECT

Em không biết nó là lỗi gì. Bác xem giúp em với nhé.

Thanks bác nhiều.


<<

Filename: 203735_bt_10.lsp
Tác giả: conghoa
Bài viết gốc: 409510
Tên lệnh: ttt
Tự Động Ghi Chú Đoạn Thẳng Theo Thứ Tự Tăng Dần

 

Bạn thử coi có được không?

(defun attfill (Lobjfind Lrep) (mapcar '(lambda(x y) (vlax-put x 'textstring y))...
>>

 

Bạn thử coi có được không?

(defun attfill (Lobjfind Lrep) (mapcar '(lambda(x y) (vlax-put x 'textstring y)) Lobjfind Lrep ))
(defun Tue-geom-divpt (p1 p2 k) (polar p1 (angle p1 p2) (* (distance p1 p2) k)))
(defun c:ttt(/ i  tto ename lst-length ss ename lst-re kq ls-kq ttu)
(setq tto (getstring t "\nNhap tien to :")) (setq ttu (getint "\nThu tu :") ttu0 ttu)
  (while (setq ename (car (entsel "Chon Line :")))
   (if ename (progn
       (setq L-length (vlax-curve-getDistAtPoint ename (vlax-curve-getEndPoint ename)))
    (if (null (member L-length lst-length))
        (setq kq (strcat tto (if (< ttu 10) (strcat "0" (itoa ttu)) (itoa ttu)))
          lst-length (append lst-length (list L-length)) ttu (1+ ttu))
        (setq vitri (VL-POSITION L-length lst-length)
          kq (strcat tto (if (< (+ ttu0 vitri) 10) (strcat "0" (itoa (+ ttu0 vitri))) (itoa (+ ttu0 vitri))))
        )
    )  
        (attfill (vlax-invoke (vla-InsertBlock (vla-get-modelspace (vla-get-ActiveDocument (vlax-get-acad-object)))
         (vlax-3d-point (Tue-geom-divpt (vlax-curve-getstartPoint ename) (vlax-curve-getEndPoint ename) 0.5))
        "BlockKH" 1 1 1 0) 'getattributes)
         (list "GOC" (rtos L-length 2 0) kq)
    )
   ))
  )
(princ)
)

Vẫn không được bác ạ, chọn sai là kết thúc luôn


<<

Filename: 409510_ttt.lsp
Tác giả: vbtxd06
Bài viết gốc: 239108
Tên lệnh: mds mts cdc cds
Nhờ các bác giúp đổi tên dimension style!

 

Mình có một số bản vẽ cad, trong mỗi bản vẽ này đều sử dụng 1 dimension style có tên giống nhau (đều đặt tên là...

>>

 

Mình có một số bản vẽ cad, trong mỗi bản vẽ này đều sử dụng 1 dimension style có tên giống nhau (đều đặt tên là abc chẳng hạn cho tất cả các file) nhưng có thuộc tính "fit->overall scale" khác nhau. Do yêu cầu công việc, mình muốn gộp tất cả vào thành 1 file bằng cách mở 1 file số 1, sau đó mở file số 2, dùng Ctrl+C và Ctrl+V cop từ file 2 dán sang file 1, cứ như vậy cho n file. Nhưng xảy ra hiện tượng các kích thước bị nhảy thành tỉ lệ theo file số 1 (do tên của dimesion style giống nhau). Mình giải quyết bằng cách đổi tên hết các dimension style cho từng file thành các tên khác nhau rồi cop thì đc. Nhưng vấn đề là số lượng file lớn, nếu đổi theo cách thủ công như trên thì rất mất thời gian mà mình lại k rành về lisp hay VBA. AE xem có cách nào giải quyết giúp mình k?

Cám ơn mọi người quan tâm!

Cái này mình đã hỏi bên Meslab nhưng chưa có câu trả lời, hi vọng là các cao thủ giúp mình.

Chào bạn. Dưới đây là 1 số lệnh lisp về Dimension style mong có thể giúp ích được bạn. Mình không rành về lisp lắm, nếu không giúp được nhiều cho bạn mong các cao thủ cadviet giúp đỡ bạn tận tình.

;-------------------Make Dimension Style-----------------
(defun c:MDS (/ scl fcal scal );dmasz dexo dexo dtxt dgap dclre dclrt dsn ao ad obj)
(vl-load-com)
(if scl scl (setq scl "1:20"))
(if #TS #TS (setq TS ""))
(setq scl (USTR "" "Specify Scale factor of Drawing" scl nil))
(setq fcal (atof (substr scl 1 1)))
(setq scal (atof (substr scl 3 3)))
(setq tyle (/ scal fcal))
(setq #TS (USTR "" "Enter Name of text Style" #TS nil))
(setvar "DIMALTF" 25)
(setvar "DIMALTTZ" 13)
(setvar "DIMALTZ" 13)
(setvar "DIMASZ" 2.5) ;Arrow size
(setvar "DIMCEN" 2.5) ;Center Mark size
(setvar "DIMDLE" 1) ;extend beyond tick
(setvar "DIMTOFL" 1);Dim Tolarance
(setvar "DIMDLI" 7) ;Base line spacing
(setvar "DIMEXE" 1) ;extend beyond dim line
(setvar "DIMEXO" 1) ;offset from origin
(setvar "DIMTMOVE" 1) ;
(setvar "DIMDEC" 0) ;phan lay thap phan
(setvar "DIMCLRT" 2) ;color text
(setvar "DIMTXT" 2.5);Text height
(setvar "DIMLFAC" 1) ;Primary Unit scale factor
(setvar "DIMSCALE" tyle);Scale Overall
(setvar "DIMTIX" 1) ;
(setvar "DIMTIH" 0)
(setvar "DIMTSZ" 0) ;closed filled
(setvar "DIMBLK" "") ;closed filled
(setvar "DIMGAP" 1) ;offset from dim line
(setvar "DIMTOH" 0)
(setvar "DIMTAD" 1) ;
(setvar "DIMTXSTY" #TS);Dim text style
(setvar "DIMTDEC" 0)
(setvar "DIMTZIN" 13)
(setvar "DIMZIN" 13)
;------
(setq dsn (strcat "TL" (substr scl 3 3)))
(setq ao (vlax-get-acad-object))
(setq ad (vla-get-ActiveDocument ao))
(setq obj (vla-add(vla-get-dimstyles ad) dsn))
(vla-copyfrom Obj ad)
(vla-put-activedimstyle ad Obj)
(princ)
);end
(Defun C:MTS(/ Name font);---Make Text Style
 (PROMPT "\n Make a new Text Style !")
 (if Font Font(setq Font "Vni-Helve-Consende"))
 (Setq Name (getstring 5"\nEnter Name of Text Style:")
       Font (getstring 5"\nEnter Full Font Name Text Style<Arial,Vni-Helve-Condense,.VnAvantH...>"))
  (command "-Style" Name Font 0 1 0 "n" "n")
  (command "ZOOM" "a")
 (princ)
);The end
;=====================================================================================================
 ;;;==============================================================================================
;;;-----------Chuyen all cac Dimension ve Dimstyle hien hanh--------------
(defun DIM_ssget ( / ssl  nsset temp ed )
  (setq sset (ssget))
  (setq ssl (sslength sset)
        nsset (ssadd)
  )
  (print ssl)
  (princ "entities found. ") 
  (while (> ssl 0)
    (progn
      (setq temp (ssname sset (setq ssl (1- ssl))))
      (setq ed (entget temp))
      (if (= (DXF 0 ed) "DIMENSION") (ssadd temp nsset))
    )
  )
  (setq ssl (sslength nsset)
        sset nsset
  )
  (print ssl)
  (princ "DIMENSION entities found. ")
  (princ)
);defun DIM_ssget
(defun c:CDC() (command "DIM1" "UP"))
;------------------
(defun C:CDS()
(Princ "\nChuyen Dimstyle hien hanh !")
(Princ "\nChon dimension muon Dimstyle current...")
(command ".-dimstyle" "r" "" pause)nil
(Princ));

<<

Filename: 239108_mds_mts_cdc_cds.lsp
Tác giả: nguyentuyen6
Bài viết gốc: 111948
Tên lệnh: khung
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

E viết cái lisp như này mà ko hiểu sao lại tắc tịt không chạy đc .hjx .Bác nào giúp e với...Thank!!!

 

(defun BatDau() (setq OldOs (getvar "osmode")) (setvar "osmode" 0))

(defun KetThuc() (setvar "osmode" OldOs)(princ))

(defun moddxf (dxf chdxf ss) (entmod (subst (cons dxf chdxf) (assoc dxf (entget ss)) (entget ss))))

(defun Aver2 (x y) (/ (+ (float x) (float y)) 2) ) ;;;Average x & y, return Real

(defun Mid2P (p1 p2)...
>>

E viết cái lisp như này mà ko hiểu sao lại tắc tịt không chạy đc .hjx .Bác nào giúp e với...Thank!!!

 

(defun BatDau() (setq OldOs (getvar "osmode")) (setvar "osmode" 0))

(defun KetThuc() (setvar "osmode" OldOs)(princ))

(defun moddxf (dxf chdxf ss) (entmod (subst (cons dxf chdxf) (assoc dxf (entget ss)) (entget ss))))

(defun Aver2 (x y) (/ (+ (float x) (float y)) 2) ) ;;;Average x & y, return Real

(defun Mid2P (p1 p2) ;;Middle point from p1, p2
(list (Aver2 (car p1) (car p2)) (Aver2 (cadr p1) (cadr p2)) (Aver2 (caddr p1) (caddr p2)))
)
;=========== Lap Khung Ten ===========;

;====================================;
(defun c:khung (/ dis121 dis141 rpt11 rpt21 rpt31 rpt41 mid121 mid231 mid341 mid411 off_set bn bp 
                      ssbv kmid12 kmid23  kmid34 kmid41 sel entkt Rec Rec1 pt1 pt2 rpt1 rpt2 rpt3 rpt4 mid12 
                      mid23 mid34 mid41 dis12 dis14 dis  toadodinh khoangcach i el1 el2 el3 el4 ssd 
                      en OldOs OldEcho )
(vl-load-com)
(setq OldEcho (getvar "cmdecho")) 
(setvar "cmdecho" 0)
(command "undo" "be")
(princ "\n       © nguyentuyen6 @CadViet ")
(princ "\n Cai Express-Tools truoc khi su dung!!!")
;====================;
;;;XU LY KHUNG TEN;;;;
;====================;
(setq sel (entsel "\nChon block khung ten:"))
(setq entkt (car sel))
(setq Rec (acet-ent-geomextents entkt)
	  pt1 (nth 0 Rec);lay dinh
	  pt2 (nth 1 Rec))
;		  i 0);setq
;-----acet-ent-geomextents:diem thap nhat trai va cao nhat phai
(BatDau)
(command "RECTANG" pt1 pt2)
(KetThuc)	
(setq el1 (entlast));el1

;-----lay dinh HCN = acet-geom-vertex-list
(setq toadodinh (acet-geom-vertex-list el1); 
	  rpt1 (nth 0 toadodinh);lay dinh 
	  rpt2 (nth 1 toadodinh)
	  rpt3 (nth 2 toadodinh)
	  rpt4 (nth 3 toadodinh)
;--
	  mid12 (Mid2P rpt1 rpt2);lay trung diem
	  mid23 (Mid2P rpt2 rpt3)
	  mid34 (Mid2P rpt3 rpt4)
	  mid41 (Mid2P rpt4 rpt1)
;--
	  dis12 (distance rpt1 rpt2)
	  dis14 (distance rpt1 rpt4));setq
;--
(setq kmid12 (polar mid12 (/ pi 2) (/ (* dis14 4) 100))
	  kmid34 (polar mid34 (/ (* pi 3) 2) (/ (* dis14 4) 100))
	  kmid23 (polar mid23 pi (/ (*dis12 20) 140))
	  kmid41 (polar mid41 0.0 (/ (* dis12 6) 140))
	  )
(command "ERASE" el1 "");xoa hcn

;====================;
;;;XU LY BAN VE;;;;
;====================;		 

 (setq bn (rtos (fix (* (getvar "CDATE") 100000)) 2 0)
;  (setq bp (getpoint "\nBase Point <0,0,0>:   "))
       bp (setq bp '(0 0 0)))
 (while (not ssbv)
        (setq ssbv (ssget "\nChon ban ve: ")))
 (command "_.BLOCK" bn bp ssbv ""
          "_.INSERT" bn bp 1 1 0)
(setq el4 (entlast));el4    
(princ)
(setq Rec1 (acet-ent-geomextents el4)
  pt11 (nth 0 Rec1);lay dinh
  pt21 (nth 1 Rec1))
;		  ii 0);setq
;-----acet-ent-geomextents:diem thap nhat trai va cao nhat phai
(BatDau)
(command "RECTANG" pt11 pt21)
(KetThuc)	
(setq el2 (entlast));el2

;-----khoang cach mac dinh
(setq khoangcach (getreal "\nKhoang cach khung ten va ban ve:"))
(if (= khoangcach nil) (setq khoangcach (/ (* dis12 5) 140)))
;---
   (setq off_set (polar pt21 (/ pi 2) khoangcach))	
(command "OFFSET" el2 off_set);offset
(setq el3 (entlast));el3
;-----lay dinh HCN = acet-geom-vertex-list
(setq toadodinh1 (acet-geom-vertex-list el3)
	  rpt11 (nth 0 toadodinh1);lay dinh
	  rpt21 (nth 1 toadodinh1)
	  rpt31 (nth 2 toadodinh1)
	  rpt41 (nth 3 toadodinh1)
;--
	  mid121 (Mid2P rpt11 rpt21);lay trung diem
	  mid231 (Mid2P rpt21 rpt31)
	  mid341 (Mid2P rpt31 rpt41)
	  mid411 (Mid2P rpt41 rpt11)
;--
	  dis121 (distance rpt11 rpt21)
	  dis141 (distance rpt11 rpt41));setq
;----- Chia truong hop cao va dai
(if (> dis121 dis141)		  
	  (command "ALIGN" khungten "" kmid41 mid141 kmid23 mid231 "" "Y" "");T
	  (command "ALIGN" khungten "" kmid34 mid341 kmid12 mid121 "" "Y" "");F
) ;if
;-----	
(command "ERASE" el2 "");xoa hcn
(command "ERASE" el3 "");xoa hcn offset
(command "EXPLODE" el4 "")
;---------------
(command "undo" "e")
(KetThuc)
(setvar "cmdecho" OldEcho)
(princ "\n...Done...")
(princ)
);defun


<<

Filename: 111948_khung.lsp
Tác giả: phamngoctukts
Bài viết gốc: 112070
Tên lệnh: stb
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)
Cảm ơn các bác đã giúp em !!!. Đây là líp em sửa lại chạy thấy kết quả cũng tốt nhưng khổ nỗi dùng đc vài lần là lại hiện bảng báo lỗi như thế...
>>
Cảm ơn các bác đã giúp em !!!. Đây là líp em sửa lại chạy thấy kết quả cũng tốt nhưng khổ nỗi dùng đc vài lần là lại hiện bảng báo lỗi như thế này:

 

FATAL ERROS: commands may not be nested more than 4 deeps

 

Còn đây là líp:

 

(defun BatDau() (setq OldOs (getvar "osmode")) (setvar "osmode" 0))

(defun KetThuc() (setvar "osmode" OldOs)(princ))

;=========== Lap Khung Ten ===========;

;====================================;
(defun c:khung (/ pt11 pt21 khungten dis121 dis141 rpt11 rpt21 rpt31 rpt41
mid121 mid231 mid341 mid411 off_set bn bp ssbv kmid12 kmid23 kmid34
kmid41 sel entkt Rec Rec1 pt1 pt2 rpt1 rpt2 rpt3 rpt4 mid12 mid23 mid34 
mid41 dis12 dis14 dis toadodinh toadodinh1 khoangcach i el1 el2 el3 el4
ssd en OldOs OldEcho )
(vl-load-com)
(setq OldEcho (getvar "cmdecho")) 
(setvar "cmdecho" 0)
(command "undo" "be")
;(princ "\n       © nguyentuyen6 @CadViet ")
(princ "\n Cai Express-Tools truoc khi su dung!!!")
;====================;
;;;XU LY KHUNG TEN;;;;
;====================;
(setq khungten (entsel "\nChon block khung ten: "))
(setq entkt (car khungten))
(setq Rec (acet-ent-geomextents entkt)
	  pt1 (nth 0 Rec) ;lay dinh
	  pt2 (nth 1 Rec))

;-----acet-ent-geomextents:diem thap nhat trai va cao nhat phai
(BatDau)
(command "RECTANG" pt1 pt2)
(KetThuc)	
(setq el1 (entlast));el1

;-----lay dinh HCN = acet-geom-vertex-list
(setq toadodinh (acet-geom-vertex-list el1)
	  rpt1 (nth 0 toadodinh);lay dinh
	  rpt2 (nth 1 toadodinh)
	  rpt3 (nth 2 toadodinh)
	  rpt4 (nth 3 toadodinh)
	  mid12 (list (/ (+ (car rpt1) (car rpt2)) 2) (/ (+ (cadr rpt1) (cadr rpt2)) 2))
	  mid23 (list (/ (+ (car rpt2) (car rpt3)) 2) (/ (+ (cadr rpt2) (cadr rpt3)) 2))
	  mid34 (list (/ (+ (car rpt3) (car rpt4)) 2) (/ (+ (cadr rpt3) (cadr rpt4)) 2))
	  mid41 (list (/ (+ (car rpt4) (car rpt1)) 2) (/ (+ (cadr rpt4) (cadr rpt1)) 2))
	  dis12 (distance rpt1 rpt2); khoang cach
	  dis14 (distance rpt1 rpt4)
);setq
;--
(setq kmid12 (polar mid12 (/ pi 2) (/ (* dis14 4) 100))
	  kmid34 (polar mid34 (/ (* pi 3) 2) (/ (* dis14 4) 100))
	  kmid23 (polar mid23 pi (/ (* dis12 20) 140))
	  kmid41 (polar mid41 0.0 (/ (* dis12 6) 140))
	  )
;====================;
;;;XU LY BAN VE;;;;
;====================;		 

 (setq bn (rtos (fix (* (getvar "CDATE") 100000)) 2 0)); block ban ve
 (while (not ssbv)
        (setq ssbv (ssget)))
 (command "_.BLOCK" bn kmid41 ssbv ""
          "_.INSERT" bn kmid41 1 1 0)
(setq el4 (entlast));el4    
;----
(setq Rec1 (acet-ent-geomextents el4)
  pt11 (nth 0 Rec1);lay dinh
  pt21 (nth 1 Rec1))

;-----acet-ent-geomextents:diem thap nhat trai va cao nhat phai
(BatDau)
(command "RECTANG" pt11 pt21)
(KetThuc)	
(setq el2 (entlast));el2

;-----khoang cach mac dinh

(setq khoangcach (/ (* dis12 15) 140))

;---
   (setq off_set (polar pt21 (/ pi 2) khoangcach))	
(command "offset" khoangcach el2 off_set "") ;offset
(setq el3 (entlast));el3
;-----lay dinh HCN = acet-geom-vertex-list
(setq toadodinh1 (acet-geom-vertex-list el3)
	  rpt11 (nth 0 toadodinh1);lay dinh
	  rpt21 (nth 1 toadodinh1)
	  rpt31 (nth 2 toadodinh1)
	  rpt41 (nth 3 toadodinh1)
;--
;lay trung diem
                 mid121 (list (/ (+ (car rpt11) (car rpt21)) 2) (/ (+ (cadr rpt11) (cadr rpt21)) 2))
	  mid231 (list (/ (+ (car rpt21) (car rpt31)) 2) (/ (+ (cadr rpt21) (cadr rpt31)) 2))
	  mid341 (list (/ (+ (car rpt31) (car rpt41)) 2) (/ (+ (cadr rpt31) (cadr rpt41)) 2))
	  mid411 (list (/ (+ (car rpt41) (car rpt11)) 2) (/ (+ (cadr rpt41) (cadr rpt11)) 2))

;--
	  dis121 (distance rpt11 rpt21)
	  dis141 (distance rpt11 rpt41));setq
;----- Chia truong hop cao va dai
(BatDau)
(if (> dis121 dis141)		  
	  (command "ALIGN" entkt "" kmid41 mid411 kmid23 mid231 "" "Y" "");T
	  (command "ALIGN" entkt "" kmid34 mid341 kmid12 mid121 "" "Y" "");F
) ;if
(KetThuc)	
;-----	
(command "ERASE" el1 "");xoa hcn
(command "ERASE" el2 "");xoa hcn
(command "ERASE" el3 "");xoa hcn offset
(command "EXPLODE" el4 "")
;---------------
(command "undo" "e")
(setvar "cmdecho" OldEcho)
(princ "\n...Done...")
(princ)
);defun

Cái này lỗi do bạn sử dụng lệnh align. Mình cũng bị trường hợp này rồi. Bạn tham khảo cái nay nhé

Để viết lisp thay thế align thì:

-Chọn đối tượng.

-Chọn điểm xuất phát 1 (a), điểm đến 1 (:cheers:.

-Chọn điểm xuất phát 2 ©, điểm đến 2 (d).

-Lấy góc ac, dài ac.

-Lấy góc bd, dài bd.

Move đối tượng từ a đến b, rotate góc bằng góc bd-ac, scale tỉ lệ dài bd/ac.

và code Ironpat của mình

Cám ơn bác Duy và bác Bình. Nhờ ơn 2 bác mà lisp cua em chay ầm ầm.

(defun nhapsolieu ()
(initget 1)
(setq goc1 (getangle p01 "chon diem thu 2 theo huong hoac nhap goc: "))
(setq goc (/ (* goc1 180) pi))
(setq xulygoc (- 45 (/ goc 2)))
(setq gocra (/ (* pi xulygoc) 180))
(setq sina (sin gocra))
(setq cosa (sqrt (- 1 (expt sina 2))))
(setq tang (/ sina cosa))
(setq a (distance p2 p3))
(setq duongcheo (* a (sqrt 2)))
(setq b (/ duongcheo (* 2 tang)))
(setq anso (- b (/ duongcheo 2)))
(setq x (* anso 2))
(setq hs (+ (/ x duongcheo) 1))
)

(defun chondoituong ()
(princ "\nchon doi tuong: ")
(setq ssa (ssget))
(command ".copy" ssa "" "0,0" "0,0")
(setq ssb (ssget "l"))
(setq n (sslength ssb))
(setq i 0)
(while (< i n)
(setq n (sslength ssb))
(setq ent (ssname ssb i))
(setq name (cadr (entget ent)))
(if (equal name '(0 . "INSERT"))
(progn
(command "explode" ent)
(setq ssc (ssget "p"))
(setq n1 (sslength ssc))
(setq i1 0)
(while (< i1 n1)
(setq ent1 (ssname ssc i1))
(setq ssb (ssadd ent1 ssb))
(setq i1 (1+ i1))
)
)
)
(setq i (1+ i))
(setq n (sslength ssb))
)
)

(DEFUN stretchblock()
(batdau)  
(chondoituong)
 (setq P01 (getpoint "\nChon diem chen: "))
(delblock)
 (command "-Block" "vkc_temp1" "0,0" ssb "")
 (command "-insert" "vkc_temp1" "0,0" "" "" "")
 (setq sstt1 (entlast))
 (setq sstt (ssget "l"))
(blockrectang)
(nhapsolieu)
 (command "_.explode" sstt1)
 (setq ss0 (ssget "p"))
 (command "-block" "vkc_temp1" "y" p1 ss0 "")
 (command "line" p2 p1 "")
 (setq re (ssget "l"))
 (command "_.move" re "" p1 p01)
 (command "_.rotate" re "" p01 "45")
 (command "-insert" "vkc_temp1" "r" "45" p01 "" "")
 (setq blgoc (entlast))
 (Command "Explode" blgoc)
 (setq bl (ssget "p")) 
 (command "-Block" "vkc_temp2" P01 re "")
 (command "-Block" "vkc_temp3" P01 bl "")
 (Command "-Insert" "vkc_temp3" P01 "" hs "")  
 (setq dt1 (entlast))
 (Command "-Insert" "vkc_temp2" P01 "" hs "")  
 (Command "_.Explode" "l" "")
 (setq dt2 (entlast))
 (setq tt1 (entget dt2))
 (setq tt1 (vl-remove-if '(lambda (x) (/= 10 (car x))) tt1))
 (setq dinh11 (cdr (nth 0 tt1)))
 (setq quay (- 90 (/ (* (angle p01 dinh11) 180) pi)))
 (setq aa (distance p01 dinh11))
 (setq bb (distance p1 p2))
 (setq ab (/ bb aa))
 (command "_.rotate" dt1 "" p01 quay)
 (command ".scale" dt1 "" p01 ab)
 (command "_.erase" dt2 "")
 (command "_.explode" dt1)
(delblock)
(ketthuc)
 (princ)
)

(defun c:stb ()
(stretchblock)
)

(defun batdau ()
 (command "undo" "be")
 (setvar "cmdecho" 0)
 (setq 
    old_er *error*
    *error* myerror
 ) 
)

(defun myerror (errmsg)
(ketthuc)
(command "undo" "")
)

(defun ketthuc ()
 (setq *error* old_er)
 (setvar "cmdecho" 1)
 (command "undo" "e")
)
(defun delblock ()
(Command "-Purge" "B" "vkc_temp1" "Y" "Y")
(Command "-Purge" "B" "vkc_temp2" "Y" "Y")
(Command "-Purge" "B" "vkc_temp3" "Y" "Y")
)

(defun blockrectang ()
(while (setq e (ssname sstt 0))
(setq sstt (ssdel e sstt)
tmp (vla-getboundingbox (vlax-ename->vla-object e) 'p1 'p3)
p1 (vlax-safearray->list p1)
p3 (vlax-safearray->list p3) 
p1 (list (car p1) (cadr p1))
p3 (list (car p3) (cadr p3))
p2 (list (car p1) (cadr p3))
p4 (list (car p3) (cadr p1))
)
) 
)

Gà như mình còn viết được code này mà bon nó bán tận 27$

http://www.rayburndrafting.com/prod_desc_I...AT.html?sno=298


<<

Filename: 112070_stb.lsp
Tác giả: tien2005
Bài viết gốc: 430956
Tên lệnh: xx
CẢI TIẾN LISP GÁN CONTENT CHO TEXT

lisp gán diện tích khác hoàn toàn lisp này. Bạn dùng lisp sau đã có đổi màu cho text

(defun c:xx (/ strl e len txt fn fid)
  (vl-load-com)
  (or color (setq color 256))		; mau theo layer
  (initget 4)
  (setq	color
	 (cond
	   ((getint
	      (strcat "\nChon mau text 0-256 (0:Byblock, 256:Bylayer) <"
		      (rtos color 2 0)
		      ">: "
	      ) ;_ end of strcat
	    ) ;_ end of...
>>

lisp gán diện tích khác hoàn toàn lisp này. Bạn dùng lisp sau đã có đổi màu cho text

(defun c:xx (/ strl e len txt fn fid)
  (vl-load-com)
  (or color (setq color 256))		; mau theo layer
  (initget 4)
  (setq	color
	 (cond
	   ((getint
	      (strcat "\nChon mau text 0-256 (0:Byblock, 256:Bylayer) <"
		      (rtos color 2 0)
		      ">: "
	      ) ;_ end of strcat
	    ) ;_ end of getint
	   )
	   (color)
	 ) ;_ end of cond
  ) ;_ end of setq


  (while
    (and (setq e (car (entsel "\n Chon pline can ghi chieu dai ")))
	 (setq
	   len (vlax-curve-getdistatparam e (vlax-curve-getendparam e))
	 ) ;_ end of setq
	 (setq txt
		(car
		  (entsel
		    "\n Chon text can ghi bo xung gia tri chieu dai polyline"
		  ) ;_ end of entsel
		) ;_ end of car
	 ) ;_ end of setq
    ) ;_ end of and
     (setq txt (vlax-ename->vla-object txt))
     (vla-put-textstring
       txt
       (strcat (vla-get-textstring txt) " " (rtos len 2 0))
     ) ;_ end of vla-put-textstring
     (vla-put-color txt color)
     (setq strl (append strl (list (rtos len 2 0))))
  ) ;_ end of while
  (if (and strl
	   (setq fn (getfiled "Chon file de save" "" "csv" 1))
      ) ;_ end of and
    (progn
      (setq fid	(open fn "w")
      ) ;_ end of setq
      (foreach str strl
	(write-line str fid)
      ) ;_ end of foreach
      (close fid)
    ) ;_ end of progn
  ) ;_ end of if
) ;_ end of defun

 


<<

Filename: 430956_xx.lsp
Tác giả: noinb01
Bài viết gốc: 406850
Tên lệnh: vpl
(Nhờ Viết Lisp) Vẽ Polyline Qua Các Điểm Khi Biết Tọa Độ Tương Đối Với Điểm Gốc
(Defun c:vpl (/ p0 x0 y0 p1 x y p2)
  (setq	p0 (getpoint "\n Chon diem tim tuyen")
	x0 (car p0)
	y0 (cadr p0)
	p1 (list (list (+ x0...
>>
(Defun c:vpl (/ p0 x0 y0 p1 x y p2)
  (setq	p0 (getpoint "\n Chon diem tim tuyen")
	x0 (car p0)
	y0 (cadr p0)
	p1 (list (list (+ x0 (getreal "\n Nhap ly do diem dau: "))
		       (+ y0 (getreal "\n Nhap chenh cao diem dau: "))
		 )
	   )
  )
  (while (and (setq x (getreal "\n Nhap ly do diem tiep theo: "))
	      (setq y (getreal "\n Nhap chenh cao diem tiep theo : "))
	 )
    (setq p1 (cons (list (+ x0 x) (+ y0 y)) p1))
;;;        (command "pline" p1 p2 "")
;;;        (setq p1 p2)
  )
  
  (if (< 1 (Length p1))
    (COMMAND "_.PLINE"
	     (repeat (Length p1)
	       (COMMAND
		 (CAR p1)
	       )
	       (SETQ p1 (CDR p1))
	     )

    )
  )
  (princ)
)

Bạn thử cái này

 

Cám ơn bác ạ, đúng ý em rồi!


<<

Filename: 406850_vpl.lsp
Tác giả: duongts
Bài viết gốc: 213188
Tên lệnh: ha
Nhờ viết lisp ghi đường dẫn file nguồn

Mình mạn phép lấy lisp của @Doan Van Ha sửa lại cho Bạn

(defun C:HA( / lst)
(load "julian.lsp")
(setq lst (jtoc (getvar...
>>

Mình mạn phép lấy lisp của @Doan Van Ha sửa lại cho Bạn

(defun C:HA( / lst)
(load "julian.lsp")
(setq lst (jtoc (getvar "date")))
(setq a (strcat (getvar "SAVENAME") "-//" (itoa (nth 2 lst)) "-" (itoa (nth 1 lst)) "-" (itoa (nth 0 lst)) "//" (itoa (nth 3 lst)) ":" (itoa (nth 4 lst))))
 (ENTMAKE (LIST(CONS 0 "TEXT")(CONS 1 A)(CONS 40 300)(CONS 10 (GETPOINT"\nINSERT POINT"))))
 )

 

lưu ý: (CONS 40 300) trong đó 300 là chiều cao text

Lisp đúng ý của mình rồi, cảm ơn Bác Tien2005 nghe


<<

Filename: 213188_ha.lsp
Tác giả: Kieu Tan
Bài viết gốc: 408337
Tên lệnh: test
Xoay text thuộc tính trong block

 

Ok, nếu thử lisp thì nghịch tí nào. Thêm cả 2 cách Autolisp và Visual lisp.

 

Autolisp này: ^_^

>>

 

Ok, nếu thử lisp thì nghịch tí nào. Thêm cả 2 cách Autolisp và Visual lisp.

 

Autolisp này: ^_^

(defun c:test (/ blk ss n name ins lst value)
  (if (setq blk (car (entsel "\nChon block: ")))
    (progn
      (setq
	ss (ssget "_X" (list '(0 . "INSERT") (assoc 2 (entget blk))))
      )
      (command "_justifytext" ss "" "MC")
      (setq name (cdr (assoc 2 (entget (ssname ss 0)))))
      (setq lst (get-block-entities name))
      (foreach ob lst
	(if (eq (cdr (assoc 0 (entget ob))) "CIRCLE")
	  (setq center (trans (cdr (assoc 10 (entget ob))) 1 0))
	  )
	);foreach
      (foreach ob lst
	(if (eq (cdr (assoc 0 (entget ob))) "ATTDEF")
	  (progn
	    (setq value (cdr (assoc 1 (entget ob))))
	    (entmod (subst (cons 11 center) (assoc 11 (entget ob)) (entget ob)))
	    )
	  )
	);foreach
      (entupd (ssname ss 0))
      (setq n 0)
      (repeat (sslength ss)
	(setq ins (cdr (assoc 10 (entget (ssname ss n)))))
	(setq value (cdr (assoc 1 (entget (entnext (ssname ss n))))))
	(command "_-insert" name "_none" ins 1 1 0 value
		 "_erase" (ssname ss n) "")
	(setq n (1+ n))
	)
      )
    )
  )
(defun get-block-entities ( blk / ent lst )
    (if (setq ent (tblobjname "block" blk))
      (while (setq ent (entnext ent))
	(setq lst (cons ent lst))
        ) ;; end WHILE
    ) ;; end IF
    (reverse lst) ;; Return the list
) ;; end DEFUN
;;;END CODE AUTOLISP HERE


 

 

Thử cả VL xem nào ^_^ Ah tất nhiên dùng lisp trong trường hợp này là các block trục không nằm trong block tổng nữa nhé. :D

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

;;;END CODE VISUAL LISP HERE

Cả 2 lsp đều bị lỗi hết rồi bạn ơi! 


<<

Filename: 408337_test.lsp
Tác giả: risusu
Bài viết gốc: 172905
Tên lệnh: cc
Căn lề text + Mtext, Căn lề đối tượng

hì hì bác bảo em ém thì em post lsp lên làm chi. Mà post lên Cadviet em đã bỏ phần kiểm tra key bản quyền rùi mà. Mặc dù lsp này thì trên...

>>

hì hì bác bảo em ém thì em post lsp lên làm chi. Mà post lên Cadviet em đã bỏ phần kiểm tra key bản quyền rùi mà. Mặc dù lsp này thì trên Internet thì vô vàn cách nhưng em vẫn muốn giữ một tý ty cho mình khì khì. Mà cái em viết chắc các bác cười em sái quai hàm lun. Nhưng kết quả okie là em zui zào.

Mà thui post lên cho các newbie có thêm tài liệu học tập vậy vì tương lai Cadviet:

Sau đây là file lsp:

;;;-------------------------------- Loading --------------------------------------------(defun c:cc (/ C10 C11 C50 C71 C72 C73 DENT DSS DSSN ENT GOC GOC1 GOC2 H I                      LSP LST M N N10 N11 N50 N71 N72 N73 OB P PT PT1 PT2 PTC SS SSN VT                      DIALOG DOITUONG LETRAI LEPHAI CHINHGIUA PNGANG DANDONG                      SS2ENT XOAYCHU)(defun dialog (/ hanh dcl_id)(while (not (vl-position hanh '(1 0)))(setq dcl_id (load_dialog "Text.DCL"))(if (not (new_dialog "Text" dcl_id))(exit))(action_tile "cancel" "(done_dialog 0)")(action_tile "accept" "(done_dialog 1)")(action_tile "ss" "(done_dialog 2)")(action_tile "lt" "(done_dialog 3)")(action_tile "lp" "(done_dialog 4)")(action_tile "cg" "(done_dialog 5)")(action_tile "cn" "(done_dialog 6)")(action_tile "dan" "(done_dialog 7)")(action_tile "xoay" "(done_dialog 8)")(setq hanh (start_dialog))  (if(= hanh 2)(doituong))  (if(= hanh 3)(letrai))  (if(= hanh 4)(lephai))  (if(= hanh 5)(chinhgiua))  (if(= hanh 6)(pngang))  (if(= hanh 7)(dandong))  (if(= hanh 8)(xoaychu)));while(setq dcl_id (unload_dialog dcl_id)))(defun doituong ()  (setq ss (ssget '((0 . "*TEXT"))))   );;;------------------------ Can chu le trai ------------------------------------(defun letrai ()  (if (= ss nil)(alert "B¹n ch­a chän ®èi t­îng")    (progn      (setq vt (getpoint "\n Chän vÞ trÝ c¨n chØnh: "))      (setq ptc (car vt))      (setq i 0)      (setq n (sslength ss))      (setq m n)      (while (< i n)	(setq ssn (ssname ss (setq m (1- m))))	(setq ent (entget ssn))	(if (= (cdr(assoc 0 ent)) "TEXT")  	(progn    	(setq c10 (cdr (assoc 10 ent)))    	(setq n10 (list 10 ptc (cadr c10) (caddr c10)))    	(setq c10 (assoc 10 ent))    	(setq c73 (assoc 73 ent))    	(setq c72 (assoc 72 ent))    	(setq n73 (cons 73 0))    	(setq n72 (cons 72 0))    	(setq ent (subst n10 c10 ent))    	(setq ent (subst n72 c72 ent))    	(setq ent (subst n73 c73 ent))    	(entmod ent)    	    	)  	)	(if (= (cdr(assoc 0 ent)) "MTEXT")  	(progn    	(setq c10 (cdr (assoc 10 ent)))    	(setq n10 (list 10 ptc (cadr c10) (caddr c10)))    	(setq c10 (assoc 10 ent))    	(setq c71 (assoc 71 ent))    	(setq n71 (cons 71 7))    	(setq ent (subst n10 c10 ent))    	(setq ent (subst n71 c71 ent))    	(entmod ent)    	    	)  	)        	(setq i (1+ i))	)      (setq ss (ssget "_P"))            )    )    (princ)  );;;------------------------ Can chu le phai ------------------------------------(defun lephai () (if (= ss nil)(alert "B¹n ch­a chän ®èi t­îng")    (progn      (setq vt (getpoint "\n Chän vÞ trÝ c¨n chØnh: "))      (setq ptc (car vt))      (setq i 0)      (setq n (sslength ss))      (setq m n)      (while (< i n)	(setq ssn (ssname ss (setq m (1- m))))	(setq ent (entget ssn))	(if (= (cdr(assoc 0 ent)) "TEXT")  	(progn    	(setq c10 (cdr (assoc 10 ent)))    	(setq c11 (cdr (assoc 11 ent)))    	(setq n10 (list 10 ptc (cadr c10) (caddr c10)))    	(setq n11 (list 11 ptc (cadr c10) (caddr c10)))    	(setq c10 (assoc 10 ent))    	(setq c11 (assoc 11 ent))    	(setq c73 (assoc 73 ent))    	(setq c72 (assoc 72 ent))    	(setq n73 (cons 73 0))    	(setq n72 (cons 72 2))    	(setq ent (subst n10 c10 ent))    	(setq ent (subst n11 c11 ent))    	(setq ent (subst n72 c72 ent))    	(setq ent (subst n73 c73 ent))    	(entmod ent)    	)  	)	(if (= (cdr(assoc 0 ent)) "MTEXT")  	(progn    	(setq c10 (cdr (assoc 10 ent)))    	(setq n10 (list 10 ptc (cadr c10) (caddr c10)))    	(setq c10 (assoc 10 ent))    	(setq c71 (assoc 71 ent))    	(setq n71 (cons 71 9))    	(setq ent (subst n10 c10 ent))    	(setq ent (subst n71 c71 ent))    	(entmod ent)    	)  	)	(setq i (1+ i))	)      (setq ss (ssget "_P"))      )   )  (princ)  );;;------------------------ Can chu giua ------------------------------------(defun chinhgiua ()  (if (= ss nil)(alert "B¹n ch­a chän ®èi t­îng")    (progn      (setq vt (getpoint "\n Chän vÞ trÝ c¨n chØnh: "))      (setq ptc (car vt))      (setq i 0)      (setq n (sslength ss))      (setq m n)      (while (< i n)	(setq ssn (ssname ss (setq m (1- m))))	(setq ent (entget ssn))	(if (= (cdr(assoc 0 ent)) "TEXT")  	(progn    	(setq c10 (cdr (assoc 10 ent)))    	(setq c11 (cdr (assoc 11 ent)))    	(setq n10 (list 10 ptc (cadr c10) (caddr c10)))    	(setq n11 (list 11 ptc (cadr c10) (caddr c10)))    	(setq c10 (assoc 10 ent))    	(setq c11 (assoc 11 ent))    	(setq c73 (assoc 73 ent))    	(setq c72 (assoc 72 ent))    	(setq n73 (cons 73 0))    	(setq n72 (cons 72 1))    	(setq ent (subst n10 c10 ent))    	(setq ent (subst n11 c11 ent))    	(setq ent (subst n72 c72 ent))    	(setq ent (subst n73 c73 ent))    	(entmod ent)    	)  	)	(if (= (cdr(assoc 0 ent)) "MTEXT")  	(progn    	(setq c10 (cdr (assoc 10 ent)))    	(setq n10 (list 10 ptc (cadr c10) (caddr c10)))    	(setq c10 (assoc 10 ent))    	(setq c71 (assoc 71 ent))    	(setq n71 (cons 71 8))    	(setq ent (subst n10 c10 ent))    	(setq ent (subst n71 c71 ent))    	(entmod ent)    	)  	)	(setq i (1+ i))	)      (setq ss (ssget "_P"))      )  )  (princ)  );;;--------------------------------- Can phuong ngang ----------------------------------------(defun pngang ()(if (= ss nil)(alert "B¹n ch­a chän ®èi t­îng")    (progn      (setq vt (getpoint "\n Chän vÞ trÝ c¨n chØnh: "))      (setq ptc (cadr vt))      (setq i 0)      (setq n (sslength ss))      (setq m n)      (while (< i n)	(setq ssn (ssname ss (setq m (1- m))))	(setq ent (entget ssn))	(if (= (cdr(assoc 0 ent)) "TEXT")  	(progn    	(if (and (= (car(cdr (assoc 11 ent))) 0.0)(= (cadr(cdr (assoc 11 ent))) 0.0)                   	(= (caddr(cdr (assoc 11 ent))) 0.0))      	(progn		(setq c10 (cdr (assoc 10 ent)))		(setq n10 (list 10 (car c10) ptc (caddr c10)))		(setq c10 (assoc 10 ent))		(setq c73 (assoc 73 ent))		(setq c72 (assoc 72 ent))		(setq n73 (cons 73 0))		(setq n72 (cons 72 0))		(setq ent (subst n10 c10 ent))		(setq ent (subst n72 c72 ent))		(setq ent (subst n73 c73 ent))		(entmod ent)		)      	(progn		(setq c10 (cdr (assoc 10 ent)))		(setq n10 (list 10 (car c10) ptc (caddr c10)))		(setq c10 (assoc 10 ent))		(setq c11 (cdr (assoc 11 ent)))		(setq n11 (list 11 (car c11) ptc (caddr c11)))		(setq c11 (assoc 11 ent))		(setq ent (subst n10 c10 ent))		(setq ent (subst n11 c11 ent))		(entmod ent)		)      	)    	)  	)	(if (= (cdr(assoc 0 ent)) "MTEXT")  	(progn    	(setq c10 (cdr (assoc 10 ent)))    	(setq n10 (list 10 (car c10) ptc (caddr c10)))    	(setq c10 (assoc 10 ent))    	(setq c71 (assoc 71 ent))    	(if(or (= (cdr c71) 1) (= (cdr c71) 4))(progn(setq n71 (cons 71 7))(setq ent (subst n71 c71 ent))))    	(if(or (= (cdr c71) 2) (= (cdr c71) 5))(progn(setq n71 (cons 71 8))(setq ent (subst n71 c71 ent))))    	(if(or (= (cdr c71) 3) (= (cdr c71) 6))(progn(setq n71 (cons 71 9))(setq ent (subst n71 c71 ent))))    	(setq ent (subst n10 c10 ent))    	(entmod ent)    	)  	)	(setq i (1+ i))	)      (setq ss (ssget "_P"))      )  )  (princ)  );;;-------------------------------- Dan dong phuong ngang ----------------------------(defun dandong ()  (if (= ss nil)(alert "B¹n ch­a chän ®èi t­îng")    (progn      (setq n (sslength ss))      (setq vt (getpoint "\n Chän vÞ trÝ c¨n chØnh: "))      (setq h (getreal "\n §é réng cña dßng: "))      (setq ptc (cadr vt))(defun ss2ent (ss / sodt index lstent)  (setq sodt (if ss (sslength ss) 0)	index 0)  (repeat sodt    (setq ent (ssname ss index)  	index (1+ index)  	lstent (cons ent lstent)  	);setq    );repeat  (reverse lstent)  )  (setq i 0)  (setq lst (ss2ent ss));  (setq lst (vl-sort lst '(lambda (e1 e2) (< (cadr (assoc 10 (entget e1))) (cadr (assoc 10 (entget e2)))))))  (setq lst (vl-sort lst '(lambda (e1 e2) (> (caddr (assoc 10 (entget e1))) (caddr (assoc 10 (entget e2)))))))  (foreach e lst    (setq ent (entget e))    (if (= (cdr(assoc 0 ent)) "TEXT")      (progn	(if (and (= (car(cdr (assoc 11 ent))) 0.0)(= (cadr(cdr (assoc 11 ent))) 0.0)                    (= (caddr(cdr (assoc 11 ent))) 0.0))  	(progn    	(setq c10 (cdr (assoc 10 ent)))    	(setq n10 (list 10 (car c10) ptc (caddr c10)))    	(setq c10 (assoc 10 ent))    	(setq c73 (assoc 73 ent))    	(setq c72 (assoc 72 ent))    	(setq n73 (cons 73 0))    	(setq n72 (cons 72 0))    	(setq ent (subst n10 c10 ent))    	(setq ent (subst n72 c72 ent))    	(setq ent (subst n73 c73 ent))    	(entmod ent)    	    	)         	(progn    	(setq c10 (cdr (assoc 10 ent)))    	(setq n10 (list 10 (car c10) ptc (caddr c10)))    	(setq c10 (assoc 10 ent))    	(setq c11 (cdr (assoc 11 ent)))    	(setq n11 (list 11 (car c11) ptc (caddr c11)))    	(setq c11 (assoc 11 ent))    	(setq ent (subst n10 c10 ent))    	(setq ent (subst n11 c11 ent))    	(entmod ent)	    	)  	);end if	)      (progn	(if (= (cdr(assoc 0 ent)) "MTEXT")  	(progn    	(setq c10 (cdr (assoc 10 ent)))    	(setq n10 (list 10 (car c10) ptc (caddr c10)))    	(setq c10 (assoc 10 ent))    	(setq c71 (assoc 71 ent))    	(if(or (= (cdr c71) 1) (= (cdr c71) 4))(progn(setq n71 (cons 71 7))(setq ent (subst n71 c71 ent))))    	(if(or (= (cdr c71) 2) (= (cdr c71) 5))(progn(setq n71 (cons 71 8))(setq ent (subst n71 c71 ent))))    	(if(or (= (cdr c71) 3) (= (cdr c71) 6))(progn(setq n71 (cons 71 9))(setq ent (subst n71 c71 ent))))    	(setq ent (subst n10 c10 ent))    	(entmod ent)	    	)  	)	)      )    (setq ptc (- ptc h))    )  (setq ss (ssget "_P"))  )    )  (princ)  );;;-----------------------------------------Xoay chu theo duong--------------------------------------------(defun xoaychu ()  (if (= ss nil)(alert "B¹n ch­a chän ®èi t­îng")    (progn      (setq i 0)      (setq pt (getpoint "\n Chän ®­êng chuÈn: "))      (setq dss (ssget pt))      (setq dssn (ssname dss 0))      (setq dent (entget dssn))      (if (= (cdr(assoc 0 dent)) "LINE")	(progn  	(setq pt1 (cdr(assoc 10 dent)))  	(setq pt2 (cdr(assoc 11 dent)))  	(setq goc (angle pt1 pt2))  	(if (and (< (* pi 0.5) goc)(< goc (* pi 1.5)))(setq goc (- goc pi)))  	);end progn	(if (= (cdr(assoc 0 dent)) "POLYLINE")  	(progn    	(setq ob (vlax-ename->vla-object dssn))    	(setq n (vlax-curve-getEndParam ob))    	(setq i 0)    	(setq lsp (list))    	(while (<= i n)      	(setq p (vlax-curve-getPointAtParam ob i))      	(setq lsp (append lsp (list p)))      	(setq i (+ i 1))      	);end progn    	(setq i 0)    	(while (<= i n)      	(if (> i 0)		(progn	  	(setq pt1 (nth (- i 1) lsp))	  	(setq pt2 (nth i lsp))	  	(setq goc1 (angle pt1 pt))	  	(setq goc2 (angle pt pt2))	  	(if(and(or(and(<= (car pt1) (car pt))(<= (car pt) (car pt2)))(and(<= (car pt2) (car pt))                       	(<= (car pt) (car pt1))))(or(and(<= (cadr pt1) (cadr pt))(<= (cadr pt) (cadr pt2)))                       	(and(<= (cadr pt2) (cadr pt))(<= (cadr pt) (cadr pt1))))(or(= goc1 goc2)                       	(< -0.001 (- goc1 goc2))(< -0.001 (- goc2 goc1))))	    	(progn	      	(setq goc (angle pt1 pt2))	      	(if (and (< (* pi 0.5) goc)(< goc (* pi 1.5)))(setq goc (- goc pi)))	      	(setq i (+ 1 n))	      	);end progn	    	);end if	  	);end progn		);end if      	(setq i (1+ i))      	)    	)  	)	)      (setq i 0)      (setq n (sslength ss))      (setq m -1)      (while (< i n)	(setq ssn (ssname ss (setq m (1+ m))))	(setq ent (entget ssn))	(if (or (= (cdr(assoc 0 ent)) "MTEXT") (= (cdr(assoc 0 ent)) "TEXT"))  	(progn    	(setq n50 (cons 50 goc))    	(setq c50 (assoc 50 ent))    	(setq ent (subst n50 c50 ent))    	(entmod ent)    	)  	)	(setq i (1+ i))	);end while      (setq ss ss)      )    )  (princ)  )(dialog)(princ))

Sau đây là file dcl:

Text :dialog {label = "Ch­¬ng tr×nh trî gióp xö lý text";:text {label = "T¸c gi¶: KS.Tr­¬ng §øc H¹nh - C«ng ty t­ vÊn 11";alignment = centered;}:row{:boxed_column{label = "Lùa chän ®èi t­îng";  :row {  :text{label = "Chän ®èi t­îng:"; alignment = left; alignment = centered;  }  :button{label = "Chän";  key = "ss";  width= 10;  fixed_width=true;  }  }:row {  :text{label = "Xoay ®èi t­îng:"; alignment = left; alignment = centered;  }  :button{label = "Xoay";  key = "xoay";  width= 10;  fixed_width=true;  }  }:row {  :text{label = "D·n dßng ph­¬ng ngang:"; alignment = left; alignment = centered;  }  :button{label = "D·n";  key ="dan";  width= 10;  }  }}:boxed_column{label = "Xö lý ®èi t­îng";  :row {  :text{label = "C¨n lÒ tr¸i:"; alignment = left; alignment = centered;  }  :button{label = "VÞ trÝ";  key = "lt";  fixed_width = true;  }  }:row {  :text{label = "C¨n lÒ ph¶i:"; alignment = left; alignment = centered;  }  :button{label = "VÞ trÝ";  key = "lp";  fixed_width = true;  }  }:row {  :text{label = "C¨n chÝnh gi÷a:"; alignment = left; alignment = centered;  }  :button{label = "VÞ trÝ";  key = "cg";  fixed_width = true;  }  }:row {  :text{label = "C¨n ph­¬ng ngang:"; alignment = left; alignment = centered;  }  :button{label = "VÞ trÝ";  key = "cn";  fixed_width = true;  }  }}}ok_only;}

 

Không hiểu sao mình down về 2 file dcl và lisp bỏ vào ổ C load lên rồi mà không có tín hiệu gì???


<<

Filename: 172905_cc.lsp
Tác giả: risusu
Bài viết gốc: 173029
Tên lệnh: trai giua phai tren giua1 duoi
Căn lề text + Mtext, Căn lề đối tượng

Giờ là lisp căn lề đối tượng (s).Bao gồm có L,PL,ARC,Dim,Hatch,Block,Att,Point,Text,Mtext,Ellisp,SPline.Code thì dài khỏi nói rồi ^^ Các bác thử...

>>

Giờ là lisp căn lề đối tượng (s).Bao gồm có L,PL,ARC,Dim,Hatch,Block,Att,Point,Text,Mtext,Ellisp,SPline.Code thì dài khỏi nói rồi ^^ Các bác thử test xem sao.(E đã bỏ phần bắt lỗi và các thiết đặt reset setting đi cho đỡ rối mắt r )

(defun c:Trai ( / Set1 Base_X I ObjName Min_X DeltaPt Pt_List_M AttribList AttribFlag)			(setq Set1 (ssget))				(setq ObjName (car (entsel "\n Select Reference Object: ")))		(setq Base_X (caar(GetObjSize_401 ObjName)))	(setq time (getvar "MILLISECS"))	(setq i 0)		(repeat (sslength Set1)				(setq Pt_List_M nil Flag2 nil InsertFlag nil)				(setq ObjName (ssname Set1 i))				(setq Min_X (caar (GetObjSize_401 ObjName)))				(if Flag2 (setq DeltaPt '(0 0))						(setq DeltaPt (list (- Base_X Min_X) 0)))						(setq DeltaPt (mapcar '- (trans DeltaPt 1 0 ) (getvar "UCSORG")))				(Entmod_Obj_401 ObjName DeltaPt)						(setq i (1+ i))		)		(setq time (/ (- (getvar "MILLISECS") time) 1000.0))(princ (strcat "\nThoi gian thuc hien (giay) :" (rtos time)))		(princ))(defun c:Giua ( / Set1 Base_X I ObjName Min_X DeltaPt Pt_List_M AttribList AttribFlag)		(setq Set1 (ssget))			(setq ObjName (car (entsel "\n Select Reference Object: ")))			(setq Pt_List_M(GetObjSize_401 ObjName))	(setq Base_X ( / (+ (caar Pt_List_M)(caadr Pt_List_M)) 2))	(setq i 0)	(setq time (getvar "MILLISECS"))		(repeat (sslength Set1)				(setq Pt_List_M nil Flag2 nil)				(setq ObjName (ssname Set1 i))				(setq Pt_List_M (GetObjSize_401 ObjName))				(setq Min_X ( / (+ (caar Pt_List_M)(caadr Pt_List_M)) 2))				(if Flag2 (setq DeltaPt '(0 0))						(setq DeltaPt (list (- Base_X Min_X) 0)))						(setq DeltaPt (mapcar '- (trans DeltaPt 1 0 ) (getvar "UCSORG")))				(Entmod_Obj_401 ObjName DeltaPt)						(setq i (1+ i))						)						(setq time (/ (- (getvar "MILLISECS") time) 1000.0))(princ (strcat "\nThoi gian thuc hien (giay) :" (rtos time)))		(princ))(defun c:phai ( / Set1 Base_X I ObjName Min_X DeltaPt Pt_List_M AttribList AttribFlag)	(setq Set1 (ssget))					(setq ObjName (car (entsel "\n Select Reference Object: ")))				(setq Pt_List_M(GetObjSize_401 ObjName))	(setq Base_X (caadr Pt_List_M))	(setq i 0)		(repeat (sslength Set1)				(setq Pt_List_M nil Flag2 nil)				(setq ObjName (ssname Set1 i))				(setq Pt_List_M(GetObjSize_401 ObjName))				(setq Min_X (caadr Pt_List_M))				(if Flag2 (setq DeltaPt '(0 0))						(setq DeltaPt (list (- Base_X Min_X) 0)))						(setq DeltaPt (mapcar '- (trans DeltaPt 1 0 ) (getvar "UCSORG")))				(Entmod_Obj_401 ObjName DeltaPt)						(setq i (1+ i))		)		(princ))(defun c:tren ( / Set1 Base_Y I ObjName Min_Y DeltaPt Pt_List_M AttribList AttribFlag)	(setq Set1 (ssget))				(setq ObjName (car (entsel "\n Select Reference Object: ")))			(setq Pt_List_M(GetObjSize_401 ObjName))	(setq Base_Y (cadar Pt_List_M))	(setq i 0)		(repeat (sslength Set1)				(setq Pt_List_M nil Flag2 nil)				(setq ObjName (ssname Set1 i))				(setq Pt_List_M(GetObjSize_401 ObjName))				(setq Min_Y (cadar Pt_List_M))				(if Flag2 (setq DeltaPt '(0 0))						(setq DeltaPt (list 0 (- Base_Y Min_Y))))						(setq DeltaPt (mapcar '- (trans DeltaPt 1 0 ) (getvar "UCSORG")))				(Entmod_Obj_401 ObjName DeltaPt)						(setq i (1+ i))		)		(princ))(defun c:giua1 ( / Set1 Base_Y I ObjName Min_Y DeltaPt Pt_List_M AttribList  AttribFlag)	(setq Set1 (ssget))				(setq ObjName (car (entsel "\n Select Reference Object: ")))				(setq Pt_List_M(GetObjSize_401 ObjName))	(setq Base_Y ( / (+ (cadar Pt_List_M)(cadadr Pt_List_M)) 2))		(setq i 0)		(repeat (sslength Set1)				(setq Pt_List_M nil Flag2 nil)				(setq ObjName (ssname Set1 i))				(setq Pt_List_M(GetObjSize_401 ObjName))				(setq Min_Y ( / (+ (cadar Pt_List_M)(cadadr Pt_List_M)) 2))				(if Flag2 (setq DeltaPt '(0 0))						(setq DeltaPt (list 0 (- Base_Y Min_Y))))						(setq DeltaPt (mapcar '- (trans DeltaPt 1 0 ) (getvar "UCSORG")))				(Entmod_Obj_401 ObjName DeltaPt)						(setq i (1+ i))		)		(princ))(defun c:duoi ( / Set1 Base_Y I ObjName Min_Y DeltaPt Pt_List_M AttribList AttribFlag)	(setq Set1 (ssget))			(setq ObjName (car (entsel "\n Select Reference Object: ")))			(setq Pt_List_M(GetObjSize_401 ObjName))	(setq Base_Y (cadadr Pt_List_M))	(setq i 0)		(repeat (sslength Set1)				(setq Pt_List_M nil Flag2 nil)				(setq ObjName (ssname Set1 i))				(setq Pt_List_M(GetObjSize_401 ObjName))				(setq Min_Y (cadadr Pt_List_M))				(if Flag2 (setq DeltaPt '(0 0))						(setq DeltaPt (list  0 (- Base_Y Min_Y))))						(setq DeltaPt (mapcar '- (trans DeltaPt 1 0 ) (getvar "UCSORG")))				(Entmod_Obj_401 ObjName DeltaPt)						(setq i (1+ i))		)		(princ));;;----------------------------Distribution_401-----------------------(defun Distribution_401 (ObjName /	)			(setq Data (entget ObjName) ObjType (cdr(assoc 0 Data)))	(cond 	((= ObjType "INSERT")(INSERT_Box ObjName))			((= ObjType "HATCH")(HATCH_Box ObjName))			((= ObjType "LINE")(Line_Box ObjName))			((= ObjType "LWPOLYLINE")(LWPOLYLINE_Box ObjName))			((= ObjType "DIMENSION")(DIMENSION_Box ObjName))			((= ObjType "TEXT")(TEXT_Box ObjName))			((= ObjType "MTEXT")(MTEXT_Box ObjName))			((= ObjType "ARC")(ARC_Box ObjName))			((= ObjType "CIRCLE")(CIRCLE_Box ObjName))			((= ObjType "POLYLINE")(POLYLINE_Box ObjName))			((= ObjType "SPLINE")(SPLINE_Box ObjName))			((= ObjType "ELLIPSE")(ELLIPSE_Box ObjName))			((= ObjType "ATTRIB")(setq AttribFlag T)(TEXT_Box ObjName)(setq AttribFlag nil))			((and (= ObjType "ATTDEF") (null InsertFlag))(TEXT_Box ObjName))			((= ObjType "POINT")(POINT_Box ObjName))	)	Pt_List_M);;;===================================================(defun INSERT_Box (ObjName / Ins_P Scale_X Scale_Y Ang AttribList I_NameList)	(setq InsertFlag T)	(setq Ins_P (reverse (cdr (reverse (cdr(assoc 10 (entget ObjName)))))))		(setq Scale_X (cdr(assoc 41 (entget ObjName))))		(setq Scale_Y (cdr(assoc 42 (entget ObjName))))		(setq ScXY (list Scale_X Scale_Y ))	(setq Ang (cdr(assoc 50 (entget ObjName))))		(cond 	((= (cdr(assoc 66 (entget ObjName))) 1)			(setq AttribList (AttribListInsideBlock ObjName))			(mapcar 'Distribution_401 AttribList)			)	)	(setq I_NameList (MakeListInsideBlock ObjName))	(mapcar 'Distribution_401 I_NameList)	(setq Pt_List_M (BoxPoint Pt_List_M))	(setq Ins_P '(0 0) Scale_X 1.0 Scale_Y 1.0 Ang 0))(defun AttribListInsideBlock (ObjName / NextObjType ObjNext )	(setq ObjNext (entnext ObjName))	(while (= (cdr (assoc 0 (entget ObjNext))) "ATTRIB")		(setq AttribList (append AttribList (list ObjNext)))		(if (entnext ObjNext)(setq ObjNext (entnext ObjNext)))	)	AttribList);;;===================================================(defun HATCH_Box (ObjName / )		(Make_Point_List Data)	(if (/= L_Line nil)	(Cal_Line L_Line))	(if (/= L_Arc nil)	(mapcar 'Cal_Arc L_Arc))	(if (/= L_Ellip nil)	(mapcar 'Cal_Ellip L_Ellip))	(if (/= L_Spline nil)(Cal_Spline L_Spline))	(if (/= PL_NoPt nil)(Cal_PL PL_NoPt PL_Pt PL_R))		(setq Pt_List_M (BoxPoint Pt_List_M))	Pt_List_M);;;----------------------------------------------------------------------(defun Make_Point_List ( Data / )	(setq nn (length Data) mm 0)	(while (/= mm nn)		(setq Item (nth mm Data))						(cond 	((and (= (car Item) 92)(= (logand (cdr item) 2) 2))(MakeList_PLine))				((and (= (car Item) 72)(= (cdr Item) 1))(MakeList_Line))				((and (= (car Item) 72)(= (cdr Item) 2))(MakeList_Arc))				((and (= (car Item) 72)(= (cdr Item) 3))(MakeList_Ellip))				((and (= (car Item) 72)(= (cdr Item) 4))(MakeList_Spline))		)		(setq mm (1+ mm))	));;;----------------------------------------------------------------------(defun Cal_PL (PL_NoPt PL_Pt PL_R / j p Pt_List)			(setq PL_Pt (MovRotScl PL_Pt Ins_P Ang Scale_X Scale_Y))			(setq PL_Pt (mapcar '(lambda(x)(trans x 0 1)) PL_Pt))		(setq PL_R (mapcar '(lambda(x)(*	(/ (* Scale_X Scale_Y)(abs (* Scale_X Scale_Y))) x)) PL_R))		(setq j 0)	(foreach Item PL_NoPt		(setq p 1)		(repeat Item			(if (/= p Item)				(setq Pt_List (append Pt_List (list (list (nth j PL_Pt)(nth (1+ j) PL_Pt)(nth j PL_R)))))							(progn 	(setq Pt_List (append Pt_List (list (list (nth j PL_Pt)(nth (- j Item -1) PL_Pt)(nth j PL_R)))))						(setq p 0))			)			(setq j (1+ j) p (1+ p))		)	)	‚Ó‚­‚ç‚Ý‚ª•‰‚Ü‚½‚Í0‚Ìꇂ͌vŽZ‚µ‚È‚¢	(setq Pt_List (vl-remove-if '(lambda(x)(<= (nth 2 x) 0)) Pt_List))	(setq C_Rd_List (mapcar 'CompR Pt_List))		(setq QtPt_List (mapcar '(lambda(x) (QuaterPt (car x)(cadr x))) C_Rd_List))	(setq QtPt_List (apply 'append QtPt_List))		(setq Pt_List (append PL_Pt QtPt_List))	(setq Pt_List (BoxPoint Pt_List))		(setq Pt_List_M (append Pt_List_M Pt_List)));;;----------------------------------------------------------------------(defun Cal_Ellip (Pt_List /)	(setq 	P1 (nth 0 Pt_List)			P2 (nth 1 Pt_List)			P2x (car P2)			P2y (cadr P2)			Rate (nth 2 Pt_List)			EPs (nth 3 Pt_List)			EPe (nth 4 Pt_List)			EDrec (nth 5 Pt_List))						(setq EPs (AngleCircleToEllip EPs Rate) EPe (AngleCircleToEllip EPe Rate))			(setq EPsOrg EPs EPeOrg EPe )						(if (= EDrec 0)(setq EPs (- (* 2 pi) EPeOrg) EPe (- (* 2 pi) EPsOrg)))		(setq Pt_List2 (list P1))			(setq Pt_List3(list P2))			(setq Pt_List2 (MovRotScl Pt_List2 Ins_P Ang Scale_X Scale_Y))			(setq Pt_List3 (MovRotScl Pt_List3 '(0 0) Ang Scale_X Scale_Y))		(setq Pt_List2 (mapcar '(lambda(x)(trans x 0 1)) Pt_List2))	(setq Pt_List3 (mapcar '(lambda(x)(trans x 0 1)) Pt_List3))		(if 	(entmake (list	'(0 . "ELLIPSE")'(100 . "AcDbEntity")'(100 . "AcDbEllipse")					(append '(10) (car Pt_List2))(append '(11) (car Pt_List3))(cons 40 Rate)(cons 41 EPs)(cons 42 EPe)))		(setq TempObjName (entlast))(princ "\n Failed in ArcEntEllip"))		(setq 	P2x (caar Pt_List3)			P2y (cadar Pt_List3))			(setq	PEco	(* P2x P2y (- 1 (* Rate Rate)))			PE1x 	(sqrt (+(* P2x P2x)(* Rate Rate P2y P2y)))			PE1y	(/ PEco PE1x)			PE2y	(sqrt (+(* P2y P2y)(* Rate Rate P2x P2x)))			PE2x	(/ PEco PE2y))	(setq 	PE1	(list PE1x PE1y)			PE2	(list PE2x PE2y)			PE3	(mapcar '* PE1 '(-1 -1))			PE4	(mapcar '* PE2 '(-1 -1)))	(setq Pt_List (list PE1 PE2 PE3 PE4))	(setq Pt_List (mapcar '(lambda(x) (mapcar '+  x (car Pt_List2))) Pt_List))		(setq Pt_List (mapcar '(lambda(x)(if (equal (distance (vlax-curve-getClosestPointTo TempObjName x) x ) 0 0.01) x)) Pt_List))	(entdel TempObjName)	·	(setq Pt_List (vl-remove nil Pt_List))		(if Pt_List		(progn	(setq Pt_List (BoxPoint Pt_List))		)	)	(setq Pt_List_M (append Pt_List_M Pt_List)));;;----------------------------------------------------------------------(defun Cal_Arc (Pt_List )		(setq 	P1 (nth 0 Pt_List)			Rd (* (abs Scale_X)(nth 1 Pt_List))			EPs (nth 2 Pt_List)			EPe (nth 3 Pt_List)			Drec (nth 4 Pt_List))	(setq EPsOrg EPs EPeOrg EPe )				(if (= Drec 0)(setq EPs (- (* 2 pi) EPe) EPe (- (* 2 pi) EPsOrg)))				(setq EPs_org EPs EPe_org EPe)				(cond 	((and (< Scale_X 0)(> Scale_Y 0))(setq EPs (- pi EPe_org) 		EPe (- pi EPs_org)))		;X- Y+						((and (< 0 Scale_X)(< Scale_Y 0))(setq EPs (- (* 2 pi) EPe_org)	EPe (- (* 2 pi) EPs_org)))	;X+ Y-						((and (< Scale_X 0)(< Scale_Y 0))(setq EPs (+ pi EPs_org) 		EPe (+ pi EPe_org)))			;X- Y-				)								(setq EPs (+ EPs Ang))				(setq EPe (+ EPe Ang))		(setq Pt_List (list P1))		(setq Pt_List (MovRotScl Pt_List Ins_P Ang Scale_X Scale_Y))	(setq Pt_List (mapcar '(lambda(x)(trans x 0 1)) Pt_List))		(if 	(entmake (list	'(0 . "ARC")'(100 . "AcDbEntity")'(100 . "AcDbCircle")					(append '(10) (car Pt_List))(cons 40 Rd)'(100 . "AcDbArc")(cons 50 EPs)(cons 51 EPe)))		(setq TempObjName (entlast))		(princ "\n Failed in ArcEntmake"))		(setq Pt_List (QuaterPt (car Pt_List) Rd))		(setq Pt_List (mapcar '(lambda(x)(if (equal (distance (vlax-curve-getClosestPointTo TempObjName x) x ) 0 0.00001) x)) Pt_List))	(entdel TempObjName)		(setq Pt_List (vl-remove nil Pt_List))	(if Pt_List		(progn	(setq Pt_List (BoxPoint Pt_List))		)	)			(setq Pt_List_M (append Pt_List_M Pt_List)));;;----------------------------------------------------------------------(defun Cal_Line (Pt_List)	(setq Pt_List (MovRotScl Pt_List Ins_P Ang Scale_X Scale_Y))	(setq Pt_List (mapcar '(lambda(x)(trans x 0 1)) Pt_List))	(setq Pt_List (BoxPoint Pt_List))			(setq Pt_List_M (append Pt_List_M Pt_List)));;;===================================================(defun DIMENSION_Box (ObjName);	(princ "\n DIMENSION_Start===============")	(setq I_NameList (MakeListInsideBlock ObjName))	(mapcar '(lambda(x) (Distribution_401 x)) I_NameList)	(setq Pt_List_M (BoxPoint Pt_List_M)));;;===================================================(defun ELLIPSE_Box (ObjName);	(princ "\n ELLIPSE_Box--------------------------")	(setq 	P1 (cdr (assoc 10 Data)) 				P2 (cdr (assoc 11 Data))				P2x (car P2)			P2y (cadr P2)			Rate (cdr (assoc 40 Data))				EPs	(cdr(assoc 41 Data))				EPe	(cdr(assoc 42 Data))			EDrec (nth 3 (assoc 210 Data))			)				(if (or	(and (< Scale_X 0)(< 0 Scale_Y))					(and (< 0 Scale_X)(< Scale_Y 0))				)			(progn	(setq EPs_org EPs)					(setq EPe_org EPe)					(setq EPs (- (* 2 pi) EPe_org))					(setq EPe (- (* 2 pi) EPs_org))))		(setq Pt_List2 (list P1))			(setq Pt_List3(list P2))			(setq Pt_List2 (MovRotScl Pt_List2 Ins_P Ang Scale_X Scale_Y))			(setq Pt_List3 (MovRotScl Pt_List3 '(0 0) Ang Scale_X Scale_Y))		(setq Pt_List2 (mapcar '(lambda(x)(trans x 0 1)) Pt_List2))	(setq Pt_List3 (mapcar '(lambda(x)(trans x 0 1)) Pt_List3))	;ŽÀ'œ‚Ìì¬	(setq Data (subst (append  '(10) (car Pt_List2)) (assoc 10 Data) Data))		(setq Data (subst (append  '(11) (car Pt_List3)) (assoc 11 Data) Data))		(setq Data (subst (cons 41 EPs)(assoc 41 Data) Data))		(setq Data (subst (cons 42 EPe)(assoc 42 Data) Data))		(setq Data (subst (cons 8 "A51")(assoc 8 Data) Data))	(if (entmake Data)(setq TempObjName (entlast))(princ "\n Failed in ArcEntmake"))	(setq Pt1 (vlax-curve-getStartPoint TempObjName))			(setq Pt2 (vlax-curve-getEndPoint TempObjName))				(setq 	P2x (caar Pt_List3)			P2y (cadar Pt_List3))			(setq	PEco	(* P2x P2y (- 1 (* Rate Rate)))			PE1x 	(sqrt (+(* P2x P2x)(* Rate Rate P2y P2y)))			PE1y	(/ PEco PE1x)			PE2y	(sqrt (+(* P2y P2y)(* Rate Rate P2x P2x)))			PE2x	(/ PEco PE2y))	(setq 	PE1	(list PE1x PE1y)			PE2	(list PE2x PE2y)			PE3	(mapcar '* PE1 '(-1 -1))			PE4	(mapcar '* PE2 '(-1 -1)))	(setq Pt_List (list PE1 PE2 PE3 PE4))	(setq Pt_List (mapcar '(lambda(x) (mapcar '+  x (car Pt_List2))) Pt_List))	;‰ñ"]Šg'åŒã‚Ì'†SÀ•W‚ð'«‚·		(setq Pt_List (mapcar '(lambda(x)(if (equal (distance (vlax-curve-getClosestPointTo TempObjName x) x ) 0 0.00001) x)) Pt_List))	(entdel TempObjName)		(setq Pt_List (append (vl-remove nil Pt_List) (list Pt1 Pt2)))		(setq Pt_List (BoxPoint Pt_List))	(setq Pt_List_M (append Pt_List_M Pt_List)));;;===================================================(defun ARC_Box(ObjName)	(setq 	P1 (cdr (assoc 10 Data)) 			Rd (* (abs Scale_X) (cdr (assoc 40 Data)))			EPs	(cdr(assoc 50 Data))			EPe	(cdr(assoc 51 Data)))									(setq EPs_org EPs EPe_org EPe)				(cond 	((and (< Scale_X 0)(> Scale_Y 0))(setq EPs (- pi EPe_org) 		EPe (- pi EPs_org)))		;X- Y+						((and (< 0 Scale_X)(< Scale_Y 0))(setq EPs (- (* 2 pi) EPe_org)	EPe (- (* 2 pi) EPs_org)))	;X+ Y-						((and (< Scale_X 0)(< Scale_Y 0))(setq EPs (+ pi EPs_org) 		EPe (+ pi EPe_org)))			;X- Y-				)								(setq EPs (+ EPs Ang))				(setq EPe (+ EPe Ang))	(setq EPs (- EPs (angle (trans '(0 0) 1 0)(trans  '(1 0) 1 0))))	(setq EPe (- EPe (angle (trans '(0 0) 1 0)(trans  '(1 0) 1 0))))	(setq Pt_List (list P1))	(setq Pt_List (MovRotScl Pt_List Ins_P Ang Scale_X Scale_Y))	(setq Pt_List (mapcar '(lambda(x)(trans x 0 1)) Pt_List))		(setq Data (subst (append  '(10) (car Pt_List)) (assoc 10 Data) Data))		(setq Data (subst (cons 50 EPs)(assoc 50 Data) Data))			(setq Data (subst (cons 51 EPe)(assoc 51 Data) Data))				(setq Data (subst (cons 40 Rd)(assoc 40 Data) Data))		(setq Data (subst (cons 8 "A51")(assoc 8 Data) Data))	(if (entmake Data)(setq TempObjName (entlast))(princ "\n Failed in ArcEntmake"))	(setq Pt1 (vlax-curve-getStartPoint TempObjName))			(setq Pt2 (vlax-curve-getEndPoint TempObjName))			(setq Pt_List (QuaterPt (car Pt_List) Rd))	(setq Pt_List (mapcar '(lambda(x)(if (equal (distance (vlax-curve-getClosestPointTo TempObjName x) x ) 0 0.00001) x)) Pt_List))	(entdel TempObjName)	(setq Pt_List (append (vl-remove nil Pt_List) (list Pt1 Pt2)))	(setq Pt_List (BoxPoint Pt_List))		(setq Pt_List_M (append Pt_List_M Pt_List))	);;;===================================================(defun SPLINE_Box (ObjName)	(setq Pt_list (mapcar 'cdr (vl-remove-if-not '(lambda(x)(= (car x) 11)) Data)))	(setq Pt_List (MovRotScl Pt_List Ins_P Ang Scale_X Scale_Y ))	(setq Pt_List (mapcar '(lambda(x)(trans x 0 1)) Pt_List))	(setq Pt_List (BoxPoint Pt_List))		(setq Pt_List_M (append Pt_List_M Pt_List)));;;===================================================(defun LWPOLYLINE_Box (ObjName)	(setq Pt_List (mapcar 'cdr (vl-remove-if-not '(lambda(x)(= (car x) 10)) Data)))		(setq R_List (mapcar 'cdr (vl-remove-if-not '(lambda(x)(= (car x) 42)) Data)))		(setq Flag401 (cdr(assoc 70 Data)))		(setq Drec (nth 3 (assoc 210 (entget ObjName))))	(setq Pt_List (MovRotScl Pt_List Ins_P Ang (* Drec Scale_X) Scale_Y))	(setq Pt_List (mapcar '(lambda(x)(trans x 0 1)) Pt_List))		(setq R_List (mapcar '(lambda(x)(*	(/ (* Scale_X Scale_Y)(abs (* Scale_X Scale_Y))) x)) R_List))		(setq Data (vl-remove-if '(lambda(x)(or (= (car x) 10)(= (car x) 40)(= (car x) 41)(= (car x) 42)(= (car x) 210))) Data))	(setq Data2 (apply 'append (mapcar '(lambda (x y) (list (append '(10) x)(cons 42 y))) Pt_List R_List)))	(setq Data (append Data Data2))	(setq Data (subst '(8 . "A51")(assoc 8 Data) Data))		(if (entmake Data)(setq TempObjName (entlast))(princ "\n Failed in LWPoly"))			(setq k 0 PtR_List nil)	(repeat (length Pt_List)		(if (/= (nth k R_List) 0)			(setq PtR_List 				(append PtR_List (list (list (nth k Pt_List)(if (null (nth (1+ k) Pt_List)) (nth 0 Pt_List)(nth (1+ k) Pt_List)) (nth k R_List))))))		(setq k (1+ k))	)	(if (= 0 Flag401)(setq PtR_List (reverse(cdr (reverse PtR_List)))))	(setq C_Rd_List (mapcar 'CompR PtR_List))		(setq QtPt_List (mapcar '(lambda(x) (QuaterPt (car x)(cadr x))) C_Rd_List))	(setq QtPt_List (mapcar '(lambda(y) (mapcar '(lambda(x)				(if (equal (distance (vlax-curve-getClosestPointTo TempObjName x) x) 0 0.00001) x )) y )) QtPt_List))	(entdel TempObjName)	(setq QtPt_List (vl-remove-if 'null (apply 'append QtPt_List)))		(setq Pt_List (append Pt_List QtPt_List))		_	(setq Pt_List (BoxPoint Pt_List))	(setq Pt_List_M (append Pt_List_M Pt_List)));;;===================================================(defun POLYLINE_Box (ObjName)	(setq ObjName (entnext ObjName) Pt_List nil)	(while	(/= (cdr(assoc 0 (entget ObjName))) "SEQEND")		(setq Pt_List (append Pt_List (list (cdr(assoc 10 (entget ObjName))))))		(setq ObjName (entnext ObjName))	)	(setq Pt_List (MovRotScl Pt_List Ins_P Ang Scale_X Scale_Y))	(setq Pt_List (mapcar '(lambda(x)(trans x 0 1)) Pt_List))	(setq Pt_List (BoxPoint Pt_List))		(setq Pt_List_M (append Pt_List_M Pt_List))	);;;===================================================(defun MText_Box (ObjName)	(setq TBase (cdr (assoc 10 Data)))	(setq IP   (cdr (assoc 71 Data)))	(setq W_42     (cdr (assoc 42 Data)))	(setq H_43     (cdr (assoc 43 Data)))	(setq TAng     (+ (angle (trans '(0 0) 1 0)(trans  '(1 0) 1 0)) (cdr (assoc 50 Data))))			(setq Pt_List (list '(0 0) (list W_42 0) (list W_42 H_43) (list 0 H_43)))	(cond 	((= IP 1)	(setq Pt_List (mapcar '(lambda(x)(mapcar '- x (mapcar '* '(0 1.0)(nth 2 Pt_List)))) Pt_List)))			((= IP 2)	(setq Pt_List (mapcar '(lambda(x)(mapcar '- x (mapcar '* '(0.5 1.0)(nth 2 Pt_List)))) Pt_List)))			((= IP 3)	(setq Pt_List (mapcar '(lambda(x)(mapcar '- x (mapcar '* '(1.0 1.0)(nth 2 Pt_List)))) Pt_List)))			((= IP 4)	(setq Pt_List (mapcar '(lambda(x)(mapcar '- x (mapcar '* '(0 0.5)(nth 2 Pt_List)))) Pt_List)))			((= IP 5)	(setq Pt_List (mapcar '(lambda(x)(mapcar '- x (mapcar '* '(0.5 0.5)(nth 2 Pt_List)))) Pt_List)))			((= IP 6)	(setq Pt_List (mapcar '(lambda(x)(mapcar '- x (mapcar '* '(1.0 0.5)(nth 2 Pt_List)))) Pt_List)))			((= IP 7)	(setq Pt_List (mapcar '(lambda(x)(mapcar '- x (mapcar '* '(0 0)(nth 2 Pt_List)))) Pt_List)))			((= IP 8)	(setq Pt_List (mapcar '(lambda(x)(mapcar '- x (mapcar '* '(0.5 0)(nth 2 Pt_List)))) Pt_List)))			((= IP 9)	(setq Pt_List (mapcar '(lambda(x)(mapcar '- x (mapcar '* '(1.0 0)(nth 2 Pt_List)))) Pt_List)))	)	(setq Pt_List (mapcar '(lambda(x)(SD8446  x '(0 0) TAng)) Pt_List))	(setq Pt_List (mapcar '(lambda(x) (mapcar '+  TBase x)) Pt_List))	(setq Pt_List (MovRotScl Pt_List Ins_P Ang Scale_X Scale_Y))	(setq Pt_List (mapcar '(lambda(x)(trans x 0 1)) Pt_List))	(setq Pt_List (BoxPoint Pt_List))		(setq Pt_List_M (append Pt_List_M Pt_List)));;;===================================================(defun Text_Box (ObjName)	(setq TBase (cdr (assoc 10 Data)))			(setq Pt2 (cadr (textbox Data)))				(setq TAng (cdr (assoc 50 Data)))			(setq Pt_List (list '(0 0) (list (car Pt2) 0) Pt2 (list 0 (cadr Pt2))))	(setq Pt_List (mapcar '(lambda(x)(SD8446  x '(0 0) TAng)) Pt_List))	(setq Pt_List (mapcar '(lambda(x) (mapcar '+  TBase x)) Pt_List))		(if (null AttribFlag)(setq Pt_List (MovRotScl Pt_List Ins_P Ang Scale_X Scale_Y)))	(setq Pt_List (mapcar '(lambda(x)(trans x 0 1)) Pt_List))	(setq Pt_List (BoxPoint Pt_List))	(setq Pt_List_M (append Pt_List_M Pt_List)));;;===================================================(defun Line_Box (ObjName);	(princ "\n Line_Box--------------------------")		(setq Pt_List (list (cdr (assoc 10 Data))(cdr (assoc 11 Data))))	(setq Pt_List (MovRotScl Pt_List Ins_P Ang Scale_X Scale_Y))	(setq Pt_List (mapcar '(lambda(x)(trans x 0 1)) Pt_List))		(setq Pt_List (BoxPoint Pt_List))		(setq Pt_List_M (append Pt_List_M Pt_List))	Pt_List_M);;;===================================================(defun CIRCLE_Box(ObjName);	(princ "\n CIRCLE_Box--------------------------")	(setq 	P1 (cdr (assoc 10 Data)) 			Rd (* (abs Scale_X) (cdr (assoc 40 Data))))		(setq Pt_List (list P1))		(setq Pt_List (MovRotScl Pt_List Ins_P Ang Scale_X Scale_Y))	(setq Pt_List (mapcar '(lambda(x)(trans x 0 1)) Pt_List))	(setq Pt_List (list (mapcar '- (car Pt_List)(list Rd Rd))(mapcar '+ (car Pt_List) (list Rd Rd) )))	(setq Pt_List_M (append Pt_List_M Pt_List)));;;===================================================(defun POINT_Box(ObjName)	(setq 	P1 (cdr (assoc 10 Data)))		(setq Pt_List (list P1))		(setq Pt_List (MovRotScl Pt_List Ins_P Ang Scale_X Scale_Y))	(setq Pt_List (mapcar '(lambda(x)(trans x 0 1)) Pt_List))	(setq Pt_List_M (append Pt_List_M Pt_List)))(defun QuaterPt (Pt Rd / )			(setq Px (car Pt) Py (cadr Pt))	(setq QtPt_List (list	(list Px (- Py Rd))	(list (+ Px Rd) Py)	(list Px (+ Py Rd))	(list (- Px Rd) Py)))		;4•ª‰~"_	QtPt_List		j)(defun CompR (PtR_List /)	(setq P1X (caar PtR_List)) 			(setq P1Y (cadar PtR_List))			(setq P2X (caadr PtR_List))			(setq P2Y (cadadr PtR_List))			(setq Ratio (nth 2 PtR_List))	(setq Dist (distance (car PtR_List) (cadr PtR_List)))	(setq Rd (abs ( / (* Dist (+ 1 (expt Ratio 2))) (* 4 Ratio))))	(setq POX ( + ( * (+ P1X P2X) 0.5) ( / ( * (- (expt Ratio 2) 1) (- P2Y P1Y)) ( * 4 Ratio))))	(setq POY ( - ( * (+ P1Y P2Y) 0.5) ( / ( * (- (expt Ratio 2) 1) (- P2X P1X)) ( * 4 Ratio))))	(setq C_Rd (list (list POX POY) Rd))	C_Rd		)(defun AngleCircleToEllip ( AngOnCircle Rate)		(setq AngOnEllip (atan (/ (sin AngOnCircle) (* Rate (cos AngOnCircle)))))	(cond 	((and (<= (* -2.0 pi) AngOnCircle)(< AngOnCircle (* -1.5 pi)))(setq  AngOnEllip (- AngOnEllip (* 2.0 pi))))			((and (<= (* -1.5 pi) AngOnCircle) (< AngOnCircle (* -0.5 pi)))	(setq  AngOnEllip (- AngOnEllip pi)))			((and (<= (* 0.5 pi) AngOnCircle) (< AngOnCircle (* 1.5 pi)))	(setq  AngOnEllip (+ pi AngOnEllip)))			((and (<= (* 1.5 pi) AngOnCircle) (< AngOnCircle (* 2.0 pi)))	(setq  AngOnEllip (+ (* 2.0 pi) AngOnEllip))))	AngOnEllip)(defun BoxPoint (Pt_List / V1 V2 )	(setq V1 (list (apply 'min (mapcar 'car Pt_List))(apply 'min (mapcar 'cadr Pt_List))))	(setq V2 (list (apply 'max (mapcar 'car Pt_List))(apply 'max (mapcar 'cadr Pt_List))))	(setq Pt_List (list V1 V2)))(defun MakeList_PLine ()	(setq mm (1+ mm))	(while (and (/= (car (nth mm Data)) 92)(/= (car (nth mm Data)) 97)(/= (car (nth mm Data)) 75))		(cond 	((= (car (nth mm Data)) 93)(setq PL_NoPt_Temp (append PL_NoPt_Temp (list (cdr (nth mm Data))))))	;'¸"_"				((= (car (nth mm Data)) 10)(setq PL_Pt_Temp (append PL_Pt_Temp (list (cdr (nth mm Data))))))	;'["_				((= (car (nth mm Data)) 42)(setq PL_R_Temp (append PL_R_Temp (list (cdr (nth mm Data))))))	;‚Ó‚­‚ç‚Ý		)		(setq mm (1+ mm))	)	(setq mm (- mm 1))		(if 	(null PL_R_Temp)		(setq L_Line0 PL_Pt_Temp PL_NoPt_Temp nil PL_Pt_Temp nil ))		(setq PL_NoPt (append PL_NoPt PL_NoPt_Temp))	(setq PL_Pt (append PL_Pt PL_Pt_Temp))	(setq PL_R (append PL_R PL_R_Temp))	(setq L_Line (append L_Line L_Line0))	)(defun MakeList_Line ( / L_Line0)	(setq mm (1+ mm))	(while (and (/= (car (nth mm Data)) 72)(/= (car (nth mm Data)) 92)				(/= (car (nth mm Data)) 97)(/= (car (nth mm Data)) 75))		(setq L_Line0 (append L_Line0 (list (cdr (nth mm Data)))))		(setq mm (1+ mm))	)	(setq mm (- mm 1))	(setq L_Line (append L_Line L_Line0))	)(defun MakeList_Arc ( / L_Arc0)	(setq mm (1+ mm))	(while (and (/= (car (nth mm Data)) 72)(/= (car (nth mm Data)) 92)				(/= (car (nth mm Data)) 97)(/= (car (nth mm Data)) 75))		(setq L_Arc0 (append L_Arc0 (list (cdr (nth mm Data)))))		(setq mm (1+ mm))	)	(setq mm (- mm 1))	(setq L_Arc (append L_Arc (list L_Arc0))))(defun MakeList_Ellip ( / L_Ellip0)	(setq mm (1+ mm))	(while (and (/= (car (nth mm Data)) 72)(/= (car (nth mm Data)) 92)				(/= (car (nth mm Data)) 97)(/= (car (nth mm Data)) 75))		(setq L_Ellip0 (append L_Ellip0 (list (cdr (nth mm Data)))))		(setq mm (1+ mm))	)	(setq mm (- mm 1))	(setq L_Ellip (append L_Ellip (list L_Ellip0))))(defun MakeList_Spline ( /L_Spline0)	(setq mm (1+ mm))	(while (and (/= (car (nth mm Data)) 72)(/= (car (nth mm Data)) 92)				(/= (car (nth mm Data)) 97)(/= (car (nth mm Data)) 75))		(if (= (car (nth mm Data)) 10)			(setq L_Spline0 (append L_Spline0 (list (cdr (nth mm Data))))))		(setq mm (1+ mm))	)	(setq mm (- mm 1))	(setq L_Spline (append L_Spline (list L_Spline0))))(defun Entmod_Obj_401 (ObjName	DeltaPt /  NewData Flag3 NextName Loc DataA NextObjType Flag4 Flag5)	(setq Data (entget ObjName))	(setq ObjType (cdr(assoc 0 Data)))	(cond 	((or (= ObjType "LINE")	(= ObjType "SPLINE"))				(entmod (mapcar '(lambda(x)(if 	(or (= (car x) 10) (= (car x) 11))														(list (car x)(+ (nth 1 x) (car DeltaPt))(+ (nth 2 x)(cadr DeltaPt))(nth 3 x))														x)) (entget ObjName)))			)			((= ObjType "INSERT")				(setq Loc (assoc 10 Data))				(entmod (subst 	(list 10 (+ (nth 1 Loc) (car DeltaPt))(+ (nth 2 Loc)(cadr DeltaPt))(nth 3 Loc))	Loc Data))								(cond 	((= (cdr (assoc 66 Data)) 1)						(setq ObjNext (entnext ObjName))						(while 	(= (cdr (assoc 0 (setq DataA (entget ObjNext)))) "ATTRIB")						       	(setq Loc (assoc 11 DataA))						       	(entmod(subst 	(list 11 (+ (nth 1 Loc) (car DeltaPt))(+ (nth 2 Loc)(cadr DeltaPt))(nth 3 Loc))	Loc DataA))								(entupd ObjNext)								(setq ObjNext(entnext ObjNext))						)						)				)			)			((= ObjType "POLYLINE")				;vertex				(setq NextName (entnext ObjName))				(setq NextObjType (cdr (assoc 0  (entget NextName))))				(while (/= NextObjType "SEQEND")					(if (= (cdr(assoc 0 (setq DataA (entget NextName)))) "VERTEX")			            	(progn	(setq Loc (assoc 10 DataA))			            			(entmod (subst 	(list 10 (+ (nth 1 Loc) (car DeltaPt))(+ (nth 2 Loc)(cadr DeltaPt))(nth 3 Loc))	Loc DataA))			            			(entupd NextName)			            	)			            )					(setq NextName(entnext NextName))					(setq NextObjType (cdr (assoc 0  (entget NextName))))				)			)			((= ObjType "HATCH")				(entmod (mapcar '(lambda(x)					(cond	((and (= (car x) 92)(= (logand (cdr x) 2) 2))								(setq Flag4 nil Flag5 nil)							)							((and (= (car x) 92)(/= (logand (cdr x) 2) 2))								(setq Flag4 T Flag5 nil)							)					)					(cond	((and (= (car x) 72)(= (cdr x) 3) Flag4)								(setq Flag5 T)													)							((and (= (car x) 72)(/= (cdr x) 3) Flag4)							(setq Flag5 nil)													)						)					(cond 	((and Flag5 (=(car x) 10))								(list 10 (+ (nth 1 x) (car DeltaPt))(+ (nth 2 x)(cadr DeltaPt))(nth 3 x))													)							((and (null Flag5)(or (=(car x) 10)(=(car x) 11)))								(list (car x) (+ (nth 1 x) (car DeltaPt))(+ (nth 2 x)(cadr DeltaPt))(nth 3 x))													)							(T x)					)					)Data)				)			)			((= ObjType "LWPOLYLINE")				(if (<= 0 (nth 3 (assoc 210 (entget ObjName))))(setq Flag3 1)(setq Flag3 -1))				(entmod (mapcar '(lambda(x) (if (= (car x) 10)(list 10 (+ (nth 1 x)(* Flag3 (car DeltaPt)))(+ (nth 2 x)(cadr DeltaPt))) x))											(entget ObjName)))     	     )	       	((= ObjType "DIMENSION")				(entmod (mapcar '(lambda(x)(if 	(or (= (car x) 10) (= (car x) 11)(= (car x) 13)(= (car x) 14)(= (car x) 15))														(list (car x)(+ (nth 1 x) (car DeltaPt))(+ (nth 2 x)(cadr DeltaPt))(nth 3 x))														x)) (entget ObjName)))	            )			((= ObjType "TEXT")		            (if 	(and (= (cdr(assoc 72 (entget ObjName))) 0)(= (cdr(assoc 73 (entget ObjName))) 0))		            	(progn	(setq Loc (assoc 10 Data))		            			(entmod (subst 	(list 10 (+ (nth 1 Loc) (car DeltaPt))(+ (nth 2 Loc)(cadr DeltaPt))(nth 3 Loc))	Loc Data))		            	)		            	(progn	(setq Loc (assoc 11 Data))		            			(entmod (subst 	(list 11 (+ (nth 1 Loc) (car DeltaPt))(+ (nth 2 Loc)(cadr DeltaPt))(nth 3 Loc))	Loc Data))		            	)			     )	            )	       	((or (= ObjType "CIRCLE")(= ObjType "ARC")(= ObjType "ELLIPSE")(= ObjType "MTEXT")(= ObjType "ATTDEF"))		       	(setq Loc (assoc 10 Data))		       	(entmod (subst 	(list 10 (+ (nth 1 Loc) (car DeltaPt))(+ (nth 2 Loc)(cadr DeltaPt))(nth 3 Loc))		       					Loc Data))		       )     		(T	(princ "\n Not Defined"))     ))(princ)(defun SD8446 ( PointA PointB Ang / XA YA XB YB PointC)	(setq	XA2(- (car PointA) (car PointB))			YA2(- (cadr PointA) (cadr PointB))	)	(setq PointC (list (- (* XA2 (cos Ang))(* YA2 (sin Ang))) (+ (* XA2 (sin Ang))(* YA2 (cos Ang)))))	(setq PointC (mapcar '+ PointC PointB))	PointC)(defun MovRotScl (Pt_List Ins_P Ang Scale_X Scale_Y / )	(setq Pt_List (mapcar '(lambda(x)(mapcar '* (list Scale_X Scale_Y ) x )) Pt_List))		;scale	(setq Pt_List (mapcar '(lambda (x) (list     (- (* (cos Ang) (car x)) (* (sin Ang) (cadr x))) (+ (* (sin Ang) (car x)) (* (cos Ang) (cadr x))))) Pt_List))	(setq Pt_List (mapcar '(lambda(x)(mapcar '+ Ins_P x)) Pt_List)) 	;move	Pt_List)(defun MakeListInsideBlock ( ObjName1 / B_Name1 I_ObjName1 I_ObjType1 I_ObjList1)	(setq B_Name1 (cdr (assoc 2 (entget ObjName1))))	(setq I_ObjName1 (cdr(assoc -2(tblsearch "block" B_Name1))))	(setq I_NameList1 (list I_ObjName1))	(while	(entnext I_ObjName1)		(setq I_ObjName1 (entnext I_ObjName1))		(setq I_NameList1 (append I_NameList1 (list I_ObjName1)))	)	I_NameList1)(defun GetObjSize_401 ( ObjName / Ins_P Ang Scale_X Scale_Y Data  I_NameList Pt_List_M									L_Line L_Arc L_Ellip L_Spline  PL_NoPt PL_Pt PL_R									nn mm Item j p Pt_List C_Rd_List QtPt_List 									P1 P2 P2x P2y Rate EPs EPe	EDrec Pt_List2 Pt_List3									PL_NoPt_Temp PL_Pt_Temp PL_R_Temp L_Line0 L_Arc0 L_Ellip0 L_Spline0)	(setq Ins_P '(0 0) Ang 0.0 Scale_X 1.0 Scale_Y 1.0)	(setq Pt_List_M (Distribution_401 ObjName))	Pt_List_M)

E cũng làm 1 phát test với 40k đối tượng già trẻ lớn bé to nhỏ đậm nhạt..Kết quả có phần đạt yêu cầu ^^

 

Cái này mà bác ketxu thêm chức năng giãn dòng nữa thì rất ok. thanks


<<

Filename: 173029_trai_giua_phai_tren_giua1_duoi.lsp

Trang 279/330

279