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

united

Thành viên
  • Số lượng nội dung

    86
  • Đã tham gia

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

  • Ngày trúng

    1

Bài đăng được đăng bởi united


  1. Vào lúc 24/7/2020 tại 11:20, dieptp đã nói:

    Tình hình em đang vẽ 1 bản vẽ có hiện tượng khá hay.

    Ở các bản vẽ trước nay em thường vẽ. Nếu block bị thay đổi độ lớn (scale) thì linetype scale cũng sẽ bị thay đổi theo. Nhưng ở bản vẽ này toàn bộ linetypes vẫn giữ nguyên tỷ lệ scale, Rất tiện trong trường hợp trích chi tiết bản vẽ.

    Vậy các bác cho em hỏi nguyên nhân và cách bật / tắt nó với ạ! Em xin cảm ơn!

    HLK-side.dwg

     

    Bác cho em xin file block của bác mà khi Scale thì Linetype scale thay đổi theo với ạ. Cảm ơn bác!


  2. Vào lúc 24/7/2020 tại 18:24, Ma Vương đã nói:

    Nếu là annotation thì lệnh MSLTSCALE = 0, PSLTSCALE = 0

    Hình như 2 biến này không giải quyết được vấn đề bác chủ hỏi ạ

    Em cũng đang vướng vấn đề này, em đang muốn Linetype scale thay đổi theo tỷ lệ Block.

    Ví dụ: nét đứt sẽ tăng độ dài lên 2 lần khi Scale block lên 2 lần.

     


  3. Như tiêu đề ạ, em nhờ các anh chỉnh sửa giúp em sao cho lisp này chạy mượt mà và gọn ạ. Lisp này vẫn chạy nhưng hơi... ngu (tất nhiên là do người viết :(().

    Mục tiêu của nó là: Nếu layer A tồn tại trong bản vẽ thì chuyển các đối tượng về layer A. Nếu không thì tạo layer A rồi chuyển đối tượng về layer A.

    Em cảm ơn các anh!

    Quote

    (Defun c:TEST()
    (if (tblsearch "layer" "DINHTT")
     (
      (Prompt "\nSelect objects >>> DINHTT")
      (Setq CHUYEN (Ssget))
      (command "chprop" CHUYEN "" "la" "DINHTT"  "")
     )
     (
      (setq HIENHANH (getvar "clayer"))
      (Prompt "\nSelect objects >>> DINHTT  ")
      (Setq CHUYEN (Ssget))
      (COMMAND "-layer" "M" "DINHTT" "C" "1" "" "L" "CONTINUOUS" "" "")
      (command "chprop" CHUYEN "" "la" "DINHTT"  "")
      (setvar "clayer" HIENHANH)
     )
    )
    (princ))

     


  4. Em có cop nhặt và chỉnh sửa được lisp này, nhưng lúc hoạt động lúc không. Lúc ngon lành, lúc báo lỗi tùm lum (mỗi lúc lỗi một kiểu luôn).

    Nhờ các anh xem và chỉnh sửa giúp ạ. Em cảm ơn nhiều ạ!

    Quote

    (defun C:BP (/ ss n)
      (setvar "CMDECHO" 0)
      (setq BLOCKNAME (entsel "\nSelect Block:"))
      (if (setq ss (ssget '((0 . "POINT"))))
        (repeat (setq n (sslength ss))
          (command        "_.INSERT" BLOCKNAME
            "_none" (cdr (assoc 10 (entget (ssname ss (setq n (1- n))))))        "" "" ""      )
        )
        (prompt "\nNo Point(s) selected.")
      )
      (princ)
    )

     


  5. 20 giờ trước, quocmanh04tt đã nói:

    Mình tham gia một cái chơi, bớt đi chút thao tác.

    Cách dùng:

    Khi gọi lệnh lisp sẽ hỏi "First point" và "Second point".

    - Nếu nối 1 đoạn thẳng qua 2 điểm tên sẽ phải cắt qua các Pline.

    - Muốn nối phía nào thì đoạn thẳng nói trên cắt qua các pline ở các vị trí gần phía đầu nối hơn đầu kia.

    
    (defun c:tt  (/ cmd doc ent ept inp lst ltp p1 p2 spt ss _int)
      (vl-load-com)
      (setq _int (lambda (ob1 ob2 mod / lst rtn)
                   (if (and (vlax-method-applicable-p ob1 'intersectwith)
                            (vlax-method-applicable-p ob2 'intersectwith)
                            (setq lst (vlax-invoke ob1 'intersectwith ob2 mod)))
                     (repeat (/ (length lst) 3)
                       (setq rtn (cons (list (car lst) (cadr lst) (caddr lst)) rtn)
                             lst (cdddr lst))))
                   (reverse rtn)))
      (if (and (setq p1 (getpoint "\nFirst point: "))
               (setq p2 (getpoint "\nSecond point: " p1))
               (setq ss (ssget "_F" (list p1 p2) '((0 . "LWPOLYLINE") (8 . "Layer1,Layer2")))))
        (progn (setq cmd (getvar 'CMDECHO))
               (setvar 'CMDECHO 0)
               (vla-startUndoMark (setq doc (vla-get-activedocument (vlax-get-acad-object))))
               (setq ltp (entmakex (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2))))
               (while (and (setq ent (ssname ss 0)) (ssdel ent ss))
                 (setq spt (vlax-curve-getStartPoint ent)
                       ept (vlax-curve-getEndPoint ent)
                       inp (car (_int (vlax-ename->vla-object ltp) (vlax-ename->vla-object ent) acextendnone)))
                 (if (< (vlax-curve-getDistAtPoint ent inp) (* 0.5 (vlax-curve-getDistAtPoint ent ept)))
                   (setq lst (cons spt lst))
                   (setq lst (cons ept lst))))
               (entdel ltp)
               (while (> (length lst) 1)
                 (setq ltp (entmakex (list (cons 0 "LINE") (cons 10 (car lst)) (cons 11 (cadr lst))))
                       ss  (ssget "_F" (list p1 p2) '((0 . "LWPOLYLINE") (8 . "Layer1"))))
                 (command "_pedit" "m" ss ltp "" "" "join" "0.00" "")
                 (setq lst (cddr lst)))
               (vla-EndUndoMark doc)
               (setvar 'CMDECHO cmd)))
      (princ))

     

    Lisp của anh rất hay và rất nhanh ạ. Loại bỏ được các trường hợp lỗi như lisp của anh @Doan Nguyen Van (một số trường hợp vẫn còn lỗi).

    Nhưng vẫn có nhược điểm như của anh @Doan Van Ha nói (khắc phục bằng cách tạm chuyển các đường nét đứt sang nét liền, xong thì chuyển lại, hơi bất tiện).

    Thêm nữa là em chạy thì nó không nối các đường tạo ra với "Layer1" (PS: Hình như do thừa "" ở đoạn Pedit)


  6. 1 giờ} trướ}c, Doan Nguyen Van đã nói:

    Chưa chắc các bản vẽ của bạn đã có sẵn các layer đó, vì bản test này tên layer khác nhau.

    Sửa lại cho bạn mỗi lần mở bv sẽ pick chọn 1 lần, các lần sau k phải pick lại, nếu muốn pick lại thì enter 2 lần

    
    (Defun c:te (/ ss lst lay lst1 ent ent2 pt p1 p2 p3 p4 lst2 ss1 ss2)
    (if (not lay1) (progn
      (setq ent1 (car (entsel "\nPick Layer 1"))
    	ent2 (car (entsel "\nPick Layer 2")))
      (setq lay1 (cdr (assoc 8 (entget ent1)))
    	lay2 (cdr (assoc 8 (entget ent2)))) ))
     (if (setq ss (acet-ss-to-list (ssget (list (cons 0 "LWPOLYLINE") (cons 8 (strcat lay1 "," lay2)))))) (progn
      (command "UNDO" "BE")
      (setq ss1 (list) ss2 (list))
      (mapcar '(lambda (x) (if (= (cdr (Assoc 8 (entget x))) lay1 ) (setq ss1 (append ss1 (list x))) (setq ss2 (append ss2 (list x))))) ss)
      (setq ss1 (vl-sort ss1 '(lambda (x y) (> (caddr (assoc 10 (entget x))) (caddr (assoc 10 (entget y)))))))
      (setq ss2 (vl-sort ss2 '(lambda (x y) (> (caddr (assoc 10 (entget x))) (caddr (assoc 10 (entget y)))))))
      (setq pt (getpoint "\nPick phia noi"))
      (mapcar '(lambda (x y) (setq lst1 (acet-geom-vertex-list x)
    			       lst2 (acet-geom-vertex-list y))
    	     (setq p1 (car lst1) p2 (last lst1) p3 (car lst2) p4 (last lst2))
    	     (if (< (distance p1 pt) (distance p2 pt)) (setq pt1 p1) (setq pt1 p2))
    	     (if (< (distance p3 pt) (distance p4 pt)) (setq pt2 p3) (setq pt2 p4))
    	     (acet-lwpline-make (list (list pt1 pt2)))
    	     (command "pedit" "m" x (entlast) "" "join" "0.00" "")
    	     ) ss1
    	  ss2
    	  )
      
      (command "UNDO" "E")
      ) (progn (setq lay1 nil) (c:te)))
      )

     

    Dạ chắc chắn có luôn anh ạ. Vì những pline này luôn do em tạo ra chứ không phải lấy từ nguồn khác (nếu lấy từ nguồn khác thì họ đã nối sẵn rồi)


  7. 58 phút trước, Doan Nguyen Van đã nói:

    Đây nhé:

    
    (Defun c:te (/ ss lst lay lst1 ent ent2 pt p1 p2 p3 p4 lst2 ss1 ss2)
      (setq ent1 (car (entsel "\nPick Layer 1"))
    	ent2 (car (entsel "\nPick Layer 2")))
      (setq lay1 (cdr (assoc 8 (entget ent1)))
    	lay2 (cdr (assoc 8 (entget ent2))))
      (setq ss (acet-ss-to-list (ssget (list (cons 0 "LWPOLYLINE") (cons 8 (strcat lay1 "," lay2))))))
      (command "UNDO" "BE")
      (setq ss1 (list) ss2 (list))
      (mapcar '(lambda (x) (if (= (cdr (Assoc 8 (entget x))) lay1 ) (setq ss1 (append ss1 (list x))) (setq ss2 (append ss2 (list x))))) ss)
      (setq ss1 (vl-sort ss1 '(lambda (x y) (> (caddr (assoc 10 (entget x))) (caddr (assoc 10 (entget y)))))))
      (setq ss2 (vl-sort ss2 '(lambda (x y) (> (caddr (assoc 10 (entget x))) (caddr (assoc 10 (entget y)))))))
      (setq pt (getpoint "\nPick phia noi"))
      (mapcar '(lambda (x y) (setq lst1 (acet-geom-vertex-list x)
    			       lst2 (acet-geom-vertex-list y))
    	     (setq p1 (car lst1) p2 (last lst1) p3 (car lst2) p4 (last lst2))
    	     (if (< (distance p1 pt) (distance p2 pt)) (setq pt1 p1) (setq pt1 p2))
    	     (if (< (distance p3 pt) (distance p4 pt)) (setq pt2 p3) (setq pt2 p4))
    	     (acet-lwpline-make (list (list pt1 pt2)))
    	     (command "pedit" "m" x (entlast) "" "join" "0.00" "")
    	     ) ss1
    	  ss2
    	  )
      
      (command "UNDO" "E")
      )

     

    Có lẽ em hơi tham, nhưng anh có thể bỏ bước chọn Layer 1 và Layer 2 được không ạ? Và mặc định "Layer 1" và "Layer 2" là layer có sẵn trong bản vẽ (ví dụ: Layer1 và Layer2). Vì trong bản vẽ của em luôn có sẵn "layer1" và "layer2" rồi. Và đường nối luôn thuộc "layer1".

    Em cảm ơn anh lần nữa!

    • Vote giảm 2

  8. 1 giờ} trướ}c, Doan Nguyen Van đã nói:

    Bạn Test thử xem oke chưa

    
    (Defun c:te (/ ss lst lay lst1 ent ent2 pt p1 p2 p3 p4 lst2 ss1 ss2)
      (setq ss (acet-ss-to-list (ssget (list (cons 0 "LWPOLYLINE")))))
      (command "UNDO" "BE")
      (setq lst (list))
      (while (setq ent (car ss))
        (Setq ss (cdr ss))
        (setq lay (cdr (assoc 8 (entget ent))))
        (setq lst1 (list ent))
    	  (foreach ent2 ss
    (if (= (cdr (assoc 8 (entget ent2))) lay) (progn(setq lst1 (append lst1 (list ent2)))(setq ss (vl-remove ent2 ss))
    							)))
        (setq lst (append lst (list lst1)))
        )
      (if (= (length lst) 2) (progn
    (setq lst (mapcar '(lambda (z) (setq z (vl-sort z '(lambda (x y) (> (caddr (assoc 10 (entget x))) (caddr (assoc 10 (entget y))))))))  lst))
    (if (> (caddr (assoc 10 (entget (caar lst)))) (caddr (assoc 10 (entget (caadr lst)))))
     (progn (setq ss1 (car lst)) (setq ss2 (cadr lst)))(progn (setq ss2 (car lst)) (setq ss1 (cadr lst))))
      (setq pt (getpoint "\nPick phia noi"))
      (mapcar '(lambda (x y) (setq lst1 (acet-geom-vertex-list x)
    			       lst2 (acet-geom-vertex-list y))
    	     (setq p1 (car lst1) p2 (last lst1) p3 (car lst2) p4 (last lst2))
    	     (if (< (distance p1 pt) (distance p2 pt)) (setq pt1 p1) (setq pt1 p2))
    	     (if (< (distance p3 pt) (distance p4 pt)) (setq pt2 p3) (setq pt2 p4))
    	     (acet-lwpline-make (list (list pt1 pt2)))
    	     (command "pedit" "m" x (entlast) "" "join" "0.00" "")
    	     ) ss1
    	  ss2
    	  )
      ))
      (command "UNDO" "E")
      )

     

    Có 1 vấn đề anh ạ. Là khi em xoay các pline theo các góc khác nhau. Sẽ có lúc đoạn nối bị sai anh ạ. Đáng lẽ đoạn nối phải join với đường màu đỏ thì nó lại join với đường màu xanh.

    Em có up lại file với một số trường hợp cho kết quả không như ý muốn ạ.

    Mong anh giúp đỡ!

    Capture2.thumb.PNG.3d2e0276783b70fcc90f1f6cc6874aaf.PNG

    Ex2.dwg


  9. - Dạ, em không rõ về lisp nên cũng không hiểu làm sao để biết muốn nối đầu nào. Liệu có cách nào để nó nhận đầu muốn nồi là đầu chuột quét chọn không ạ? Hay là thêm 1 bước chọn đầu bằng cách pick chọn (các đầu gần điểm pick sẽ được nối với nhau)...

    - Các cặp pline thì luôn sắp xếp xen kẽ (và song song với nhau luôn) ạ.

    - Bản vẽ em đã up.

    Ex.dwg


  10. Em xin trình bày theo các thao tác làm thông thường trên CAD ạ:

    Có 2 polyline thuộc 2 layer khác nhau (giả sử là layer1 và layer2). Vẽ 1 đường thẳng nối 2 đỉnh của 2 polyline rồi dùng lệnh Join nối đường thẳng thuộc layer1 với đường thẳng vừa vẽ.

    Em xin nhờ các anh viết giúp em 1 lisp giúp đơn giản hóa các bước trên ạ.

    Như hình là em có rất nhiều đường thẳng thuộc layer1 và layer2 nằm xen kẽ nhau. Nếu chọn được một lượt cho ra kết quả (như hình bên phải) thì hay quá ạ.

    Em cảm ơn ạ!

    Capture.PNG

    • Vote giảm 1

  11. Vào lúc 17/7/2019 tại 15:24, united đã nói:

    Không biết anh @thanhduan2407 còn ở đây không?

    Em xin được nhờ anh (hoặc bất kỳ anh nào) sửa giúp em 1 chút lisp VTL2 để "đối tượng thứ hai" không phải là 1 đường mà có thể là nhiều đường.

    Trên diễn đàn có 1 lisp làm được tương tự (lisp Batter) nhưng với các đối tượng dài (hoặc rải dày) thì nó làm việc rất chậm.

    Về tác dụng thì như hình: Chỉ cần chọn đối tượng thứ nhất (1) và chọn nhóm đối tượng thứ 2 (2&3) rồi Enter để ra được kết quả như hình. Còn với lisp VTL2 thì phải thực hiện rải 2 lần và xóa bớt đối tượng thừa, hoặc phải Break đối tượng (1) thành các đoạn nhỏ.

    PS: hình chỉ là minh họa chứ em thường rải nhiều đối tượng khá phức tạp nên rất mất thời gian.

    - Thêm 1 điều nữa là lisp này có nhược điểm là không chạy liên tục, mỗi lần rải lại phải thực hiện lệnh từ đầu, không như lisp #dưới em up.

    Capture.PNG

    Nhờ các anh xem giúp ạ


  12. Vào lúc 25/6/2015 tại 20:26, thanhduan2407 đã nói:

    Của bạn đây! Mình đang ở vùng biên giới nên ko có mạng internet.

    • vtl_vtl2_dctl.lsp
      lisp help
    •  
    
    (vl-load-com)
    (defun C:VTL( /  ObjPline LtsTaluy LtsLDai LtsLNgan e1 e2 e3 e4 ang1 ang2 ang3 ang4 Pnt10N Pnt10D Pnt11N Pnt11D Chon)
    (defun *error* ( msg )
    (if Olmode (setvar 'osmode Olmode))
    (if (not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
        (princ (strcat "\nError: " msg))
    )
    (princ)
    )
    (setq Olmode (getvar "OSMODE"))
    
    (or *CDTLN* (setq *CDTLN* 1))
    (setq CDTLN (getreal (strcat "\nChi\U+1EC1u d\U+00E0i c\U+1EE7a v\U+1EA1ch nh\U+1ECF < "
    			  (rtos *CDTLN* 2 2)
    			 " > :"
    		    )
    	 )
    )
    (if (not CDTLN) (setq CDTLN *CDTLN*) (setq *CDTLN* CDTLN))
    
    (or *CDTLD* (setq *CDTLD* 2))
    (setq CDTLD (getreal (strcat "\nChi\U+1EC1u d\U+00E0i c\U+1EE7a v\U+1EA1ch d\U+00E0i < "
    			  (rtos *CDTLD* 2 2)
    			 " > :"
    		    )
    	 )
    )
    (if (not CDTLD) (setq CDTLD *CDTLD*) (setq *CDTLD* CDTLD))
    
      
    (or *Sovachngan* (setq *Sovachngan* 2))
    (setq Sovachngan (getint (strcat "\nS\U+1ED1 v\U+1EA1ch nh\U+1ECF gi\U+1EEFa 2 v\U+1EA1ch l\U+1EDBn: < "
    			  (rtos *Sovachngan* 2 0)
    			 " > :"
    		  )
    	 )
    )
    (if (not Sovachngan) (setq Sovachngan *Sovachngan*) (setq *Sovachngan* Sovachngan))
    
    (while (setq ObjPline (car (entsel "\nCh\U+1ECDn Pline: ")))
      	(setq VlaObjPL (vlax-ename->vla-object ObjPline))
            (setq LtsTaluy (VTLL CDTLN CDTLD Sovachngan ObjPline))
    	(setq LtsLDai (car LtsTaluy))
    	(setq LtsLNgan (cadr LtsTaluy))
      	 (setq Chon (strcase (getstring "\n(Ghi ch\U+00FA: U - L\U+00E0m l\U+1EA1i, C - \U+0110\U+1ED5i chi\U+1EC1u v\U+1EA1ch, G\U+00F5 b\U+1EA5t k\U+1EF3 \U+0111\U+1EC3 ti\U+1EBFp t\U+1EE5c) ")))
             (cond
               ((= Chon  "U")
    	     (progn
    	        (foreach e1 LtsLDai
    			(entdel e1)
    		)
    	        (foreach e2 LtsLNgan
    			(entdel e2)
    		)
    	     )
    	    )
    	   ((= Chon  "C")
    	     (progn
    	        (foreach e3 LtsLDai
    		  	(progn
    				(setq Pnt10D (cdr (assoc 10 (entget e3))))
    			  	(setq ang3 (angle '(0 0) (Vlax-curve-getfirstderiv VlaObjPL (vlax-curve-getParamAtPoint VlaObjPL Pnt10D))))
    			  	(setq Pnt11D (polar Pnt10D (- ang3 (/ pi 2) )  CDTLD))
    		  		(entmod (subst (cons 11 Pnt11D) (assoc 11 (entget e3)) (entget e3) ))
    			)
    		)
    	        (foreach e4 LtsLNgan
    		  	(progn
    				(setq Pnt10N (cdr (assoc 10 (entget e4))))
    			  	(setq ang4 (angle '(0 0) (Vlax-curve-getfirstderiv VlaObjPL (vlax-curve-getParamAtPoint VlaObjPL Pnt10N))))
    			  	(setq Pnt11N (polar Pnt10N (- ang4 (/ pi 2) ) CDTLN))
    		  		(entmod (subst (cons 11 Pnt11N) (assoc 11 (entget e4)) (entget e4) ))
    			)
    		)
    	     )
    	    )
    	   ((or (/= Chon  "U") (/= Chon  "C"))
    	     (setq Chon nil)
    	    )
    	 )
       )
    (setvar "OSMODE" Olmode)
    (princ)
    )
    
    (defun VTLL (CDTLN CDTLD Sovachngan ObjPline / CDTLD CDDoan n d1 d2 CDaiPLine ang2 Ptd Lts1 Lts2 LtsPntNgan Pnt1  EnameLD )
    (MakeLayer_ "TALUY" 7)
    (setq CDDoan (* (+ Sovachngan 1) CDTLN ))
    (setq VlaObjPline (vlax-ename->vla-object ObjPline))
    (setq CDaiPLine (vla-get-length VlaObjPline))
    (setq n (fix (/ CDaiPLine CDDoan)))
    (setq d1 0)
    (setq Lts1 (list))
    (setq LtsEnameLD (list))
    (setq LtsEnameLN (list))
    (while (< d1 CDaiPLine)
    	(progn
    		(setq Ptd (vlax-curve-getPointAtDist VlaObjPline d1))
    		(setq d1 (+ d1 CDDoan))
    	  	(setq ang2 (angle '(0 0) (Vlax-curve-getfirstderiv VlaObjPline (vlax-curve-getParamAtPoint VlaObjPline Ptd))))
    	  	(entmake (list (cons 0 "LINE") (cons 8 "TALUY") (cons 10  Ptd) (cons 11 (polar Ptd (+ ang2 (/ pi 2) ) CDTLD))))
    	  	(setq EnameLD (entlast))
    	  	(setq LtsEnameLD (append LtsEnameLD (list EnameLD)))
    	  	(setq Lts1 (append Lts1 (list Ptd)))
    	)
    )
    (setq d2 0)
    (setq Lts2 (list))
    (setq m (fix (/ CDaiPLine CDTLN)))
    (while (< d2 CDaiPLine)
    	(progn
    		(setq Ptn (vlax-curve-getPointAtDist VlaObjPline d2))
    		(setq d2 (+ d2 CDTLN))
    	  	(setq Lts2 (append Lts2 (list Ptn)))
    	)
    )
    (setq LtsPntNgan (LM:ListDifference Lts2 Lts1))
    (foreach Pnt1 LtsPntNgan
      	(setq ang3 (angle '(0 0) (Vlax-curve-getfirstderiv VlaObjPline (vlax-curve-getParamAtPoint VlaObjPline Pnt1))))
      	(entmake (list (cons 0 "LINE") (cons 10  Pnt1) (cons 8 "TALUY") (cons 11 (polar Pnt1 (+ ang3 (/ pi 2) ) CDTLN))))
      	(setq EnameLN (entlast))
      	(setq LtsEnameLN (append LtsEnameLN (list EnameLN)))
    )
    (setq DsTaluy (list LtsEnameLD LtsEnameLN))
    DsTaluy
    )
    
    
    (defun MakeLayer_ ( name colour /)
        (if (null (tblsearch "LAYER" name))
            (entmake
                (list
                   '(0 . "LAYER")
                   '(100 . "AcDbSymbolTableRecord")
                   '(100 . "AcDbLayerTableRecord")
                   '(70 . 0)
                    (cons 2 name)
                    (cons 62 colour)
                )
            )
        )
    )
    
    (defun C:VTL2 (  / Olmode Sovachngan  *Sovachngan* CDVN *CDVN*  CDDoan ObjPline1 ObjPL2 ObjPline2 VlaObjPline1 CDaiPLine1 VlaObjPline2
    		   n d1 d2 LtsEnameLD LtsEnameLN Lts1 Lts2 LtsPntNgan   PntInObjPline2 PntInObjPline3 ang_1 ang_2 P3
    	       )
    (MakeLayer_ "TALUYN" 1)
    (MakeLayer_ "TALUYD" 7)
    ;;;;;;;;;LUU OSNAP KHI BREAK, CANCEL, EXIT
    (defun *error* ( msg )
    (if Olmode (setvar 'osmode Olmode))
    (if (not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
        (princ (strcat "\nError: " msg))
    )
    (princ)
    )
    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    (setq Olmode (getvar "OSMODE"))
    ;;;(setq Sovachngan 1)
    
    (or *Sovachngan* (setq *Sovachngan* 1))
    (setq Sovachngan (getint (strcat "\nNhap so vach ngan giua 2 vach dai: < "
    			  (rtos *Sovachngan* 2 0)
    			 " > :"
    		    )
    	 )
    )
    (if (not Sovachngan) (setq Sovachngan *Sovachngan*) (setq *Sovachngan* Sovachngan))
      
    (or *CDVN* (setq *CDVN* 2.5))
    (setq CDVN (getreal (strcat "\nNh\U+1EADp kho\U+1EA3ng c\U+00E1ch gi\U+1EEFa c\U+00E1c v\U+1EA1ch: < "
    			  (rtos *CDVN* 2 2)
    			 " > :"
    		    )
    	 )
    )
    (if (not CDVN) (setq CDVN *CDVN*) (setq *CDVN* CDVN))
    (setq CDDoan (* (+ Sovachngan 1) CDVN ))
    
    
      
    (setq ObjPline1 (car (entsel "\nChon duong thu nhat: ")))
    (setq ObjPL2  (entsel "\nChon duong thu hai: "))
    (setq ObjPline2 (car ObjPL2))
    ;;;(setq PickPoint (cdr ObjPL2))
    
    (setq VlaObjPline1 (vlax-ename->vla-object ObjPline1))
    (setq CDaiPLine1 (vla-get-length VlaObjPline1))
    
    
    (setq VlaObjPline2 (vlax-ename->vla-object ObjPline2))
      
    (setq n (fix (/ CDaiPLine1 CDDoan)))
    (setq d1 0)
    (setq Lts1 (list))
    (setq LtsEnameLD (list))
    (setq LtsEnameLN (list))
    (while (< d1 CDaiPLine1)
    	(progn
    		(setq Ptd (vlax-curve-getPointAtDist VlaObjPline1 d1))
    		(setq d1 (+ d1 CDDoan))
    	  	(setq ang_1 (angle '(0 0) (Vlax-curve-getfirstderiv VlaObjPline1 (vlax-curve-getParamAtPoint VlaObjPline1 Ptd))))
    	  	(if (setq PntInObjPline2 (TDKDGN Ptd ObjPline2 (polar Ptd (+ ang_1 (/ pi 2) ) CDVN)))
    		    (progn
    	  	    	(entmake (list (cons 0 "LINE") (cons 8 "TALUYD") (cons 10  Ptd) (cons 11 PntInObjPline2)))
    	  	    	(setq EnameLD (entlast))
    	  		(setq LtsEnameLD (append LtsEnameLD (list EnameLD)))
    	  		(setq Lts1 (append Lts1 (list Ptd)))
    		    )
    		)
    	)
    )
    (setq d2 0)
    (setq Lts2 (list))
    (setq m (fix (/ CDaiPLine1 CDVN)))
    (while (< d2 CDaiPLine1)
    	(progn
    		(setq Ptn_N (vlax-curve-getPointAtDist VlaObjPline1 d2))
    		(setq d2 (+ d2 CDVN))
    	  	(setq Lts2 (append Lts2 (list Ptn_N)))
    	)
    )
    (setq LtsPntNgan (LM:ListDifference Lts2 Lts1))
    (foreach Pnt1 LtsPntNgan
      	(setq ang_2 (angle '(0 0) (Vlax-curve-getfirstderiv VlaObjPline1 (vlax-curve-getParamAtPoint VlaObjPline1 Pnt1))))
      	(if (setq PntInObjPline3 (TDKDGN Pnt1 ObjPline2 (polar Pnt1 (+ ang_2 (/ pi 2) ) CDVN)))
    	    (progn
    	  	(setq P3 (list (/ (+ (car Pnt1) (car PntInObjPline3)) 2) (/ (+ (cadr Pnt1) (cadr PntInObjPline3)) 2)))
    	  	(entmake (list (cons 0 "LINE") (cons 10  Pnt1) (cons 8 "TALUYN") (cons 11 P3)))
    	    )
    	)
    )
    (princ)
    )
    
    
    
    
    
    ;;;HAM LAY RA CAC PHAN TU KHAC NHAU TRONG DANH SACH 1 SO VOI DANH SACH 2 (TO - CON) (LEN L1 > LEN L2)
    ;;(LM:ListDifference '(1 2 3 4 5) '(2 4 6)  )
    (defun LM:ListDifference ( l1 l2 )
      (if l1
        (if (member (car l1) l2)
          (LM:ListDifference (cdr l1) l2)
          (cons (car l1) (LM:ListDifference (cdr l1) l2))
        )
      )
    )
    
    
    ;;;;;;;;;;;;;;;acextendnone	Do not extend either object
    ;;;;;;;;;;;;;;acextendthisentity	Extend obj1 to meet obj2
    ;;;;;;;;;;;;;;acextendotherentity	Extend obj2 to meet obj1
    ;;;;;;;;;;;;;;acextendboth	Extend both objects
    
    (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 MakeXline (pt vec)
      (entmakex (list (cons 0 "XLINE")
                      (cons 100 "AcDbEntity")
                      (cons 100 "AcDbXline")
                      (cons 10 pt)
                      (cons 11 vec)
    	    )
      )
    )
    
    (defun TDKDGN (P1 ObjPline1 Pnt / Vla:ObjPline1   EnameXline Vla:Xline LtsPnt ) ;;;TIM DIEM KEO DAI GAN NHAT
    (setq Vla:ObjPline1 (vlax-ename->vla-object ObjPline1))
    (setq P2 (mapcar '- Pnt P1))
    (MakeXline P1 P2)
    (setq EnameXline (entlast))
    (setq Vla:Xline (vlax-ename->vla-object EnameXline))
    (setq LtsPnt (LM:Intersections Vla:ObjPline1  Vla:Xline acextendboth))
    (entdel EnameXline)
    (setq PntNear (car (vl-sort LtsPnt '(lambda(x y) (< (distance x P1) (distance y P1))))))
    PntNear
    )
    
    
    (defun C:DCTL( / ss LtsEnameLine P1 P2  PVG1 PVG2 CDLine);;;DAO CHIEU TALUY
    (setq VLA:ObjPline (vlax-ename->vla-object (car (entsel "\nChon Polyline can dao chieu Taluy:"))))
    (Alert "\nQuet chon Line")
    (setq ss (ssget (list (cons 0 "LINE"))))
    (setq LtsEnameLine (acet-ss-to-list ss))
    (setq i 0)
    (foreach EnameL LtsEnameLine
    	(setq P1 (acet-dxf 10 (entget EnameL)))
    	(setq P2 (acet-dxf 11 (entget EnameL)))
    	(if (and (setq Pgiao (last (LM:Intersections (vlax-ename->vla-object EnameL) VLA:ObjPline acextendnone ))) (equal (LineVGtPline VLA:ObjPline EnameL) 1 0.0000000001))
    	    (progn
    	    	(setq CDLine (vla-get-length (vlax-ename->vla-object EnameL)))
    	    	(cond ((equal P1 Pgiao 0.00000001)
    		      	      (progn
    			    	(setq angL10 (angle '(0 0) (Vlax-curve-getfirstderiv VLA:ObjPline (vlax-curve-getParamAtPoint VLA:ObjPline Pgiao))))
    				(setq P2A (polar Pgiao (+ angL10 (* -1.0 (PointLeftRightPline VLA:ObjPline P2)  (/ pi 2))) CDLine))
    			      	(entmod (subst (cons 11 P2A) (assoc 11 (entget EnameL)) (entget EnameL) ))
    			      )
    		      )
    		      ((equal P2 Pgiao 0.00000001)
    		      	      (progn
    			    	(setq angL11 (angle '(0 0) (Vlax-curve-getfirstderiv VLA:ObjPline (vlax-curve-getParamAtPoint VLA:ObjPline Pgiao))))
    				(setq P1A (polar Pgiao (+ angL11 (* -1.0 (PointLeftRightPline VLA:ObjPline P1)  (/ pi 2))) CDLine))
    			      	(entmod (subst (cons 10 P1A) (assoc 10 (entget EnameL)) (entget EnameL) ))
    			      )
    		      )
    		    )
    		 )
    	)
    )
    (princ)
    )
    
    
      
    (defun LineVGtPline (VLA:ObjPline ObjLine / PVG Pd1 Pd2 GocP1P2  VLA:ObjPline VLA:ObjLine PntGiao );;;;XET LINE VUONG GOC VOI POLYLINE HAY KHONG?
    	(setq P1 (acet-dxf 10 (entget ObjLine)))
    	(setq P2 (acet-dxf 11 (entget ObjLine)))
      	(setq GocP1P2 (angle P1 P2))
      	(setq GocP2P1 (angle P2 P1))
      	(setq VLA:ObjLine (vlax-ename->vla-object ObjLine))
            (setq PntGiao (last (LM:Intersections VLA:ObjLine VLA:ObjPline acextendnone)))
      	(setq Goctaidiemgiao (angle '(0 0) (Vlax-curve-getfirstderiv VLA:ObjPline (vlax-curve-getParamAtPoint VLA:ObjPline PntGiao))))
      	(setq KQVG nil)
    	(if (or (equal (+ Goctaidiemgiao (/ pi 2)) GocP1P2 0.00000000001) (equal (- Goctaidiemgiao (/ pi 2)) GocP1P2 0.00000000001)
    	        (equal (+ Goctaidiemgiao (/ pi 2)) GocP2P1 0.00000000001) (equal (- Goctaidiemgiao (/ pi 2)) GocP2P1 0.00000000001))
    	    (setq KQVG 1)
    	    (setq KQVG 0)
            )
      KQVG
    )
    
    
    (defun PointLeftRightPline (ObjPline Pnt / PVG Pd1 Pd2);;;;XET DIEM NAM TRAI HAY PHAI PLINE
        (setq PVG (vlax-curve-getClosestPointTo ObjPline Pnt)
              Pd1 (vlax-curve-getpointAtParam ObjPline (fix (vlax-curve-getparamatPoint ObjPline PVG)))
              Pd2 (vlax-curve-getpointAtParam ObjPline (1+ (fix (vlax-curve-getparamatPoint ObjPline PVG))))
        )
        (setq Kqua nil)
        (if (or (equal (cos (+ (/ pi 2) (angle Pd1 Pd2))) (cos (angle Pnt PVG)) 0.00000001)
       	    (equal (sin (+ (/ pi 2) (angle Pd1 Pd2))) (sin (angle Pnt Pd1)) 0.00000001)
    	)
            (setq Kqua -1)
            (setq Kqua 1)
        )
        Kqua
    )
    
    
    
    

    Không biết anh @thanhduan2407 còn ở đây không?

    Em xin được nhờ anh (hoặc bất kỳ anh nào) sửa giúp em 1 chút lisp VTL2 để "đối tượng thứ hai" không phải là 1 đường mà có thể là nhiều đường.

    Trên diễn đàn có 1 lisp làm được tương tự (lisp Batter) nhưng với các đối tượng dài (hoặc rải dày) thì nó làm việc rất chậm.

    Về tác dụng thì như hình: Chỉ cần chọn đối tượng thứ nhất (1) và chọn nhóm đối tượng thứ 2 (2&3) rồi Enter để ra được kết quả như hình. Còn với lisp VTL2 thì phải thực hiện rải 2 lần và xóa bớt đối tượng thừa, hoặc phải Break đối tượng (1) thành các đoạn nhỏ.

    PS: hình chỉ là minh họa chứ em thường rải nhiều đối tượng khá phức tạp nên rất mất thời gian.

    - Thêm 1 điều nữa là lisp này có nhược điểm là không chạy liên tục, mỗi lần rải lại phải thực hiện lệnh từ đầu, không như lisp #dưới em up.

    Capture.PNG


  13. Em cảm ơn các bác vì đã đọc bài ạ!

    Vấn đề này em đã hỏi nhiều nơi (có thể đã hỏi ở diễn đàn mà quên mất) và từ khá lâu. Nếu trùng bài mong các anh bỏ quá.

    Đó là lỗi không thể tạo được TextStyle bằng lệnh -STYLE với các font TCVN3. Cứ nhập tên font là CAD báo lỗi "Font file doesn't exist"

    Ví dụ với font .VnArial em nhập ".VnArial" hay ".VnArial.ttf"... đều không được.

    Hậu quả của lỗi này là hầu hết lisp về text liên quan đến TCVN3 đều không chạy được. Mà bản vẽ đầu vào của em đa phần đều toàn font TCVN3 nên phải làm thủ công nhiều.

    Em đã thử trên CAD2007, 2013, 2015, 2018 và 2020... tất cả đều bị.

    Thêm nữa là em đang dùng Win10. Ngày mới lên win10 thì không bị, nhưng cứ cài win được 1 thời gian là lại bị. Em có backup Registry của bản win cũ rồi chạy trên bản win mới nhưng cũng chỉ được một thời gian (chắc tại win tự động update).

    Mong các anh chỉ bảo cách giải quyết ạ. Em cảm ơn lần nữa ạ!

     

    PS: Đây là nội dung em thực hiện trên CAD:

    Command: -STYLE
    Enter name of text style or [?] <0-Txt>: 1
    
    Existing style. Full font name = .VnTime
    Specify font name or font filename (for SHX) <txt>: .VnArial
    
    Font file doesn't exist.

  14. Em có 1 thắc mắc lâu nay cũng tìm hiểu và hỏi nhiều chỗ nhưng không được. Nay nhờ các bác giải quyết ạ:
    CAD2018 trên máy em mở lần đầu (sau khi bật laptop) bao giờ cũng ngốn CPU, dù không mở file nào. Nhưng tắt đi bật lại thì bình thường.
    Bác nào từng gặp phải vấn đề này cho em xin cách giải quyết ạ. Em cảm ơn nhiều!

    Capture 2.PNG

    Capture.PNG


  15. 19 phút trước, tien2005 đã nói:

    Theo y/c của Bạn, số chẵn màu 5, số lẽ màu 3

    
    (defun c:cle ( / num ss _dxf)
      (defun _dxf (code e) (cdr (assoc code (entget e))))
      (setq ss (ssget '((0 . "*TEXT"))))
      (foreach n (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
        (if(and
    	 (setq num (distof (_dxf 1 n)))
    	 (= (rem num 1) 0);chon so nguyen
    	 )
          (if(= (rem num 2) 0); chon so chan
    	(vla-put-color(vlax-ename->vla-object n) 5); so chan mau 5
    	(vla-put-color(vlax-ename->vla-object n) 3); so le mau 3
    	)
          )
        )
      (princ)
      )

     

    Dạ chuẩn luôn ạ. Thank anh!


  16. Dạ em sợ trình bày dài dòng các anh ngại đọc thôi ạ.

    Cụ thể là thế này, em hay phải làm việc với bản đồ địa hình với các đường đồng mức có ghi giá trị cao độ trên nó.

    Do bản đồ em nhận được thường là tỷ lệ 1:1000, em muốn giảm tỷ lệ bản đồ xuống 1:2000 thì phải xóa bớt các đường đồng mức đi.

    Sau khi xóa các đường đồng mức thì còn lại các text thừa với giá trị cao độ chẵn hoặc lẻ. Với rất nhiều text mà thao tác bằng FIND hoặc QSELECT thì sẽ mất nhiều thời gian.

    Tương tự với các mặt cắt có ghi cao độ từ thấp đến cao và cũng muốn xóa bớt text...

    Dạ vấn đề là như thế ạ.


  17. Cảm ơn các anh vì đã quan tâm ạ!

    Như tiêu đề, em muốn nhờ các anh viết giúp em 1 lisp chọn số với lựa chọn chẵn hoặc lẻ, rồi chuyển số chọn được sang màu 5.

    Các số được chọn chỉ là số tự nhiên (1, 2, 3...) và nếu được với số nguyên (-1, -2, -3,..., 1, 2, 3...) thì tốt ạ.

    Em cảm ơn nhiều ạ!

    • Vote giảm 1
×