Chuyển đến nội dung
Diễn đàn CADViet

NgọcH

Thành viên
 Xem Hồ Sơ  Xem hoạt động của họ

  • Số lượng nội dung

    38

  • Đã tham gia

  • Lần ghé thăm cuối

  • Ngày trúng

    1

Bài đăng được đăng bởi NgọcH

  8. Đã đăng · Trả lời báo cáo

    Nó lỗi luôn rùi b ơi. Với lại có cách nào để bỏ qua hình bên trong không điền kích thước không b 

    52 phút trước, conghoa đã nói: 
    
;; Minimum Bounding Box  -  Lee Mac (modified)
(defun LM:minboundingbox ( sel tol / ang box bx1 bx2 cen idx lst obj rtn wid len pts edges)
    (if (and sel (< 0.0 tol 1.0))
        (progn
            (repeat (setq idx (sslength sel))
                (setq obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))))
                (if (and (vlax-method-applicable-p obj 'getboundingbox)
                         (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list obj 'a 'b))))
                    )
                    (setq lst (cons (vla-copy obj) lst))
                )
            )
            (if lst
                (progn
                    (setq box (LM:objlstboundingbox lst)
                          tol (* tol pi)
                          cen (apply 'mapcar (cons '(lambda ( a b ) (/ (+ a b) 2.0)) box))
                          bx1 (* (- (caadr box) (caar box)) (- (cadadr box) (cadar box)))
                          rtn (list 0.0 box)
                          ang 0.0
                    )
                    (while (< (setq ang (+ ang tol)) pi)
                        (foreach obj lst (vlax-invoke obj 'rotate cen tol))
                        (setq box (LM:objlstboundingbox lst)
                              bx2 (* (- (caadr box) (caar box)) (- (cadadr box) (cadar box)))
                        )
                        (if (< bx2 bx1)
                            (setq bx1 bx2
                                  rtn (list ang box))
                        )
                    )
                    (foreach obj lst (vla-delete obj))
                    (setq pts (LM:rotatepoints
                                (mapcar '(lambda ( a ) (mapcar '(lambda ( b ) (apply b (cdr rtn))) a))
                                    '(
                                        (caar   cadar)
                                        (caadr  cadar)
                                        (caadr cadadr)
                                        (caar  cadadr)
                                    )
                                )
                                cen (- (car rtn))
                              )
                    )
                    (setq edges (list
                                    (distance (nth 0 pts) (nth 1 pts))
                                    (distance (nth 1 pts) (nth 2 pts))
                                    (distance (nth 2 pts) (nth 3 pts))
                                    (distance (nth 3 pts) (nth 0 pts))
                                )
                    )
                    (setq len (apply 'max edges))
                    (setq wid (apply 'min edges))
                    (list pts len wid)
                )
            )
        )
    )
)

;; Object List Bounding Box  -  Lee Mac
(defun LM:objlstboundingbox ( lst / llp ls1 ls2 urp )
    (foreach obj lst
        (vla-getboundingbox obj 'llp 'urp)
        (setq ls1 (cons (vlax-safearray->list llp) ls1)
              ls2 (cons (vlax-safearray->list urp) ls2)
        )
    )
    (mapcar '(lambda ( a b ) (apply 'mapcar (cons a b))) '(min max) (list ls1 ls2))
)

;; Rotate Points  -  Lee Mac
(defun LM:rotatepoints ( lst bpt ang / mat vec )
    (setq mat
        (list
            (list (cos ang) (sin (- ang)) 0.0)
            (list (sin ang) (cos ang)     0.0)
           '(0.0 0.0 1.0)
        )
    )
    (setq vec (mapcar '- bpt (mxv mat bpt)))
    (mapcar '(lambda ( x ) (mapcar '+ (mxv mat x) vec)) lst)
)

;; Matrix x Vector - Vladimir Nesterovsky
(defun mxv ( m v )
    (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)

(defun C:MinBoxToPline (/ sel plines text text_obj txtstyle txtheight txtlayer i pline cen result len wid txtdim pts edge1 edge2 long_edge text_angle box_ents)
    (vl-load-com)
    (setvar "CMDECHO" 0) ; Tat echo lenh

    (princ "\nChon nhieu Pline kin de tinh bounding box va ghi kich thuoc: ")
    (if (setq plines (ssget '((0 . "LWPOLYLINE") (70 . 1))))
        (progn
            (princ "\nChon text mau de lay thong so: ")
            (while (not (setq text (ssget ":S" '((0 . "TEXT")))))
                (princ "\nVui long chon mot doi tuong Text!"))

            (setq text (ssname text 0))
            (setq text_obj (vlax-ename->vla-object text))
            (setq txtstyle  (vla-get-StyleName text_obj))
            (setq txtheight (vla-get-Height text_obj))
            (setq txtlayer  (vla-get-Layer text_obj)) ; Lay layer cua text goc
            (setvar "TEXTSTYLE" txtstyle)

            (setq box_ents '())
            (setq i 0)
            (repeat (sslength plines)
                (setq pline (ssname plines i))
                (setq sel (ssadd))
                (ssadd pline sel)

                (setq result (LM:minboundingbox sel 0.01))
                (if result
                    (progn
                        (setq pts (car result))
                        (setq len (cadr result))
                        (setq wid (caddr result))

                        (vla-GetBoundingBox (vlax-ename->vla-object pline) 'minpt 'maxpt)
                        (setq cen (mapcar '/
                                        (mapcar '+ (vlax-safearray->list minpt) (vlax-safearray->list maxpt))
                                        '(2 2 2)))

                        ; Xac dinh canh dai nhat va tinh goc nghieng, dong bo voi len va wid
                        (setq edge1 (distance (nth 0 pts) (nth 1 pts)))
                        (setq edge2 (distance (nth 1 pts) (nth 2 pts)))
                        (if (> edge1 edge2)
                            (progn
                                (setq long_edge (list (nth 0 pts) (nth 1 pts)))
                                (setq text_angle (angle (nth 0 pts) (nth 1 pts)))
                                (setq len edge1 wid edge2)
                            )
                            (progn
                                (setq long_edge (list (nth 1 pts) (nth 2 pts)))
                                (setq text_angle (angle (nth 1 pts) (nth 2 pts)))
                                (setq len edge2 wid edge1)
                            )
                        )

                        ; Dieu chinh goc text de khong bi nguoc
                        (cond
                            ((and (> text_angle (/ pi 2)) (<= text_angle (* pi 1.5))) ; 90° den 270°
                             (setq text_angle (- text_angle pi))) ; Giam 180°
                            ((> text_angle (* pi 1.5)) ; > 270°
                             (setq text_angle (- text_angle (* 2 pi)))) ; Giam 360°
                            ((< text_angle (- (/ pi 2))) ; < -90°
                             (setq text_angle (+ text_angle pi))) ; Cong 180°
                        )

                        (setq txtdim (strcat (rtos wid 2 2) "x" (rtos len 2 2)))
                        (command "_TEXT" "_J" "_MC" cen txtheight (* 180 (/ text_angle pi)) txtdim)
                        ; Dat layer cua text moi giong text goc
                        (if (tblobjname "LAYER" txtlayer)
                            (command "_CHPROP" (entlast) "" "_LA" txtlayer "")
                            (princ (strcat "\nLayer '" txtlayer "' khong ton tai!"))
                        )

                        (entmake
                            (append
                               '(
                                    (000 . "LWPOLYLINE")
                                    (100 . "AcDbEntity")
                                    (100 . "AcDbPolyline")
                                    (090 . 4)
                                    (070 . 1)
                                )
                                (mapcar '(lambda ( p ) (cons 10 p)) pts)
                            )
                        )
                        (setq box_ents (cons (entlast) box_ents))
                    )
                    (princ (strcat "\nKhong the tinh bounding box cho Pline thu " (itoa (1+ i)) "."))
                )
                (setq i (1+ i))
            )

            (foreach ent box_ents
                (if (entget ent) (entdel ent))
            )
            (princ "\nDa ghi kich thuoc vao cac Pline va xoa bounding box!")
        )
        (princ "\nKhong co Pline kin nao duoc chon.")
    )
    (setvar "CMDECHO" 1)
    (princ)
)
(vl-load-com) (princ)

    Bạn thử lại xem được chưa.

     

     

    image.png

    image.png

  9. Đã đăng · Trả lời báo cáo

    1 giờ} trướ}c, conghoa đã nói: 
    
;; Minimum Bounding Box  -  Lee Mac (modified)
(defun LM:minboundingbox ( sel tol / ang box bx1 bx2 cen idx lst obj rtn wid len pts edges)
    (if (and sel (< 0.0 tol 1.0))
        (progn
            (repeat (setq idx (sslength sel))
                (setq obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))))
                (if (and (vlax-method-applicable-p obj 'getboundingbox)
                         (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list obj 'a 'b))))
                    )
                    (setq lst (cons (vla-copy obj) lst))
                )
            )
            (if lst
                (progn
                    (setq box (LM:objlstboundingbox lst)
                          tol (* tol pi)
                          cen (apply 'mapcar (cons '(lambda ( a b ) (/ (+ a b) 2.0)) box))
                          bx1 (* (- (caadr box) (caar box)) (- (cadadr box) (cadar box)))
                          rtn (list 0.0 box)
                          ang 0.0
                    )
                    (while (< (setq ang (+ ang tol)) pi)
                        (foreach obj lst (vlax-invoke obj 'rotate cen tol))
                        (setq box (LM:objlstboundingbox lst)
                              bx2 (* (- (caadr box) (caar box)) (- (cadadr box) (cadar box)))
                        )
                        (if (< bx2 bx1)
                            (setq bx1 bx2
                                  rtn (list ang box))
                        )
                    )
                    (foreach obj lst (vla-delete obj))
                    (setq pts (LM:rotatepoints
                                (mapcar '(lambda ( a ) (mapcar '(lambda ( b ) (apply b (cdr rtn))) a))
                                    '(
                                        (caar   cadar)
                                        (caadr  cadar)
                                        (caadr cadadr)
                                        (caar  cadadr)
                                    )
                                )
                                cen (- (car rtn))
                              )
                    )
                    (setq edges (list
                                    (distance (nth 0 pts) (nth 1 pts))
                                    (distance (nth 1 pts) (nth 2 pts))
                                    (distance (nth 2 pts) (nth 3 pts))
                                    (distance (nth 3 pts) (nth 0 pts))
                                )
                    )
                    (setq len (apply 'max edges))
                    (setq wid (apply 'min edges))
                    (list pts len wid)
                )
            )
        )
    )
)

;; Object List Bounding Box  -  Lee Mac
(defun LM:objlstboundingbox ( lst / llp ls1 ls2 urp )
    (foreach obj lst
        (vla-getboundingbox obj 'llp 'urp)
        (setq ls1 (cons (vlax-safearray->list llp) ls1)
              ls2 (cons (vlax-safearray->list urp) ls2)
        )
    )
    (mapcar '(lambda ( a b ) (apply 'mapcar (cons a b))) '(min max) (list ls1 ls2))
)

;; Rotate Points  -  Lee Mac
(defun LM:rotatepoints ( lst bpt ang / mat vec )
    (setq mat
        (list
            (list (cos ang) (sin (- ang)) 0.0)
            (list (sin ang) (cos ang)     0.0)
           '(0.0 0.0 1.0)
        )
    )
    (setq vec (mapcar '- bpt (mxv mat bpt)))
    (mapcar '(lambda ( x ) (mapcar '+ (mxv mat x) vec)) lst)
)

;; Matrix x Vector - Vladimir Nesterovsky
(defun mxv ( m v )
    (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)

(defun C:Test (/ sel plines text txtstyle txtheight i pline cen result len wid txtdim pts edge1 edge2 long_edge text_angle box_ents)
    (vl-load-com)
    (setvar "CMDECHO" 0) ; Tat echo lenh

    (princ "\nChon nhieu Pline kin de tinh bounding box va ghi kich thuoc: ")
    (if (setq plines (ssget '((0 . "LWPOLYLINE") (70 . 1))))
        (progn
            (princ "\nChon text mau de lay kieu chu va chieu cao: ")
            (while (not (setq text (ssget ":S" '((0 . "TEXT")))))
                (princ "\nVui long chon mot doi tuong Text!"))

            (setq text (ssname text 0))
            (setq text_obj (vlax-ename->vla-object text))
            (setq txtstyle (vla-get-StyleName text_obj))
            (setq txtheight (vla-get-Height text_obj))
            (setvar "TEXTSTYLE" txtstyle)

            (setq box_ents '())
            (setq i 0)
            (repeat (sslength plines)
                (setq pline (ssname plines i))
                (setq sel (ssadd))
                (ssadd pline sel)

                (setq result (LM:minboundingbox sel 0.01))
                (if result
                    (progn
                        (setq pts (car result))
                        (setq len (cadr result))
                        (setq wid (caddr result))

                        (vla-GetBoundingBox (vlax-ename->vla-object pline) 'minpt 'maxpt)
                        (setq cen (mapcar '/
                                        (mapcar '+ (vlax-safearray->list minpt) (vlax-safearray->list maxpt))
                                        '(2 2 2)))

                        ; Xac dinh canh dai nhat va tinh goc nghieng, dong bo voi len va wid
                        (setq edge1 (distance (nth 0 pts) (nth 1 pts)))
                        (setq edge2 (distance (nth 1 pts) (nth 2 pts)))
                        (if (> edge1 edge2)
                            (progn
                                (setq long_edge (list (nth 0 pts) (nth 1 pts)))
                                (setq text_angle (angle (nth 0 pts) (nth 1 pts)))
                                (setq len edge1 wid edge2)
                            )
                            (progn
                                (setq long_edge (list (nth 1 pts) (nth 2 pts)))
                                (setq text_angle (angle (nth 1 pts) (nth 2 pts)))
                                (setq len edge2 wid edge1)
                            )
                        )

                        ; Dieu chinh goc text de khong bi nguoc
                        (cond
                            ((and (> text_angle (/ pi 2)) (<= text_angle (* pi 1.5))) ; 90° den 270°
                             (setq text_angle (- text_angle pi))) ; Giam 180°
                            ((> text_angle (* pi 1.5)) ; > 270°
                             (setq text_angle (- text_angle (* 2 pi)))) ; Giam 360° de ve khoang -90° den 90°
                            ((< text_angle (- (/ pi 2))) ; < -90°
                             (setq text_angle (+ text_angle pi))) ; Cong 180°
                        )

                        (setq txtdim (strcat (rtos wid 2 2) "x" (rtos len 2 2)))
                        (command "_TEXT" "_J" "_MC" cen txtheight (* 180 (/ text_angle pi)) txtdim)

                        (entmake
                            (append
                               '(
                                    (000 . "LWPOLYLINE")
                                    (100 . "AcDbEntity")
                                    (100 . "AcDbPolyline")
                                    (090 . 4)
                                    (070 . 1)
                                )
                                (mapcar '(lambda ( p ) (cons 10 p)) pts)
                            )
                        )
                        (setq box_ents (cons (entlast) box_ents))
                    )
                    (princ (strcat "\nKhong the tinh bounding box cho Pline thu " (itoa (1+ i)) "."))
                )
                (setq i (1+ i))
            )

            (foreach ent box_ents
                (if (entget ent) (entdel ent))
            )
            (princ "\nDa ghi kich thuoc vao cac Pline va xoa bounding box!")
        )
        (princ "\nKhong co Pline kin nao duoc chon.")
    )
    (setvar "CMDECHO" 1)
    (princ)
)
(vl-load-com) (princ)

    AI kết hợp với leemac, Bạn dùng thử, lưu ý là code của Lee cũng đang bị trường hợp khi cùng 1 hình với các góc xoay khác nhau thì lại ra kết quả khác nhau chút ít.

    Tên lệnh là : Test

    cảm ơn bạn lisp dùng ok nhưng có 1 vấn đề là text xuất ra layer và màu nó k giống với text mình chọn mẫu ý, bạn sửa giúp mình được không 

    image.png

  12. Đã đăng · Trả lời báo cáo

    cảm ơn a nhưng e ko biết xuất ra text như trên yêu cầu như nào ah với lại e xem thì nó vẽ luôn đường bao nhưng e ko muốn có đường bao chỉ xuất text thôi. a có thể giúp e không ạ

    15 giờ trước, cuongtk2 đã nói:

    Trong Lee-Mac cũng có  hàm (LM:minboundingbox sel tol) để lấy vùng bao tối thiểu cho tập hợp. Bằng cách rotate liên tục theo tol + 0->pi để tính bound có diện tích nhỏ nhất. 

     

  14. Đã đăng · Trả lời báo cáo

    E chào mọi người. Nhờ các cao nhân giúp đỡ lisp.

    Có các đa giác là pline kín. E muốn ghi được text kích thước như trong ảnh thì có cách nào ko ạ, kích thước là chiều dài dim đoạn thằng lớn nhất của đa giác

    Text xoay theo chiều cạnh dài

    Kiểu text là layer là layer hiện hành, chiều cao chữ chọn 1 lần đầu tiên.

    Và có thể quét chọn 1 lần nhiều đa giác được ko.

    E cảm ơn ạ.

     

    image.png

  15. Đã đăng · Trả lời báo cáo

    Vào lúc 30/9/2014 tại 17:21, nhoclangbat đã nói:

    - bạn cứ test thử nhiều trường hợp có lỗi pm nhoc hen ^^ 

    
;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/13750-lisp-tinh-gia-tri-trung-binh-cua-cac-text/page-3
(defun mktext (point height string justify style  mau / lst)
(setq lst (list '(0 . "TEXT")
                              (cons 10 point)
							  (cons 40 height)
							  (cons 7 style)
							  (cons 1 string)
							  (cons 62 mau)
			)
			justify (strcase justify))
		(cond   ((= justify "L") (setq Lst (append Lst (list (cons 72 0) (cons 11 point)))))
		        ((= justify "C") (setq Lst (append Lst (list (cons 72 1) (cons 11 point)))))
				((= justify "R") (setq Lst (append Lst (list (cons 72 2) (cons 11 point)))))
				((= justify "M") (setq Lst (append Lst (list (cons 72 4) (cons 11 point)))))
				)
	(entmakex Lst)
  )	;end mktext
;;;;
(prompt "Lenh tinh trung binh cong cac so: TBCC")
(defun C:tbcc(/ c tong mstbc num ss pt ctext kq old sty)
(setq old (getvar "osmode"))
(setq sty (getvar "textstyle"))
(setq c -1 tong 0 mstbc 0)
(if (setq ss (ssget '((0 . "TEXT"))))
 (progn
    (while (setq ename (ssname ss (setq c (1+ c))))
      (if (setq num (distof (cdr (assoc 1 (entget ename)))))
	      
          (setq tong (+ tong num) mstbc (1+ mstbc))
      );if
	  (if ename
	  (progn
	  (setq ctext (cdr (assoc 40 (entget ename))))
	  ;(setq glayer (cdr (assoc 8 (entget ename))))
	  ;(setq gstyle (cdr (assoc 7 (entget ename))))
	  )
	  )
	  
    );while
	
	
	(if (null (zerop mstbc))
	(progn
	(setq kq (/ tong mstbc))
	(setvar "osmode" 0)
	(setq pt (getpoint "\nchon diem dat ket qua:"))
    (mktext pt ctext (rtos kq 2 3) "L" sty 1)
     );progn
    );if	 
	
  );progn
  (alert "\nChua co doi tuong dc chon hoac ban chi chon toan text chu ^^")
);if    
(setvar "osmode" old)
(princ)
)

     

    Chào a, phiền a có thể chỉnh text xuất ra: 

    + layer và màu theo layer hiện hành

    + kiểu text theo kiểu text hiện hành

    + chiều cao chữ do mình tự chọn

    được không ạ

  19. Đã đăng · Trả lời báo cáo

    19 giờ trước, vietduc147258 đã nói:

    Vì lệnh này mà bỏ 2016 lên 2018. Tính ra cad mới lưu mạc định cũng 2018 nên cũng tiện nhiều thứ ghê. 

    Ngoài ra hình như có lệnh hplayer, textlayer, nữa thì phải. Có lệnh layer đường center line nữa

    e cảm ơn ạ, dùng lệnh này ổn rồi hehe

  23. Đã đăng · Trả lời báo cáo

    Vào lúc 16/7/2012 tại 13:19, lp_hai đã nói:

    Mình nhớ trước đây có bạn yêu cầu lisp chọn những dt có vị trí trương đồng ở nhiều Mặt bằng khác nhau, có viết cho riêng trường hợp bạn ấy yêu cầu, kiểu chọn đối tượng là (ssget "W"), bạn test thử có giống như vậy không?

      

    
(defun c:ss(/ dt lstp p01 p02 n id dtc p1 p2 stdc spt)
 (setq dt (ssadd)
osm (getvar "osmode")
)
 (setq p01(getpoint "\nchon diem goc 1:"))
 (command "ucs" "n" p01)
 (setvar "osmode" 0)
 (while (setq p1(getpoint"\nchon doi tuong:"))
(setq p2(getcorner p1)
  lstp (append (list p1 p2) lstp))
)
 (setq spt (/(length lstp)2)
n 0)
 (repeat spt
(setq dtc (ssget "W" (nth n lstp) (nth (+ n 1) lstp))
  n (+ n 2)
  )
(setq sdtc (sslength dtc)
  id 0)
(repeat sdtc
 	(setq dt (ssadd (ssname dtc id) dt)
	id (1+ id))
 	)
)
 (setvar "osmode" osm)
 ;;;;
 (while (setq p02 (getpoint "\nchon diem goc tiep theo:"))
(command "ucs" "n" p02)
(setvar "osmode" 0)
(setq n 0)
(repeat spt
 	(setq dtc (ssget "W" (nth n lstp) (nth (+ n 1) lstp))
  n (+ n 2)
  )
 	(setq sdtc (sslength dtc)
  id 0)
 	(repeat sdtc
(setq dt (ssadd (ssname dtc id) dt)
  	id (1+ id))
)
 	)
(setvar "osmode" osm)
)
 (command "ucs" "w")
 (sssetfirst dt dt) 
 (princ)
 )
     

     

    a cho e hỏi lisp này có chọn được các đối tượng giống nhau theo vị trí và số lượng ko ạ. 1 mặt bằng có rất nhiều tấm như này và e muốn tìm những tấm giống với tấm e khoanh đỏ kia

    image.png

  25. Đã đăng · Trả lời báo cáo

    23 giờ trước, cuongtk2 đã nói: 
    
(defun c:test ( / CK CK1 LISTCIRCLE LISTLINE SS nss)
(setq ss (mapcar 'vlax-ename->vla-object (ACET-SS-TO-LIST(ssget))))
(setq listcircle (vl-remove-if-not '(lambda (obj) (= "AcDbCircle" (vla-get-ObjectName obj))) ss)
      listline (vl-remove-if '(lambda (obj) (= "AcDbCircle" (vla-get-ObjectName obj))) ss))
  (SETQ nss (ssadd))
(foreach circle listcircle
  (setq ck nil)
  (foreach line listline  
    (if (vlax-invoke circle 'intersectwith line acextendnone)
      (setq ck T))   ;if
    );foreach
  (if ck (setq nss (ssadd  (vlax-vla-object->ename circle) nss ))
    );if
  );foreach
  (command "select" nss "")
 ; (command "select" "_P" )  xu ly tiep theo cho nss 
  )

     

    e cảm ơn a, e nhận thấy lisp nó không xóa được các block phức tạp như gồm nhiều đoạn thẳng khác nhau hoặc block chứa nhiều đường cong và thi thoảng lisp nó không hoạt động. a có biết nguyên nhân vì sao không ạ

     

×