highflybir的留言板 - 明经CAD社区

shang_123 2012-3-18 11:51

大哥你那个最小外包圆改成外包多段线围成的盒子该怎么改呀！忘指教！

zwqgdhl 2012-2-2 14:44

highflybir大师，烦请出手相助，能在不打开图形下读词典http://bbs.mjtd.com/forum.php?mod=viewthread&tid=91452&page=1#pid504572pid504572

自贡黄明儒 2012-2-2 11:22

大师，我想画垂线，结果未成功，麻烦你有空帮看看
;;本程序根据highflybird[曲线和块内曲线画切线]改
;;本程序的作用是[曲线和块内曲线画垂线]
;;先是交点,其次是中点和端点
(defun c:t11 (/ ANG BS EN GEOM LST M MODE NORM P0 P1 P2 P3 P4 P5 P6 PP Q TMP V VAL VT ang)
  (vl-load-com)
  ;;1 矢量的点积
  ;; VXV Returns the dot product of 2 vectors
  (defun vxv (v1 v2) (apply '+ (mapcar '* v1 v2)))
  ;;2 矢量转置
  ;; TRP Transpose a matrix -Doug Wilson-
  (defun trp (m) (apply 'mapcar (cons 'list m)))
  ;;3 矢量的矩阵变换
  ;; MXV Apply a transformation matrix to a vector -Vladimir Nesterovsky-
  (defun mxv (m v) (mapcar (function (lambda (r) (vxv r v))) m))
  ;;4 矩阵相乘
  ;; MXM Multiply two matrices -Vladimir Nesterovsky-
  (defun mxm (m q) (mapcar (function (lambda (r) (mxv (trp q) r))) m))
  ;;5 TransNested (gile)
  ;; Translates a point coordinates from WCS or UCS to RCS -coordinates system of a
  ;; reference (xref or block) whatever its nested level-
  ;;
  ;; Arguments
  ;; pt : the point to translate
  ;; rlst : the parents entities list from the deepest nested to the one inserted in
  ;;       current space -same as (last (nentsel)) or (last (nentselp))
  ;; from to : as with trans function: 0 for WCS, 1 for current UCS, 2 for RCS
  (defun TransNested (pt rlst from to)
(and (= 1 from) (setq pt (trans pt 1 0)))
(and (= 2 to) (setq rlst (reverse rlst)))
(and (or (= 2 from) (= 2 to))
      (while rlst
         (setq geom (if (= 2 to)
                     (RevRefGeom (car rlst))
                     (RefGeom (car rlst))
                  )
               rlst (cdr rlst)
               pt (mapcar '+ (mxv (car geom) pt) (cadr geom))
         )
      )
)
(if (= 1 to)
   (trans pt 0 1)
   pt
)
  )
  ;;6 RefGeom (gile)
  ;; Returns a list which first item is a 3x3 transformation matrix (rotation,
  ;; scales, normal) and second item the object insertion point in its parent
  ;; (xref, bloc or space)
  ;;
  ;; Argument : an ename
  (defun RefGeom (ename / elst ang norm mat)
(setq elst (entget ename)
      ang  (cdr (assoc 50 elst))
      norm (cdr (assoc 210 elst))
)
(list (setq mat (mxm (mapcar (function (lambda (v) (trans v 0 norm T)))
                              '((1.0 0.0 0.0) (0.0 1.0 0.0) (0.0 0.0 1.0))
                     )
                     (mxm (list (list (cos ang) (- (sin ang)) 0.0)
                                 (list (sin ang) (cos ang) 0.0)
                                 '(0.0 0.0 1.0)
                           )
                           (list (list (cdr (assoc 41 elst)) 0.0 0.0)
                                 (list 0.0 (cdr (assoc 42 elst)) 0.0)
                                 (list 0.0 0.0 (cdr (assoc 43 elst)))
                           )
                     )
                  )
      )
      (mapcar '-
               (trans (cdr (assoc 10 elst)) norm 0)
               (mxv mat (cdr (assoc 10 (tblsearch "BLOCK" (cdr (assoc 2 elst))))))
      )
)
  )
  ;;7 RevRefGeom (gile)
  ;; RefGeom inverse function
  (defun RevRefGeom (ename / entData ang norm mat)
(setq entData (entget ename)
      ang    (- (cdr (assoc 50 entData)))
      norm (cdr (assoc 210 entData))
)
(list (setq mat (mxm (list (list (/ 1 (cdr (assoc 41 entData))) 0.0 0.0)
                           (list 0.0 (/ 1 (cdr (assoc 42 entData))) 0.0)
                           (list 0.0 0.0 (/ 1 (cdr (assoc 43 entData))))
                     )
                     (mxm (list (list (cos ang) (- (sin ang)) 0.0)
                                 (list (sin ang) (cos ang) 0.0)
                                 '(0.0 0.0 1.0)
                           )
                           (mapcar (function (lambda (v) (trans v norm 0 T)))
                                    '((1.0 0.0 0.0) (0.0 1.0 0.0) (0.0 0.0 1.0))
                           )
                     )
                  )
      )
      (mapcar '-
               (cdr (assoc 10 (tblsearch "BLOCK" (cdr (assoc 2 entData)))))
               (mxv mat (trans (cdr (assoc 10 entData)) norm 0))
      )
)
  )
  ;;8 主程序
  (setq lst (MC:NENTSEL1 "\n拾取曲线,以便在交点、中点or端点作垂线:"
                     '((0 . "*LINE,ELLIPSE,CIRCLE,ARC,RAY"))
                     "对象必须是曲线或块内曲线。"
         )
  )
  (setq P0 (cadr lst))                                                                            ; 光标点
  (setq en (car lst))                                                                            ; 光标处图元
  (setq lst (nentselp P0))
  (setq p1 (osnap p0 "_int,_mid,_endp"))
  (setq m  (caddr lst)                                                                            ; 变换矩阵
      Bs (cadddr lst)                                                                            ; 块参照列表(可能有嵌套)
      P1 (TransNested P1 Bs 1 2)                                                                ; 把点变换到图块坐标系
      P1 (vlax-curve-getclosestpointto en P1)                                                    ; 得到最近点
      pp (vlax-curve-getParamAtPoint en P1)                                                    ; 得到这点参数
      vt (vlax-curve-getSecondDeriv en pp)                                                       ; 得到法线
      an (angle '(0 0 0) vt)                                                                   ; 切线角
      P3 (mapcar '+ P1 vt)                                                                      ; 切线端点(RCS)
      P4 (mapcar '- P1 vt)                                                                      ; 切线端点(RCS)
      p2 (TransNested P1 Bs 2 0)                                                                ; 切点
      P5 (TransNested P3 Bs 2 0)                                                                ; 切线端点(WCS)
      P6 (transNested P4 Bs 2 0)                                                                ; 切线端点(WCS)
  )
  (setq ang (angle p5 p6))
  (while (not (or (= mode 3)                                                                      ; 左击
               (= mode 11)                                                                      ; 右击
               (= mode 13)                                                                      ; 回车
               (= mode 32)                                                                      ; 空格
               (= mode 25)
            )
      )
(setq mode (car (setq TMP (grread 2)))
      val  (cadr tmp)
)
(if (equal (type val) 'LIST)
   (progn (setq p6 (polar p5 ang (distance val p5)))
         (if (> (distance val p6) (distance val p5))
            (progn (setq ang (+ pi ang)) (redraw))
         )
         (grdraw P6 p5 1)
   )
)
  )
  (redraw)
  (entmake (list '(0 . "LINE") (cons 10 p5) (cons 11 p6)))                                        ; 画垂线
  (princ)
)
;;; 由caoyin的MC:ENTSEL1函数,写MC:NENTSEL1________________________________________________________________自贡黄明儒
;;;  MSG 同entsel,当该参数为nil时，缺省提示信息为“选择对象: ”。
;;;  ERRMAG：选择目标不符合条件时命令行信息。当该参数为nil时，缺省提示信息为"无效的对象。"。
;;;  FIL 同ssget
(defun MC:NENTSEL1 (MSG FIL ERRMSG / E ERR PF RT)
  (setq E  T
      PF (getvar 'PICKFIRST)
  )
  (or ERRMSG (setq ERRMSG "无效的对象。"))
  (setvar 'PICKFIRST 1)
  (while E
;;用apply的目的在于当nentsel后面的参数为nil时不会出错。
(if (setq E (apply 'nentsel (cond (MSG (list MSG)))))
   (cond ((vl-consp E)
         (if (wcmatch (cdr (assoc 0 (entget (car E)))) (cdr (car FIL)))
            (setq RT E
                  E  nil
            )
            (progn (princ ERRMSG) (setq E T))
         )
         )
         (T
         (setq RT E
               E  nil
         )
         )
   )
   ;; 当ERRNO返回7，表明用户鼠标的拾取点上没有对象，变量E设为T确保while继续。若ERRNO返回52则表明用户右击鼠标放弃选择。
   (cond ((= (setq ERR (getvar 'ERRNO)) 7) (setq E T) (princ "未选择对象。"))
         ((= ERR 52) (setq E nil))
   )
)
  )
  (setvar 'PICKFIRST PF)
  RT
)
;;; 由caoyin的MC:ENTSEL1函数,写MC:NENTSEL1________________________________________________________________自贡黄明儒