修改Lisp 乐筑天下 - Powered by Discuz! Archiver

feargt 发表于 2022-7-6 14:30:57

修改Lisp

你好

我有一个lisp例程，我们在办公室使用它来标记具有全局宽度的多段线。
即，如果我有一条全局宽度为0.2的多段线（代表管道），例程将用DN200标记多段线的所有段

我想做的是更改此代码，以便如果多段线段小于10个单位，则此段不会得到标签。

例如，长度为29个单位的多段线有3段，2段的长度为12个单位，第三段的长度为5个单位。
我希望标记12个单元的2个段，但不要标记5个单元的第三个段

_________________

如果没有线段大于10个单位，则在中点标记一次多段线。

______________

这里我的第一个问题是，我不确定我需要在代码中的什么地方进行更改。

如果有人能帮助我或给我举一些例子说明如何实现这一点，我将不胜感激。

谢谢

;This routine was provided by ASMI.
(vl-load-com)
(defun c:Label_Width (/       js    htx AcDoc cLay Space
      nw_style       obj dxf_ent ename t_mod
      key pr    t_charjs_text pt    deriv
      rtx nw_objn
      )
(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_char64
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)
)

feargt 发表于 2022-7-6 14:39:41

有人有什么想法吗？

CAB 发表于 2022-7-6 14:45:10

试试这个：

;;This routine was provided by ASMI.
(vl-load-com)
(defun c:Label_Width (/       js    htx AcDoc cLay Space
      nw_style       obj dxf_ent ename t_mod
      key pr    t_charjs_text pt    deriv
      rtx nw_objnparlen
      )
(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_char64
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"))
   )
)
      ;;Test for segment length - CAB
      ;;vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
      (setq par (fix pr))
      (if (= par (fix (vlax-curve-getEndParam ename)))
         (setq len (vlax-curve-getdistatparam ename (vlax-curve-getEndParam ename)))
         (setq len (vlax-curve-getdistatparam ename (1+ par)))
      )
      (setq len (- len (vlax-curve-getdistatparam ename par)))

      (if (> len 10.0) ; Min Segment Length
         (progn
      ;;^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
(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)
      ) ; CAB
         ) ; CAB
)
   )
   (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)
)

ronjonp 发表于 2022-7-6 14:52:35

这似乎对我有效*又太慢了

*将翻转标签更改为拾取点。。输入结束。

;This routine was provided by ASMI.
; Additions by RJP 05-29-2009
(defun c:label_width (/    acdocclay d    derivdxf_ent    enameflag js js_text
                  key nw_obj obj out p    pr pt pt2 rtx spacet_char
                  t_modval x    w
               )
(vl-load-com)
(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 function!")
)
(setq obj (ssname js 0)
   dxf_ent (entget obj)
   ename (vlax-ename->vla-object obj)
   clay (vla-get-layer ename)
   t_mod '+
   key "Yes"
)
(if (setq w (cdr (assoc 43 dxf_ent)))
(progn (setq acdoc (vla-get-activedocument (vlax-get-acad-object))
            space (if (= 1 (getvar "CVPORT"))
                     (vla-get-paperspace acdoc)
                     (vla-get-modelspace acdoc)
                  )
            x 0.0
      )
      ;;RJP check if at least one segment is longer than 10
      (repeat (fix (vlax-curve-getendparam ename))
         (if (> (distance (vlax-curve-getpointatparam ename x)
                        (vlax-curve-getpointatparam ename (setq x (1+ x)))
               )
               10.
            )
         (setq flag t)
         )
      )
      (setq pr    -0.5
            t_char64
            js_text (ssadd)
            x    0.0
      )
      (if (and (eq key "Yes") flag)
         ;;RJP add - If at least one segment is greater than 10
         (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")))
               d (distance (vlax-curve-getpointatparam ename x)
                                 (vlax-curve-getpointatparam ename (setq x (1+ x)))
                     )
         )
         (if (> d 5)
            ;;RJP add - If segment length > 5 rock and roll (does not calculate length along arc segment) it's pt to pt
            (progn (setq nw_obj
                           (vla-addmtext space
                                       (vlax-3d-point (setq pt (polar pt
                                                                        ((eval t_mod) rtx (* pi 0.5))
                                                                        (+ (getvar "TEXTSIZE") (/ w 2.))
                                                               )
                                                      )
                                       )
                                       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)
                  )
                  (setq out (cons nw_obj out))
            )
         )
         )
         ;;RJP add - Else no segments greater than 10 get midpoint of polyline
         (progn (setq pt (vlax-curve-getpointatdist
                              ename
                              (/ (vlax-curve-getdistatpoint ename (vlax-curve-getendpoint ename)) 2)
                           )
                     deriv (vlax-curve-getfirstderiv ename (vlax-curve-getparamatpoint ename pt))
                     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") (/ w 2.))
                                                               )
                                                      )
                                       )
                                       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)
               )
               (setq out (cons nw_obj out))
         )
      )
      ;;RJP add - pickpoint to flip labels or enter to exit
      (while (setq p (getpoint "\nPick a point to flip labels :"))
         (foreach txt out
         (vla-move txt
                     (vla-get-insertionpoint txt)
                     (vlax-3d-point
                     (polar (setq pt (vlax-get txt 'insertionpoint))
                              (angle pt (setq pt2 (vlax-curve-getclosestpointto ename pt)))
                              (* 2. (distance pt pt2))
                     )
                     )
         )
         )
      )
)
(princ "\nThis polyline does not have a constant width!")
)
(prin1)
)

dani 发表于 2022-7-6 14:59:21

这是我的名字，丹过去了。

ronjonp 发表于 2022-7-6 15:10:03

Dani，

一幅画抵得上一千个字。。。我重新发布了代码，试一试。

feargt 发表于 2022-7-6 15:12:50

非常感谢您在这方面花时间。

不幸的是，这似乎不适用于线段长度不超过10个单位的多段线

它适用于具有多个段的柱脚，其中一些段短于10个单位

ronjonp的版本似乎完全符合我的需要，我只需要在周一的办公室里对它进行更多的测试

feargt 发表于 2022-7-6 15:21:22

嗨，Ronjonp，

这似乎和我描述的一模一样（希望我最初的描述足够好，这不仅仅是巧合）

我会在周一的工作中测试它，并给出一些反馈。但初步测试似乎非常令人满意！

再次非常感谢您，特别感谢您在代码中提供了描述，这样我就可以看到您做了什么，以及您是如何做到的。

ronjonp 发表于 2022-7-6 15:26:43

很高兴帮助。。。如果它没有按预期工作，请告诉我。

MarcoW 发表于 2022-7-6 15:36:46

在我尝试了这个程序（只是出于好奇）之后，我想知道是否可以这样做。

假设我们有一个叫做“19mm管道”的层，所以在该层中绘制的所有线都是19mm管道。现在，我将文字放在“19mm”行旁边，或者使用图形中某处解释的线型。有时我会放置一个引线，其中填充了所需的文本“19mm”。

有没有办法在直接显示直径的那条线上放置（某种）引线？
因为线本身没有直径，我知道。也许因为这是一条线，它在一个特定的层上，所以它可以做到。

只是好奇。。。我可以用它。

页: [1]

乐筑天下's Archiver

修改Lisp