图框程序，加个标题求教

lxb9721 · 发表于 2015-8-28 10:27:50

本帖最后由 lxb9721 于 2015-8-28 12:08 编辑

;;;--------------------------------------------------------------
;;;功能：根据给定的左下角和右上角坐标绘制图框
;;;--------------------------------------------------------------
(defun c:mf ()
(setq oldosmode (getvar "osmode"))
(setq oldcmdecho (getvar "cmdecho"))
(setvar "osmode" 0) ;指定目标捕捉模式
(setvar "cmdecho" 0)
(command)
(command ".style" "TUKUANG" "文鼎CS细等线" 0 1 0 "N" "N")
(command)
;;;设定绘图比例尺
(setq
mapscale (getint "输入出图比例尺(1:1000输1;1:2000输2):>")
)
;;;设定初始图框
(print)
(setq selborder (entsel "请选择初始图框:>"))
(setq border (entget (car selborder)))
;;; (entdel (car selborder))
(setq index 0
xmin 999999999.9
ymin 999999999.9
xmax -999999999.9
ymax -999999999.9)
(repeat (length border)
(setq xy1 (nth index border))
(setq index (1+ index))
(if (= (car xy1 ) 10)
(progn
(setq x (cadr xy1)
y (caddr xy1))
(if (> xmin x) (setq xmin x))
(if (> ymin y) (setq ymin y))
(if (< xmax x) (setq xmax x))
(if (< ymax y) (setq ymax y)))
)
)
(setq leftdownx xmin)
(setq leftdowny ymin)
(setq leftdownxy (list leftdownx leftdowny))
(setq outleftdownxy
(list (- leftdownx (* 10 mapscale))
(- leftdowny (* 10 mapscale))
)
)
(print)
(setq rightupx xmax)
(setq rightupy ymax)
(setq rightupxy (list rightupx rightupy))
(setq outrightupxy
(list (+ rightupx (* 10 mapscale))
(+ rightupy (* 10 mapscale))
)
)
(print)
(if (= (strlen (rtos (fix leftdowny))) 8)
(progn
(setq zoneid (atof (substr (rtos (fix leftdowny)) 1 2)))
(setq centerm (* (/ (* zoneid 3) 180.0) pi))
)
(progn
(setq centerm (getreal "本投影带(3°带)中央经线........"))
(setq centerm (* (/ centerm 180.0) pi))
)
)
(print)
(entdel (car selborder))
(command "_rectang" leftdownxy rightupxy)
(command)
(setq inframe (entget (entlast)))
(setq inframe (subst (cons 8 "图框")
(assoc 8 inframe)
inframe))
(entmod inframe)
(command "_rectang" outleftdownxy outrightupxy)
(command)
(setq outframe (entget (entlast)))
(setq outframe (subst (cons 43 (* 2 mapscale))
(assoc 43 outframe)
outframe
)
)
(setq outframe (subst (cons 8 "图框")
(assoc 8 outframe)
outframe))
(entmod outframe)
;;; 取netdist的整数位置
(setq netdist (* 100 mapscale))
(setq intnetdistx (fix (/ leftdownx netdist)))
(setq intnetdisty (fix (/ leftdowny netdist)))
(setq f1x (* netdist intnetdistx))
(setq f1y (* netdist intnetdisty))
;;;绘制方格网
(setq index 1)
(setq crosswide (* 10 mapscale))
(setq no_y (1+ (fix (/ (- rightupy leftdowny) netdist))))
(setq no_x (1+ (fix (/ (- rightupx leftdownx) netdist))))
(setq fy 0)
(while (< fy (- rightupy netdist))
(setq index0 1)
(setq fy (+ f1y (* index netdist)))
(setq index (1+ index))
(setq fx 0)
(while (< fx (- rightupx netdist))
(setq fx (+ f1x (* index0 netdist)))
(drawcross fx fy mapscale)
(setq index0 (1+ index0))
)
)
;;;绘制边框上的格网点
;;; 下边
(setq fx 0)
(setq index0 1)
(setq test "aaaaaa")
(while (< fx (- rightupx netdist))
(setq fx (+ f1x (* index0 netdist)))
(drawcrossdown fx leftdowny mapscale)
(writex fx (- leftdowny (* 7.5 mapscale)) mapscale)
(setq textlong_fx (strlen (rtos fx 2 0)))
(setq textstr_fx (substr (rtos fx 2 0) 1 (- textlong_fx 4)))
(if (/= textstr_fx test)
(progn
(writexforeside fx leftdowny mapscale)
(setq test textstr_fx)
)
)
(setq index0 (1+ index0))
)
(writexforeside fx leftdowny mapscale)
;;; 上边
(setq fx 0)
(setq index0 1)
(setq test "aaaaaa")
(while (< fx (- rightupx netdist))
(setq fx (+ f1x (* index0 netdist)))
(drawcrossup fx rightupy mapscale)
(writex fx (+ rightupy (* 4.9 mapscale)) mapscale)
(setq textlong_fx (strlen (rtos fx 2 0)))
(setq textstr_fx (substr (rtos fx 2 0) 1 (- textlong_fx 4)))
(if (/= textstr_fx test)
(progn
(writexforeside
fx
(+ rightupy (* 12.4 mapscale))
mapscale
)
(setq test textstr_fx)
)
)
(setq index0 (1+ index0))
)
(writexforeside fx (+ rightupy (* 12.4 mapscale)) mapscale)
;;; 左边
(setq fy 0)
(setq index0 1)
(setq test "aaaaaa")
(while (< fy (- rightupy netdist))
(setq fy (+ f1y (* index0 netdist)))
(drawcrossleft leftdownx fy mapscale)
(writey (- leftdownx (* 5 mapscale))
(+ fy (* 1.5 mapscale))
mapscale
)
(setq textlong_fy (strlen (rtos fy 2 0)))
(setq textstr_fy (substr (rtos fy 2 0) 1 (- textlong_fy 4)))
(if (/= textstr_fy test)
(progn
(writeleftyforeside leftdownx fy mapscale)
(setq test textstr_fy)
)
)
(setq index0 (1+ index0))
)
(writeleftyforeside leftdownx fy mapscale)
;;; 右边
(setq fy 0)
(setq index0 1)
(setq test "aaaaaa")
(while (< fy (- rightupy netdist))
(setq fy (+ f1y (* index0 netdist)))
(drawcrossright rightupx fy mapscale)
(writey (+ rightupx (* 3.8 mapscale))
(+ fy (* 1.5 mapscale))
mapscale
)
(setq textlong_fy (strlen (rtos fy 2 0)))
(setq textstr_fy (substr (rtos fy 2 0) 1 (- textlong_fy 4)))
(if (/= textstr_fy test)
(progn
(writerightyforeside rightupx fy mapscale)
(setq test textstr_fy)
)
)
(setq index0 (1+ index0))
)
(writerightyforeside rightupx fy mapscale)
;;;四角
(drawline leftdownxy
(list (- leftdownx (* 10 mapscale)) leftdowny)
)
(drawline leftdownxy
(list leftdownx (- leftdowny (* 10 mapscale)))
)
(setq leftdownbl (xytobl54 leftdownx leftdowny centerm))
(entmake
(list
(cons 0 "TEXT")
(cons 8 "图框")
(cons 7 "TUKUANG")
(cons 10
(list (- leftdownx (* mapscale 5.5644))
(- leftdowny (* mapscale 6.2651))
)
)
(cons 40 (* mapscale 1.8))
(cons 50 0)
(cons 1 (car leftdownbl))
)
)
(entmake
(list
(cons 0 "TEXT")
(cons 8 "图框")
(cons 7 "TUKUANG")
(cons 10
(list (- leftdownx (* mapscale 4.3258))
(+ leftdowny (* mapscale 1.35))
)
)
(cons 40 (* mapscale 1.8))
(cons 50 0)
(cons 1 (substr (nth 1 leftdownbl) 1 4))
)
)
(entmake
(list
(cons 0 "TEXT")
(cons 8 "图框")
(cons 7 "TUKUANG")
(cons 10
(list (- leftdownx (* mapscale 8.7))
(- leftdowny (* mapscale 2.8))
)
)
(cons 40 (* mapscale 1.8))
(cons 50 0)
(cons 1 (substr (nth 1 leftdownbl) 5))
)
)
;;;单行文本
(entmake
(list '(0 . "TEXT")
(cons 1 str)
(cons 10 pt)
(cons 40 5)))
(drawline (list rightupx leftdowny)
(list (+ rightupx (* 10 mapscale)) leftdowny)
)
(drawline (list rightupx leftdowny)
(list rightupx (- leftdowny (* 10 mapscale)))
)
(setq rightdownbl (xytobl54 rightupx leftdowny centerm))
(entmake
(list
(cons 0 "TEXT")
(cons 8 "图框")
(cons 7 "TUKUANG")
(cons 10
(list (- rightupx (* mapscale 10.6))
(- leftdowny (* mapscale 6.2651))
)
)
(cons 40 (* mapscale 1.8))
(cons 50 0)
(cons 1 (car rightdownbl))
)
)
(entmake
(list
(cons 0 "TEXT")
(cons 8 "图框")
(cons 7 "TUKUANG")
(cons 10
(list (- rightupx (* mapscale 0))
(+ leftdowny (* mapscale 1.35))
)
)
(cons 40 (* mapscale 1.8))
(cons 50 0)
(cons 1 (substr (nth 1 rightdownbl) 1 4))
)
)
(entmake
(list
(cons 0 "TEXT")
(cons 8 "图框")
(cons 7 "TUKUANG")
(cons 10
(list (- rightupx (* mapscale 3.5))
(- leftdowny (* mapscale 2.8))
)
)
(cons 40 (* mapscale 1.8))
(cons 50 0)
(cons 1 (substr (nth 1 rightdownbl) 5))
)
)
(drawline rightupxy
(list (+ rightupx (* 10 mapscale)) rightupy)
)
(drawline rightupxy
(list rightupx (+ rightupy (* 10 mapscale)))
)
(setq rightupbl (xytobl54 rightupx rightupy centerm))
(entmake
(list
(cons 0 "TEXT")
(cons 8 "图框")
(cons 7 "TUKUANG")
(cons 10
(list (- rightupx (* mapscale 10.6))
(+ rightupy (* mapscale 5.0))
)
)
(cons 40 (* mapscale 1.8))
(cons 50 0)
(cons 1 (car rightupbl))
)
)
(entmake
(list
(cons 0 "TEXT")
(cons 8 "图框")
(cons 7 "TUKUANG")
(cons 10
(list (- rightupx (* mapscale 0))
(+ rightupy (* mapscale 1.35))
)
)
(cons 40 (* mapscale 1.8))
(cons 50 0)
(cons 1 (substr (nth 1 rightupbl) 1 4))
)
)
(entmake
(list
(cons 0 "TEXT")
(cons 8 "图框")
(cons 7 "TUKUANG")
(cons 10
(list (- rightupx (* mapscale 3.5))
(- rightupy (* mapscale 2.8))
)
)
(cons 40 (* mapscale 1.8))
(cons 50 0)
(cons 1 (substr (nth 1 rightupbl) 5))
)
)
(drawline (list leftdownx rightupy)
(list (- leftdownx (* 10 mapscale)) rightupy)
)
(drawline (list leftdownx rightupy)
(list leftdownx (+ rightupy (* 10 mapscale)))
)
(setq leftupbl (xytobl54 leftdownx rightupy centerm))
(entmake
(list
(cons 0 "TEXT")
(cons 8 "图框")
(cons 7 "TUKUANG")
(cons 10
(list (- leftdownx (* mapscale 5.5644))
(+ rightupy (* mapscale 5.0))
)
)
(cons 40 (* mapscale 1.8))
(cons 50 0)
(cons 1 (car leftupbl))
)
)
(entmake
(list
(cons 0 "TEXT")
(cons 8 "图框")
(cons 7 "TUKUANG")
(cons 10
(list (- leftdownx (* mapscale 4.3258))
(+ rightupy (* mapscale 1.35))
)
)
(cons 40 (* mapscale 1.8))
(cons 50 0)
(cons 1 (substr (nth 1 leftupbl) 1 4))
)
)
(entmake
(list
(cons 0 "TEXT")
(cons 8 "图框")
(cons 7 "TUKUANG")
(cons 10
(list (- leftdownx (* mapscale 8.7))
(- rightupy (* mapscale 2.8))
)
)
(cons 40 (* mapscale 1.8))
(cons 50 0)
(cons 1 (substr (nth 1 leftupbl) 5))
)
)
(setvar "osmode" oldosmode)
(setvar "cmdecho" oldcmdecho)
(princ)
)
;;;drawcross()
(defun drawcross (x y s / x1 x2 y1 y2)
(setq x1 (list (- x (* 5 s)) y)
x2 (list (+ x (* 5 s)) y)
y1 (list x (+ y (* 5 s)))
y2 (list x (- y (* 5 s)))
)
(drawline x1 x2)
(drawline y1 y2)
(princ)
)
(defun drawcrossdown (x y s / y1 y2)
(setq y1 (list x (+ y (* 5 s)))
y2 (list x (- y (* 10 s)))
)
(drawline y1 y2)
(princ)
)
(defun drawcrossup (x y s / y1 y2)
(setq y1 (list x (+ y (* 10 s)))
y2 (list x (- y (* 5 s)))
)
(drawline y1 y2)
(princ)
)
(defun drawcrossleft (x y s / x1 x2)
(setq x1 (list (- x (* 10 s)) y)
x2 (list (+ x (* 5 s)) y)
)
(drawline x1 x2)
(princ)
)
(defun drawcrossright (x y s / x1 x2 y1 y2)
(setq x1 (list (- x (* 5 s)) y)
x2 (list (+ x (* 10 s)) y)
)
(drawline x1 x2)
(princ)
)
(defun drawline (xy1 xy2 /)
(entmake
(list
(cons 0 "LINE")
(cons 8 "图框")
(cons 10 xy1)
(cons 11 xy2)
)
)
)
(defun writex (x y s / textlong textstr)
(setq textlong (strlen (rtos x 2 0)))
(setq textstr (substr (rtos x 2 0) (- textlong 3) 2))
(entmake
(list
(cons 0 "TEXT")
(cons 8 "图框")
(cons 7 "TUKUANG")
(cons 10 (list x y))
(cons 40 (* s 3))
(cons 50 0)
(cons 1 textstr)
)
)
)
(defun writey (x y s / textlong textstr)
(setq textlong (strlen (rtos y 2 0)))
(setq textstr (substr (rtos y 2 0) (- textlong 3) 2))
(entmake
(list
(cons 0 "TEXT")
(cons 8 "图框")
(cons 7 "TUKUANG")
(cons 10 (list x y))
(cons 40 (* s 3))
(cons 50 0)
(cons 1 textstr)
)
)
)
(defun writexforeside (x y s / textlong textstr texthigh)
(setq textlong (strlen (rtos x 2 0)))
(setq textstr (substr (rtos x 2 0) 1 (- textlong 4)))
(setq textlong (strlen textstr))
(setq texthigh (* s 1.8))
(entmake
(list
(cons 0 "TEXT")
(cons 8 "图框")
(cons 7 "TUKUANG")
(cons 10
(list (- x (* textlong texthigh 0.7))
(- y texthigh (* 4.4676 s))
)
)
(cons 40 texthigh)
(cons 50 0)
(cons 1 textstr)
)
)
)
(defun writeleftyforeside (x y s / textlong textstr texthigh)
(setq textlong (strlen (rtos y 2 0)))
(setq textstr (substr (rtos y 2 0) 1 (- textlong 4)))
(setq textlong (strlen textstr))
(setq texthigh (* s 1.8))
(entmake
(list
(cons 0 "TEXT")
(cons 8 "图框")
(cons 7 "TUKUANG")
(cons 10
(list (- x (* s 8.924))
(+ y (* s 2.6517))
)
)
(cons 40 texthigh)
(cons 50 0)
(cons 1 textstr)
)
)
)
(defun writerightyforeside (x y s / textlong textstr texthigh)
(setq textlong (strlen (rtos y 2 0)))
(setq textstr (substr (rtos y 2 0) 1 (- textlong 4)))
(setq textlong (strlen textstr))
(setq texthigh (* s 1.8))
(entmake
(list
(cons 0 "TEXT")
(cons 8 "图框")
(cons 7 "TUKUANG")
(cons 10
(list x
(+ y (* s 2.6518))
)
)
(cons 40 texthigh)
(cons 50 0)
(cons 1 textstr)
)
)
)
;;; BJ-54坐标系的椭球参数为：
;;; 长半轴：a=6378245
;;; 短半轴：b=6356863.018773
(defun xytobl54 (y x cm /)
(setq a 6378245.0
b 6356863.018773
e1 (sqrt (- 1.0 (expt (/ b a) 2.0)))
e2 (sqrt (- (expt (/ a b) 2.0) 1.0))
k0 1.0
fn 0.0
fe 500000.0
)
(if (= (strlen (rtos (fix y))) 8)
(progn
(setq zoneid (atof (substr (rtos (fix y)) 1 2)))
(setq l0 (* (/ (* zoneid 3) 180.0) pi))
(setq y (- y (* zoneid 1000000)))
)
(progn
;;; (setq cm (getreal "本投影带(3°带)中央经线........"))
(setq l0 cm)
)
)
(setq mf (/ (- x fn) k0))
(setq e3 (/ (- a b) (+ a b)))
(setq q (/ mf
(* a
(- 1
(/ (expt e1 2) 4)
(/ (* 3 (expt e1 4)) 64)
(/ (* 5 (expt e1 6)) 256)
)
)
)
)
(setq bf (+ q
(* (- (* 3 (/ e3 2)) (* 27 (/ (expt e3 3) 32)))
(sin (* 2 q))
)
(* (- (* 21 (/ (expt e3 2) 16))
(* 55 (/ (expt e3 4) 32))
)
(sin (* 4 q))
)
(* (* 151 (/ (expt e3 3) 96)) (sin (* 6 q)))
)
)
(setq tf (expt (/ (sin bf) (cos bf)) 2))
(setq cf (* (expt e2 2) (expt (cos bf) 2)))
(setq rf (/ (* a (- 1 (expt e1 2)))
(expt (- 1 (* (expt e1 2) (expt (sin bf) 2))) 1.5)
)
)
(setq nf (/ a (sqrt (- 1 (* (expt e1 2) (expt (sin bf) 2))))))
(setq d (/ (- y fe) (* k0 nf)))
(setq b (- bf
(/ (* nf
(/ (sin bf) (cos bf))
(- (/ (* d d) 2)
(/ (* (expt d 4)
(+ 5 (* 3 tf) cf (* -9 tf cf))
)
24
)
(/ (* (expt d 6)
(+ 61 (* 90 tf) (* 45 tf tf))
)
-720
)
)
)
rf
)
)
)
(setq l (+ l0
(* (/ 1 (cos bf))
(+ d
(/ (* (+ 1 (* 2 tf) cf) (expt d 3)) -6)
(/ (* (+ 5
(* 28 tf)
(* 6 cf)
(* 8 tf cf)
(* 24 tf tf)
)
(expt d 5)
)
120
)
)
)
)
)
(list (dfm l) (dfm b))
)
(defun dfm (degree / d f d_error f_error result)
(setq degree (/ (* degree 180) pi))
(setq d (fix degree))
(setq d_error (* (- degree d) 60))
(setq f (fix d_error))
(setq f_error (* (- d_error f) 60))
(setq result (strcat (rtos d 2 0)
"°"
(rtos f 2 0)
"'"
(rtos f_error 2 2)
(chr 34)
)
)
result
)

;;;-------------------------------------------------------------- 
;;;功  能：根据给定的左下角和右上角坐标绘制图框 
;;;-------------------------------------------------------------- 
(defun c:mf () 
    (setq oldosmode (getvar "osmode")) 
    (setq oldcmdecho (getvar "cmdecho")) 
    (setvar "osmode" 0)      ;指定目标捕捉模式 
    (setvar "cmdecho" 0) 
    (command) 
    (command ".style" "TUKUANG" "文鼎CS细等线" 0 1 0 "N" "N") 
    (command) 
;;;设定绘图比例尺 
    (setq 
  mapscale (getint "输入出图比例尺(1:1000输1;1:2000输2):>") 
    ) 
;;;设定初始图框 
    (print) 
    (setq selborder (entsel "请选择初始图框:>")) 
    (setq border (entget (car selborder))) 
;;;    (entdel (car selborder)) 
    (setq index 0 
    xmin 999999999.9 
    ymin 999999999.9 
    xmax -999999999.9 
    ymax -999999999.9) 
    (repeat (length border) 
  (setq xy1 (nth index border)) 
  (setq index (1+ index)) 
  (if (= (car xy1 ) 10) 
      (progn 
    (setq x (cadr xy1) 
          y (caddr xy1)) 
    (if (> xmin x) (setq xmin x)) 
    (if (> ymin y) (setq ymin y)) 
    (if (< xmax x) (setq xmax x)) 
    (if (< ymax y) (setq ymax y))) 
      ) 
  ) 
 
    
    (setq leftdownx xmin) 
    (setq leftdowny ymin) 
    (setq leftdownxy (list leftdownx leftdowny)) 
    (setq outleftdownxy 
       (list (- leftdownx (* 10 mapscale)) 
       (- leftdowny (* 10 mapscale)) 
       ) 
    ) 
    (print) 
 
    (setq rightupx xmax) 
    (setq rightupy ymax) 
    (setq rightupxy (list rightupx rightupy)) 
    (setq outrightupxy 
       (list (+ rightupx (* 10 mapscale)) 
       (+ rightupy (* 10 mapscale)) 
       ) 
    ) 
    (print) 
    (if  (= (strlen (rtos (fix leftdowny))) 8) 
  (progn 
      (setq zoneid (atof (substr (rtos (fix leftdowny)) 1 2))) 
      (setq centerm (* (/ (* zoneid 3) 180.0) pi)) 
  ) 
  (progn 
      (setq centerm (getreal "本投影带(3°带)中央经线........")) 
      (setq centerm (* (/ centerm 180.0) pi)) 
  ) 
    ) 
    (print) 
 
    (entdel (car selborder)) 
 
    (command "_rectang" leftdownxy rightupxy) 
    (command) 
    (setq inframe (entget (entlast))) 
    (setq inframe (subst (cons 8 "图框") 
       (assoc 8 inframe) 
       inframe)) 
    (entmod inframe) 
    (command "_rectang" outleftdownxy outrightupxy) 
    (command) 
    (setq outframe (entget (entlast))) 
    (setq outframe (subst (cons 43 (* 2 mapscale)) 
        (assoc 43 outframe) 
        outframe 
       ) 
    ) 
    (setq outframe (subst (cons 8 "图框") 
        (assoc 8 outframe) 
        outframe)) 
    (entmod outframe) 
;;;    取netdist的整数位置 
    (setq netdist (* 100 mapscale)) 
    (setq intnetdistx (fix (/ leftdownx netdist))) 
    (setq intnetdisty (fix (/ leftdowny netdist))) 
    (setq f1x (* netdist intnetdistx)) 
    (setq f1y (* netdist intnetdisty)) 
 
;;;绘制方格网 
    (setq index 1) 
    (setq crosswide (* 10 mapscale)) 
    (setq no_y (1+ (fix (/ (- rightupy leftdowny) netdist)))) 
    (setq no_x (1+ (fix (/ (- rightupx leftdownx) netdist)))) 
    (setq fy 0) 
    (while (< fy (- rightupy netdist)) 
  (setq index0 1) 
  (setq fy (+ f1y (* index netdist))) 
  (setq index (1+ index)) 
  (setq fx 0) 
  (while (< fx (- rightupx netdist)) 
      (setq fx (+ f1x (* index0 netdist))) 
      (drawcross fx fy mapscale) 
      (setq index0 (1+ index0)) 
  ) 
    ) 
;;;绘制边框上的格网点 
;;;    下边 
    (setq fx 0) 
    (setq index0 1) 
    (setq test "aaaaaa") 
 
    (while (< fx (- rightupx netdist)) 
  (setq fx (+ f1x (* index0 netdist))) 
  (drawcrossdown fx leftdowny mapscale) 
 
  (writex fx (- leftdowny (* 7.5 mapscale)) mapscale) 
  (setq textlong_fx (strlen (rtos fx 2 0))) 
  (setq textstr_fx (substr (rtos fx 2 0) 1 (- textlong_fx 4))) 
  (if (/= textstr_fx test) 
      (progn 
    (writexforeside fx leftdowny mapscale) 
    (setq test textstr_fx) 
      ) 
  ) 
 
  (setq index0 (1+ index0)) 
    ) 
    (writexforeside fx leftdowny mapscale) 
 
;;;    上边 
    (setq fx 0) 
    (setq index0 1) 
    (setq test "aaaaaa") 
 
    (while (< fx (- rightupx netdist)) 
  (setq fx (+ f1x (* index0 netdist))) 
  (drawcrossup fx rightupy mapscale) 
  (writex fx (+ rightupy (* 4.9 mapscale)) mapscale) 
  (setq textlong_fx (strlen (rtos fx 2 0))) 
  (setq textstr_fx (substr (rtos fx 2 0) 1 (- textlong_fx 4))) 
  (if (/= textstr_fx test) 
      (progn 
    (writexforeside 
        fx 
        (+ rightupy (* 12.4 mapscale)) 
        mapscale 
    ) 
    (setq test textstr_fx) 
      ) 
  ) 
 
  (setq index0 (1+ index0)) 
    ) 
    (writexforeside fx (+ rightupy (* 12.4 mapscale)) mapscale) 
 
;;;    左边 
    (setq fy 0) 
    (setq index0 1) 
    (setq test "aaaaaa") 
 
    (while (< fy (- rightupy netdist)) 
  (setq fy (+ f1y (* index0 netdist))) 
  (drawcrossleft leftdownx fy mapscale) 
  (writey  (- leftdownx (* 5 mapscale)) 
    (+ fy (* 1.5 mapscale)) 
    mapscale 
  ) 
  (setq textlong_fy (strlen (rtos fy 2 0))) 
  (setq textstr_fy (substr (rtos fy 2 0) 1 (- textlong_fy 4))) 
  (if (/= textstr_fy test) 
      (progn 
    (writeleftyforeside leftdownx fy mapscale) 
    (setq test textstr_fy) 
      ) 
  ) 
 
  (setq index0 (1+ index0)) 
    ) 
    (writeleftyforeside leftdownx fy mapscale) 
 
;;;    右边 
    (setq fy 0) 
    (setq index0 1) 
    (setq test "aaaaaa") 
 
    (while (< fy (- rightupy netdist)) 
  (setq fy (+ f1y (* index0 netdist))) 
  (drawcrossright rightupx fy mapscale) 
  (writey  (+ rightupx (* 3.8 mapscale)) 
    (+ fy (* 1.5 mapscale)) 
    mapscale 
  ) 
  (setq textlong_fy (strlen (rtos fy 2 0))) 
  (setq textstr_fy (substr (rtos fy 2 0) 1 (- textlong_fy 4))) 
  (if (/= textstr_fy test) 
      (progn 
    (writerightyforeside rightupx fy mapscale) 
    (setq test textstr_fy) 
      ) 
  ) 
 
 
  (setq index0 (1+ index0)) 
    ) 
    (writerightyforeside rightupx fy mapscale) 
 
;;;四角 
    (drawline leftdownxy 
        (list (- leftdownx (* 10 mapscale)) leftdowny) 
    ) 
    (drawline leftdownxy 
        (list leftdownx (- leftdowny (* 10 mapscale))) 
    ) 
    (setq leftdownbl (xytobl54 leftdownx leftdowny centerm)) 
    (entmake 
  (list 
      (cons 0 "TEXT") 
      (cons 8 "图框") 
      (cons 7 "TUKUANG") 
      (cons 10 
      (list  (- leftdownx (* mapscale 5.5644)) 
      (- leftdowny (* mapscale 6.2651)) 
      ) 
      ) 
      (cons 40 (* mapscale 1.8)) 
      (cons 50 0) 
      (cons 1 (car leftdownbl)) 
  ) 
    ) 
    (entmake 
  (list 
      (cons 0 "TEXT") 
      (cons 8 "图框") 
      (cons 7 "TUKUANG") 
      (cons 10 
      (list  (- leftdownx (* mapscale 4.3258)) 
      (+ leftdowny (* mapscale 1.35)) 
      ) 
      ) 
      (cons 40 (* mapscale 1.8)) 
      (cons 50 0) 
      (cons 1 (substr (nth 1 leftdownbl) 1 4)) 
  ) 
    ) 
    (entmake 
  (list 
      (cons 0 "TEXT") 
      (cons 8 "图框") 
      (cons 7 "TUKUANG") 
      (cons 10 
      (list  (- leftdownx (* mapscale 8.7)) 
      (- leftdowny (* mapscale 2.8)) 
      ) 
      ) 
      (cons 40 (* mapscale 1.8)) 
      (cons 50 0) 
      (cons 1 (substr (nth 1 leftdownbl) 5)) 
  ) 
    ) 
 
;;;单行文本 
    (entmake 
        (list '(0 . "TEXT") 
               (cons 1 str) 
               (cons 10 pt) 
               (cons 40 5))) 
 
    (drawline (list rightupx leftdowny) 
        (list (+ rightupx (* 10 mapscale)) leftdowny) 
    ) 
    (drawline (list rightupx leftdowny) 
        (list rightupx (- leftdowny (* 10 mapscale))) 
    ) 
    (setq rightdownbl (xytobl54 rightupx leftdowny centerm)) 
    (entmake 
  (list 
      (cons 0 "TEXT") 
      (cons 8 "图框") 
      (cons 7 "TUKUANG") 
      (cons 10 
      (list  (- rightupx (* mapscale 10.6)) 
      (- leftdowny (* mapscale 6.2651)) 
      ) 
      ) 
      (cons 40 (* mapscale 1.8)) 
      (cons 50 0) 
      (cons 1 (car rightdownbl)) 
  ) 
    ) 
    (entmake 
  (list 
      (cons 0 "TEXT") 
      (cons 8 "图框") 
      (cons 7 "TUKUANG") 
      (cons 10 
      (list  (- rightupx (* mapscale 0)) 
      (+ leftdowny (* mapscale 1.35)) 
      ) 
      ) 
      (cons 40 (* mapscale 1.8)) 
      (cons 50 0) 
      (cons 1 (substr (nth 1 rightdownbl) 1 4)) 
  ) 
    ) 
    (entmake 
  (list 
      (cons 0 "TEXT") 
      (cons 8 "图框") 
      (cons 7 "TUKUANG") 
      (cons 10 
      (list  (- rightupx (* mapscale 3.5)) 
      (- leftdowny (* mapscale 2.8)) 
      ) 
      ) 
      (cons 40 (* mapscale 1.8)) 
      (cons 50 0) 
      (cons 1 (substr (nth 1 rightdownbl) 5)) 
  ) 
    ) 
 
 
    (drawline rightupxy 
        (list (+ rightupx (* 10 mapscale)) rightupy) 
    ) 
    (drawline rightupxy 
        (list rightupx (+ rightupy (* 10 mapscale))) 
    ) 
 
    (setq rightupbl (xytobl54 rightupx rightupy centerm)) 
    (entmake 
  (list 
      (cons 0 "TEXT") 
      (cons 8 "图框") 
      (cons 7 "TUKUANG") 
      (cons 10 
      (list  (- rightupx (* mapscale 10.6)) 
      (+ rightupy (* mapscale 5.0)) 
      ) 
      ) 
      (cons 40 (* mapscale 1.8)) 
      (cons 50 0) 
      (cons 1 (car rightupbl)) 
  ) 
    ) 
    (entmake 
  (list 
      (cons 0 "TEXT") 
      (cons 8 "图框") 
      (cons 7 "TUKUANG") 
      (cons 10 
      (list  (- rightupx (* mapscale 0)) 
      (+ rightupy (* mapscale 1.35)) 
      ) 
      ) 
      (cons 40 (* mapscale 1.8)) 
      (cons 50 0) 
      (cons 1 (substr (nth 1 rightupbl) 1 4)) 
  ) 
    ) 
    (entmake 
  (list 
      (cons 0 "TEXT") 
      (cons 8 "图框") 
      (cons 7 "TUKUANG") 
      (cons 10 
      (list  (- rightupx (* mapscale 3.5)) 
      (- rightupy (* mapscale 2.8)) 
      ) 
      ) 
      (cons 40 (* mapscale 1.8)) 
      (cons 50 0) 
      (cons 1 (substr (nth 1 rightupbl) 5)) 
  ) 
    ) 
    (drawline (list leftdownx rightupy) 
        (list (- leftdownx (* 10 mapscale)) rightupy) 
    ) 
    (drawline (list leftdownx rightupy) 
        (list leftdownx (+ rightupy (* 10 mapscale))) 
    ) 
    (setq leftupbl (xytobl54 leftdownx rightupy centerm)) 
    (entmake 
  (list 
      (cons 0 "TEXT") 
      (cons 8 "图框") 
      (cons 7 "TUKUANG") 
      (cons 10 
      (list  (- leftdownx (* mapscale 5.5644)) 
      (+ rightupy (* mapscale 5.0)) 
      ) 
      ) 
      (cons 40 (* mapscale 1.8)) 
      (cons 50 0) 
      (cons 1 (car leftupbl)) 
  ) 
    ) 
    (entmake 
  (list 
      (cons 0 "TEXT") 
      (cons 8 "图框") 
      (cons 7 "TUKUANG") 
      (cons 10 
      (list  (- leftdownx (* mapscale 4.3258)) 
      (+ rightupy (* mapscale 1.35)) 
      ) 
      ) 
      (cons 40 (* mapscale 1.8)) 
      (cons 50 0) 
      (cons 1 (substr (nth 1 leftupbl) 1 4)) 
  ) 
    ) 
    (entmake 
  (list 
      (cons 0 "TEXT") 
      (cons 8 "图框") 
      (cons 7 "TUKUANG") 
      (cons 10 
      (list  (- leftdownx (* mapscale 8.7)) 
      (- rightupy (* mapscale 2.8)) 
      ) 
      ) 
      (cons 40 (* mapscale 1.8)) 
      (cons 50 0) 
      (cons 1 (substr (nth 1 leftupbl) 5)) 
  ) 
    ) 
 
    (setvar "osmode" oldosmode) 
    (setvar "cmdecho" oldcmdecho) 
 
    (princ) 
) 
;;;drawcross() 
(defun drawcross (x y s / x1 x2 y1 y2) 
    (setq x1 (list (- x (* 5 s)) y) 
    x2 (list (+ x (* 5 s)) y) 
    y1 (list x (+ y (* 5 s))) 
    y2 (list x (- y (* 5 s))) 
    ) 
    (drawline x1 x2) 
    (drawline y1 y2) 
    (princ) 
) 
(defun drawcrossdown (x y s / y1 y2) 
    (setq y1 (list x (+ y (* 5 s))) 
    y2 (list x (- y (* 10 s))) 
    ) 
    (drawline y1 y2) 
    (princ) 
) 
(defun drawcrossup (x y s / y1 y2) 
    (setq y1 (list x (+ y (* 10 s))) 
    y2 (list x (- y (* 5 s))) 
    ) 
    (drawline y1 y2) 
    (princ) 
) 
(defun drawcrossleft (x y s / x1 x2) 
    (setq x1 (list (- x (* 10 s)) y) 
    x2 (list (+ x (* 5 s)) y) 
    ) 
    (drawline x1 x2) 
    (princ) 
) 
(defun drawcrossright (x y s / x1 x2 y1 y2) 
    (setq x1 (list (- x (* 5 s)) y) 
    x2 (list (+ x (* 10 s)) y) 
    ) 
    (drawline x1 x2) 
    (princ) 
) 
 
(defun drawline  (xy1 xy2 /) 
    (entmake 
  (list 
      (cons 0 "LINE") 
      (cons 8 "图框") 
      (cons 10 xy1) 
      (cons 11 xy2) 
  ) 
    ) 
) 
 
(defun writex (x y s / textlong textstr) 
    (setq textlong (strlen (rtos x 2 0))) 
    (setq textstr (substr (rtos x 2 0) (- textlong 3) 2)) 
    (entmake 
  (list 
      (cons 0 "TEXT") 
      (cons 8 "图框") 
      (cons 7 "TUKUANG") 
      (cons 10 (list x y)) 
      (cons 40 (* s 3)) 
      (cons 50 0) 
      (cons 1 textstr) 
  ) 
    ) 
) 
(defun writey (x y s / textlong textstr) 
    (setq textlong (strlen (rtos y 2 0))) 
    (setq textstr (substr (rtos y 2 0) (- textlong 3) 2)) 
    (entmake 
  (list 
      (cons 0 "TEXT") 
      (cons 8 "图框") 
      (cons 7 "TUKUANG") 
      (cons 10 (list x y)) 
      (cons 40 (* s 3)) 
      (cons 50 0) 
      (cons 1 textstr) 
  ) 
    ) 
) 
(defun writexforeside (x y s / textlong textstr texthigh) 
    (setq textlong (strlen (rtos x 2 0))) 
    (setq textstr (substr (rtos x 2 0) 1 (- textlong 4))) 
    (setq textlong (strlen textstr)) 
    (setq texthigh (* s 1.8)) 
 
    (entmake 
  (list 
      (cons 0 "TEXT") 
      (cons 8 "图框") 
      (cons 7 "TUKUANG") 
      (cons 10 
      (list  (- x (* textlong texthigh 0.7)) 
      (- y texthigh (* 4.4676 s)) 
      ) 
      ) 
      (cons 40 texthigh) 
      (cons 50 0) 
      (cons 1 textstr) 
  ) 
    ) 
) 
(defun writeleftyforeside (x y s / textlong textstr texthigh) 
    (setq textlong (strlen (rtos y 2 0))) 
    (setq textstr (substr (rtos y 2 0) 1 (- textlong 4))) 
    (setq textlong (strlen textstr)) 
    (setq texthigh (* s 1.8)) 
 
    (entmake 
  (list 
      (cons 0 "TEXT") 
      (cons 8 "图框") 
      (cons 7 "TUKUANG") 
      (cons 10 
      (list  (- x (* s 8.924)) 
      (+ y (* s 2.6517)) 
      ) 
      ) 
      (cons 40 texthigh) 
      (cons 50 0) 
      (cons 1 textstr) 
  ) 
    ) 
) 
(defun writerightyforeside (x y s / textlong textstr texthigh) 
    (setq textlong (strlen (rtos y 2 0))) 
    (setq textstr (substr (rtos y 2 0) 1 (- textlong 4))) 
    (setq textlong (strlen textstr)) 
    (setq texthigh (* s 1.8)) 
 
    (entmake 
  (list 
      (cons 0 "TEXT") 
      (cons 8 "图框") 
      (cons 7 "TUKUANG") 
      (cons 10 
      (list  x 
      (+ y (* s 2.6518)) 
      ) 
      ) 
      (cons 40 texthigh) 
      (cons 50 0) 
      (cons 1 textstr) 
  ) 
    ) 
) 
;;;    BJ-54坐标系的椭球参数为： 
;;;    长半轴：a=6378245 
;;;    短半轴：b=6356863.018773 
 
(defun xytobl54  (y x cm /) 
    (setq a  6378245.0 
    b  6356863.018773 
    e1 (sqrt (- 1.0 (expt (/ b a) 2.0))) 
    e2 (sqrt (- (expt (/ a b) 2.0) 1.0)) 
    k0 1.0 
    fn 0.0 
    fe 500000.0 
    ) 
    (if  (= (strlen (rtos (fix y))) 8) 
  (progn 
      (setq zoneid (atof (substr (rtos (fix y)) 1 2))) 
      (setq l0 (* (/ (* zoneid 3) 180.0) pi)) 
      (setq y (- y (* zoneid 1000000))) 
  ) 
  (progn 
;;;      (setq cm (getreal "本投影带(3°带)中央经线........")) 
      (setq l0 cm) 
  ) 
    ) 
 
 
    (setq mf (/ (- x fn) k0)) 
 
    (setq e3 (/ (- a b) (+ a b))) 
 
    (setq q (/ mf 
         (* a 
      (- 1 
         (/ (expt e1 2) 4) 
         (/ (* 3 (expt e1 4)) 64) 
         (/ (* 5 (expt e1 6)) 256) 
      ) 
         ) 
      ) 
    ) 
 
    (setq bf (+  q 
    (* (- (* 3 (/ e3 2)) (* 27 (/ (expt e3 3) 32))) 
       (sin (* 2 q)) 
    ) 
    (* (- (* 21 (/ (expt e3 2) 16)) 
          (* 55 (/ (expt e3 4) 32)) 
       ) 
       (sin (* 4 q)) 
    ) 
    (* (* 151 (/ (expt e3 3) 96)) (sin (* 6 q))) 
       ) 
    ) 
 
    (setq tf (expt (/ (sin bf) (cos bf)) 2)) 
 
    (setq cf (* (expt e2 2) (expt (cos bf) 2))) 
 
    (setq rf (/  (* a (- 1 (expt e1 2))) 
    (expt (- 1 (* (expt e1 2) (expt (sin bf) 2))) 1.5) 
       ) 
    ) 
 
    (setq nf (/ a (sqrt (- 1 (* (expt e1 2) (expt (sin bf) 2)))))) 
 
    (setq d (/ (- y fe) (* k0 nf))) 
 
    (setq b (- bf 
         (/ (* nf 
         (/ (sin bf) (cos bf)) 
         (-  (/ (* d d) 2) 
      (/ (* (expt d 4) 
            (+ 5 (* 3 tf) cf (* -9 tf cf)) 
         ) 
         24 
      ) 
      (/ (* (expt d 6) 
            (+ 61 (* 90 tf) (* 45 tf tf)) 
         ) 
         -720 
      ) 
         ) 
      ) 
      rf 
         ) 
      ) 
    ) 
 
 
    (setq l (+ l0 
         (* (/ 1 (cos bf)) 
      (+ d 
         (/ (* (+ 1 (* 2 tf) cf) (expt d 3)) -6) 
         (/  (* (+ 5 
            (* 28 tf) 
            (* 6 cf) 
            (* 8 tf cf) 
            (* 24 tf tf) 
         ) 
         (expt d 5) 
      ) 
      120 
         ) 
      ) 
         ) 
      ) 
    ) 
    (list (dfm l) (dfm b)) 
) 
 
(defun dfm (degree / d f d_error f_error result) 
    (setq degree (/ (* degree 180) pi)) 
    (setq d (fix degree)) 
    (setq d_error (* (- degree d) 60)) 
    (setq f (fix d_error)) 
    (setq f_error (* (- d_error f) 60)) 
    (setq result (strcat (rtos d 2 0) 
       "°" 
       (rtos f 2 0) 
       "'" 
       (rtos f_error 2 2) 
       (chr 34) 
     ) 
    ) 
    result 
)

我想在图框上再加个标题，而且标题要随比例尺变化而变化，求教。

lucas_3333 · 发表于 2015-8-28 10:38:16

你的代码格式化有问题, 插入代码时请使用lisp

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

[源码] 图框程序，加个标题求教

本帖子中包含更多资源