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

[Yêu cầu] Nhờ tiền bối viết giùm lisp chuyển hình tròn thành đa giác

Bởi hawking312 , trong AutoLisp

Các bài được khuyến nghị

hawking312    1

hawking312
Đã đăng

Như tiêu đề ạ, em có việc muốn chuyển các đường cong hoặc hình tròn thành các đa giác. Em thấy có app tương tự của Autodesk nhưng có tính phí, mong các tiền bối giúp đỡ. 

Link Autodesk:
CIR2VECT – Circle to Vectored polygon

ARCVECT – Arc, PolyArc and Circle Vectorizer

Video ví dụ

https://www.youtube.com/watch?v=JZJTSI2N66E

Chia sẻ bài đăng này

Liên kết tới bài đăng
Chia sẻ trên các trang web khác

thiep    365

thiep
Đã đăng
46 phút trước, hawking312 đã nói:

Như tiêu đề ạ, em có việc muốn chuyển các đường cong hoặc hình tròn thành các đa giác. Em thấy có app tương tự của Autodesk nhưng có tính phí, mong các tiền bối giúp đỡ. 

Link Autodesk:
CIR2VECT – Circle to Vectored polygon

ARCVECT – Arc, PolyArc and Circle Vectorizer

Video ví dụ

https://www.youtube.com/watch?v=JZJTSI2N66E

Lisp này mình mới vừa đăng cách nay gần 1 tháng, chịu khó tìm là có: 

;;; lisp convert curve: ARC, CIRCLE, ELLIPSE, SPLINE to Lwpolyline
;;;                  by Trân Thiêp  0918841230                              
(defun DXF (code en) (cdr (assoc code (entget en))))

(defun c:c2pl (/ ss lstpo obj)
    (command "undo" "be")
    (and (not ACET-GEOM-SPLINE-POINT-LIST)
         (findfile "acetutil.arx")
        (arxload (findfile "acetutil.arx") "Failed to Load Express Tools")
    )
    (defun curve->Lstpo (ent num / LL_UR)
        (setq LL_UR (acet-ent-geomextents ent))
        (ACET-GEOM-SPLINE-POINT-LIST ent
                                     (/ (distance (car LL_UR) (cadr LL_UR)) num)
        )
    )
    (acet-error-init '(("cmdecho" 0 "osmode" 0 "PLINEGEN" 1) 1 (acet-ui-status)))
    (acet-ui-status "\nSelect curves to convert it into Lwpolylines" "PROMPT")
    (while (NOT (setq ss (ssget '((0 . "ARC,CIRCLE,ELLIPSE,SPLINE")))))
        (acet-ui-status "\nSelect arn't right, please select curves again" "PROMPT")
    )
    (acet-ui-status)
    (mapcar '(lambda (x)
                 (cond ((wcmatch (acet-dxf 0 (entget x)) "ARC,CIRCLE,ELLIPSE")
                        (acet-Lwpline-make (list (curve->Lstpo x 2020)))
                       )
                       (T (acet-Lwpline-make (list (curve->Lstpo x 3000))))
                 )
                 (setq obj (vlax-ename->vla-object (entlast)))
                 (if (dxf 6 x)(Vla-put-Linetype obj (dxf 6 x)))
                 (if (dxf 48 x)
                     (Vla-put-LinetypeScale obj (dxf 48 x))
                 )
                 (Vla-put-LinetypeGeneration obj :vlax-true)
                 (Vla-put-layer obj (dxf 8 x))
                 (if (setq col (dxf 62 x))
                     (Vla-put-color obj col)
                     (Vla-put-color obj 256)
                 )
                 (entdel x)
             )
            (acet-ss-to-list ss)
    )
    (acet-error-restore)
    (command "undo" "en")
    (princ "\nOk")
)

 

  • Like 1

Chia sẻ bài đăng này

Liên kết tới bài đăng
Chia sẻ trên các trang web khác

hawking312    1

hawking312
Đã đăng
Vào lúc 29/4/2020 tại 14:52, thiep đã nói:

Lisp này mình mới vừa đăng cách nay gần 1 tháng, chịu khó tìm là có: 


;;; lisp convert curve: ARC, CIRCLE, ELLIPSE, SPLINE to Lwpolyline
;;                  by Trân Thiêp  0918841230                              
(defun DXF (code en) (cdr (assoc code (entget en))))

(defun c:c2pl (/ ss lstpo obj)
    (command "undo" "be")
    (and (not ACET-GEOM-SPLINE-POINT-LIST)
         (findfile "acetutil.arx")
        (arxload (findfile "acetutil.arx") "Failed to Load Express Tools")
    )
    (defun curve->Lstpo (ent num / LL_UR)
        (setq LL_UR (acet-ent-geomextents ent))
        (ACET-GEOM-SPLINE-POINT-LIST ent
                                     (/ (distance (car LL_UR) (cadr LL_UR)) num)
        )
    )
    (acet-error-init '(("cmdecho" 0 "osmode" 0 "PLINEGEN" 1) 1 (acet-ui-status)))
    (acet-ui-status "\nSelect curves to convert it into Lwpolylines" "PROMPT")
    (while (NOT (setq ss (ssget '((0 . "ARC,CIRCLE,ELLIPSE,SPLINE")))))
        (acet-ui-status "\nSelect arn't right, please select curves again" "PROMPT")
    )
    (acet-ui-status)
    (mapcar '(lambda (x)
                 (cond ((wcmatch (acet-dxf 0 (entget x)) "ARC,CIRCLE,ELLIPSE")
                        (acet-Lwpline-make (list (curve->Lstpo x 2020)))
                       )
                       (T (acet-Lwpline-make (list (curve->Lstpo x 3000))))
                 )
                 (setq obj (vlax-ename->vla-object (entlast)))
                 (if (dxf 6 x)(Vla-put-Linetype obj (dxf 6 x)))
                 (if (dxf 48 x)
                     (Vla-put-LinetypeScale obj (dxf 48 x))
                 )
                 (Vla-put-LinetypeGeneration obj :vlax-true)
                 (Vla-put-layer obj (dxf 8 x))
                 (if (setq col (dxf 62 x))
                     (Vla-put-color obj col)
                     (Vla-put-color obj 256)
                 )
                 (entdel x)
             )
            (acet-ss-to-list ss)
    )
    (acet-error-restore)
    (command "undo" "en")
    (princ "\nOk")
)

 

Cảm ơn bác đã giúp đỡ, có thể bỏ bảng thông báo này mà thay bằng dòng command phía dưới cho dễ chịu và tăng tốc hơn được không bác, xin cảm ơn bác nhiều.

image.png.f10486f5badc49867bcb9adb520ce2fc.png

Chia sẻ bài đăng này

Liên kết tới bài đăng
Chia sẻ trên các trang web khác

thiep    365

thiep
Đã đăng
1 giờ} trướ}c, hawking312 đã nói:

Cảm ơn bác đã giúp đỡ, có thể bỏ bảng thông báo này mà thay bằng dòng command phía dưới cho dễ chịu và tăng tốc hơn được không bác, xin cảm ơn bác nhiều.

  

;;;   LISP convert ARC, CIRCLE, ELLIPSE, SPLINE to LWPOLYLINE
;;;   By Trân Thiêp 0918.841230
;;;       05/2020.
(defun curve->Lstpo (ent num / LL_UR )
    (setq LL_UR (acet-ent-geomextents ent))
    (ACET-GEOM-SPLINE-POINT-LIST ent
                                 (/ (distance (car LL_UR) (cadr LL_UR)) num)
    )
)
(defun c:c2pl (/ ss lstpo obj col Ltype LtypeScale)
    (command "undo" "be")
    (acet-error-init '(("cmdecho" 0 "osmode" 0) 0))
    (or ucshold_thiep (setq ucshold_thiep (acet-ucs-get nil)))
    (acet-ucs-cmd '("w"))
    (PROMPT "\nSelect curves to convert it into Lwpolylines" )
    (while (NOT (setq ss (ssget '((0 . "ARC,CIRCLE,ELLIPSE,SPLINE")))))
        (PROMPT "\nSelect arn't right, please select curves again" )
    )
    (mapcar '(lambda (x)
                 (setq eng (entget x))
                 (cond ((wcmatch (acet-dxf 0 eng) "ARC,CIRCLE,ELLIPSE")
                        (acet-Lwpline-make (list (curve->Lstpo x 2020)))
                       )
                       (T (acet-Lwpline-make (list (curve->Lstpo x 3000))))
                 )
                 (setq obj (vlax-ename->vla-object (entlast)))
                 (if (setq Ltype (acet-dxf 6 eng)) (Vla-put-Linetype obj Linetype))
                 (if (setq LtypeScale (acet-dxf 48 eng)) (Vla-put-LinetypeScale obj LtypeScale))
                 (Vla-put-LinetypeGeneration obj :vlax-true)
                 (Vla-put-layer obj (acet-dxf 8 eng))
                 (if (setq col (acet-dxf 62 eng)) (Vla-put-color obj col))
                 (entdel x)
             )
            (acet-ss-to-list ss)
    )
    (acet-ucs-set ucshold_thiep)
    (acet-error-restore)
    (command "undo" "en")
    (princ "\nOk")
    (princ) 
)

Thử lại xem bạn. Nhân tiện fix luôn 1 lỗi nhỏ về color của đối tượng.

Chia sẻ bài đăng này

Liên kết tới bài đăng
Chia sẻ trên các trang web khác

12.12.2012    0

12.12.2012
Đã đăng
20 giờ trước, thiep đã nói: 

;;;   LISP convert ARC, CIRCLE, ELLIPSE, SPLINE to LWPOLYLINE
;;   By Trân Thiêp 0918.841230
;;       05/2020.
(defun curve->Lstpo (ent num / LL_UR )
    (setq LL_UR (acet-ent-geomextents ent))
    (ACET-GEOM-SPLINE-POINT-LIST ent
                                 (/ (distance (car LL_UR) (cadr LL_UR)) num)
    )
)
(defun c:c2pl (/ ss lstpo obj col Ltype LtypeScale)
    (command "undo" "be")
    (acet-error-init '(("cmdecho" 0 "osmode" 0) 0))
    (or ucshold_thiep (setq ucshold_thiep (acet-ucs-get nil)))
    (acet-ucs-cmd '("w"))
    (PROMPT "\nSelect curves to convert it into Lwpolylines" )
    (while (NOT (setq ss (ssget '((0 . "ARC,CIRCLE,ELLIPSE,SPLINE")))))
        (PROMPT "\nSelect arn't right, please select curves again" )
    )
    (mapcar '(lambda (x)
                 (setq eng (entget x))
                 (cond ((wcmatch (acet-dxf 0 eng) "ARC,CIRCLE,ELLIPSE")
                        (acet-Lwpline-make (list (curve->Lstpo x 2020)))
                       )
                       (T (acet-Lwpline-make (list (curve->Lstpo x 3000))))
                 )
                 (setq obj (vlax-ename->vla-object (entlast)))
                 (if (setq Ltype (acet-dxf 6 eng)) (Vla-put-Linetype obj Linetype))
                 (if (setq LtypeScale (acet-dxf 48 eng)) (Vla-put-LinetypeScale obj LtypeScale))
                 (Vla-put-LinetypeGeneration obj :vlax-true)
                 (Vla-put-layer obj (acet-dxf 8 eng))
                 (if (setq col (acet-dxf 62 eng)) (Vla-put-color obj col))
                 (entdel x)
             )
            (acet-ss-to-list ss)
    )
    (acet-ucs-set ucshold_thiep)
    (acet-error-restore)
    (command "undo" "en")
    (princ "\nOk")
    (princ) 
)

Thử lại xem bạn. Nhân tiện fix luôn 1 lỗi nhỏ về color của đối tượng.

Mình bị lỗi này sửa sao vậy bạn? Tks!

Command: C2PL
undo Current settings: Auto = Off, Control = All, Combine = Yes, Layer = Yes
Enter the number of operations to undo or [Auto/Control/BEgin/End/Mark/Back] <1>: be
Command: ; error: no function definition: ACET-ERROR-INIT

Chia sẻ bài đăng này

Liên kết tới bài đăng
Chia sẻ trên các trang web khác

thanhduan2407    272

thanhduan2407
Đã đăng
4 giờ trước, 12.12.2012 đã nói:

Mình bị lỗi này sửa sao vậy bạn? Tks!

Command: C2PL
undo Current settings: Auto = Off, Control = All, Combine = Yes, Layer = Yes
Enter the number of operations to undo or [Auto/Control/BEgin/End/Mark/Back] <1>: be
Command: ; error: no function definition: ACET-ERROR-INIT

Bạn chưa cài full Autocad. Tức là Cad phải có menu Express.

Chia sẻ bài đăng này

Liên kết tới bài đăng
Chia sẻ trên các trang web khác

thiep    365

thiep
Đã đăng
Vào lúc 10/6/2020 tại 12:21, 12.12.2012 đã nói:

 

 

Cài rồi bạn ơi

 

Bạn thêm dòng này vào đầu dòng hay cuối dòng lisp:

(vl-load-com)

Ủa mà lisp trước bạn chạy ok mà?

  • Like 1

Chia sẻ bài đăng này

Liên kết tới bài đăng
Chia sẻ trên các trang web khác

hawking312    1

hawking312
Đã đăng
Vào lúc 9/6/2020 tại 10:50, thiep đã nói: 

;;;   LISP convert ARC, CIRCLE, ELLIPSE, SPLINE to LWPOLYLINE
;;   By Trân Thiêp 0918.841230
;;       05/2020.
(defun curve->Lstpo (ent num / LL_UR )
    (setq LL_UR (acet-ent-geomextents ent))
    (ACET-GEOM-SPLINE-POINT-LIST ent
                                 (/ (distance (car LL_UR) (cadr LL_UR)) num)
    )
)
(defun c:c2pl (/ ss lstpo obj col Ltype LtypeScale)
    (command "undo" "be")
    (acet-error-init '(("cmdecho" 0 "osmode" 0) 0))
    (or ucshold_thiep (setq ucshold_thiep (acet-ucs-get nil)))
    (acet-ucs-cmd '("w"))
    (PROMPT "\nSelect curves to convert it into Lwpolylines" )
    (while (NOT (setq ss (ssget '((0 . "ARC,CIRCLE,ELLIPSE,SPLINE")))))
        (PROMPT "\nSelect arn't right, please select curves again" )
    )
    (mapcar '(lambda (x)
                 (setq eng (entget x))
                 (cond ((wcmatch (acet-dxf 0 eng) "ARC,CIRCLE,ELLIPSE")
                        (acet-Lwpline-make (list (curve->Lstpo x 2020)))
                       )
                       (T (acet-Lwpline-make (list (curve->Lstpo x 3000))))
                 )
                 (setq obj (vlax-ename->vla-object (entlast)))
                 (if (setq Ltype (acet-dxf 6 eng)) (Vla-put-Linetype obj Linetype))
                 (if (setq LtypeScale (acet-dxf 48 eng)) (Vla-put-LinetypeScale obj LtypeScale))
                 (Vla-put-LinetypeGeneration obj :vlax-true)
                 (Vla-put-layer obj (acet-dxf 8 eng))
                 (if (setq col (acet-dxf 62 eng)) (Vla-put-color obj col))
                 (entdel x)
             )
            (acet-ss-to-list ss)
    )
    (acet-ucs-set ucshold_thiep)
    (acet-error-restore)
    (command "undo" "en")
    (princ "\nOk")
    (princ) 
)

Thử lại xem bạn. Nhân tiện fix luôn 1 lỗi nhỏ về color của đối tượng.

Cảm ơn bác Thiệp tuyệt vời nhé, ưng ý quá luôn, nay mới vào diễn đàn.

  • Like 1

Chia sẻ bài đăng này

Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Tạo một tài khoản hoặc đăng nhập để nhận xét

Bạn cần phải là một thành viên để lại một bình luận

Tạo tài khoản

Đăng ký một tài khoản mới trong cộng đồng của chúng tôi. Điều đó dễ mà.

Đăng ký tài khoản mới

Đăng nhập

Bạn có sẵn sàng để tạo một tài khoản ? Đăng nhập tại đây.

Đăng nhập ngay
Về Đầu Trang AutoLisp
×