（完成）[编程申请]：求画用地红线图,自动标注的程序

homexpvip · 发表于 2004-3-24 19:07:05

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

我在规划管理部门工作，经常要画用地红线图，求程序：只需用鼠标点击几个图上的点，可自动标出点坐标，自动按顺序用红线连接，并标出每段红线的长度，并计算面积。
狂谢！！我的homexpvip@163.com

eachy · 发表于 2004-3-25 12:16:25

最初由 homexpvip 发布
[B]我在规划管理部门工作，经常要画用地红线图，求程序：只需用鼠标点击几个图上的点，可自动标出点坐标，自动按顺序用红线连接，并标出每段红线的长度，并计算面积。
狂谢！！我的homexpvip@163.com [/B]

下载附件释放到 \XDSoft\Lisp 目录下，加载 plan1.lsp

;|
功能：循环拾取点后，绘制封闭曲线、标注分段线长、各点坐标、积
适用范围：规划
注意：字体高度(textsize)、绘图单位(m & mm)请自行设定
|;
(if (not $xdtb_globle_scale)
(setq $xdtb_globle_scale 1.0)
)
($xdrx_load "xdlsp.lsp")
(load "hzbbz.fas")
(defun c:XDTB_DRedLn (/ area e e1 len pcen pt pts ss box xmid ymid)
(xdrx_begin)
(xdrx_sysvar_push "osmode")
(xdrx_ucson)
(while (setq pt (getpoint "\n边界点: "))
($xdlsp_grdraw pt)
(setq pts (cons pt pts))
(if (> (length pts) 1)
(grdraw (car pts) (cadr pts) 1 1)
)
)
(redraw)
(setq e1 (entlast)
ss (ssadd)
)
(if (>= (length pts) 2)
(progn
(setq len (length pts)
pts ($XDLSP_Points_Close pts)
)
($XDLSP_Draw_Pline pts t)
(setq e (entlast)
ss (ssadd e ss)
)
(mapcar '(lambda (x y)
(vl-cmdf ".text"
(list (/ (+ (car x) (car y)) 2)
(/ (+ (cadr x) (cadr y)) 2)
'0.
)
""
($xdlsp_rtd ($xdlsp_angle_format (angle x y)))
(rtos (distance x y) 2 3)
)
(ssadd (entlast) ss)
)
(reverse (cdr (reverse pts)))
(cdr pts)
)
(if (not (equal e e1))
(progn
(setq area (apply 'xdrx_parea pts))
(if (not (zerop area))
(progn (vl-cmdf ".text"
"j"
"mc"
(list (/ (apply '+ (mapcar 'car pts)) len)
(/ (apply '+ (mapcar 'cadr pts)) len)
'0.
)
""
0.
(strcat "总面积: " (rtos area 2 3))
)
(ssadd (entlast) ss)
)
)
)
)
(setq box (apply 'xdrx_pointsbox pts)
xmid (/ (+ (caar box) (caadr box)) 2)
ymid (/ (+ (cadar box) (cadr (last box))) 2)
)
(mapcar
'(lambda (p)
(cond
((and (< (car p) xmid)
(< (cadr p) ymid)
)
(ea:hzbbz p
(polar p (* -0.75 pi) (* 10. $xdtb_globle_scale))
0.
t
"X"
t
)
)
((and (<= (car p) xmid)
(>= (cadr p) ymid)
)
(ea:hzbbz p
(polar p (* 0.75 pi) (* 10. $xdtb_globle_scale))
0.
t
"X"
t
)
)
((and (>= (car p) xmid)
(< (cadr p) ymid)
)
(ea:hzbbz p
(polar p (* -0.25 pi) (* 10. $xdtb_globle_scale))
0.
nil
"X"
t
)
)
((and (>= (car p) xmid)
(>= (cadr p) ymid)
)
(ea:hzbbz p
(polar p _pi4 (* 10. $xdtb_globle_scale))
0.
nil
"X"
t
)
)
(t)
)
(ssadd (entlast) ss)
)
(cdr pts)
)
(if ss
(xdrx_group_make "*" ss)
)
)
)
(xdrx_ucsoff)
(xdrx_sysvar_pop)
(xdrx_end)
(princ)
)

;| 
功    能：循环拾取点后，绘制封闭曲线、标注分段线长、各点坐标、积 
适用范围：规划 
 
注    意：字体高度(textsize)、绘图单位(m & mm)请自行设定 
|; 
(if (not $xdtb_globle_scale) 
  (setq $xdtb_globle_scale 1.0) 
) 
($xdrx_load "xdlsp.lsp") 
(load "hzbbz.fas") 
(defun c:XDTB_DRedLn (/ area e e1 len pcen pt pts ss box xmid ymid) 
  (xdrx_begin) 
  (xdrx_sysvar_push "osmode") 
  (xdrx_ucson) 
  (while (setq pt (getpoint "\n边界点: ")) 
    ($xdlsp_grdraw pt) 
    (setq pts (cons pt pts)) 
    (if        (> (length pts) 1) 
      (grdraw (car pts) (cadr pts) 1 1) 
    ) 
  ) 
  (redraw) 
  (setq        e1 (entlast) 
        ss (ssadd) 
  ) 
  (if (>= (length pts) 2) 
    (progn 
      (setq len        (length pts) 
            pts        ($XDLSP_Points_Close pts) 
      ) 
      ($XDLSP_Draw_Pline pts t) 
      (setq e  (entlast) 
            ss (ssadd e ss) 
      ) 
      (mapcar '(lambda (x y) 
                 (vl-cmdf ".text" 
                          (list        (/ (+ (car x) (car y)) 2) 
                                (/ (+ (cadr x) (cadr y)) 2) 
                                '0. 
                          ) 
                          "" 
                          ($xdlsp_rtd ($xdlsp_angle_format (angle x y))) 
                          (rtos (distance x y) 2 3) 
                 ) 
                 (ssadd (entlast) ss) 
               ) 
              (reverse (cdr (reverse pts))) 
              (cdr pts) 
      ) 
      (if (not (equal e e1)) 
        (progn 
          (setq area (apply 'xdrx_parea pts)) 
          (if (not (zerop area)) 
            (progn (vl-cmdf ".text" 
                            "j" 
                            "mc" 
                            (list (/ (apply '+ (mapcar 'car pts)) len) 
                                  (/ (apply '+ (mapcar 'cadr pts)) len) 
                                  '0. 
                            ) 
                            "" 
                            0. 
                            (strcat "总面积: " (rtos area 2 3)) 
                   ) 
                   (ssadd (entlast) ss) 
            ) 
          ) 
        ) 
      ) 
      (setq box         (apply 'xdrx_pointsbox pts) 
            xmid (/ (+ (caar box) (caadr box)) 2) 
            ymid (/ (+ (cadar box) (cadr (last box))) 2) 
      ) 
      (mapcar 
        '(lambda (p) 
           (cond 
             ((and (< (car p) xmid) 
                   (< (cadr p) ymid) 
              ) 
              (ea:hzbbz        p 
                        (polar p (* -0.75 pi) (* 10. $xdtb_globle_scale)) 
                        0. 
                        t 
                        "X" 
                        t 
              ) 
             ) 
             ((and (<= (car p) xmid) 
                   (>= (cadr p) ymid) 
              ) 
              (ea:hzbbz        p 
                        (polar p (* 0.75 pi) (* 10. $xdtb_globle_scale)) 
                        0. 
                        t 
                        "X" 
                        t 
              ) 
             ) 
             ((and (>= (car p) xmid) 
                   (< (cadr p) ymid) 
              ) 
              (ea:hzbbz        p 
                        (polar p (* -0.25 pi) (* 10. $xdtb_globle_scale)) 
                        0. 
                        nil 
                        "X" 
                        t 
              ) 
             ) 
             ((and (>= (car p) xmid) 
                   (>= (cadr p) ymid) 
              ) 
              (ea:hzbbz        p 
                        (polar p _pi4 (* 10. $xdtb_globle_scale)) 
                        0. 
                        nil 
                        "X" 
                        t 
              ) 
             ) 
             (t) 
           ) 
           (ssadd (entlast) ss) 
         ) 
        (cdr pts) 
      ) 
      (if ss 
        (xdrx_group_make "*" ss) 
      ) 
    ) 
  ) 
  (xdrx_ucsoff) 
  (xdrx_sysvar_pop) 
  (xdrx_end) 
  (princ) 
)

eachy · 发表于 2004-3-25 17:43:49

hzbbz.fas 使用说明

本程序生成一拾取点的当前UCS属性标注块
使用方法 (ea:hzbbz p1 p2 angle mark type xcontype)
参数： p1 -------- 标注点
p2 -------- 引线点
angle ----- 旋转角度
mark ----- 坐标数字相对引线的位置，以WCS下 Y 轴为界左侧 t 右侧 nil
type ----- “X” “A” 可选必须大写
xcontype -- 控制上下标注值是否交换
返回值：属性块实体名
说明：程序固定文字大小为2.5倍比例，比例由变量 $xdtb_globle_scale 控制，可
由外部设定，否则默认为 1.0

复制代码

homexpvip · 发表于 2004-3-25 20:39:27

thanks,虽然有些简陋，但足够了，剩下的就只用我做些简单的编辑了，狂谢*-*7

狂喜，星期天加班，其他人用整一星期画的用地红线图，我用此方法三小时完成，一共画了90张图。颇用点鸟枪换炮的感觉。*-*4 *-*6

账号		自动登录	找回密码
密码			立即注册

（完成）[编程申请]：求画用地红线图,自动标注的程序

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子

Re: [编程申请]：求画用地红线图,自动标注的程序

thank

浏览过的版块