关于输入或选取的问题

dennylaw163 · 发表于 2021-4-21 08:42:37

请大师帮忙看看下面程序中第63行可否改为选取一个块,而不是程序要求的输入块名。

(defun c:cme ( / *error* _StartUndo _EndUndo _SelectIf _IsCurveObject acdoc al bl d0 di en mx nm pt )
(defun *error* ( msg )
(if acdoc (_EndUndo acdoc))
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
(princ (strcat "\n** Error: " msg " **")))
(princ)
)
(defun _StartUndo ( doc ) (_EndUndo doc)
(vla-StartUndoMark doc)
)
(defun _EndUndo ( doc )
(if (= 8 (logand 8 (getvar 'UNDOCTL)))
(vla-EndUndoMark doc)
)
)
(defun _SelectIf ( msg pred func / sel ) (setq pred (eval pred))
(while
(progn (setvar 'ERRNO 0) (setq sel (car (func msg)))
(cond
( (= 7 (getvar 'ERRNO))
(princ "\nMissed, Try again.")
)
( (eq 'ENAME (type sel))
(if (and pred (not (pred sel)))
(princ "\nInvalid Object Selected.")
)
)
)
)
)
sel
)
(defun _IsCurveObject ( entity / param )
(and
(not
(vl-catch-all-error-p
(setq param
(vl-catch-all-apply 'vlax-curve-getendparam (list entity))
)
)
)
param
)
)
(setq acdoc (vla-get-activedocument (vlax-get-acad-object))
nm (trans '(0. 0. 1.) 1 0 t)
)
(if (setq en (_SelectIf "\nSelect Object to Measure: " '_isCurveObject entsel))
(progn
(initget 7 "Block")
(setq di (getdist "\nSpecify length of segment or [Block]: "))
(if (eq "Block" di)
(progn
(while
(progn (setq bl (getstring t "\nEnter name of block to insert: "))
(cond
( (not (snvalid bl))
(princ "\nInvalid block name.")
)
( (not (tblsearch "BLOCK" bl))
(princ (strcat "\nCannot find block \"" bl "\"."))
)
)
)
)
(initget "Yes No")
(setq al (not (eq "No" (getkword "\nAlign block with object? [Yes/No] <Y>: "))))
(initget 7)
(setq di (getdist "\nSpecify length of segment: "))
)
)
(setq mx (vlax-curve-getdistatparam en (vlax-curve-getendparam en))
d0 (- (/ (- mx (* di (fix (/ mx di)))) 2.) di)
)
(_StartUndo acdoc)
(while (and (<= (setq d0 (+ d0 di)) mx) (setq pt (vlax-curve-getpointatdist en d0)))
(if bl
(entmakex
(list
(cons 0 "INSERT")
(cons 2 bl)
(cons 10 (trans pt 0 nm))
(cons 50
(if al
(angle '(0. 0. 0.)
(trans
(vlax-curve-getfirstderiv en (vlax-curve-getparamatpoint en pt)) 0 nm
)
)
0.
)
)
(cons 210 nm)
)
)
(entmakex (list (cons 0 "POINT") (cons 10 pt)))
)
)
(_EndUndo acdoc)
)
(princ "\n*Cancel*")
)
(princ)
)
(vl-load-com) (princ)

dennylaw163 · 发表于 2021-4-21 11:45:06

终于还是靠自己想出来了，居中画孔的命令，需要的拿去用。

;;-------------------=={ Centered Measure }==-----------------;;

(defun c:cme ( / *error* _StartUndo _EndUndo _SelectIf _IsCurveObject acdoc al holeD bl d0 di en mx nm pt )

  (defun *error* ( msg )
(if acdoc (_EndUndo acdoc))
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
      (princ (strcat "\n** Error: " msg " **")))
(princ)
  )

  (defun _StartUndo ( doc ) (_EndUndo doc)
(vla-StartUndoMark doc)
  )

  (defun _EndUndo ( doc )
(if (= 8 (logand 8 (getvar 'UNDOCTL)))
   (vla-EndUndoMark doc)
)
  )

  (defun _SelectIf ( msg pred func / sel ) (setq pred (eval pred))
(while
   (progn (setvar 'ERRNO 0) (setq sel (car (func msg)))
      (cond
      ( (= 7 (getvar 'ERRNO))
         (princ "\nMissed, Try again.")
      )
      ( (eq 'ENAME (type sel))
         (if (and pred (not (pred sel)))
            (princ "\nInvalid Object Selected.")
         )
      )
      )
   )
)
sel
  )

  (defun _IsCurveObject ( entity / param )
(and
   (not
      (vl-catch-all-error-p
      (setq param
         (vl-catch-all-apply 'vlax-curve-getendparam (list entity))
      )
      )
   )
   param
)
  )

  (setq acdoc (vla-get-activedocument (vlax-get-acad-object))
      nm (trans '(0. 0. 1.) 1 0 t)
  )

(setq holeD (getdist (strcat "\nSpecify diameter of holes <" "5" ">")))
(if (= holeD nil) (setq holeD 5))

  (if (setq en (_SelectIf "\nSelect Object to Measure: " '_isCurveObject entsel))
(progn
   (initget 7 "Block")
   (setq di (getdist "\nSpecify Center to Center distance or [Block]: "))

   (if (eq "Block" di)
      (progn
      (while

         (progn (setq bl (vla-get-effectivename (vlax-ename->vla-object (car(entsel "\nSelect block to segment:")))))

            (cond
            ( (not (snvalid bl))
               (princ "\nInvalid block name.")
            )
            ( (not (tblsearch "BLOCK" bl))
               (princ (strcat "\nCannot find block \"" bl "\"."))
            )
            )
         )
      )
      (initget "Yes No")
      (setq al (not (eq "No" (getkword "\nAlign block with object? [Yes/No] <Y>: "))))
      (initget 7)
      (setq di (getdist "\nSpecify Center to Center distance: "))
      )
   )
   (setq mx (vlax-curve-getdistatparam en (vlax-curve-getendparam en))
         d0 (- (/ (- mx (* di (fix (/ mx di)))) 2.) di)
   )
   (_StartUndo acdoc)
   (while (and (<= (setq d0 (+ d0 di)) mx) (setq pt (vlax-curve-getpointatdist en d0)))
      (if bl
      (entmakex
         (list
            (cons 0 "INSERT")
            (cons 2 bl)
            (cons 10 (trans pt 0 nm))
            (cons 50
            (if al
               (angle '(0. 0. 0.)
                  (trans
                  (vlax-curve-getfirstderiv en (vlax-curve-getparamatpoint en pt)) 0 nm
                  )
               )
               0.
            )
            )
            (cons 210 nm)
         )
      )

      (entmake (list '(0 . "CIRCLE") (cons 10 pt) (cons 40 (/ holeD 2))))

      )
   )
   (_EndUndo acdoc)
)

(princ "\n*Cancel*")
  )
  (princ)
)
(vl-load-com) (princ)

;;------------------------------------------------------------;;
;;                      End of File                      ;;
;;------------------------------------------------------------;;

845245015 · 发表于 2021-4-21 11:42:54

(defun c:cme ( / *error* _StartUndo _EndUndo _SelectIf _IsCurveObject acdoc al bl d0 di en mx nm pt  lzr)
  (defun *error* ( msg )
(if acdoc (_EndUndo acdoc))
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
      (princ (strcat "\n** Error: " msg " **")))
(princ)
  )
  (defun _StartUndo ( doc ) (_EndUndo doc)
(vla-StartUndoMark doc)
  )
  (defun _EndUndo ( doc )
(if (= 8 (logand 8 (getvar 'UNDOCTL)))
   (vla-EndUndoMark doc)
)
  )
  (defun _SelectIf ( msg pred func / sel ) (setq pred (eval pred))
(while
   (progn (setvar 'ERRNO 0) (setq sel (car (func msg)))
      (cond
      ( (= 7 (getvar 'ERRNO))
         (princ "\nMissed, Try again.")
      )
      ( (eq 'ENAME (type sel))
         (if (and pred (not (pred sel)))
            (princ "\nInvalid Object Selected.")
         )
      )
      )
   )
)
sel
  )
  (defun _IsCurveObject ( entity / param )
(and
   (not
      (vl-catch-all-error-p
      (setq param
         (vl-catch-all-apply 'vlax-curve-getendparam (list entity))
      )
      )
   )
   param
)
  )
  (setq acdoc (vla-get-activedocument (vlax-get-acad-object))
      nm (trans '(0. 0. 1.) 1 0 t)
  )
  (if (setq en (_SelectIf "\nSelect Object to Measure: " '_isCurveObject entsel))
(progn
   (initget 7 "Block")
   (setq di (getdist "\nSpecify length of segment or [Block]: "))
   (if (eq "Block" di)
      (progn
      (while
         (progn
            ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
            ;没有测试图，不知道是否可行以下为修改部分
            ;(setq bl (getstring t "\nEnter name of block to insert: "))
            (print "请选择图块")
            (setq bl (vla-get-effectivename (vlax-ename->vla-object (car(entsel)))))
            ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
            (cond
            ( (not (snvalid bl))
               (princ "\nInvalid block name.")
            )
            ( (not (tblsearch "BLOCK" bl))
               (princ (strcat "\nCannot find block \"" bl "\"."))
            )
            )
         )
      )
      (initget "Yes No")
      (setq al (not (eq "No" (getkword "\nAlign block with object? [Yes/No] <Y>: "))))
      (initget 7)
      (setq di (getdist "\nSpecify length of segment: "))
      )
   )
   (setq mx (vlax-curve-getdistatparam en (vlax-curve-getendparam en))
         d0 (- (/ (- mx (* di (fix (/ mx di)))) 2.) di)
   )
   (_StartUndo acdoc)
            ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
            ;以下为修改部分
            (setq lzr (getreal "请输入半径:"))
            ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   (while (and (<= (setq d0 (+ d0 di)) mx) (setq pt (vlax-curve-getpointatdist en d0)))
      (if bl
      (entmakex
         (list
            (cons 0 "INSERT")
            (cons 2 bl)
            (cons 10 (trans pt 0 nm))
            (cons 50
            (if al
               (angle '(0. 0. 0.)
                  (trans
                  (vlax-curve-getfirstderiv en (vlax-curve-getparamatpoint en pt)) 0 nm
                  )
               )
               0.
            )
            )
            (cons 210 nm)
         )
      )
      (entmake (list '(0 . "CIRCLE") (cons 10 pt) (cons 40 lzr)))
      )
   )
   (_EndUndo acdoc)
)
(princ "\n*Cancel*")
  )
  (princ)
)
(vl-load-com) (princ)

845245015 · 发表于 2021-4-21 09:03:02

(defun c:cme ( / *error* _StartUndo _EndUndo _SelectIf _IsCurveObject acdoc al bl d0 di en mx nm pt )
  (defun *error* ( msg )
(if acdoc (_EndUndo acdoc))
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
      (princ (strcat "\n** Error: " msg " **")))
(princ)
  )
  (defun _StartUndo ( doc ) (_EndUndo doc)
(vla-StartUndoMark doc)
  )
  (defun _EndUndo ( doc )
(if (= 8 (logand 8 (getvar 'UNDOCTL)))
   (vla-EndUndoMark doc)
)
  )
  (defun _SelectIf ( msg pred func / sel ) (setq pred (eval pred))
(while
   (progn (setvar 'ERRNO 0) (setq sel (car (func msg)))
      (cond
      ( (= 7 (getvar 'ERRNO))
         (princ "\nMissed, Try again.")
      )
      ( (eq 'ENAME (type sel))
         (if (and pred (not (pred sel)))
            (princ "\nInvalid Object Selected.")
         )
      )
      )
   )
)
sel
  )
  (defun _IsCurveObject ( entity / param )
(and
   (not
      (vl-catch-all-error-p
      (setq param
         (vl-catch-all-apply 'vlax-curve-getendparam (list entity))
      )
      )
   )
   param
)
  )
  (setq acdoc (vla-get-activedocument (vlax-get-acad-object))
      nm (trans '(0. 0. 1.) 1 0 t)
  )
  (if (setq en (_SelectIf "\nSelect Object to Measure: " '_isCurveObject entsel))
(progn
   (initget 7 "Block")
   (setq di (getdist "\nSpecify length of segment or [Block]: "))
   (if (eq "Block" di)
      (progn
      (while
         (progn
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;没有测试图，不知道是否可行以下为修改部分
      ;(setq bl (getstring t "\nEnter name of block to insert: "))
      (print "请选择图块")
      (setq bl (vla-get-effectivename (vlax-ename->vla-object (car(entsel)))))
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
            (cond
            ( (not (snvalid bl))
               (princ "\nInvalid block name.")
            )
            ( (not (tblsearch "BLOCK" bl))
               (princ (strcat "\nCannot find block \"" bl "\"."))
            )
            )
         )
      )
      (initget "Yes No")
      (setq al (not (eq "No" (getkword "\nAlign block with object? [Yes/No] <Y>: "))))
      (initget 7)
      (setq di (getdist "\nSpecify length of segment: "))
      )
   )
   (setq mx (vlax-curve-getdistatparam en (vlax-curve-getendparam en))
         d0 (- (/ (- mx (* di (fix (/ mx di)))) 2.) di)
   )
   (_StartUndo acdoc)
   (while (and (<= (setq d0 (+ d0 di)) mx) (setq pt (vlax-curve-getpointatdist en d0)))
      (if bl
      (entmakex
         (list
            (cons 0 "INSERT")
            (cons 2 bl)
            (cons 10 (trans pt 0 nm))
            (cons 50
            (if al
               (angle '(0. 0. 0.)
                  (trans
                  (vlax-curve-getfirstderiv en (vlax-curve-getparamatpoint en pt)) 0 nm
                  )
               )
               0.
            )
            )
            (cons 210 nm)
         )
      )
      (entmakex (list (cons 0 "POINT") (cons 10 pt)))
      )
   )
   (_EndUndo acdoc)
)
(princ "\n*Cancel*")
  )
  (princ)
)
(vl-load-com) (princ)

dennylaw163 · 发表于 2021-4-21 09:44:52

845245015 发表于 2021-4-21 09:03
(defun c:cme ( / *error* _StartUndo _EndUndo _SelectIf _IsCurveObject acdoc al bl d0 di en mx nm pt ...

试了下，行了，谢谢！

第106行，现程序的用点分段，可否实现用指定直径或半径的圆来分，也就是点的位置改为圆。

烟盒迷唇 · 发表于 2021-4-21 10:10:18

换圆很简单的吧，这都不会

dennylaw163 · 发表于 2021-4-21 10:32:09

烟盒迷唇发表于 2021-4-21 10:10
换圆很简单的吧，这都不会

(entmake (list '(0 . "CIRCLE") (cons 10 pt) (cons 40 r))

不是不会，是想把r的地方换成手输

dennylaw163 · 发表于 2021-4-21 11:15:43

(entmake (list '(0 . "CIRCLE") (cons 10 pt) (cons 40 (getreal "请输入半径:"))))

换成这句了可以手输半径了，但要输很多次，何解

dennylaw163 · 发表于 2021-4-21 17:20:42

845245015 发表于 2021-4-21 11:42
(defun c:cme ( / *error* _StartUndo _EndUndo _SelectIf _IsCurveObject acdoc al bl d0 di en mx nm p ...

我加在前面去了

dennylaw163 · 发表于 2021-4-21 18:05:03

845245015 发表于 2021-4-21 11:42
(defun c:cme ( / *error* _StartUndo _EndUndo _SelectIf _IsCurveObject acdoc al bl d0 di en mx nm p ...

选了插入块之后还是要求输入孔的半径，应该是选了块后就不用问了才对啊

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

[讨论] 关于输入或选取的问题