Jump to content
InfoFile
Tác giả: 18011985
Bài viết gốc: 94498
Tên lệnh: a1
Viết lisp theo yêu cầu [phần 2]

Chào bạn Phamthanhbinh,
Trước hết cảm ơn bạn đã góp ý, sau đây mình giải thích đoạn code của mình để bạn hiểu hơn.
Đoạn code
(progn
(initget "tyleMCD tyleMCN")
(setq tyleMCD (getreal (strcat "\nMCD<1/"(rtos tyleMCD0 2 0)">/MCN(1/"(rtos tyleMCN 2 0)"): ")))
(if (or (= tyleMCD "MCD") (= tyleMCD "mcd") (= tyleMCD "tyleMCD") (= tyleMCD "tylemcd")
(= tyleMCD "MCN") (= tyleMCD "mcn") (= tyleMCD "tyleMCN") (=...
>>

Chào bạn Phamthanhbinh,
Trước hết cảm ơn bạn đã góp ý, sau đây mình giải thích đoạn code của mình để bạn hiểu hơn.
Đoạn code
(progn
(initget "tyleMCD tyleMCN")
(setq tyleMCD (getreal (strcat "\nMCD<1/"(rtos tyleMCD0 2 0)">/MCN(1/"(rtos tyleMCN 2 0)"): ")))
(if (or (= tyleMCD "MCD") (= tyleMCD "mcd") (= tyleMCD "tyleMCD") (= tyleMCD "tylemcd")
(= tyleMCD "MCN") (= tyleMCD "mcn") (= tyleMCD "tyleMCN") (= tyleMCD "tylemcn") (= tyleMCD ""))
(setq Test 1)
(setq tyleMCD0 tyleMCD)
)
Đoạn này có ý nghĩa, khi nhập giá trị là real thì (setq tyleMCD0 tyleMCD) và khi nhập giá trị là String thì nhảy đến đoạn code nhận dạng string đằng sau
(if (or (= tyleMCD "MCD") (= tyleMCD "mcd") (= tyleMCD "tyleMCD") (= tyleMCD "tylemcd"))
(progn
(setq tyleMCD (getreal (strcat "\nMCD(1/"(rtos tyleMCD0 2 0)"): ")))
(setq tyleMCD0 tyleMCD)
); End progn (if)
); End if
(if (or (= tyleMCD "MCN") (= tyleMCD "mcn") (= tyleMCD "tyleMCN") (= tyleMCD "tylemcn"))
(progn
(setq tyleMCN (getreal (strcat "\nMCN(1/"(rtos tyleMCN0 2 0)"): ")))
(setq tyleMCN0 tyleMCN)
); End progn (if)
); End if
Sau khi nhập giá trị cho biến tyleMCN hay tyleMCD ở trên, máy tự động trả về dòng lựa chọn
(progn
(initget "tyleMCD tyleMCN")
(setq tyleMCD (getreal (strcat "\nMCD<1/"(rtos tyleMCD0 2 0)">/MCN(1/"(rtos tyleMCN 2 0)"): ")))
(if (or (= tyleMCD "MCD") (= tyleMCD "mcd") (= tyleMCD "tyleMCD") (= tyleMCD "tylemcd")
(= tyleMCD "MCN") (= tyleMCD "mcn") (= tyleMCD "tyleMCN") (= tyleMCD "tylemcn") (= tyleMCD ""))
(setq Test 1)
(setq tyleMCD0 tyleMCD)
)
Chỉ thoát giá khi giá trị của tyleMCD là "" tức khi nhập Enter hay Space.
Đó là ý nghĩa của đoạn code của mình.
Mình đang băn khoăn vì sao tyleMCD0 của mình bị lỗi. Rất mong nhận được góp ý của các bạn về bài của mình. Mong tin!!

<<

Filename: 94498_a1.lsp
Tác giả: Ce.truonghai
Bài viết gốc: 240875
Tên lệnh: cd bd
Nhờ chỉnh sửa LISP CUTDIM.

Tình hình là mình đã tìm kiếm nhiều các LISP CUTDIM khác nhau, nhưng vẫn còn 1 lỗi khá rắc rối chưa hoàn chỉnh. Nhờ các PRO xem chỉnh sửa lại dùm mình.

- LISP cắt Dim đã giải quyết được các DIM không phải trong UCS World, nhưng còn 1 lỗi nhỏ là khi 1 dim bị rút 1 Node về ngang với đường kích thước thì Cắt Dim sẽ cho về giá trị 0 (lệnh CD) và không nhúc nhích (lệnh BD).

 

>>

Tình hình là mình đã tìm kiếm nhiều các LISP CUTDIM khác nhau, nhưng vẫn còn 1 lỗi khá rắc rối chưa hoàn chỉnh. Nhờ các PRO xem chỉnh sửa lại dùm mình.

- LISP cắt Dim đã giải quyết được các DIM không phải trong UCS World, nhưng còn 1 lỗi nhỏ là khi 1 dim bị rút 1 Node về ngang với đường kích thước thì Cắt Dim sẽ cho về giá trị 0 (lệnh CD) và không nhúc nhích (lệnh BD).

 

;*******************************************************************************
;* WRITTEN BY DAO NGUYEN THANG 94X3 - HANOI ARCHITECTURAL UNIVERSITY (VIETNAM) *
;*******************************************************************************
(defun myerror (s)                    ; If an error (such as CTRL-C) occurs
                                      ; while this command is active...
  (cond
    ((= s "quit / exit abort") (princ))
    ((/= s "Function cancelled") (princ (strcat "\nError: " s)))
  )
  (setvar "cmdecho" CMD)             ; Restore saved modes
  (setvar "osmode" OSM)
  (setq *error* OLDERR)               ; Restore old *error* handler
  (princ)
)
;*******************************************************************************
(DEFUN C:CD (/ CMD SS LTH DEM PT DS KDL N70 GOCX GOCY PT13 PT14 PTI PT13I PT14I
                PT13N PT14N O13 O14 N13 N14 OSM OLDERR PT10 PT11)
(SETQ CMD (GETVAR "CMDECHO"))
(SETQ OSM (GETVAR "OSMODE"))
(SETQ OLDERR *error*
      *error* myerror)
(PRINC "Please select dimension object!")
(SETQ SS (SSGET))
(SETVAR "CMDECHO" 0)
(SETQ PT (GETPOINT "Point to trim or extend:"))
(SETQ PT (TRANS PT 1 0))
(COMMAND "UCS" "W")
(SETQ LTH (SSLENGTH SS))
(SETQ DEM 0)
(WHILE (< DEM LTH)
    (PROGN
	(SETQ DS (ENTGET (SSNAME SS DEM)))
	(SETQ KDL (CDR (ASSOC 0 DS)))
	(IF (= "DIMENSION" KDL)
	   (PROGN
		(SETQ PT10 (CDR (ASSOC 10 DS)))
		(SETQ PT11 (CDR (ASSOC 11 DS)))
		(SETQ PT13 (CDR (ASSOC 13 DS)))
		(SETQ PT14 (CDR (ASSOC 14 DS)))
		(SETQ N70 (CDR (ASSOC 70 DS)))
		(IF (OR (= N70 32) (= N70 33) (= N70 160) (= N70 161))
		   (PROGN
			(SETQ GOCY (ANGLE PT10 PT14))
			(SETQ GOCX (+ GOCY (/ PI 2)))
		   )
		)
		(SETVAR "OSMODE" 0)
		(SETQ PTI (POLAR PT GOCX 2))
		(SETQ PT13I (POLAR PT13 GOCY 2))
		(SETQ PT14I (POLAR PT14 GOCY 2))
		(SETQ PT13N (INTERS PT PTI PT13 PT13I NIL))
		(SETQ PT14N (INTERS PT PTI PT14 PT14I NIL))
		(SETQ O13 (ASSOC 13 DS))
		(SETQ O14 (ASSOC 14 DS))
		(SETQ N13 (CONS 13 PT13N))
		(SETQ N14 (CONS 14 PT14N))
		(SETQ DS (SUBST N13 O13 DS))
		(SETQ DS (SUBST N14 O14 DS))
		(ENTMOD DS)
	   )
	)
	(SETQ DEM (+ DEM 1))
    )
)
(COMMAND "UCS" "P")
(SETVAR "CMDECHO" CMD)
(SETVAR "OSMODE" OSM)
(setq *error* OLDERR)               ; Restore old *error* handler
(PRINC)
)
;******************************************************************************

(DEFUN C:BD (/ CMD SS LTH DEM PT DS KDL N70 GOCX GOCY PT13 PT14 PTI
                PT10 PT10I PT10N O10 N10 PT11 PT11N O11 N11 KC OSM OLDERR)
(SETQ CMD (GETVAR "CMDECHO"))
(SETQ OSM (GETVAR "OSMODE"))
(SETQ OLDERR *error*
      *error* myerror)
(PRINC "Please select dimension object!")
(SETQ SS (SSGET))
(SETVAR "CMDECHO" 0)
(SETQ PT (GETPOINT "Point to trim or extend:"))
(SETQ PT (TRANS PT 1 0))
(COMMAND "UCS" "W")
(SETQ LTH (SSLENGTH SS))
(SETQ DEM 0)
(WHILE (< DEM LTH)
    (PROGN
	(SETQ DS (ENTGET (SSNAME SS DEM)))
	(SETQ KDL (CDR (ASSOC 0 DS)))
	(IF (= "DIMENSION" KDL)
	   (PROGN
		(SETQ PT13 (CDR (ASSOC 13 DS)))
		(SETQ PT14 (CDR (ASSOC 14 DS)))
		(SETQ PT10 (CDR (ASSOC 10 DS)))
		(SETQ PT11 (CDR (ASSOC 11 DS)))
		(SETQ N70 (CDR (ASSOC 70 DS)))
		(IF (OR (= N70 32) (= N70 33) (= N70 160) (= N70 161))
		   (PROGN
			(SETQ GOCY (ANGLE PT10 PT14))
			(SETQ GOCX (+ GOCY (/ PI 2)))
		   )
		)
		(SETVAR "OSMODE" 0)
		(SETQ PTI (POLAR PT GOCX 2))
		(SETQ PT10I (POLAR PT10 GOCY 2))
		(SETQ PT10N (INTERS PT PTI PT10 PT10I NIL))
		(SETQ KC (DISTANCE PT10 PT10N))
		(SETQ O10 (ASSOC 10 DS))
		(SETQ N10 (CONS 10 PT10N))
		(SETQ DS (SUBST N10 O10 DS))
		(SETQ PT11N (POLAR PT11 (ANGLE PT10 PT10N) KC))
		(SETQ O11 (ASSOC 11 DS))
		(SETQ N11 (CONS 11 PT11N))
		(SETQ DS (SUBST N11 O11 DS))
		(ENTMOD DS)
	   )
	)
	(SETQ DEM (+ DEM 1))
    )
)
(COMMAND "UCS" "P")
(SETVAR "CMDECHO" CMD)
(SETVAR "OSMODE" OSM)
(setq *error* OLDERR)
(PRINC)
)

Cảm ơn AE giúp đỡ,

Thân chào.


<<

Filename: 240875_cd_bd.lsp
Tác giả: TaiNguyen79
Bài viết gốc: 242218
Tên lệnh: ghicanh
Lisp thống kê tọa độ địa chính

Thanks bác em đã làm đc rồi. Tiện đây cho em hỏi có lisp nào chạy cạnh của thửa đất không cho em xin với.
Nó cũng giống như mình chạy tọa độ, chỉ cần pick vào 1 điểm trong vùng kín là nó tự hiện kích thước tất cả các cạnh lên

Cái này chắc cũng dùng tạm đc cho yc của bạn :

(defun...
>>

Thanks bác em đã làm đc rồi. Tiện đây cho em hỏi có lisp nào chạy cạnh của thửa đất không cho em xin với.
Nó cũng giống như mình chạy tọa độ, chỉ cần pick vào 1 điểm trong vùng kín là nó tự hiện kích thước tất cả các cạnh lên

Cái này chắc cũng dùng tạm đc cho yc của bạn :

(defun C:ghicanh (/ ss)
(luuBHT)
(setvar "CMDECHO" 0)
(setvar "OSMODE" 0)
(setq ss (ssget))
(command "UNDO" "BE" "")
(T_ALL ss)
(command "UNDO" "E" "")
(traBHT))
(defun XULY (s1 s2 / goc so canh goc90 pt0 pt)
(setq goc (angle s1 s2) so (distance s1 s2) HSLT 2 )
(setq pt0 (polar s1 goc (/ so 2)))
(setq goc90 (+ goc (/ PI 2)) pt (polar pt0 goc90 0.8))
(setq canh (trtos so HSLT))
(if (or (<= (* (/ goc pi) 180) 90) (>= (* (/ goc pi) 180) 270))
(command "TEXT" "M" pt 0.85 (* (/ goc pi) 180) canh "")
(command "TEXT" "M" pt 0.85 (+ (* (/ goc pi) 180) 180) canh "")))
(defun T_LINE (oldob / s01 s02)
(setq s01 (cdr (assoc 10 oldob)) s02 (cdr (assoc 11 oldob)))
(xuly s01 s02))
(defun T_POLYLINE (oldob / s s1 s2 i)
(setq i 0 s nil s1 nil)
(while (< i (length oldob))
(if (= (car (nth i oldob)) 10)
(progn
(setq s2 (cdr (nth i oldob)))
(if (= s1 nil) (setq s s2) (xuly s1 s2))
(setq s1 s2)))
(setq i (1+ i)))
(if (= (cdr (assoc 70 oldob)) 1)
(xuly s2 s)))
(defun T_BLOCK (oldob / ss1 pt1)
(setq pt1 (cdr (assoc 10 oldob)))
(setq b_name (cdr (assoc 2 oldob)))
(setq tt_name (cdr (assoc -1 oldob)))
(command "EXPLODE" tt_name "")
(setq ss1 (ssget "P"))
(T_ALL ss1)
(command "ERASE" "P" "")
(command "INSERT" b_name pt1 "" "" ""))
(defun T_ALL (ss / c oldob)
(setq c 0)
(if (/= ss nil)
(while (< c (sslength ss))
(setq oldob (entget (ssname ss c)))
(if (= (cdr (assoc 0 oldob)) "LINE")
(T_LINE oldob)
(if (/= (or (= (cdr (assoc 0 oldob)) "POLYLINE") (= (cdr (assoc 0 oldob)) "LWPOLYLINE")) nil)
(T_POLYLINE oldob)
(if (= (cdr (assoc 0 oldob)) "INSERT")
(T_BLOCK oldob))))
(setq c (1+ c)))))


Chọn các cạnh muốn ghi là đc.
PS : lsp xử lý đc luôn cả pline và block. Nhưng nếu là block thì chỉ đúng khi block chưa bị scale .
Và phải có hàm trtos của lsp ghitd bên trên.
(Trtos cũng giống rtos nhưng tránh đc các lỗi do CAD làm tròn số)
<<

Filename: 242218_ghicanh.lsp
Tác giả: TaiNguyen79
Bài viết gốc: 242345
Tên lệnh: tchtext
Sửa nhiều text có giá trị khác nhau về 1 giá trị

Em nhờ các anh viết lisp giúp em: Em muốn đồng bộ hóa nhiều Text với các giá trị khác nhau về 1 giá trị (Nghĩa là sau khi dùng lisp xong thì các text có giá trị khác nhau ấy sẽ có cùng 1 giá trị giống nhau). Thanks!!!

Dùng cái này đi bạn :

(defun bylayer (lname)
(if (null (assoc 62 lname))...
>>

Em nhờ các anh viết lisp giúp em: Em muốn đồng bộ hóa nhiều Text với các giá trị khác nhau về 1 giá trị (Nghĩa là sau khi dùng lisp xong thì các text có giá trị khác nhau ấy sẽ có cùng 1 giá trị giống nhau). Thanks!!!

Dùng cái này đi bạn :

(defun bylayer (lname)
(if (null (assoc 62 lname)) (setq lname (append lname (list (cons 62 256)))))
lname)
;---------------------------------------------
;;Sua nhieu chu theo tinh chat cua mot chu chon lam mau
(defun c:Tchtext (/ SS1 Ename Ans Eget ds1 ds2 Count En Eg)
(setvar "cmdecho" 0)
(princ "\nChon cac chu can thay doi")
(while (null (setq SS1 (ssget (list (cons 0 "Text"))))) (princ "\nKhong co doi tuong"))
(while (or (null (setq Ename (car (entsel "\nChon 1 chu lam mau"))))
(/= "TEXT" (cdr (assoc 0 (entget ename)))))
(princ "\nKhong co doi tuong, hoac do khong phai la Text.")) ;while
(setq Eget (bylayer (entget Ename)))
(setq ds1 (list "Text" "Height" "Rotation" "Width" "Obliquing" "Style" "Color" "Layer")
ds2 (list 1 40 50 41 51 7 62 8));setq
(initget "Text Height Rotation Width Obliquing Style Color Layer")
(setq Ans (getkword "\nText Height Rotation Width Obliquing Style Color Layer <Enter=Exit>"))
(mapcar '(lambda (a B)
(if (= Ans a)
(progn
(setq Count 0)
(repeat (sslength SS1)
(setq En (ssname SS1 Count) Eg (bylayer (entget En)))
(setq Eg (subst (assoc b Eget) (assoc b Eg) Eg))
(setq Count (1+ Count))
(entmod Eg));repeat
))) ds1 ds2) ;mapcar
(setq SS1 nil Ename nil)
(setvar "cmdecho" 1)
(princ))


Muốn đồng bộ hóa nội dung text thì nhập : T
khi chương trình hỏi : Text Height Rotation Width Obliquing Style Color Layer <Enter=Exit>
<<

Filename: 242345_tchtext.lsp
Tác giả: ndtnv
Bài viết gốc: 242564
Tên lệnh: vd
Lisp dim góc vát

Xem chủ đề thấy hay hay nên test thử thì thấy code của bạn TaiNguyen79 có lỗi sau:
- Mã dxf 70 của pline là  (bit-coded) nên nếu = 0, 128 open; = 1, 129 closed
- osmode phải để ở hàm chính (có lẽ lúc đầu bạn vẽ dim trong hàm con)
- Ngoài ra code có nhiều đoạn không cần thiết như:
  + Khi gọi hàm vatgoc_tinhtoan các biến trung gian a b c d thừa
  + Tạo list lst_vg chiếm bộ nhớ gần 4 lần...

>>

Xem chủ đề thấy hay hay nên test thử thì thấy code của bạn TaiNguyen79 có lỗi sau:
- Mã dxf 70 của pline là  (bit-coded) nên nếu = 0, 128 open; = 1, 129 closed
- osmode phải để ở hàm chính (có lẽ lúc đầu bạn vẽ dim trong hàm con)
- Ngoài ra code có nhiều đoạn không cần thiết như:
  + Khi gọi hàm vatgoc_tinhtoan các biến trung gian a b c d thừa
  + Tạo list lst_vg chiếm bộ nhớ gần 4 lần lstpt, khi dùng lại phải truy xuất qua 2 cấp.
Dù sao thì lisp này cũng có thuật toán hay như thuật toán lính canh để xử lý closed pline
Sau đây là lisp tôi sửa, cải tiến lại.

(defun vatgoc_tinhtoan (p1 p2 p3 p4 / intp d1 d2 a1 a2 di1 di2 ai1 ai2 kqua)
    (if (setq intp (inters p1 p2 p3 p4 nil))
    (progn
        (setq d1 (distance p1 p2) d2 (distance p3 p4) a1 (angle p1 p2) a2 (angle p3 p4))
        (setq di1 (distance p1 intp) di2 (distance p3 intp) ai1 (angle p1 intp) ai2 (angle p3 intp))
        (if (and (and (equal ai1 a1 0.00001) (> di1 d1)) (and (equal ai2 a2 0.00001)(> di2 d2)))
            (setq kqua intp))))
    kqua
)
;-------------------------
(defun c:vd ( / Egss k cl lstpt t1 p1 diem n osm vgtt); c:vatgoc_dimaligned
    (setq osm (getvar "osmode"))
    (setvar "osmode" 0)
    (setq Egss (entget (car (entsel "\nChon pline :" ))))
    (setq k (cdr (assoc 90 Egss)) cl (rem (cdr (assoc 70 Egss)) 2))
    (repeat k
        (progn
            (setq t1 (member (assoc 10 Egss) Egss))
            (setq p1 (car t1))
            (setq Egss (cdr t1))
            (setq diem (cdr p1))
            (setq lstpt (append lstpt (list diem)))
            ));while
    (if (< (setq k (length lstpt)) 4) (exit))
    (if (= cl 1) (setq lstpt (append lstpt (list (nth 0 lstpt)(nth 1 lstpt) (nth 2 lstpt))))
        (if (equal (nth 0 lstpt) (nth (- k 1) lstpt))
                (setq lstpt (append lstpt (list (nth 1 lstpt) (nth 2 lstpt)))))        )
    
    (setq n 0 k (- (length lstpt) 3))
    (repeat k
    (if (setq vgtt (vatgoc_tinhtoan (nth n lstpt) (nth (+ n 1) lstpt) (nth (+ n 3) lstpt) (nth (+ n 2) lstpt)))
        (progn (command "dimaligned" (nth (+ n 1) lstpt) vgtt vgtt)
            (command "dimaligned" (nth (+ n 2) lstpt) vgtt vgtt))
    )
    (setq n (1+ n))
    )
    (setvar "osmode" osm)
)

<<

Filename: 242564_vd.lsp
Tác giả: khaosat2009
Bài viết gốc: 114774
Tên lệnh: xkl
Viết lisp theo yêu cầu [phần 2]


Vừa hay, mới vừa viết xong Code cho Út. Tuy nhiên, không hiểu sao Lisp chạy lần đầu tiên thì không có kết quả. Chạy lần thứ hai trở đi thì OK
Út hãy thử với Code này :

Xin nhờ các anh giúp cho Lisp chon text trên Cad xuất ra file text hoặc Excel.
* Lisp yêu cầu xác nhận số text cần xuất ra hàng ngang Ví dụ : ( số text trên 1 hàng là 5 ) 1.23 2.35 3.21 3.25 3.25
>>

Vừa hay, mới vừa viết xong Code cho Út. Tuy nhiên, không hiểu sao Lisp chạy lần đầu tiên thì không có kết quả. Chạy lần thứ hai trở đi thì OK
Út hãy thử với Code này :

Xin nhờ các anh giúp cho Lisp chon text trên Cad xuất ra file text hoặc Excel.
* Lisp yêu cầu xác nhận số text cần xuất ra hàng ngang Ví dụ : ( số text trên 1 hàng là 5 ) 1.23 2.35 3.21 3.25 3.25
ta chọn các text đúng với số khống chế 5 như trên của một hàng ( nếu có trường hợp trong một hàng số lần thứ 3 không có dử liệu ta chỉ chọn ngoài màn hình, thì có bỏ qua một ô . Ví dụ: 1.23 2.35 -- 3.25 3.25 ), khi hết dử liệu của hàng thì lisp hỏi nhập hàng tiếp nủa không ?
Nhấn Enter chọn nhập tiếp hàng 2, như vậy chọn tiếp...n
Khi kết thúc nhấn enter, enter thì xuất các số liệu text ra file text theo tên của file Cad theo số hàng n , có 5 cột
** PS: Lisp yêu cầu xác nhận số xuất ra cột dọc
ta chọn các text cần xuất ra cột , lisp hỏi nhập để xuất ra cột tiếp nủa không ?
Nhấn Enter chọn nhập tiếp để xuất ra cột 2, như vậy chọn tiếp...đến n cột
Khi kết thúc nhấn enter, enter thì xuất các số liệu text ra file text theo tên của file Cad theo số n cột.
Vì một lý do ta dừng khi kết thức nhập theo hàng hay cột mà dử liệu cò phải nhập tiếp, khi nhập tiếp thì số liệu nhập sau sẻ được thêm vào trong file nó và được nối tiếp.
Rất mong được các anh giúp. Cám ơn
<<

Filename: 114774_xkl.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 114874
Tên lệnh: tchu
Viết lisp theo yêu cầu [phần 2]

Hề hề hề,
Nhờ sự chỉ bảo của bác Tue_NV, mình sửa lại cái lisp viết cho bạn ceddtu như sau, xem ra nó ngon hơn cái cũ nhiều. Hẳn là bác Tue_NV sẽ hài lòng với kết quả này


Bạn ceddtu đâu rồi, cho ý kiến đi chứ nhể...

Filename: 114874_tchu.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 242703
Tên lệnh: ha
Lisp đánh ký hiệu khung block att

Lisp thay đổi Att tăng dần 1 đơn vị cho các Block_Att được chọn theo Att được chọn đầu tiên.

;; Thay doi att tang dan 1 don vi cho cac block_att duoc chon theo att duoc chon dau tien.
;; Doan Van Ha - CadViet.com - ngay 26/7/2013
(vl-load-com)
(defun C:HA( / ent ss tag lst pre suf int len num #SS->List #String:Split-First VxSetAtts)
 (defun #SS->List (ss / i lst)
  (repeat (setq i (sslength ss))
   (setq...
>>

Lisp thay đổi Att tăng dần 1 đơn vị cho các Block_Att được chọn theo Att được chọn đầu tiên.

;; Thay doi att tang dan 1 don vi cho cac block_att duoc chon theo att duoc chon dau tien.
;; Doan Van Ha - CadViet.com - ngay 26/7/2013
(vl-load-com)
(defun C:HA( / ent ss tag lst pre suf int len num #SS->List #String:Split-First VxSetAtts)
 (defun #SS->List (ss / i lst)
  (repeat (setq i (sslength ss))
   (setq lst (cons (ssname ss (setq i (1- i))) lst))))
 (defun #String:Split-First (string symbol / i)
  (if (setq i (vl-string-position (ascii symbol) string))
   (list (substr string 1 (1+ i)) (substr string (+ 2 i)))
   (list string)))
 (defun VxSetAtts (Obj Lst / AttVal)
  (mapcar '(lambda (Att) (if (setq AttVal (cdr (assoc (vla-get-TagString Att) Lst))) (vla-put-TextString Att AttVal))) (vlax-invoke Obj 'GetAttributes))
  (vla-update Obj))
 (if
  (and
   (setq ent (car (nentsel "\nChon Att So hieu cua ban ve dau tien: ")))
   (princ "\nChon cac Block theo thu tu de thay So hieu ban ve...")
   (setq ss (ssget '((0 . "Insert") (66 . 1)))))
  (progn
   (setq tag (cdr (assoc 2 (setq elist (entget ent)))))
   (setq lst (#String:Split-First (cdr (assoc 1 elist)) "-"))
   (setq pre (car lst))
   (setq suf (cadr lst))
   (setq int (atoi suf))
   (setq len (strlen suf))
   (foreach n (#SS->List ss)
(setq num (itoa (setq int (1+ int))))
(repeat (- len (strlen num))
(setq num (strcat "0" num)))
(VxSetAtts (vlax-ename->vla-object n) (list (cons tag (strcat pre num))))))))
 

<<

Filename: 242703_ha.lsp
Tác giả: ketxu
Bài viết gốc: 238438
Tên lệnh: doi
Quét, lọc và thay đổi Layer cho nhóm đối tượng.

Quick code cho bạn 

(defun c:doi(/ lstSource ss i e)
	(setq 	lstSource '(("1" . "1a")("2" . "2a") ("3" . "3a")) ;Them danh sach nguon, dich vao day
			ss (ssget 
			(list (cons 8
				(substr
					(apply 'strcat (mapcar '(lambda(x)(strcat "," x))(mapcar 'car lstSource)))
					2
				))
			))
			i -1
	)
	(while (setq e (ssname ss (setq i (1+ i))))
		(entmod (append (setq e (entget e))(list (cons 8 (cdr (assoc (cdr (assoc 8 e))...
>>

Quick code cho bạn 

(defun c:doi(/ lstSource ss i e)
	(setq 	lstSource '(("1" . "1a")("2" . "2a") ("3" . "3a")) ;Them danh sach nguon, dich vao day
			ss (ssget 
			(list (cons 8
				(substr
					(apply 'strcat (mapcar '(lambda(x)(strcat "," x))(mapcar 'car lstSource)))
					2
				))
			))
			i -1
	)
	(while (setq e (ssname ss (setq i (1+ i))))
		(entmod (append (setq e (entget e))(list (cons 8 (cdr (assoc (cdr (assoc 8 e)) lstSource))))))
	)
	(princ)
)

 

(defun c:doi(/ lstSource ss i e)
(setq lstSource '(("1" . "1a")("2" . "2a") ("3" . "3a")) ;Them danh sach nguon, dich vao day
ss (ssget 
(list (cons 8
(substr
(apply 'strcat (mapcar '(lambda(x)(strcat "," x))(mapcar 'car lstSource)))
2
))
))
i -1
)
(while (setq e (ssname ss (setq i (1+ i))))
(entmod (append (setq e (entget e))(list (cons 8 (cdr (assoc (cdr (assoc 8 e)) lstSource))))))
)
(princ)
 
(defun c:doi(/ lstSource ss i e)
(setq lstSource '(("1" . "1a")("2" . "2a") ("3" . "3a")) ;Them danh sach nguon, dich vao day
ss (ssget 
(list (cons 8
(substr
(apply 'strcat (mapcar '(lambda(x)(strcat "," x))(mapcar 'car lstSource)))
2
))
))
i -1
)
(while (setq e (ssname ss (setq i (1+ i))))
(entmod (append (setq e (entget e))(list (cons 8 (cdr (assoc (cdr (assoc 8 e)) lstSource))))))
)
(princ)
)
(defun c:doi(/ lstSource ss i e)
(setq lstSource '(("1" . "1a")("2" . "2a") ("3" . "3a")) ;Them danh sach nguon, dich vao day
ss (ssget 
(list (cons 8
(substr
(apply 'strcat (mapcar '(lambda(x)(strcat "," x))(mapcar 'car lstSource)))
2
))
))
i -1
)
(while (setq e (ssname ss (setq i (1+ i))))
(entmod (append (setq e (entget e))(list (cons 8 (cdr (assoc (cdr (assoc 8 e)) lstSource))))))
)
(princ)
)
(defun c:doi(/ lstSource ss i e)
(setq lstSource '(("1" . "1a")("2" . "2a") ("3" . "3a")) ;Them danh sach nguon, dich vao day
ss (ssget 
(list (cons 8
(substr
(apply 'strcat (mapcar '(lambda(x)(strcat "," x))(mapcar 'car lstSource)))
2
))
))
i -1
)
(while (setq e (ssname ss (setq i (1+ i))))
(entmod (append (setq e (entget e))(list (cons 8 (cdr (assoc (cdr (assoc 8 e)) lstSource))))))
)
(princ)
 
(defun c:doi(/ lstSource ss i e)
(setq lstSource '(("1" . "1a")("2" . "2a") ("3" . "3a")) ;Them danh sach nguon, dich vao day
ss (ssget 
(list (cons 8
(substr
(apply 'strcat (mapcar '(lambda(x)(strcat "," x))(mapcar 'car lstSource)))
2
))
))
i -1
)
(while (setq e (ssname ss (setq i (1+ i))))
(entmod (append (setq e (entget e))(list (cons 8 (cdr (assoc (cdr (assoc 8 e)) lstSource))))))
)
(princ)
 
(defun c:doi(/ lstSource ss i e)
(setq lstSource '(("1" . "1a")("2" . "2a") ("3" . "3a")) ;Them danh sach nguon, dich vao day
ss (ssget 
(list (cons 8
(substr
(apply 'strcat (mapcar '(lambda(x)(strcat "," x))(mapcar 'car lstSource)))
2
))
))
i -1
)
(while (setq e (ssname ss (setq i (1+ i))))
(entmod (append (setq e (entget e))(list (cons 8 (cdr (assoc (cdr (assoc 8 e)) lstSource))))))
)
(princ)
)

<<

Filename: 238438_doi.lsp
Tác giả: TaiNguyen79
Bài viết gốc: 242841
Tên lệnh: f2 4
[Nhờ chỉnh sửa] Lisp tính cao độ
Sửa cho bạn đây :

(defun C:f2( / cdd L te p1 p2)
(setq cdd (atof (cdr(assoc 1 (entget(car(entsel "\n Pick chon Text cao do dau :")))))))
(setq p1 (getpoint "\n Chon diem da biet cao do:"))
(while (setq p2 (getpoint p1 "\n Chon diem can tim cao do :"))
(setq L (+ cdd (- (cadr p2) (cadr p1))))
(setq te (entget(car(entsel"\n Chon Text de gan ket qua :")))
te (subst (cons 1 (rtos L 2 2)) (assoc 1 te) te))
(entmod te))(princ))
;---
(defun C:4( / L te p1...
>>
Sửa cho bạn đây :

(defun C:f2( / cdd L te p1 p2)
(setq cdd (atof (cdr(assoc 1 (entget(car(entsel "\n Pick chon Text cao do dau :")))))))
(setq p1 (getpoint "\n Chon diem da biet cao do:"))
(while (setq p2 (getpoint p1 "\n Chon diem can tim cao do :"))
(setq L (+ cdd (- (cadr p2) (cadr p1))))
(setq te (entget(car(entsel"\n Chon Text de gan ket qua :")))
te (subst (cons 1 (rtos L 2 2)) (assoc 1 te) te))
(entmod te))(princ))
;---
(defun C:4( / L te p1 p2)
(while (and (setq p1 (getpoint "\n Chon diem thu nhat :"))(setq p2 (getpoint p1 "\n Chon diem thu hai :")))
(setq L (distance p1 p2))
(setq te (entget(car(entsel"\n Chon Text de gan ket qua :"))) te (subst (cons 1 (rtos L 2 2)) (assoc 1 te) te))
(entmod te))(princ))


<<

Filename: 242841_f2_4.lsp
Tác giả: Song Nhi
Bài viết gốc: 240297
Tên lệnh: dvv
Help về việc chia đoạn thẳng thành nhưng phàn bằng nhau

ý của mình là làm thế nào để nó cất ra thành 10 phần bằng nhau ấy
các pro làm ơn chỉ tôi với :D

 
cất = cắt đó phải không bạn?! Nếu đúng vậy, bạn dùng code sau nhé

>>

ý của mình là làm thế nào để nó cất ra thành 10 phần bằng nhau ấy
các pro làm ơn chỉ tôi với :D

 
cất = cắt đó phải không bạn?! Nếu đúng vậy, bạn dùng code sau nhé

(defun C:DVV( / dc dd dex dey dt enil ik layy mm nn oms pd1 pd2 xpd1 xpd2 ypd1 ypd2)
(setq oms (getvar "OSMODE")) (setvar "OSMODE" 0)
(setq DTT (car (entsel "\nVui long chon tuyen\n")))
(setq DT  (entget DTT))
(setq nn (getint "\nVui long nhap do khoang chia <10>\n"))
  (if (= nn nil) (setq nn 10))
(setq layy (cdr (assoc 8 enil))) (command "-layer" "s" layy "")
(setq DD  (cdr (assoc 10 DT)) DC  (cdr (assoc 11 DT)))
(setq dex (/ (- (car  DC) (car  DD)) nn)
      dey (/ (- (cadr DC) (cadr DD)) nn))
(setq ik 0) (while (<= ik (- nn 1))
(setq   xpd1 (+ (car  DD) (* ik dex))
	ypd1 (+ (cadr DD) (* ik dey))
	pd1  (list xpd1 ypd1)
	xpd2 (+ (car   DD) (* (+ ik 1) dex))
	ypd2 (+ (cadr  DD) (* (+ ik 1) dey))
	pd2  (list xpd2 ypd2))
(command "line" pd1 pd2 "") (princ) (setq ik (+ ik 1)))
(command "_.erase" DTT "") (setvar "OSMODE" oms) (princ))

Bạn test lại nhé, mình có chuyện phải đi, có j bạn nhắn lại, tối mình về sửa lại cho bạn nhé!


<<

Filename: 240297_dvv.lsp
Tác giả: TaiNguyen79
Bài viết gốc: 242954
Tên lệnh: chcao
Lisp copy text, giá trị text thay đổi theo chênh cao các vị trí bắt điểm

- Ặc. Em vội quá lên chưa đặt câu hỏi hoàn chỉnh. Em ắp lại nè. https://mega.co.nz/#!oh9C3bLK!SGhsgjHUXTEQNpFrDxoeL0W92e8xddFHRmo1WhLCB0M
- Các anh giúp em với. Thanks
- Anh quansla: Lisp của em cần mà làm được theo thứ tự là:  Lệnh -> Chọn cao độ (giả...

>>

- Ặc. Em vội quá lên chưa đặt câu hỏi hoàn chỉnh. Em ắp lại nè. https://mega.co.nz/#!oh9C3bLK!SGhsgjHUXTEQNpFrDxoeL0W92e8xddFHRmo1WhLCB0M
- Các anh giúp em với. Thanks
- Anh quansla: Lisp của em cần mà làm được theo thứ tự là:  Lệnh -> Chọn cao độ (giả định=10đv) điểm A (a) -> Chọn bắt điểm 1 là điểm A -> chọn bắt điểm 2 là điểm B -> Chọn vị trí ghi giá trị text được tính là b (Lúc này, yêu cầu của bài toán là: b=a+XB-XA); Với XA,XB là số liệu tọa độ trong hệ tọa độ Đề các.

Như vầy đc không ?

(defun c:chcao (/ ha hb chon p1 p2 p3 T1)
(if (null (setq ha (getreal "\n Nhap cao do diem A :")))
(while (or (null (setq te1 (car (entsel "\n Chon Text <Cao do diem A>: ")))) (/= "TEXT" (cdr (assoc 0 (entget te1))))
(null (setq ha (distof (cdr (assoc 1 (entget te1)))))))));while
(initget 1) (setq p1 (getpoint "\nVi tri diem A :"))
(initget 1) (setq p2 (getpoint p1 "\nVi tri diem B :"))
(setq hb (+ ha (- (nth 1 p2) (nth 1 p1))))
(if (setq p3 (getpoint "\nChon vi tri dat ket qua :"))
(progn
(setq T1 (nentselp p3))
(if (or (null T1) (/= "TEXT" (cdr (assoc 0 (entget (car T1))))))
(entmake (list (cons 0 "TEXT") (cons 100 "AcDbEntity") (cons 100 "AcDbText") (list 10 (nth 0 p3) (nth 1 p3) 0.0)
(cons 40 1.0)(cons 1 (rtos hb 2 2))))
(entmod (subst (cons 1 (rtos hb 2 2)) (assoc 1 (entget (car T1))) (entget (car T1))))))
(princ (strcat "chenh cao can tim :" (rtos hb 2 2))))
(princ))

<<

Filename: 242954_chcao.lsp
Tác giả: quansla
Bài viết gốc: 242962
Tên lệnh: caodo
Lisp copy text, giá trị text thay đổi theo chênh cao các vị trí bắt điểm
Gửi bạn

 
(defun c:caodo (/ ANG ENTA ENTB KC PA PB TEXTA TEXTB DAUTP POS TEXTSTR)
  (if (and (setq textA (ssname (ssget '((0 . "*TEXT"))) 0 ))
  (setq pA (getpoint "\nChon diem A\t")))
    (progn      
      (setq entA (entget TextA)
   Textstr (cdr(assoc 1 entA))
   pos (cond ( (vl-string-search "." Textstr))( 1))
   kc (distance pA (cdr (assoc 10 entA)))
   ang (angle pA (cdr (assoc 10 entA))))
      (setq dauTP ( - (strlen...
>>
Gửi bạn

 
(defun c:caodo (/ ANG ENTA ENTB KC PA PB TEXTA TEXTB DAUTP POS TEXTSTR)
  (if (and (setq textA (ssname (ssget '((0 . "*TEXT"))) 0 ))
  (setq pA (getpoint "\nChon diem A\t")))
    (progn      
      (setq entA (entget TextA)
   Textstr (cdr(assoc 1 entA))
   pos (cond ( (vl-string-search "." Textstr))( 1))
   kc (distance pA (cdr (assoc 10 entA)))
   ang (angle pA (cdr (assoc 10 entA))))
      (setq dauTP ( - (strlen Textstr) pos 1))
      ;(setq dauTP 3);;;;-----Co the sua lai dau thap phan o day
      (while (setq pB (Getpoint "\nChon diem B"))
(if (= (type pB) 'LIST)
 (progn
   (setq textB (+ (atof(cdr(assoc 1 entA))) (- (car pB) (car pA))))
   (command "copy" TextA "" pA pB)
   (setq entB (entget(entlast)))
   (progn
     (setq entB (subst (cons 10 (polar pB ang kc)) (assoc 10 entB) entB))
     (setq entB (subst (cons 11 (polar pB ang kc)) (assoc 11 entB) entB))
     (setq entB (subst (cons 1 (rtos TextB 2 dauTP)) (assoc 1 entB) entB))
     (entmod entB)
     )
 nil
 )))
      );end progn
    );end if
  (princ)
  )

lisp lấy chữ số thập phân giống như TextA chọn, Ví dụ TextA chọn là 20.00 thì các số tiếp theo sẽ là 20.01 26.33 27.00 .....
Còn nếu TextA là 20 thì tiếp theo sẽ là 21 23 49 50 ....100,,,,,
<<

Filename: 242962_caodo.lsp
Tác giả: vantuan18nd
Bài viết gốc: 242822
Tên lệnh: f2
[Nhờ chỉnh sửa] Lisp tính cao độ
vigrx plus price in lahore But a spokeswoman with the International Association of Amusement Parks and Attractions countered that the trade group believes state officials "are best able to determine the level of regulation needed for their state."
befar order The monument lighting also marks Rubenstein"s role...
>>
vigrx plus price in lahore But a spokeswoman with the International Association of Amusement Parks and Attractions countered that the trade group believes state officials "are best able to determine the level of regulation needed for their state."
befar order The monument lighting also marks Rubenstein"s role in a larger campaign to restore neglected sites on the National Mall, officials said. The co-founder of the Carlyle Group investment firm has joined the nonprofit Trust for the National Mall as a co-chairman to help raise $350 million to preserve and restore sites in the nation"s most-visited national park.
sinrex before and after The report said that Google also proposed providing links to at least three competing search engines and making it easier for advertisers to transfer their search advertising campaigns to rival platforms, but the competitors remained unsatisfied with the proposals.
opiniones testo y xength "The accounts are always just a means to an end. Thecriminals are always looking to profit," said computer securityexpert Chris Grier, a University of California at Berkeleyresearch scientist who spent a year working on a team thatinvestigated fake accounts on Twitter.
sizegenetics 2012 The pending plan, which was approved by creditors in earlyOctober, relies on a planned $1.9 billion sale of new sewersystem bonds to replace soured bonds at the heart of what hadbeen the biggest U.S. municipal bankruptcy case until Detroitfiled for bankruptcy in July.
male extra en pharmacie "New pro features will be added regularly. The goal is to offer our most passionate users more productivity and make Feedly sustainable in the long run," the company said. "A more sustainable company will lead to more innovation for users of both Feedly pro and Feedly standard."
l-arginine nerve damage Interest rates on those T-bills jumped as high as 0.71percent early Wednesday, which was the highestlevel in five years during the depth of the global financialcrisis. T-bill rates subsided later Wednesday after the U.S.Senate reached a last-minute deal to temporarily raise the debtceiling and fully fund the government, which has been in partialshutdown for two weeks.
testoforce and xength x1 dosage Now that he has returned to therapy and has resumed taking “a ton” of medication to treat his illness, Schwyzer says he realizes that teaching the course on porn “was done under false pretenses.”
using penatropin Marcus Newman, an insurance agent in Bannockburn, Illinois, outside Chicago, does not know anyone who has purchased a plan on a public exchange. "I"ve quoted prices, and every single person choked on the rates," Newman says. "I don"t know what they were expecting."

<<

Filename: 242822_f2.lsp
Tác giả: quansla
Bài viết gốc: 243050
Tên lệnh: caodox caodoy
Lisp copy text, giá trị text thay đổi theo chênh cao các vị trí bắt điểm

- Cảm ơn anh quansla. Em làm được rồi. Nhưng a có thể sửa thêm: Vị trí đặt text B là text có đã sẵn giúp em được không?
- Anh có thể làm lisp như vậy, nhưng với YA-YB được không a? Vị trí đặt text B là text đã có sẵn a nhé 

>>

- Cảm ơn anh quansla. Em làm được rồi. Nhưng a có thể sửa thêm: Vị trí đặt text B là text có đã sẵn giúp em được không?
- Anh có thể làm lisp như vậy, nhưng với YA-YB được không a? Vị trí đặt text B là text đã có sẵn a nhé . Thanks!!!

Của bạn đây
Tên lệnh CaodoX và CaodoY (tương ứng là trừ xB-xA và yB-yA)
sử dụng

  • Bước 1 : chọn TextA và vị trí tương ứng của A
  • Bước 2: Chọn vị trí B và có hai lựa chọn: chọn trực tiếp 1 Text có sẵn để "EDDIT" về giá trị tính được hoặc Enter (/ phím "Space") để lựa chọn điểm chèn TextB
  • Lặp lại bước 2 nếu chưa Enter(hoặc Space) kết thúc lệnh

http://www.cadviet.com/upfiles/3/101306_viet_ho.lsp

(defun c:caodoX (/ DAUTP DCHEN ENTA ENTB PA PB POS TEXTA TEXTASTR TEXTB TEXTBSTR)
(vl-load-com)
(prompt "\nChon TextA")(princ)
(if (and (setq textA (ssname (ssget '((0 . "*TEXT"))) 0 ))
(setq pA (getpoint "\nChon diem A\t")))
(progn
(setq entA (entget TextA)
TextAstr (cdr(assoc 1 entA))
pos (cond ( (vl-string-search "." TextAstr))( 1)))
(setq dauTP ( - (strlen TextAstr) pos 1))
;(setq dauTP 3);;;;-----Co the sua lai dau thap phan o day
(while (setq pB (Getpoint "\nCHON DIEM B"))
(initget "P")
(setq textBstr (+ (atof(cdr(assoc 1 entA))) (- (car pB) (car pA))))
(prompt "\nChon TextB")
(if (setq TextB (entsel"\nChon TextB<or Enter de chon diem chen TextB>"))
(progn
(setq entB (entget(car TextB)))
(entmod(subst (cons 1 (rtos textBstr 2 dauTP))(assoc 1 entB) entB)))
(progn
(setq dchen (getpoint "\nChon diem chen TextB>"))
(entmake (list
(cons 0 "TEXT")
(cons 10 dchen)
(cons 11 dchen)
(assoc 40 entA)
(cons 1 (rtos textBstr 2 dauTP))
))
)
)
)
)
nil
)
(princ)
)



(defun c:caodoY (/ DAUTP DCHEN ENTA ENTB PA PB POS TEXTA TEXTASTR TEXTB TEXTBSTR)
(vl-load-com)
(prompt "\nChon TextA")(princ)
(if (and (setq textA (ssname (ssget '((0 . "*TEXT"))) 0 ))
(setq pA (getpoint "\nChon diem A\t")))
(progn
(setq entA (entget TextA)
TextAstr (cdr(assoc 1 entA))
pos (cond ( (vl-string-search "." TextAstr))( 1)))
(setq dauTP ( - (strlen TextAstr) pos 1))
;(setq dauTP 3);;;;-----Co the sua lai dau thap phan o day
(while (setq pB (Getpoint "\nCHON DIEM B"))
(initget "P")
(setq textBstr (+ (atof(cdr(assoc 1 entA))) (- (cadr pB) (cadr pA))))
(prompt "\nChon TextB")
(if (setq TextB (entsel"\nChon TextB<or Enter de chon diem chen TextB>"))
(progn
(setq entB (entget(car TextB)))
(entmod(subst (cons 1 (rtos textBstr 2 dauTP))(assoc 1 entB) entB)))
(progn
(setq dchen (getpoint "\nChon diem chen TextB>"))
(entmake (list
(cons 0 "TEXT")
(cons 10 dchen)
(cons 11 dchen)
(assoc 40 entA)
(cons 1 (rtos textBstr 2 dauTP))
))
)
)
)
)
nil
)
(princ)
)
 


<<

Filename: 243050_caodox_caodoy.lsp
Tác giả: bach1212
Bài viết gốc: 243070
Tên lệnh: dcs
Lisp copy text, giá trị text thay đổi theo chênh cao các vị trí bắt điểm

Dùng lisp này xem
 

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=12103&st=20
(defun c:dcs(/ tlv blm blname dmo cdm cd dm cdmi dmoc bl)
(setvar "attreq" 1)
(setvar "cmdecho" 0)
(setq oldim (getvar "DimZin"))
(setvar "Dimzin" 0)
(setq tlv (/ 1 (getreal "\n Nhap ti le ve : 1/")))
(setq bl (car(entsel "\n Pick chon Block mau / Text mau :")))
(setq blm (entget bl))
(setq...
>>

Dùng lisp này xem
 

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=12103&st=20
(defun c:dcs(/ tlv blm blname dmo cdm cd dm cdmi dmoc bl)
(setvar "attreq" 1)
(setvar "cmdecho" 0)
(setq oldim (getvar "DimZin"))
(setvar "Dimzin" 0)
(setq tlv (/ 1 (getreal "\n Nhap ti le ve : 1/")))
(setq bl (car(entsel "\n Pick chon Block mau / Text mau :")))
(setq blm (entget bl))
(setq dmo (getpoint "\n Pick diem moc : "))

(setq cdm (getreal "\n Nhap cao do cua diem moc \ Enter pick text cao do : "))
(if (null cdm) (setq cdm (atof (cdr(assoc 1 (entget(car (entsel "pick text cao do : ")))))))  )
(if cdm (progn
(if (= cdm 0) (setq cd (strcat "%%p" (rtos cdm 2 2))))
(if (> cdm 0) (setq cd (strcat "+" (rtos cdm 2 2))))
(if (< cdm 0) (setq cd (rtos cdm 2 2)))
(setq dmoc dmo)
(while (setq dm (getpoint dmoc "\n Pick diem tiep theo :"))
(if (> (cadr dm) (cadr dmo))  (setq cdmi (+ (* (- (cadr dm) (cadr dmo)) tlv) cdm) ) )
(if (<= (cadr dm) (cadr dmo))  (setq cdmi (- cdm (* (- (cadr dmo) (cadr dm)) tlv) ) ) )
(if (= cdmi 0) (setq cdi (strcat "%%p" (rtos cdmi 2 2))))
(if (> cdmi 0) (setq cdi (strcat "+" (rtos cdmi 2 2))))
(if (< cdmi 0) (setq cdi (rtos cdmi 2 2)))
(command "copy" bl "" "_non" (cdr(assoc 10 blm)) "_non" dm)
(if (and (wcmatch (cdr(assoc 0 (entget (entlast)))) "INSERT") (= (cdr(assoc 66 (entget (entlast)))) 1))
 	(setq el (entget (entnext (entlast)) )))
(if (wcmatch (cdr(assoc 0 (entget (entlast)))) "TEXT") (setq el (entget (entlast))) )
(entmod (subst (cons 1 cdi) (assoc 1 el) el))
(setq dmoc dm)
)
(setvar "Dimzin" oldim)
))
(princ)
)



<<

Filename: 243070_dcs.lsp
Tác giả: TaiNguyen79
Bài viết gốc: 243412
Tên lệnh: vantuan18
Xuất cao độ từ CAD sang Notpad hoặc Excel

- Mình đang phải giải quyết một đống cao độ và khoảng cách lẻ trong CAD, các cao độ và khoảng cách lẻ này của mình cái thì nằm theo phương ngang, cái thì theo phương đứng.
  Trên Forums cũng có nhiều lisp tương tự nhưng không giải quyết được bài toán của mình.
- Mình muốn nhờ các member cadviet.com viết...

>>

- Mình đang phải giải quyết một đống cao độ và khoảng cách lẻ trong CAD, các cao độ và khoảng cách lẻ này của mình cái thì nằm theo phương ngang, cái thì theo phương đứng.
  Trên Forums cũng có nhiều lisp tương tự nhưng không giải quyết được bài toán của mình.
- Mình muốn nhờ các member cadviet.com viết giúp lisp xuất các cao độ và khoảng cách lẻ này sang Notpad hoặc Excel.
 
- Cụ thể, file CAD mình up lên như sau :
+ Hàng bên trên là cao độ, bên dưới là khoảng cách lẻ tương ứng.
+ Hàng cao độ thì text theo phương đứng; Hàng K/c lẻ thì các text có cả theo phương đứng và phương ngang.
 
??? Bây giờ mình muốn có 1 lisp như sau :\
+ Chạy lệnh.
+ Quét chọn hàng cao độ (hoặc khoảng cách lẻ).
+ Lisp sẽ cho ra kết quả là các text trong file Notpad hoặc Excel theo dạng cột, hoặc hàng đều được. Quét chọn nhiều lần thì sẽ được nhiều cột; hàng trong cùng một file.
+ Lisp chạy liên tục cho đến khi nhấn Enter để kết thúc lệnh.
Link file : http://www.cadviet.com/upfiles/3/103675_vd.dwg

Như vầy đc không ?

(defun c:vantuan18 (/ f fl ss p1 p2) ;chon text theo goc roi ghi ra file
(if (findfile (setq f (getstring "\n<Ten FILE> xuat so lieu , Go <ENTER> neu khong luu : "))) (setq fl (open f "a")) (setq fl (open f "w")))
(while (setq p1 (getpoint "\nChon 2 diem xac dinh hang lay text :"))
(initget 1) (setq p2 (getpoint p1) ss (ssget "F" (list p1 p2) (list (cons 0 "TEXT"))) i 0)
(repeat (sslength ss) (prin1 (read (cdr (assoc 1 (entget (ssname ss i))))) fl) (princ " " fl) (setq i (1+ i)))
(write-line "" fl));while
(if fl (close fl))(princ))


Xuất ra file *.txt (notepad)
Chỉ cần pick 2 điểm là lsp tóm lấy rồi xuất ra.
Nếu tóm không đc thằng nào thì cũng xuống 1 dòng
<<

Filename: 243412_vantuan18.lsp
Tác giả: TaiNguyen79
Bài viết gốc: 243514
Tên lệnh: chu so songuyen chu coso
Lisp lọc text số nguyên và text có số thập phân.

Chào mọi người!
Vấn đề của mình như sau:
Trong bản vẽ của mình có 3 đối tượng text
1 là text chữ
2 là text số nguyên
3 là text số có số lẻ đằng sau
 
3 text này giờ đang cùng 1 layer và color giờ mình muốn tách rieng 3 text này thành 3 layer riêng biệt.
Mọi người viết giúp mình lsp...

>>

Chào mọi người!
Vấn đề của mình như sau:
Trong bản vẽ của mình có 3 đối tượng text
1 là text chữ
2 là text số nguyên
3 là text số có số lẻ đằng sau
 
3 text này giờ đang cùng 1 layer và color giờ mình muốn tách rieng 3 text này thành 3 layer riêng biệt.
Mọi người viết giúp mình lsp sau
Lệnh đầu tiên để tách text chữ là : LTC
Lệnh thứ 2 để tách text số nguyên là: LTN
Lệnh thứ 3 để tách text số có số lẻ là: LTP
 
ây là hình minh họa của mình
96857_h2_convent.jpg
Mong mọi người viết giúp mình, mình đang cần gấp!
Thanks all !

Của bạn đây :


;tach rieng chu va so
(defun c:chu_so (/ SS1 LopT LopN Count Eg)
(princ "\nChon cac chu ")
(while (null (setq SS1 (ssget (list (cons 0 "Text"))))) (princ "\nChua chon duoc chu "))
(if (= (setq LopT (getstring "\nNhap ten lop se chua cac chu ")) "")
(progn (if (null (tblsearch "layer" "so nguyen")) (command "layer" "N" "chu" "")) (setq LopT "chu")))
(if (= (setq LopN (getstring "\nNhap ten lop se chua cac so ")) "")
(progn (if (null (tblsearch "layer" "so nguyen")) (command "layer" "N" "so" "")) (setq LopN "so")))
(setq Count 0)
(repeat (sslength SS1)
(setq Eg (entget (ssname SS1 Count)))
(if (numberp (distof (cdr (assoc 1 eg))))
(setq Eg (subst (cons 8 lopN) (assoc 8 Eg) Eg))
(setq Eg (subst (cons 8 LopT) (assoc 8 Eg) Eg)));if
(setq Count (1+ Count))
(entmod Eg));repeat
(princ))
;;---------------------
;;tach lay cac chu mang gia tri la so nguyen
(defun c:songuyen (/ SS1 Lopsn Count Eg)
(princ "\nChon cac chu ")
(while (null (setq SS1 (ssget (list (cons 0 "Text"))))) (princ "\nChua chon duoc chu "))
(if (= (setq Lopsn (getstring "\nNhap ten lop se chua cac so nguyen chon duoc : ")) "")
(progn (if (null (tblsearch "layer" "so nguyen")) (command "layer" "N" "so nguyen" ""))(setq Lopsn "so nguyen")));if
(setq Count 0)
(repeat (sslength SS1)
(setq Eg (entget (ssname SS1 Count)) ndung (cdr (assoc 1 eg)))
(if (and (numberp (distof ndung)) (= (type (read ndung) ) 'INT))
(setq Eg (subst (cons 8 lopsn) (assoc 8 Eg) Eg)));end if
(setq Count (1+ Count))
(entmod Eg));repeat
(princ))
;;---------------------
;;Tach lay chu co so bat dau
(defun c:chu_coso (/ SS1 LopT Count Eg)
(princ "\nChon cac chu ")
(while (null (setq SS1 (ssget (list (cons 0 "Text"))))) (princ "\nChua chon duoc chu "))
(if (= (setq LopT (getstring "\nNhap ten lop se chua cac chu ")) "")
(progn (if (null (tblsearch "layer" "so nguyen")) (command "layer" "N" "Chu co so bat dau" ""))
(setq LopT "Chu co so bat dau")));end if
(setq Count 0)
(repeat (sslength SS1)
(setq Eg (entget (ssname SS1 Count)))
(if (not (numberp (distof (cdr (assoc 1 eg)))))
(if (numberp (distof (substr (cdr (assoc 1 eg)) 1 1)))
(setq Eg (subst (cons 8 lopT) (assoc 8 Eg) Eg))))
(setq Count (1+ Count))(entmod Eg))(princ))

Dùng lệnh chu_so để tách riêng chữ và số.
Dùng lệnh songuyen để lấy số nguyên

:( Nếu muốn chọn địa chỉ thửa đất thì dùng lệnh chu_coso để tách lấy những chũ có số bắt đầu

P/S : Bạn có thể cứ bấm enter không cần trả lời . chương trình sẽ tự tạo ra các lớp tạm để chứa các chữ tìm đc
<<

Filename: 243514_chu_so_songuyen_chu_coso.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 243573
Tên lệnh: ha
Lisp lọc text số nguyên và text có số thập phân.

Lisp tách 3 đối tượng của layer thửa đất thành 3 layer khác nhau: symbol -> "LOAIDAT" ; integer -> "SOTHUA" ; real -> "DIENTICH".

;; Tach 3 doi tuong cua layer thua dat thanh 3 layer khac nhau: symbol, integer, real.
;; Doan Van Ha - CadViet.com - ngay 01/8/2013
(defun C:HA ( / MakeLayer txt)
 (defun MakeLayer (name color)
  (if (not (tblsearch "Layer" name))
   (entmakex (list '(0 . "LAYER") (cons 100...
>>

Lisp tách 3 đối tượng của layer thửa đất thành 3 layer khác nhau: symbol -> "LOAIDAT" ; integer -> "SOTHUA" ; real -> "DIENTICH".

;; Tach 3 doi tuong cua layer thua dat thanh 3 layer khac nhau: symbol, integer, real.
;; Doan Van Ha - CadViet.com - ngay 01/8/2013
(defun C:HA ( / MakeLayer txt)
 (defun MakeLayer (name color)
  (if (not (tblsearch "Layer" name))
   (entmakex (list '(0 . "LAYER") (cons 100 "AcDbSymbolTableRecord") (cons 100 "AcDbLayerTableRecord") (cons 2 name) (cons 70 0) (cons 62 color)))))
 (mapcar '(lambda(x y) (MakeLayer x y)) (list "LOAIDAT" "SOTHUA" "DIENTICH") '(1 2 3))
 (princ "\nChon cac doi tuong Text can phan lop...")
 (ssget '((0 . "TEXT")))
 (vlax-for obj (vla-get-activeselectionset (vla-get-ActiveDocument (vlax-get-acad-object)))
  (if (= (setq txt (type (read (cdr (assoc 1 (entget (vlax-vla-object->ename obj))))))) 'SYM)
   (progn (vla-put-Layer obj "LOAIDAT") (vla-put-Color obj 1))
   (if (= txt 'INT)
    (progn (vla-put-Layer obj "SOTHUA") (vla-put-Color obj 2))
    (progn (vla-put-Layer obj "DIENTICH") (vla-put-Color obj 3))))))
 

<<

Filename: 243573_ha.lsp
Tác giả: lyky
Bài viết gốc: 243586
Tên lệnh: dm
[Nhờ chỉnh sửa] Lisp thay đổi màu layer

nhờ các anh sửa giúp em để khi gõ lệnh => Pick chọn đối tượng (theo Layer) => thì tất cả các đối tượng thuộc Layer đó sẽ chuyển thành màu số 4 (Cyan).
cảm ơn các anh!

(defun c:dm ( / layy m ss ss1)
(princ "\nChon doi tuong thuoc layer ban muon doi...
>>

nhờ các anh sửa giúp em để khi gõ lệnh => Pick chọn đối tượng (theo Layer) => thì tất cả các đối tượng thuộc Layer đó sẽ chuyển thành màu số 4 (Cyan).
cảm ơn các anh!

(defun c:dm ( / layy m ss ss1)
(princ "\nChon doi tuong thuoc layer ban muon doi mau:\n")
(setq ss (ssget)) (setq layy (cdr (assoc 8 (entget (ssname ss 0)))))
(setq ss1 (ssget "X" (list (cons 8 layy))))
(setq m (getint "\nChon mau muon doi <4>:\n"))
(if (= m nil) (setq m 4))
(command "_.change" ss1 "" "p" "c" m "")
(princ))

Xài tạm bạn nhé, bẫy lỗi và né lỗi gì gì đó thì bạn tự bổ xung vào nhé!  :D


<<

Filename: 243586_dm.lsp

Trang 137/330

137