Đến nội dung


Hình ảnh
* * * * * 1 Bình chọn

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


  • Please log in to reply
17 replies to this topic

#1 vanmanh192hd

vanmanh192hd

    biết vẽ line

  • Members
  • PipPip
  • 23 Bài viết
Điểm đánh giá: -4 (bình thường)

Đã gửi 10 October 2016 - 12:29 PM

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


  • 0

#2 Bee

Bee

    biết lệnh extend

  • Members
  • PipPipPip
  • 198 Bài viết
Điểm đánh giá: 68 (tàm tạm)

Đã gửi 10 October 2016 - 03:37 PM

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...iew?usp=sharing


  • 1

#3 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5685 Bài viết
Điểm đánh giá: 2606 (tuyệt vời)

Đã gửi 10 October 2016 - 05:16 PM

Lỗi đó bác :) 


  • 0

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#4 vanmanh192hd

vanmanh192hd

    biết vẽ line

  • Members
  • PipPip
  • 23 Bài viết
Điểm đánh giá: -4 (bình thường)

Đã gửi 10 October 2016 - 05:33 PM

Lisp cho nhanh nhỉ ^_^

 

https://drive.google...iew?usp=sharing

Bạn có thể xóa cho minh cái đường tâm hình chòn đi được không

Cảm ơn Bee nhé


  • 0

#5 Bee

Bee

    biết lệnh extend

  • Members
  • PipPipPip
  • 198 Bài viết
Điểm đánh giá: 68 (tàm tạm)

Đã gửi 10 October 2016 - 06:39 PM

Lỗi đó bác :)

Uhm, lỗi gì vậy ketxu ? ^_^


  • 0

#6 quocmanh04tt

quocmanh04tt

    biết lệnh imageclip

  • Members
  • PipPipPipPipPipPipPip
  • 673 Bài viết
Điểm đánh giá: 315 (khá)

Đã gửi 10 October 2016 - 08:49 PM

Biểu diễn chơi: https://drive.google...iew?usp=sharing

Lệnh: TRMM


  • 1

#7 Bee

Bee

    biết lệnh extend

  • Members
  • PipPipPip
  • 198 Bài viết
Điểm đánh giá: 68 (tàm tạm)

Đã gửi 10 October 2016 - 08:55 PM

Bạn có thể xóa cho minh cái đường tâm hình chòn đi được không

Cảm ơn Bee nhé

Đã xóa tâm và fix một số lỗi. ^_^

 

https://drive.google...iew?usp=sharing


  • 1

#8 nvcnc1

nvcnc1

    biết pan

  • Members
  • Pip
  • 9 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 10 October 2016 - 09:04 PM

Lâu giờ không vẽ card giờ kiến thức cũng mai một gần hết rồi. Có lẽ minh đã học phí :)


  • 0

#9 vanmanh192hd

vanmanh192hd

    biết vẽ line

  • Members
  • PipPip
  • 23 Bài viết
Điểm đánh giá: -4 (bình thường)

Đã gửi 10 October 2016 - 09:05 PM

Đã xóa tâm và fix một số lỗi. ^_^

 

https://drive.google...iew?usp=sharing

Chạy Ok luôn. cảm ơn bee nhé :)  :)


  • 0

#10 Bee

Bee

    biết lệnh extend

  • Members
  • PipPipPip
  • 198 Bài viết
Điểm đánh giá: 68 (tàm tạm)

Đã gửi 10 October 2016 - 09:35 PM

Biểu diễn chơi: https://drive.google...iew?usp=sharing

Lệnh: TRMM

Cầu kỳ ghê ^_^ ngon đới bạn


  • 0

#11 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5685 Bài viết
Điểm đánh giá: 2606 (tuyệt vời)

Đã gửi 11 October 2016 - 08:17 AM

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-


  • 0

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#12 Bee

Bee

    biết lệnh extend

  • Members
  • PipPipPip
  • 198 Bài viết
Điểm đánh giá: 68 (tàm tạm)

Đã gửi 11 October 2016 - 10:30 AM

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.!


  • 0

#13 Bee

Bee

    biết lệnh extend

  • Members
  • PipPipPip
  • 198 Bài viết
Điểm đánh giá: 68 (tàm tạm)

Đã gửi 11 October 2016 - 06:53 PM

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. ;)


  • 0

#14 quocmanh04tt

quocmanh04tt

    biết lệnh imageclip

  • Members
  • PipPipPipPipPipPipPip
  • 673 Bài viết
Điểm đánh giá: 315 (khá)

Đã gửi 12 October 2016 - 07:52 AM

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.


  • 0

#15 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5685 Bài viết
Điểm đánh giá: 2606 (tuyệt vời)

Đã gửi 12 October 2016 - 09:45 AM

@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 ạ


  • 0

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#16 quocmanh04tt

quocmanh04tt

    biết lệnh imageclip

  • Members
  • PipPipPipPipPipPipPip
  • 673 Bài viết
Điểm đánh giá: 315 (khá)

Đã gửi 12 October 2016 - 01:52 PM

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))

  • 1

#17 Bee

Bee

    biết lệnh extend

  • Members
  • PipPipPip
  • 198 Bài viết
Điểm đánh giá: 68 (tàm tạm)

Đã gửi 12 October 2016 - 06:52 PM

@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)
  )

  • 0

#18 quocmanh04tt

quocmanh04tt

    biết lệnh imageclip

  • Members
  • PipPipPipPipPipPipPip
  • 673 Bài viết
Điểm đánh giá: 315 (khá)

Đã gửi 12 October 2016 - 08:19 PM

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.
  • 0