[源码]勘丈地籍图绘图程序

004 发表于 2014-5-11 02:32:05

本帖最后由 004 于 2014-5-11 02:43 编辑

;;;勘丈地籍图绘图程序
;;;wkq00420140420
(setvar "cmdecho" 0)

(if (setq layerE (tblobjname "layer" "004YS"))
(progn
(setq layerEL (entget layerE))
(setq ass62 (assoc 62 layerEL))
(if(/= 4 (cdr ass62))
   (progn (setq layerEL (subst (cons 62 4) ass62 layerEL))
   (entmod layerEL)
   )
)
)
(entmake (list '(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(70 . 0)
'(6 . "Continuous")
'(62 . 4)
(cons 2 "004YS")
)
)
)
;;;(if (setq layerE (tblobjname "layer" "004YS"))
;;;(progn
;;; (setq layerEL (entget layerE))
;;; (if(eq nil (setq ass62 (assoc 62 layerEL)))
;;;    (progn
;;;(setq el
;;;       (cons
;;; (nth 0 layerEL)
;;; (cons (nth 1 layerEL)
;;;       (cons (cons 62 4) (cddr layerEl))
;;; )
;;;       )
;;;)
;;;(entmod el)
;;;    )
;;;    (if (/= 4 (cdr ass62))
;;;(progn (setq layerEL (subst (cons 62 4) ass62 layerEL))
;;;       (entmod layerEL)
;;;)
;;;    )
;;; )
;;;)
;;;)
(if (setq layerE (tblobjname "layer" "004FJ"))
(progn
(setq layerEL (entget layerE))
(setq ass62 (assoc 62 layerEL))
(if(/= 5 (cdr ass62))
   (progn (setq layerEL (subst (cons 62 5) ass62 layerEL))
   (entmod layerEL)
   )
)
)
(entmake (list '(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(70 . 0)
'(6 . "Continuous")
'(62 . 5)
(cons 2 "004FJ")
)
)
)

(if (setq layerE (tblobjname "layer" "004GFJ"))
(progn
(setq layerEL (entget layerE))
(setq ass62 (assoc 62 layerEL))
(if(/= 2 (cdr ass62))
   (progn (setq layerEL (subst (cons 62 2) ass62 layerEL))
   (entmod layerEL)
   )
)
)

(entmake (list '(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(70 . 0)
'(6 . "Continuous")
'(62 . 2)
(cons 2 "004GFJ")
)
)
)

(if (setq layerE (tblobjname "layer" "004QSX"))
(progn
(setq layerEL (entget layerE))
(setq ass62 (assoc 62 layerEL))
(if(/= 1 (cdr ass62))
   (progn (setq layerEL (subst (cons 62 1) ass62 layerEL))
   (entmod layerEL)
   )
)
)

(entmake (list '(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(70 . 0)
'(6 . "Continuous")
'(62 . 1)
(cons 2 "004QSX")
)
)
)

(if (setq layerE (tblobjname "layer" "004权利人"))
(progn
(setq layerEL (entget layerE))
(setq ass62 (assoc 62 layerEL))
(if(/= 4 (cdr ass62))
   (progn (setq layerEL (subst (cons 62 4) ass62 layerEL))
   (entmod layerEL)
   )
)
)
(entmake (list '(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(70 . 0)
'(6 . "Continuous")
'(62 . 4)
(cons 2 "004权利人")
)
)
)

(if (setq layerE (tblobjname "layer" "004序号"))
(progn
(setq layerEL (entget layerE))
(setq ass62 (assoc 62 layerEL))
(if(/= 4 (cdr ass62))
   (progn (setq layerEL (subst (cons 62 4) ass62 layerEL))
   (entmod layerEL)
   )
)
)
(entmake (list '(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(70 . 0)
'(6 . "Continuous")
'(62 . 4)
(cons 2 "004序号")
)
)
)

(defun c:QD ()
(princ "\n权属线起点")
(setq ss (cadr (ssgetfirst)))
(if (and ss (= (setq ssn (sslength ss)) 1))
(progn
   (setq e (ssname ss 0))
   (setq el (entget e))
   (setq pt (cdr (assoc 10 el)))
   (setq pt1 (polar pt (* 0.25 pi) 1))
   (setq pt2 (polar pt (* 1.25 pi) 1))
   (setq pt3 (polar pt (* 0.75 pi) 1))
   (setq pt4 (polar pt (* 1.75 pi) 1))
   (grdraw pt1 pt2 1)
   (grdraw pt3 pt4 1)
)
(progn
   (setq e (car (entsel "\n选择权属线")))
   (setq el (entget e))
   (setq pt (cdr (assoc 10 el)))
   (setq pt1 (polar pt (* 0.25 pi) 1))
   (setq pt2 (polar pt (* 1.25 pi) 1))
   (setq pt3 (polar pt (* 0.75 pi) 1))
   (setq pt4 (polar pt (* 1.75 pi) 1))
   (grdraw pt1 pt2 -1)
   (grdraw pt3 pt4 -1)
)
)
(princ)
)

(defun c:0 (/ ss)
(setq ss (cadr (ssgetfirst)))
(if ss
'()
(progn
   (princ "\n选择要归到0层的对象：")
   (setq ss (ssget))
)
)
(if ss
(progn (command "change" ss "" "p" "la" "0" "")
(princ "\n对象已归到0层：")
)
)
(princ)
)

(defun c:sx ()
(setvar "SORTENTS" 0)
(if (setq ss (ssget "x" '((8 . "0"))))
(command "draworder" ss "" "B")
)
(if (setq ss (ssget "x" '((8 . "JZD"))))
(command "draworder" ss "" "B")
)
(if (setq ss (ssget "x" '((8 . "*影像*"))))
(command "draworder" ss "" "B")
)
(princ)
)

(defun c:0s ()
(if (setq ss (ssget "x" '((8 . "0"))))
(command "draworder" ss "" "F")
)
)

(defun c:QSS ()
(setvar "SORTENTS" 0)
(if (setq ss (ssget "x" '((8 . "QSX"))))
(command "draworder" ss "" "F")
)
(princ)
)

(defun c:QSX ()
(setvar "SORTENTS" 0)
(if (setq ss (ssget "x" '((8 . "QSX"))))
(command "draworder" ss "" "B")
)
(if (setq ss (ssget "x" '((8 . "*影像*"))))
(command "draworder" ss "" "B")
)
(princ)
)

(defun c:YS (/ ss)
(princ "\n檐水：")
(setq ss (cadr (ssgetfirst)))
(if (and ss (< (setq ssn (sslength ss)) 3))
(progn
   (command "PUTP" "c" "143132" ss "")
)
(progn
   (command "DD" "143132")
)
)
(princ)
)

(defun c:FJ (/ ss)
(princ "\n房基：")
(setq ss (cadr (ssgetfirst)))
(if (and ss (< (setq ssn (sslength ss)) 3))
(progn
   (command "PUTP" "c" "143133" ss "")
)
(progn
   (command "DD" "143133")
)
)
(princ)
)

(defun c:QS (/ ss)
(princ "\n权属线：")
(setq ss (cadr (ssgetfirst)))
(if (and ss (= (setq ssn (sslength ss)) 1))
(progn
   (command "PUTP" "c" "143134" ss "")
)
(progn
   (command "DD" "143134")
)
)
(princ)
)

(defun c:DK (/ ss)
(princ "\n加固坎：")
(setq ss (cadr (ssgetfirst)))
(if (and ss (< (setq ssn (sslength ss)) 3))
(progn
   (command "PUTP" "c" "143135" ss "")
)
(progn
   (command "DD" "143135")
)
)
(princ)
)

(defun c:YZ (/ ss)
(princ "\n雨罩：")
(setq ss (cadr (ssgetfirst)))
(if (and ss (< (setq ssn (sslength ss)) 3))
(progn
   (command "PUTP" "c" "143130" ss "")
)
(command "DD" "143130")
)
(princ)
)

f4800 发表于 2020-11-1 11:02:20

[源码]勘丈地籍图绘图程序

wm123456 发表于 2020-12-21 14:40:24

感谢分享好东西

xuhaiguang 发表于 2020-1-13 14:00:40

感谢分享好东西

gzxl 发表于 2014-5-11 08:00:11

一早上明经见到有测绘的好源码，顶顶顶

杜阳发表于 2014-5-11 08:19:34

专业测绘人人员终于有大作了支持强烈支持

树櫴希德 发表于 2014-5-12 14:34:26

大侠，能根据三角网文件（图形或者数据）查询指定点坐标高程吗

wkq004 发表于 2014-5-12 21:26:14

树櫴希德发表于 2014-5-12 14:34
大侠，能根据三角网文件（图形或者数据）查询指定点坐标高程吗

gzxl有这方面的源码，看他发过的主题

wkq004 发表于 2014-5-12 21:29:12

本帖最后由 wkq004 于 2014-5-12 21:30 编辑

树櫴希德发表于 2014-5-12 14:34
大侠，能根据三角网文件（图形或者数据）查询指定点坐标高程吗

高程点内插程序(已更新)

http://bbs.mjtd.com/forum.php?mod=viewthread&tid=100043&extra=&mobile=yes

jxy308 发表于 2014-12-21 22:40:30

是个好东西得支持

ynpxqjlb 发表于 2020-1-13 17:06:55

感谢分享！！！！

页: [1] 2

明经CAD社区's Archiver

[源码]勘丈地籍图绘图程序