[编程交流] 查找最近的多段线，创建

;; Design by Gabo CALOS DE VIT from CORDOBA ARGENTINA
;;;    Copyleft 1995-2018 by Gabriel Calos De Vit 
;; DEVITG@GMAIL.COM    
; Hecho por  Gabo CALOS DE VIT de CORDOBA ARGENTINA
;;;    Copyleft 1995-2018 por Gabriel Calos De Vit 
;; DEVITG@GMAIL.COM 
; no error check.
;; no nothing 
(vl-load-com)
(DEFUN C:EXAMPLE_ADDVERTEX  ( /
ACADOBJ
BLK-REF-XYZ
BLK-REFERENCE
DOC
LSTPOINT
MODELSPACE
NEWVERTEX
PARAM-AT-CLOSEST-POINT
PLINE
PLINE-OBJ
POINT-AT-PARAM
VERTEX-POINT
                            )
 (SETQ ACADOBJ (VLAX-GET-ACAD-OBJECT))
 (SETQ DOC (VLA-GET-ACTIVEDOCUMENT ACADOBJ))
 (SETQ MODELSPACE (VLA-GET-MODELSPACE DOC))
 (SETQ PLINE (ENTSEL "\nSelect Polyline: "))
 (SETQ PLINE-OBJ (VLAX-ENAME->VLA-OBJECT (CAR PLINE)))
 (SETQ BLK-REFERENCE (CAR (ENTSEL "\Select the block-reference")))
 (SETQ BLK-REF-XYZ (CDR (ASSOC 10 (ENTGET BLK-REFERENCE))))
;;;  (VL-CMDF "POINT" BLK-REF-XYZ "")
 (SETQ LSTPOINT (VLAX-CURVE-GETCLOSESTPOINTTO PLINE-OBJ BLK-REF-XYZ))
 (SETQ PARAM-AT-CLOSEST-POINT (VLAX-CURVE-GETPARAMATPOINT PLINE-OBJ LSTPOINT))
 (SETQ POINT-AT-PARAM (VLAX-CURVE-GETPOINTATPARAM PLINE-OBJ PARAM-AT-CLOSEST-POINT))
 (SETQ VERTEX-POINT (LIST (CAR POINT-AT-PARAM) (CADR POINT-AT-PARAM)))
;;;  (VL-CMDF "POINT" VERTEX-POINT "")
 (SETQ NEWVERTEX (VLAX-MAKE-SAFEARRAY VLAX-VBDOUBLE '(0 . 1)))
 (VLAX-SAFEARRAY-FILL NEWVERTEX VERTEX-POINT)
 (VLA-ADDVERTEX PLINE-OBJ (1+ (FIX PARAM-AT-CLOSEST-POINT)) NEWVERTEX)
 (VLA-UPDATE PLINE-OBJ)
 )

(defun C:ODATA (/ pl s fn opn i e de dp )
 (vl-load-com)
 (setvar 'pdmode 3)
     (while
(progn
  (setvar 'errno 0)
  (setq pl
  (car (entsel "\nSelect Polyline: ")
  ) ;_ end of car
  ) ;_ end of setq
  (cond
    ((= 7 (getvar 'errno))
     (princ "\nMissed, Please Try Again.")
    )
    ((/= "LWPOLYLINE" (cdr (assoc 0 (entget pl))))
     (princ
       "\nThe Selected Entity is not a LWPOLYLINE."
     ) ;_ end of princ
    )
  ) ;_ end of cond
) ;_ end of progn
     ) ;_ end of while
(prompt "\nSelect **Attributed** Blocks to Process: ")
 (if (and (setq s (ssget "_:L" '((0 . "INSERT") (66 . 1))))
   (setq fn (getfiled "Save Block Data to CSV File"
        (vl-filename-base (getvar 'dwgname))
        "csv"
        1
     ) ;_ end of getfiled
   ) ;_ end of setq
   (setq opn (open fn "w"))
     ) ;_ end of and
  
   (progn
     (write-line
(strcat
  "SERIAL NUMBER (ATTRIBUTE)"
  ","
  "ELEC LINE VERTEX EASTING"
  ","
  "ELEC LINE VERTEX NORTHING"
  ","
  "BLOCK INSERTION EASTING"
  ","
  "BLOCK INSERTION NORTHING"
    ) ;_ end of strcat
    opn
  ) ;_ end of write-line
  
     (close opn)
     (setq opn (open fn "a"))
     (repeat (setq i (sslength s))
(setq e (vlax-ename->vla-object (ssname s (setq i (1- i)))))
(setq
  de (vlax-get e 'insertionpoint)
  dp (vlax-curve-getclosestpointto pl de)
) ;_ end of setq
(vl-cmdf "_.point" dp "")
(write-line
  (strcat
    (vla-get-textstring (car (vlax-invoke e 'getattributes)))
    ","
    (rtos (car dp) 2 4)
    ","
    (rtos (cadr dp) 2 4)
    ","
    (rtos (car de) 2 4)
    ","
    (rtos (cadr de) 2 4)
  ) ;_ end of strcat
  opn
) ;_ end of write-line
     ) ;_ end of repeat
   ) ;_ end of progn
 ) ;_ end of if
 (close opn)
 (princ)
) ;_ end of defun

(defun c:foo (/ _writefile d od out p p2 s s1 tmp x)
 ;; RJP - 2.2.2018
 (defun _writefile (file l / fo)
   (cond ((and (eq 'str (type file)) (setq fo (open file "w")))
   (foreach x l (write-line (vl-princ-to-string x) fo))
   (close fo)
   file
  )
   )
 )
 (if (= 'exrxsubr (type ade_odgettables))
   (if        (and ;; All the meters
     (setq s (ssget "_x" '((0 . "insert") (2 . "tempmeter"))))
     ;; All the lwpoly[line]s on layer *Phase
     (setq s1 (ssget "_x" '((0 . "lwpolyline,line") (8 . "*phase"))))
     ;; Convert block to list of enames
     (setq s (mapcar 'cadr (ssnamex s)))
     ;; Convert lwpoly[line]s to list of enames
     (setq s1 (mapcar 'cadr (ssnamex s1)))
)
     ;; For each meter
     (progn
(foreach b s
  ;; Get meter basepoint
  (setq p (cdr (assoc 10 (entget b))))
  ;; List of '((<closepoint> <distance> <ename>)...)
  (setq        d
         (mapcar
           '(lambda (x) (list (setq p2 (vlax-curve-getclosestpointto x p)) (distance p p2) x))
           s1
         )
  )
  ;; Sort by closest distance and retrieve first item
  (setq d (car (vl-sort d '(lambda (r j) (< (cadr r) (cadr j))))))
  ;; Get serial number
  (setq od (ade_odgetfield b (car (ade_odgettables b)) "SerialNo" 0))
  ;; If the serial number is blank  change to "OHNOES!!!!!NoSerial!"
  (and (= "" od) (setq od "OHNOES!!!!!NoSerial!"))
  ;; Create point on closest pline
  (entmakex (list '(0 . "point") '(8 . "MeterClosePoint") (cons 10 (car d))))
  ;; Create line for visual check
  (entmakex (list '(0 . "line") '(8 . "Check") (cons 10 p) (cons 11 (car d))))
  ;; Create a vertex if it passes checks
  (and (= "LWPOLYLINE" (cdr (assoc 0 (entget (setq o (caddr d))))))
       (vlax-write-enabled-p (setq o (vlax-ename->vla-object o)))
       (setq i (vlax-curve-getparamatpoint o (setq p2 (car d))))
       (or (= 0 (fix i)) (/= 0 (rem (fix i) i)))
       (vlax-invoke o 'addvertex (1+ (fix i)) (list (car p2) (cadr p2)))
  )
  ;; Gather results
  (if (setq tmp (assoc (car d) out))
    ;; Point in list exists so append entry
    (setq out (subst (append tmp (list (strcat "," od))) tmp out))
    ;; New point just add item
    (setq out (cons (list (car d) od) out))
  )
)
;; Write file to current directory
(_writefile
  (strcat (getvar 'dwgprefix) "MeterStuff.csv")
  (mapcar
    '(lambda (x)
       (apply
         'strcat
         (append (mapcar '(lambda (y) (strcat (vl-princ-to-string y) ",")) (car x)) (cdr x))
       )
     )
    out
  )
)
     )
   )
   (print "Civil3D needed for this code...")
 )
 (princ)
)