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

divine kai

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

  • Số lượng nội dung

    83

  • Đã tham gia

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

Bài đăng được đăng bởi divine kai

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

    Cho em hỏi giờ em có đối tượng mtext, em muốn scale nó theo ý của mình theo vị trí 

    Left

    Center

    Middle

    Right

    TL (top left)

    TC (top center)

    TR (top right)

    ML (middle left)

    MC (middle center)

    MR (middle right)

    BL (bottom left)

    BC (bottom center)

    BR (bottom right)

    và sau đó chọn tỷ lệ scale, cho em hỏi làm cách nào để scale như thế ạ, bởi vì em phải scale một lúc cả ngàn đối tượng mà em muốn vị trí chúng thay đổi theo ý mình...

    image.png.6551c4c1291e172350fe272905d2bf23.png

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

    Vào lúc 9/9/2019 tại 14:27, Doan Nguyen Van đã nói: 
    
(defun c:te  (/ ss n value pos)
  (if (not (tblsearch "LAYER" "TEN"))
    (command "Layer" "M" "TEN" "")
    )
  (if (setq ss (ssget '((0 . "TEXT") (1 . "*/*"))))
    (progn
      (setq n 0)
      (repeat (sslength ss)
        (setq value (vl-list->string (vl-remove-if (function (lambda (u) (or (< 64 u 91) (< 96 u 123))))
                                                   (vl-string->list (vl-string-subst "" "." (vl-string-subst "" " "
											      (setq str (cdr (assoc 1 (entget (ssname ss n))))))))
                                                   )
                                     )
              )
        (if (setq pos (vl-string-search "/" value 1)) (progn
(setq pos1 (vl-string-search (substr value 1 pos) (cdr (assoc 1 (entget (ssname ss n)))) 1))
(make (substr str 1 pos1) 0 (ssname ss n) (cdr (assoc 10 (entget (ssname ss n)))))
(vla-getboundingbox (vlax-ename->vla-object (entlast)) 'mn 'mx)
(setq width (- (car (vlax-safearray->list mx))  (car (vlax-safearray->list mn))))
(entdel (entlast))
(make (substr value 1 pos) (cdr (assoc 50 (entget (ssname ss n)))) (ssname ss n) (polar (cdr (assoc 10 (entget (ssname ss n))))
											       (cdr (assoc 50 (entget (ssname ss n)))) width))
           )
          ) ;if
        (setq n (1+ n))
        ) ;repeat
      ) ;progn
    ) ;if
  (princ)
  )
(defun make (noidung goc ent pt)
	(entmake
            (list
              (cons 0 "TEXT")
              (cons 100 "AcDbText")
              (cons 10 (trans pt 1 0))
              (assoc 40 (entget ent))
              (cons 1 noidung)
              (assoc 7 (entget ent))
              (cons 50 goc)
              (cons 8 "TEN")
              (cons 100 "AcDbText")
              )
            )
)

     

    có nhiều dữ liệu bị sai khi quét lisp ví dụ như ĐM, 2L và vườn thì khi chạy nó cho ra kết quả bị sai anh có cách nào sửa không anh?

    image.png.46bf9a31e831516ddbee5e5dfdb8b9b1.png

    image.png.403ba3cc50fa585d9b4389fbac3c0a71.pngimage.png.5a739e0135cc9574e43f6b45282921a2.png

     

    du lieu bi sai.dwg

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

    Vào lúc 9/9/2019 tại 14:27, Doan Nguyen Van đã nói: 
    
(defun c:te  (/ ss n value pos)
  (if (not (tblsearch "LAYER" "TEN"))
    (command "Layer" "M" "TEN" "")
    )
  (if (setq ss (ssget '((0 . "TEXT") (1 . "*/*"))))
    (progn
      (setq n 0)
      (repeat (sslength ss)
        (setq value (vl-list->string (vl-remove-if (function (lambda (u) (or (< 64 u 91) (< 96 u 123))))
                                                   (vl-string->list (vl-string-subst "" "." (vl-string-subst "" " "
											      (setq str (cdr (assoc 1 (entget (ssname ss n))))))))
                                                   )
                                     )
              )
        (if (setq pos (vl-string-search "/" value 1)) (progn
(setq pos1 (vl-string-search (substr value 1 pos) (cdr (assoc 1 (entget (ssname ss n)))) 1))
(make (substr str 1 pos1) 0 (ssname ss n) (cdr (assoc 10 (entget (ssname ss n)))))
(vla-getboundingbox (vlax-ename->vla-object (entlast)) 'mn 'mx)
(setq width (- (car (vlax-safearray->list mx))  (car (vlax-safearray->list mn))))
(entdel (entlast))
(make (substr value 1 pos) (cdr (assoc 50 (entget (ssname ss n)))) (ssname ss n) (polar (cdr (assoc 10 (entget (ssname ss n))))
											       (cdr (assoc 50 (entget (ssname ss n)))) width))
           )
          ) ;if
        (setq n (1+ n))
        ) ;repeat
      ) ;progn
    ) ;if
  (princ)
  )
(defun make (noidung goc ent pt)
	(entmake
            (list
              (cons 0 "TEXT")
              (cons 100 "AcDbText")
              (cons 10 (trans pt 1 0))
              (assoc 40 (entget ent))
              (cons 1 noidung)
              (assoc 7 (entget ent))
              (cons 50 goc)
              (cons 8 "TEN")
              (cons 100 "AcDbText")
              )
            )
)

     

    hiện tại em muốn lấy thêm dữ liệu là chỉ chữ ở đầu tiên , ví dụ như T 83/243.6 thì khi quét lisp sẽ cho ra kết quả là T, anh có thể sửa giúp em trên lisp này luôn không ạ, em cảm ơn anh

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

    23 giờ trước, Doan Nguyen Van đã nói:

    Đã giải quyết vấn đề 4-5 hàng cho bạn, chọn 3 hay 4 hay 5 hàng đều được  

    
(defun c:te (/ ss lstl ent ss1 lst lst2 en en2 en3 str pref)
  (vl-load-com)
  (setq ss (acet-ss-to-list (ssget (list (cons 0 "MTEXT")))))
  (setvar 'cmdecho 0)
    (setq lstl (list "layer1" "layer2" "layer3" "layer4" "layer5"))
  (setq i 0)
  (mapcar '(lambda (x)(if (not (tblsearch "layer" x)) (progn (setq i (1+ i)) (command "-LAYER" "M" x "C" (itoa i) "" ""))) ) lstl)
  (foreach ent ss
    (setq lst (list))
    (setq str (cdr (assoc 1 (entget ent)))) 
    (while (vl-string-search "\\P" str)
      (setq stri (substr str 1 (vl-string-search "\\P" str)))
      (setq lst (append lst (list stri)))
      (setq str (substr str (+ (vl-string-search "\\P" str) 3)))
      )
    (if (/= str "") (setq lst (append lst (list str))))
    (if (or (= (length lst) 4)
	    (= (length lst) 5) )(progn
			    (setq pt (cdr (assoc 10 (entget ent))))
			    (setq pref (vl-string-right-trim "1234567890" (car lst)))			    
	(mapcar '(lambda (str lay) (if (and (/= str (car lst)) (/= pref "")) (setq str (strcat pref str)))
		   (maketext pt str lay ent )
		   (setq pt (polar pt (* 1.5 pi) (vla-get-linespacingdistance (vlax-ename->vla-object ent) )) ) ) lst lstl)
			    (entdel ent)
			     ) 
      )
    )
  (setvar 'cmdecho 1)
  (princ)
  )
(defun maketext (point noidungtext lay entg / oldla)
  (vla-move (vla-copy (vlax-ename->vla-object entg)) (vlax-3d-point (cdr (assoc 10 (entget entg)))) (vlax-3d-point point))
  (vla-put-textstring (vlax-ename->vla-object (entlast)) noidungtext)
  (vla-put-layer (vlax-ename->vla-object (entlast)) lay)
  (vla-put-color (vlax-ename->vla-object (entlast)) 256))

     

    em cảm ơn a rất nhiều

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

    10 giờ trước, Bee đã nói:

    Có chỉnh lại theo bản vẽ của bạn, đã test thấy chạy ok với lisp sau: sau khi gõ lệnh - TEST thì gõ all xong enter chạy bình thường ^_^ Hoặc dùng lisp Doan NV filter giá trị text cho nhanh hơn. 

    
(defun c:test  (/ ss n value pos)
  (if (not (tblsearch "LAYER" "@TEN"))
    (command "Layer" "M" "@TEN" "")
    )
  (if (setq ss (ssget '((0 . "TEXT"))))
    (progn
      (setq n 0)
      (repeat (sslength ss)
        (if (> (strlen (cdr (assoc 1 (entget (ssname ss n))))) 6)
          (progn
            (setq value (vl-list->string
                          (vl-remove-if (function (lambda (u) (or (< 64 u 91) (< 96 u 123))))
                                        (vl-string->list
                                          (vl-string-subst "" "." (vl-string-subst "" " " (cdr (assoc 1 (entget (ssname ss n)))))))
                                        )
                          )
                  )
            (if (setq pos (vl-string-search "/" value 1))
              (entmake
                (list
                  (cons 0 "TEXT")
                  (cons 100 "AcDbText")
                  (cons 10 (trans (cdr (assoc 10 (entget (ssname ss n)))) 1 0))
                  (assoc 40 (entget (ssname ss n)))
                  (cons 1 (substr value 1 pos))
                  (assoc 7 (entget (ssname ss n)))
                  (assoc 50 (entget (ssname ss n)))
                  (cons 8 "@TEN")
                  (cons 100 "AcDbText")
                  )
                )
              ) ;if
            )
          )
        (setq n (1+ n))
        ) ;repeat

      ) ;progn
    ) ;if
 
  (princ)
  )

     

    cảm ơn bạn rất nhiều nha bee

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

    17 giờ trước, Doan Nguyen Van đã nói: 
    
(defun c:te  (/ ss n value pos)
  (if (not (tblsearch "LAYER" "TEN"))
    (command "Layer" "M" "TEN" "")
    )
  (if (setq ss (ssget '((0 . "TEXT") (1 . "*/*"))))
    (progn
      (setq n 0)
      (repeat (sslength ss)
        (setq value (vl-list->string (vl-remove-if (function (lambda (u) (or (< 64 u 91) (< 96 u 123))))
                                                   (vl-string->list (vl-string-subst "" "." (vl-string-subst "" " "
											      (setq str (cdr (assoc 1 (entget (ssname ss n))))))))
                                                   )
                                     )
              )
        (if (setq pos (vl-string-search "/" value 1)) (progn
(setq pos1 (vl-string-search (substr value 1 pos) (cdr (assoc 1 (entget (ssname ss n)))) 1))
(make (substr str 1 pos1) 0 (ssname ss n) (cdr (assoc 10 (entget (ssname ss n)))))
(vla-getboundingbox (vlax-ename->vla-object (entlast)) 'mn 'mx)
(setq width (- (car (vlax-safearray->list mx))  (car (vlax-safearray->list mn))))
(entdel (entlast))
(make (substr value 1 pos) (cdr (assoc 50 (entget (ssname ss n)))) (ssname ss n) (polar (cdr (assoc 10 (entget (ssname ss n))))
											       (cdr (assoc 50 (entget (ssname ss n)))) width))
           )
          ) ;if
        (setq n (1+ n))
        ) ;repeat
      ) ;progn
    ) ;if
  (princ)
  )
(defun make (noidung goc ent pt)
	(entmake
            (list
              (cons 0 "TEXT")
              (cons 100 "AcDbText")
              (cons 10 (trans pt 1 0))
              (assoc 40 (entget ent))
              (cons 1 noidung)
              (assoc 7 (entget ent))
              (cons 50 goc)
              (cons 8 "TEN")
              (cons 100 "AcDbText")
              )
            )
)

    Sửa theo bài của BEE

    Em cảm ơn anh Doan

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

    42 phút trước, Doan Nguyen Van đã nói: 
    
(defun c:te (/ ss lstl ent ss1 lst lst2 en en2 en3 str)
  (vl-load-com)
  (setq ss (acet-ss-to-list (ssget (list (cons 0 "MTEXT")))))
  (setvar 'cmdecho 0)
    (setq lstl (list "layer1" "layer2" "layer3" "layer4" "layer5"))
  (setq i 0)
  (mapcar '(lambda (x)(if (not (tblsearch "layer" x)) (progn (setq i (1+ i)) (command "-LAYER" "M" x "C" (itoa i) "" ""))) ) lstl)
  (foreach ent ss
    (setq lst (list))
    (setq str (cdr (assoc 1 (entget ent)))) 
    (while (vl-string-search "\\P" str)
      (setq stri (substr str 1 (vl-string-search "\\P" str)))
      (if (/= stri "")
      (setq lst (append lst (list stri))) )
      (setq str (substr str (+ (vl-string-search "\\P" str) 3)))
      )
    (if (/= str "") (setq lst (append lst (list str))))
    
    (if (= (length lst) 5 ) (progn
			    (setq pt (cdr (assoc 10 (entget ent))))
	(mapcar '(lambda (str lay) (maketext pt str (cdr (assoc 40 (entget ent))) lay (cdr (assoc 7 (Entget ent)))
					  (vla-get-linespacingfactor (vlax-ename->vla-object ent))   )
		   (setq pt (polar pt (* 1.5 pi) (vla-get-linespacingdistance (vlax-ename->vla-object ent) )) ) ) lst lstl)
			    (entdel ent)
			     ) 
      )
    )
  (setvar 'cmdecho 1)
  (princ)
  )
(defun maketext (point noidungtext heighttext lay style sps / oldla)
  (entmakex (list '(0 . "MTEXT") '(100 . "AcDbEntity") '(100 . "AcDbMText")
              (cons 10 point)
              (cons 40 heighttext)
              (cons 1 noidungtext)
		  (cons 8 lay)
		  (cons 7 style)
		  (cons 44 sps)
		(cons 71 2)
		 (cons 72 1)
		  (cons 73 2)
		  ))
  )

     

    cho em hỏi là nếu dữ liệu khác thì làm sao nó ra được 5 layer 5 màu như anh, có cần chỉnh lại thuộc tính layer không anh

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

    Vào lúc 6/9/2019 tại 09:23, Doan Nguyen Van đã nói:

     

    Anh ơi anh có thể thêm vào dòng lệnh tăng tốc xử lí lên được không anh, của em có đen 300 ngàn đối tượng em đã quét một lần 500 đối tượng nhưng lisp vẫn xử lí rất lâu và mất nhiều thời gian, anh có thể thêm giúp em không anh?

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

    Vào lúc 29/5/2019 tại 19:05, Bee đã nói:

     

    bạn ơi, mình cũng gặp trường hợp tương tự, nhưng sao sài lisp thì không quét được nhiều đối tượng vs quét có nhiều đối tượng khác dạng line hay text khác thì lisp không chạy, bạn có thể sửa giúp mình không...( mình chỉ có thể quét rất ít đối tượng )

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

    Vào lúc 17/7/2019 tại 15:25, Doan Nguyen Van đã nói: 
    
(defun c:te (/ ss lstl ent ss1 lst lst2 en en2 en3 str)
  (vl-load-com)
  (setq ss (acet-ss-to-list (ssget (list (cons 0 "MTEXT")))))
  (setvar 'cmdecho 0)
    (setq lstl (list "layer1" "layer2" "layer3" "layer4" "layer5"))
  (mapcar '(lambda (x)(if (not (tblsearch "layer" x)) (command "-LAYER" "M" x "" "")) ) lstl)
  (foreach ent ss
    (vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
    (setq ss1 (acet-ss-to-list (acet-explode ent)))
    (setq ss1 (vl-sort ss1 '(lambda (x y) (cond	( (= (cadr (cdr (assoc 10 (entget x)))) (cadr (cdr (assoc 10 (entget y)))) )
					    (< (car (cdr (assoc 10 (entget x)))) (car (cdr (assoc 10 (entget y))))))
					     ((> (cadr (cdr (assoc 10 (entget x)))) (cadr (cdr (assoc 10 (entget  y))))))  ))))
    (setq lst (list))
    (while (setq en (car ss1))
      (setq ss1 (cdr ss1))
      (setq lst2 (list en))
      (while (and (setq en2 (car ss1))
		  (= (cadr (cdr (assoc 10 (entget en)))) (cadr (cdr (assoc 10 (entget en2)))) ) )
	(setq ss1 (cdr ss1))
	(setq lst2 (append lst2 (list en2)))
	)
      (if (> (length lst2) 1) (progn
	(setq str "")
	(mapcar '(lambda (x) (setq str (strcat str (cdr (assoc 1 (entget x)))))) lst2)
	(setq en3 (car lst2))
	 (mapcar '(lambda (x) (entdel x) ) (cdr lst2))
	(entmod (subst (cons 1 str) (assoc 1 (entget en3)) (entget en3)))
	(setq lst (append lst (list en3)))
	) (setq lst (append lst lst2)))
      )
    (if (= (length lst) 5) (progn
			     (vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
			     (mapcar '(lambda (x y) (vla-put-layer (vlax-ename->vla-object x) y)) lst lstl))
      (progn
	(vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
	(command "UNDO" "1")))
    )
  (setvar 'cmdecho 1)
  (princ)
  )

    Anh ơi hiện tại dữ liệu của em cũng gần giống bạn này nhưng chỉ có 4 dòng, anh có thể giúp em sửa lại lisp trên thành 4 được không anh, em cảm ơn anh nhiều...

    em gửi dứ liệu ạ

     

    du lieu.dwg

×