Đến nội dung


Hình ảnh
- - - - -

Căn lề text + Mtext, Căn lề đối tượng


  • Please log in to reply
52 replies to this topic

#1 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5678 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 20 December 2010 - 09:48 AM

Trước giờ, e vẫn dùng lisp ft của bác Đường Thái để căn lề cho text, cảm thấy rất ưng ý rồi, cứ ngỡ rằng như thế là đủ...Vừa rồi lớ ngớ mò vào trang Nhật Bổn, mót được cái này,e liền làm thử bài đánh giá, thấy tốc độ khá tốt, các bác thử chém gió xem sao, và vì code dài nên e cũng chẳng hiểu tại sao ^^

Mạn phép bác Thái,E xin post lại lisp ft của bác, thêm dòng check time :

(defun c:ft()
(setq txt (ssget '((0 . "*TEXT"))))
(setq mau (entget (car (entsel "\nChon text chuan"))))
(command "undo" "begin")
(setq oldos (getvar "osmode"))
(setq olcol (getvar "CEColor"))
(setq ollay (getvar "Clayer"))
(setq olstyle (getvar "textstyle"))
(setq TB (textbox mau) LC (car TB) RC (cadr TB) di (distance LC RC) i 0)
(setq h (cdr(assoc 40 mau)))
(setq x1 (cdr(assoc 10 mau)))
(setq x2 (list (+ (car x1) (* di 0.5) (* -0.03 h)) (cadr x1)))
(setq x3 (list (+ (car x1) di (* -0.06 h)) (cadr x1)))
(setq canle (cond (canle) ("Left")))
(initget "Left Center Right Fit")
(setq canle (cond ((getkword (strcat "\Vi tri can le [Left/Center/Right/Fit/]<" canle ">"))) (canle)))
(setq oldang (getvar "Angbase"))
(command "angbase" 0 "ucs" "w")

(setq time (getvar "MILLISECS"))

(repeat (sslength txt)
(setq txt_ent (entget (ssname txt i)))
(setq txt_val (cdr(assoc 1 txt_ent)))
(setq txt_st (cdr(assoc 7 txt_ent)))
(setq txt_lay (cdr(assoc 8 txt_ent)))
(setq txt_h (cdr(assoc 40 txt_ent)))
(setq txt_fctr (cdr(assoc 41 txt_ent)))
(setq txt_clr (cdr(assoc 62 txt_ent)))
(setq y1 (cdr(assoc 10 txt_ent)))
(if (cdr(assoc 43 txt_ent)) (setq txt_fctr 1 y1 (list (car y1) (- (cadr y1) txt_h))))
(setq pt1 (list (car x1) (cadr y1)))
(setq pt2 (list (car x2) (cadr y1)))
(setq pt3 (list (car x3) (cadr y1)))
(command "-style" txt_st "" 0 txt_fctr "" "" "" "" "clayer" txt_lay "color" txt_clr "osmode" 0)
(if (eq canle "Left") (command "text" pt1 txt_h 0 txt_val))
(if (eq canle "Center") (command "text" "C" pt2 txt_h 0 txt_val))
(if (eq canle "Right") (command "text" "R" pt3 txt_h 0 txt_val))
(if (eq canle "Fit") (command "text" "F" pt1 pt3 txt_h txt_val))
(setq i (+ i 1))
(command "color" "bylayer")
);repeat
(command "ucs" "p")
(setvar "textstyle" olstyle)
(setvar "angbase" oldang)
(setvar "Clayer" ollay)
(setvar "CECOLOR" olcol)
(setvar "osmode" oldos)
(command "erase" txt "")

(setq time (/ (- (getvar "MILLISECS") time) 1000.0))
(princ (strcat "\nThoi gian thuc hien (giay) :" (rtos time)))

(prompt"\nText da duoc sap xep lai\n")
(command "undo" "end")
);defun


Bên dưới là code khác,dài hơn,cũng với chức năng tương tự (và đổi Insert point của text) :


(defun c:trai ( / ObjSet ObjName ObjName0 Data Value72_73_71 Co AssocL
Data0 Ang1 AngT Ang2 Pt0 Pt0_U Pt0_O i)

(princ "\n Change Insetion point to Left and align to Left")
(setq Value72_73_71 '(0 0 7))
(setq AssocL '(10 10))
(Procedure)
(princ)
)

(defun c:giua ( / ObjSet ObjName ObjName0 Data Value72_73_71 Co AssocL
Data0 Ang1 AngT Ang2 Pt0 Pt0_U Pt0_O i)

(princ "\n Change Insetion point to Center and align to Center")
(setq Value72_73_71 '(1 0 8))
(setq AssocL '(11 10))
(Procedure)
(princ)
)

(defun c:phai ( / ObjSet ObjName ObjName0 Data Value72_73_71 Co AssocL
Data0 Ang1 AngT Ang2 Pt0 Pt0_U Pt0_O i)
(princ "\n Change Insetion point to Right and align to Right")

(setq Value72_73_71 '(2 0 9))
(setq AssocL '(11 10))
(Procedure)
(princ)
)

;***************************************************
(defun Procedure ()
(while (= ObjSet nil)
(setq ObjSet (ssget '((-4 . ""))))
)
(setq ObjName0 (car (entsel "\n")))
(setq i 0)
(setq time (getvar "MILLISECS"))
(repeat (sslength ObjSet)
(setq ObjName (ssname ObjSet i))
(setq Data (entget ObjName))
(cond ((= (cdr(assoc 0 Data)) "TEXT")
(TextInsP_Text ObjName Value72_73_71)
(setq Co (car AssocL))
)
( (= (cdr(assoc 0 Data)) "MTEXT")
(TextInsP_MText ObjName Value72_73_71)
(setq Co (cadr AssocL))
)
)
(setq i (1+ i))
)


(setq Data0 (entget ObjName0))
(setq Ang1 (angle '(0 0) (getvar "UCSXDIR")))
(cond ((= (cdr(assoc 0 Data0)) "TEXT")
(setq AngT (cdr(assoc 50 Data0)))
(setq Ang2 (- AngT Ang1))
(setq Co (car AssocL))
)
((= (cdr(assoc 0 Data0)) "MTEXT")
(setq Ang2 (cdr(assoc 50 Data0)))
(setq AngT (+ Ang1 Ang2))
(setq Co (cadr AssocL))
)
)
(setq Pt0 (cdr (assoc Co Data0)))
(setq Pt0_U (trans Pt0 0 1))
(setq Pt0_O (SD1862 Pt0_U Ang2))

(setq i 0)
(repeat (sslength ObjSet)
(setq Data (entget (setq ObjName (ssname ObjSet i))))
(cond ((= (cdr(assoc 0 Data)) "TEXT")(setq Co (car AssocL)))
((= (cdr(assoc 0 Data)) "MTEXT")(setq Co (cadr AssocL)))
)
(setq Pt1 (cdr (assoc Co Data)))
(setq Pt1_U (trans Pt1 0 1))
(setq Pt1_O (SD1862 Pt1_U Ang2))
(setq Delta_O (- (car Pt0_O) (car Pt1_O)))
(setq Delta_U (SD8446 (list Delta_O 0) '(0 0) AngT))
(setq Data (subst (cons Co (mapcar '+ Pt1 Delta_U))(assoc Co Data) Data))
(entmod Data)
(setq i (1+ i))
)
(setq time (/ (- (getvar "MILLISECS") time) 1000.0))
(princ (strcat "\nThoi gian thuc hien (giay) :" (rtos time)))
(princ)
)



(defun TextInsP_Text ( ObjName Value72_73_71 / Data OrgPosition NewPosition Org_11 New_11 )

(setq Data (entget ObjName))
(setq OrgPosition (cdr (assoc 10 Data)))
(setq Org_11 (cdr (assoc 11 Data))) ,0,0j
(setq Data (subst (cons 72 (car Value72_73_71)) (assoc 72 Data) Data))
(setq Data (subst (cons 73 (cadr Value72_73_71)) (assoc 73 Data) Data))
(entmod Data)

(setq NewPosition (cdr (assoc 10 (entget ObjName))))
(setq Delta (mapcar '- OrgPosition NewPosition))
(setq New_11 (mapcar '+ Org_11 Delta))
(setq Data (entget ObjName))
(setq Data (subst (cons 11 New_11) (assoc 11 Data) Data))
(entmod Data)
)


(defun TextInsP_MText ( ObjName Value72_73_71 / Data X_Old X_New Y_Old Y_New Scale Base0 W_42 Ang_50 Delta )
(setq Data (entget ObjName))
(setq InsP (cdr (assoc 10 Data)))
(setq W_42 (cdr (assoc 42 (entget ObjName))))
(setq H_43 (cdr (assoc 43 (entget ObjName))))
(setq Ang (cdr (assoc 50 Data)))
(setq AngU (angle '(0 0) (getvar "UCSXDIR")))
(setq OldIP (cdr (assoc 71 Data)))
(setq NewIP (caddr Value72_73_71))

(setq Data (subst (cons 71 NewIP) (assoc 71 Data) Data))
(entmod Data)


(setq X_Old (- (+ OldIP 2) (* (fix ( / (+ OldIP 2) 3)) 3)))
(setq X_New (- (+ NewIP 2) (* (fix ( / (+ NewIP 2) 3)) 3)))


(setq Y_Old (fix ( / (- OldIP 1) 3)))
(setq Y_New (fix ( / (- NewIP 1) 3)))

(setq IncUnit (list (- X_New X_Old)(- Y_Old Y_New )))



(setq Delta (mapcar '* IncUnit (list (* 0.5 W_42)(* 0.5 H_43))))

(setq Delta (SD8446 Delta '(0 0) Ang))

·
(setq Delta (SD1862 Delta (* -1.0 AngU)))

(setq Data (subst (cons 10 (mapcar '+ InsP Delta))(assoc 10 Data) Data))
(entmod Data)

)

(defun SD1862 (OldPt Ang / NewCs)
(setq NewCs (SD8446 '(1 0) '(0 0) Ang))
(setq NewPt (trans OldPt 0 NewCs))
(setq NewPt (list (nth 2 NewPt)(nth 0 NewPt)))
NewPt
)

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


Tiếp theo, thực hiện test so sánh :
Lần 1: với 100 text và sắp xếp bên trái :

Command: ft

Select objects: Specify opposite corner: 100 found

Select objects:
Chon text chuanVi tri can le [Left/Center/Right/Fit/]L

Thoi gian thuc hien (giay) :6.053
Text da duoc sap xep lai
nil

Command: trai

Change Insetion point to Left and align to Left100 found


Thoi gian thuc hien (giay) :0.171

-> gần như là ngay tức thì

Lần 2, e chơi sang làm hẳn 1000 text + Mtext đi .Lần này thì :

Command: ft

Select objects: Specify opposite corner: 77 found
.......
Select objects: Specify opposite corner: 279 found (279 duplicate), 1000 total

Select objects:
Chon text chuanVi tri can le [Left/Center/Right/Fit/]L

Thoi gian thuc hien (giay) :64.413
Text da duoc sap xep lai
nil

Command: Specify opposite corner:
Command: trai

Change Insetion point to Left and align to Left1000 found


Thoi gian thuc hien (giay) :1.388

- > :undecided:

Vậy là tương quan,2 lisp chênh nhau về thời gian xử lý khoảng 50 lần.Tất nhiên, ngoài thực tế ít khi ta gặp 1 đoạn văn bản CAD dài như vậy, nhưng nhiều khi, 1 vấn đề đã cũ,mà vẫn có nhiều lựa chọn giải quyết.

PS :Còn đoạn code FIT + code sắp xếp Đối tượng cũng khù khoằm như vậy,tí rỗi e post típ ^^

P/S 2 : hình như 4room lại trục trặc, e post file lisp đây
Lisp
  • 4

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#2 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 992 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 20 December 2010 - 11:06 AM

Trước giờ, e vẫn dùng lisp ft của bác Đường Thái để căn lề cho text, cảm thấy rất ưng ý rồi, cứ ngỡ rằng như thế là đủ...Vừa rồi lớ ngớ mò vào trang Nhật Bổn, mót được cái này,e liền làm thử bài đánh giá, thấy tốc độ khá tốt, các bác thử chém gió xem sao, và vì code dài nên e cũng chẳng hiểu tại sao ^^

Mạn phép bác Thái,E xin post lại lisp ft của bác, thêm dòng check time :

(defun c:ft()
(setq txt (ssget '((0 . "*TEXT"))))
(setq mau (entget (car (entsel "\nChon text chuan"))))
(command "undo" "begin")
(setq oldos (getvar "osmode"))
(setq olcol (getvar "CEColor"))
(setq ollay (getvar "Clayer"))
(setq olstyle (getvar "textstyle"))
(setq TB (textbox mau) LC (car TB) RC (cadr TB) di (distance LC RC) i 0)
(setq h (cdr(assoc 40 mau)))
(setq x1 (cdr(assoc 10 mau)))
(setq x2 (list (+ (car x1) (* di 0.5) (* -0.03 h)) (cadr x1)))
(setq x3 (list (+ (car x1) di (* -0.06 h)) (cadr x1)))
(setq canle (cond (canle) ("Left")))
(initget "Left Center Right Fit")
(setq canle (cond ((getkword (strcat "\Vi tri can le [Left/Center/Right/Fit/]<" canle ">"))) (canle)))
(setq oldang (getvar "Angbase"))
(command "angbase" 0 "ucs" "w")

(setq time (getvar "MILLISECS"))

(repeat (sslength txt)
(setq txt_ent (entget (ssname txt i)))
(setq txt_val (cdr(assoc 1 txt_ent)))
(setq txt_st (cdr(assoc 7 txt_ent)))
(setq txt_lay (cdr(assoc 8 txt_ent)))
(setq txt_h (cdr(assoc 40 txt_ent)))
(setq txt_fctr (cdr(assoc 41 txt_ent)))
(setq txt_clr (cdr(assoc 62 txt_ent)))
(setq y1 (cdr(assoc 10 txt_ent)))
(if (cdr(assoc 43 txt_ent)) (setq txt_fctr 1 y1 (list (car y1) (- (cadr y1) txt_h))))
(setq pt1 (list (car x1) (cadr y1)))
(setq pt2 (list (car x2) (cadr y1)))
(setq pt3 (list (car x3) (cadr y1)))
(command "-style" txt_st "" 0 txt_fctr "" "" "" "" "clayer" txt_lay "color" txt_clr "osmode" 0)
(if (eq canle "Left") (command "text" pt1 txt_h 0 txt_val))
(if (eq canle "Center") (command "text" "C" pt2 txt_h 0 txt_val))
(if (eq canle "Right") (command "text" "R" pt3 txt_h 0 txt_val))
(if (eq canle "Fit") (command "text" "F" pt1 pt3 txt_h txt_val))
(setq i (+ i 1))
(command "color" "bylayer")
);repeat
(command "ucs" "p")
(setvar "textstyle" olstyle)
(setvar "angbase" oldang)
(setvar "Clayer" ollay)
(setvar "CECOLOR" olcol)
(setvar "osmode" oldos)
(command "erase" txt "")

(setq time (/ (- (getvar "MILLISECS") time) 1000.0))
(princ (strcat "\nThoi gian thuc hien (giay) :" (rtos time)))

(prompt"\nText da duoc sap xep lai\n")
(command "undo" "end")
);defun


Bên dưới là code khác,dài hơn,cũng với chức năng tương tự (và đổi Insert point của text) :


(defun c:trai ( / ObjSet ObjName ObjName0 Data Value72_73_71 Co AssocL
Data0 Ang1 AngT Ang2 Pt0 Pt0_U Pt0_O i)

(princ "\n Change Insetion point to Left and align to Left")
(setq Value72_73_71 '(0 0 7))
(setq AssocL '(10 10))
(Procedure)
(princ)
)

(defun c:giua ( / ObjSet ObjName ObjName0 Data Value72_73_71 Co AssocL
Data0 Ang1 AngT Ang2 Pt0 Pt0_U Pt0_O i)

(princ "\n Change Insetion point to Center and align to Center")
(setq Value72_73_71 '(1 0 8))
(setq AssocL '(11 10))
(Procedure)
(princ)
)

(defun c:phai ( / ObjSet ObjName ObjName0 Data Value72_73_71 Co AssocL
Data0 Ang1 AngT Ang2 Pt0 Pt0_U Pt0_O i)
(princ "\n Change Insetion point to Right and align to Right")

(setq Value72_73_71 '(2 0 9))
(setq AssocL '(11 10))
(Procedure)
(princ)
)

;***************************************************
(defun Procedure ()
(while (= ObjSet nil)
(setq ObjSet (ssget '((-4 . ""))))
)
(setq ObjName0 (car (entsel "\n")))
(setq i 0)
(setq time (getvar "MILLISECS"))
(repeat (sslength ObjSet)
(setq ObjName (ssname ObjSet i))
(setq Data (entget ObjName))
(cond ((= (cdr(assoc 0 Data)) "TEXT")
(TextInsP_Text ObjName Value72_73_71)
(setq Co (car AssocL))
)
( (= (cdr(assoc 0 Data)) "MTEXT")
(TextInsP_MText ObjName Value72_73_71)
(setq Co (cadr AssocL))
)
)
(setq i (1+ i))
)


(setq Data0 (entget ObjName0))
(setq Ang1 (angle '(0 0) (getvar "UCSXDIR")))
(cond ((= (cdr(assoc 0 Data0)) "TEXT")
(setq AngT (cdr(assoc 50 Data0)))
(setq Ang2 (- AngT Ang1))
(setq Co (car AssocL))
)
((= (cdr(assoc 0 Data0)) "MTEXT")
(setq Ang2 (cdr(assoc 50 Data0)))
(setq AngT (+ Ang1 Ang2))
(setq Co (cadr AssocL))
)
)
(setq Pt0 (cdr (assoc Co Data0)))
(setq Pt0_U (trans Pt0 0 1))
(setq Pt0_O (SD1862 Pt0_U Ang2))

(setq i 0)
(repeat (sslength ObjSet)
(setq Data (entget (setq ObjName (ssname ObjSet i))))
(cond ((= (cdr(assoc 0 Data)) "TEXT")(setq Co (car AssocL)))
((= (cdr(assoc 0 Data)) "MTEXT")(setq Co (cadr AssocL)))
)
(setq Pt1 (cdr (assoc Co Data)))
(setq Pt1_U (trans Pt1 0 1))
(setq Pt1_O (SD1862 Pt1_U Ang2))
(setq Delta_O (- (car Pt0_O) (car Pt1_O)))
(setq Delta_U (SD8446 (list Delta_O 0) '(0 0) AngT))
(setq Data (subst (cons Co (mapcar '+ Pt1 Delta_U))(assoc Co Data) Data))
(entmod Data)
(setq i (1+ i))
)
(setq time (/ (- (getvar "MILLISECS") time) 1000.0))
(princ (strcat "\nThoi gian thuc hien (giay) :" (rtos time)))
(princ)
)
(defun TextInsP_Text ( ObjName Value72_73_71 / Data OrgPosition NewPosition Org_11 New_11 )

(setq Data (entget ObjName))
(setq OrgPosition (cdr (assoc 10 Data)))
(setq Org_11 (cdr (assoc 11 Data)))
(setq Data (subst (cons 72 (car Value72_73_71)) (assoc 72 Data) Data))
(setq Data (subst (cons 73 (cadr Value72_73_71)) (assoc 73 Data) Data))
(entmod Data)
‚ª–³‚¢j
(setq NewPosition (cdr (assoc 10 (entget ObjName))))
(setq Delta (mapcar '- OrgPosition NewPosition))
(setq New_11 (mapcar '+ Org_11 Delta))
(setq Data (entget ObjName))
(setq Data (subst (cons 11 New_11) (assoc 11 Data) Data))
(entmod Data)
)
(defun TextInsP_MText ( ObjName Value72_73_71 / Data X_Old X_New Y_Old Y_New Scale Base0 W_42 Ang_50 Delta )
(setq Data (entget ObjName))
(setq InsP (cdr (assoc 10 Data)))
(setq W_42 (cdr (assoc 42 (entget ObjName))))
(setq H_43 (cdr (assoc 43 (entget ObjName))))
(setq Ang (cdr (assoc 50 Data)))
(setq AngU (angle '(0 0) (getvar "UCSXDIR")))
(setq OldIP (cdr (assoc 71 Data)))
(setq NewIP (caddr Value72_73_71))

(setq Data (subst (cons 71 NewIP) (assoc 71 Data) Data))
(entmod Data)


(setq X_Old (- (+ OldIP 2) (* (fix ( / (+ OldIP 2) 3)) 3)))
(setq X_New (- (+ NewIP 2) (* (fix ( / (+ NewIP 2) 3)) 3)))


(setq Y_Old (fix ( / (- OldIP 1) 3)))
(setq Y_New (fix ( / (- NewIP 1) 3)))

(setq IncUnit (list (- X_New X_Old)(- Y_Old Y_New )))
(setq Delta (mapcar '* IncUnit (list (* 0.5 W_42)(* 0.5 H_43))))

(setq Delta (SD8446 Delta '(0 0) Ang))

·
(setq Delta (SD1862 Delta (* -1.0 AngU)))

(setq Data (subst (cons 10 (mapcar '+ InsP Delta))(assoc 10 Data) Data))
(entmod Data)

)


Tiếp theo, thực hiện test so sánh :
Lần 1: với 100 text và sắp xếp bên trái :

-> gần như là ngay tức thì

Lần 2, e chơi sang làm hẳn 1000 text + Mtext đi .Lần này thì :

- > :undecided:

Vậy là tương quan,2 lisp chênh nhau về thời gian xử lý khoảng 50 lần.Tất nhiên, ngoài thực tế ít khi ta gặp 1 đoạn văn bản CAD dài như vậy, nhưng nhiều khi, 1 vấn đề đã cũ,mà vẫn có nhiều lựa chọn giải quyết.

PS :Còn đoạn code FIT + code sắp xếp Đối tượng cũng khù khoằm như vậy,tí rỗi e post típ ^^

bạn ketxu rất hăng hái trong diễn đàn. Cảm ơn bài viết của bạn. Mình ủng hộ bạn
  • 0



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#3 hdg2318

hdg2318

    biết lệnh mirror

  • Members
  • PipPipPip
  • 158 Bài viết
Điểm đánh giá: 31 (tàm tạm)

Đã gửi 20 December 2010 - 12:38 PM

đoạn code bạn post ko hết, ko chạy được, ko test được.
  • 0

Có 2 cách để nhìn đời:
1 là : coi như chẳng có gì là huyền diệu
2 là : coi như mọi điều đều huyền diệu


Click here


#4 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5678 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 20 December 2010 - 01:11 PM

Cám ơn bạn đã phát hiện.Có thể do 4rum bị lỗi tạm thời hoặc mắt mũi mình tèm nhèm cóp k hết, nên để chắc ăn mình up lại file lisp bên dưới bài 1 rồi đó ^^ :">
  • 0

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#5 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5678 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 20 December 2010 - 02:27 PM

bạn ketxu rất hăng hái trong diễn đàn. Cảm ơn bài viết của bạn. Mình ủng hộ bạn

Hề hề :undecided: Được câu nói mát lòng mát dạ.CV toàn ng nhiệt tình (như và) hơn mình th :"> Tks bạn
  • 0

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#6 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

  • Moderator
  • PipPipPipPipPipPipPip
  • 6007 Bài viết
Điểm đánh giá: 3113 (tuyệt vời)

Đã gửi 20 December 2010 - 02:35 PM

Cám ơn bạn đã phát hiện.Có thể do 4rum bị lỗi tạm thời hoặc mắt mũi mình tèm nhèm cóp k hết, nên để chắc ăn mình up lại file lisp bên dưới bài 1 rồi đó ^^ :">

Hề hề hề,
Chào bác ketxu,
Cám ơn bác đã chia xẻ với mọi người những thông tin hữu ích.
Sau khi đọc lướt qua thấy cái lisp của nhật bổn nó có sử dụng hai cái hàm (SD8446 .....) và (SD1862 ....) mà mình chả hiểu cái hàm này nó có răng hay không nữa bác ạ.....
Bác có thông tin gì về nó có thể cho anh em biết tí xíu được không ạ.
Hề hề hề,....
  • 0
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#7 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5678 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 20 December 2010 - 02:46 PM

Ý,hí hí,nó ở trong file lisp support nên e để sót,lúc test trên máy mình thì quên béng mất,e đã kèm theo rồi đấy ạ :undecided:

P/S : e còn ít tuổi mà ... :|
  • 0

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#8 Thaistreetz

Thaistreetz

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 903 Bài viết
Điểm đánh giá: 505 (tốt)

Đã gửi 20 December 2010 - 03:38 PM

hehe, lisp trên là 1 trong mấy lisp đầu tay của mình ở cadviet. toàn dùng hàm command để move text nên nó chậm là đúng rùi. với lại nó sảy ra lỗi khi dùng cho các loại text và Mtext có thuộc tính annotative (bản vẽ cty mình toàn text loại này) nên mình bỏ nó chẳng buồn sửa nữa. lười viết lại nên giờ chuyển qua dùng lisp của cty :undecided:
  • 0

Hình đã gửi
IN HIM, I TRUST. THE TRUST IN MY GOD


#9 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5678 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 20 December 2010 - 03:47 PM

Bác đệu thật.Thế mà cứ găm mãi.E vẫn dùng nó từ khi đi làm đến giờ đấy >"< ( 4 tháng rùi chứ ít ỏi j) .Thế pác post lên đi :">.
P/S : lisp trên cũng bay text khi text chọn làm mẫu không thuộc tập chọn ban đầu,n được cái tốt là Mờ tếch mờ tiếc k bị thay đổi format ^^
  • 0

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#10 18011985

18011985

    biết lệnh properties

  • Members
  • PipPipPipPip
  • 255 Bài viết
Điểm đánh giá: 61 (tàm tạm)

Đã gửi 20 December 2010 - 03:54 PM

Trước giờ, e vẫn dùng lisp ft của bác Đường Thái để căn lề cho text, cảm thấy rất ưng ý rồi, cứ ngỡ rằng như thế là đủ...Vừa rồi lớ ngớ mò vào trang Nhật Bổn, mót được cái này,e liền làm thử bài đánh giá, thấy tốc độ khá tốt, các bác thử chém gió xem sao, và vì code dài nên e cũng chẳng hiểu tại sao ^^

Mạn phép bác Thái,E xin post lại lisp ft của bác, thêm dòng check time :

(defun c:ft()
(setq txt (ssget '((0 . "*TEXT"))))
(setq mau (entget (car (entsel "\nChon text chuan"))))
(command "undo" "begin")
(setq oldos (getvar "osmode"))
(setq olcol (getvar "CEColor"))
(setq ollay (getvar "Clayer"))
(setq olstyle (getvar "textstyle"))
(setq TB (textbox mau) LC (car TB) RC (cadr TB) di (distance LC RC) i 0)
(setq h (cdr(assoc 40 mau)))
(setq x1 (cdr(assoc 10 mau)))
(setq x2 (list (+ (car x1) (* di 0.5) (* -0.03 h)) (cadr x1)))
(setq x3 (list (+ (car x1) di (* -0.06 h)) (cadr x1)))
(setq canle (cond (canle) ("Left")))
(initget "Left Center Right Fit")
(setq canle (cond ((getkword (strcat "\Vi tri can le [Left/Center/Right/Fit/]<" canle ">"))) (canle)))
(setq oldang (getvar "Angbase"))
(command "angbase" 0 "ucs" "w")

(setq time (getvar "MILLISECS"))

(repeat (sslength txt)
(setq txt_ent (entget (ssname txt i)))
(setq txt_val (cdr(assoc 1 txt_ent)))
(setq txt_st (cdr(assoc 7 txt_ent)))
(setq txt_lay (cdr(assoc 8 txt_ent)))
(setq txt_h (cdr(assoc 40 txt_ent)))
(setq txt_fctr (cdr(assoc 41 txt_ent)))
(setq txt_clr (cdr(assoc 62 txt_ent)))
(setq y1 (cdr(assoc 10 txt_ent)))
(if (cdr(assoc 43 txt_ent)) (setq txt_fctr 1 y1 (list (car y1) (- (cadr y1) txt_h))))
(setq pt1 (list (car x1) (cadr y1)))
(setq pt2 (list (car x2) (cadr y1)))
(setq pt3 (list (car x3) (cadr y1)))
(command "-style" txt_st "" 0 txt_fctr "" "" "" "" "clayer" txt_lay "color" txt_clr "osmode" 0)
(if (eq canle "Left") (command "text" pt1 txt_h 0 txt_val))
(if (eq canle "Center") (command "text" "C" pt2 txt_h 0 txt_val))
(if (eq canle "Right") (command "text" "R" pt3 txt_h 0 txt_val))
(if (eq canle "Fit") (command "text" "F" pt1 pt3 txt_h txt_val))
(setq i (+ i 1))
(command "color" "bylayer")
);repeat
(command "ucs" "p")
(setvar "textstyle" olstyle)
(setvar "angbase" oldang)
(setvar "Clayer" ollay)
(setvar "CECOLOR" olcol)
(setvar "osmode" oldos)
(command "erase" txt "")

(setq time (/ (- (getvar "MILLISECS") time) 1000.0))
(princ (strcat "\nThoi gian thuc hien (giay) :" (rtos time)))

(prompt"\nText da duoc sap xep lai\n")
(command "undo" "end")
);defun


Bên dưới là code khác,dài hơn,cũng với chức năng tương tự (và đổi Insert point của text) :


(defun c:trai ( / ObjSet ObjName ObjName0 Data Value72_73_71 Co AssocL
Data0 Ang1 AngT Ang2 Pt0 Pt0_U Pt0_O i)

(princ "\n Change Insetion point to Left and align to Left")
(setq Value72_73_71 '(0 0 7))
(setq AssocL '(10 10))
(Procedure)
(princ)
)

(defun c:giua ( / ObjSet ObjName ObjName0 Data Value72_73_71 Co AssocL
Data0 Ang1 AngT Ang2 Pt0 Pt0_U Pt0_O i)

(princ "\n Change Insetion point to Center and align to Center")
(setq Value72_73_71 '(1 0 8))
(setq AssocL '(11 10))
(Procedure)
(princ)
)

(defun c:phai ( / ObjSet ObjName ObjName0 Data Value72_73_71 Co AssocL
Data0 Ang1 AngT Ang2 Pt0 Pt0_U Pt0_O i)
(princ "\n Change Insetion point to Right and align to Right")

(setq Value72_73_71 '(2 0 9))
(setq AssocL '(11 10))
(Procedure)
(princ)
)

;***************************************************
(defun Procedure ()
(while (= ObjSet nil)
(setq ObjSet (ssget '((-4 . ""))))
)
(setq ObjName0 (car (entsel "\n")))
(setq i 0)
(setq time (getvar "MILLISECS"))
(repeat (sslength ObjSet)
(setq ObjName (ssname ObjSet i))
(setq Data (entget ObjName))
(cond ((= (cdr(assoc 0 Data)) "TEXT")
(TextInsP_Text ObjName Value72_73_71)
(setq Co (car AssocL))
)
( (= (cdr(assoc 0 Data)) "MTEXT")
(TextInsP_MText ObjName Value72_73_71)
(setq Co (cadr AssocL))
)
)
(setq i (1+ i))
)


(setq Data0 (entget ObjName0))
(setq Ang1 (angle '(0 0) (getvar "UCSXDIR")))
(cond ((= (cdr(assoc 0 Data0)) "TEXT")
(setq AngT (cdr(assoc 50 Data0)))
(setq Ang2 (- AngT Ang1))
(setq Co (car AssocL))
)
((= (cdr(assoc 0 Data0)) "MTEXT")
(setq Ang2 (cdr(assoc 50 Data0)))
(setq AngT (+ Ang1 Ang2))
(setq Co (cadr AssocL))
)
)
(setq Pt0 (cdr (assoc Co Data0)))
(setq Pt0_U (trans Pt0 0 1))
(setq Pt0_O (SD1862 Pt0_U Ang2))

(setq i 0)
(repeat (sslength ObjSet)
(setq Data (entget (setq ObjName (ssname ObjSet i))))
(cond ((= (cdr(assoc 0 Data)) "TEXT")(setq Co (car AssocL)))
((= (cdr(assoc 0 Data)) "MTEXT")(setq Co (cadr AssocL)))
)
(setq Pt1 (cdr (assoc Co Data)))
(setq Pt1_U (trans Pt1 0 1))
(setq Pt1_O (SD1862 Pt1_U Ang2))
(setq Delta_O (- (car Pt0_O) (car Pt1_O)))
(setq Delta_U (SD8446 (list Delta_O 0) '(0 0) AngT))
(setq Data (subst (cons Co (mapcar '+ Pt1 Delta_U))(assoc Co Data) Data))
(entmod Data)
(setq i (1+ i))
)
(setq time (/ (- (getvar "MILLISECS") time) 1000.0))
(princ (strcat "\nThoi gian thuc hien (giay) :" (rtos time)))
(princ)
)
(defun TextInsP_Text ( ObjName Value72_73_71 / Data OrgPosition NewPosition Org_11 New_11 )

(setq Data (entget ObjName))
(setq OrgPosition (cdr (assoc 10 Data)))
(setq Org_11 (cdr (assoc 11 Data))) ,0,0j
(setq Data (subst (cons 72 (car Value72_73_71)) (assoc 72 Data) Data))
(setq Data (subst (cons 73 (cadr Value72_73_71)) (assoc 73 Data) Data))
(entmod Data)

(setq NewPosition (cdr (assoc 10 (entget ObjName))))
(setq Delta (mapcar '- OrgPosition NewPosition))
(setq New_11 (mapcar '+ Org_11 Delta))
(setq Data (entget ObjName))
(setq Data (subst (cons 11 New_11) (assoc 11 Data) Data))
(entmod Data)
)
(defun TextInsP_MText ( ObjName Value72_73_71 / Data X_Old X_New Y_Old Y_New Scale Base0 W_42 Ang_50 Delta )
(setq Data (entget ObjName))
(setq InsP (cdr (assoc 10 Data)))
(setq W_42 (cdr (assoc 42 (entget ObjName))))
(setq H_43 (cdr (assoc 43 (entget ObjName))))
(setq Ang (cdr (assoc 50 Data)))
(setq AngU (angle '(0 0) (getvar "UCSXDIR")))
(setq OldIP (cdr (assoc 71 Data)))
(setq NewIP (caddr Value72_73_71))

(setq Data (subst (cons 71 NewIP) (assoc 71 Data) Data))
(entmod Data)


(setq X_Old (- (+ OldIP 2) (* (fix ( / (+ OldIP 2) 3)) 3)))
(setq X_New (- (+ NewIP 2) (* (fix ( / (+ NewIP 2) 3)) 3)))


(setq Y_Old (fix ( / (- OldIP 1) 3)))
(setq Y_New (fix ( / (- NewIP 1) 3)))

(setq IncUnit (list (- X_New X_Old)(- Y_Old Y_New )))
(setq Delta (mapcar '* IncUnit (list (* 0.5 W_42)(* 0.5 H_43))))

(setq Delta (SD8446 Delta '(0 0) Ang))

·
(setq Delta (SD1862 Delta (* -1.0 AngU)))

(setq Data (subst (cons 10 (mapcar '+ InsP Delta))(assoc 10 Data) Data))
(entmod Data)

)

(defun SD1862 (OldPt Ang / NewCs)
(setq NewCs (SD8446 '(1 0) '(0 0) Ang))
(setq NewPt (trans OldPt 0 NewCs))
(setq NewPt (list (nth 2 NewPt)(nth 0 NewPt)))
NewPt
)

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


Tiếp theo, thực hiện test so sánh :
Lần 1: với 100 text và sắp xếp bên trái :

-> gần như là ngay tức thì

Lần 2, e chơi sang làm hẳn 1000 text + Mtext đi .Lần này thì :

- > :undecided:

Vậy là tương quan,2 lisp chênh nhau về thời gian xử lý khoảng 50 lần.Tất nhiên, ngoài thực tế ít khi ta gặp 1 đoạn văn bản CAD dài như vậy, nhưng nhiều khi, 1 vấn đề đã cũ,mà vẫn có nhiều lựa chọn giải quyết.

PS :Còn đoạn code FIT + code sắp xếp Đối tượng cũng khù khoằm như vậy,tí rỗi e post típ ^^

P/S 2 : hình như 4room lại trục trặc, e post file lisp đây
Lisp

hì hì các bác cho em tham gia thử với http://www.cadviet.c...showtopic=24188
  • 0
Trăng 16 trăng tròn
Em 16 bụng ... như trăng

Hướng dẫn sử dụng diễn đàn:
Để cảm ơn hay bài viết có ích: Ấn dấu + cuối bài.
Không vừa lòng hay bài spam: Ấn dấu - cuối bài.

#11 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5678 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 20 December 2010 - 04:08 PM

Khổ quá,cái của bác nhìn ngon quá mà bác để trong VLX thì e biết mần răng.Bác thêm code test time trước vòng lặp của bác đi ^^
  • 0

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#12 Thaistreetz

Thaistreetz

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 903 Bài viết
Điểm đánh giá: 505 (tốt)

Đã gửi 20 December 2010 - 04:20 PM

Bác đệu thật.Thế mà cứ găm mãi.E vẫn dùng nó từ khi đi làm đến giờ đấy >"< ( 4 tháng rùi chứ ít ỏi j) .Thế pác post lên đi :">.
P/S : lisp trên cũng bay text khi text chọn làm mẫu không thuộc tập chọn ban đầu,n được cái tốt là Mờ tếch mờ tiếc k bị thay đổi format ^^

Hề hề, Lisp mình viết thì mình luôn sẵn lòng chia xẻ, nhưng những lisp của anh em trong cty viết thì mình chịu rùi, bọn nó chém mình lun á :undecided:
  • 0

Hình đã gửi
IN HIM, I TRUST. THE TRUST IN MY GOD


#13 18011985

18011985

    biết lệnh properties

  • Members
  • PipPipPipPip
  • 255 Bài viết
Điểm đánh giá: 61 (tàm tạm)

Đã gửi 20 December 2010 - 04:52 PM

Khổ quá,cái của bác nhìn ngon quá mà bác để trong VLX thì e biết mần răng.Bác thêm code test time trước vòng lặp của bác đi ^^

hê hê từ lúc bắt đầu dialog đến lúc kết thúc là ...... (tuỳ thuộc vào thao tác người làm).
Đây là kết quả test
Select objects: Specify opposite corner: 767 found

Select objects:

Chän vÞ trÝ c¨n chØnh:
Thoi gian thuc hien (giay) :4.9690

Được cái là chỉ phải ấn nút thui hì hì. Phạm vi của lsp đối với toạ độ World và đối tượng là text và Mtext còn text thuộc tính đang ở ngoài luồng hì hì hì.
Select objects: Specify opposite corner: 17641 found

Select objects:

Chän vÞ trÝ c¨n chØnh:
Thoi gian thuc hien (giay) :16.3750

Hix mất lâu thật.
  • 1
Trăng 16 trăng tròn
Em 16 bụng ... như trăng

Hướng dẫn sử dụng diễn đàn:
Để cảm ơn hay bài viết có ích: Ấn dấu + cuối bài.
Không vừa lòng hay bài spam: Ấn dấu - cuối bài.

#14 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5678 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 20 December 2010 - 05:15 PM

Chẹp.Thế là nhanh lắm rồi.Kể bác test đc chỉ thao tác lặp thôi thì hay,vì lúc hiện dialog,thao tác ảnh hưởng nhiều đến kquả quá mà :undecided: Con số 17641 obj cũng đáng nể thật ^^.Máy e cùi,k biết chọn bao lâu mới đc 17k đối tượng,bác nhân tiện test luôn thử hộ e nhé :leluoi:
  • 0

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#15 18011985

18011985

    biết lệnh properties

  • Members
  • PipPipPipPip
  • 255 Bài viết
Điểm đánh giá: 61 (tàm tạm)

Đã gửi 20 December 2010 - 06:10 PM

Chẹp.Thế là nhanh lắm rồi.Kể bác test đc chỉ thao tác lặp thôi thì hay,vì lúc hiện dialog,thao tác ảnh hưởng nhiều đến kquả quá mà :undecided: Con số 17641 obj cũng đáng nể thật ^^.Máy e cùi,k biết chọn bao lâu mới đc 17k đối tượng,bác nhân tiện test luôn thử hộ e nhé :leluoi:

Của bác đây máy mình cũng tàm tạm. Thiết kế thì ok không vấn đề gì.
Command:  TRAI
Change Insetion point to Left and align to Left
Select objects: Specify opposite corner: 42368 found

Select objects:


Thoi gian thuc hien (giay) :153.6720

Đây là của mình
Command: ik

Select objects: Specify opposite corner: 42368 found

Select objects:

Chän vÞ trÝ c¨n chØnh:
Thoi gian thuc hien (giay) :30.7030

Chọn đối tượng trước cho bạn sau đó thực hiện lệnh thì kết quả như sau:
Command: trai

Change Insetion point to Left and align to Left42368 found


Thoi gian thuc hien (giay) :82.4370

  • 0
Trăng 16 trăng tròn
Em 16 bụng ... như trăng

Hướng dẫn sử dụng diễn đàn:
Để cảm ơn hay bài viết có ích: Ấn dấu + cuối bài.
Không vừa lòng hay bài spam: Ấn dấu - cuối bài.

#16 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5678 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 20 December 2010 - 09:20 PM

Vậy là nhanh gấp mấy lần rồi.Bác share code hoặc hướng đi :">
  • 0

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#17 VUVUZELA

VUVUZELA

    biết lệnh chamfer

  • Members
  • PipPipPipPip
  • 210 Bài viết
Điểm đánh giá: 97 (tàm tạm)

Đã gửi 20 December 2010 - 09:32 PM

Vậy là nhanh gấp mấy lần rồi.Bác share code hoặc hướng đi :">


Code đây bạn ơi
Chịu khó lên mạng tìm sẽ thấy hết

http://www.planetsou...s...3&lngWId=13

Cái này chuyên trị về TEXT (có từ hồi R14)
:undecided:
  • 0

Hệ thống Liên Kết, Thiết Kế Tự Động

ttps://www.facebook...etThietKeTuDong


#18 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5678 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 20 December 2010 - 10:18 PM

Ơ ơ..Liệu cái này với cái trên của pác 1985 có giống nhau k hè ^^
  • 0

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#19 hdg2318

hdg2318

    biết lệnh mirror

  • Members
  • PipPipPip
  • 158 Bài viết
Điểm đánh giá: 31 (tàm tạm)

Đã gửi 20 December 2010 - 11:31 PM

hehe, đã down được cái lisp của bạn ketxu , đã test, công nhận chạy nhanh thật, nhưng ko biết có cái giãn dòng như của bác Thái ko?? (kể mà có thì tốt quá :undecided: )
còn cái lisp của VuVuZeLa, mình chưa có thời gian test, nhìn qua cái ScreenShoot trên trang chủ thấy có vẻ hơi loằng ngoằng, ko biết lúc dùng sẽ ra sao.

Thanks anyway!!! :leluoi:
  • 0

Có 2 cách để nhìn đời:
1 là : coi như chẳng có gì là huyền diệu
2 là : coi như mọi điều đều huyền diệu


Click here


#20 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5678 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 20 December 2010 - 11:41 PM

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

Command: Specify opposite corner:
Command: trai
41180 found

Select Reference Object:
Thoi gian thuc hien (giay) :64.959


  • 3

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC