Đến nội dung


Hình ảnh
5 stars - based on 24598 reviews
- - - - -

Nhờ Các Bác Sửa Cho Lisp Copy Theo Kiểu Array


  • Please log in to reply
1 reply to this topic

#1 classicgt

classicgt

    biết zoom

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

Đã gửi 28 July 2017 - 08:30 AM

(defun c:arf ( / ss->list copyv dx dy gr i1 i2 nx ny obs obx oby p0 px py vx vy ) (vl-load-com)
(defun ss->list ( ss / i l )
(if ss
(repeat (setq i (sslength ss))
(setq l (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) l))
)
)
)
(defun copyv ( ob n v / i b l ) (setq i 1 b (vlax-3D-point '(0. 0. 0.)))
(repeat n
(foreach obj ob
(vla-move (car (setq l (cons (vla-copy obj) l))) b (vlax-3D-point (mapcar '* v (list i i i))))
)
(setq i (1+ i))
)
l
)
(if
(and
(setq obs (ss->list (ssget '((0 . "~VIEWPORT")))))
(setq p0 (getpoint "\nBase Point (P0): "))
(setq px (getpoint "\nArray X-Vector (Px): " p0))
(setq py (getpoint "\nArray Y-Vector (Py): " p0))
)
(progn
(setq vx (mapcar '- px p0) dx (distance '(0. 0. 0.) vx)
vy (mapcar '- py p0) dy (distance '(0. 0. 0.) vy)
)
(princ "\nArray Endpoint: ")
(while (= 5 (car (setq gr (grread 't 13 0)))) (redraw)
(setq obx (car (mapcar 'vla-delete obx))
oby (car (mapcar 'vla-delete oby))
gr (mapcar '- (cadr gr) p0)
i1 (inters '(0. 0. 0.) vx gr (mapcar '+ gr vy) nil)
i2 (inters '(0. 0. 0.) vy gr (mapcar '+ gr vx) nil)
nx (fix (/ (caddr (trans i1 1 vx)) dx))
ny (fix (/ (caddr (trans i2 1 vy)) dy))
obx (copyv obs (abs nx) (mapcar (if (minusp nx) '- '+) vx))
oby (copyv (append obs obx) (abs ny) (mapcar (if (minusp ny) '- '+) vy))
)
(grvecs (list -3 '(0. 0. 0.) i1 i1 gr '(0. 0. 0.) i2 i2 gr)
(list
(list 1. 0. 0. (car p0))
(list 0. 1. 0. (cadr p0))
(list 0. 0. 1. (caddr p0))
(list 0. 0. 0. 1.)
)
)
)
)
)
(redraw) (princ)
)

  • 0

#2 classicgt

classicgt

    biết zoom

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

Đã gửi 28 July 2017 - 09:04 AM

Nhờ các bác sửa lại hộ em, chỉ copy theo phương ngang hoạch phương dọc.


  • 0