距离最近Po的区块距离

David Bethel · 发表于 2022-7-6 15:52:55

ASMI，

我在第12、13和14版中工作，它们大多没有activeX功能。我只将Acad 2000用于大型渲染项目。

在以后的AutoCAD版本中，我从未发现任何“我离不开”的东西

李，

我使用样板模板来实现真正的程序。我做了基本的弧线测试。我在飞行中写的主体-大卫

wannabe · 发表于 2022-7-6 15:56:10

好的，我快速试用了ASMI的版本，它已经加快了当前的进程。然而，如果我可以通过某种选择过滤器（名称、图层最好）以某种方式选择许多块，然后将结果值列在表中，这将是一个很好的改进。如果这张表还可以有另一列，向我们展示关于块的独特之处，比如它的坐标或特定属性，我会很高兴。

wannabe · 发表于 2022-7-6 15:59:12

我还有一个问题，一开始我忘了提，那就是图纸上的轨道和公路，代表它们的多段线，通常是3D的；然而，在这种情况下，我们希望将其视为2D，忽略Z值，因为这会扭曲真实距离。

再次感谢。

Lee Mac · 发表于 2022-7-6 16:02:17

这是一个初学者：

将返回块基点和到直线的距离的列表。

copy


; pdis by ASMI, (modified by Lee Mac)
(defun c:pdis (/ cCurve cBlock index ent dPt1 dPt2 blkDist blklist)
   (vl-load-com)
   (if
   (and
       (setq cCurve (entsel "\nSelect curve to measure > "))
       (member (cdr (assoc 0 (entget (car cCurve))))
           '("LINE" "POLYLINE" "LWPOLYLINE" "SPLINE" "ARC" "CIRCLE" "ELLIPSE")
       ) ;_  end member
   ) ; end and
      (progn
          (setq cBlock (ssget '((0 . "INSERT")))
            index  (1- (sslength cBlock))
          ) ;_  end setq
          (while (not (minusp index))
          (setq ent  (entget (ssname cBlock index))
            dPt1 (cdr (assoc 10 ent))
            dPt2 (vlax-curve-getClosestPointTo (car cCurve) dPt1)
            blkDist (distance dPt1 dPt2)
          ) ;_  end setq
          (setq blklist (cons (list dPt1 blkDist) blklist)
            index     (1- index)
          ) ;_  end setq
          ) ; end while
      ) ;_  end progn
      (princ "\n<!> Empty selection or this isn't curve (line, polyline, etc.) <!> ")
   ) ; end if
   (alert (vl-princ-to-string blklist))
   (princ)
) ; end of c:pdis

Lee Mac · 发表于 2022-7-6 16:04:37

稍微好一点：

copy


(defun c:pdis (/ cCurve cBlock index ent dPt1 dPt2 blkDist blklist)
   (vl-load-com)
   (if
   (and
       (setq cCurve (entsel "\nSelect curve to measure > "))
       (member (cdr (assoc 0 (entget (car cCurve))))
           '("LINE" "POLYLINE" "LWPOLYLINE" "SPLINE" "ARC" "CIRCLE" "ELLIPSE")
       ) ;_  end member
   ) ; end and
      (progn
          (setq cBlock  (ssget '((0 . "INSERT")))
            index   (1- (sslength cBlock))
            blklist "\n"
          ) ;_  end setq
          (while (not (minusp index))
          (setq ent     (entget (ssname cBlock index))
            dPt1     (cdr (assoc 10 ent))
            dPt2     (vlax-curve-getClosestPointTo (car cCurve) dPt1)
            blkDist (distance dPt1 dPt2)
          ) ;_  end setq
          (setq blklist (strcat "\n"
                    (rtos (car dPt1))
                    ","
                    (rtos (cadr dPt1))
                    " <---> "
                    (rtos blkDist)
                    blklist
                ) ;_  end strcat
            index     (1- index)
          ) ;_  end setq
          ) ; end while
      ) ;_  end progn
      (princ "\n<!> Empty selection or this isn't curve (line, polyline, etc.) <!> ")
   ) ; end if
   (alert blklist)
   (princ)
) ; end of c:pdis

Lee Mac · 发表于 2022-7-6 16:08:46

好的，这个怎么样：

copy


(defun c:pdis (/ cCurve cBlock txtpnt index ent dPt1 dPt2 blkDist blklist txt)
   (defun makelay (x)
   (if (not (tblsearch "Layer" x))
       (progn
       (setvar "cmdecho" 0)
       (command "-layer" "m" x "")
       (setvar "cmdecho" 1)
       ) ;_  end progn
       (setvar "CLAYER" x)
   ) ;_  end if
   ) ;_  end defun
   (defun Make_Text (txt_pt txt_val)
   (entmake
       (list '(0 . "TEXT")
         '(8 . "TEXT")
         (cons 10 txt_pt)
         (cons 40 2.5)
         (cons 1 txt_val)
         '(50 . 0.0)
         '(7 . "STANDARD")
         '(71 . 0)
         '(72 . 0)
         '(73 . 0)
       ) ; end list
   ) ; end entmake
   ) ;_  end defun
   (vl-load-com)
   (if
   (and
       (setq cCurve (entsel "\nSelect curve to measure > "))
       (member (cdr (assoc 0 (entget (car cCurve))))
           '("LINE" "POLYLINE" "LWPOLYLINE" "SPLINE" "ARC" "CIRCLE" "ELLIPSE")
       ) ;_  end member
   ) ; end and
      (progn
          (while
          (and
              (setq cBlock (ssget '((0 . "INSERT"))))
              (setq txtpnt (getpoint "\nSelect Point for Table > "))
          ) ;_  end and
             (makelay "TEXT")
             (setq index   (1- (sslength cBlock))
               blklist "\n"
               txt        1
             ) ;_  end setq
             (while (not (minusp index))
             (setq    ent    (entget (ssname cBlock index))
               dPt1    (cdr (assoc 10 ent))
               dPt2    (vlax-curve-getClosestPointTo (car cCurve) dPt1)
               blkDist    (distance dPt1 dPt2)
             ) ;_  end setq
             (setq    blklist    (strcat    (rtos (car dPt1) 2 1)
                       ","
                       (rtos (cadr dPt1) 2 1)
                       " <---> "
                       (rtos blkDist 2 1)
                   ) ;_  end strcat
             ) ;_  end setq
             (Make_Text (polar txtpnt (* pi 1.5) (* 3.5 txt)) blklist)
             (setq    index (1- index)
               txt   (1+ txt)
             ) ;_  end setq
             ) ; end while
          ) ;_  end while
      ) ;_  end progn
      (princ "\n<!> Empty selection or this isn't curve (line, polyline, etc.) <!> ")
   ) ; end if
   (princ)
) ;_  end defun

Lee Mac · 发表于 2022-7-6 16:11:01

对不起，所有的帖子！

还有一个更新：

copy


(defun c:pdis (/ oldlay cCurve cBlock txtpnt index ent dPt1 dPt2 blkDist blklist txt)
   (defun makelay (x)
   (if (not (tblsearch "Layer" x))
       (progn
       (setvar "cmdecho" 0)
       (command "-layer" "m" x "")
       (setvar "cmdecho" 1)
       ) ;_  end progn
       (setvar "CLAYER" x)
   ) ;_  end if
   ) ;_  end defun
   (defun Make_Text (txt_pt txt_val)
   (entmake
       (list '(0 . "TEXT")
         '(8 . "TEXT")
         (cons 10 txt_pt)
         (cons 40 2.5)
         (cons 1 txt_val)
         '(50 . 0.0)
         '(7 . "STANDARD")
         '(71 . 0)
         '(72 . 0)
         '(73 . 0)
       ) ; end list
   ) ; end entmake
   ) ;_  end defun
   (vl-load-com)
   (setq oldlay (getvar "clayer"))
   (if
   (and
       (setq cCurve (entsel "\nSelect curve to measure > "))
       (member (cdr (assoc 0 (entget (car cCurve))))
           '("LINE" "POLYLINE" "LWPOLYLINE" "SPLINE" "ARC" "CIRCLE" "ELLIPSE")
       ) ;_  end member
   ) ; end and
      (progn
          (while
          (and
              (setq cBlock (ssget '((0 . "INSERT"))))
              (setq txtpnt (getpoint "\nSelect Point for Table > "))
          ) ;_  end and
             (makelay "TEXT")
             (setq index   (1- (sslength cBlock))
               blklist "\n"
               txt        1
             ) ;_  end setq
             (while (not (minusp index))
             (setq    ent    (entget (ssname cBlock index))
               dPt1    (cdr (assoc 10 ent))
               dPt2    (vlax-curve-getClosestPointTo (car cCurve) dPt1)
               blkDist    (distance dPt1 dPt2)
             ) ;_  end setq
             (setq    blklist    (strcat    (rtos (car dPt1) 2 1)
                       ","
                       (rtos (cadr dPt1) 2 1)
                       "   <--->   "
                       (rtos blkDist 2 1)
                   ) ;_  end strcat
             ) ;_  end setq
             (Make_Text (polar txtpnt (* pi 1.5) (* 3.5 txt)) blklist)
             (setq    index (1- index)
               txt   (1+ txt)
             ) ;_  end setq
             ) ; end while
          ) ;_  end while
      ) ;_  end progn
      (princ "\n<!> Empty selection or this isn't a Curve (line, polyline, etc.) <!> ")
   ) ; end if
   (setvar "clayer" oldlay)
   (princ)
) ;_  end defun