社区 › Auto Lisp › 同时插入dim

teknomatika 发表于 2022-7-6 07:32:13

同时插入dim

我不确定，但我想我在这里看到过类似于PLEN的惯例。LSP（由Lee Mac大师编写），但能够自动注释多段线所有线段的长度，如我在所附图像中所示。
 
如果有人知道，我很感谢你的帮助。

Tharwat 发表于 2022-7-6 07:44:22

我的老朋友。。。
 

(defun c:Test (/ *error* pl i sn)
(vl-load-com)
(defun *error* (msg)
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*") (princ (strcat "\n** Error: " msg " **")))
   (princ)
   )
(cond ((not acdoc) (setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object)))))
(princ "\n select a Polyline :")
(if (setq pl (ssget '((0 . "*POLYLINE"))))
   (progn (vla-StartUndoMark acdoc)
          (repeat (setq i (sslength pl)) (setq sn (ssname pl (setq i (1- i)))) (WriteLengthsForSegments sn))
          (vla-EndUndoMark acdoc)
          )
   (princ)
   )
(princ "\n Written By Tharwat Al Shoufi")
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun WriteLengthsForSegments (sn / j a b sty txt)
(progn (setq j 0)
      (repeat (fix (vlax-curve-getendparam sn))
          (setq a (vlax-curve-getpointatparam sn j))
          (setq b (vlax-curve-getpointatparam sn (setq j (1+ j))))
          (setq
            txt (entmakex
                  (list '(0 . "MTEXT")
                        '(100 . "AcDbEntity")
                        '(100 . "AcDbMText")
                        (assoc 8 (entget sn))
                        (cons 10 (mapcar '(lambda (x y) (/ (+ y x) 2.)) a b))
                        (cons 7 (getvar 'textstyle))
                        (cons 40
                              (if (eq (cdr (assoc 40 (setq sty (entget (tblobjname "style" (getvar 'textstyle)))))) 0.)
                              (cdr (assoc 42 sty))
                              (cdr (assoc 40 sty))
                              )
                              )
                        (cons 1 (rtos (distance a b) 2))
                        (cons 50 (angle a b))
                        '(71 . 5)
                        )
                  )
            )
          (vla-put-BackgroundFill (vlax-ename->vla-object txt) -1)
          )
      )
)

teknomatika 发表于 2022-7-6 08:08:10

塔尔瓦特，
 
就是这样。太棒了。：）但是可以重新编程以允许文本的放置，使用一个选项，可以在外部或内部有一定的偏移？

Tharwat 发表于 2022-7-6 08:12:06

 
不客气。
 
试试看。
 

(defun c:Test (/ *error* WriteLengthsForSegments pl i dir)
(vl-load-com)
;;; Tharwat 12. Sep. 2012 ;;;
(if (not acdoc)
   (setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object)))
)
(defun *error* (msg)
   (vla-EndUndoMark acdoc)
   (princ "\n *Cancel*")
   (princ)
)

(defun WriteLengthsForSegments (sn dir / h j a b sty)
   (progn (setq j 0)
          (repeat (fix (vlax-curve-getendparam sn))
            (setq a (vlax-curve-getpointatparam sn j))
            (setq b (vlax-curve-getpointatparam sn (setq j (1+ j))))
            (entmakex
            (list
                '(0 . "MTEXT")
                '(100 . "AcDbEntity")
                '(100 . "AcDbMText")
                (assoc 8 (entget sn))
                (cons 7 (getvar 'textstyle))
                (cons
                  40
                  (setq h
                         (if
                           (eq (cdr (assoc 40
                                           (setq sty (entget (tblobjname
                                                               "style"
                                                               (getvar 'textstyle)
                                                             )
                                                   )
                                           )
                                    )
                               )
                               0.
                           )
                            (cdr (assoc 42 sty))
                            (cdr (assoc 40 sty))
                         )
                  )
                )

                (cons 10
                      (polar (mapcar '(lambda (x y) (/ (+ y x) 2.)) a b)
                           (if (eq dir "Out")
                               (+ (angle a b) (* pi 0.5))
                               (+ (angle b a) (* pi 0.5))
                           )
                           (* h 1.1)
                      )
                )

                (cons 1 (rtos (distance a b) 2))
                (cons 50 (angle a b))
                '(71 . 5)
            )
            )
          )
   )
   (princ)
)
(princ "\n select a Polyline :")
(if (and (setq pl (ssget '((0 . "*POLYLINE"))))
          (progn (initget "In Out")
               (setq dir
                        (cond
                        ((getkword "\n Specify Text placement <Out> :")
                        )
                        (t "Out")
                        )
               )
          )
   )
   (progn (vla-StartUndoMark acdoc)
          (repeat (setq i (sslength pl))
            (WriteLengthsForSegments (ssname pl (setq i (1- i))) dir)
          )
          (vla-EndUndoMark acdoc)
   )
   (princ)
)
(princ "\n Written By Tharwat Al Shoufi")
(princ)
)

teknomatika 发表于 2022-7-6 08:23:40

塔尔瓦特，
 
完美的谢谢你的帮助！

Tharwat 发表于 2022-7-6 08:39:53

 
随时欢迎你。

查看完整版本: 同时插入dim