[源码]模拟动态四连杆

snddd2000 · 发表于 2012-1-13 15:20

本帖最后由 snddd2000 于 2012-1-14 08:46 编辑

练习grread之用

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun C:SLG ()
(setq ent1 (car (entsel "Please choose a LWPolyLine: "))) ;_选取四节直线段的多段线
(while (/= (cdr (assoc 0 (entget ent1))) "LWPOLYLINE")
(setq ent1 (car (entsel "\nPlease choose a LWPolyLine: ")))
)
(setq ent1obj (vlax-ename->vla-object ent1))
(vla-highlight ent1obj 1) ;_虚显目标图元
(setq pt1 (vlax-curve-getStartPoint ent1obj)
pt2 (GetNopolypoint ent1 2)
pt3 (GetNopolypoint ent1 3)
pt4 (vlax-curve-getEndPoint ent1obj)
)
(setq
ent2 (entmakex (entget ent1))
)
(setq ent2list (entget ent2))
(prompt "\nPlease Moving cursor to change")
(setq mm (grread t 15 0))
(while (= 5 (car mm))
(setq mm (grread t 15 0))
(setq pt0 (cadr mm))
(setq pt2new (polar pt1 (angle pt1 pt0) (distance pt1 pt2)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setq cir1
(entmakex (list (cons 0 "CIRCLE")
(cons 10 pt2new)
(cons 40 (distance pt2 pt3))
)
)
)
(setq cir2
(entmakex (list (cons 0 "CIRCLE")
(cons 10 pt4)
(cons 40 (distance pt3 pt4))
)
)
)
(setq ptlist1 (2cirIntersect cir1 cir2))
(entdel cir1)
(entdel cir2)
(setq pt3new pt3)
(if ptlist1
(progn
(cond
((= 1 (length ptlist1))
(setq pt3new (car ptlist1))
)
((= 2 (length ptlist1))
(progn
(if (< (distance (car ptlist1) pt3new)
(distance (cadr ptlist1) pt3new)
)
(setq pt3new (car ptlist1))
(setq pt3new (cadr ptlist1))
)
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setq n 0)
(setq ent2list (mapcar '(lambda (p)
(if (= 10 (car p))
(progn
(setq n (1+ n))
(cond
((= 2 n)
(setq p (cons 10 pt2new))
)
((= 3 n)
(setq p (cons 10 pt3new))
)
(t (setq p p))
)
)
(setq p p)
)
)
ent2list
)
)
(entmod ent2list)
)
)
)
(vla-highlight ent1obj 0)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun GetNopolypoint (plent No)
(nth (1- No) (get-pline-points plent))
)
;;;(eval '(pragma '((protect-assign GetNopolypoint))))
(defun get-pline-points (ent / ptlist ptlist1)
(vl-load-com)
(setq ptlist '()
ptlist1 '()
n 0
)
(setq ptlist (vlax-safearray->list
(vlax-variant-value
(vlax-get-property
(vlax-ename->vla-object ent)
'Coordinates
)
)
)
)
(cond
(
(= "LWPOLYLINE"
(cdr (assoc 0
(entget ent)
)
)
)
(progn
(repeat (/ (length ptlist) 2)
(setq ptlist1 (cons (list (nth n ptlist)
(nth (setq n (1+ n)) ptlist)
)
ptlist1
)
)
(setq n (1+ n))
)
)
)
(
(= "POLYLINE"
(cdr (assoc 0
(entget ent)
)
)
)
(progn
(repeat (/ (length ptlist) 3)
(setq ptlist1 (cons (list (nth n ptlist)
(nth (setq n (1+ n)) ptlist)
(nth (setq n (1+ n)) ptlist)
)
ptlist1
)
)
(setq n (1+ n))
)
)
)
)
(reverse ptlist1)
)
;;;(eval '(pragma '((protect-assign get-pline-points))))
(defun 2cirIntersect (cir1 cir2)
(vl-load-com)
(setq ptlist (vlax-invoke
(vlax-ename->vla-object cir1)
'intersectwith
(vlax-ename->vla-object cir2)
0
)
n 0
)
(setq ptlist1 '())
(if ptlist
(progn
(repeat (/ (length ptlist) 3)
(setq ptlist1 (cons (list (nth n ptlist)
(nth (setq n (1+ n)) ptlist)
(nth (setq n (1+ n)) ptlist)
)
ptlist1
)
)
(setq n (1+ n))
)
)
)
ptlist1
) ;_ end defun
;;;(eval '(pragma '((protect-assign 2cirIntersect))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
(defun C:SLG () 
  (setq ent1 (car (entsel "Please choose a LWPolyLine: "))) ;_选取四节直线段的多段线 
  (while (/= (cdr (assoc 0 (entget ent1))) "LWPOLYLINE") 
    (setq ent1 (car (entsel "\nPlease choose a LWPolyLine: "))) 
  ) 
  (setq ent1obj (vlax-ename->vla-object ent1)) 
  (vla-highlight ent1obj 1) ;_虚显目标图元 
  (setq        pt1 (vlax-curve-getStartPoint ent1obj) 
        pt2 (GetNopolypoint ent1 2) 
        pt3 (GetNopolypoint ent1 3) 
        pt4 (vlax-curve-getEndPoint ent1obj) 
  ) 
 
  (setq 
    ent2 (entmakex (entget ent1)) 
  ) 
 
  (setq ent2list (entget ent2)) 
  (prompt "\nPlease Moving cursor to change") 
  (setq mm (grread t 15 0)) 
  (while (= 5 (car mm)) 
    (setq mm (grread t 15 0)) 
    (setq pt0 (cadr mm)) 
    (setq pt2new (polar pt1 (angle pt1 pt0) (distance pt1 pt2))) 
 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;; 
    (setq cir1 
           (entmakex (list (cons 0 "CIRCLE") 
                           (cons 10 pt2new) 
                           (cons 40 (distance pt2 pt3)) 
                     ) 
           ) 
    ) 
    (setq cir2 
           (entmakex (list (cons 0 "CIRCLE") 
                           (cons 10 pt4) 
                           (cons 40 (distance pt3 pt4)) 
                     ) 
           ) 
    ) 
    (setq ptlist1 (2cirIntersect cir1 cir2)) 
    (entdel cir1) 
    (entdel cir2) 
      (setq pt3new pt3) 
    (if        ptlist1 
      (progn 
        (cond 
          ((= 1 (length ptlist1)) 
           (setq pt3new (car ptlist1)) 
          ) 
          ((= 2 (length ptlist1)) 
           (progn 
       (if (< (distance (car ptlist1) pt3new) 
              (distance (cadr ptlist1) pt3new) 
                 ) 
               (setq pt3new (car ptlist1)) 
               (setq pt3new (cadr ptlist1)) 
             ) 
           ) 
          ) 
        ) 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
        (setq n 0) 
        (setq ent2list (mapcar '(lambda        (p) 
                                  (if (= 10 (car p)) 
                                    (progn 
                                      (setq n (1+ n)) 
                                      (cond 
                                        ((= 2 n) 
                                         (setq p (cons 10 pt2new)) 
                                        ) 
                                        ((= 3 n) 
                                         (setq p (cons 10 pt3new)) 
                                        ) 
                                        (t (setq p p)) 
                                      ) 
                                    ) 
                                    (setq p p) 
                                  ) 
                                ) 
                               ent2list 
                       ) 
        ) 
        (entmod ent2list) 
      ) 
    ) 
  ) 
  (vla-highlight ent1obj 0) 
) 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
(defun GetNopolypoint (plent No) 
  (nth (1- No) (get-pline-points plent)) 
) 
;;;(eval '(pragma '((protect-assign GetNopolypoint)))) 
 
(defun get-pline-points        (ent / ptlist ptlist1) 
  (vl-load-com) 
  (setq        ptlist '() 
        ptlist1        '() 
        n 0 
  ) 
  (setq        ptlist (vlax-safearray->list 
                 (vlax-variant-value 
                   (vlax-get-property 
                     (vlax-ename->vla-object ent) 
                     'Coordinates 
                   ) 
                 ) 
               ) 
  ) 
  (cond 
    ( 
     (=        "LWPOLYLINE" 
        (cdr (assoc 0 
                    (entget ent) 
             ) 
        ) 
     ) 
     (progn 
       (repeat (/ (length ptlist) 2) 
         (setq ptlist1 (cons (list (nth n ptlist) 
                                   (nth (setq n (1+ n)) ptlist) 
                             ) 
                             ptlist1 
                       ) 
         ) 
         (setq n (1+ n)) 
       ) 
     ) 
    ) 
    ( 
     (=        "POLYLINE" 
        (cdr (assoc 0 
                    (entget ent) 
             ) 
        ) 
     ) 
     (progn 
       (repeat (/ (length ptlist) 3) 
         (setq ptlist1 (cons (list (nth n ptlist) 
                                   (nth (setq n (1+ n)) ptlist) 
                                   (nth (setq n (1+ n)) ptlist) 
                             ) 
                             ptlist1 
                       ) 
         ) 
         (setq n (1+ n)) 
       ) 
     ) 
    ) 
  ) 
 
  (reverse ptlist1) 
) 
;;;(eval '(pragma '((protect-assign get-pline-points)))) 
(defun 2cirIntersect (cir1 cir2) 
  (vl-load-com) 
  (setq        ptlist (vlax-invoke 
                 (vlax-ename->vla-object cir1) 
                 'intersectwith 
                 (vlax-ename->vla-object cir2) 
                 0 
               ) 
        n      0 
  ) 
  (setq ptlist1 '()) 
  (if ptlist 
    (progn 
      (repeat (/ (length ptlist) 3) 
        (setq ptlist1 (cons (list (nth n ptlist) 
                                  (nth (setq n (1+ n)) ptlist) 
                                  (nth (setq n (1+ n)) ptlist) 
                            ) 
                            ptlist1 
                      ) 
        ) 
        (setq n (1+ n)) 
      ) 
    ) 
  ) 
  ptlist1 
) ;_ end defun 
;;;(eval '(pragma '((protect-assign 2cirIntersect))))

669423907 · 发表于 2012-1-13 20:12

第一个坐着沙发顶上。好马！

vlisp2012 · 发表于 2012-1-13 20:30

很好！学习了！！！！！！

灰色头像2 · 发表于 2020-9-10 14:52

很好！学习了！！！！！！

账号		自动登录	找回密码
密码			注册

[源码]模拟动态四连杆

本帖子中包含更多资源

本帖被以下淘专辑推荐: