Chuyển đến nội dung
Diễn đàn CADViet
  • Thông báo

    • Nguyen Hoanh

      CADViet đã hoàn tất nâng cấp   14/09/2017

      Chào các bạn, CADViet đã hoàn tất việc nâng cấp lên phiên bản mới. Tất cả các chức năng đã hoạt động theo kỳ vọng của ban quản trị. Nếu có vấn đề gì cần phản hồi, các bản post ở đây nhé: Trân trọng, Nguyễn Hoành.
Đăng nhập để thực hiện theo  
vanmanh192hd

[Lisp] Thiết Kế Khuôn Tự Động (Tạo Rãnh Dầu)

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

Chào tất cả anh em

Mình muốn tạo một lisp tạo nhanh rãnh dầu chỉ bằng 2 lần click chuột

yêu cầu bài toán và thông sô mình đã thể hiện trên hình ảnh. rất mong nhận được sự giúp đở của mọi người

Bai%20Toan%204_zpsjuwakis2.jpg

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
Bee    108

Chào tất cả anh em

Mình muốn tạo một lisp tạo nhanh rãnh dầu chỉ bằng 2 lần click chuột

yêu cầu bài toán và thông sô mình đã thể hiện trên hình ảnh. rất mong nhận được sự giúp đở của mọi người

Bai%20Toan%204_zpsjuwakis2.jpg

Lisp cho nhanh nhỉ ^_^

 

https://drive.google.com/file/d/0B-3fZ45DSr_XOFBLRHptZ0UtNmM/view?usp=sharing

  • Vote tăng 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
ketxu    2.649

Sao của bác Mạnh ket thấy chỉ có preview thôi nhỉ ^^ Ấn j để ra kết quả ta

Chưa hợp lý với n = 1 và UCS khác world 

Ps : code 28k chắc bác ôm LM osnap của Grread + LM:Grtext vào hén :)

 

- Của bác Bee thì test thấy chỉ tạo được nửa dưới đường bao ngoài. Hay cad của ket có vấn đề nhỉ @@

Bai%204%20-8-22-2014-12.22.50%20PM11-10-

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
Bee    108

Sao của bác Mạnh ket thấy chỉ có preview thôi nhỉ ^^ Ấn j để ra kết quả ta

Chưa hợp lý với n = 1 và UCS khác world 

Ps : code 28k chắc bác ôm LM osnap của Grread + LM:Grtext vào hén :)

 

- Của bác Bee thì test thấy chỉ tạo được nửa dưới đường bao ngoài. Hay cad của ket có vấn đề nhỉ @@

Bai%204%20-8-22-2014-12.22.50%20PM11-10-

CAD ketxu bao nhiêu vậy. Mình test file vlx thì vẫn đúng khi xoay usc và một số kiểu khác. Load lại và test lại xem nào ketxu.!

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
Bee    108

Sao của bác Mạnh ket thấy chỉ có preview thôi nhỉ ^^ Ấn j để ra kết quả ta

Chưa hợp lý với n = 1 và UCS khác world 

Ps : code 28k chắc bác ôm LM osnap của Grread + LM:Grtext vào hén :)

  Thiếu case (= (car gr) 3)) ^_^ là ra kq. ;)

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
quocmanh04tt    385

Sao của bác Mạnh ket thấy chỉ có preview thôi nhỉ ^^ Ấn j để ra kết quả ta

Chưa hợp lý với n = 1 và UCS khác world 

Ps : code 28k chắc bác ôm LM osnap của Grread + LM:Grtext vào hén :)

 

Chỉ biểu diễn thôi mà...! (dung lượng lớn nằm ở chỗ Grread và Grtext).

 

  Thiếu case (= (car gr) 3)) ^_^ là ra kq. ;)

Case tương đối đầy đủ, nhưng không có thực thi - Vì chỉ là Grread.

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
ketxu    2.649

@Bee : Ket dùng 2008 và 2017. Lỗi UCS là code biểu diễn của bác Mạnh, vì chắc chưa trans vector, k phải ở code bác. Các bác toàn đóng vào nên ket cũng k học được nhiều :D

 

- Bài này với đường biên các bác dùng vla-boolean union với Region bên ngoài (nếu n >1) sẽ thuận tiện hơn ạ

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
quocmanh04tt    385

Code theo gợi ý của ketxu:

Kết quả chỉ 1 đối tượng Region

(defun c:tt (/ Circle MakeRegion ang cen cir dia dis n pt1 pt2 reg lst-reg lst-reg1 d)

(defun Circle (cen rad) (entmakex (list (cons 0 "CIRCLE") (cons 10 cen) (cons 40 rad))))

(defun MakeRegion (en)

(if (vlax-curve-isclosed en)

(car (vlax-invoke (vlax-get-property (vla-get-activedocument (vlax-get-acad-object))

(if (= 1 (getvar 'CVPORT))

'Paperspace

'Modelspace))

'AddRegion

(list (vlax-ename->vla-object en))))))

(or (> (getvar 'USERR1) 0) (setvar 'USERR1 6))

(if (and (setq dia (cond ((getreal (strcat "Diameter <" (rtos (getvar 'USERR1)) ">: ")))

((getvar 'USERR1))))

(setvar 'USERR1 dia)

(setq pt1 (getpoint "\nFirst point: "))

(setq pt2 (getpoint "\nSecond point: " pt1)))

(progn (setq pt1 (trans pt1 1 0)

pt2 (trans pt2 1 0)

ang (angle pt1 pt2)

dis (distance pt1 pt2))

(if (> dis (1+ dia))

(progn (setq n -1

d 0)

;;(setq d (/ (- dis (* (1+ dia) (1- (fix (/ dis (1+ dia)))))) 2))

(repeat (fix (/ dis (1+ dia)))

(setq cen (polar pt1 ang (+ d (* (setq n (1+ n)) (1+ dia)))))

(setq reg1 (MakeRegion (setq cir (Circle cen (/ dia 2)))))

(setq lst-reg1 (cons reg1 lst-reg1))

(and cir (entdel cir))

(setq reg (MakeRegion (setq cir (Circle cen (/ (+ dia 2) 2)))))

(and cir (entdel cir))

(setq lst-reg (cons reg lst-reg)))

(setq reg (car lst-reg))

(foreach x (cdr lst-reg) (vla-Boolean reg acUnion x) (setq reg (vlax-ename->vla-object (entlast))))))

(foreach x lst-reg1 (vla-Boolean reg acSubtraction x) (setq reg (vlax-ename->vla-object (entlast))))))

(princ))

  • Vote tăng 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
Bee    108

@Bee : Ket dùng 2008 và 2017. Lỗi UCS là code biểu diễn của bác Mạnh, vì chắc chưa trans vector, k phải ở code bác. Các bác toàn đóng vào nên ket cũng k học được nhiều :D

 

- Bài này với đường biên các bác dùng vla-boolean union với Region bên ngoài (nếu n >1) sẽ thuận tiện hơn ạ

Có tí code nghịch vui. Bác nào rảnh hoàn thiện nốt cho ra kết quả ^_^

(DEFUN c:test  (/ *error* cen d gr loop p1 foo foo_1 line circle1 circle2 lst_1 lst_2)
  (DEFUN *error*  (msg)
    (MAPCAR '(LAMBDA (o) (VLA-DELETE (VLAX-ENAME->VLA-OBJECT o))) lst_1)
    (MAPCAR '(LAMBDA (o) (VLA-DELETE (VLAX-ENAME->VLA-OBJECT o))) lst_2)
    (AND line
         (ENTDEL line)
         (SETQ line nil)
         ) ;and
    (OR (= msg "function cancelled")
        (PRINC (STRCAT "\nerror: " msg))
        )
    (PRINC)
    )
  (SETQ cen  (GETPOINT "\nChon diem 1: ")
        loop T
        )
  (SETQ d (GETREAL "\nChon duong kinh: "))
  (IF (NOT d)
    (SETQ d 6)
    )
  (WHILE (AND (SETQ gr (GRREAD T 12 0)) loop)
    (COND
      ((= (CAR gr) 5)
       (MAPCAR '(LAMBDA (o) (VLA-DELETE (VLAX-ENAME->VLA-OBJECT o))) lst_1)
       (MAPCAR '(LAMBDA (o) (VLA-DELETE (VLAX-ENAME->VLA-OBJECT o))) lst_2)
       (SETQ lst_1 nil
             lst_2 nil)
       (AND line
            (ENTDEL line)
            (SETQ line nil)
            ) ;and
       (SETQ p1 (CADR gr))
       (SETQ foo (/ (DISTANCE p1 cen) d))
       (SETQ foo_1 (ATOI (RTOS foo 2 2)))
       (IF (> foo_1 1)
         (PROGN
           (SETQ lst_1 nil
                 lst_2 nil)

           (SETQ line (ENTMAKEX
                        (LIST
                          '(0 . "LINE")
                          '(100 . "AcDbEntity")
                          '(100 . "AcDbLine")
                          '(62 . 6)
                          (CONS 11 p1)
                          (CONS 10 cen)
                          )
                        ) ;entmakex_line
                 )

           (SETQ circle1 (ENTMAKEX
                           (LIST
                             '(0 . "CIRCLE")
                             '(100 . "AcDbEntity")
                             '(100 . "AcDbCircle")
                             '(62 . 6)
                             (CONS 40 (/ d 2))
                             (CONS 10 cen)
                             )
                           ) ;entmakex_circle1
                 circle2 (ENTMAKEX
                           (LIST
                             '(0 . "CIRCLE")
                             '(100 . "AcDbEntity")
                             '(100 . "AcDbCircle")
                             '(62 . 6)
                             (CONS 40 (+ (/ d 2) 1))
                             (CONS 10 cen)
                             )
                           ) ;entmakex_circle2
                 ) ;setq
           (SETQ lst_1 (CONS circle1 lst_1))
           (SETQ lst_2 (CONS circle2 lst_2))

           (SETQ p1a (POLAR cen (ANGLE cen p1) (+ d 1)))
           (REPEAT (- foo_1 3)
             (SETQ circle1 (ENTMAKEX
                             (LIST
                               '(0 . "CIRCLE")
                               '(100 . "AcDbEntity")
                               '(100 . "AcDbCircle")
                               '(62 . 6)
                               (CONS 40 (/ d 2))
                               (CONS 10 p1a)
                               )
                             ) ;entmakex_circle1
                   circle2 (ENTMAKEX
                             (LIST
                               '(0 . "CIRCLE")
                               '(100 . "AcDbEntity")
                               '(100 . "AcDbCircle")
                               '(62 . 6)
                               (CONS 40 (+ (/ d 2) 1))
                               (CONS 10 p1a)
                               )
                             ) ;entmakex_circle2
                   ) ;setq
             (SETQ p1a (POLAR p1a (ANGLE cen p1) (+ d 1)))

             (SETQ lst_1 (CONS circle1 lst_1))
             (SETQ lst_2 (CONS circle2 lst_2))
             ) ;repeat
           )
         ) ;if
       )
      ((= (CAR gr) 3) (SETQ loop nil))
      (T
       (MAPCAR '(LAMBDA (o) (VLA-DELETE (VLAX-ENAME->VLA-OBJECT o))) lst_1)
       (MAPCAR '(LAMBDA (o) (VLA-DELETE (VLAX-ENAME->VLA-OBJECT o))) lst_2)
       (SETQ lst_1 nil
             lst_2 nil)
       (AND line
            (ENTDEL line)
            (SETQ line nil)
            ) ;and
       (SETQ loop nil))
      )
    )
  (PRINC)
  )

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
quocmanh04tt    385

Thêm hàm sau vào case: (= (car gr) 3) là ra KQ.

(defun action (/ MakeRegion reg lst lst1)

(defun MakeRegion (en)

(if (vlax-curve-isclosed en)

(car (vlax-invoke (vlax-get-property (vla-get-activedocument (vlax-get-acad-object))

(if (= 1 (getvar 'CVPORT))'Paperspace 'Modelspace))'AddRegion

(list (vlax-ename->vla-object en))))))

(foreach x lst_1 (setq reg (MakeRegion x)) (setq lst1 (cons reg lst1)) (entdel x))

(foreach x lst_2 (setq reg (MakeRegion x)) (setq lst (cons reg lst)) (entdel x))

(setq reg (car lst))

(foreach x (cdr lst) (vla-Boolean reg acUnion x) (setq reg (vlax-ename->vla-object (entlast))))

(foreach x lst1 (vla-Boolean reg acSubtraction x) (setq reg (vlax-ename->vla-object (entlast))))

(and line (entdel line))

(princ))

P/s:

- Thiếu các case: Osnap mode (F3), Ortho Mode (F8) và Shift + RightClick...

- UCS khác World.

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

Đăng nhập để thực hiện theo  

×