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

huunhantvxdts

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

  • Số lượng nội dung

    857

  • Đã tham gia

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

  • Ngày trúng

    40

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

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

    6 phút trước, Newbia_1812 đã nói:

    Chào các bạn, mình là thành viên mới, mình muốn kết bạn và tìm 1 bạn rành về Lisp, Net có thể viết dùm mình 1 lisp hoặc net để hỗ trợ công việc, bạn nào nhận thì để lại số zalo mình liên hệ nhé, mình sẽ gởi phí đàng hoàng nhé, cảm ơn các bạn đã đọc bài viết, thanks nhé

    Chào bạn lisp thì mình cũng biết 1 ít, nếu đề bài của bạn ko quá khó mình có thể hỗ trợ được nhé 

    Zalo: 0848.998.045

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

    1 giờ} trướ}c, nguyenbd1 đã nói:

    Cũng là vấn đề cũ nhưng là đi theo hướng khác. E muốn lấy phép chia của 2 đoạn thẳng. Câu trúc như sau. Chọn điểm 1 và 2 tinh được khoảng cách 1 và 2 là a sau đó chọn điểm 3 chọn điểm 4  tình được khoảng cách 3 và 4 là b sau đó lấy a chia b và lấy kết quả đó ghi ra màn hình autocad. Rất mong anh e giúp đỡ 

    (defun c:CKC (/ cur_lay oldos p1 p2 p3 p4 p kc1 kc2 heso)
(setq cur_lay (getvar "clayer" ))
(setq oldos (getvar "OSMODE"))
(setvar "osmode" 0)
(setvar "cmdecho" 0)
(vl-load-com)
(setq p1 (getpoint "\nPick diem thu 1"))
(setq p2 (getpoint p1 "\nPick diem thu 2"))
(setq p3 (getpoint "\nPick diem thu 3"))
(setq p4 (getpoint p3 "\nPick diem thu 4"))
(setq kc1 (distance p1 p2))
(setq kc2 (distance p3 p4))
(setq heso (/ kc1 kc2))
(setq p (getpoint "\nPick diem dat text"))
(MakeText p (rtos heso 2 2) 2 0 "MC" nil 1 nil)
(setvar "clayer" cur_lay)
(setvar "osmode" oldos)
(setvar "CMDECHO" 1)
(princ)
)
(defun MakeText (point string Height Ang justify Layer color Style / Lst); Ang: Radial
    (setq Lst (list '(0 . "TEXT")
            (cons 8 (if Layer Layer (getvar "Clayer")))
            (cons 62 (if Color Color 256))
            (cons 10 point)
            (cons 40 Height)
            (cons 1 string)
            (cons 50 Ang)
            (cons 7 (if Style Style (getvar "Textstyle")))
        )
    justify (strcase justify)
      )
      (cond ((= 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)))))
            ((= justify "TL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 3)))))
            ((= justify "TC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 3)))))
            ((= justify "TR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 3)))))    
            ((= justify "ML") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 2)))))
            ((= justify "MC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 2)))))
            ((= justify "MR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 2)))))
            ((= justify "BL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 1)))))
            ((= justify "BC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 1)))))
            ((= justify "BR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 1)))))
      )
     (entmakex Lst)
 )

    Gửi bạn

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

    4 giờ trước, thietke08 đã nói:

    Hiện mình đang tạo lisp để chèn một block trong một bản vẽ có chứa các block thư viện bằng lệnh -INSERTCONTENT tuy nhiên nó báo lỗi không thực hiện được như nhập lệnh trực tiếp trong CAD.

    Nhờ mọi người biết cách sửa giúp và chèn thêm điểm chèn bằng cách pick điểm trên bản vẽ. Xin cảm ơn.

     

    Lisp hiện tại là  

    
;INSERT BLOCK LAYER
(defun c:IB	()	(command "-INSERTCONTENT"""U:\04 CAD\05 DIGITAL LIBRARY\K_LSTEAM-TEMPLATE "" "K-LA-LAYER-DIM-TABLE-LEADER""0,0" "0" "1"))

     

    Lệnh "-INSERTCONTENT" có từ cad bao nhiêu nhỉ sao cad mình không có 

    mình thì dùng lệnh insert như sau:

    (command "INSERT" (strcat "C:" "\\TND\\dwg\\TND_huongchay1") (list 0 0) 1 1 0)

     

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

    1 giờ trước, MrCGIS đã nói:

     (setq p1 (polar pt (/ (* 3 pi) 4) 0.01))
    (setq p2 (polar pt (/ pi -4) 0.01))

    Anh có thể giải thích thêm cho em biết thêm hai dòng code này là gì không anh? về set chỉ số ,... Em cảm ơn

    Cái này là set 2 điểm của khung để chọn đối tượng bạn.

    Add zalo 0848.998.045 trao đổi thêm nhé

    • Vote tăng 1

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

    1 giờ trước, VoHoan đã nói:

    Cái trên chắc không phù hợp vì cách thức thực hiện của mình nó đòi hỏi thực tế với mặt bằng tuyến, mà không có lisp nên không kt có chạy được không.

    không biết như này có đúng với yêu cầu của bạn không nữa, không phân biệt đối tượng thuộc layer nào cả, chỉ cần nó là line hoặc Polyline nhé

    https://www.facebook.com/watch?v=502227591495777

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

    43 phút trước, VoHoan đã nói:

    Mình làm bình đồ tuyến giao thông, khi vuốt các đường giao thường tao cung tròn bo góc. Các bước mình có miêu tả trong file ví dụ gửi kèm như sau:

    Bước 1: tạo đường tròn với lựa chọn "TTR" tiếp xúc với 2 đường Pline L1, L2 (2 đường này có thể gãy khúc) với bán kính phù hợp (bán kính phù hợp còn phụ thuộc điếm tiếp xúc). Nên có thể phải vẽ nhiều lần đường tròn để phù hợp với thực tế mặt bằng tuyến.

    Bước 2: Dùng lệnh "trim" để cắt tạo cung tròn. Nhưng do không phải lúc nào cũng cắt được (chắc do đường L1, L2 hoặc do điểm tiếp xúc nhưng chưa chạm L1 L2) nên mình phải thêm bước phụ để cắt (có miêu tả trong file VD).

    Giờ mình muốn viết 1 lisp với các bước thực hiện như sau:

    - Bước 1: Lệnh lisp "Bogoc" lựa chọn đường L1, L2, (khi chọn L1, L2 thì vị trí chọn là vị trí tiếp xúc với đường tròn) nhập bán kính để tạo đường tròn.

    - Bước 2: Nếu phù hợp thì "enter" tạo cung tròn, chưa ưng ý thì quay lại bước 1.

    Xin cảm ơn trước các bác xem giúp đỡ.

    Vi du.dwg

    Bạn xem cái này phù hợp không nhé

    https://www.youtube.com/watch?v=4rBz4QPay7A

    • Like 1

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

    1 giờ} trướ}c, AutoTay.com đã nói:

    Em có chỉnh sửa lisp VK 1 chút cho đúng nhu cầu của em nhưng còn 1 số thứ không biết sửa thế nào. Nhờ các anh sửa giúp em ạ.

    Em cảm ơn các anh nhiều!

    Các thứ em muốn sửa là: Bóp Width factor của text lại thành 0.8 và bật tất cả chế độ Osnap sau khi chạy xong. 

    
(defun c:VKK( / olmode P1 P2 Tleebd)

    (setvar "PLINEWID" 0)
    (command "Layer" "M" "--KHUNG" "C" "7" "" "")
    (command "_Style" "--KHUNG" "txt.shx" "0" "0.8" "0" "" "" "")

(vl-load-com)
(setq olmode (getvar "OSMODE"))
(setvar "OSMODE" 1)
(setq P1 (getpoint "\n Top Left >>> "))
(setq P2 (getpoint P1 "\n Right Bottom >>> "))
(or *Tleebd* (setq *Tleebd* 1000))
(setq Tleebd (getreal (strcat "\n \n Scale 1/...   <"
          (rtos *Tleebd* 2 0)
         "> :"
      )
 )
)
(if (not Tleebd) (setq Tleebd *Tleebd*) (setq *Tleebd* Tleebd))
(TML1 P1 P2 Tleebd)
(setvar "OSMODE" olmode)
(princ)
)

(defun TML1 (P1 P22 tile_tmp /  Ent Height rau tHeight len_per ob ) ;;;; Tao mat luoi
(vl-load-com)

(setq olmode (getvar "OSMODE"))
(setvar "Osmode" 1)
(setq Height (abs (- (cadr P1) (cadr P22))))
(or #tile (setq #tile 500))
(if tile_tmp (setq #tile tile_tmp))
(setq dis (/ #tile 10.0)
        rau (/ #tile 200.0)
        tHeight  (/ (* 1.7 rau) 5) ; Chieu cao text
        len_per (/ #tile 125.0) ; Chieu dai rau
)
(setq WithLine (* 0.6 (/ rau 5))) ; Chieu rong Pline
(setq olmode (getvar "OSMODE"))
(setvar "Osmode" 0)
(setq P11 (list (car P1) (cadr P22)))
(setq
      Gocxoay (angle P11 P22)
      Kc (distance P11 P22)
      P3 (polar P11 (+ (/ pi 2) Gocxoay) Height)
      P4 (polar P3  Gocxoay  Kc)
)
(command "Pline" P11 P3 P4 P22 P11 "")
(setq e (entlast))
(setq Elast (entlast))
(vla-getboundingbox (vlax-ename->vla-object e) 'p1 'p2)
(mapcar  '(lambda (a b ) (* 0.5 (+ a b )))
(setq p1 (vlax-safearray->list p1)) (setq p2(vlax-safearray->list p2)))
(setq x1 (car p1) x2 (car p2) y1 (cadr p1) y2 (cadr p2) y1_tmp (round+ y1 dis) x1_tmp (round+ x1 dis))
;;; DoX
(while (< y1_tmp y2)
    (setq objLine (ST:Entmake-Line (list x1 y1_tmp) (list x2 y1_tmp)))
    (setq y1_tmp (+ y1_tmp dis)
        lstInter (ST:Ent-IntersObj (entlast) e)
        lstInter (vl-sort lstInter '(lambda (x y) (< (car x)(car y))))
        1st  (car lstInter)
            2nd  (cadr lstInter)
    )
    ;Trai
    (ST:Entmake-Line 1st (mapcar '- 1st (list (* 2 rau) 0 0)))
      (wtxt (substr (rtos (cadr 1st) 2 0) 1 4) (list (- (+ (car 1st) (* 1.5 WithLine)) (* 2 rau)) (+ (cadr 1st) (/ rau 10))) tHeight 0 "L")
      (wtxt  (substr (rtos (cadr 1st) 2 0) 5) (list (- (car 1st) (/ rau 10)) (- (cadr 1st) (/ rau 10)))  (/ (* 2.1 tHeight) 1.7) 0 "TR")
    ;Phai
    (ST:Entmake-Line 2nd (mapcar '+ 2nd (list (* 2 rau) 0 0)))
      (wtxt (substr (rtos (cadr 2nd) 2 0) 1 4) (list (+ (car 2nd) (/ rau 10)) (+ (cadr 2nd) (/ rau 10))) tHeight 0 "L")
      (wtxt  (substr (rtos (cadr 2nd) 2 0) 5) (list (+ (- (car 2nd) (* 1.5 WithLine)) (* 2 rau)) (-  (cadr 2nd)  (/ rau 10)))  (/ (* 2.1 tHeight) 1.7) 0 "TR")
 
    (ST:GGBP (car lstInter) (cadr lstInter) dis len_per)                
    (entdel objLine)
)
(ST:Entmake-Line P11 (list (- (car P11) (* 2 rau)) (cadr P11)))
(ST:Entmake-Line P11 (list (car P11) (- (cadr P11) (* 2 rau)) ))

(ST:Entmake-Line P22 (list (+ (car P22) (* 2 rau)) (cadr P22)))
(ST:Entmake-Line P22 (list (car P22) (- (cadr P22) (* 2 rau)) ))

(ST:Entmake-Line P4 (list (+ (car P4) (* 2 rau)) (cadr P4)))
(ST:Entmake-Line P4 (list (car P4) (+ (cadr P4) (* 2 rau))))

(ST:Entmake-Line P3 (list (- (car P3) (* 2 rau)) (cadr P3)))
(ST:Entmake-Line P3 (list (car P3) (+ (cadr P3) (* 2 rau)) ))


(setvar "CECOLOR" "bylayer")
(command "rectangle" "w" WithLine (list (- (car P11) (* 2 rau)) (- (cadr P11) (* 2 rau))) (list (+ (car P4) (* 2 rau)) (+ (cadr P4) (* 2 rau))))
(setvar "CECOLOR" "256")
    ;;DoY
(while (< x1_tmp x2)
    (setq objLine (ST:Entmake-Line (list x1_tmp y1)(list x1_tmp y2)))
    (setq x1_tmp (+ x1_tmp dis)
        lstInter (ST:Ent-IntersObj (entlast) e)
        lstInter (vl-sort lstInter '(lambda (x y) (< (cadr x)(cadr y))))
        1st (car lstInter) 2nd (cadr lstInter)
        )
    ;Duoi
    (ST:Entmake-Line 1st (mapcar '- 1st (list 0 (* 2 rau) 0)))
    (wtxt  (substr (rtos (car 1st) 2 0) 1 3) (list (- (car 1st) (/ rau 10)) (+  (- (cadr 1st) rau) (/ rau 10))) tHeight 0 "TR")
    (wtxt  (substr (rtos (car 1st) 2 0) 4) (list (+ (car 1st) (/ rau 10)) (+  (- (cadr 1st) rau) (/ rau 10)))  (/ (* 2.1 tHeight) 1.7) 0 "TL")
 
    ;Tren
    (ST:Entmake-Line 2nd (mapcar '+ 2nd (list 0 (* 2 rau) 0 )))
    (wtxt  (substr (rtos (car 2nd) 2 0) 1 3) (list (- (car 2nd) (/ rau 10)) (+  (+ (cadr 2nd) rau) (* 2 (/ rau 10)))) tHeight 0 "TR")
    (wtxt  (substr (rtos (car 2nd) 2 0) 4) (list (+ (car 2nd) (/ rau 10)) (+  (+ (cadr 2nd) rau) (* 2 (/ rau 10))))  (/ (* 2.1 tHeight) 1.7) 0 "TL")
 
    (entdel objLine)
)
(princ)

   (command "-LAYER" "S" "0" "")
   (command "RECTANG" "W" "0" ^C)

)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun dinhhcn (P Cdai CCao / ) ;Dinh hinh chu nhat
(setq P2 (Polar P 0 Cdai))
(setq P4 (Polar P (/ pi 2) CCao))
(setq P3 (Polar P4 0 Cdai))
(setq DHV (list P P2 P3 P4 P))
DHV
)

(Defun RTD(x) (/ (* x 180) pi) )
(defun round+ (num prec)
    (if (< 0 prec)
        (* prec
             (if (minusp (setq num (/ num prec)))
                 (fix num)
                 (if (= num (fix num))
                     num
                     (fix (1+ num))
                 )
             )
        )
    num
    )
)

(defun ST:Entmake-Point (pt Len / lstEn)
    (append (list (ST:Entmake-Line (mapcar '- pt (list (/ len 2) 0 0))(mapcar '+ pt (list (/ len 2) 0 0))))
    (list (ST:Entmake-Line (mapcar '- pt (list 0 (/ len 2)  0))(mapcar '+ pt  (list 0 (/ len 2)  0)))))
)
(defun ST:Entmake-Line (p1 p2)(entmakex (list (cons 0 "LINE")(cons 10 p1)(cons 11 p2))))
(defun ST:Ent-IntersObj (e1 e2  / ob1 ob2 g L i kq)
(setq
    ob1 (vlax-ename->vla-object e1)
    ob2 (vlax-ename->vla-object e2)
)    
(setq g (vlax-variant-value (vla-IntersectWith ob1 ob2 acExtendNone)))
(if (/= (vlax-safearray-get-u-bound g 1) -1) (setq L (vlax-safearray->list g)))
(setq i 0)
(repeat (/ (length L) 3)
    (setq kq (append (list (list (nth i L) (nth (+ i 1) L) (nth (+ i 2) L))) kq))
    (setq i (+ i 3))
)
kq
)
(defun ST:GGBP (p1 p2 dis len_perLine / x1) ;trai -> phai
        (setq x1 (round+ (car p1) dis))
        (while (< x1 (car p2))
            (ST:Entmake-Point  (list  x1 (cadr p1))    len_perLine)
            (setq x1 (+ x1 dis)))
)

(defun wtxt (string Point Height Ang justify / Lst)
 (setq Lst (list '(0 . "TEXT")
   (cons 8 (if Layer Layer (getvar "Clayer")))
   (cons 62 (if Color Color 256))
   (cons 10 point)
   (cons 40 Height)
   (cons 1 string)
   (if Ang (cons 50 Ang))
   (cons 7 (if Style Style (getvar "Textstyle"))))
  justify (strcase justify))
 (cond ((= justify "C") (setq Lst (append Lst (list (cons 72 1) (cons 11 point)))))
               ((= justify "L") (setq Lst (append Lst (list (cons 72 0)(cons 73 0) (cons 10 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)))))
            ((= justify "TL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 3)))))
            ((= justify "TC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 3)))))
            ((= justify "TR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 3)))))   
            ((= justify "ML") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 2)))))
            ((= justify "MC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 2)))))
            ((= justify "MR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 2)))))
            ((= justify "BL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 1)))))
            ((= justify "BC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 1)))))
            ((= justify "BR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 1))))))
 (entmake Lst)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

     

    Gửi bạn nhé 

    (defun c:VKK( / olmode P1 P2 Tleebd)

    (setvar "PLINEWID" 0)
    (command "Layer" "M" "--KHUNG" "C" "7" "" "")
    (command "_Style" "--KHUNG" "txt.shx" "0" "0.8" "0" "" "" "")

(vl-load-com)
(setq olmode (getvar "OSMODE"))
(setvar "OSMODE" 0)
(setq P1 (getpoint "\n Top Left >>> "))
(setq P2 (getpoint P1 "\n Right Bottom >>> "))
(or *Tleebd* (setq *Tleebd* 1000))
(setq Tleebd (getreal (strcat "\n \n Scale 1/...   <"
          (rtos *Tleebd* 2 0)
         "> :"
      )
 )
)
(if (not Tleebd) (setq Tleebd *Tleebd*) (setq *Tleebd* Tleebd))
(TML1 P1 P2 Tleebd)
(setvar "OSMODE" olmode)
(princ)
)

(defun TML1 (P1 P22 tile_tmp /  Ent Height rau tHeight len_per ob ) ;;;; Tao mat luoi
(vl-load-com)

;(setq olmode (getvar "OSMODE"))
;(setvar "Osmode" 1)
(setq Height (abs (- (cadr P1) (cadr P22))))
(or #tile (setq #tile 500))
(if tile_tmp (setq #tile tile_tmp))
(setq dis (/ #tile 10.0)
        rau (/ #tile 200.0)
        tHeight  (/ (* 1.7 rau) 5) 		; Chieu cao text
        len_per (/ #tile 125.0) 		; Chieu dai rau
)
(setq WithLine (* 0.6 (/ rau 5))) 		; Chieu rong Pline
;(setq olmode (getvar "OSMODE"))
(setvar "Osmode" 0)
(setq P11 (list (car P1) (cadr P22)))
(setq
      Gocxoay (angle P11 P22)
      Kc (distance P11 P22)
      P3 (polar P11 (+ (/ pi 2) Gocxoay) Height)
      P4 (polar P3  Gocxoay  Kc)
)
(command "Pline" P11 P3 P4 P22 P11 "")
(setq e (entlast))
(setq Elast (entlast))
(vla-getboundingbox (vlax-ename->vla-object e) 'p1 'p2)
(mapcar  '(lambda (a b ) (* 0.5 (+ a b )))
(setq p1 (vlax-safearray->list p1)) (setq p2(vlax-safearray->list p2)))
(setq x1 (car p1) x2 (car p2) y1 (cadr p1) y2 (cadr p2) y1_tmp (round+ y1 dis) x1_tmp (round+ x1 dis))
;;; DoX
(while (< y1_tmp y2)
    (setq objLine (ST:Entmake-Line (list x1 y1_tmp) (list x2 y1_tmp)))
    (setq y1_tmp (+ y1_tmp dis)
        lstInter (ST:Ent-IntersObj (entlast) e)
        lstInter (vl-sort lstInter '(lambda (x y) (< (car x)(car y))))
        1st  (car lstInter)
            2nd  (cadr lstInter)
    )
    ;Trai
    (ST:Entmake-Line 1st (mapcar '- 1st (list (* 2 rau) 0 0)))
      (wtxt (substr (rtos (cadr 1st) 2 0) 1 4) (list (- (+ (car 1st) (* 1.5 WithLine)) (* 2 rau)) (+ (cadr 1st) (/ rau 10))) tHeight 0 "L")
      (wtxt  (substr (rtos (cadr 1st) 2 0) 5) (list (- (car 1st) (/ rau 10)) (- (cadr 1st) (/ rau 10)))  (/ (* 2.1 tHeight) 1.7) 0 "TR")
    ;Phai
    (ST:Entmake-Line 2nd (mapcar '+ 2nd (list (* 2 rau) 0 0)))
      (wtxt (substr (rtos (cadr 2nd) 2 0) 1 4) (list (+ (car 2nd) (/ rau 10)) (+ (cadr 2nd) (/ rau 10))) tHeight 0 "L")
      (wtxt  (substr (rtos (cadr 2nd) 2 0) 5) (list (+ (- (car 2nd) (* 1.5 WithLine)) (* 2 rau)) (-  (cadr 2nd)  (/ rau 10)))  (/ (* 2.1 tHeight) 1.7) 0 "TR")
 
    (ST:GGBP (car lstInter) (cadr lstInter) dis len_per)                
    (entdel objLine)
)
(ST:Entmake-Line P11 (list (- (car P11) (* 2 rau)) (cadr P11)))
(ST:Entmake-Line P11 (list (car P11) (- (cadr P11) (* 2 rau)) ))

(ST:Entmake-Line P22 (list (+ (car P22) (* 2 rau)) (cadr P22)))
(ST:Entmake-Line P22 (list (car P22) (- (cadr P22) (* 2 rau)) ))

(ST:Entmake-Line P4 (list (+ (car P4) (* 2 rau)) (cadr P4)))
(ST:Entmake-Line P4 (list (car P4) (+ (cadr P4) (* 2 rau))))

(ST:Entmake-Line P3 (list (- (car P3) (* 2 rau)) (cadr P3)))
(ST:Entmake-Line P3 (list (car P3) (+ (cadr P3) (* 2 rau)) ))


(setvar "CECOLOR" "bylayer")
(command "rectangle" "w" WithLine (list (- (car P11) (* 2 rau)) (- (cadr P11) (* 2 rau))) (list (+ (car P4) (* 2 rau)) (+ (cadr P4) (* 2 rau))))
(setvar "CECOLOR" "256")
    ;;DoY
(while (< x1_tmp x2)
    (setq objLine (ST:Entmake-Line (list x1_tmp y1)(list x1_tmp y2)))
    (setq x1_tmp (+ x1_tmp dis)
        lstInter (ST:Ent-IntersObj (entlast) e)
        lstInter (vl-sort lstInter '(lambda (x y) (< (cadr x)(cadr y))))
        1st (car lstInter) 2nd (cadr lstInter)
        )
    ;Duoi
    (ST:Entmake-Line 1st (mapcar '- 1st (list 0 (* 2 rau) 0)))
    (wtxt  (substr (rtos (car 1st) 2 0) 1 3) (list (- (car 1st) (/ rau 10)) (+  (- (cadr 1st) rau) (/ rau 10))) tHeight 0 "TR")
    (wtxt  (substr (rtos (car 1st) 2 0) 4) (list (+ (car 1st) (/ rau 10)) (+  (- (cadr 1st) rau) (/ rau 10)))  (/ (* 2.1 tHeight) 1.7) 0 "TL")
 
    ;Tren
    (ST:Entmake-Line 2nd (mapcar '+ 2nd (list 0 (* 2 rau) 0 )))
    (wtxt  (substr (rtos (car 2nd) 2 0) 1 3) (list (- (car 2nd) (/ rau 10)) (+  (+ (cadr 2nd) rau) (* 2 (/ rau 10)))) tHeight 0 "TR")
    (wtxt  (substr (rtos (car 2nd) 2 0) 4) (list (+ (car 2nd) (/ rau 10)) (+  (+ (cadr 2nd) rau) (* 2 (/ rau 10))))  (/ (* 2.1 tHeight) 1.7) 0 "TL")
 
    (entdel objLine)
)
(princ)

   (command "-LAYER" "S" "0" "")
   (command "RECTANG" "W" "0" ^C)

)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun dinhhcn (P Cdai CCao / ) ;Dinh hinh chu nhat
(setq P2 (Polar P 0 Cdai))
(setq P4 (Polar P (/ pi 2) CCao))
(setq P3 (Polar P4 0 Cdai))
(setq DHV (list P P2 P3 P4 P))
DHV
)

(Defun RTD(x) (/ (* x 180) pi) )
(defun round+ (num prec)
    (if (< 0 prec)
        (* prec
             (if (minusp (setq num (/ num prec)))
                 (fix num)
                 (if (= num (fix num))
                     num
                     (fix (1+ num))
                 )
             )
        )
    num
    )
)

(defun ST:Entmake-Point (pt Len / lstEn)
    (append (list (ST:Entmake-Line (mapcar '- pt (list (/ len 2) 0 0))(mapcar '+ pt (list (/ len 2) 0 0))))
    (list (ST:Entmake-Line (mapcar '- pt (list 0 (/ len 2)  0))(mapcar '+ pt  (list 0 (/ len 2)  0)))))
)
(defun ST:Entmake-Line (p1 p2)(entmakex (list (cons 0 "LINE")(cons 10 p1)(cons 11 p2))))
(defun ST:Ent-IntersObj (e1 e2  / ob1 ob2 g L i kq)
(setq
    ob1 (vlax-ename->vla-object e1)
    ob2 (vlax-ename->vla-object e2)
)    
(setq g (vlax-variant-value (vla-IntersectWith ob1 ob2 acExtendNone)))
(if (/= (vlax-safearray-get-u-bound g 1) -1) (setq L (vlax-safearray->list g)))
(setq i 0)
(repeat (/ (length L) 3)
    (setq kq (append (list (list (nth i L) (nth (+ i 1) L) (nth (+ i 2) L))) kq))
    (setq i (+ i 3))
)
kq
)
(defun ST:GGBP (p1 p2 dis len_perLine / x1) ;trai -> phai
        (setq x1 (round+ (car p1) dis))
        (while (< x1 (car p2))
            (ST:Entmake-Point  (list  x1 (cadr p1))    len_perLine)
            (setq x1 (+ x1 dis)))
)

(defun wtxt (string Point Height Ang justify / Lst)
 (setq Lst (list '(0 . "TEXT")
   (cons 8 (if Layer Layer (getvar "Clayer")))
   (cons 62 (if Color Color 256))
   (cons 10 point)
   (cons 41 0.8)
   (cons 40 Height)
   (cons 1 string)
   (if Ang (cons 50 Ang))
   (cons 7 (if Style Style (getvar "Textstyle"))))
  justify (strcase justify))
 (cond ((= justify "C") (setq Lst (append Lst (list (cons 72 1) (cons 11 point)))))
               ((= justify "L") (setq Lst (append Lst (list (cons 72 0)(cons 73 0) (cons 10 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)))))
            ((= justify "TL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 3)))))
            ((= justify "TC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 3)))))
            ((= justify "TR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 3)))))   
            ((= justify "ML") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 2)))))
            ((= justify "MC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 2)))))
            ((= justify "MR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 2)))))
            ((= justify "BL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 1)))))
            ((= justify "BC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 1)))))
            ((= justify "BR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 1))))))
 (entmake Lst)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

     

    • Vote tăng 1

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

    2 giờ trước, MrCGIS đã nói:

    Dạ cảm ơn anh, cho em hỏi thêm là nếu khoản cách giữa các block thông tin quá sát nhau thì em giảm giá trị thông tin đoạn :

     (setq p1 (polar pt (/ (* 3 pi) 4) 0.01))
    (setq p2 (polar pt (/ pi -4) 0.01))

    như thế này có hợp lý không anh, hay phải điều chỉnh chỗ khác nữa ạ?

    image.png.7f0f5f357631fba8fee8c988baabe1c8.png

    Bạn tự test được mà, nếu ko được thì tăng lên nhé

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

    22 phút trước, MrCGIS đã nói:

    Cảm ơn anh giúp đỡ, nhưng cho em hỏi với trường hợp gần nhau thì kết quả lisp lại bị sai vị trí có cách nào cho chính xác hơn đc k anh. Với cho em hỏi sao em quét chọn block thì chỉ cho phép chọn số lượng ít thôi còn số lượng nhiều thì không thấy chạy ạ?

    image.png.6424e4288d19b38f5645cf7c222d30e9.png

    image.png.66fc518a4bfaa445ec6d5f145d084973.png

    Sửa lại cho bạn nhé 

    (defun C:SCBL (/ tl obj blkname pt p1 p2 ssbl doc blkname lay mau)
(setq tl (getreal "\nNhap ti le scale:"))
(princ "\nChon cac Blocks...")
(if (ssget '((0 . "INSERT")));(2 . "CENTRD_1")
(progn
(vlax-for obj (vla-get-ActiveSelectionSet (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))))
(setq blkname (vla-get-Name obj))
	;chuyen doi tuong trong BL thanh mau layer
(if (= blkname "CENTRD_1")
(progn
(setq pt (vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint obj))))
(setq p1 (polar pt (/ (* 3 pi) 4) 1))
(setq p2 (polar pt (/ pi -4) 1))
(vla-ZoomCenter (vlax-get-acad-object) (vlax-3D-point pt) 500)
(setq ssbl (ssget "C" p1 p2 '((0 . "INSERT") (-4 . "<NOT") (2 . "CENTRD_1") (-4 . "NOT>"))))
(command "scale" ssbl "" pt tl)
)
)
)
)
)
)

     

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

    14 phút trước, MrCGIS đã nói:

    Cảm ơn anh giúp đỡ, nhưng cho em hỏi với trường hợp gần nhau thì kết quả lisp lại bị sai vị trí có cách nào cho chính xác hơn đc k anh. Với cho em hỏi sao em quét chọn block thì chỉ cho phép chọn số lượng ít thôi còn số lượng nhiều thì không thấy chạy ạ?

    image.png.6424e4288d19b38f5645cf7c222d30e9.png

    image.png.66fc518a4bfaa445ec6d5f145d084973.png

    1. Phạm vi xét trong o vuông 10x10 nên nó bị dính vào nhau có thể giảm lại 2x2 chắc sẽ ổn.

    2. Các đối tượng phải nằm trong phạm vi màn hình thấy được nó mới chạy bạn nhé

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

    Vào lúc 31/3/2022 tại 10:36, MrCGIS đã nói:

    Em xin chào các anh, hiện tại em có file địa chính có block thông tin thửa bao gồm: số thửa, quy hoạch, diện tích, line .... giờ em muốn scale block này làm sao để nó có thể nằm lọt trong thửa với tâm của nó đặt tại đầu line màu xanh ngay điểm block màu vàng, mong muốn của em là có được lisp scale hoàn loạt đối tượng để block thông tin lọt vào trong thửa để lấy dữ liệu. Mong các anh giúp

    Em có để file cad mẫu và hình minh họa ạ em xin cảm ơn.

    File mẫu: 

    Ban đầu: 

    image.png.bdce08cfb92ed7d6d5189b9a48273d8d.png

    Kết quả: 

    image.png.54210069b706600c460631b91299dc6b.png

     

    Drawing4.dwg

    Gửi bạn nhé 

    (defun C:SCBL (/ tl obj blkname pt p1 p2 ssbl doc blkname lay mau)
(setq tl (getreal "\nNhap ti le scale:"))
(princ "\nChon cac Blocks...")
(if (ssget '((0 . "INSERT")));(2 . "CENTRD_1")
(progn
(vlax-for obj (vla-get-ActiveSelectionSet (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))))
(setq blkname (vla-get-Name obj))
	;chuyen doi tuong trong BL thanh mau layer
(if (= blkname "CENTRD_1")
(progn
(setq pt (vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint obj))))
(setq p1 (polar pt (/ (* 3 pi) 4) 5))
(setq p2 (polar pt (/ pi -4) 5))
(setq ssbl (ssget "C" p1 p2 '((0 . "INSERT") (-4 . "<NOT") (2 . "CENTRD_1") (-4 . "NOT>"))))
(command "scale" ssbl "" pt tl)
)
)
)
)
)
)

     

    • Vote tăng 1

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

    23 giờ trước, nguyenvinh5779 đã nói:

    Xin cám on bạn @huunhantvxdts:

    Bạn cho chỉ thêm cho mình : Mình  muốn lấy 2 số thập phân  thì phải chỉnh như thế nào !

    Xin cám on ban nhieu .

    Gửi bạn 

    (defun C:fd( / ss L e #h tongcd ent txtObj)
(vl-load-com)
(setq ent (car (entsel "\nChon text lay chieu cao")))
(setq #h (cdr (assoc 40 (entget ent))))
(defun Length1(e) (/ (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)) 1000))
(or ans (setq ans 1))
(prompt "\nChon cac duong tính chieu dai")
(setq tongcd (apply '+ (mapcar 'Length1 (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget (list (cons 0 "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")))))))))
;(getvar "dimlfac")
(setq L (strcat "L : " (vl-princ-to-string (rtos (* (getvar "dimlfac") tongcd) 2 2)) "m"))
   (setq
   ans (cond ((getint (strcat "\nPhuong an nhap ket qua < " (itoa ans) " > :")))(ans))
   txtObj (cond     ((= ans 1) (vlax-ename->vla-object (car (entsel "\nChon text ghi ket qua :"))))
                   (T (vla-addtext (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) L (vlax-3d-point (getpoint "\n Chon diem nhap ket qua" )) #h ))))
(vla-put-TextString txtObj L)
(vla-put-Height txtObj #h)
(princ))

     

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

    3 giờ trước, nguyenvinh5779 đã nói:

    Xin cám ơn bạn

    nhưng sao không dược bạn oi !

    nho bạn chỉnh giúp  !

    có thể chỉnh chiều cao chữ bằng cách chọn 02 điểm trên màn hình khong ?

    xin cám on ban !

    (defun C:fd( / ss L e #h)
    (vl-load-com)
    (setq ent (car (entsel "\nChon text lay chieu cao text")))
    (setq #h (cdr (assoc 40 (entget ent))))
    (defun Length1(e) (/ (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)) 1000))
    (or ans (setq ans 1))
    (setq
       #h 200
       L (strcat "L : "
       (vl-princ-to-string (* (getvar "dimlfac") (apply '+
           (mapcar 'Length1 (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget (list (cons 0 "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")))))))))) "m"))
       (setq
       ans (cond ((getint (strcat "\nPhuong an nhap ket qua < " (itoa ans) " > :")))(ans))
       txtObj (cond     ((= ans 1) (vlax-ename->vla-object (car (entsel "\nChon text ghi ket qua :"))))
                       (T (vla-addtext (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) L (vlax-3d-point (getpoint "\n Chon diem nhap ket qua" )) #h ))))
    (vla-put-TextString txtObj L)
    (vla-put-Height txtObj #h)
    (princ))

    mình thấy bạn sửa ở trên là xoa #h rồi nên mình chỉ nói thay phần trên, bạn lại thêm #h phía dưới

    Sửa lại cho bạn lấy chiểu cao chữ theo chữ mẫu 

    (defun C:fd( / ss L e #h)
(vl-load-com)
(setq ent (car (entsel "\nChon text lay chieu cao text")))
(setq #h (cdr (assoc 40 (entget ent))))
(defun Length1(e) (/ (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)) 1000))
(or ans (setq ans 1))
(setq
   L (strcat "L : "
   (vl-princ-to-string (* (getvar "dimlfac") (apply '+
       (mapcar 'Length1 (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget (list (cons 0 "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")))))))))) "m"))
   (setq
   ans (cond ((getint (strcat "\nPhuong an nhap ket qua < " (itoa ans) " > :")))(ans))
   txtObj (cond     ((= ans 1) (vlax-ename->vla-object (car (entsel "\nChon text ghi ket qua :"))))
                   (T (vla-addtext (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) L (vlax-3d-point (getpoint "\n Chon diem nhap ket qua" )) #h ))))
(vla-put-TextString txtObj L)
(vla-put-Height txtObj #h)
(princ))

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

    26 phút trước, nguyenvinh5779 đã nói:

    nhờ bạn giúp dùm mình lisp này !

    mình muốn chiều cao chữ bang cach chọn trên màn hình !

    xin cám on ban !

    (defun C:fd( / ss L e #h)
    (setvar 'textsize
    (cond ((getdist (strcat "\nSpecify Area text height by two points on screen : ")))
    ((getvar 'textsize))
    )
    )
    (vl-load-com)
    (defun Length1(e) (/ (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)) 1000))
    (or ans (setq ans 1))
    (setq
          L (strcat "L : "
       (vl-princ-to-string (* (getvar "dimlfac") (apply '+
           (mapcar 'Length1 (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget (list (cons 0 "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")))))))))) "m"))
       (setq
       ans (cond ((getint (strcat "\nPhuong an nhap ket qua < " (itoa ans) " > :")))(ans))
       txtObj (cond     ((= ans 1) (vlax-ename->vla-object (car (entsel "\nChon text ghi ket qua :"))))
                       (T (vla-addtext (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) L (vlax-3d-point (getpoint "\n Chon diem nhap ket qua" )) #h ))))
    (vla-put-TextString txtObj L)
    (vla-put-Height txtObj #h)
    (princ))

    thay phần này nhé

    (setvar 'textsize
    (cond ((getdist (strcat "\nSpecify Area text height by two points on screen : ")))
    ((getvar 'textsize))
    )
    )

    bằng

    (setq ent (car (entsel "\nChon text lay cao do")))
    (setq #h (cdr (assoc 40 (entget ent))))

     

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

    1 giờ} trướ}c, thevien104 đã nói:

    Pick Pline Tim Tuyen
    Select objects: Specify opposite corner: 1 found
    Select objects:
    ; error: no function definition: ACET-SS-TO-LIST

    Thiếu hàm bạn nhé: 

    (defun acet-ss-to-list (ss / n e l)
(setq n (sslength ss))
(while (setq e (ssname ss (setq n (1- n))))
(setq l (cons  e l))
)
)

     

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

    Vào lúc 17/2/2022 tại 18:32, emhoccad đã nói:

    Chào các bác,

    E cần lisp thống kê danh sách các Text trong bản vẽ thành 1 danh sách như bảng dưới.

     

    Ví dụ: N1,N2,N3,vv...

     

    image.png.c144bf96c964bd47a044c570ee8bbcf5.png

     

    Cảm ơn các bác^^

    thong ke text.dwg

    Gửi bạn!!!! 

    (defun C:TKTE(/ acdoc acspc lsttthe lsttk nd lstin point point2 p1 p2 pointt cur_lay oldos)
(setq cur_lay (getvar "clayer" ))
(setq oldos (getvar "OSMODE"))
(setvar "osmode" 0)
(setvar "cmdecho" 0)
(command "UNDO" "Be")
(vl-load-com)
;;;;;;;;;;;;;;;;;;;;;
(setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object)) 
		acspc (vlax-get-property acdoc (if (= 1 (getvar 'CVPORT)) 'paperspace 'modelspace)))
(prompt "\nChon TEXT thong ke")
(setq lsttthe (ST:SS->List-Vla (ssget '((0 . "TEXT")))))
(setq lsttk nil)
(foreach ent lsttthe
;(setq ent (vlax-ename->vla-object (car (entsel))))
(setq nd (vlax-get-property ent 'TextString))
(setq lsttk (append (list nd) lsttk))
)
(setq lstin (LM:CountItems lsttk))
(setq lstin  (vl-sort lstin '(lambda (x y) (< (car x) (car y)))))
(setq point (getpoint "/nPick diem dat"))
(setq point2 (polar point 0 1.38))
(command "Line" point point2 "")
(foreach ent lstin
(setq p1 (polar point (/ pi -2) 0.36))
(setq p2 (polar point2 (/ pi -2) 0.36))
(command "Line" p1 p2 "")
(command "Line" point p1 "")
(command "Line" point2 p2 "")
(command "Line" (polar point 0 (/ 1.38 2)) (polar p1 0 (/ 1.38 2)) "")
(setq pointt (polar (polar p1 0 0.1247) (/ pi 2) 0.0745))
(vla-addtext acspc (car ent) (vlax-3d-point pointt) 0.18)
(setq pointt (polar pointt 0 0.8305))
(vla-addtext acspc (cdr ent) (vlax-3d-point pointt) 0.18)
(setq point p1)
(setq point2 p2)
)
;;;;;;;;;;;;;;;;;;;;
(command "UNDO" "End")
(setvar "clayer" cur_lay)
(setvar "osmode" oldos)
(setvar "CMDECHO" 1)
(princ)
)
(defun LM:CountItems ( l / c l r x )
    (while l
        (setq x (car l)
              c (length l)
              l (vl-remove x (cdr l))
              r (cons (cons x (- c (length l))) r)
        )
    )
    (reverse r)
)
(defun ST:SS->List-Vla (ss / n e l)
(setq n (sslength ss))
(while (setq e (ssname ss (setq n (1- n))))
(setq l (cons (vlax-ename->vla-object e) l))
)
)

     

    • Like 1
×