需要帮助修改标签Lwpo
你好我有一些我试图修改的代码。该代码将用全局宽度标记LWpolyline。
(vl-load-com)
(defun c:Label_Width ( / js htx AcDoc Space nw_style obj dxf_ent ename t_mod key pr t_char js_text pt deriv rtx nw_obj n)
(princ "\nSelect a polyline.")
(while
(null
(setq js
(ssget "_+.:E:S"
(list
'(0 . "*POLYLINE")
(cons 67 (if (eq (getvar "CVPORT") 1) 1 0))
(cons 410 (if (eq (getvar "CVPORT") 1) (getvar "CTAB") "Model"))
)
)
)
)
(princ "\nIsn't an available object for this fonction!")
)
(setq
obj (ssname js 0)
dxf_ent (entget obj)
ename (vlax-ename->vla-object obj)
t_mod '+
key "Yes"
)
(cond
((assoc 43 dxf_ent)
(initget 6)
(setq htx (getdist (getvar "VIEWCTR") (strcat "\nSpecify text height <" (rtos (getvar "TEXTSIZE")) ">: ")))
(if htx (setvar "TEXTSIZE" htx))
(setq
AcDoc (vla-get-ActiveDocument (vlax-get-acad-object))
Space
(if (= 1 (getvar "CVPORT"))
(vla-get-PaperSpace AcDoc)
(vla-get-ModelSpace AcDoc)
)
)
(cond
((null (tblsearch "LAYER" "Label"))
(vlax-put (vla-add (vla-get-layers AcDoc) "Label") 'color 96)
)
)
(cond
((null (tblsearch "STYLE" "Romand-Label"))
(setq nw_style (vla-add (vla-get-textstyles AcDoc) "Romand-Label"))
(mapcar
'(lambda (pr val)
(vlax-put nw_style pr val)
)
(list 'FontFile 'Height 'ObliqueAngle 'Width 'TextGenerationFlag)
(list "romand.shx" 0.0 (/ (* 15.0 pi) 180) 1.0 0.0)
)
)
)
(repeat 2
(setq pr -0.5 t_char 64 js_text (ssadd))
(if (eq key "Yes")
(repeat (fix (vlax-curve-getEndParam ename))
(setq
pt (vlax-curve-GetpointAtParam ename (setq pr (1+ pr)))
deriv (vlax-curve-getFirstDeriv ename pr)
rtx (- (atan (cadr deriv) (car deriv)) (angle '(0 0 0) (getvar "UCSXDIR")))
)
(setq nw_obj
(vla-addMtext Space
(vlax-3d-point (setq pt (polar pt ((eval t_mod) rtx (* pi 0.5)) (getvar "TEXTSIZE"))))
0.0
(strcat
"%<\\AcObjProp.16.2 Object(%<\\_ObjId "
(itoa (vla-get-ObjectID (vlax-ename->vla-object obj)))
">%).ConstantWidth \\f \"%lu2\">%"
)
)
)
(if (or (> rtx (* pi 0.5)) (< rtx (- (* pi 0.5)))) (setq rtx (+ rtx pi)))
(mapcar
'(lambda (pr val)
(vlax-put nw_obj pr val)
)
(list 'AttachmentPoint 'Height 'DrawingDirection 'InsertionPoint 'StyleName 'Layer 'Rotation)
(list 5 (getvar "TEXTSIZE") 5 pt "Romand-Label" "Label" rtx)
)
(ssadd (entlast) js_text)
)
)
(if (not (eq t_mod '-))
(progn
(initget "Yes No")
(if (eq (setq key (getkword "\nPut labels on other side ? <No>: ")) "Yes")
(progn (setq n -1 t_mod '-) (repeat (sslength js_text) (entdel (ssname js_text (setq n (1+ n))))))
(setq t_mod '-)
)
)
)
)
)
(T (princ "\nThis polyine does not have a constant width!"))
)
(prin1)
)
1.我需要更改代码，使其只使用当前的文本样式，甚至询问用户应该使用哪种文本样式。它不应该要求高度，也不应该创造一种风格。
2.我还想把这个文本放在与lwpolyline相同的层上。
3.代码使用文本字段作为文本。我需要修改这个文本字段，使其采用全局宽度并将其乘以1000，并在新值之前放置前缀。即，全局宽度为0.5的pline将具有DN 500的文本标签。
我花了一些时间试图实现上述目标，但没有成功。我原以为第3条最容易修改，只需编辑文本字段的代码，但不幸的是，不是这样，否则我做错了什么。
任何帮助都将不胜感激。例如，我需要在哪里修改代码，如何修改它以及为什么需要修改它，以便我可以从中学习其他代码。
我相信这段代码对其他人也可能有用。
不幸的是，我只是没有时间在mo上花时间，因为我在mo的工作中遇到了困难。
谢谢 打破而不是建立。。。
(vl-load-com)
(defun c:Label_Width ( / js htx AcDoc cLay Space nw_style obj dxf_ent ename t_mod key pr t_char js_text pt deriv rtx nw_obj n)
(princ "\nSelect a polyline.")
(while
(null
(setq js
(ssget "_+.:E:S"
(list
'(0 . "*POLYLINE")
(cons 67 (if (eq (getvar "CVPORT") 1) 1 0))
(cons 410 (if (eq (getvar "CVPORT") 1) (getvar "CTAB") "Model"))
)
)
)
)
(princ "\nIsn't an available object for this fonction!")
)
(setq
obj (ssname js 0)
dxf_ent (entget obj)
ename (vlax-ename->vla-object obj)
cLay(vla-get-Layer ename)
t_mod '+
key "Yes"
)
(cond
((assoc 43 dxf_ent)
(setq
AcDoc (vla-get-ActiveDocument (vlax-get-acad-object))
Space
(if (= 1 (getvar "CVPORT"))
(vla-get-PaperSpace AcDoc)
(vla-get-ModelSpace AcDoc)
)
)
(repeat 2
(setq pr -0.5 t_char 64 js_text (ssadd))
(if (eq key "Yes")
(repeat(fix (vlax-curve-getEndParam ename))
(setq
pt (vlax-curve-GetpointAtParam ename (setq pr (1+ pr)))
deriv (vlax-curve-getFirstDeriv ename pr)
rtx (- (atan (cadr deriv) (car deriv)) (angle '(0 0 0) (getvar "UCSXDIR")))
)
(setq nw_obj
(vla-addMtext Space
(vlax-3d-point (setq pt (polar pt ((eval t_mod) rtx (* pi 0.5)) (getvar "TEXTSIZE"))))
0.0
(strcat "DN"
"%<\\AcExpr (%<\\AcObjProp.16.2 Object(%<\\_ObjId "
(itoa (vla-get-ObjectID (vlax-ename->vla-object obj)))
">%).ConstantWidth >% * 1000) \\f \"%lu2%pr0\">%"
)
)
)
(if (or (> rtx (* pi 0.5)) (< rtx (- (* pi 0.5)))) (setq rtx (+ rtx pi)))
(mapcar
'(lambda (pr val)
(vlax-put nw_obj pr val)
)
(list 'AttachmentPoint 'Height 'DrawingDirection 'InsertionPoint 'StyleName 'Layer 'Rotation)
(list 5 (getvar "TEXTSIZE") 5 pt (getvar "TEXTSTYLE") cLay rtx)
)
(ssadd (entlast) js_text)
)
)
(if (not (eq t_mod '-))
(progn
(initget "Yes No")
(if (eq (setq key (getkword "\nPut labels on other side ? <No>: ")) "Yes")
(progn (setq n -1 t_mod '-) (repeat (sslength js_text) (entdel (ssname js_text (setq n (1+ n))))))
(setq t_mod '-)
)
)
)
)
)
(T (princ "\nThis polyine does not have a constant width!"))
)
(prin1)
) 再次对延迟回复表示抱歉。请不要以为我不感激你的帮助和帮助。我是，非常。这对我来说很好。再次感谢
页:
[1]