mycad 发表于 2013-6-21 15:36:56

关于法线斜坡的绘制

请教高手怎样把meflying版主的程序改造成为“附件”中绘图的方式，谢谢！

原帖地址：http://bbs.mjtd.com/forum.php?mod=viewthread&tid=15804&page=1#pid49582
;函数:GetInterPOint
;功能:返回两个对象的所有交点
;参数:ent1、ent2均为ename对象
(vl-load-com)
(defun GetInterPoint (ent1 ent2 / ax_ent_1 ax_ent_2 intpoints points i)
   (setq ax_ent_1 (vlax-ename->vla-object ent1)
               ax_ent_2 (vlax-ename->vla-object ent2)
   )
   (setq intpoints (vla-intersectwith ax_ent_1 ax_ent_2 acextendnone))
   (setq intpoints (vlax-variant-value intpoints))
   (setq i 0)
   (if (> (vlax-safearray-get-u-bound intpoints 1) 0)
       (repeat (/ (+ 1
                           (- (vlax-safearray-get-u-bound intpoints 1)
                                 (vlax-safearray-get-l-bound intpoints 1)
                           )
                     )
                     3
               )
         (setq points (append points (list (list
               (vlax-safearray-get-element intpoints i)
               (vlax-safearray-get-element intpoints (+ i 1))
               (vlax-safearray-get-element intpoints (+ i 2))
         )))
         )
         (setq i (+ 3 i))
       )
   )
   points
)(defun err(msg)
   (princ msg)
   (setvar "osmode" os)
   (setvar "cmdecho" cmd)
   (setq *error* errtmp)
   (command "_.undo" "e")
   (princ)
)
(defun c:test( / ent1 ent2 entv1 entv2 pts param11 param12 param21 param22 param1 param2 i n2 pt1 pt2)   
   (setq os (getvar "osmode"))
   (setq cmd (getvar "cmdecho"))
   (command "_.undo" "be")
   (setvar "osmode" 0)
   (setvar "cmdecho" 0)
   ;(SetVar "PLINETYPE" 0)
   (setq errtmp *error*)
   (setq *error* err)
   (setq ent1 (car (entsel "\nSelect the first line...")))
   (setq ent2 (car (entsel "\nSelect the second line...")))
   (if (not n)
       (setq n (getint "\n输入密度:"))
       (progn (setq n2 (getint (strcat "\n输入密度<" (itoa n) ">:")))
         (if n2
(setq n n2)
         )
       )
   )
   (setq pts (GetInterpoint ent1 ent2))
   (setq entv1 (vlax-ename->vla-object ent1))
   (setq entv2 (vlax-ename->vla-object ent2))
   (setq param11 (vlax-curve-getParamAtPoint entv1 (car pts)))
   (setq param12 (vlax-curve-getParamAtPoint entv1 (cadr pts)))
   (setq param21 (vlax-curve-getParamAtPoint entv2 (car pts)))
   (setq param22 (vlax-curve-getParamAtPoint entv2 (cadr pts)))
   (setq i 1)
   (setq param1 (/ (- param12 param11) n))
   (setq param2 (/ (- param22 param21) n))
   (repeat (1- n)
       (setq pt1 (vlax-curve-getPointAtParam ent1 (+ param11 (* param1 i))))
       (setq pt2 (vlax-curve-getPointAtParam ent2 (+ param21 (* param2 i))))
       (if (= (* (/ i 2) 2) i)
         (setq pt2 (list (/ (+ (car pt1) (car pt2)) 2.0)
               (/ (+ (cadr pt1) (cadr pt2)) 2.0)
               (/ (+ (last pt1) (last pt2)) 2.0)
               ))
       )
       (command "_.line" pt1 pt2 "")
       (setq i (1+ i))
   )
   (setvar "osmode" os)
   (setvar "cmdecho" cmd)
   (setq *error* errtmp)
   (command "_.undo" "e")
   (princ)
)

mycad 发表于 2013-6-22 16:50:40

meflying版主可不可帮忙看看？先谢谢啦

lichunyu 发表于 2015-12-10 14:39:29

怎么没有看明白
页: [1]
查看完整版本: 关于法线斜坡的绘制