是否有编号命令i 乐筑天下 - Powered by Discuz! Archiver

Lee Mac 发表于 2022-7-6 15:21:47

好的，这是怎么回事

;; ============ NumCur.lsp ===============
;;
;;FUNCTION:
;;Will sequentially place numerical
;;text at the end of a leader, upon
;;mouse click.
;;
;;SYNTAX: numCur
;;
;;AUTHOR:
;;Copyright (c) 2009, Lee McDonnell
;;(Contact Lee Mac, CADTutor.net)
;;
;;PLATFORMS:
;;No Restrictions,
;;only tested in ACAD 2004.
;;
;;VERSION:
;;1.0~05.04.2009
;;
;; =======================================

(defun c:numCur (/ *error* vlst ovar doc spc dVars
      tmpVars cObj tBox GLst mPos cPt
      cDis EnPt ArPt1 ArPt2 AngCor vCol
      Verts VertVar )

(vl-load-com)

(defun *error* (msg)
(redraw)
(if ovar (mapcar 'setvar vlst ovar))
(if (not (member msg '("Function cancelled" "quit / exit abort")))
(princ (strcat "\nError: " (strcase msg)))
(princ "\n<<-- cancelled -->>"))
(princ))

(setq vlst '("OSMODE" "CLAYER")
ovar (mapcar 'getvar vlst))
(setvar "OSMODE" 0)

(setq doc (vla-get-ActiveDocument (vlax-get-Acad-Object))
   spc (if (zerop (vla-get-activespace doc))
         (if (= (vla-get-mspace doc) :vlax-true)
            (vla-get-modelspace doc)
            (vla-get-paperspace doc))
         (vla-get-modelspace doc)))

(or (tblsearch "LAYER" "Num-Text")
(vla-put-color
(vla-add
(vla-get-layers doc) "NumText") acYellow))
(setq dVars '(sNum inNum Pref Suff))
(mapcar '(lambda (x y) (or (boundp x) (set x y))) dVars '(1 1 "" ""))
(setq tmpVars (list (getreal (strcat "\nSpecify Starting Number <" (rtos sNum 2 2) ">: "))
         (getreal (strcat "\nSpecify Increment <" (rtos inNum 2 2) ">: "))
         (getstring t (strcat "\nSpecify Prefix <" (if (eq "" Pref) "-None-" Pref) ">: "))
         (getstring t (strcat "\nSpecify Suffix <" (if (eq "" Suff) "-None-" Suff) ">: "))))
(mapcar '(lambda (x y) (or (or (not x) (eq "" x)) (set y x))) tmpVars dVars)
(while (and (setq cEnt (car (entsel "\nSelect Curve to Label: ")))
      (member (cdr (assoc 0 (entget cEnt)))
      '("LINE" "POLYLINE" "LWPOLYLINE" "SPLINE" "ARC" "ELLIPSE" "CIRCLE")))
(vla-EndUndoMark doc)
(vla-StartUndomark doc)
(setq cObj (vlax-ename->vla-object cEnt)
tBox (textbox (list (cons 1 (setq tStr (strcat Pref (rtos sNum 2 0) Suff))))))
(princ "\nSelect Location for Leader... ")
(while (= (car (setq GLst (grread T 1))) 5)
(redraw)
(if (= (type (setq mPos (cadr GLst))) 'list)
(progn
(setq cPt (vlax-curve-getClosestPointto cObj mPos)
   cAng (angle cPt mPos)
   cDis (distance cPt mPos)
   EnPt (polar cPt cAng (/ cDis 1.5))
   ArPt1 (polar cPt (+ cAng (/ pi 12)) (/ cDis 8.0))
   ArPt2 (polar cPt (- cAng (/ pi 12)) (/ cDis 8.0))
   AngCor (fix (abs (* 10.0 (fix (* 18.0 (/ cAng pi)))))))
(or (and (< AngCor 1.0) (setq vCol 1)) (setq vCol AngCor))
(grvecs (list vCol cPt EnPt vCol cPt ArPt1 vCol cPt ArPt2)))))
(princ "\nSelect Leader Size & Angle...")
(while (= (car (setq GLst (grread T 1))) 5)
(redraw)
(if (= (type (setq mPos (cadr GLst))) 'list)
(progn
(setq cAng (angle cPt mPos)
   cDis (distance cPt mPos)
   ArPt1 (polar cPt (+ cAng (/ pi 12)) (/ cDis 8.0))
   ArPt2 (polar cPt (- cAng (/ pi 12)) (/ cDis 8.0)))
(grvecs (list vCol cPt mPos vCol cPt ArPt1 vCol cPt ArPt2)))))
(setq Verts (apply 'append (list cPt mPos))
VertVar (vlax-make-variant
      (vlax-safearray-fill
         (vlax-make-safearray
      vlax-vbdouble
      (cons 0 (1- (length Verts))))
         Verts)))
(vla-addleader spc VertVar
(vla-addMText spc
(vlax-3d-Point
(polar mPos 0 (/ (getvar "TEXTSIZE") 2.0)))
(- (caadr tBox) (caar tBox)) tStr) acLineWithArrow)
(redraw)
(setq sNum (+ sNum inNum)))
(mapcar 'setvar vlst ovar)
(redraw)
(princ))

CAB 发表于 2022-7-6 15:24:24

不要忘记在ExpressTools中计算

Lee Mac 发表于 2022-7-6 15:30:06

从来都不知道那是真的——指挥棒极了！

Lee Mac 发表于 2022-7-6 15:30:48

实际上，这更好（按颜色）：

;; ============ NumCur.lsp ===============
;;
;;FUNCTION:
;;Will sequentially place numerical
;;text at the end of a leader, upon
;;mouse click.
;;
;;SYNTAX: numCur
;;
;;AUTHOR:
;;Copyright (c) 2009, Lee McDonnell
;;(Contact Lee Mac, CADTutor.net)
;;
;;PLATFORMS:
;;No Restrictions,
;;only tested in ACAD 2004.
;;
;;VERSION:
;;1.0~05.04.2009
;;
;; =======================================

(defun c:numCur (/ *error* vlst ovar doc spc dVars
      tmpVars cObj tBox GLst mPos cPt
      cDis EnPt ArPt1 ArPt2 AngCor vCol
      Verts VertVar )

(vl-load-com)

(defun *error* (msg)
(redraw)
(if ovar (mapcar 'setvar vlst ovar))
(if (not (member msg '("Function cancelled" "quit / exit abort")))
(princ (strcat "\nError: " (strcase msg)))
(princ "\n<<-- cancelled -->>"))
(princ))

(setq vlst '("OSMODE" "CLAYER")
ovar (mapcar 'getvar vlst))
(setvar "OSMODE" 0)

(setq doc (vla-get-ActiveDocument (vlax-get-Acad-Object))
   spc (if (zerop (vla-get-activespace doc))
         (if (= (vla-get-mspace doc) :vlax-true)
            (vla-get-modelspace doc)
            (vla-get-paperspace doc))
         (vla-get-modelspace doc)))

(or (tblsearch "LAYER" "Num-Text")
(vla-put-color
(vla-add
(vla-get-layers doc) "NumText") acYellow))
(setq dVars '(sNum inNum Pref Suff))
(mapcar '(lambda (x y) (or (boundp x) (set x y))) dVars '(1 1 "" ""))
(setq tmpVars (list (getreal (strcat "\nSpecify Starting Number <" (rtos sNum 2 2) ">: "))
         (getreal (strcat "\nSpecify Increment <" (rtos inNum 2 2) ">: "))
         (getstring t (strcat "\nSpecify Prefix <" (if (eq "" Pref) "-None-" Pref) ">: "))
         (getstring t (strcat "\nSpecify Suffix <" (if (eq "" Suff) "-None-" Suff) ">: "))))
(mapcar '(lambda (x y) (or (or (not x) (eq "" x)) (set y x))) tmpVars dVars)
(while (and (setq cEnt (car (entsel "\nSelect Curve to Label: ")))
      (member (cdr (assoc 0 (entget cEnt)))
      '("LINE" "POLYLINE" "LWPOLYLINE" "SPLINE" "ARC" "ELLIPSE" "CIRCLE")))
(vla-EndUndoMark doc)
(vla-StartUndomark doc)
(setq cObj (vlax-ename->vla-object cEnt)
tBox (textbox (list (cons 1 (setq tStr (strcat Pref (rtos sNum 2 0) Suff))))))
(princ "\nSelect Location for Leader... ")
(while (= (car (setq GLst (grread T 1))) 5)
(redraw)
(if (= (type (setq mPos (cadr GLst))) 'list)
(progn
(setq cPt (vlax-curve-getClosestPointto cObj mPos)
   cAng (angle cPt mPos)
   cDis (distance cPt mPos)
   EnPt (polar cPt cAng (/ cDis 1.5))
   ArPt1 (polar cPt (+ cAng (/ pi 12)) (/ cDis 8.0))
   ArPt2 (polar cPt (- cAng (/ pi 12)) (/ cDis 8.0))
   AngCor (fix (rem (abs (* 10.0 (fix (* 18.0 (/ cAng pi))))) 255.0)))
(or (and (< AngCor 1.0) (setq vCol 1)) (setq vCol AngCor))
(grvecs (list vCol cPt EnPt vCol cPt ArPt1 vCol cPt ArPt2)))))
(princ "\nSelect Leader Size & Angle...")
(while (= (car (setq GLst (grread T 1))) 5)
(redraw)
(if (= (type (setq mPos (cadr GLst))) 'list)
(progn
(setq cAng (angle cPt mPos)
   cDis (distance cPt mPos)
   ArPt1 (polar cPt (+ cAng (/ pi 12)) (/ cDis 8.0))
   ArPt2 (polar cPt (- cAng (/ pi 12)) (/ cDis 8.0)))
(grvecs (list vCol cPt mPos vCol cPt ArPt1 vCol cPt ArPt2)))))
(setq Verts (apply 'append (list cPt mPos))
VertVar (vlax-make-variant
      (vlax-safearray-fill
         (vlax-make-safearray
      vlax-vbdouble
      (cons 0 (1- (length Verts))))
         Verts)))
(vla-addleader spc VertVar
(vla-addMText spc
(vlax-3d-Point
(polar mPos 0 (/ (getvar "TEXTSIZE") 2.0)))
(- (caadr tBox) (caar tBox)) tStr) acLineWithArrow)
(redraw)
(setq sNum (+ sNum inNum)))
(mapcar 'setvar vlst ovar)
(redraw)
(princ))

tzframpton 发表于 2022-7-6 15:35:20

CAB在theswamp有一辆很棒的车。我的办公室每天使用的组织。

Lee Mac 发表于 2022-7-6 15:38:18

我只是喜欢摆弄GRREAD、GRVECS等命令

mdbdesign 发表于 2022-7-6 15:42:01

CAB例程的文件名是什么？

tzframpton 发表于 2022-7-6 15:44:33

http://www.theswamp.org/index.php?topic=518.0

VVA 发表于 2022-7-6 15:47:53

和http://asmitools.com/Files/Programs.html

CAB 发表于 2022-7-6 15:51:18

谢谢
请确保在此处尝试版本26
http://www.theswamp.org/index.php?topic=518.msg295901#msg295901

还测试了29版，请参阅我的最后一篇文章。

页: 1 [2]

乐筑天下's Archiver