Jump to content
InfoFile
Tác giả: KangKung
Bài viết gốc: 232600
Tên lệnh: cvp
lisp chia viewport trong layout

Thanks ketxu. Một ý kiến hay.

Nhân đây mình post thêm version mới của Lisp chia Viewport. Sơ qua về Lisp mới này:

1. Cắt viewport theo phương ngang (nếu chọn điểm chia nằm trên cạnh ngang)

2. Cắt theo phương thẳng đứng (nếu chọn điểm chia nằm trên cạnh đứng)

3. Cắt viewport thành 4 viewport nếu chọn điểm cắt không thỏa mãn cả 2 điều kiện...

>>

Thanks ketxu. Một ý kiến hay.

Nhân đây mình post thêm version mới của Lisp chia Viewport. Sơ qua về Lisp mới này:

1. Cắt viewport theo phương ngang (nếu chọn điểm chia nằm trên cạnh ngang)

2. Cắt theo phương thẳng đứng (nếu chọn điểm chia nằm trên cạnh đứng)

3. Cắt viewport thành 4 viewport nếu chọn điểm cắt không thỏa mãn cả 2 điều kiện trên.

4. Có thể mở rộng viewport bằng cách chọn điểm cắt nằm ngoài khung viewport gốc.

Tất cả đều dùng chung 1 lệnh là CVP và kết quả sẽ ra 2 hoặc 4 viewport tùy thuộc vào vị trí chọn điểm chia. Lisp này thỏa mãn được nhiều nhu cầu chia khác nhau tuy nhiên cách chọn điểm cắt sẽ phải chính xác hơn Lisp #2. Các bạn xem hình minh họa dưới đây rồi Test thử xem có lỗi gì không. Thanks

;==========LISP CHIA 1 VIEWPORT THANH 2 VIEWPORT================
;==================KANGKUNG 21/04/2013==========================
;UPDATE THEM PHAN CHIA THEO CHIEU NGANG, DOC, HOAC THANH 4 VPORT
(defun C:CVP ( / Viewport vpdata centerpoint VP_Width VP_Height pt cPWp utObj mPt xPt lbCon trCon verLst tyle
	      pt1 pt2 pt3 pt4 pt1A pt1B pt2A pt2B pt3A pt3B pt4A pt4B P1 P2 P3 P4 P5 list_VP kd kn layer)
  (vl-load-com)
  (if (= (getvar "TILEMODE") 0)
    (progn
      (if (/= (getvar "cvport") 1) (command "PSPACE"))
      (command "UNDO" "BE")
      (while (setq Viewport (ssget '((0 . "VIEWPORT"))))
	(setq vpdata(entget (ssname Viewport 0)))
	(setq layer(cdr(assoc 8 vpdata)))
	(setq n(cdr(assoc 69 vpdata)))
	(command "MSPACE") (setvar "cvport" n) (command "PSPACE")
	(setq centerpoint(cdr(assoc 10 vpdata))) (setq VP_Width(cdr(assoc 40 vpdata))) (setq VP_Height(cdr(assoc 41 vpdata)))
	(setq pt(getpoint "\n Chon diem chia: "))
	(setq os(getvar "OSMODE"))
	(setvar "OSMODE" 0)
	(if (not dist) (setq dist(atof(lisped "Nhap khoang cach giua cac Vport vao day.")))
	  (setq dist(atof(lisped (rtos dist 2 2)))))
	(setq cPWp(vlax-ename->vla-object (ssname Viewport 0))
	      utObj(vla-get-Utility(vla-get-ActiveDocument(vlax-get-acad-Object))))
	(vla-GetBoundingBox cPWp 'mPt 'xPt)
	(setq lbCon(vla-TranslateCoordinates utObj mPt acPaperSpaceDCS acDisplayDCS :vlax-false)
	      trCon(vla-TranslateCoordinates utObj xPt acPaperSpaceDCS acDisplayDCS :vlax-false))
	(if(and lbCon trCon) (setq verLst(list (vlax-safearray->list(vlax-variant-value lbCon)) (vlax-safearray->list(vlax-variant-value trCon)))))
	(setq tyle(/ VP_Width (- (car(cadr verLst)) (car(car verLst)))))
	(setq pt1(list (- (car centerpoint) (/ VP_Width 2)) (+ (cadr centerpoint) (/ VP_Height 2)))
	      pt2(list (+ (car centerpoint) (/ VP_Width 2)) (+ (cadr centerpoint) (/ VP_Height 2)))
	      pt3(list (+ (car centerpoint) (/ VP_Width 2)) (- (cadr centerpoint) (/ VP_Height 2)))
	      pt4(list (- (car centerpoint) (/ VP_Width 2)) (- (cadr centerpoint) (/ VP_Height 2)))
	      pt1A pt1
	      pt1B(list (+ (car pt1) (abs(- (car pt1) (car pt)))) (- (cadr pt1) (abs(- (cadr pt1) (cadr pt)))))
	      pt2A(list (+ (car pt1) (abs(- (car pt1) (car pt))) dist) (cadr pt1))
	      pt2B(list (+ (car pt2A) (abs(- (car pt2) (car pt)))) (cadr pt1B))
	      pt3A(list (car pt2A) (- (cadr pt2B) dist))
	      pt3B(list (car pt2B) (- (cadr pt3A) (abs(- (cadr pt3) (cadr pt)))))
	      pt4A(list (car pt1A) (cadr pt3A))
	      pt4B(list (car pt1B) (cadr pt3B)))
	(setq P1(list (car (car verLst)) (cadr (cadr verLst)))
	      P2(cadr verLst)
	      P3(list (car (cadr verLst)) (cadr (car verLst)))
	      P4(car verLst)
	      P5(list (+ (car P4) (/ (- (car pt) (car pt4)) tyle))
		      (+ (cadr P4) (/ (- (cadr pt) (cadr pt4)) tyle))))
	(if (= (car pt) (car pt1)) (setq kn 1) (setq kn 0))
	(if (= (cadr pt) (cadr pt1)) (setq kd 1) (setq kd 0))
	(setq list_VP(list (list pt1A pt1B P1 P5)
			   (list pt2A pt2B P2 P5)
			   (list pt3A pt3B P3 P5)
			   (list pt4A pt4B P4 P5)))
	(foreach VP list_VP
	  (if (/= (* (- (car (car VP)) (car (cadr VP))) (- (cadr (car VP)) (cadr (cadr VP)))) 0)
	    (progn
	      (command "MVIEW" (car VP) (cadr VP))
	      (command "MOVE" (entlast) "" (car VP) (list (- (car (car VP)) (* kn dist)) (+ (cadr (car VP)) (* kd dist))))
	      (command "MSPACE") (command "ZOOM" (caddr VP) (cadddr VP)) (command "PSPACE")
	      (vla-put-layer (vlax-ename->vla-object (entlast)) layer)
	      (vla-put-displaylocked (vlax-ename->vla-object (entlast)) :vlax-true)
	      )
	    )
	  )
	(command "ERASE" (ssname Viewport 0) "")
	(setvar "OSMODE" os)
	(command "UNDO" "END")
	)
      )
    (alert "Chuyen sang Layout truoc khi chay Lisp")
    )
  )
(defun *error* (msg)
  (if (/= os nil) (setvar "OSMODE" os))
  (command "UNDO" "END")
  )
(princ "\n              KangKung - 21/04/2013\n")
(princ "\n           Nhap CVP de chay chuong trinh\n") 

 

Minh họa tí cho sinh động:

71162_vp1_1.jpg71162_vp2_1.jpg


<<

Filename: 232600_cvp.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 232694
Tên lệnh: ha
Bạn nào có ý tưởng nào hay về thuật toán để giải quyết vấn đề này không ?

1) Cảm ơn bác Hà vote :).

2) Cái này ko ý kiến, có thể CAD của bác bị lỗi gì đó.

3) Mình chưa test nhiều trường hợp, nhưng theo yêu cầu đầu bài thì Hội tụ thì ko phải là ko thể. Bác có thể up bản vẽ trường hợp Bác cho là ko hộ tụ để mình ngâm cứu.

Bạn thử test bản vẽ này xem....

>>

1) Cảm ơn bác Hà vote :).

2) Cái này ko ý kiến, có thể CAD của bác bị lỗi gì đó.

3) Mình chưa test nhiều trường hợp, nhưng theo yêu cầu đầu bài thì Hội tụ thì ko phải là ko thể. Bác có thể up bản vẽ trường hợp Bác cho là ko hộ tụ để mình ngâm cứu.

Bạn thử test bản vẽ này xem. Tôi test nó toàn báo lỗi thế này:

Command: T1

Xac dinh chieu dai MN: <900>300

Chon duong cong tich luy:

Command:

Point is directly on an object.

Point is directly on an object.

Point is directly on an object.

Point is directly on an object.; error: Automation Error. Object was erased

 

Còn đây là lisp tôi đã viết: lisp cân bằng diện tích của đường cong tích lũy.

Tuy nhiên cần khẳng định rằng: tùy thuộc dữ liệu đầu vào mà bài toán này có thể hội tụ hoặc không.

 

; Doan Van Ha - CADViet.com - Ngay 22/4/2013
; Chuc nang: C©n b»ng diÖn tich cña ®­êng cong tich luy.
(defun C:HA( / dung len giaso sscp CU lst G P Q M M1 N N1 MP Px GM GN S1 S2 S3 S4 ss12 ss34)
 (setq len (getdist "\nNhap khoang cach MN: "))
 (setq sscp (getreal "\nSai so toi da <0.05>: "))
 (if (not sscp) (setq sscp 0.05)) ;MÆc ®inh 0.05 (tøc 5%). Sai sè cµng nhá th× ch¹y cµng chËm, vµ nhieu khi kh«ng tinh to¸n ®­îc.
 (setq giaso (* len sscp 0.2))
 (setq CU (car (entsel "\nChon duong cong tich luy dang Pline: ")))
 (setq lstCU (vl-sort (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget CU))) '(lambda (e1 e2) (< (car e1) (car e2)))))
 (setq MP (polar (setq G (Pymin lstCU)) pi len)) ; lÊy MP & G
 (setq P (vlax-curve-getStartpoint CU) Q (vlax-curve-getEndpoint CU)) (if (< (cadr Q) (cadr P)) (setq P Q)) ; lÊy ®iÓm thÊp nhÊt
 (if (< (car P) (car Q)) (setq lst (Giao lstCU P (polar P 0 1E8))) (setq lst (Giao lstCU Q (polar Q 0 1E8)))) ; lÊy list point giao víi Curve
 (setq P (car lst) Q (last lst)) (if (< (car Q) (car P)) (setq Px P P Q Q Px)) ; lÊy ®iÓm bªn tr¸i
 (if (> (car MP) (car P)) (setq P (car (Giao lstCU MP (polar MP (/ pi 2) 1E8)))))
 (while (and (not dung) (> (cadr P) (+ giaso (cadr G))))
  (setq lst (Giao lstCU (setq P (polar P (/ pi -2) giaso)) (polar P 0 1E8)))
  (setq P (car lst) Q (last lst)) (if (< (car Q) (car P)) (setq Px P P Q Q Px)) ; lÊy P vµ Q
  (setq M (list (+ giaso (car P)) (cadr G)) N (polar M 0 len))
  (while (and (not dung) (< (+ giaso (car M)) (car G)) (< (+ giaso (car N)) (car Q)))
   (setq M (polar M 0 giaso) M1 (list (car M) (cadr P)) N (polar M 0 len) N1 (list (car N) (cadr M1))) ; lÊy M, M1, N, N1
   (setq GM (car (Giao lstCU M M1)) GN (car (Giao lstCU N N1))) ; lÊy GM, GN
   (setq S1 (PointArea (cons M1 (LST_P lstCU P GM))))
   (setq S2 (PointArea (cons M (LST_P lstCU GM G))))
   (setq S3 (PointArea (cons N (LST_P lstCU G GN))))
   (setq S4 (PointArea (cons N1 (LST_P lstCU GN Q))))
   (setq ss12 (abs (/ (- S1 S2) (* 0.5 (+ S1 S2)))))
   (setq ss34 (abs (/ (- S3 S4) (* 0.5 (+ S3 S4)))))
   (if (<= (max ss12 ss34) sscp) (progn (LWPoly (list P M1 M N N1 Q)) (setq dung T)))))
 (if (not dung) (alert "Hoac sai so qua nho; \nHoac khoang cach MN qua lon, khong hoi tu nen khong giai duoc.")))
(defun Giao(lst p1 p2 / z pg lst1)
 (setq z -1)
 (repeat (1- (length lst))
  (if (setq pg (inters p1 p2 (nth (setq z (1+ z)) lst) (nth (1+ z) lst))) (setq lst1 (cons pg lst1))))
 lst1)
(defun PointArea (lst)
 (/ (abs (apply '+ (mapcar (function (lambda (a B) (- (* (car a) (cadr B)) (* (car B) (cadr a))))) lst (append (cdr lst) (list (car lst)))))) 2.0))
(defun LST_P(lst p1 p2 / pt lst lst1)
 (setq lst1 (vl-remove-if '(lambda (pt) (or (< (car pt) (car p1)) (> (car pt) (car p2)))) (cons p1 (reverse (cons p2 (reverse lst)))))))
(defun Pymin(lst)
 (setq pt (car lst)) (foreach px (cdr lst) (if (< (cadr px) (cadr pt)) (setq pt px))) pt)
(defun LWPoly(lst)
 (entmakex (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 (length lst))) 
   (mapcar (function (lambda (p) (cons 10 p))) lst))))

<<

Filename: 232694_ha.lsp
Tác giả: nataca
Bài viết gốc: 93449
Tên lệnh: rgt
viết lisp thống kê bản vẽ

Chiến trường đã tan, em trở về với việc nhà bề bộn. Xin lỗi bác vì chưa trả lời được bác sớm.
Đây là đoạn Code ví dụ về Link giữa 2 thuộc tính của Block (lấy chính từ lisp này)


Filename: 93449_rgt.lsp
Tác giả: hatieu
Bài viết gốc: 108742
Tên lệnh: direc comp2
Heya i am for the first time here. I found this board and I find It really useful & it helped me out much. I hope to give something back and aid others like you helped me.
Chưa ai giúp em à!
Em có lisp này nhưng chỉ thực hiện được phần nhỏ của công việc trên.Anh xem có phát triển lên được như ý ban đầu của em không

Filename: 108742_direc_comp2.lsp
Tác giả: hatieu
Bài viết gốc: 113339
Tên lệnh: ppp
Nhờ viết hộ lisp vẽ composite panel
Phù....!!!!Vẽ nhiều composite panel mệt quá, mà vẫn chưa tìm ra giải pháp. Rất mong các bác giúp.
Đây là em sưu tầm được trên mạng. Nhưng vẫn chưa theo ý của em.Cái khó nhất là chỗ góc lượn. :lol:


Em muốn thực hiện vẽ được như theo bản vẽ bên dưới.
File Composite panel.dwg
>>
Phù....!!!!Vẽ nhiều composite panel mệt quá, mà vẫn chưa tìm ra giải pháp. Rất mong các bác giúp.
Đây là em sưu tầm được trên mạng. Nhưng vẫn chưa theo ý của em.Cái khó nhất là chỗ góc lượn. :lol:


Em muốn thực hiện vẽ được như theo bản vẽ bên dưới.
File Composite panel.dwg

http://www.cadviet.com/upfiles/3/1_20.jpg
http://www.cadviet.com/upfiles/3/2_11.jpg
<<

Filename: 113339_ppp.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 232917
Tên lệnh: vdtd
Chuyển tọa độ điểm từ file excel sang cad

Chào cả nhà. Mình có một file 2 cột ( tương ứng tọa độ X,Y) trên excel. Mình muốn chuyển nó thành các tọa độ điểm trong autocad( dạng chấm để có thể nhìn thấy hình dáng của đồ thị). Nhờ các bạn hướng dẫn giúp mình. File upload bên dưới( tọa độ X, Y có được từ thí nghiệm, mình muốn các tọa độ...

>>

Chào cả nhà. Mình có một file 2 cột ( tương ứng tọa độ X,Y) trên excel. Mình muốn chuyển nó thành các tọa độ điểm trong autocad( dạng chấm để có thể nhìn thấy hình dáng của đồ thị). Nhờ các bạn hướng dẫn giúp mình. File upload bên dưới( tọa độ X, Y có được từ thí nghiệm, mình muốn các tọa độ điểm này hiển thị trong autocard dưới dạng điểm(chấm))

Cảm ơn mọi người rất nhiều.http://www.cadviet.com/upfiles/3/118868_dothi.rar

Hề hề hề,

Khỏi chấm mút chi cả, mình viết lisp vẽ luôn đồ thị cho bạn bằng đường pline nè. không khoái dùng thì quẳng nó vô sọt rác cũng không sao.

Hề hề hề.

http://www.cadviet.com/upfiles/3/5194_vedothidiem.lsp

 

 

(defun c:vdtd ( / oldos fn f plst str p lst n)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(command "undo" "be")
(setq  fn (getfiled "Select Data File" "" "csv" 0)
            f (open fn "r")  ) 
(setq plst (list))
(while (/= (setq str (read-line f)) nil) 
          (setq lst (separate str (chr 44)))
          (setq p (list (atof (cadr lst)) (atof (car lst))))
          (setq plst (append plst (list p)))        
)
(setq plst (cdr plst))
(setq n (length plst))
(command "pline"
      (foreach p plst
            (command p)
      )
       "")
(command "undo" "e")
(setvar "osmode" oldos)
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun Separate (S sym / i L ch)
(setq i 0 L nil)
(while (< i (strlen S))
      (setq i (1+ i) ch (substr S i 1))
      (if (= ch sym) (progn
(setq
     L (append L (list (substr S 1 (- i 1))))
     S (substr S (1+ i) (- (strlen S) i))
     i 0
)
      ))
)
(append L (list S))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

<<

Filename: 232917_vdtd.lsp
Tác giả: Acad2013
Bài viết gốc: 232929
Tên lệnh: e2p
Chuyển tọa độ điểm từ file excel sang cad

Nếu không quen dùng *.dll bạn có thể dùng Lisp này...

Gõ lệnh: e2p xuất hiện hộp thoại, sau đó bạn chọn file excel có chứa các tập hợp điểm của bạn.

 

(defun Add_point(ExcelFile / xlapp ex-wb CurReg sheet MaxRow cell ri mspace xx yy)
(VL-LOAD-COM)
(setq xlapp (vlax-create-object "Excel.Application"))
;(setq ex (vlax-put-property xlapp "Visible" nil))
(setq ex-wb (vlax-invoke-method (vlax-get-property xlapp...

>>

Nếu không quen dùng *.dll bạn có thể dùng Lisp này...

Gõ lệnh: e2p xuất hiện hộp thoại, sau đó bạn chọn file excel có chứa các tập hợp điểm của bạn.

 

(defun Add_point(ExcelFile / xlapp ex-wb CurReg sheet MaxRow cell ri mspace xx yy)
(VL-LOAD-COM)
(setq xlapp (vlax-create-object "Excel.Application"))
;(setq ex (vlax-put-property xlapp "Visible" nil))
(setq ex-wb (vlax-invoke-method (vlax-get-property xlapp 'WorkBooks) 'Open ExcelFile))
(setq CurReg (vlax-get-property (vlax-get-property
(vlax-get-property xlapp "ActiveSheet") "Range" "A1") "CurrentRegion")
)
(setq MaxRow (vlax-get-property (vlax-get-property CurReg "Rows") "Count"))
(setq sheet (vlax-get-property ex-wb "ActiveSheet"))
(setq cell (vlax-get-property sheet "Cells"))
(setq ri 2)
(setq mspace (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
(while (<= ri MaxRow)
(setq xx (vlax-variant-value (vlax-get-property (vlax-variant-value (vlax-get-property cell "item" ri 1)) 'Value2)))
(setq yy (vlax-variant-value (vlax-get-property (vlax-variant-value (vlax-get-property cell "item" ri 2)) 'Value2)))
(vla-AddPoint mspace (vlax-3d-point xx yy))
(setq ri (1+ ri))
)
(vlax-invoke-method (vlax-get-property xlapp "ActiveWorkbook") 'Close :vlax-False)
(vlax-invoke-method xlapp 'Quit)
(vlax-release-object xlapp)(gc)
(setq xlapp nil)
(princ)
(princ)
)
(defun c:e2p(/ ExcelFile)
(setq ExcelFile (getfiled "Ch\U+1ECDn File Excel" (getvar "DWGPREFIX") "Xlsx;Xls" 8))
(if ExcelFile (Add_point ExcelFile))
)


<<

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

Tue_NV đã tách chuỗi cho bạn xong. Việc xuất chuỗi , viết Text -> Hy vọng bạn làm được
Kết quả tách chuỗi ở biến C1; C2 và C3
Lisp chạy ứng với Text có kí tự dạng * = #*
như bản vẽ bạn đã post.
Đây là code

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

Mạn phép bác Tue_NV, mình sử dụng lisp của bác bổ sung thêm phần ghi lại text mới vào vị trí gần đúng với text cũ cho bạn ceddtu . Việc ghi lại cho hoàn toàn chính xác là vấn đề khá khó chịu nên mình chỉ dừng ở đây. Lý do là do số lượng các ký tự khá khác nhau và khoảng cách giữa các ký tự cũng hoàn toàn không giống nhau. Mình đã tận dụng đến thông số width factor nhưng chỉ đạt...
>>

Mạn phép bác Tue_NV, mình sử dụng lisp của bác bổ sung thêm phần ghi lại text mới vào vị trí gần đúng với text cũ cho bạn ceddtu . Việc ghi lại cho hoàn toàn chính xác là vấn đề khá khó chịu nên mình chỉ dừng ở đây. Lý do là do số lượng các ký tự khá khác nhau và khoảng cách giữa các ký tự cũng hoàn toàn không giống nhau. Mình đã tận dụng đến thông số width factor nhưng chỉ đạt gần đúng. Hy vọng bạn ceddtu hài lòng.


@ Bác Tue_NV: Tiện đây bác cho hỏi luôn cái vụ ký tự # là thay cho các chữ số hử bác??? Mình lọ mọ mà chả tìm thấy chỗ nào nói về cách sử dụng các ký tự như vậy trong lisp cả bác ạ. Nếu có tài liệu, bác post lên giùm cho anh em được mót với.....
<<

Filename: 114755_tchu.lsp
Tác giả: thiep
Bài viết gốc: 64887
Tên lệnh: hb hatchb
Viết Lisp theo yêu cầu

Xin lỗi, thiep nhầm, nó là hatchb.lsp:

Lisp rất hay ở chỗ khôi phục lại bound cho hatch kể cả đường SPLINE, ARC, CIRCLE...

Không hiểu chiều nay không upload được, bạn copy từ codebox vậy. Nếu có lỗi gì, ngày mai mạng tốt, mình sẽ up vậy.

Filename: 64887_hb_hatchb.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 232964
Tên lệnh: bx
Lisp Bind Xref các bản vẽ đang mở

1). Bạn post bài nhiều rồi mà vẫn post sai quy định của box autolisp nên rất dễ bị mod xóa. Chú ý lần sau nhé!

2). Thử cái này xem, dùng để bind các xref trong modelspace của bản vẽ hiện hành.

 

(defun C:BX(/ tmp)
 (vl-load-com)
 (vlax-for objs (vla-get-ModelSpace (vla-get-activedocument (vlax-get-acad-object)))
  (if
   (and
    (= (vla-get-ObjectName...
>>

1). Bạn post bài nhiều rồi mà vẫn post sai quy định của box autolisp nên rất dễ bị mod xóa. Chú ý lần sau nhé!

2). Thử cái này xem, dùng để bind các xref trong modelspace của bản vẽ hiện hành.

 

(defun C:BX(/ tmp)
 (vl-load-com)
 (vlax-for objs (vla-get-ModelSpace (vla-get-activedocument (vlax-get-acad-object)))
  (if
   (and
    (= (vla-get-ObjectName objs) "AcDbBlockReference")
    (vlax-property-available-p objs 'Path)
    (setq tmp (vla-Item  (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-Acad-Object))) (vla-get-Name objs)))
    (not (assoc 71 (entget (tblobjname "block" (vla-get-Name objs))))))
   (vla-Bind tmp :vlax-true)))
 (princ))

<<

Filename: 232964_bx.lsp
Tác giả: Acad2013
Bài viết gốc: 233099
Tên lệnh: dtm
Nho sua lips

Lisp này có chức năng tương tự, và phần số lẻ là 1 số. Bạn dùng thử nhé.

 

(defun c:dtm (/ pick sset-obj ob area)
(vl-load-com)
(command ".undo" "be")
(setvar "CMDECHO" 0)
(setq os (getvar "OSMODE"))
(setvar "OSMODE" 0)
(setq pick (getpoint "\n>> Ch\U+1ECDn \U+0111i\U+1EC3m trong vùng c\U+1EA7n tính di\U+1EC7n tích: "))
(while pick
(command ".boundary" pick "" ^C^C)
(setq set-obj (ssget "_L"))
(setq ob...

>>

Lisp này có chức năng tương tự, và phần số lẻ là 1 số. Bạn dùng thử nhé.

 

(defun c:dtm (/ pick sset-obj ob area)
(vl-load-com)
(command ".undo" "be")
(setvar "CMDECHO" 0)
(setq os (getvar "OSMODE"))
(setvar "OSMODE" 0)
(setq pick (getpoint "\n>> Ch\U+1ECDn \U+0111i\U+1EC3m trong vùng c\U+1EA7n tính di\U+1EC7n tích: "))
(while pick
(command ".boundary" pick "" ^C^C)
(setq set-obj (ssget "_L"))
(setq ob (vlax-ename->vla-object (ssname set-obj 0)))
(setq area (rtos (vla-get-area ob) 2 1))
(command ".erase" set-obj "" ^C^C)
(command ".text" "J" "MC" pick #ct1_height 0 area)
(setq pick (getpoint "\n>> Ch\U+1ECDn \U+0111i\U+1EC3m trong vùng c\U+1EA7n tính di\U+1EC7n tích: "))
)

(setvar "OSMODE" os)
(command ".undo" "e")
(princ)
(princ)

)


<<

Filename: 233099_dtm.lsp
Tác giả: Lucky me
Bài viết gốc: 233162
Tên lệnh: test+nil
[Đã xong] Lisp chọn nhiều file bằng dialog (tương tự hàm getfiled)

Thanks bác Doan Van Ha đã chia sẽ Lisp. Tôi cũng sưu tầm được Lisp tương tự như của bác và post lên để anh em nghiên cứu.

;;------------------=={ Get Files Dialog }==------------------;;
;;                                                            ;;
;;  An analog of the 'getfiled' function for multiple files.  ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2013 -...
>>

Thanks bác Doan Van Ha đã chia sẽ Lisp. Tôi cũng sưu tầm được Lisp tương tự như của bác và post lên để anh em nghiên cứu.

;;------------------=={ Get Files Dialog }==------------------;;
;;                                                            ;;
;;  An analog of the 'getfiled' function for multiple files.  ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2013 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  title   - String specifying the dialog box label.         ;;
;;  default - Default directory; can be a null string ("")    ;;
;;  ext     - Filename extension filter (e.g. "dwg;lsp")      ;;
;;------------------------------------------------------------;;
;;  Returns:  List of selected files, else nil                ;;
;;------------------------------------------------------------;;
;;  Version 1.2    -    18-04-2013                            ;;
;;------------------------------------------------------------;;

(defun LM:GetFiles ( title default ext / *error* dch dcl des dir dirdata lst rtn )

    (defun *error* ( msg )
        (if (= 'file (type des))
            (close des)
        )
        (if (and (= 'int (type dch)) (< 0 dch))
            (unload_dialog dch)
        )
        (if (and (= 'str (type dcl)) (findfile dcl))
            (vl-file-delete dcl)
        )
        (if (and msg (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")))
            (princ (strcat "\nError: " msg))
        )
        (princ)
    )    
    
    (if
        (and
            (setq dcl (vl-filename-mktemp nil nil ".dcl"))
            (setq des (open dcl "w"))
            (progn
                (foreach x
                   '(
                        "lst : list_box"
                        "{"
                        "    width = 40.0;"
                        "    height = 20.0;"
                        "    fixed_width = true;"
                        "    fixed_height = true;"
                        "    alignment = centered;"
                        "    multiple_select = true;"
                        "}"
                        ""
                        "but : button"
                        "{"
                        "    width = 20.0;"
                        "    height = 1.8;"
                        "    fixed_width = true;"
                        "    fixed_height = true;"
                        "    alignment = centered;"
                        "}"
                        ""
                        "getfiles : dialog"
                        "{"
                        "    key = \"title\"; spacer;"
                        "    : row"
                        "    {"
                        "        alignment = centered;"
                        "        : edit_box { key = \"dir\"; label = \"Folder:\"; }"
                        "        : button"
                        "        {"
                        "            key = \"brw\";"
                        "            label = \"Browse\";"
                        "            fixed_width = true;"
                        "        }"
                        "    }"
                        "    spacer;"
                        "    : row"
                        "    {"
                        "        : column"
                        "        {"
                        "            : lst { key = \"box1\"; }"
                        "            : but { key = \"add\" ; label = \"Add Files\"; }"
                        "        }"
                        "        : column {"
                        "            : lst { key = \"box2\"; }"
                        "            : but { key = \"del\" ; label = \"Remove Files\"; }"
                        "        }"
                        "    }"
                        "    spacer; ok_cancel;"
                        "}"
                    )
                    (write-line x des)
                )
                (setq des (close des))
                (< 0 (setq dch (load_dialog dcl)))
            )
            (new_dialog "getfiles" dch)
        )
        (progn
            (setq ext (LM:getfiles:str->lst (strcase ext) ";"))
            (set_tile "title" (if (= "" title) "Select Files" title))
            (set_tile "dir"
                (setq dir
                    (LM:getfiles:fixdir
                        (if (or (= "" default) (not (vl-file-directory-p (LM:getfiles:fixdir default))))
                            (getvar 'dwgprefix)
                            default
                        )
                    )
                )
            )
            (setq lst (LM:getfiles:updatefilelist dir ext nil))
            (mode_tile "add" 1)
            (mode_tile "del" 1)

            (action_tile "brw"
                (vl-prin1-to-string
                   '(if (setq tmp (LM:getfiles:browseforfolder "" nil 512))
                        (setq lst (LM:getfiles:updatefilelist (set_tile "dir" (setq dir tmp)) ext rtn)
                              rtn (LM:getfiles:updateselected dir rtn)
                        )                              
                    )
                )
            )

            (action_tile "dir"
                (vl-prin1-to-string
                   '(if (= 1 $reason)
                        (setq lst (LM:getfiles:updatefilelist (set_tile "dir" (setq dir (LM:getfiles:fixdir $value))) ext rtn)
                              rtn (LM:getfiles:updateselected dir rtn)
                        )
                    )
                )
            )

            (action_tile "box1"
                (vl-prin1-to-string
                   '(
                        (lambda ( / itm tmp )
                            (setq itm (mapcar '(lambda ( n ) (nth n lst)) (read (strcat "(" $value ")"))))
                            (if (= 4 $reason)
                                (cond
                                    (   (equal '("..") itm)
                                        (setq lst (LM:getfiles:updatefilelist (set_tile "dir" (setq dir (LM:getfiles:updir dir))) ext rtn)
                                              rtn (LM:getfiles:updateselected dir rtn)
                                        )
                                    )
                                    (   (and
                                            (not (vl-filename-extension (car itm)))
                                            (vl-file-directory-p (setq tmp (LM:getfiles:checkredirect (strcat dir "\\" (car itm)))))
                                        )
                                        (setq lst (LM:getfiles:updatefilelist (set_tile "dir" (setq dir tmp)) ext rtn)
                                              rtn (LM:getfiles:updateselected dir rtn)
                                        )
                                    )
                                    (   (setq rtn (LM:getfiles:sort (append rtn (mapcar '(lambda ( x ) (strcat dir "\\" x)) itm)))
                                              rtn (LM:getfiles:updateselected dir rtn)
                                              lst (LM:getfiles:updatefilelist dir ext rtn)
                                        )
                                    )
                                )
                                (if (vl-some 'vl-filename-extension itm)
                                    (mode_tile "add" 0)
                                )
                            )
                        )
                    )
                )
            )

            (action_tile "box2"
                (vl-prin1-to-string
                   '(
                        (lambda ( / itm )
                            (setq itm (mapcar '(lambda ( n ) (nth n rtn)) (read (strcat "(" $value ")"))))
                            (if (= 4 $reason)
                                (setq rtn (LM:getfiles:updateselected dir (vl-remove (car itm) rtn))
                                      lst (LM:getfiles:updatefilelist dir ext rtn)
                                )
                                (mode_tile "del" 0)
                            )
                        )
                    )
                )
            )

            (action_tile "add"
                (vl-prin1-to-string
                   '(
                        (lambda ( / itm )
                            (if
                                (setq itm
                                    (vl-remove-if-not 'vl-filename-extension
                                        (mapcar '(lambda ( n ) (nth n lst)) (read (strcat "(" (get_tile "box1") ")")))
                                    )
                                )
                                (setq rtn (LM:getfiles:sort (append rtn (mapcar '(lambda ( x ) (strcat dir "\\" x)) itm)))
                                      rtn (LM:getfiles:updateselected dir rtn)
                                      lst (LM:getfiles:updatefilelist dir ext rtn)
                                )
                            )
                            (mode_tile "add" 1)
                            (mode_tile "del" 1)
                        )
                    )
                )
            )

            (action_tile "del"
                (vl-prin1-to-string
                   '(
                        (lambda ( / itm )
                            (if (setq itm (read (strcat "(" (get_tile "box2") ")")))
                                (setq rtn (LM:getfiles:updateselected dir (LM:getfiles:removeitems itm rtn))
                                      lst (LM:getfiles:updatefilelist dir ext rtn)
                                )
                            )
                            (mode_tile "add" 1)
                            (mode_tile "del" 1)
                        )
                    )
                )
            )
         
            (if (zerop (start_dialog))
                (setq rtn nil)
            )
        )
    )
    (*error* nil)
    rtn
)

(defun LM:getfiles:listbox ( key lst )
    (start_list key)
    (foreach x lst (add_list x))
    (end_list)
    lst
)

(defun LM:getfiles:listfiles ( dir ext lst )
    (vl-remove-if '(lambda ( x ) (member (strcat dir "\\" x) lst))
        (cond
            (   (cdr (assoc dir dirdata)))
            (   (cdar
                    (setq dirdata
                        (cons
                            (cons dir
                                (append
                                    (LM:getfiles:sortlist (vl-remove "." (vl-directory-files dir nil -1)))
                                    (LM:getfiles:sort
                                        (if (member ext '(("") ("*")))
                                            (vl-directory-files dir nil 1)
                                            (vl-remove-if-not
                                                (function
                                                    (lambda ( x / e )
                                                        (and
                                                            (setq e (vl-filename-extension x))
                                                            (setq e (strcase (substr e 2)))
                                                            (vl-some '(lambda ( w ) (wcmatch e w)) ext)
                                                        )
                                                    )
                                                )
                                                (vl-directory-files dir nil 1)
                                            )
                                        )
                                    )
                                )
                            )
                            dirdata
                        )
                    )
                )
            )
        )
    )
)

(defun LM:getfiles:checkredirect ( dir / itm pos )
    (cond
        (   (vl-directory-files dir)
            dir
        )
        (   (and
                (=  (strcase (getenv "UserProfile"))
                    (strcase (substr dir 1 (setq pos (vl-string-position 92 dir nil t))))
                )
                (setq itm
                    (cdr
                        (assoc (substr (strcase dir t) (+ pos 2))
                           '(
                                ("my documents" . "Documents")
                                ("my pictures"  . "Pictures")
                                ("my videos"    . "Videos")
                                ("my music"     . "Music")
                            )
                        )
                    )
                )
                (vl-file-directory-p (setq itm (strcat (substr dir 1 pos) "\\" itm)))
            )
            itm
        )
        (   dir   )
    )
)

(defun LM:getfiles:sort ( lst )
    (apply 'append
        (mapcar 'LM:getfiles:sortlist
            (vl-sort
                (LM:getfiles:groupbyfunction lst
                    (lambda ( a b / x y )
                        (and
                            (setq x (vl-filename-extension a))
                            (setq y (vl-filename-extension b))
                            (= (strcase x) (strcase y))
                        )
                    )
                )
                (function
                    (lambda ( a b / x y )
                        (and
                            (setq x (vl-filename-extension (car a)))
                            (setq y (vl-filename-extension (car b)))
                            (< (strcase x) (strcase y))
                        )
                    )
                )
            )
        )
    )
)

(defun LM:getfiles:sortlist ( lst )
    (mapcar (function (lambda ( n ) (nth n lst)))
        (vl-sort-i (mapcar 'LM:getfiles:splitstring lst)
            (function
                (lambda ( a b / x y )
                    (while
                        (and
                            (setq x (car a))
                            (setq y (car b))
                            (= x y)
                        )
                        (setq a (cdr a)
                              b (cdr b)
                        )
                    )
                    (cond
                        (   (null x) b)
                        (   (null y) nil)
                        (   (and (numberp x) (numberp y)) (< x y))
                        (   (= "." x))
                        (   (numberp x))
                        (   (numberp y) nil)
                        (   (< x y))
                    )
                )
            )
        )
    )
)

(defun LM:getfiles:groupbyfunction ( lst fun / tmp1 tmp2 x1 )
    (if (setq x1 (car lst))
        (progn
            (foreach x2 (cdr lst)
                (if (fun x1 x2)
                    (setq tmp1 (cons x2 tmp1))
                    (setq tmp2 (cons x2 tmp2))
                )
            )
            (cons (cons x1 (reverse tmp1)) (LM:getfiles:groupbyfunction (reverse tmp2) fun))
        )
    )
)

(defun LM:getfiles:splitstring ( str )
    (
        (lambda ( l )
            (read
                (strcat "("
                    (vl-list->string
                        (apply 'append
                            (mapcar
                                (function
                                    (lambda ( a b c )
                                        (cond
                                            (   (= 92 b)
                                                (list 32 34 92 b 34 32)
                                            )
                                            (   (or (< 47 b 58)
                                                    (and (= 45 b) (< 47 c 58) (not (< 47 a 58)))
                                                    (and (= 46 b) (< 47 a 58) (< 47 c 58))
                                                )
                                                (list b)
                                            )
                                            (   (list 32 34 b 34 32))
                                        )
                                    )
                                )
                                (cons nil l) l (append (cdr l) '(( )))
                            )
                        )
                    )
                    ")"
                )
            )
        )
        (vl-string->list (strcase str))
    )
)

(defun LM:getfiles:browseforfolder ( msg dir flg / err fld pth shl slf )
    (setq err
        (vl-catch-all-apply
            (function
                (lambda ( / app hwd )
                    (if (setq app (vlax-get-acad-object)
                              shl (vla-getinterfaceobject app "shell.application")
                              hwd (vl-catch-all-apply 'vla-get-hwnd (list app))
                              fld (vlax-invoke-method shl 'browseforfolder (if (vl-catch-all-error-p hwd) 0 hwd) msg flg dir)
                        )
                        (setq slf (vlax-get-property fld 'self)
                              pth (vlax-get-property slf 'path)
                              pth (vl-string-right-trim "\\" (vl-string-translate "/" "\\" pth))
                        )
                    )
                )
            )
        )
    )
    (if slf (vlax-release-object slf))
    (if fld (vlax-release-object fld))
    (if shl (vlax-release-object shl))
    (if (vl-catch-all-error-p err)
        (prompt (vl-catch-all-error-message err))
        pth
    )
)

(defun LM:getfiles:full->relative ( dir path / p q )
    (setq dir (vl-string-right-trim "\\" dir))
    (cond
        (   (and
                (setq p (vl-string-position 58  dir))
                (setq q (vl-string-position 58 path))
                (not (eq (strcase (substr dir 1 p)) (strcase (substr path 1 q))))
            )
            path
        )
        (   (and
                (setq p (vl-string-position 92  dir))
                (setq q (vl-string-position 92 path))
                (eq (strcase (substr dir 1 p)) (strcase (substr path 1 q)))
            )
            (LM:getfiles:full->relative (substr dir (+ 2 p)) (substr path (+ 2 q)))
        )
        (   (and
                (setq q (vl-string-position 92 path))
                (eq (strcase dir) (strcase (substr path 1 q)))
            )
            (strcat ".\\" (substr path (+ 2 q)))
        )
        (   (eq "" dir)
            path
        )
        (   (setq p (vl-string-position 92 dir))
            (LM:getfiles:full->relative (substr dir (+ 2 p)) (strcat "..\\" path))
        )
        (   (LM:getfiles:full->relative "" (strcat "..\\" path)))
    )
)

(defun LM:getfiles:str->lst ( str del / pos )
    (if (setq pos (vl-string-search del str))
        (cons (substr str 1 pos) (LM:getfiles:str->lst (substr str (+ pos 1 (strlen del))) del))
        (list str)
    )
)

(defun LM:getfiles:updatefilelist ( dir ext lst )
    (LM:getfiles:listbox "box1" (LM:getfiles:listfiles dir ext lst))
)

(defun LM:getfiles:updateselected ( dir lst )
    (LM:getfiles:listbox "box2" (mapcar '(lambda ( x ) (LM:getfiles:full->relative dir x)) lst))
    lst
)

(defun LM:getfiles:updir ( dir )
    (substr dir 1 (vl-string-position 92 dir nil t))
)

(defun LM:getfiles:fixdir ( dir )
    (vl-string-right-trim "\\" (vl-string-translate "/" "\\" dir))
)

(defun LM:getfiles:removeitems ( itm lst / idx )
    (setq idx -1)
    (vl-remove-if '(lambda ( x ) (member (setq idx (1+ idx)) itm)) lst)
)

(vl-load-com)
(princ)


(defun c:test nil
    (mapcar 'print (LM:GetFiles "Select Drawings" "" "dwg"))
    (princ)
)

<<

Filename: 233162_test+nil.lsp
Tác giả: thehost31
Bài viết gốc: 233092
Tên lệnh: ktcot col
10- LTRUC : lệnh chèn cột vào lưới trục (như Revit)

Không biết ý bạn có phải là chọn hệ lưới trục ngang và dọc sẽ chèn các cột vào vị trí giao của hai hệ lưới. Nếu đúng ý thì hy vọng cái này sẽ dùng được.

 

(defun Str_Split(Root_string separate / Sep_len Olist temp_str si stri)
(setq Sep_len (strlen separate)
Olist '()
temp_str ""
si 1
)
(while (<= si (strlen Root_string))
(setq stri (substr Root_string si Sep_len))
(if (= stri...

>>

Không biết ý bạn có phải là chọn hệ lưới trục ngang và dọc sẽ chèn các cột vào vị trí giao của hai hệ lưới. Nếu đúng ý thì hy vọng cái này sẽ dùng được.

 

(defun Str_Split(Root_string separate / Sep_len Olist temp_str si stri)
(setq Sep_len (strlen separate)
Olist '()
temp_str ""
si 1
)
(while (<= si (strlen Root_string))
(setq stri (substr Root_string si Sep_len))
(if (= stri separate)
(setq Olist (append Olist (list temp_str))
temp_str ""
si (+ si Sep_len -1)
)
(setq temp_str (strcat temp_str (substr Root_string si 1)))
)
(setq si (1+ si))
)
(setq Olist (append Olist (list temp_str)))
)
;==============================================================
(defun Get-intesect(ent1 ent2 Extend / obj1 obj2 inter Out Cnt)
(vl-load-com)
(setq obj1 (vlax-ename->vla-object ent1)
obj2 (vlax-ename->vla-object ent2)
)
(if Extend
(setq inter (vlax-variant-value (vla-IntersectWith obj1 obj2 acExtendBoth)))
(setq inter (vlax-variant-value (vla-IntersectWith obj1 obj2 acExtendNone)))
)
(if (/= (vlax-safearray-get-u-bound inter 1) -1)
(setq inter (vlax-safearray->list inter))
(setq inter nil)
)
(if inter
(progn
(setq Cnt (fix (/ (length inter) 3)) Out nil)
(repeat Cnt (setq Out (append Out (list (list (car inter) (cadr inter) (caddr inter)))) inter (cdddr inter)))
)
(setq Out nil)
)
Out
)
;==============================================================
(defun C:ktcot(/ ktc_string)
(setq ktc_string (getstring "\nKích th\U+01B0\U+1EDBc c\U+1ED9t: "))
(setq #KT_list (STR_SPLIT ktc_string "x")
#KT_list (mapcar 'atof #KT_list)
)
(setq check nil)
(if (/= (length #KT_list) 2)
(setq check T)
(if (OR (<= (car #KT_list) 0.0) (<= (cadr #KT_list) 0.0))
(setq check T)
)
)
(if check
(progn (princ "\nVui lòng nh\U+1EADp l\U+1EA1i.") (C:ktcot))
)
(princ)
(princ)
)
;==============================================================
(defun Draw_colunm(pt Ang / dai rong ptt1 ptt2 p1 p2 p3 p4 mspace ptlist tmp poly)
(setq dai (car #KT_list)
rong (cadr #KT_list)

)
(setq ptt1 (polar pt Ang (* 0.5 rong))
p1 (polar ptt1 (+ Ang (* 0.5 pi)) (* 0.5 dai))
p2 (polar ptt1 (- Ang (* 0.5 pi)) (* 0.5 dai))
ptt2 (polar pt (- Ang pi) (* 0.5 rong))
p3 (polar ptt2 (- Ang (* 0.5 pi)) (* 0.5 dai))
p4 (polar ptt2 (+ Ang (* 0.5 pi)) (* 0.5 dai))
)
(setq mspace (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
(setq ptlist (apply 'append (list p1 p2 p3 p4 p1)))
(if (= (rem (length ptlist) 3) 0)
(progn
(setq tmp (vlax-make-safearray vlax-vbDouble (cons 0 (- (length ptlist) 1))))
(vlax-safearray-fill tmp ptlist)
(setq poly (vla-addPolyline mspace tmp))
)
)
)
;==============================================================
(defun c:col(/ ssgrid Gp_list Goc_list si gridi gridj sj giao)
(if (not #KT_list) (C:KTCOT))
(setq ssgrid (ssget '((0 . "LINE,POLYLINE,LWPOLYLINE")))
Gp_list '()
Goc_list '()
si 0
)
(while (> (sslength ssgrid) 0)
(setq gridi (ssname ssgrid si)
ssgrid (ssdel gridi ssgrid)
sj 0
)
(while (< sj (sslength ssgrid))
(setq gridj (ssname ssgrid sj))
(setq giao (GET-INTESECT gridi gridj nil))
(if giao
(setq Gp_list (append Gp_list (list (car giao)))
Goc_list (append Goc_list (list (angle (car giao) (cdr (assoc 10 (entget gridi))))))
)
)
(setq sj (1+ sj))
)
)
(setq si 0)
(while (< si (length Gp_list))
(DRAW_COLUNM (nth si Gp_list) (nth si Goc_list))
(setq si (1+ si))
)
(princ)
(princ)
)

 

Có hai lệnh:

                - Col  để thực hiện chèn cột. Nếu chưa có kích thước cột lệnh Ktcot sẽ tự động được gọi.

                - Khi muốn thay đổi kích thước cột dùng lệnh Ktcot. Kích thước cột nhập theo cú pháp ngang nhân dọc. Ví dụ: 300x300 – 500x500 – 500x1000.

Có thể dùng cho cả trường hợp hệ lưới trục quay nghiêng. Để có được code này mình có sưu tập được đoạn hàm nhỏ ở Trạm X.vn. Đây là link tham khảo:

 

http://www.tramx.vn/Baiviet.aspx?id=demigod4252013100708


<<

Filename: 233092_ktcot_col.lsp
Tác giả: Tue_NV
Bài viết gốc: 59926
Tên lệnh: thaydim
Thay thế kiểu dim của 1 bản vẽ bằng 1 kiểu dim đã được định nghĩa ở 1 bản vẽ khác !!!

Sử dụng lệnh MA được mà bạn. Sao lại nông dân? Bạn dùng bộ lọc Quick Select hay filter chọn trước dimstyle
Sau đó dùng lệnh MA và ở dòng này , bạn gõ chữ P
Command: MATCHPROP
Select source object:
Current active settings: Color Layer Ltype Ltscale Lineweight Thickness
PlotStyle Text Dim Hatch Polyline Viewport

Select destination object(s) or : P


Select destination object(s) or...
>>

Sử dụng lệnh MA được mà bạn. Sao lại nông dân? Bạn dùng bộ lọc Quick Select hay filter chọn trước dimstyle
Sau đó dùng lệnh MA và ở dòng này , bạn gõ chữ P
Command: MATCHPROP
Select source object:
Current active settings: Color Layer Ltype Ltscale Lineweight Thickness
PlotStyle Text Dim Hatch Polyline Viewport

Select destination object(s) or : P


Select destination object(s) or :

Còn nếu bạn muốn sử dụng Lisp thì đây :

<<

Filename: 59926_thaydim.lsp
Tác giả: Song Nhi
Bài viết gốc: 233210
Tên lệnh: s1 s2
Nho sua lisp

Theo quy định của diễn đàn bạn nên vui lòng post tiếng Việt, điều nho nhỏ này cũng xem như là bạn tôn trọng những anh em khác trên diễn đàn. Vấn đề của bạn, trong diễn đàn đã có rất nhiều.

 

 

http://www.cadviet.com/upfiles/3/118796_dtm.lspNho cac Bac sua...

>>

Theo quy định của diễn đàn bạn nên vui lòng post tiếng Việt, điều nho nhỏ này cũng xem như là bạn tôn trọng những anh em khác trên diễn đàn. Vấn đề của bạn, trong diễn đàn đã có rất nhiều.

 

 

http://www.cadviet.com/upfiles/3/118796_dtm.lspNho cac Bac sua gup doan lsp nay.Tinh Dien tich mien dien tich sau dau phay la 1 so. Hien tai lisp khi dung lsp dien tich la 12.01234 ( sau dau phay la 4 so) em muon sua lai la 12.0 thoi. Em xin chan thanh cam on! (may em khong go duoc tieng Viet)

http://www.cadviet.com/upfiles/3/118796_dtm.dwg

 

File bạn up lên chỉ có 3 hàm con, chứ đâu có lệnh gì đâu? Không biết bạn đã dùng LISP này như thế nào, nhập vào lệnh gì để xuất ra kết quả 12.01234??!

Có lẽ là bạn đã up lên thiếu rồi bạn à, bạn nên kiểm tra lại và up file đầy đủ thì mọi người mới giúp được bạn!

Nếu không, bạn có thể nói đúng yêu cầu của mình, mọi người sẽ viết giúp bạn!

 

 

(defun C:S1 ( / vki vkii) ;;; Xac dinh S va P bang chon doi tuong
(setq vki (entsel "\nChon vung kin:\n"))
(setq vkii (car vki))
(command ".AREA" "o" vkii)
(alert (strcat "\nDien tich: " (rtos (getvar "Area") 2 1) ". Chu vi: " (rtos (getvar "Perimeter") 2 1) "\n")))
 
(defun C:S2 (/ d1 o_hpb vki) ;;; Xac dinh S va P bang pick diem
(setq o_hpb (getvar "HPBOUND") vki nil)
(setq d1 (getpoint "\nPick diem:\n"))
(setvar "HPBOUND" 1) (command "_.Undo" "mark") 
(command ".boundary" d1 "") (setq vki (ssget "L")) 
(if(= (cdr (assoc 0 (entget (ssname vki 0)) )) "LWPOLYLINE")
(progn 
(command ".AREA" "o" vki)
(alert (strcat "\nDien tich: " (rtos (getvar "Area") 2 1) ". Chu vi: " (rtos (getvar "Perimeter") 2 1) "\n")))
(command "_.Undo" "Back")) (setvar "HPBOUND" o_hpb))

(defun C:S1 ( / vki vkii) ;;; Xac dinh S va P bang chon doi tuong
(setq vki (entsel "\nChon vung kin:\n"))
(setq vkii (car vki))
(command ".AREA" "o" vkii)
(alert (strcat "\nDien tich: " (rtos (getvar "Area") 2 1) ". Chu vi: " (rtos (getvar "Perimeter") 2 1) "\n")))
 
(defun C:S2 (/ d1 o_hpb vki) ;;; Xac dinh S va P bang pick diem
(setq o_hpb (getvar "HPBOUND") vki nil)
(setq d1 (getpoint "\nPick diem:\n"))
(setvar "HPBOUND" 1) (command "_.Undo" "mark") 
(command ".boundary" d1 "") (setq vki (ssget "L")) 
(if(= (cdr (assoc 0 (entget (ssname vki 0)) )) "LWPOLYLINE")
(progn 
(command ".AREA" "o" vki)
(alert (strcat "\nDien tich: " (rtos (getvar "Area") 2 1) ". Chu vi: " (rtos (getvar "Perimeter") 2 1) "\n")))
 

 

Có 2 lisp xác định diện tích và chu vi (0.0), tuỳ bạn muốn xài cách nào cũng được.


<<

Filename: 233210_s1_s2.lsp
Tác giả: NguyenNgocSon
Bài viết gốc: 233240
Tên lệnh: a2xl
Lisp tính diện tích bằng Pick Điểm
(defun c:A2xl (/ *error* vl ov xlApp xlCells Row pt eLast)
  (vl-load-com)

  (defun *error* (msg)
    (ObjRel (list xlApp xlCells))
    (and ov (mapcar 'setvar vl ov))
    (if (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*"))
      (princ (strcat "\n** Error: " msg " **")))
    (princ))

  (setq vl '("CMDECHO" "OSMODE") ov (mapcar 'getvar vl))

  (setq xlApp  (vlax-get-or-create-object "Excel.Application")
        xlCells   (vlax-get-property
                  ...
>>
(defun c:A2xl (/ *error* vl ov xlApp xlCells Row pt eLast)
  (vl-load-com)

  (defun *error* (msg)
    (ObjRel (list xlApp xlCells))
    (and ov (mapcar 'setvar vl ov))
    (if (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*"))
      (princ (strcat "\n** Error: " msg " **")))
    (princ))

  (setq vl '("CMDECHO" "OSMODE") ov (mapcar 'getvar vl))

  (setq xlApp  (vlax-get-or-create-object "Excel.Application")
        xlCells   (vlax-get-property
                    (vlax-get-property
                      (vlax-get-property
                        (vlax-invoke-method
                          (vlax-get-property xlApp 'Workbooks)
                          'Add)
                        'Sheets)
                      'Item 1)
                    'Cells)    Row 1)

  (while (setq pt (getpoint "\nPick Area: "))

    (mapcar 'setvar vl '(0 0))
    (setq eLast (entlast))
    (vl-cmdf "_.-boundary" "_a" "_i" "_n" "" "" pt "")

    (if (not (eq elast (setq ent (entlast))))
      (progn
        (vlax-put-property xlCells 'Item row 1
          (rtos
            (vlax-get-property (vlax-ename->vla-object ent) 'Area)))
        
        (entdel ent)
        (setq Row (1+ Row))))
    
    (mapcar 'setvar vl ov))

  (vlax-put-property xlApp 'Visible :vlax-true)
  (ObjRel (list xlApp xlCells))
  (gc) (gc)
  
  (mapcar 'setvar vl ov)
  (princ))
(defun ObjRel (lst)
  (mapcar
    (function
      (lambda (x)
        (if (and (eq (type x) 'VLA-OBJECT)
                 (not (vlax-object-released-p x)))
          (vl-catch-all-apply
            'vlax-release-object (list x))))) lst))

Mình có cái lisp này thấy rất hay nhưng có điều giờ mình muốn khi pick vào miền thì sẽ tạo luôn Hatch bao quanh miền đó và có 1 text ghi số thứ tự. Mong các bạn giúp vì cái lisp này dùng nhiều hàm -Vla quá mình không rành lắm

Cám ơn!


<<

Filename: 233240_a2xl.lsp
Tác giả: toiyeuvietnam
Bài viết gốc: 193494
Tên lệnh: chay cb pdm vl tm thuhoi
Nhờ hoàn thiện lisp phun điểm mia địa chính ra Autocad
Em tìm thấy hàm (defun DPGTOD rồi nhưng vẫn không được vậy bác ketxu nhỉ?

;******\\\\\\\\\**chuong trinh che bien cho may TOPCON 223*********\\\\\\\\\\\\\\*********////////
;khong dung chenh cao, chi su dung de thanh lap ban do dia chinh
(defun c:chay()
(c:cb) ;1
(c:pdm) ;2
(c:vl) ;3
(c:tm) ;4
(c:pdm) ;5
)
(defun c:cb (/ ch i FN FD sosanh j trammay
ccmay tramdh ccguong canhng hm hg goctd
canhb...
>>
Em tìm thấy hàm (defun DPGTOD rồi nhưng vẫn không được vậy bác ketxu nhỉ?

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

;)
;(close FNr)
(command "_.undo" "begin")
(setq cmd (getvar "cmdecho"))
(setq plwid (getvar "plinewid"))
(setq elev (getvar "elevation"))
(setq thick (getvar "thickness"))
(setq hh (getvar "osmode"))
(setq clay (getvar "clayer"))
)
(defun kthuc ()
(command "plinewid" plwid)
(command "elevation" elev)
(command "thickness" thick)
(command "osmode" hh)
(command "_.undo" "end")
(command "clayer" clay)
(command "cmdecho" cmd)
)
(defun dpgtod (nhap / do phut giay)
(setq do (fix nhap))
(setq phut (fix (* (- nhap do) 100)))
(setq giay (* (- (* (- nhap do) 100) phut) 100))
(setq xuat (+ do (/ (* phut 1.0) 60) (/ giay 3600)))
)
(defun dtodpg (nhap / do phut giay)
(setq do (fix nhap))
(setq phut (fix (* (- nhap do) 60)))
(setq giay (* (- (* (- nhap do) 60) phut) 60))
(setq xuat (strcat (rtos do 2 0) "." (rtos phut 2 0) (rtos giay 2 0)))
)
(defun dd (nhap)
(setq len (strlen nhap))
(cond ((= len 1) (setq xuat (strcat nhap " ")))
((= len 2) (setq xuat (strcat nhap " ")))
((= len 3) (setq xuat (strcat nhap " ")))
((= len 4) (setq xuat (strcat nhap " ")))
((= len 5) (setq xuat (strcat nhap " ")))
((= len 6) (setq xuat (strcat nhap " ")))
((= len 7) (setq xuat (strcat nhap " ")))
((= len 8) (setq xuat (strcat nhap " ")))
((= len 9) (setq xuat (strcat nhap " ")))
((= len 10) (setq xuat (strcat nhap " ")))
((= len 11) (setq xuat (strcat nhap "")))
; ((= len 12) (setq xuat (strcat nhap " ")))
; ((= len 13) (setq xuat (strcat nhap " ")))
; ((= len 14) (setq xuat (strcat nhap " ")))
; ((= len 15) (setq xuat (strcat nhap " ")))
; ((= len 16) (setq xuat (strcat nhap " ")))
; ((= len 17) (setq xuat (strcat nhap " ")))
; ((= len 18) (setq xuat (strcat nhap " ")))
; ((= len 19) (setq xuat (strcat nhap " ")))
; ((= len 20) (setq xuat (strcat nhap " ")))
; ((= len 21) (setq xuat (strcat nhap "")))
)
)
(defun dd1 (nhap)
(setq len (strlen nhap))
(cond ((= len 1) (setq xuat (strcat nhap " ")))
((= len 2) (setq xuat (strcat nhap " ")))
((= len 3) (setq xuat (strcat nhap " ")))
((= len 4) (setq xuat (strcat nhap " ")))
((= len 5) (setq xuat (strcat nhap " ")))
((= len 6) (setq xuat (strcat nhap " ")))
((= len 7) (setq xuat (strcat nhap " ")))
((= len 8) (setq xuat (strcat nhap " ")))
((= len 9) (setq xuat (strcat nhap " ")))
((= len 10) (setq xuat (strcat nhap " ")))
((= len 11) (setq xuat (strcat nhap " ")))
((= len 12) (setq xuat (strcat nhap " ")))
((= len 13) (setq xuat (strcat nhap " ")))
((= len 14) (setq xuat (strcat nhap " ")))
((= len 15) (setq xuat (strcat nhap " ")))
((= len 16) (setq xuat (strcat nhap " ")))
((= len 17) (setq xuat (strcat nhap " ")))
((= len 18) (setq xuat (strcat nhap " ")))
((= len 19) (setq xuat (strcat nhap " ")))
((= len 20) (setq xuat (strcat nhap " ")))
((= len 21) (setq xuat (strcat nhap "")))
)
)


KHI CHẠY ĐẾN BƯỚC PHUN ĐIỂM MIA THÌ NÓ HIỆN LÊN DÒNG NÀY LÀ SAO ANH NHỈ:

Command: chay
Nhap ten file ket qua (khong can .txt): hoanchinh


OK!Nhap vao mau so ty le : 200
Regenerating model.
TRA
error:bad argument type: numberp: nil
Requires an integer between 0 and 32767.
; error: An error has occurred inside the *error* functionFunction cancelled

Enter new value for OSMODE <0>:
NÓ KHÔNG PHUN ĐIỂM RA NGOÀI MÀN HÌNH ANH Ạ
<<

Filename: 193494_chay_cb_pdm_vl_tm_thuhoi.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 233287
Tên lệnh: ha
Bạn nào có ý tưởng nào hay về thuật toán để giải quyết vấn đề này không ?

Tôi chỉ code cho bạn cách chia S thôi, còn ba thứ lăng nhăng như hatch và dimension thì không hứng lắm, với nó còn phụ thuộc sở thích của người dùng.

Cái này chạy tức thì, không cần mò dần, kết quả đúng tuyệt đối.

 

(defun C:HA( / obj1 obj2 ent1 lstg lst1 lst z p1 p2 lstx lstt lstp St Stt pt Sp Spp pp)
 (setq obj1 (vlax-ename->vla-object (setq ent1 (car (entsel "\nChon duong cong tich...
>>

Tôi chỉ code cho bạn cách chia S thôi, còn ba thứ lăng nhăng như hatch và dimension thì không hứng lắm, với nó còn phụ thuộc sở thích của người dùng.

Cái này chạy tức thì, không cần mò dần, kết quả đúng tuyệt đối.

 

(defun C:HA( / obj1 obj2 ent1 lstg lst1 lst z p1 p2 lstx lstt lstp St Stt pt Sp Spp pp)
 (setq obj1 (vlax-ename->vla-object (setq ent1 (car (entsel "\nChon duong cong tich luy Pline: ")))))
 (setq obj2 (vlax-ename->vla-object (car (entsel "\nChon duong dieu phoi: "))))
 (setq lstg (vl-sort (LM:Intersections obj1 obj2 acExtendNone) '(lambda (e1 e2) (< (car e1) (car e2)))))
 (setq lst1 (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget ent1))))
 (setq lst (vl-sort (append lstg lst1) '(lambda (e1 e2) (< (car e1) (car e2)))))
 (setq lst (vl-remove-if '(lambda(pt) (or (< (car pt) (caar lstg)) (> (car pt) (car (last lstg))))) lst))
 (setq z -1)
 (repeat (1- (length lstg))
  (setq p1 (nth (setq z (1+ z)) lstg) p2 (nth (1+ z) lstg))
  (setq lstx (vl-remove-if '(lambda(pt) (or (< (car pt) (car p1)) (> (car pt) (car p2)))) lst))
  (setq lstt (vl-remove-if '(lambda(pt) (> (car pt) (car (Cuctri lstx)))) lstx))
  (setq lstp (vl-remove-if '(lambda(pt) (< (car pt) (car (Cuctri lstx)))) lstx))
  (setq St (PointArea (cons (list (car (last lstt)) (cadr (car lstt))) lstt)))
  (setq Stt (PointArea (cons (list (car (car lstt)) (cadr (last lstt))) lstt)))
  (setq pt (polar p1 0 (* (/ Stt (+ Stt St)) (- (car (Cuctri lstx)) (car p1)))))
  (setq Sp (PointArea (cons (list (car (car lstp)) (cadr (last lstp))) lstp)))
  (setq Spp (PointArea (cons (list (car (last lstp)) (cadr (car lstp))) lstp)))
  (setq pp (polar p2 pi (* (/ Spp (+ Sp Spp)) (- (car p2) (car (Cuctri lstx))))))
  (LWPoly (list pt (list (car pt) (cadr (Cuctri lstx))) (list (car pp) (cadr (Cuctri lstx))) pp))))
;-----
(defun LM:Intersections(obj1 obj2 mode / lst r)
 (setq lst (vlax-invoke obj1 'intersectwith obj2 mode))
 (repeat (/ (length lst) 3)
  (setq r (cons (list (car lst) (cadr lst) (caddr lst)) r) lst (cdddr lst)))
 r)
(defun Cuctri(lst / p1)
 (if (vl-remove-if '(lambda(pt) (>= (cadr pt) (cadar lst))) lst) ;co cuc tieu
  (progn
   (setq p1 (car lst))
   (foreach pt lst
    (if (< (cadr pt) (cadr p1)) (setq p1 pt))))
  (progn
   (setq p1 (car lst))
   (foreach pt lst
    (if (> (cadr pt) (cadr p1)) (setq p1 pt)))))
 p1)
(defun LWPoly(lst)
 (entmakex (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 (length lst))) 
   (mapcar (function (lambda (p) (cons 10 p))) lst))))
(defun PointArea (lst)
 (/ (abs (apply '+ (mapcar (function (lambda (a b) (- (* (car a) (cadr b)) (* (car b) (cadr a))))) lst (append (cdr lst) (list (car lst)))))) 2.0))

<<

Filename: 233287_ha.lsp
Tác giả: thehost31
Bài viết gốc: 233291
Tên lệnh: a2xl
[Nhờ chỉnh sửa] Lisp tính diện tích bằng Pick Điểm

Đã chỉnh sửa cho bạn. Tớ chỉ thêm các hàm con bên trên và thêm vào khoảng 4 câu lệnh trong hàm cũ của bạn. Mấy hàm con copy của ông Demigod bên trạm X.vn. Hy vọng giải quyết được yêu cầu của bạn. Tuy nhiên chưa điền tỷ lệ hatch và chiều cao text hợp lý. Kiểu Hatch tớ chọn ANSI31 và chiều cao chữ 1.5.

 

 

(defun Add_Hatch(poly Htype /...

>>

Đã chỉnh sửa cho bạn. Tớ chỉ thêm các hàm con bên trên và thêm vào khoảng 4 câu lệnh trong hàm cũ của bạn. Mấy hàm con copy của ông Demigod bên trạm X.vn. Hy vọng giải quyết được yêu cầu của bạn. Tuy nhiên chưa điền tỷ lệ hatch và chiều cao text hợp lý. Kiểu Hatch tớ chọn ANSI31 và chiều cao chữ 1.5.

 

 

(defun Add_Hatch(poly Htype / mspace)
(vl-load-com)
(setq mspace (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-Acad-Object))))
(setq hatch (vla-AddHatch mspace acHatchPatternTypePreDefined Htype :vlax-True))
(vlax-invoke hatch 'AppendOuterLoop (list poly))
(vla-evaluate hatch)
)
;==============================================================
(defun MCText (pt string ht / mspace thetext tent alpoint)
(vl-load-com)
(setq mspace (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
(setq thetext (vla-AddText mspace string (vlax-3d-point pt) ht))
(setq tent (entget (vlax-vla-object->ename thetext)))
(setq alpoint (cdr (assoc 10 tent)))
(setq tent (subst (cons 73 2) (assoc 73 tent) tent))
(setq tent (subst (cons 72 1) (assoc 72 tent) tent))
(setq tent (subst (cons 11 alpoint) (assoc 11 tent) tent))
(entmod tent)
thetext
)
;==============================================================
(defun obj2plist(obj-ename / en timp timl pli)
(if (= (cdr (assoc 0 (entget obj-ename))) "LINE")
(progn
(setq timp (list
(cdr (assoc 10 (entget obj-ename)))
(cdr (assoc 11 (entget obj-ename)))
)
)
)
)
(if (= (cdr (assoc 0 (entget obj-ename))) "POLYLINE")
(progn
(setq en obj-ename)
(while (/= (cdr (assoc 0 (entget en))) "SEQEND")
(if (= (cdr (assoc 0 (entget en))) "VERTEX")
(setq timp (append timp (list (cdr (assoc 10 (entget en))))))
)
(setq en (entnext en))
)
)
)
(if (= (cdr (assoc 0 (entget obj-ename))) "LWPOLYLINE")
(progn
(setq timl (entget obj-ename))
(setq pli 0)
(while (< pli (length timl))
(if (= (car (nth pli timl)) 10)
(setq timp (append timp (list (cdr (nth pli timl)))))
)
(setq pli (1+ pli))
)
)
)
timp
)
;==============================================================
(defun c:A2xl (/ *error* vl ov xlApp xlCells Row pt eLast dtich plist pgiua)
(vl-load-com)
(defun *error* (msg)
(ObjRel (list xlApp xlCells))
(and ov (mapcar 'setvar vl ov))
(if (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*"))
(princ (strcat "\n** Error: " msg " **"))
)
(princ)
)
(setq vl '("CMDECHO" "OSMODE")
ov (mapcar 'getvar vl)
)
(setq xlApp (vlax-get-or-create-object "Excel.Application")
xlCells (vlax-get-property
(vlax-get-property
(vlax-get-property
(vlax-invoke-method
(vlax-get-property xlApp 'Workbooks)
'Add
)
'Sheets
)
'Item
1
)
'Cells
)
Row 1
)

(while (setq pt (getpoint "\nPick Area: "))
(mapcar 'setvar vl '(0 0))
(setq eLast (entlast))
(vl-cmdf "_.-boundary" "_a" "_i" "_n" "" "" pt "")
(if (not (eq elast (setq ent (entlast))))
(progn
(vlax-put-property
xlCells
'Item
row
1
(setq dtich (rtos (vlax-get-property (vlax-ename->vla-object ent) 'Area)));;;
)
;;;;;;;;;
(ADD_HATCH (vlax-ename->vla-object ent) "ANSI31")
(setq plist (OBJ2PLIST ent))
(setq Pgiua (list
(/ (apply '+ (mapcar '(lambda (x) (car x)) plist)) (length plist))
(/ (apply '+ (mapcar '(lambda (x) (cadr x)) plist)) (length plist))
)
)
(MCText Pgiua dtich 1.5)
;;;;;;;;;
(entdel ent)
(setq Row (1+ Row))
)
)
(mapcar 'setvar vl ov)
)

(vlax-put-property xlApp 'Visible :vlax-true)
(ObjRel (list xlApp xlCells))
(gc)
(gc)

(mapcar 'setvar vl ov)
(princ)
)
;==============================================================
(defun ObjRel (lst)
(mapcar
(function
(lambda (x)
(if (and (eq (type x) 'VLA-OBJECT)
(not (vlax-object-released-p x))
)
(vl-catch-all-apply
'vlax-release-object
(list x)
)
)
)
)
lst
)
)


<<

Filename: 233291_a2xl.lsp

Trang 127/330

127