修改仓老师代码，不开图批量拟合二维多段线等高线
修改仓老师代码，不开图批量拟合二维多段线等高线;(assoc 0(entget(car(entsel))'("*")) )
(defun try-getFolder (msg / WinShell shFolder path catchit)
(setq winshell (vlax-create-object "Shell.Application"))
(setq shFolder (vlax-invoke-method WinShell 'BrowseForFolder 0 msg 1))
(setq catchit (vl-catch-all-apply
'(lambda ()
(setq shFolder (vlax-get-property shFolder 'self))
(setq path (vlax-get-property shFolder 'path))
)
)
)
(if (vl-catch-all-error-p catchit)
nil
path
)
)
(defun c:plind123 (/ BANBEN DBX PATH FILES DH STR PT0 PT1 I DWGNAME temp ob obj)
(vl-load-com)
;(setvar "cmdecho" 0)
(initget 1 "D S F 3S") (setq temp (getkword "(D)不拟合/(S)2次样条拟合/(3S)3次样条拟合/(F)圆弧拟合] <F>"))
(setq banben (substr (getvar "acadver") 1 2))
;版本2004-2006返回16,2007-2009返回17,2010-2012返回18,2013返回19
(setq dbx (Vlax-Get-Or-Create-Object (strcat "ObjectDBX.AxDbDocument." banben)))
(setq path (strcat (try-getFolder "\n 选择图纸所在文件夹名称：") "\\"));文件夹路径
(setq files (vl-directory-files path "*.dwg" 1)) ;获取所有文件名
(setq i -1)
(while (setq dwgname (nth (setq i (1+ i)) files))
(vlax-invoke-method dbx 'open (strcat path dwgname))
;;;;;;;;;;;;;;;;;;;;;;;;;;;
(vlax-for ob (Vlax-Get dbx 'ModelSpace) ;历遍模型空间集合;;;;;;;;;;;;;;;;;;;;;;;;
; (vlax-3d-point '(100 100 100))
(cond((equal (type ob) 'ENAME) (setq obj (vlax-ename->vla-object ob)))
(T (setq obj ob)))
(if(and (= (vla-get-Layer Obj) "DGX" )(= (vlax-get-property obj 'ObjectName) "AcDb2dPolyline") )
(progn
(cond
((= temp "D") (vla-put-Type obj0) (vla-Update obj ) )
((= temp "F") (vla-put-Type obj1) (vla-Update obj ))
((= temp "S") (vla-put-Type obj2) (vla-Update obj ))
((= temp "3S") (vla-put-Type obj3) (vla-Update obj ))
)
)
)
;(vla-move ob (vlax-3d-point pt0)(vlax-3d-point pt1))
);;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(vlax-invoke-method dbx 'SaveAs (strcat path dwgname))
);;;;;;;;;;;;;;;;;;;;;;;;
(vlax-release-object dbx);释放
;(setvar "cmdecho" 1)
(princ)
)
;(princ "\n 不开图地形图平移代号坐标运行命令：pydhzb")
;(princ "\n 如有疑问或者好的建议请联系老仓测绘上班记QQ:729292370")
(princ)
;(vlax-get-property (vlax-ename->vla-object (car(entsel))) 'ObjectName)
;;(vla-get-Layer (vlax-ename->vla-object (car(entsel))))
;(vlax-get-property (vlax-ename->vla-object (car(entsel))) ''EntityType)
;(vl-cmdf "CONVERTPOLY" "h" (vlax-vla-object->ename (vlax-ename->vla-object (car(entsel)) )) "" )
我个人喜欢写成这样，感觉代码可读性好些, 0 1 2 3 时间久了都不知道是什么了。
(vla-put-Type obj acSimplePoly)
(vla-put-Type obj acFitCurvePoly)
(vla-put-Type obj acQuadSplinePoly)
(vla-put-Type obj acCubicSplinePoly) gzxl 发表于 2023-6-22 09:43
我个人喜欢写成这样，感觉代码可读性好些, 0 1 2 3 时间久了都不知道是什么了。
(vla-put-Type obj acSimp ...
请问大神 dbx 不能使用CAD命令吗？如(vl-cmdf "convertpoly "(vlax-vla-object->enameob) "")
在(vlax-for )下面 树櫴希德 发表于 2023-6-22 09:55
请问大神 dbx 不能使用CAD命令吗？如(vl-cmdf "convertpoly "(vlax-vla-object->enameob) "")
在(vl ...
【话唠】t18-13nil(158675958)10:06:24
dbx只是数据库，没有doc环境
【话唠】t18-13nil(158675958)10:06:32
不能用命令
管理员】LLSheng_73■■■
相当于某个时候对你点名一次，至于你来没来都没事，来了不会和你互动，没来也不会找你也不找人替代你 ;二维多段线与多段线互相转换
(defun c:tesaa ( / &k1 &kw1 a10 a42 a70 a8 a90 ent ss1 ss2 ss5 x)
(vl-load-com)
(princ "\n请选择对象")
(if (setq &kw1 (ssget '((0 . "*POLYLINE"))))
(progn;;1
(setq ss1 '())
(while (setq &k1 (ssname &kw1 0))
(setq &kw1 (ssdel &k1 &kw1) ss1 (cons &k1 ss1))
);while
(if (setq ss2 (vl-remove-if-not '(lambda (x) (= (cdr (assoc 0 (entget x))) "POLYLINE")) ss1))
(progn;;2
(setq ss1 (vl-remove-if '(lambda (x) (member x ss2)) ss1))
(while (setq ent (car ss2))
(setq ss2 (cdr ss2) ss5 (s1712081 ent))
(if (vlax-curve-isClosed ent) (setq a70 '(70 . 1)) (setq a70 '(70 . 0)))
(setq a90 (cons 90 (length ss5))
ss5 (apply 'append ss5)
a8 (assoc 8 ss5)
a10 (vl-remove-if-not '(lambda (x) (member (car x) '(10 42))) ss5)
ss5 (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") a8 '(100 . "AcDbPolyline") a90 a70 '(38 . 0)) a10)
)
(entmake ss5)
(entdel ent)
);while
);progn;2
);if;2
(if (car ss1)
(progn
(while (setq ent (car ss1))
(setq ss1 (cdr ss1) ss5 (entget ent))
(setq a70 (assoc 70 ss5)
a8 (assoc 8 ss5)
a10 (vl-remove-if-not '(lambda (x) (= (car x) 10)) ss5)
a42 (vl-remove-if-not '(lambda (x) (= (car x) 42)) ss5)
ss5 (mapcar '(lambda (x) (append (list '(0 . "VERTEX") '(100 . "AcDbEntity") '(67 . 0) a8 '(100 . "AcDbVertex") '(100 . "AcDb2dVertex")) x))
(mapcar 'cons a10 (mapcar '(lambda (x) (list x a70)) a42)))
)
(s1712082 ss5 a70 a8)
(entdel ent)
);while
)
);if;3
);progn;1
);if;1
(princ)
)
;entmake生成二维多段线
(defun s1712082 (ss5 a70 a8 / a70 a8 ed ss5)
(entmake (list'(0 . "POLYLINE") '(100 . "AcDbEntity") a8 '(100 . "AcDb2dPolyline") a70))
(while (setq ed (car ss5))
(setq ss5 (cdr ss5))
(entmake ed)
)
(entmake '((0 . "SEQEND")))
)
;提取二维多段线数据
(defun s1712081 (e / e ed pts)
(if (eq (cdr (assoc 0 (entget e))) "POLYLINE")
(progn
(while (and (setq e (entnext e))
(/= (cdr (assoc 0 (setq ed (entget e)))) "SEQEND")
)
(setq pts (cons ed pts))
)
)
)
(reverse pts)
)
本帖最后由 树櫴希德 于 2023-7-18 22:53 编辑
不开图批量等高线lwpolyto二维poly 并拟合，可以保留南方代码了"south"
;(setq startPnt(vlax-make-safearray vlax-vbDouble '(0 . 2)))
;(vlax-safearray-fill startPnt st_point)
;(setq endPnt(vlax-make-safearray vlax-vbDouble '(0 . 2)))
;(vlax-safearray-fill endPnt p3)
;(setq Line_Obj(vla-AddLine mSpace startPnt endPnt))
;(vl-load-com )
;(vlax-dump-object(vlax-ename->vla-object(car(entsel)))T) (entget(car(entsel))'("*"))
;(setq xtype (vlax-make-safearray vlax-vbvariant '(0 . 1)))
;(setq xtype (vlax-make-safearray vlax-vbInteger '(0 . 1)))
;(setq xdata (vlax-make-safearray vlax-vbvariant '(0 . 1)))
; (vlax-safearray-fill xtype '(1001 1000))
;(vlax-safearray-fill xdata '("loop" "loop"))
; (vla-setxdata (vlax-ename->vla-object(car(entsel))) xtype xdata)
;(-3 ("loop" (1000 . "loop")))
(defun c:GetX (/ xType XData)
(vl-load-com)
(setq appid "south")
(setq vlaobj (car(entsel"\\n）选择环：")))
(cond ((= (type vlaObj) 'ENAME) (SETQ vlaObj (vlax-ename->vla-object vlaObj)))
((= (type vlaObj) 'VLA-OBJECT) (SETQ vlaObj vlaObj))
(t (setq olderror *error*)))
(vla-getxdata vlaObj appid 'xType 'xData) ;；此处监视时，其值为nil
(mapcar '(lambda (key val) (cons key (VLAX-VARIANT-value val)))
(vlax-safearray->list xType)
(vlax-safearray->list xData)
)
)
;(VLAX-VARIANT-value (vlax-safearray->list xData))
; (apply 'append(mapcar '(lambda (x) (list (cdr x))) (mapcar '(lambda (key val) (cons key (VLAX-VARIANT-value val)))(vlax-safearray->list xType)(vlax-safearray->list xData)))) ;;; ("SOUTH" "202101")
;(apply 'append '(("SOUTH") ("202101")))
; (mapcar '(lambda (x) (append (cdr x))) '((1001 . "SOUTH") (1000 . "202101")) )
;注意APPID是一个已经注册的应用程序名称..是REGAPP以后的名称,是字符串.
(defun zhnfbm (oldobj newobj / xTypexDataxType1 xData1)
(vl-load-com)
(setq appid "south")
(vla-getxdata oldobj appid 'xType 'xData) ;；此处监视时，其值为nil
(setq xType1 (vlax-safearray->list xType) )
(setq xData1 (apply 'append(mapcar '(lambda (x) (list (cdr x))) (mapcar '(lambda (key val) (cons key (VLAX-VARIANT-value val)))(vlax-safearray->list xType)(vlax-safearray->list xData)))) )
(setq xtype (vlax-make-safearray vlax-vbInteger '(0 . 1)))
(setq xdata (vlax-make-safearray vlax-vbvariant '(0 . 1)))
(vlax-safearray-fill xtype xType1)
(vlax-safearray-fill xdata xData1)
(vla-setxdata newobj xtype xdata)
)
;; (zhnfbm (vlax-ename->vla-object(car(entsel)))(vlax-ename->vla-object(car(entsel))))
;(lw2pl (car(entsel))) (entget (car(entsel))'("*"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun vxs (e / i v lst ppp)
(setq i 0)
(while
(setq v (vlax-curve-getpointatparam e (setq i (1+ i))))
(setq lst (cons v lst))
)
(setq ppp (reverse lst) )
(append (list(vlax-curve-getpointatparam e 0)) ppp )
);;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun mk222 ( en mSpace/ plst plst1 points mSpace )
(vl-load-com)
;(vla-AddPolyline (vxs(car(entsel)))) (vla-addlightweightpolyline (vxs(car(entsel))))
;(setq plst nil)
(setq plst (vxs en) )
(setq plst1 (apply 'append plst
) )
(setq points
(vlax-make-safearray
vlax-vbdouble
(cons 0 (- (length plst1) 1))
)
)
;(vlax-safearray-fill points plst1)
(setq points (vlax-safearray-fill points plst1) )
(vlax-invoke-method mSpace 'AddPolyline points)
;(vla-AddPolyline ms points )
;(princ)
)
;(setq ms
; (vla-get-ModelSpace
; (vla-get-ActiveDocument
; (vlax-get-acad-object)
; )
; )
;)
;(lw2pl (car(entsel))) (entget (car(entsel))'("*"))
;;;;;;;;;;;;;;;;;;;;;;;
;(assoc 0(entget(car(entsel))'("*")) )
(defun try-getFolder (msg / WinShell shFolder path catchit)
(setq winshell (vlax-create-object "Shell.Application"))
(setq shFolder (vlax-invoke-method WinShell 'BrowseForFolder 0 msg 1))
(setq catchit (vl-catch-all-apply
'(lambda ()
(setq shFolder (vlax-get-property shFolder 'self))
(setq path (vlax-get-property shFolder 'path))
)
)
)
(if (vl-catch-all-error-p catchit)
nil
path
)
)
(defun c:mk22 (/ BANBEN DBX PATH FILES DH STR PT0 PT1 I DWGNAME temp ob obj mSpace kd ys tc biaogao kdobj bgobj lyobj ysobj objobj)
(vl-load-com)
;(setvar "cmdecho" 0)
(initget 1 "D S F 3S") (setq temp (getkword "(D)不拟合/(S)2次样条拟合/(3S)3次样条拟合/(F)圆弧拟合] <F>"))
(setq banben (substr (getvar "acadver") 1 2))
;版本2004-2006返回16,2007-2009返回17,2010-2012返回18,2013返回19
(setq dbx (Vlax-Get-Or-Create-Object (strcat "ObjectDBX.AxDbDocument." banben)))
(setq path (strcat (try-getFolder "\n 选择图纸所在文件夹名称：") "\\"));文件夹路径
(setq files (vl-directory-files path "*.dwg" 1)) ;获取所有文件名
(setq i -1)
(while (setq dwgname (nth (setq i (1+ i)) files))
(vlax-invoke-method dbx 'open (strcat path dwgname))
;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setq mSpace (Vlax-Get dbx 'ModelSpace)) (vla-SaveAs dbx (strcat path dwgname) )
(vlax-for obmSpace ;历遍模型空间集合;;;;;;;;;;;;;;;;;;;;;;;;
; (vlax-3d-point '(100 100 100))
;(vla-save dbx)
(cond((equal (type ob) 'ENAME) (setq obj (vlax-ename->vla-object ob)))
(T (setq obj ob)))
;(setq circCenter (vlax-3d-point '(2.0 2.0 0.0)))
;(vlax-invoke-method mspace 'AddCircle circCenter 3.0)
(if(and (= (vla-get-Layer Obj) "DGX" )(= (vlax-get-property obj 'ObjectName) "AcDbPolyline") )
(progn
;(Setq ms (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument) 'ModelSpace ))
; (mk2d (vlax-vla-object->ename Obj) (Vlax-Get dbx 'ModelSpace))
;(vla-put-color obj 1)
;(mk222 OBJ mSpace)
(setq kd (vlax-get-property Obj'ConstantWidth))
(setq ys (vlax-get-property Obj'color))
(setq tc (vlax-get-property Obj'Layer))
(setq biaogao (vlax-get-property Obj'Elevation))
;;;;;;;;;;;;
(setq objobj (mk222 OBJ mSpace))
(vla-put-ConstantWidth objobj kd)(vla-put-Elevation objobj biaogao) (vla-put-layer objobj tc) (vla-put-color objobj ys)
(cond
((= temp "D") (vla-put-Type objobjacSimplePoly) (vla-Update objobj ) )
((= temp "F") (vla-put-Type objobjacFitCurvePoly) (vla-Update objobj ))
((= temp "S") (vla-put-Type objobjacQuadSplinePoly) (vla-Update objobj ))
((= temp "3S") (vla-put-Type objobjacCubicSplinePoly) (vla-Update objobj ))
)
(zhnfbm objobjobj)
(vla-delete obj )
;(setq kdobj (vla-put-ConstantWidth (mk222 OBJ mSpace) kd))
;(setq bgobj (vla-put-Elevation kdobj biaogao))
;(setq lyobj (vla-put-layer bgobj tc) )
;(setq ysobj (vla-put-color lyobj ys) )
;(vla-put-color (vla-put-layer (vla-put-Elevation (vla-put-ConstantWidth (mk222 OBJ mSpace) kd) biaogao)tc) ys)
;(vlax-put-property (vlax-put-property (vlax-put-property (vlax-put-property (mk222 OBJ mSpace) 'ConstantWidth kd) 'Layer tc) 'color ys) 'Elevation biaogao)
; (vla-put-Color (mk222 OBJ mSpace) 1)
;(lw2pl (vlax-vla-object->ename Obj))
)
)
;(vla-move ob (vlax-3d-point pt0)(vlax-3d-point pt1))
);;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(vlax-invoke-method dbx 'SaveAs (strcat path dwgname))
);;;;;;;;;;;;;;;;;;;;;;;;
(vlax-release-object dbx);释放
;(setvar "cmdecho" 1)
(princ)
)
;(princ "\n 不开图地形图平移代号坐标运行命令：pydhzb")
;(princ "\n 如有疑问或者好的建议请联系老仓测绘上班记QQ:729292370")
;(princ)
树櫴希德 发表于 2023-6-23 15:34
南方等高线多段线转二维多段线非拟合 非圆弧
;entmake生成二维多段线
(defun s1712082 (ss5 a38 a-3 a62 a8 / a70 a8 ed ss5 )
(entmake (list'(0 . "POLYLINE") '(100 . "AcDbEntity") a8 '(100 . "AcDb2dPolyline") '(70 . 0) a38 a-3 a62))
(while (setq ed (car ss5))
(setq ss5 (cdr ss5))
(entmake ed)
)
(entmake '((0 . "SEQEND")))
)
(defunlw2pl(ent /ss5 a70 a8 a10 a42 a70 a40 a41 a38 a-3 a62) ;ss5 a70 a8 a10 a42 a70
;(setq ent (car ss1))
(setqss5 (entget ent '("*") ))
(setq a70 (assoc 70 ss5)
a8 (assoc 8 ss5)
a38 (assoc 38 ss5)
a-3 (assoc -3 ss5)
a62 (assoc 62 ss5)
a10 (vl-remove-if-not '(lambda (x) (= (car x) 10)) ss5)
a40 (vl-remove-if-not '(lambda (x) (= (car x) 40)) ss5)
a41 (vl-remove-if-not '(lambda (x) (= (car x) 41)) ss5)
a42 (vl-remove-if-not '(lambda (x) (= (car x) 42)) ss5)
ss5 (mapcar '(lambda (x) (append (list '(0 . "VERTEX") '(100 . "AcDbEntity") '(67 . 0) a8 '(100 . "AcDbVertex") '(100 . "AcDb2dVertex")) x))
(mapcar 'cons a41 (mapcar 'cons a40 (mapcar 'cons a10 (mapcar '(lambda (x) (list x '(70 . 0))) a42)))) )
)
(s1712082 ss5 a38 a-3 a62 a8)
; (entdel ent)
(princ )
)
;(lw2pl (car(entsel))) (entget (car(entsel))'("*"))
(setq jb (cdr (assoc 5 (entget (car(entsel ""))))))
(setq newobj (vlax-ename->vla-object (car(entsel ""))))
(regapp "ZXCAD")
(setq xtype (vlax-make-safearray vlax-vbInteger '(0 . 4)))
(setq xdata (vlax-make-safearray vlax-vbvariant '(0 . 4)))
(vlax-safearray-fill xtype (list 1001 1000 1002 1005 1002))
(vlax-safearray-fill xdata (list "ZXCAD" "1005的值是圆的句柄值,当用户复制到新图纸的时候cad自动更新1005的值为圆的新句柄" "{" jb "}") )
(vla-setxdata newobj xtype xdata)
(vlax-for ob (Vlax-Get dbx 'ModelSpace) ;历遍模型空间集合
出现异常。
参数类型错误: VLA 对象集合: ""是什么原因 我上传一个二维多段线lwPLINETYPE→LINETYPE，同时其标高值还能继续保留的在“;修改仓老师代码，不开图批量拟合二维多段线等高线;http://bbs.mjtd.com/forum.php?mo ... &fromuid=418631;(出处: 明经CAD社区);树櫴希德发表于 2023-6-23 10:28基础上升级而成！
http://bbs.mjtd.com/forum.php?mo ... 27&page=1#pid987799
页:
[1]