社区 › AutoCAD与GIS测绘 › 修改仓老师代码，不开图批量拟合二维多段线等高线

树櫴希德 发表于 2023-6-21 22:06

修改仓老师代码，不开图批量拟合二维多段线等高线

修改仓老师代码，不开图批量拟合二维多段线等高线

;(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)) ))   "" )

gzxl 发表于 2023-6-22 09:43

我个人喜欢写成这样，感觉代码可读性好些, 0 1 2 3 时间久了都不知道是什么了。
(vla-put-Type obj acSimplePoly)
(vla-put-Type obj acFitCurvePoly)
(vla-put-Type obj acQuadSplinePoly)
(vla-put-Type obj acCubicSplinePoly)

树櫴希德 发表于 2023-6-22 09:55

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 10:14

树櫴希德 发表于 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■■■
相当于某个时候对你点名一次，至于你来没来都没事，来了不会和你互动，没来也不会找你也不找人替代你

树櫴希德 发表于 2023-6-23 10:28

;二维多段线与多段线互相转换
(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-6-23 15:34

本帖最后由 树櫴希德 于 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-7-4 15:58

树櫴希德 发表于 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))'("*"))

树櫴希德 发表于 2024-4-14 12:24

(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)

查看完整版本: 修改仓老师代码，不开图批量拟合二维多段线等高线