Đến nội dung


Hình ảnh
- - - - -

Nhờ viết Lisp Hatch vùng kín của các đối tượng giao nhau.


  • Please log in to reply
37 replies to this topic

#21 doanduyhung

doanduyhung

    biết vẽ spline

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

Đã gửi 15 January 2014 - 10:42 AM

mình up lại đây

lisp nay mình test rồi nó ổn khi các đối tượng phải giao nhau hết (không tính được như hình mẫu ở trên trường hợp line và spline nó không giao nhau còn các hình còn lại thì ok)

File mẫu phải khai báo lại tỉ lệ hatch mặc định lớn lên vd=10 nếu không nó không có hatch được

(defun LM:Intersections ( obj1 obj2 mode / l r )
    (setq l (vlax-invoke obj1 'intersectwith obj2 mode))
    (repeat (/ (length l) 3)
        (setq r (cons (list (car l) (cadr l) (caddr l)) r)
              l (cdddr l)
        )
    )
    (reverse r)
)
(defun LM:IntersectionsInSet ( ss / a b i j l )
    (repeat (setq i (sslength ss))
        (setq a (vlax-ename->vla-object (ssname ss (setq i (1- i)))))
        (repeat (setq j i)
            (setq b (vlax-ename->vla-object (ssname ss (setq j (1- j))))
                  l (cons (LM:Intersections a b acextendnone) l)
            )
        )
    )
    (apply 'append (reverse l))
)
(defun DDH:pointtolsppoint (pointchen lsppointchen / vitrichen ii)
  (setq iii 0)
  (repeat (- (length lsppointchen) 1)
    (if (and (> (distance pointchen (nth (+ iii 1) lsppointchen)) 0.001)
	     (> (distance pointchen (nth iii lsppointchen)) 0.001)
	     )
      (progn
	(if (<= (abs (- (distance (nth iii lsppointchen) (nth (+ iii 1) lsppointchen))
			(+ (distance pointchen (nth (+ iii 1) lsppointchen))
			   (distance pointchen (nth iii lsppointchen))
			   )
			))
		     0.001)
	  (setq vitrichen (+ iii 1))
	  )
	)
      )
    (setq iii (+ iii 1))
    )
  (setq lsppointchen (LM:InsertNth pointchen vitrichen lsppointchen))
  )
(defun LM:InsertNth ( x n l )
  ((lambda ( k )
     (apply 'append
	    (mapcar '(lambda ( a ) (if (= n (setq k (1+ k))) (list x a) (list a))) l)
	    )
     )
    -1
    )
  )
(defun taopolyline (lst layer mau / x )
  (entmakex
    (append (list (cons 0 "LWPOLYLINE")
		  (cons 100 "AcDbEntity")
		  (cons 100 "AcDbPolyline")
		  (cons 90 (length lst))
		  (cons 70 0)
		  (cons 66 1)
		  (cons 8 layer)
		  (cons 62 mau)
		  )
	    (mapcar (function (lambda (x) (cons 10 x))) lst)
	    )
    )  
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:hatchkin(/)
  (vl-load-com)
  (princ "\nChon Cac Line, Polyline, Arc, Circle, Spline Hoac Ellipse De Tao Polyline Kin")
  (if (setq chonlinepolyline (ssget '((-4 . "<OR")(0 . "LINE")(0 . "CIRCLE")(0 . "SPLINE")(0 . "ARC")(0 . "ELLIPSE")(0 . "*POLYLINE")(-4 . "OR>"))))
    (progn   
      (setq chonpolyline (ssadd))
      (setq lsppolyline nil)
      (setq i 0)
      (repeat (sslength chonlinepolyline)
	(taopolyline (ACET-GEOM-OBJECT-POINT-LIST (ssname chonlinepolyline i)
		       (/ (vlax-curve-getdistatparam (ssname chonlinepolyline i) (vlax-curve-getendparam (ssname chonlinepolyline i)))
			  10000)) "0" 1)
	(ssadd (entlast) chonpolyline)
	(setq lsppolyline (append lsppolyline (list (ACET-GEOM-OBJECT-POINT-LIST (ssname chonlinepolyline i)
						      (/ (vlax-curve-getdistatparam (ssname chonlinepolyline i) (vlax-curve-getendparam (ssname chonlinepolyline i)))
							 10000)))))
	(setq i (+ i 1))
	)
      (setq lspgiaodiem (LM:IntersectionsInSet chonpolyline))
      (setq chonline (ssadd))
      (setq lspchonline nil)
      (foreach lsp lsppolyline
	(foreach diemgiao lspgiaodiem
	  (setq lsp (DDH:pointtolsppoint diemgiao lsp))
	  )
	(setq i 0)
	(repeat (- (length lsp) 1)
	  (entmakex (list '(0 . "LINE")
			    (cons 10 (nth i lsp))
			    (cons 11 (nth (+ i 1) lsp))
			    ))
	  (ssadd (entlast) chonline)
	  (setq lspchonline (append lspchonline (list (vlax-ename->vla-object (entlast)))))
	  (setq i (+ i 1))
	  )
	)     
      (or acDoc (setq acDoc (vla-get-activedocument (vlax-get-acad-object))))
      (setq ms (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace)))
      (if (setq lsptongregion (vlax-invoke ms 'AddRegion lspchonline))
	(progn
	  (command "ERASE" chonline "")
	  (command "ERASE" chonpolyline "")
	  (setq lspxetbien nil)
	  (foreach tungregion lsptongregion
	    (setq lspxetbien (append lspxetbien (list (list (vlax-vla-object->ename tungregion) (vlax-get-property tungregion 'area)))))
	    )
	  (setq lspxetbien (vl-sort lspxetbien (function (lambda (e1 e2) (> (cadr e1) (cadr e2))))))
	  (setq dientichtong 0.00)
	  (foreach dientich (cdr lspxetbien)
	    (setq dientichtong (+ dientichtong (cadr dientich)))
	    )
	  (if (<= (abs (- (cadr (car lspxetbien)) dientichtong)) 0.0001)
	    (entdel (car (car lspxetbien)))
	    )
	  (setq mau 1)
	  (foreach xetpl (cdr lspxetbien)
	    (if (>= mau 255)
	      (setq mau 1)
	      )
	    (command "hatch" "" "" "" (car xetpl) "")
	    (command "change" (entlast) "" "p" "c" mau "")
	    (setq mau (+ mau 1))
	    )
	  
	  )
	)
      )
    )
  )

test.gif


  • 3

#22 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 5448 Bài viết
Điểm đánh giá: 2624 (tuyệt vời)

Đã gửi 15 January 2014 - 12:18 PM

Nếu chủ topic chấp nhận hatch "gần đúng" thì ổn.


  • 0

* Chỉ nên yêu cầu Lisp khi bạn làm việc đó mất cả ngày nhưng họ chỉ viết 1 giờ. Đừng nêu yêu cầu Lisp khi bạn chỉ làm 1 giờ nhưng bắt họ phải mất cả ngày.

* Nhờ viết lisp cũng như đi khám bệnh. Chỉ gởi căn cước và than sắp chết thì không bác sỹ nào cứu sống được.


#23 dragontalon0802

dragontalon0802

    biết lệnh erase

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

Đã gửi 15 January 2014 - 12:43 PM

Không biết tại đầu óc mình đen tối hay tại cái tít nhạy cảm nhỉ?

"vùng kín của các đối tượng giao nhau"


  • 0

#24 huaductiep

huaductiep

    biết vẽ rectang

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

Đã gửi 15 January 2014 - 04:55 PM

mình up lại đây

lisp nay mình test rồi nó ổn khi các đối tượng phải giao nhau hết (không tính được như hình mẫu ở trên trường hợp line và spline nó không giao nhau còn các hình còn lại thì ok)

File mẫu phải khai báo lại tỉ lệ hatch mặc định lớn lên vd=10 nếu không nó không có hatch được

(defun LM:Intersections ( obj1 obj2 mode / l r )
    (setq l (vlax-invoke obj1 'intersectwith obj2 mode))
    (repeat (/ (length l) 3)
        (setq r (cons (list (car l) (cadr l) (caddr l)) r)
              l (cdddr l)
        )
    )
    (reverse r)
)
(defun LM:IntersectionsInSet ( ss / a b i j l )
    (repeat (setq i (sslength ss))
        (setq a (vlax-ename->vla-object (ssname ss (setq i (1- i)))))
        (repeat (setq j i)
            (setq b (vlax-ename->vla-object (ssname ss (setq j (1- j))))
                  l (cons (LM:Intersections a b acextendnone) l)
            )
        )
    )
    (apply 'append (reverse l))
)
(defun DDH:pointtolsppoint (pointchen lsppointchen / vitrichen ii)
  (setq iii 0)
  (repeat (- (length lsppointchen) 1)
    (if (and (> (distance pointchen (nth (+ iii 1) lsppointchen)) 0.001)
	     (> (distance pointchen (nth iii lsppointchen)) 0.001)
	     )
      (progn
	(if (<= (abs (- (distance (nth iii lsppointchen) (nth (+ iii 1) lsppointchen))
			(+ (distance pointchen (nth (+ iii 1) lsppointchen))
			   (distance pointchen (nth iii lsppointchen))
			   )
			))
		     0.001)
	  (setq vitrichen (+ iii 1))
	  )
	)
      )
    (setq iii (+ iii 1))
    )
  (setq lsppointchen (LM:InsertNth pointchen vitrichen lsppointchen))
  )
(defun LM:InsertNth ( x n l )
  ((lambda ( k )
     (apply 'append
	    (mapcar '(lambda ( a ) (if (= n (setq k (1+ k))) (list x a) (list a))) l)
	    )
     )
    -1
    )
  )
(defun taopolyline (lst layer mau / x )
  (entmakex
    (append (list (cons 0 "LWPOLYLINE")
		  (cons 100 "AcDbEntity")
		  (cons 100 "AcDbPolyline")
		  (cons 90 (length lst))
		  (cons 70 0)
		  (cons 66 1)
		  (cons 8 layer)
		  (cons 62 mau)
		  )
	    (mapcar (function (lambda (x) (cons 10 x))) lst)
	    )
    )  
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:hatchkin(/)
  (vl-load-com)
  (princ "\nChon Cac Line, Polyline, Arc, Circle, Spline Hoac Ellipse De Tao Polyline Kin")
  (if (setq chonlinepolyline (ssget '((-4 . "<OR")(0 . "LINE")(0 . "CIRCLE")(0 . "SPLINE")(0 . "ARC")(0 . "ELLIPSE")(0 . "*POLYLINE")(-4 . "OR>"))))
    (progn   
      (setq chonpolyline (ssadd))
      (setq lsppolyline nil)
      (setq i 0)
      (repeat (sslength chonlinepolyline)
	(taopolyline (ACET-GEOM-OBJECT-POINT-LIST (ssname chonlinepolyline i)
		       (/ (vlax-curve-getdistatparam (ssname chonlinepolyline i) (vlax-curve-getendparam (ssname chonlinepolyline i)))
			  10000)) "0" 1)
	(ssadd (entlast) chonpolyline)
	(setq lsppolyline (append lsppolyline (list (ACET-GEOM-OBJECT-POINT-LIST (ssname chonlinepolyline i)
						      (/ (vlax-curve-getdistatparam (ssname chonlinepolyline i) (vlax-curve-getendparam (ssname chonlinepolyline i)))
							 10000)))))
	(setq i (+ i 1))
	)
      (setq lspgiaodiem (LM:IntersectionsInSet chonpolyline))
      (setq chonline (ssadd))
      (setq lspchonline nil)
      (foreach lsp lsppolyline
	(foreach diemgiao lspgiaodiem
	  (setq lsp (DDH:pointtolsppoint diemgiao lsp))
	  )
	(setq i 0)
	(repeat (- (length lsp) 1)
	  (entmakex (list '(0 . "LINE")
			    (cons 10 (nth i lsp))
			    (cons 11 (nth (+ i 1) lsp))
			    ))
	  (ssadd (entlast) chonline)
	  (setq lspchonline (append lspchonline (list (vlax-ename->vla-object (entlast)))))
	  (setq i (+ i 1))
	  )
	)     
      (or acDoc (setq acDoc (vla-get-activedocument (vlax-get-acad-object))))
      (setq ms (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace)))
      (if (setq lsptongregion (vlax-invoke ms 'AddRegion lspchonline))
	(progn
	  (command "ERASE" chonline "")
	  (command "ERASE" chonpolyline "")
	  (setq lspxetbien nil)
	  (foreach tungregion lsptongregion
	    (setq lspxetbien (append lspxetbien (list (list (vlax-vla-object->ename tungregion) (vlax-get-property tungregion 'area)))))
	    )
	  (setq lspxetbien (vl-sort lspxetbien (function (lambda (e1 e2) (> (cadr e1) (cadr e2))))))
	  (setq dientichtong 0.00)
	  (foreach dientich (cdr lspxetbien)
	    (setq dientichtong (+ dientichtong (cadr dientich)))
	    )
	  (if (<= (abs (- (cadr (car lspxetbien)) dientichtong)) 0.0001)
	    (entdel (car (car lspxetbien)))
	    )
	  (setq mau 1)
	  (foreach xetpl (cdr lspxetbien)
	    (if (>= mau 255)
	      (setq mau 1)
	      )
	    (command "hatch" "" "" "" (car xetpl) "")
	    (command "change" (entlast) "" "p" "c" mau "")
	    (setq mau (+ mau 1))
	    )
	  
	  )
	)
      )
    )
  )

test.gif

Em còn gặp lỗi là nếu ta quét chọn nhiều hình cùng lúc (như file em gửi là em quét chọn cả 6 khối hình 1 lúc) thì sau khi Hatchkin có một số vùng Hatch được tạo ra bao toàn bộ tất cả các hình. Mà em chỉ muốn nó ra kết quả Hatch ở mỗi vùng riêng biệt thôi. Và Bác có thể chỉnh cho em cái phần sau khi hatch xong thì nó mất cái phần Region được tạo ra đó ko ah? 
Nói chung Lisp đã rất tuyệt rồi. Bác chỉnh giúp em mấy cái này nữa nhá. Em cám ơn các Bác nhiều lắm  :) http://www.cadviet.c...est_hatch_2.dwg64997_screenshot_81.png


  • 0

#25 doanduyhung

doanduyhung

    biết vẽ spline

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

Đã gửi 15 January 2014 - 05:02 PM

Em còn gặp lỗi là nếu ta quét chọn nhiều hình cùng lúc (như file em gửi là em quét chọn cả 6 khối hình 1 lúc) thì sau khi Hatchkin có một số vùng Hatch được tạo ra bao toàn bộ tất cả các hình. Mà em chỉ muốn nó ra kết quả Hatch ở mỗi vùng riêng biệt thôi. Và Bác có thể chỉnh cho em cái phần sau khi hatch xong thì nó mất cái phần Region được tạo ra đó ko ah? 
Nói chung Lisp đã rất tuyệt rồi. Bác chỉnh giúp em mấy cái này nữa nhá. Em cám ơn các Bác nhiều lắm  :) http://www.cadviet.c...est_hatch_2.dwg64997_screenshot_81.png

đúng rồi chỉ đúng chọn 1 nhóm giao và loại đối tượng bao chung, chưa xét chọn nhiều nhóm, đang tìm cách để lọc cái đó
  • 0

#26 huaductiep

huaductiep

    biết vẽ rectang

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

Đã gửi 15 January 2014 - 07:17 PM

Em dùng lisp trên với bản Cad sau lại ko được bác DoanDuyHung ah. Em rất hay phải hatch với những đối tượng giao với đường mặt đất tự nhiên màu tím như trong hình sau. Mặc dù em đã Extend hết để cho các đối tượng giao cắt với nhau mà vẫn ko thể Hatch được. Mong bác và diễn đàn tìm cách giúp đỡ em với nhé. Em xin chân thành cảm ơn ạ  :)

http://www.cadviet.c...st_hatchkin.dwg64997_screenshot_82.png


  • 0

#27 dươngp

dươngp

    biết zoom

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

Đã gửi 16 January 2014 - 11:56 AM

cảm ơn bạn rất nhièu về bài viết này..........................nó rất hay


  • 0

#28 doanduyhung

doanduyhung

    biết vẽ spline

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

Đã gửi 16 January 2014 - 02:42 PM

Hi bạn:

Em dùng lisp trên với bản Cad sau lại ko được bác DoanDuyHung ah. Em rất hay phải hatch với những đối tượng giao với đường mặt đất tự nhiên màu tím như trong hình sau. Mặc dù em đã Extend hết để cho các đối tượng giao cắt với nhau mà vẫn ko thể Hatch được. Mong bác và diễn đàn tìm cách giúp đỡ em với nhé. Em xin chân thành cảm ơn ạ  :)

http://www.cadviet.c...st_hatchkin.dwg64997_screenshot_82.png

hi bạn

- 2 cái hình trong khung lần 1 đối tượng màu đỏ không giao với đường đứng màu vàng nên chỉ hatch được các phần còn lại

- 2 cái hình trong khung lần 2 thì hatch được hết.

(defun LM:Intersections ( obj1 obj2 mode / l r )
    (setq l (vlax-invoke obj1 'intersectwith obj2 mode))
    (repeat (/ (length l) 3)
        (setq r (cons (list (car l) (cadr l) (caddr l)) r)
              l (cdddr l)
        )
    )
    (reverse r)
)
(defun LM:IntersectionsInSet ( ss / a b i j l )
    (repeat (setq i (sslength ss))
        (setq a (vlax-ename->vla-object (ssname ss (setq i (1- i)))))
        (repeat (setq j i)
            (setq b (vlax-ename->vla-object (ssname ss (setq j (1- j))))
                  l (cons (LM:Intersections a b acextendnone) l)
            )
        )
    )
    (apply 'append (reverse l))
)
(defun DDH:pointtolsppoint (pointchen lsppointchen / vitrichen ii)
  (setq iii 0)
  (repeat (- (length lsppointchen) 1)
    (if (and (> (distance pointchen (nth (+ iii 1) lsppointchen)) 0.001)
	     (> (distance pointchen (nth iii lsppointchen)) 0.001)
	     )
      (progn
	(if (<= (abs (- (distance (nth iii lsppointchen) (nth (+ iii 1) lsppointchen))
			(+ (distance pointchen (nth (+ iii 1) lsppointchen))
			   (distance pointchen (nth iii lsppointchen))
			   )
			))
		     0.001)
	  (setq vitrichen (+ iii 1))
	  )
	)
      )
    (setq iii (+ iii 1))
    )
  (setq lsppointchen (LM:InsertNth pointchen vitrichen lsppointchen))
  )
(defun LM:InsertNth ( x n l )
  ((lambda ( k )
     (apply 'append
	    (mapcar '(lambda ( a ) (if (= n (setq k (1+ k))) (list x a) (list a))) l)
	    )
     )
    -1
    )
  )
(defun LM:Uniqueline ( l )
  (if l (cons (car l)
	      (LM:Uniqueline
		(vl-remove-if '(lambda (x) (or (and (equal (car x) (car (car l)))
						    (equal (cadr x) (cadr (car l))))
					       (and (equal (car x) (cadr (car l)))
						    (equal (cadr x) (car (car l))))
					       )
				 ) (cdr l))
		))))
(defun taopolyline (lst layer mau / x )
  (entmakex
    (append (list (cons 0 "LWPOLYLINE")
		  (cons 100 "AcDbEntity")
		  (cons 100 "AcDbPolyline")
		  (cons 90 (length lst))
		  (cons 70 0)
		  (cons 66 1)
		  (cons 8 layer)
		  (cons 62 mau)
		  )
	    (mapcar (function (lambda (x) (cons 10 x))) lst)
	    )
    )  
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:hatchkin(/)
  (vl-load-com)
  (princ "\nChon Cac Line, Polyline, Arc, Circle, Spline Hoac Ellipse De Tao Polyline Kin")
  (if (setq chonlinepolyline (ssget '((-4 . "<OR")(0 . "LINE")(0 . "CIRCLE")(0 . "SPLINE")(0 . "ARC")(0 . "ELLIPSE")(0 . "*POLYLINE")(-4 . "OR>"))))
    (progn   
      (setq chonpolyline (ssadd))
      (setq lsppolyline nil)
      (setq i 0)
      (repeat (sslength chonlinepolyline)
	(taopolyline (ACET-GEOM-OBJECT-POINT-LIST (ssname chonlinepolyline i)
		       (/ (vlax-curve-getdistatparam (ssname chonlinepolyline i) (vlax-curve-getendparam (ssname chonlinepolyline i)))
			  10000)) "0" 1)
	(ssadd (entlast) chonpolyline)
	(setq lsppolyline (append lsppolyline (list (ACET-GEOM-OBJECT-POINT-LIST (ssname chonlinepolyline i)
						      (/ (vlax-curve-getdistatparam (ssname chonlinepolyline i) (vlax-curve-getendparam (ssname chonlinepolyline i)))
							 10000)))))
	(setq i (+ i 1))
	)
      (setq lspgiaodiem (LM:IntersectionsInSet chonpolyline))
      (setq chonline (ssadd))
      (setq lspchonline nil)
      (setq lsp2diemline nil)
      (foreach lsp lsppolyline
	(foreach diemgiao lspgiaodiem
	  (setq lsp (DDH:pointtolsppoint diemgiao lsp))
	  )
	(setq i 0)
	(repeat (- (length lsp) 1)
	  (setq lsp2diemline (append lsp2diemline (list (list (nth i lsp) (nth (+ i 1) lsp)))))
	  (setq i (+ i 1))
	  )
	)
      (setq lsp2diemline (LM:Uniqueline lsp2diemline))
      (foreach line lsp2diemline
	(entmakex (list '(0 . "LINE")
			(cons 10 (car line))
			(cons 11 (cadr line))
			))
	(ssadd (entlast) chonline)
	(setq lspchonline (append lspchonline (list (vlax-ename->vla-object (entlast)))))
	)
      (or acDoc (setq acDoc (vla-get-activedocument (vlax-get-acad-object))))
      (setq ms (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace)))
      (if (setq lsptongregion (vlax-invoke ms 'AddRegion lspchonline))
	(progn
	  (command "ERASE" chonline "")
	  (command "ERASE" chonpolyline "")
	  (setq lspxetbien nil)
	  (foreach tungregion lsptongregion
	    (setq lspxetbien (append lspxetbien (list (list (vlax-vla-object->ename tungregion) (vlax-get-property tungregion 'area)))))
	    )
	  (setq lspxetbien (vl-sort lspxetbien (function (lambda (e1 e2) (> (cadr e1) (cadr e2))))))
	  (setq dientichtong 0.00)
	  (foreach dientich (cdr lspxetbien)
	    (setq dientichtong (+ dientichtong (cadr dientich)))
	    )
	  (if (<= (abs (- (cadr (car lspxetbien)) dientichtong)) 0.0001)
	    (entdel (car (car lspxetbien)))
	    )
	  (setq mau 1)
	  (foreach xetpl (cdr lspxetbien)
	    (if (>= mau 255)
	      (setq mau 1)
	      )
	    (command "hatch" "" "" "" (car xetpl) "")
	    (command "change" (entlast) "" "p" "c" mau "")
	    (setq mau (+ mau 1))
	    )
	  
	  )
	)
      )
    )
  )

  • 2

#29 huaductiep

huaductiep

    biết vẽ rectang

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

Đã gửi 16 January 2014 - 10:33 PM

Hi bạn:

Em dùng lisp trên với bản Cad sau lại ko được bác DoanDuyHung ah. Em rất hay phải hatch với những đối tượng giao với đường mặt đất tự nhiên màu tím như trong hình sau. Mặc dù em đã Extend hết để cho các đối tượng giao cắt với nhau mà vẫn ko thể Hatch được. Mong bác và diễn đàn tìm cách giúp đỡ em với nhé. Em xin chân thành cảm ơn ạ  :)

http://www.cadviet.c...st_hatchkin.dwg64997_screenshot_82.png

hi bạn

- 2 cái hình trong khung lần 1 đối tượng màu đỏ không giao với đường đứng màu vàng nên chỉ hatch được các phần còn lại

- 2 cái hình trong khung lần 2 thì hatch được hết.

(defun LM:Intersections ( obj1 obj2 mode / l r )
    (setq l (vlax-invoke obj1 'intersectwith obj2 mode))
    (repeat (/ (length l) 3)
        (setq r (cons (list (car l) (cadr l) (caddr l)) r)
              l (cdddr l)
        )
    )
    (reverse r)
)
(defun LM:IntersectionsInSet ( ss / a b i j l )
    (repeat (setq i (sslength ss))
        (setq a (vlax-ename->vla-object (ssname ss (setq i (1- i)))))
        (repeat (setq j i)
            (setq b (vlax-ename->vla-object (ssname ss (setq j (1- j))))
                  l (cons (LM:Intersections a b acextendnone) l)
            )
        )
    )
    (apply 'append (reverse l))
)
(defun DDH:pointtolsppoint (pointchen lsppointchen / vitrichen ii)
  (setq iii 0)
  (repeat (- (length lsppointchen) 1)
    (if (and (> (distance pointchen (nth (+ iii 1) lsppointchen)) 0.001)
	     (> (distance pointchen (nth iii lsppointchen)) 0.001)
	     )
      (progn
	(if (<= (abs (- (distance (nth iii lsppointchen) (nth (+ iii 1) lsppointchen))
			(+ (distance pointchen (nth (+ iii 1) lsppointchen))
			   (distance pointchen (nth iii lsppointchen))
			   )
			))
		     0.001)
	  (setq vitrichen (+ iii 1))
	  )
	)
      )
    (setq iii (+ iii 1))
    )
  (setq lsppointchen (LM:InsertNth pointchen vitrichen lsppointchen))
  )
(defun LM:InsertNth ( x n l )
  ((lambda ( k )
     (apply 'append
	    (mapcar '(lambda ( a ) (if (= n (setq k (1+ k))) (list x a) (list a))) l)
	    )
     )
    -1
    )
  )
(defun LM:Uniqueline ( l )
  (if l (cons (car l)
	      (LM:Uniqueline
		(vl-remove-if '(lambda (x) (or (and (equal (car x) (car (car l)))
						    (equal (cadr x) (cadr (car l))))
					       (and (equal (car x) (cadr (car l)))
						    (equal (cadr x) (car (car l))))
					       )
				 ) (cdr l))
		))))
(defun taopolyline (lst layer mau / x )
  (entmakex
    (append (list (cons 0 "LWPOLYLINE")
		  (cons 100 "AcDbEntity")
		  (cons 100 "AcDbPolyline")
		  (cons 90 (length lst))
		  (cons 70 0)
		  (cons 66 1)
		  (cons 8 layer)
		  (cons 62 mau)
		  )
	    (mapcar (function (lambda (x) (cons 10 x))) lst)
	    )
    )  
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:hatchkin(/)
  (vl-load-com)
  (princ "\nChon Cac Line, Polyline, Arc, Circle, Spline Hoac Ellipse De Tao Polyline Kin")
  (if (setq chonlinepolyline (ssget '((-4 . "<OR")(0 . "LINE")(0 . "CIRCLE")(0 . "SPLINE")(0 . "ARC")(0 . "ELLIPSE")(0 . "*POLYLINE")(-4 . "OR>"))))
    (progn   
      (setq chonpolyline (ssadd))
      (setq lsppolyline nil)
      (setq i 0)
      (repeat (sslength chonlinepolyline)
	(taopolyline (ACET-GEOM-OBJECT-POINT-LIST (ssname chonlinepolyline i)
		       (/ (vlax-curve-getdistatparam (ssname chonlinepolyline i) (vlax-curve-getendparam (ssname chonlinepolyline i)))
			  10000)) "0" 1)
	(ssadd (entlast) chonpolyline)
	(setq lsppolyline (append lsppolyline (list (ACET-GEOM-OBJECT-POINT-LIST (ssname chonlinepolyline i)
						      (/ (vlax-curve-getdistatparam (ssname chonlinepolyline i) (vlax-curve-getendparam (ssname chonlinepolyline i)))
							 10000)))))
	(setq i (+ i 1))
	)
      (setq lspgiaodiem (LM:IntersectionsInSet chonpolyline))
      (setq chonline (ssadd))
      (setq lspchonline nil)
      (setq lsp2diemline nil)
      (foreach lsp lsppolyline
	(foreach diemgiao lspgiaodiem
	  (setq lsp (DDH:pointtolsppoint diemgiao lsp))
	  )
	(setq i 0)
	(repeat (- (length lsp) 1)
	  (setq lsp2diemline (append lsp2diemline (list (list (nth i lsp) (nth (+ i 1) lsp)))))
	  (setq i (+ i 1))
	  )
	)
      (setq lsp2diemline (LM:Uniqueline lsp2diemline))
      (foreach line lsp2diemline
	(entmakex (list '(0 . "LINE")
			(cons 10 (car line))
			(cons 11 (cadr line))
			))
	(ssadd (entlast) chonline)
	(setq lspchonline (append lspchonline (list (vlax-ename->vla-object (entlast)))))
	)
      (or acDoc (setq acDoc (vla-get-activedocument (vlax-get-acad-object))))
      (setq ms (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace)))
      (if (setq lsptongregion (vlax-invoke ms 'AddRegion lspchonline))
	(progn
	  (command "ERASE" chonline "")
	  (command "ERASE" chonpolyline "")
	  (setq lspxetbien nil)
	  (foreach tungregion lsptongregion
	    (setq lspxetbien (append lspxetbien (list (list (vlax-vla-object->ename tungregion) (vlax-get-property tungregion 'area)))))
	    )
	  (setq lspxetbien (vl-sort lspxetbien (function (lambda (e1 e2) (> (cadr e1) (cadr e2))))))
	  (setq dientichtong 0.00)
	  (foreach dientich (cdr lspxetbien)
	    (setq dientichtong (+ dientichtong (cadr dientich)))
	    )
	  (if (<= (abs (- (cadr (car lspxetbien)) dientichtong)) 0.0001)
	    (entdel (car (car lspxetbien)))
	    )
	  (setq mau 1)
	  (foreach xetpl (cdr lspxetbien)
	    (if (>= mau 255)
	      (setq mau 1)
	      )
	    (command "hatch" "" "" "" (car xetpl) "")
	    (command "change" (entlast) "" "p" "c" mau "")
	    (setq mau (+ mau 1))
	    )
	  
	  )
	)
      )
    )
  )

Hj hj.. Em cám ơn bác nhiều lắm. Bác có thể giúp em thêm cái phần xóa mấy cái Region được tạo ra ko ah? Tạo ra mấy cái đó gây nhiều rác trên bản vẽ quá bác ah.


  • 0

#30 doanduyhung

doanduyhung

    biết vẽ spline

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

Đã gửi 17 January 2014 - 07:33 AM

Hj hj.. Em cám ơn bác nhiều lắm. Bác có thể giúp em thêm cái phần xóa mấy cái Region được tạo ra ko ah? Tạo ra mấy cái đó gây nhiều rác trên bản vẽ quá bác ah.

bạn thêm dòng này (entdel (car xetpl)) dưới dòng (command "hatch" "" "" "" (car xetpl) "")
  • 1

#31 huaductiep

huaductiep

    biết vẽ rectang

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

Đã gửi 17 January 2014 - 05:49 PM

Em sửa được rồi. Tuyệt quá. Ko biết bác có cách nào để khắc phục vấn đề những chỗ hở 1 chút thì ko hatch được ko ah?
Vì hình như khi Hatch cũng có tùy chọn để ta hatch những hình bị hở đúng ko nhỉ? Nếu giải quyết thêm được vấn đề này thì tuyệt quá.

Không biết phải làm sao để cám ơn các bác trên diễn đàn. Em xin gửi lời cám ơn chân thành tới các bác  :)


  • 0

#32 doanduyhung

doanduyhung

    biết vẽ spline

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

Đã gửi 19 January 2014 - 06:04 PM

Em sửa được rồi. Tuyệt quá. Ko biết bác có cách nào để khắc phục vấn đề những chỗ hở 1 chút thì ko hatch được ko ah?
Vì hình như khi Hatch cũng có tùy chọn để ta hatch những hình bị hở đúng ko nhỉ? Nếu giải quyết thêm được vấn đề này thì tuyệt quá.

Không biết phải làm sao để cám ơn các bác trên diễn đàn. Em xin gửi lời cám ơn chân thành tới các bác  :)

(defun LM:Intersections ( obj1 obj2 mode / l r )
    (setq l (vlax-invoke obj1 'intersectwith obj2 mode))
    (repeat (/ (length l) 3)
        (setq r (cons (list (car l) (cadr l) (caddr l)) r)
              l (cdddr l)
        )
    )
    (reverse r)
)
(defun LM:IntersectionsInSet ( ss / a b i j l )
    (repeat (setq i (sslength ss))
        (setq a (vlax-ename->vla-object (ssname ss (setq i (1- i)))))
        (repeat (setq j i)
            (setq b (vlax-ename->vla-object (ssname ss (setq j (1- j))))
                  l (cons (LM:Intersections a b acextendnone) l)
            )
        )
    )
    (apply 'append (reverse l))
)
(defun LM:IntersectionsInSetboth ( ss / a b i j l )
    (repeat (setq i (sslength ss))
        (setq a (vlax-ename->vla-object (ssname ss (setq i (1- i)))))
        (repeat (setq j i)
            (setq b (vlax-ename->vla-object (ssname ss (setq j (1- j))))
                  l (cons (LM:Intersections a b acextendboth) l)
            )
        )
    )
    (apply 'append (reverse l))
)
(defun DDH:pointtolsppoint (pointchen lsppointchen / vitrichen ii)
  (setq iii 0)
  (repeat (- (length lsppointchen) 1)
    (if (and (> (distance pointchen (nth (+ iii 1) lsppointchen)) 0.001)
	     (> (distance pointchen (nth iii lsppointchen)) 0.001)
	     )
      (progn
	(if (<= (abs (- (distance (nth iii lsppointchen) (nth (+ iii 1) lsppointchen))
			(+ (distance pointchen (nth (+ iii 1) lsppointchen))
			   (distance pointchen (nth iii lsppointchen))
			   )
			))
		     0.001)
	  (setq vitrichen (+ iii 1))
	  )
	)
      )
    (setq iii (+ iii 1))
    )
  (setq lsppointchen (LM:InsertNth pointchen vitrichen lsppointchen))
  )
(defun LM:InsertNth ( x n l )
  ((lambda ( k )
     (apply 'append
	    (mapcar '(lambda ( a ) (if (= n (setq k (1+ k))) (list x a) (list a))) l)
	    )
     )
    -1
    )
  )
(defun LM:Uniqueline ( l )
  (if l (cons (car l)
	      (LM:Uniqueline
		(vl-remove-if '(lambda (x) (or (and (equal (car x) (car (car l)))
						    (equal (cadr x) (cadr (car l))))
					       (and (equal (car x) (cadr (car l)))
						    (equal (cadr x) (car (car l))))
					       )
				 ) (cdr l))
		))))
(defun taopolyline (lst layer mau / x )
  (entmakex
    (append (list (cons 0 "LWPOLYLINE")
		  (cons 100 "AcDbEntity")
		  (cons 100 "AcDbPolyline")
		  (cons 90 (length lst))
		  (cons 70 0)
		  (cons 66 1)
		  (cons 8 layer)
		  (cons 62 mau)
		  )
	    (mapcar (function (lambda (x) (cons 10 x))) lst)
	    )
    )  
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:fixline(/)
  (setq khoangfix (getreal "\nNhap Khang Cach Max De Xet Fix Doi Tuong <1.00>:"))
  (if (= khoangfix nil)
    (setq khoangfix 1.00)
    )		       
  (princ "\nChon Cac Line, Polyline, Arc, Circle, Spline Hoac Ellipse De Tao Polyline Kin")
  (if (setq chonlinepolyline (ssget '((-4 . "<OR")(0 . "LINE")(0 . "CIRCLE")(0 . "SPLINE")(0 . "ARC")(0 . "ELLIPSE")(0 . "*POLYLINE")(-4 . "OR>"))))
    (progn
      (setq chonpolyline (ssadd))      
      (setq i 0)
      (repeat (sslength chonlinepolyline)
	(taopolyline (ACET-GEOM-OBJECT-POINT-LIST (ssname chonlinepolyline i)
		       (/ (vlax-curve-getdistatparam (ssname chonlinepolyline i) (vlax-curve-getendparam (ssname chonlinepolyline i)))
			  10000)) "0" 1)
	(ssadd (entlast) chonpolyline)
	(setq i (+ i 1))
	)
      (setq lspgiaodiem (LM:IntersectionsInSetboth chonpolyline))
      (setq i 0)
      (repeat (sslength chonpolyline)
	(setq toado (ACET-GEOM-OBJECT-POINT-LIST (ssname chonpolyline i)
		       (/ (vlax-curve-getdistatparam (ssname chonpolyline i) (vlax-curve-getendparam (ssname chonpolyline i)))
			  10000)))      
	(foreach diemgiao lspgiaodiem
	  (if (and (<= (distance (car toado) diemgiao) khoangfix)
		   (> (distance (car toado) diemgiao) 0.001))
	    (entmakex (list '(0 . "LINE")
			(cons 10 (car toado))
			(cons 11 diemgiao)
			))
	    )
	  )
	(foreach diemgiao lspgiaodiem
	  (if (and (<= (distance (last toado) diemgiao) khoangfix)
		   (> (distance (last toado) diemgiao) 0.001))
	    (entmakex (list '(0 . "LINE")
			(cons 10 (last toado))
			(cons 11 diemgiao)
			))
	    )
	  )
	(entdel (ssname chonpolyline i))
	(setq i (+ i 1))
	)
      )
    )
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:hatchkin(/)
  (vl-load-com)
  (princ "\nChon Cac Line, Polyline, Arc, Circle, Spline Hoac Ellipse De Tao Polyline Kin")
  (if (setq chonlinepolyline (ssget '((-4 . "<OR")(0 . "LINE")(0 . "CIRCLE")(0 . "SPLINE")(0 . "ARC")(0 . "ELLIPSE")(0 . "*POLYLINE")(-4 . "OR>"))))
    (progn   
      (setq chonpolyline (ssadd))
      (setq lsppolyline nil)
      (setq i 0)
      (repeat (sslength chonlinepolyline)
	(taopolyline (ACET-GEOM-OBJECT-POINT-LIST (ssname chonlinepolyline i)
		       (/ (vlax-curve-getdistatparam (ssname chonlinepolyline i) (vlax-curve-getendparam (ssname chonlinepolyline i)))
			  10000)) "0" 1)
	(ssadd (entlast) chonpolyline)
	(setq lsppolyline (append lsppolyline (list (ACET-GEOM-OBJECT-POINT-LIST (ssname chonlinepolyline i)
						      (/ (vlax-curve-getdistatparam (ssname chonlinepolyline i) (vlax-curve-getendparam (ssname chonlinepolyline i)))
							 10000)))))
	(setq i (+ i 1))
	)
      (setq lspgiaodiem (LM:IntersectionsInSet chonpolyline))
      (setq chonline (ssadd))
      (setq lspchonline nil)
      (setq lsp2diemline nil)
      (foreach lsp lsppolyline
	(foreach diemgiao lspgiaodiem
	  (setq lsp (DDH:pointtolsppoint diemgiao lsp))
	  )
	(setq i 0)
	(repeat (- (length lsp) 1)
	  (setq lsp2diemline (append lsp2diemline (list (list (nth i lsp) (nth (+ i 1) lsp)))))
	  (setq i (+ i 1))
	  )
	)
      (setq lsp2diemline (LM:Uniqueline lsp2diemline))
      (foreach line lsp2diemline
	(entmakex (list '(0 . "LINE")
			(cons 10 (car line))
			(cons 11 (cadr line))
			))
	(ssadd (entlast) chonline)
	(setq lspchonline (append lspchonline (list (vlax-ename->vla-object (entlast)))))
	)
      (or acDoc (setq acDoc (vla-get-activedocument (vlax-get-acad-object))))
      (setq ms (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace)))
      (if (setq lsptongregion (vlax-invoke ms 'AddRegion lspchonline))
	(progn
	  (command "ERASE" chonline "")
	  (command "ERASE" chonpolyline "")
	  (setq lspxetbien nil)
	  (foreach tungregion lsptongregion
	    (setq lspxetbien (append lspxetbien (list (list (vlax-vla-object->ename tungregion) (vlax-get-property tungregion 'area)))))
	    )
	  (setq lspxetbien (vl-sort lspxetbien (function (lambda (e1 e2) (> (cadr e1) (cadr e2))))))
	  (setq dientichtong 0.00)
	  (foreach dientich (cdr lspxetbien)
	    (setq dientichtong (+ dientichtong (cadr dientich)))
	    )
	  (if (<= (abs (- (cadr (car lspxetbien)) dientichtong)) 0.0001)
	    (entdel (car (car lspxetbien)))
	    )
	  (setq mau 1)
	  (foreach xetpl (cdr lspxetbien)
	    (if (>= mau 255)
	      (setq mau 1)
	      )
	    (command "hatch" "" "" "" (car xetpl) "")
	    (entdel (car xetpl))
	    (command "change" (entlast) "" "p" "c" mau "")
	    (setq mau (+ mau 1))
	    )	  
	  )
	)
      )
    )
  )

thực hiện lệnh fixline để đóng những khoảng hở trước

test2.gif


  • 2

#33 Tue_NV

Tue_NV

    KS Võ Quang Tuệ

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

Đã gửi 20 January 2014 - 07:01 AM

Chào bạn doanduyhung!

Mình thấy khi quét "nhiều hình" để Hatch Lisp chạy ra thì có Region Tổng bo quanh region của hình.

Vậy chỉ cần loại bỏ Region tổng đó là ta có thể Hatch 1 loạt cho rất nhiều hình mà không cần kiếm cái Region tổng (Hatch tổng) đó ở đâu để xoá đi? Không biết bạn đã có giải pháp gì chưa?


  • 0

#34 doanduyhung

doanduyhung

    biết vẽ spline

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

Đã gửi 20 January 2014 - 07:51 AM

Chào bạn doanduyhung!
Mình thấy khi quét "nhiều hình" để Hatch Lisp chạy ra thì có Region Tổng bo quanh region của hình.
Vậy chỉ cần loại bỏ Region tổng đó là ta có thể Hatch 1 loạt cho rất nhiều hình mà không cần kiếm cái Region tổng (Hatch tổng) đó ở đâu để xoá đi? Không biết bạn đã có giải pháp gì chưa?

lisp chỉ xét cho 1 nhóm obj giao nhau thôi, còn chọn nhiều nhóm thì có lẻ xét nheo cách truyền các đối tượng giao nhau để phân vùng lại từng nhóm thì có lẻ khả thi
  • 0

#35 huaductiep

huaductiep

    biết vẽ rectang

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

Đã gửi 20 January 2014 - 09:55 PM

(defun LM:Intersections ( obj1 obj2 mode / l r )
    (setq l (vlax-invoke obj1 'intersectwith obj2 mode))
    (repeat (/ (length l) 3)
        (setq r (cons (list (car l) (cadr l) (caddr l)) r)
              l (cdddr l)
        )
    )
    (reverse r)
)
(defun LM:IntersectionsInSet ( ss / a b i j l )
    (repeat (setq i (sslength ss))
        (setq a (vlax-ename->vla-object (ssname ss (setq i (1- i)))))
        (repeat (setq j i)
            (setq b (vlax-ename->vla-object (ssname ss (setq j (1- j))))
                  l (cons (LM:Intersections a b acextendnone) l)
            )
        )
    )
    (apply 'append (reverse l))
)
(defun LM:IntersectionsInSetboth ( ss / a b i j l )
    (repeat (setq i (sslength ss))
        (setq a (vlax-ename->vla-object (ssname ss (setq i (1- i)))))
        (repeat (setq j i)
            (setq b (vlax-ename->vla-object (ssname ss (setq j (1- j))))
                  l (cons (LM:Intersections a b acextendboth) l)
            )
        )
    )
    (apply 'append (reverse l))
)
(defun DDH:pointtolsppoint (pointchen lsppointchen / vitrichen ii)
  (setq iii 0)
  (repeat (- (length lsppointchen) 1)
    (if (and (> (distance pointchen (nth (+ iii 1) lsppointchen)) 0.001)
	     (> (distance pointchen (nth iii lsppointchen)) 0.001)
	     )
      (progn
	(if (<= (abs (- (distance (nth iii lsppointchen) (nth (+ iii 1) lsppointchen))
			(+ (distance pointchen (nth (+ iii 1) lsppointchen))
			   (distance pointchen (nth iii lsppointchen))
			   )
			))
		     0.001)
	  (setq vitrichen (+ iii 1))
	  )
	)
      )
    (setq iii (+ iii 1))
    )
  (setq lsppointchen (LM:InsertNth pointchen vitrichen lsppointchen))
  )
(defun LM:InsertNth ( x n l )
  ((lambda ( k )
     (apply 'append
	    (mapcar '(lambda ( a ) (if (= n (setq k (1+ k))) (list x a) (list a))) l)
	    )
     )
    -1
    )
  )
(defun LM:Uniqueline ( l )
  (if l (cons (car l)
	      (LM:Uniqueline
		(vl-remove-if '(lambda (x) (or (and (equal (car x) (car (car l)))
						    (equal (cadr x) (cadr (car l))))
					       (and (equal (car x) (cadr (car l)))
						    (equal (cadr x) (car (car l))))
					       )
				 ) (cdr l))
		))))
(defun taopolyline (lst layer mau / x )
  (entmakex
    (append (list (cons 0 "LWPOLYLINE")
		  (cons 100 "AcDbEntity")
		  (cons 100 "AcDbPolyline")
		  (cons 90 (length lst))
		  (cons 70 0)
		  (cons 66 1)
		  (cons 8 layer)
		  (cons 62 mau)
		  )
	    (mapcar (function (lambda (x) (cons 10 x))) lst)
	    )
    )  
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:fixline(/)
  (setq khoangfix (getreal "\nNhap Khang Cach Max De Xet Fix Doi Tuong <1.00>:"))
  (if (= khoangfix nil)
    (setq khoangfix 1.00)
    )		       
  (princ "\nChon Cac Line, Polyline, Arc, Circle, Spline Hoac Ellipse De Tao Polyline Kin")
  (if (setq chonlinepolyline (ssget '((-4 . "<OR")(0 . "LINE")(0 . "CIRCLE")(0 . "SPLINE")(0 . "ARC")(0 . "ELLIPSE")(0 . "*POLYLINE")(-4 . "OR>"))))
    (progn
      (setq chonpolyline (ssadd))      
      (setq i 0)
      (repeat (sslength chonlinepolyline)
	(taopolyline (ACET-GEOM-OBJECT-POINT-LIST (ssname chonlinepolyline i)
		       (/ (vlax-curve-getdistatparam (ssname chonlinepolyline i) (vlax-curve-getendparam (ssname chonlinepolyline i)))
			  10000)) "0" 1)
	(ssadd (entlast) chonpolyline)
	(setq i (+ i 1))
	)
      (setq lspgiaodiem (LM:IntersectionsInSetboth chonpolyline))
      (setq i 0)
      (repeat (sslength chonpolyline)
	(setq toado (ACET-GEOM-OBJECT-POINT-LIST (ssname chonpolyline i)
		       (/ (vlax-curve-getdistatparam (ssname chonpolyline i) (vlax-curve-getendparam (ssname chonpolyline i)))
			  10000)))      
	(foreach diemgiao lspgiaodiem
	  (if (and (<= (distance (car toado) diemgiao) khoangfix)
		   (> (distance (car toado) diemgiao) 0.001))
	    (entmakex (list '(0 . "LINE")
			(cons 10 (car toado))
			(cons 11 diemgiao)
			))
	    )
	  )
	(foreach diemgiao lspgiaodiem
	  (if (and (<= (distance (last toado) diemgiao) khoangfix)
		   (> (distance (last toado) diemgiao) 0.001))
	    (entmakex (list '(0 . "LINE")
			(cons 10 (last toado))
			(cons 11 diemgiao)
			))
	    )
	  )
	(entdel (ssname chonpolyline i))
	(setq i (+ i 1))
	)
      )
    )
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:hatchkin(/)
  (vl-load-com)
  (princ "\nChon Cac Line, Polyline, Arc, Circle, Spline Hoac Ellipse De Tao Polyline Kin")
  (if (setq chonlinepolyline (ssget '((-4 . "<OR")(0 . "LINE")(0 . "CIRCLE")(0 . "SPLINE")(0 . "ARC")(0 . "ELLIPSE")(0 . "*POLYLINE")(-4 . "OR>"))))
    (progn   
      (setq chonpolyline (ssadd))
      (setq lsppolyline nil)
      (setq i 0)
      (repeat (sslength chonlinepolyline)
	(taopolyline (ACET-GEOM-OBJECT-POINT-LIST (ssname chonlinepolyline i)
		       (/ (vlax-curve-getdistatparam (ssname chonlinepolyline i) (vlax-curve-getendparam (ssname chonlinepolyline i)))
			  10000)) "0" 1)
	(ssadd (entlast) chonpolyline)
	(setq lsppolyline (append lsppolyline (list (ACET-GEOM-OBJECT-POINT-LIST (ssname chonlinepolyline i)
						      (/ (vlax-curve-getdistatparam (ssname chonlinepolyline i) (vlax-curve-getendparam (ssname chonlinepolyline i)))
							 10000)))))
	(setq i (+ i 1))
	)
      (setq lspgiaodiem (LM:IntersectionsInSet chonpolyline))
      (setq chonline (ssadd))
      (setq lspchonline nil)
      (setq lsp2diemline nil)
      (foreach lsp lsppolyline
	(foreach diemgiao lspgiaodiem
	  (setq lsp (DDH:pointtolsppoint diemgiao lsp))
	  )
	(setq i 0)
	(repeat (- (length lsp) 1)
	  (setq lsp2diemline (append lsp2diemline (list (list (nth i lsp) (nth (+ i 1) lsp)))))
	  (setq i (+ i 1))
	  )
	)
      (setq lsp2diemline (LM:Uniqueline lsp2diemline))
      (foreach line lsp2diemline
	(entmakex (list '(0 . "LINE")
			(cons 10 (car line))
			(cons 11 (cadr line))
			))
	(ssadd (entlast) chonline)
	(setq lspchonline (append lspchonline (list (vlax-ename->vla-object (entlast)))))
	)
      (or acDoc (setq acDoc (vla-get-activedocument (vlax-get-acad-object))))
      (setq ms (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace)))
      (if (setq lsptongregion (vlax-invoke ms 'AddRegion lspchonline))
	(progn
	  (command "ERASE" chonline "")
	  (command "ERASE" chonpolyline "")
	  (setq lspxetbien nil)
	  (foreach tungregion lsptongregion
	    (setq lspxetbien (append lspxetbien (list (list (vlax-vla-object->ename tungregion) (vlax-get-property tungregion 'area)))))
	    )
	  (setq lspxetbien (vl-sort lspxetbien (function (lambda (e1 e2) (> (cadr e1) (cadr e2))))))
	  (setq dientichtong 0.00)
	  (foreach dientich (cdr lspxetbien)
	    (setq dientichtong (+ dientichtong (cadr dientich)))
	    )
	  (if (<= (abs (- (cadr (car lspxetbien)) dientichtong)) 0.0001)
	    (entdel (car (car lspxetbien)))
	    )
	  (setq mau 1)
	  (foreach xetpl (cdr lspxetbien)
	    (if (>= mau 255)
	      (setq mau 1)
	      )
	    (command "hatch" "" "" "" (car xetpl) "")
	    (entdel (car xetpl))
	    (command "change" (entlast) "" "p" "c" mau "")
	    (setq mau (+ mau 1))
	    )	  
	  )
	)
      )
    )
  )

thực hiện lệnh fixline để đóng những khoảng hở trước

test2.gif

Ý tưởng cải tiến này của bác tuyệt quá . Em cám ơn bác Hưng ah :)


  • 1

#36 Tue_NV

Tue_NV

    KS Võ Quang Tuệ

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

Đã gửi 21 January 2014 - 09:53 AM

lisp chỉ xét cho 1 nhóm obj giao nhau thôi, còn chọn nhiều nhóm thì có lẻ xét nheo cách truyền các đối tượng giao nhau để phân vùng lại từng nhóm thì có lẻ khả thi

 

ĐỌc code bạn viết mình cũng biết, bạn xét 1 nhóm obj giao nhau dựa trên việc lọc diện tích

Việc tạo REGION của nhiều nhóm obj nó không tuân theo 1 quy luật nào cả, Việc loại bỏ cái REGION tổng của nhóm obj giao nhau khi quét hàng loạt xem ra rất khó, mình cũng chưa tìm ra cách :blush: 


  • 0

#37 doanduyhung

doanduyhung

    biết vẽ spline

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

Đã gửi 21 January 2014 - 10:22 AM

 
ĐỌc code bạn viết mình cũng biết, bạn xét 1 nhóm obj giao nhau dựa trên việc lọc diện tích
Việc tạo REGION của nhiều nhóm obj nó không tuân theo 1 quy luật nào cả, Việc loại bỏ cái REGION tổng của nhóm obj giao nhau khi quét hàng loạt xem ra rất khó, mình cũng chưa tìm ra cách :blush: 

đây là lisp trả về tập hợp từng nhóm chọn, ko gộp vào file lisp của mình do file cad mẫu chứa nhiều đối tượng trùng nhau quá nên lisp có khi phân nhóm giao không hiểu được (có lẻ phải kết hợp overkill vào thỉ ổn hơn)
*************************************************************
(defun LM:Intersections ( obj1 obj2 mode / l r )
(setq l (vlax-invoke obj1 'intersectwith obj2 mode))
(repeat (/ (length l) 3)
(setq r (cons (list (car l) (cadr l) (caddr l)) r)
l (cdddr l)
)
)
(reverse r)
)
(defun LM:IntersectionsBetweenSets ( s1 s2 / a b i j l )
(repeat (setq i (sslength s1))
(setq a (vlax-ename->vla-object (ssname s1 (setq i (1- i)))))
(repeat (setq j (sslength s2))
(setq b (vlax-ename->vla-object (ssname s2 (setq j (1- j))))
l (cons (LM:Intersections a b acextendnone) l)
)
)
)
(apply 'append (reverse l))
)
(defun c:nhomgiao(/)
(if (setq doituong (ssget))
(progn
(setq lspnhomgiao nil)
(while (> (sslength doituong) 0)
(setq tungnhom (ssadd))
(ssadd (ssname doituong 0) tungnhom)
(ssdel (ssname doituong 0) doituong)
(setq i 0)
(repeat (sslength doituong)
(if (LM:IntersectionsBetweenSets tungnhom (ACET-LIST-TO-SS (list (ssname doituong i))))
(progn
(ssadd (ssname doituong i) tungnhom)
(ssdel (ssname doituong i) doituong)
(setq i (- i 1))
)
)
(setq i (+ i 1))
)
(setq lspnhomgiao (append lspnhomgiao (list tungnhom)))
)
)
)
)
************************************
  • 2

#38 ndtnv

ndtnv

    biết lệnh minsert

  • Members
  • PipPipPipPipPipPip
  • 437 Bài viết
Điểm đánh giá: 384 (khá)

Đã gửi 21 January 2014 - 02:02 PM

Vì không có nhiều thời gian nên tôi viết tạm phần xử lý REGION tổng. Chương trình chạy hơi chậm vì xử lý các REGION

- Thêm hàm FiltReg : Lọc REGION tổng

- Sửa lại c:hatchkin

Các hàm khác như cũ

(defun FiltReg (rg / el i j n r rt ss)
    (setq i -1 n (1- (length rg)) el (entlast))
    (repeat n
        (setq i (1+ i) j n r nil)
        (while (and (not r) (> j i))
            (setq ss (ssadd))
            (vla-copy (vlax-ename->vla-object(car(nth i rg))))
            (setq ss (ssadd (entlast) ss))
            (vla-copy (vlax-ename->vla-object(car(nth j rg))))
            (setq ss (ssadd (entlast) ss))
            (vl-cmdf "INTERSECT" ss "")
            (if (not (eq el (entlast)))
                (progn
                    (setq r (nth i rg))
                    (setq rt (append rt (list r)))
                    (entdel (entlast)))
            )
            (setq j (1- j))
        )
    )
    rt
)

(defun c:hatchkin(/)
  (princ "\nChon Cac Line, Polyline, Arc, Circle, Spline Hoac Ellipse De Tao Polyline Kin")
  (if (setq chonlinepolyline (ssget '((-4 . "<OR")(0 . "LINE")(0 . "CIRCLE")(0 . "SPLINE")(0 . "ARC")(0 . "ELLIPSE")(0 . "*POLYLINE")(-4 . "OR>"))))
    (progn   
      (setq chonpolyline (ssadd))
      (setq lsppolyline nil)
      (setq i 0)
      (repeat (sslength chonlinepolyline)
    (taopolyline (ACET-GEOM-OBJECT-POINT-LIST (ssname chonlinepolyline i)
               (/ (vlax-curve-getdistatparam (ssname chonlinepolyline i) (vlax-curve-getendparam (ssname chonlinepolyline i)))
              10000)) "0" 1)
    (ssadd (entlast) chonpolyline)
    (setq lsppolyline (append lsppolyline (list (ACET-GEOM-OBJECT-POINT-LIST (ssname chonlinepolyline i)
                              (/ (vlax-curve-getdistatparam (ssname chonlinepolyline i) (vlax-curve-getendparam (ssname chonlinepolyline i)))
                             10000)))))
    (setq i (+ i 1))
    )
      (setq lspgiaodiem (LM:IntersectionsInSet chonpolyline))
      (setq chonline (ssadd))
      (setq lspchonline nil)
      (setq lsp2diemline nil)
      (foreach lsp lsppolyline
    (foreach diemgiao lspgiaodiem
      (setq lsp (DDH:pointtolsppoint diemgiao lsp))
      )
    (setq i 0)
    (repeat (- (length lsp) 1)
      (setq lsp2diemline (append lsp2diemline (list (list (nth i lsp) (nth (+ i 1) lsp)))))
      (setq i (+ i 1))
      )
    )
      (setq lsp2diemline (LM:Uniqueline lsp2diemline))
      (foreach line lsp2diemline
    (entmakex (list '(0 . "LINE")
            (cons 10 (car line))
            (cons 11 (cadr line))
            ))
    (ssadd (entlast) chonline)
    (setq lspchonline (append lspchonline (list (vlax-ename->vla-object (entlast)))))
    )
      (or acDoc (setq acDoc (vla-get-activedocument (vlax-get-acad-object))))
      (setq ms (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace)))
      (if (setq lsptongregion (vlax-invoke ms 'AddRegion lspchonline))
    (progn
      (command "ERASE" chonline "")
      (command "ERASE" chonpolyline "")
      (setq lspxetbien nil)
      (foreach tungregion lsptongregion
        (setq lspxetbien (append lspxetbien (list (list (vlax-vla-object->ename tungregion) (vlax-get-property tungregion 'area)))))
        )
      (setq lspxetbien (vl-sort lspxetbien (function (lambda (e1 e2) (> (cadr e1) (cadr e2))))))
        (setq rt (FiltReg lspxetbien))
      (foreach r rt
            (setq lspxetbien (vl-remove r lspxetbien))
        (entdel (car r))
      )
;;;      (setq dientichtong 0.00)
;;;      (foreach dientich (cdr lspxetbien)
;;;        (setq dientichtong (+ dientichtong (cadr dientich)))
;;;        )
;;;      (if (<= (abs (- (cadr (car lspxetbien)) dientichtong)) 0.0001)
;;;        (entdel (car (car lspxetbien)))
;;;        )
      (setq mau 0)
      (foreach xetpl lspxetbien
            (setq mau (1+ (rem mau 255)))
        (command "hatch" "" "" "" (car xetpl) "")
        (entdel (car xetpl))
        (command "change" (entlast) "" "p" "c" mau "")
        )
      )
    )
      )
    )
  )
 

  • 4