查找最近的多段线，创建
大家好，我正在尝试编写一个LISP例程，该例程将完成以下任务：
1、选择图纸上的块参照
2.从该块参照中查找最近的多段线和该多段线上的最近点
3.在该点上创建顶点，并将该点的坐标保存到变量中以供进一步使用
4.从该块参考中提取对象数据，如SerialNo（请参阅随附的屏幕截图）
5.每个块参考的回路
6.将先前保存的点坐标及其对应的序列号导出为txt或csv，如下所示：
X_coord，Y_coord，序列号
E、 g.85.4535、18.7903、09I4E5Q2104022719
或85.4535、18.7903、09I4E5Q2104022311、09I4E5Q2104022719（如果其具有多个块参考）
输出文件被解释为在该特定点上具有负载的电线。
以下是我迄今为止发现/借用的有帮助的内容：
用于在此线程上创建DeviceG提供的顶点程序
;; Design by Gabo CALOS DE VIT from CORDOBA ARGENTINA
;;; Copyleft 1995-2018 by Gabriel Calos De Vit
;; DEVITG@GMAIL.COM
; Hecho porGabo 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)
)
它工作得很好，但现在需要修改以在循环中工作
对于提取对象数据，BlackBox在此线程上提供的答案可能会有所帮助
随附样品图
谢谢你的帮助
非常感谢。
当做
Jes G公司
示例图。图纸
jes\u g，
这是我周五下午的尝试。
假设您的数据（序列号？）包含在每个块的属性中；
提取第一个属性值（序列号）；
1选择多段线；然后
2选择块。
将（在选定的多段线上）在每个块的最近点处放置一个点；和
数据将保存到CSV文件中
(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
我不是专家，但希望这能让你更接近你想要的解决方案。
干杯
奥达塔。lsp
谢谢你的回复。我运行这段代码，当我尝试选择块参照时，它们不会被选中。非常感谢。 这里有一个快速的开始。我已经发表了评论，所以你可以编辑代码，以完全满足你的需要。
(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 lwpolys 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 lwpolys 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 blankchange 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)
)
哇！这看起来很完美！谢谢
我唯一需要的是在多段线上创建新的顶点，其中最近的点如图所示。您建议如何修改？
非常感谢。非常感谢你的帮助 我更新了代码。。试试看。记得给服务员小费。
最后一件事。希望你没有厌倦
如何在图片上显示的多段线上创建新顶点？
谢谢 查看您的个人信息。。我已经解决了这个问题。
页:
[1]