图层名称到文字

Cylis0509 · 发表于 2022-7-5 18:17:50

大家好，

我发现了这个李Mac的Lisp程序，我正在寻找一些帮助来修改它。它工作得很好，只是需要调整它，以满足我的需要。

我一直从几个城镇收到税务地图，每个地块都在自己的图层上，图层名称是地块和区块。例如：层名称：2003298-10，其中2003年为年份，298为区块，10为地块。

我希望修改代码，这样当我选择其中一个批次（顺便说一句，这是一条多段线）时，它会适当地标记多段线。

到目前为止，代码可以工作，并用图层名标记线。我想修改它，这样它会提示用户输入文本大小，通过删除前四个字符来打破标签，在接下来的三个字符中添加Block，删除-并在最后两个字符中添加lot。然后尽可能将文字放置在多段线地块的中心，文字旋转角度设置为snapang或viewtwist变量。

我希望我能解释清楚，在这些方面有任何帮助都会很好。

谢谢
气缸0509

copy


;; LayText.lsp by Lee McDonnell, 03.12.2009
;; Function will display layer information
;; at midpoint of every line selected.
(defun c:LayText (/ *error* mk_txt
DOC ENT I IPT LANG OFAC P SPC SS TOBJ TSZE UFLAG)
(vl-load-com)
(setq oFac 0.7) ;; Offset Factor
(setq tSze nil) ;; Text Size ~ nil for TEXTSIZE Variable
(defun *error* (msg)
(and uFlag (vla-EndUndoMark doc))
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
(princ (strcat "\n** Error: " msg " **")))
(princ)) 
(defun mk_txt (p v) (vla-addText spc v (vlax-3D-point p) tSze))
(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 tSze (setq tSze (getvar "TEXTSIZE")))
(if (setq i -1 ss (ssget '((0 . "*LINE,ARC,CIRCLE,ELLIPSE"))))
(progn
(setq uFlag (not (vla-StartUndoMark doc)))
(while (setq ent (ssname ss (setq i (1+ i))))
(setq iPt (vlax-curve-getPointatDist ent
(/ (- (vlax-curve-getDistatParam ent
(vlax-curve-getEndParam ent))
(vlax-curve-getDistatParam ent
(vlax-curve-getStartParam ent))) 2.)))
(setq lAng (angle '(0 0 0) (vlax-curve-getFirstDeriv ent
(vlax-curve-getParamatPoint ent iPt))))
(if (equal lAng (/ pi 2.) 0.001) (setq lAng (/ pi 2.)))
(if (equal lAng (/ (* 3 pi) 2.) 0.001) (setq lAng (/ (* 3 pi) 2.)))
(cond ( (and (> lAng (/ pi 2)) (<= lAng pi)) (setq lAng (- lAng pi)))
( (and (> lAng pi) (<= lAng (/ (* 3 pi) 2))) (setq lAng (+ lAng pi))))
(setq tObj (mk_txt (setq p (polar iPt (+ lAng (/ pi 2.)) (* oFac tSze)))
(vla-get-Layer (vlax-ename->vla-object ent))))
(vla-put-Alignment tObj acAlignmentMiddleCenter)
(vla-put-TextAlignmentPoint tObj (vlax-3D-point p))
(vla-put-Rotation tObj lAng))
(setq uFlag (vla-EndUndoMark doc))))
(princ))

Cylis0509 · 发表于 2022-7-5 18:21:52

好的，我已经知道了如何提示输入文本大小，并将标签设置为图形的捕捉角度。它工作得很好。但我仍在努力解决如何将文本集中在对象上，以及如何将层名称截断为我想要的格式。

copy


;; LayText.lsp by Lee McDonnell, 03.12.2009
;; Function will display layer information
;; at midpoint of every line selected.
(defun c:LBLL (/ *error* mk_txt
DOC ENT I IPT LANG OFAC P SPC SS TOBJ TSZE UFLAG)
(vl-load-com)
(setq oFac 0.7) ;; Offset Factor
(setq tSze (getint "Enter the text size for the label: "))
(defun *error* (msg)
(and uFlag (vla-EndUndoMark doc))
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
(princ (strcat "\n** Error: " msg " **")))
(princ)) 
(defun mk_txt (p v) (vla-addText spc v (vlax-3D-point p) tSze))
(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)))
(if (setq i -1 ss (ssget '((0 . "*LINE,ARC,CIRCLE,ELLIPSE"))))
(progn
(setq uFlag (not (vla-StartUndoMark doc)))
(while (setq ent (ssname ss (setq i (1+ i))))
(setq iPt (vlax-curve-getPointatDist ent
(/ (- (vlax-curve-getDistatParam ent
(vlax-curve-getEndParam ent))
(vlax-curve-getDistatParam ent
(vlax-curve-getStartParam ent))) 2.)))
(setq lAng (getvar "snapang"))
(setq tObj (mk_txt (setq p (polar iPt (+ lAng (/ pi 2.)) (* oFac tSze)))
(vla-get-Layer (vlax-ename->vla-object ent))))
(vla-put-Alignment tObj acAlignmentMiddleCenter)
(vla-put-TextAlignmentPoint tObj (vlax-3D-point p))
(vla-put-Rotation tObj lAng))
(setq uFlag (vla-EndUndoMark doc))))
(princ))