Đến nội dung


Hình ảnh
* * * - - 2 Bình chọn

Viết Lisp theo yêu cầu


  • Chủ đề bị khóa Chủ đề bị khóa
2780 replies to this topic

#881 Sony2007

Sony2007

    biết lệnh copy

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

Đã gửi 16 July 2008 - 10:37 AM

bạn up file ví dụ của bạn lên diễn đàn xem?

File của em upload đây
http://www.cadviet.c...up_dien_dan.dwg
em ở file ra, sau đó load file lsp. thực hiện lệnh cong, chọn hàng đầu tiên enter, chọn hàng thứ hai enter. Và kết quả nằm trùng với hàng thứ nhất. Bác xem em phạm lỗi nào, chỉ giúp em với. Cám ơn bác
  • 0

#882 Nguyen Hoanh

Nguyen Hoanh

    biết lệnh adcenter

  • Moderator
  • PipPipPipPipPipPipPip
  • 4105 Bài viết
Điểm đánh giá: 4495 (đỉnh cao)

Đã gửi 16 July 2008 - 11:20 AM

File của em upload đây

em ở file ra, sau đó load file lsp. thực hiện lệnh cong, chọn hàng đầu tiên enter, chọn hàng thứ hai enter. Và kết quả nằm trùng với hàng thứ nhất. Bác xem em phạm lỗi nào, chỉ giúp em với. Cám ơn bác

Lỗi là do file của bạn, hàng trên điểm chèn nằm phía dưới, hàng dưới điểm chèn lại nằm lên trên. Vì vậy, kết quả là một text mới có hàng xác định không chuẩn.

Đây là lisp đã sửa cho trường hợp riêng của bạn:

(defun c:cong () (xulytext +))
(defun c:tru () (xulytext -))
(defun c:nhan () (xulytext *))
(defun c:chia () (xulytext /))

(defun xulytext (ham / lst1 lst2 sst1 sst2 ykq)
(princ "\nNhap vao hang text dau tien: ")
(setq sst1 (ssget '((0 . "TEXT"))))
(princ "\nNhap vao hang text thu hai: ")
(setq sst2 (ssget '((0 . "TEXT"))))

(if (/= (sslength sst1) (sslength sst2))
(alert
"\nHai tap chon co so doi tuong khong bang nhau!\nHay chon lai!"
)
(progn
(setq
lst1 (mapcar 'entget (ss2ent sst1))
lst2 (mapcar 'entget (ss2ent sst2))
Ykq (cadr (getpoint "\nVao toa do y cua hang ket qua: "))
lsterr ""
)
(mapcar
'entmake
(mapcar '(lambda (t1 t2 / tt pp gt)
(setq gt (vl-catch-all-apply
'ham
(list (atof (cdr (assoc 1 t1)))
(atof (cdr (assoc 1 t2)))
)
)
)
(if (vl-catch-all-error-p gt)
(setq lsterr (strcat lsterr
"- "
(vl-catch-all-error-message gt)
"\n"
)
gt "#"
)
(setq gt (vl-string-right-trim
"."
(vl-string-right-trim "0" (rtos gt))
)
)
)
(setq
p (cdr (assoc 10 t1))
pp (list 11 (car p) Ykq (caddr p))
tt (subst (cons 1 gt) (assoc 1 t1) t1)
tt (subst pp (assoc 11 t1) tt)
)
)
lst1
lst2
)
)
(if (/= lsterr "")
(alert
(strcat "Trong qua trinh tinh toan, co cac loi sau:\n"
lsterr
)
)
)
)
)
)
(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)
)

  • 2

#883 Sony2007

Sony2007

    biết lệnh copy

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

Đã gửi 16 July 2008 - 11:37 AM

Lỗi là do file của bạn, hàng trên điểm chèn nằm phía dưới, hàng dưới điểm chèn lại nằm lên trên. Vì vậy, kết quả là một text mới có hàng xác định không chuẩn.


Cám ơn bác nhé. Bây giờ có thể đặt kết quả theo tọa độ Y tùy ý rồi. Cám ơn bác Hoành nhiều.
  • 0

#884 kien_long

kien_long

    biết pan

  • Members
  • Pip
  • 8 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 16 July 2008 - 06:22 PM

Bạn hãy upload 1 file dwg ví dụ đi.
2 điều kiện đầu tiên thì tôi hiểu.
Đến điều kiện thứ 3, vẽ các line có chiều dài 500 đơn vị và chèn vào các điểm đó thì chiều hướng các line này thế nào?


Nó đây ah !
http://www.cadviet.com/upfiles/up.dwg
Cảm ơn a Nguyễn Hoành nhé !
:rolleyes:
  • 0

#885 Nguyen Hoanh

Nguyen Hoanh

    biết lệnh adcenter

  • Moderator
  • PipPipPipPipPipPipPip
  • 4105 Bài viết
Điểm đánh giá: 4495 (đỉnh cao)

Đã gửi 16 July 2008 - 08:39 PM

Nó đây ah !
http://www.cadviet.com/upfiles/up.dwg
Cảm ơn a Nguyễn Hoành nhé !
:rolleyes:


Tên lệnh là DBL (Devide by Line)

(defun c:DBL( / p1 p2 pgx pgy pgz)
(princ "\ndevide by line\nFree lisp from cadviet.com!")
(setq p1 (trans (getpoint "\nDiem dau: ") 1 0)
p2 (trans (getpoint p1 "\nDiem cuoi: ") 1 0)
sl (cond
((setq tmp (getint "\nSo lan:")) tmp)
(t 2)
)
x1 (car p1)
y1 (cadr p1)
x2 (car p2)
y2 (cadr p2)
pgx (/ (+ (car p1) (car p2)) 2.0)
pgy (/ (+ (cadr p1) (cadr p2)) 2.0)
pgz (/ (+ (caddr p1) (caddr p2)) 2.0)
tm (/ 1.0 sl)
index -1
g (+ (angle p1 p2) (/ pi 2.0))
)
(repeat (1+ sl)
(setq index (1+ index)
tht (* tm index)
xht (+ (* x1 tht) (* x2 (- 1.0 tht)))
yht (+ (* y1 tht) (* y2 (- 1.0 tht)))
p (list xht yht 0.0)
p1 (polar p g 250.0)
p2 (polar p g -250.0)
)
(entmake (list (cons 0 "LINE") (cons 10 p1)(cons 11 p2)))
)
(princ)
)

  • 0

#886 kien_long

kien_long

    biết pan

  • Members
  • Pip
  • 8 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 16 July 2008 - 11:12 PM

Tên lệnh là DBL (Devide by Line)


(defun c:DBL( / p1 p2 pgx pgy pgz)
(princ "\ndevide by line\nFree lisp from cadviet.com!")
(setq p1 (trans (getpoint "\nDiem dau: ") 1 0)
p2 (trans (getpoint p1 "\nDiem cuoi: ") 1 0)
sl (cond
((setq tmp (getint "\nSo lan:")) tmp)
(t 2)
)
x1 (car p1)
y1 (cadr p1)
x2 (car p2)
y2 (cadr p2)
pgx (/ (+ (car p1) (car p2)) 2.0)
pgy (/ (+ (cadr p1) (cadr p2)) 2.0)
pgz (/ (+ (caddr p1) (caddr p2)) 2.0)
tm (/ 1.0 sl)
index -1
g (+ (angle p1 p2) (/ pi 2.0))
)
(repeat (1+ sl)
(setq index (1+ index)
tht (* tm index)
xht (+ (* x1 tht) (* x2 (- 1.0 tht)))
yht (+ (* y1 tht) (* y2 (- 1.0 tht)))
p (list xht yht 0.0)
p1 (polar p g 250.0)
p2 (polar p g -250.0)
)
(entmake (list (cons 0 "LINE") (cons 10 p1)(cons 11 p2)))
)
(princ)
)


Cảm ơn a Nguyễn Hoành rất nhiều !
Chúc tất cả ae tên CV mạnh khoẻ nhé
  • 0

#887 duy782006

duy782006

    PHẠM QUỐC DUY

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 2155 Bài viết
Điểm đánh giá: 1360 (rất tốt)

Đã gửi 17 July 2008 - 09:40 AM

Nhờ bác Nguyenhoanh giúp cho cái lisp sau với:

-Hỏi chọn đối tượng:
-Hỏi tỉ lệ phóng: chấp nhận cả số <0 nếu nhận cả "a/b" và "a*b" thì càng hay.
*Thay đổi tất cả Lineltype Scale trong tập hợp chọn lên một tỉ bằng tỉ lệ phóng.
*Bác có thể không dùng các hàm VL- được không.
Cám ơn!
  • 0

Cứ ngỡ trần gian là cõi thật.Cho nên tất bật đến bây giờ.
Tạo hộp thoại bằng lisp My blog QUY ĐỊNH ĐẶT TÊN TOPIC TRONG CHUYÊN MỤC LISPD http://ktsduy.wordpress.com/
Để cám ơn chỉ cần nhấn rep_up.png
(Là nhấn vào nút đó phía bài viết của người ta í chứ đừng có nhè cái hình này mà nhấn miết đi nha :-D


#888 longines

longines

    Chưa sử dụng CAD

  • Members
  • Pip
  • 1 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 17 July 2008 - 09:46 AM

Các bác ơi!Viết giúp em lisp cái!Trong quá trình vẽ em có mấy vấn đề khá bất tiện mà không xử lý được!các bác giúp em nhé!
1.Khi sử dụng lệnh copy giá trị của Text để gán qua một đối tượng text khác_lệnh này là lisp không biết em sưu tầm được ở đâu thì em thấy rằng đối với các đối tượng là Group của các Text thì khi mình thực hiện lệnh sẽ bị gán giá trị cho tất cả các Text có trong nhóm rất bất tiện. Các bác giúp em viết lisp mà chỉ gán giá trị cho Text trong Group nhưng chỉ là Text mà mình chon không làm ảnh hưởng đến giá trị các Text khác. Lệnh gán giá trị đó:
;----------------------------------------------------------------------------------------
(defun Copytext ()
(setvar "Cmdecho" 0)
(prompt "\n<< Select Data >>")
(setq sstcong (entsel))
(setq sdk (entget (car sstcong)))
(if (= (cdr (assoc 0 sdk)) "TEXT")
(setq tckl (cdr (assoc 1 sdk)))
(prompt "\n<< ERROR : Nothing Text Selected. >>")
)
(prompt "\n<< Select Text To Copy. >>")
(setq tcong (ssget))
(setq sslen (sslength tcong))
(while (> sslen 0)
(setq stc (entget (ssname tcong (setq sslen (1- sslen)))))
(if (= (cdr (assoc 0 stc)) "TEXT")
(entmod (subst (cons 1 tckl) (assoc 1 Stc) Stc))
(prompt "\n<< ERROR : Nothing Text Selected. >>")
)
)
(setvar "Cmdecho" 1)
)
;;*******************************
;(DEFUN C:Copytext ()(vmon)(Copytext))
(DEFUN C:CT ()(vmon)(Copytext))
(princ "\n CopyText Loaded . Start with CT")
(princ)
;----------------------------------------------------------------------------------------
2.Khi sử dụng lệnh copy giá trị của Text có bước nhảy là 1 hoặc copy Text từ A ->B...dùng cho việc vẽ trục...Thì có vấn đề là không thực hiện được với đối tượng là Attribute, Bác nào giúp em sửa Lisp dưới đây để dùng cho cả Block Attribute thì tốt quá:
*********************************************************************
Copy Intelligent
;*********************************************************************
(defun ketthuc ()
(setvar "cmdecho" luuecho)
(setq *error* luu
luu nil
luuecho nil
);setq
(princ)
)
;*********************************************************************
(defun modau ()
(setq luu *error
luuecho (getvar "cmdecho")
*error (ketthuc)
)
)
;*********************************************************************
(defun xulytext (text / kytu ma sokt luusokt lui )
(setq kytu (substr text (strlen text))
ma (ascii kytu)
sokt (read kytu)
lui 1
)
(if (numberp sokt)
(progn
(setq luusokt (1+ sokt))
(if (and (numberp sokt)
(> (strlen text) 1)
)
(progn
(setq kytu (substr text (1- (strlen text)))
sokt (read kytu)
)
(if (numberp sokt)
(setq luusokt (1+ sokt)
lui 2

)
)
);progn
)
(if (= luusokt 100) (setq luusokt 0))
(setq kytu (rtos luusokt 2 0)

text (strcat (substr text 1 (- (strlen text) lui)) kytu)
)
);progn
(if (or (= kytu "z")
(= kytu "Z")
)
(setq text (strcat text "0")
textxl "0"
)
(setq ma (1+ ma)
text (strcat (substr text 1 (1- (strlen text))) (chr ma))
)
);if
);if
)
;*********************************************************************
(defun doitext(tendoituong / chuoi doituong thoat tam dsach kieu text vitri10 vitri11 dem canle)
;Neu doi tuong la text thi tiep tuc
(setq doituong (entget tendoituong)
kieu (cdr (assoc 0 doituong))
canle (cdr (assoc 72 doituong))
)
(if (or (= kieu "TEXT")
(= kieu "MTEXT")
)
(progn
(setq textxl (xulytext textxl)
text (cons 1 textxl)
vitri10 (cdr (assoc 10 doituong))
vitri10 (list (+ (car vitri10) (car vitrilech)) (+ (nth 1 vitri10) (nth 1 vitrilech)))
vitri10 (cons 10 vitri10)
vitri11 (cdr (assoc 11 doituong))
vitri11 (list (+ (car vitri11) (car vitrilech)) (+ (nth 1 vitri11) (nth 1 vitrilech)))
vitri11 (cons 11 vitri11)
dem 0
dsach nil
)
(foreach tam doituong
(cond
((= (car tam) 1) (setq dsach (append dsach (list text))))
((= (car tam) 10) (setq dsach (append dsach (list vitri10))))
((= (car tam) 11) (setq dsach (append dsach (list vitri11))))
((setq dsach (append dsach (list tam))))
)
)
(entmake dsach)
);progn
);if
);
;*********************************************************************
;sao doi tuong cu sang vi tri moi

(defun copy_dt (tendoituong )
(command "copy" tendoituong "" goc toi )
);defun

;*********************************************************************
(defun c:CI ( / cumdt dodai thoat dem ten doituong textxl dem goc toi)
; Khoi dau cua chuong trinh
(princ "\nCopy Inteligent...\n")
(setq luuecho (getvar "cmdecho")
luu *error*
*error* ketthuc
cumdt (ssget)
dodai (sslength cumdt)
goc (getpoint "\nSelect base point:")
thoat nil
dem 0
textxl nil
);
(setvar "cmdecho" 0)
; Loc ra duoc ong text de xu ly
(while (and (= thoat nil)
(< dem dodai)
)
(setq ten (ssname cumdt dem)
dem (1+ dem)
doituong (entget ten)
kieu (cdr (assoc 0 doituong))
)

(if (or (= kieu "TEXT")
(= kieu "MTEXT")
)
(setq thoat T
textxl (cdr (assoc 1 doituong))
)
)
);
(while T
(setq toi (getpoint "\nSelect next point: " goc)
vitrilech (list (- (car toi) (car goc)) (- (nth 1 toi) (nth 1 goc)))
dem 0
)
(while (< dem dodai)
(setq ten (ssname cumdt dem)
dem (1+ dem)
doituong (entget ten)
kieu (cdr (assoc 0 doituong))
)

(if (or (= kieu "TEXT")
(= kieu "MTEXT")
)
(doitext ten)
(copy_dt ten)

);if
)
);while
(ketthuc)
);defun
(princ "Type \"DG\" to start")
;Note: bien toan cuc: textxl vitrilech
*******************************************************
3.Bác nào có lisp có tính năng như lệnh WIPEOUT trong Cad mà có thể chọn đối tượng là Circle hoặc các đối tượng khác không bất tiện như lệnh WIPEOUT phải thực hiện vẽ lại một polyline khác:
Các bác giúp em nhé!!!thanks các bác nhiều!!!hì...
  • 0

#889 ssg

ssg

    biết lệnh adcenter

  • Vip
  • PipPipPipPipPipPipPip
  • 1228 Bài viết
Điểm đánh giá: 1087 (rất tốt)

Đã gửi 17 July 2008 - 10:39 AM

Nhờ bác Nguyenhoanh giúp cho cái lisp sau với:

-Hỏi chọn đối tượng:
-Hỏi tỉ lệ phóng: chấp nhận cả số <0 nếu nhận cả "a/b" và "a*b" thì càng hay.
*Thay đổi tất cả Lineltype Scale trong tập hợp chọn lên một tỉ bằng tỉ lệ phóng.
*Bác có thể không dùng các hàm VL- được không.
Cám ơn!

1- Cái này đơn giản mà, bạn chỉ dùng lệnh "change" là OK. Nó "chơi" luôn cả ss:
(setq
ss (ssget)
k (getreal "\nHe so ty le:")
)
(command "change" ss "" "p" "s" k "")

2- Muốn kiểu a/b, a*b... thì bạn dùng (c:cal S), S là string dạng "a/b", "a*b"...
Lưu ý, trước khi dùng c:cal phải gọi: (if (not geomcal) (arxload "geomcal"))

3- LTscale không chấp nhận số <0, chỗ này không hiểu ý bạn!
  • 0

#890 truongliem0902

truongliem0902

    Chưa sử dụng CAD

  • Members
  • Pip
  • 2 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 17 July 2008 - 11:07 AM

Bác Hoành ơi ! Bác viết giùm em một lisp như sau nha :
Em muốn cập nhật số nhà. em có sử dụng lệnh "CT" ( viết số liên tục ) nhưng lệnh đó chỉ áp dụng cho những số ở mặt tiền. Còn trong hẻm thì lệnh đó không sử dụng được ( Vd : 194/37, 194/37/4 ... ). Bác hãy chỉnh lại giùm em nha. Mong hồi âm của Bác.
  • 0

#891 duy782006

duy782006

    PHẠM QUỐC DUY

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 2155 Bài viết
Điểm đánh giá: 1360 (rất tốt)

Đã gửi 17 July 2008 - 11:12 AM

1- Cái này đơn giản mà, bạn chỉ dùng lệnh "change" là OK. Nó "chơi" luôn cả ss:
(setq
ss (ssget)
k (getreal "\nHe so ty le:")
)
(command "change" ss "" "p" "s" k "")

2- Muốn kiểu a/b, a*b... thì bạn dùng (c:cal S), S là string dạng "a/b", "a*b"...
Lưu ý, trước khi dùng c:cal phải gọi: (if (not geomcal) (arxload "geomcal"))

3- LTscale không chấp nhận số <0, chỗ này không hiểu ý bạn!


Vấn đề thế này:
-Khi làm quy hoạch thì mình nhận được file địa hình của các bác làm trắc địa trong đó có nhiều linetype scale khác nhau thể hiện phù hợp với tỉ lệ vẽ của các bác ấy thường là 1/200, 1/500.
-Khi Scale bản vẽ đó lên (theo thói quen về tỉ lệ để dể làm) thì các đường nét thể hiện với tỉ lệ không đúng với tương quan chung nửa . ví dụ đường taluy xẻ xít lại hơn.
-Lips phải làm việc đọc linetypescale của từng đối tượng và nhân với hệ số mình yêu cầu rồi chỉnh lại.
-Hệ số <0 nghĩa là thế này: ví dụ linetypescale đang là 2 hệ số điều chỉnh là 0,5 thì linetypescale sẽ thành 1 vậy mà.
  • 0

Cứ ngỡ trần gian là cõi thật.Cho nên tất bật đến bây giờ.
Tạo hộp thoại bằng lisp My blog QUY ĐỊNH ĐẶT TÊN TOPIC TRONG CHUYÊN MỤC LISPD http://ktsduy.wordpress.com/
Để cám ơn chỉ cần nhấn rep_up.png
(Là nhấn vào nút đó phía bài viết của người ta í chứ đừng có nhè cái hình này mà nhấn miết đi nha :-D


#892 cuongtk2

cuongtk2

    biết vẽ ellipse

  • Members
  • PipPip
  • 59 Bài viết
Điểm đánh giá: 20 (tàm tạm)

Đã gửi 17 July 2008 - 11:34 AM

Vậy đâu có <0 mà chỉ < 1 thôi. Phải kiểm hàng trước khi xuất xưởng chứ.
  • 1

#893 vinataba

vinataba

    biết vẽ circle

  • Members
  • PipPip
  • 30 Bài viết
Điểm đánh giá: 3 (bình thường)

Đã gửi 17 July 2008 - 01:20 PM

*******************************************************
3.Bác nào có lisp có tính năng như lệnh WIPEOUT trong Cad mà có thể chọn đối tượng là Circle hoặc các đối tượng khác không bất tiện như lệnh WIPEOUT phải thực hiện vẽ lại một polyline khác:
Các bác giúp em nhé!!!thanks các bác nhiều!!!hì...


mình cũng đang sử dụng cái lisp này nhung chẳng hiểu sao cứ đến 100 thì nó lại thành 11. bác nào sửa thì xem giúp luôn hộ cái lỗi đấy.
  • 0

#894 thanhbinh166

thanhbinh166

    biết pan

  • Members
  • Pip
  • 6 Bài viết
Điểm đánh giá: 3 (bình thường)

Đã gửi 17 July 2008 - 01:26 PM

Nhờ bác Hoành viết giúp lisp theo ý tưởng như thế này:
1 - offset đường 3d polyline tương tự như offset đường polyline.
Vì 3d polyline sẽ có 3 phương X,Y,Z nên khi offset sẽ hỏi xem offset theo phương X=??; Y=??; Z=??
Thank
  • 0

#895 ssg

ssg

    biết lệnh adcenter

  • Vip
  • PipPipPipPipPipPipPip
  • 1228 Bài viết
Điểm đánh giá: 1087 (rất tốt)

Đã gửi 17 July 2008 - 02:04 PM

Vấn đề thế này:
-Khi làm quy hoạch thì mình nhận được file địa hình của các bác làm trắc địa trong đó có nhiều linetype scale khác nhau thể hiện phù hợp với tỉ lệ vẽ của các bác ấy thường là 1/200, 1/500.
-Khi Scale bản vẽ đó lên (theo thói quen về tỉ lệ để dể làm) thì các đường nét thể hiện với tỉ lệ không đúng với tương quan chung nửa . ví dụ đường taluy xẻ xít lại hơn.
-Lips phải làm việc đọc linetypescale của từng đối tượng và nhân với hệ số mình yêu cầu rồi chỉnh lại.
-Hệ số <0 nghĩa là thế này: ví dụ linetypescale đang là 2 hệ số điều chỉnh là 0,5 thì linetypescale sẽ thành 1 vậy mà.

Hiểu rồi, nếu vậy thì bạn dùng entmod cho từng entity trong ss. Mã DXF của LTScale là 48. Nếu LTScale = 1 nó sẽ không hiện diện trong data nhận được từ entget. Tiến trình chung như sau:
1- Ssget
2- Nhập hệ số điều chỉnh k. Dùng C:CAL tính các dạng a/b, a*b... như đã nói ở bài trên
3- Dùng vòng lặp xử lý từng "chú". Trong vòng lặp:
- Dùng entget lấy data -> rút ra k1 = LTScale hiện tại của đối tượng
- Nếu data không chứa mã DXF 48 -> k1 =1
- k2 = k*k1
- Entmod
Hy vọng là bạn tự làm được?
  • 0

#896 duy782006

duy782006

    PHẠM QUỐC DUY

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 2155 Bài viết
Điểm đánh giá: 1360 (rất tốt)

Đã gửi 18 July 2008 - 07:53 AM

Hiểu rồi, nếu vậy thì bạn dùng entmod cho từng entity trong ss. Mã DXF của LTScale là 48. Nếu LTScale = 1 nó sẽ không hiện diện trong data nhận được từ entget. Tiến trình chung như sau:
1- Ssget
2- Nhập hệ số điều chỉnh k. Dùng C:CAL tính các dạng a/b, a*b... như đã nói ở bài trên
3- Dùng vòng lặp xử lý từng "chú". Trong vòng lặp:
- Dùng entget lấy data -> rút ra k1 = LTScale hiện tại của đối tượng
- Nếu data không chứa mã DXF 48 -> k1 =1
- k2 = k*k1
- Entmod
Hy vọng là bạn tự làm được?

Cám ơn bác! Đã làm dược rồi. Sẳn đây gửi lên bà con ai có nhu cầu giống mình thì dùng.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:sclt (/ c e ss dtsc tlsc dtsckt)
(setq tlsc (getreal "\nTi le phong : "))
(prompt "\nChon doi tuong muon chinh ltscale.")
(setq ss (ssget))
(setq c 0)
(setq N (sslength ss))
(while (< c N)
(setq e (ssname ss c))
(setq e (entget e))
(setq dtsckt (cdr (assoc 48 e)))
(if (Null tlsc)
(setq dtsc 1)
)
(IF (/= NIL dtsckt) (PROGN

(setq dtsc (* (cdr (assoc 48 e)) tlsc))
)
)

(setq e (subst (cons 48 dtsc) (assoc 48 e) e))
(entmod e)
(setq c (1+ c))
)
(Prin I)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

Hỏi bác SSG tí:
Nếu không có phần màu đỏ thì chạy nhanh nhưng nếu gặp đối tượng có linetypescale bằng 1 thì xuất hiện lổi và không chạy tiếp được. Còn có như hiện giờ thì chạy ổn nhưng hơi chậm bác có cách gì hay hơn không thì giúp cải tạo lại với. cám ơn
  • 0

Cứ ngỡ trần gian là cõi thật.Cho nên tất bật đến bây giờ.
Tạo hộp thoại bằng lisp My blog QUY ĐỊNH ĐẶT TÊN TOPIC TRONG CHUYÊN MỤC LISPD http://ktsduy.wordpress.com/
Để cám ơn chỉ cần nhấn rep_up.png
(Là nhấn vào nút đó phía bài viết của người ta í chứ đừng có nhè cái hình này mà nhấn miết đi nha :-D


#897 Snowman

Snowman

    biết lệnh mirror

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

Đã gửi 18 July 2008 - 12:49 PM

Bác nên đưa phần này ra ngoài vòng lặp (dưới dòng nhập tlsc: để giá trị mặc định cho tlsc = 1)

(if (Null tlsc)
(setq dtsc 1)
)
)

Và sửa lại thành:
(if (Null tlsc)
(setq tlsc 1)
)


Đồng thời sửa lại đoạn:
(IF (/= NIL dtsckt) (PROGN
(setq dtsc (* (cdr (assoc 48 e)) tlsc))
)
)
thành :
(IF (/= NIL dtsckt)
(setq dtsc (* (cdr (assoc 48 e)) tlsc))
(setq dtsc 1) ; Nếu dtsckt = nil thì gán dtsc = 1)

  • 1

. - ' * ' - .. - ... "Sống trong đời sống cần có một tấm lòng..." . - ' * ' - .. -
-----------------------------------------------------------------------------------

Hình đã gửi Hình đã gửi


#898 Snowman

Snowman

    biết lệnh mirror

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

Đã gửi 18 July 2008 - 12:54 PM

Bác nên đưa phần này ra ngoài vòng lặp (dưới dòng nhập tlsc: để giá trị mặc định cho tlsc = 1)

(if (Null tlsc)
(setq dtsc 1)
)
)

Và sửa lại thành:
(if (Null tlsc)
(setq tlsc 1)
)


Đồng thời sửa lại đoạn:
(IF (/= NIL dtsckt) (PROGN
(setq dtsc (* (cdr (assoc 48 e)) tlsc))
)
)
thành :
(IF (/= NIL dtsckt)
(setq dtsc (* (cdr (assoc 48 e)) tlsc))
(setq dtsc 1) ; Nếu dtsckt = nil thì gán dtsc = 1)


Mạng lại lỗi rồi ... các Mod thông cảm nhé
  • 0

. - ' * ' - .. - ... "Sống trong đời sống cần có một tấm lòng..." . - ' * ' - .. -
-----------------------------------------------------------------------------------

Hình đã gửi Hình đã gửi


#899 kts.ngocquan

kts.ngocquan

    biết vẽ ellipse

  • Members
  • PipPip
  • 59 Bài viết
Điểm đánh giá: 36 (tàm tạm)

Đã gửi 19 July 2008 - 12:31 AM

Bác nên đưa phần này ra ngoài vòng lặp (dưới dòng nhập tlsc: để giá trị mặc định cho tlsc = 1)

(if (Null tlsc)
(setq dtsc 1)
)
)

Và sửa lại thành:
(if (Null tlsc)
(setq tlsc 1)
)


Đồng thời sửa lại đoạn:
(IF (/= NIL dtsckt) (PROGN
(setq dtsc (* (cdr (assoc 48 e)) tlsc))
)
)
thành :
(IF (/= NIL dtsckt)
(setq dtsc (* (cdr (assoc 48 e)) tlsc))
(setq dtsc 1) ; Nếu dtsckt = nil thì gán dtsc = 1)


Mạng lại lỗi rồi ... các Mod thông cảm nhé

Ae trên diễn đàn có lisp có tính năng như lệnh WIPEOUT trong Cad mà có thể chọn đối tượng là Block ko thì cho tôi xin.
Nếu ko có lisp viết sẵn thì nhờ ae trên diễn đàn viết cho tôi nhé .
Theo tôi cái này rất hữu ích cho ae dùng CAD
  • 0

#900 ssg

ssg

    biết lệnh adcenter

  • Vip
  • PipPipPipPipPipPipPip
  • 1228 Bài viết
Điểm đánh giá: 1087 (rất tốt)

Đã gửi 19 July 2008 - 08:23 AM

Hỏi bác SSG tí:
Nếu không có phần màu đỏ thì chạy nhanh nhưng nếu gặp đối tượng có linetypescale bằng 1 thì xuất hiện lổi và không chạy tiếp được. Còn có như hiện giờ thì chạy ổn nhưng hơi chậm bác có cách gì hay hơn không thì giúp cải tạo lại với. cám ơn

Chương trình như hiện tại của bạn không lỗi khi LTSC = 1, nhưng nó không nhân với "Tỷ lệ phóng" như ý bạn muốn.
Bạn thử với code này xem. Mình đã thử, kết quả đúng trong mọi trường hợp. Còn về tốc độ thì... không biết! Mình đã cố tinh giản code đến mức thấp nhất có thể.
Nói chung, trong các vòng lặp phải xử lý một số lượng lớn đối tượng, các lưu ý sau sẽ làm chương trình chạy nhanh hơn:
- Giảm số lượng biến phải sử dụng
- Giảm số lượng thao tác mà chương trình phải làm trong vòng lặp (cái nào có thể thì nên đưa nó ra ngoài vòng lặp)
- Thay các phép tính phức tạp bằng các phép tính đơn giản hơn
- Nếu có thể, "chơi" luôn cả ss là nhanh nhất. Chỉ xử lý từng entity trong trường hợp bắt buộc.
(defun C:SLT( / k ss e d k1)
(setq
k (getreal "\nTi le phong: ")
ss (ssget)
)
(while (setq e (ssname ss 0))
(setq d (entget e))
(if (setq k1 (cdr (assoc 48 d)))
(setq d (subst (cons 48 (* k k1)) (assoc 48 d) d))
(setq d (append d (list (cons 48 k))))
)
(entmod d)
(ssdel e ss)
)
(princ)
)

  • 3