多段线顶点数查询

notview · 发表于 2022-7-6 06:08:21

我想知道某个角的多段线的顶点数。使用对象属性和滚动顶点需要时间。
伙计们，能让我们Lisp程序。。通过单击多段线的角点，它将为您提供该角点的顶点数。

marko_ribar · 发表于 2022-7-6 06:15:59

试试看，让我知道它对你有什么作用。。。

(defun unit ( v )
 (mapcar '(lambda ( x ) (/ x (distance '(0.0 0.0 0.0) v))) v)
)
(defun mxv ( m v )
 (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)
(defun v^v ( u v )
 (mapcar '(lambda ( n ) (- (* (nth (car n) u) (nth (cadr n) v)) (* (nth (cadr n) u) (nth (car n) v)))) '((1 2) (2 0) (0 1)))
)
(defun transptucs ( pt p1 p2 p3 / ux uy uz )
 (setq uz (unit (v^v (mapcar '- p2 p1) (mapcar '- p3 p1))))
 (setq ux (unit (mapcar '- p2 p1)))
 (setq uy (unit (mapcar '- p3 p1)))
 
 (mxv (list ux uy uz) (mapcar '- pt p1))
)
(defun transptwcs ( pt pt1 pt2 pt3 / pt1n pt2n pt3n )
 (setq pt1n (transptucs '(0.0 0.0 0.0) pt1 pt2 pt3))
 (setq pt2n (transptucs '(1.0 0.0 0.0) pt1 pt2 pt3))
 (setq pt3n (transptucs '(0.0 1.0 0.0) pt1 pt2 pt3))
 (transptucs pt pt1n pt2n pt3n)
)
(defun hplv ( pl / el uz v vl ux uy )
 (if (and (eq (cdr (assoc 0 (entget pl))) "POLYLINE") (< -1 (cdr (assoc 70 (entget pl))) 6))
   (progn
     (setq el (last (cdr (assoc 10 (entget pl)))))
     (setq uz (cdr (assoc 210 (entget pl))))
     (setq v pl)
     (while (eq (cdr (assoc 0 (entget (setq v (entnext v))))) "VERTEX")
       (setq vl (cons (list (car (cdr (assoc 10 (entget v)))) (cadr (cdr (assoc 10 (entget v)))) el) vl))
     )
     (if (equal uz '(0.0 0.0 1.0) 1e- (setq ux '(1.0 0.0 0.0) uy '(0.0 1.0 0.0)))
     (if (equal uz '(0.0 0.0 -1.0) 1e- (setq ux '(-1.0 0.0 0.0) uy '(0.0 1.0 0.0)))
     (if (not (or (equal uz '(0.0 0.0 1.0) 1e- (equal uz '(0.0 0.0 -1.0) 1e-)) (setq ux (unit (v^v '(0.0 0.0 1.0) uz))))
     (if (not uy) (setq uy (unit (v^v uz ux))))
     (setq vl (mapcar '(lambda ( p ) (transptwcs p '(0.0 0.0 0.0) ux uy)) vl))
     (reverse vl)
   )
   (progn
     (prompt "\nNot valid pl agument supplied to function") 
     (princ)
   )
 )
)
(defun lplv ( pl / el uz vl ux uy )
 (if (eq (cdr (assoc 0 (entget pl))) "LWPOLYLINE")
   (progn
     (setq el (cdr (assoc 38 (entget pl))))
     (setq uz (cdr (assoc 210 (entget pl))))
     (setq vl (mapcar 'cdr (vl-remove-if-not '(lambda ( p ) (= (car p) 10)) (entget pl))))
     (setq vl (mapcar '(lambda ( p ) (list (car p) (cadr p) el)) vl))
     (if (equal uz '(0.0 0.0 1.0) 1e- (setq ux '(1.0 0.0 0.0) uy '(0.0 1.0 0.0)))
     (if (equal uz '(0.0 0.0 -1.0) 1e- (setq ux '(-1.0 0.0 0.0) uy '(0.0 1.0 0.0)))
     (if (not (or (equal uz '(0.0 0.0 1.0) 1e- (equal uz '(0.0 0.0 -1.0) 1e-)) (setq ux (unit (v^v '(0.0 0.0 1.0) uz))))
     (if (not uy) (setq uy (unit (v^v uz ux))))
     (setq vl (mapcar '(lambda ( p ) (transptwcs p '(0.0 0.0 0.0) ux uy)) vl))
     vl
   )
   (progn
     (prompt "\nNot valid pl agument supplied to function") 
     (princ)
   )
 )
)
(defun c:plvertnumb (/ osm pt pl vl i)
 (setq osm (getvar 'osmode))
 (setvar 'osmode 1)
 (setq pt (getpoint "\nPick vertex point on pline to retrieve its position number : "))
 (setq pl (ssname (ssget "_C" pt pt) 0))
 (setq pt (trans pt 1 0))
 (if (eq (cdr (assoc 0 (entget pl))) "LWPOLYLINE")
   (progn
     (setq vl (lplv pl))
     (setq i (vl-position pt vl))
   )
   (progn
     (setq vl (hplv pl))
     (setq i (vl-position pt vl))
   )
 )
 (prompt "\nPicked vertex is on the ") (princ (itoa (+ i 1))) (prompt " position")
 (setvar 'osmode osm)
 (princ)
)

M.R。

notview · 发表于 2022-7-6 06:23:09

ThanX！M、 R.干杯！！
如果你还有时间，你能让程序一直运行到我按“Esc”键吗。

marko_ribar · 发表于 2022-7-6 06:32:01

虽然我认为你可以很容易地做到这一点，这是它。。。

copy


(defun unit ( v )
 (mapcar '(lambda ( x ) (/ x (distance '(0.0 0.0 0.0) v))) v)
)
(defun mxv ( m v )
 (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)
(defun v^v ( u v )
 (mapcar '(lambda ( n ) (- (* (nth (car n) u) (nth (cadr n) v)) (* (nth (cadr n) u) (nth (car n) v)))) '((1 2) (2 0) (0 1)))
)
(defun transptucs ( pt p1 p2 p3 / ux uy uz )
 (setq uz (unit (v^v (mapcar '- p2 p1) (mapcar '- p3 p1))))
 (setq ux (unit (mapcar '- p2 p1)))
 (setq uy (unit (mapcar '- p3 p1)))
 
 (mxv (list ux uy uz) (mapcar '- pt p1))
)
(defun transptwcs ( pt pt1 pt2 pt3 / pt1n pt2n pt3n )
 (setq pt1n (transptucs '(0.0 0.0 0.0) pt1 pt2 pt3))
 (setq pt2n (transptucs '(1.0 0.0 0.0) pt1 pt2 pt3))
 (setq pt3n (transptucs '(0.0 1.0 0.0) pt1 pt2 pt3))
 (transptucs pt pt1n pt2n pt3n)
)
(defun hplv ( pl / el uz v vl ux uy )
 (if (and (eq (cdr (assoc 0 (entget pl))) "POLYLINE") (< -1 (cdr (assoc 70 (entget pl))) 6))
   (progn
     (setq el (last (cdr (assoc 10 (entget pl)))))
     (setq uz (cdr (assoc 210 (entget pl))))
     (setq v pl)
     (while (eq (cdr (assoc 0 (entget (setq v (entnext v))))) "VERTEX")
       (setq vl (cons (list (car (cdr (assoc 10 (entget v)))) (cadr (cdr (assoc 10 (entget v)))) el) vl))
     )
     (if (equal uz '(0.0 0.0 1.0) 1e- (setq ux '(1.0 0.0 0.0) uy '(0.0 1.0 0.0)))
     (if (equal uz '(0.0 0.0 -1.0) 1e- (setq ux '(-1.0 0.0 0.0) uy '(0.0 1.0 0.0)))
     (if (not (or (equal uz '(0.0 0.0 1.0) 1e- (equal uz '(0.0 0.0 -1.0) 1e-)) (setq ux (unit (v^v '(0.0 0.0 1.0) uz))))
     (if (not uy) (setq uy (unit (v^v uz ux))))
     (setq vl (mapcar '(lambda ( p ) (transptwcs p '(0.0 0.0 0.0) ux uy)) vl))
     (reverse vl)
   )
   (progn
     (prompt "\nNot valid pl agument supplied to function") 
     (princ)
   )
 )
)
(defun lplv ( pl / el uz vl ux uy )
 (if (eq (cdr (assoc 0 (entget pl))) "LWPOLYLINE")
   (progn
     (setq el (cdr (assoc 38 (entget pl))))
     (setq uz (cdr (assoc 210 (entget pl))))
     (setq vl (mapcar 'cdr (vl-remove-if-not '(lambda ( p ) (= (car p) 10)) (entget pl))))
     (setq vl (mapcar '(lambda ( p ) (list (car p) (cadr p) el)) vl))
     (if (equal uz '(0.0 0.0 1.0) 1e- (setq ux '(1.0 0.0 0.0) uy '(0.0 1.0 0.0)))
     (if (equal uz '(0.0 0.0 -1.0) 1e- (setq ux '(-1.0 0.0 0.0) uy '(0.0 1.0 0.0)))
     (if (not (or (equal uz '(0.0 0.0 1.0) 1e- (equal uz '(0.0 0.0 -1.0) 1e-)) (setq ux (unit (v^v '(0.0 0.0 1.0) uz))))
     (if (not uy) (setq uy (unit (v^v uz ux))))
     (setq vl (mapcar '(lambda ( p ) (transptwcs p '(0.0 0.0 0.0) ux uy)) vl))
     vl
   )
   (progn
     (prompt "\nNot valid pl agument supplied to function") 
     (princ)
   )
 )
)
(defun c:plvertnumb (/ *error* osm pt pl vl i)
 (defun *error* (msg)
   (if osm (setvar 'osmode osm))
   (if msg (prompt msg))
   (princ)
 )
 (setq osm (getvar 'osmode))
 (setvar 'osmode 1)
 (while (and
          (not (initget 128))
          (setq pt (getpoint "\nPick vertex point on pline to retrieve its position number : "))
          (listp pt)
        )
       (setq pl (ssname (ssget "_C" pt pt) 0))
       (setq pt (trans pt 1 0))
       (if (eq (cdr (assoc 0 (entget pl))) "LWPOLYLINE")
         (progn
           (setq vl (lplv pl))
           (setq i (vl-position pt vl))
         )
         (progn
           (setq vl (hplv pl))
           (setq i (vl-position pt vl))
         )
       )
       (prompt "\nPicked vertex is on the ") (princ (itoa (+ i 1))) (prompt " position")
 )
 (*error* nil)
 (princ)
)

M.R。

notview · 发表于 2022-7-6 06:34:37

非常感谢。
M、 R.，你很善良，很棒！！

Lee Mac · 发表于 2022-7-6 06:44:18

另一种选择：

copy

(defun c:vn ( / p s )
   (while (setq p (getpoint "\nPick vertex <Exit>: "))
       (if (setq s (ssget p '((0 . "*POLYLINE"))))
           (princ
               (strcat "\nVertex number: "
                    (rtos (1+ (vlax-curve-getparamatpoint (ssname s 0)  (vlax-curve-getclosestpointto (ssname s 0) (trans p 1 0)))) 2 0)
               )
           )
           (princ "\nNo polyline found at the selected point.")
       )
   )
   (princ)
)
(vl-load-com) (princ)

notview · 发表于 2022-7-6 06:46:32

M、 R.，你的Lisp程序对我的工作很有用。我在多段线顶点附近随机标记。使用lisp，我使用它进行查询，并使用cad命令手动标记。在我看来，如果在查询后它会询问“pick the text location”，并且它会标记该查询的多段线的顶点数，直到我按下“Esc”或取消它，那么对我来说就容易多了。谢谢你给我一点时间。

notview · 发表于 2022-7-6 06:52:32

五十、你简化了程序：）。非常感谢。如果你还有时间，请帮我把我上面问的问题包括进去。

Lee Mac · 发表于 2022-7-6 06:59:28

请尝试以下操作：

copy

(defun c:vn ( / a n p q s )
   (setq n (trans '(0.0 0.0 1.0) 1 0 t)
         a (angle '(0.0 0.0 0.0) (trans (getvar 'ucsxdir) 0 n t))
   )
   (while (setq p (getpoint "\nPick vertex <Exit>: "))
       (if
           (setq s
               (ssget p
                  '(
                       (0 . "*POLYLINE")
                       (-4 . "<NOT")
                           (-4 . "<AND")
                               (0 . "POLYLINE") (-4 . "&") (70 . 80)
                           (-4 . "AND>")
                       (-4 . "NOT>")
                   )
               )
           )
           (if (setq q (getpoint "\nPick point for text: "))
               (entmake
                   (list
                      '(0 . "TEXT")
                       (cons 010 (trans q 1 n))
                       (cons 007 (getvar 'textstyle))
                       (cons 040 (getvar 'textsize))
                       (cons 001 (rtos (1+ (vlax-curve-getparamatpoint (ssname s 0) (vlax-curve-getclosestpointto (ssname s 0) (trans p 1 0)))) 2 0))
                       (cons 050 a)
                       (cons 210 n)
                   )
               )
           )
           (princ "\nNo polyline found at the selected point.")
       )
   )
   (princ)
)
(vl-load-com) (princ)

上述内容也应适用于所有UCS和视图。

notview · 发表于 2022-7-6 07:04:40

：庆祝：Big Big thanx！！五十、 M。。这对我的工作有很大帮助。感谢您与我们分享您的知识！！

[编程交流] 多段线顶点数查询

发表回复

精选推荐