[LISP程序]：非常好的标高绘制程序，用了才知道

sahara124

[pcode=lisp,true];;;标高绘制程序
;;;MAIL PROGRAM
(PRINC "\n标高绘制程序, 执行命令: BG ")
(DEFUN C:BG (/    &OLDERR&   *$MYERROR$*         BGBLS        BGDOTS
        BGNUMLST   BG_ID      BSPOINT     HTBLS        I
        NUM       OHEIGHTSTR OLDCMD     OLDCUR        OLDDIMZ
        OLDLAY       OLDOS      OLDSTY     ORGPOINT   ORGPTY
            SYMLST     HTBL
           )
  (VL-LOAD-COM)
  ;;;错误处理函数
  (DEFUN *$MYERROR$* (MSG)
    (COMMAND "_.ERASE" SSTXTS "")
    (COMMAND ".UCS" "P")
    (SETVAR "CLAYER" OLDLAY)
    (SETVAR "OSMODE" OLDOS)
    (SETVAR "DIMZIN" OLDDIMZ)
    (SETVAR "TEXTSTYLE" OLDSTY)
    (SETVAR "CURSORSIZE" OLDCUR)
    (SETQ *ERROR* &OLDERR&)
     (SETVAR "CMDECHO" OLDCMD)
    (REDRAW)
    (PRINC)
    )
  (SETQ &OLDERR& *ERROR*)
  (SETQ *ERROR* *$MYERROR$*)
  ;;;系统变量初始化
  (SETQ OLDCMD (GETVAR "CMDECHO"))
  (SETQ OLDLAY (GETVAR "CLAYER"))
  (SETQ OLDOS (GETVAR "OSMODE"))
  (SETQ OLDDIMZ (GETVAR "DIMZIN"))
  (SETQ OLDSTY (GETVAR "TEXTSTYLE"))
  (SETQ OLDCUR (GETVAR "CURSORSIZE"));光标大小
  (SETVAR "CMDECHO" 0)
  (SETVAR "OSMODE" 0)
  (SETVAR "DIMZIN" 0)
  (COMMAND ".UNDO" "BE")
  (COMMAND ".UCS" "W")
  (SETQ HPI (* 0.5 PI))
  (SETQ TPI (* 1.5 PI))
  (SETQ BG_ID T)
  (SETVAR "OSMODE" (+ 1 2 32 128 512))
  ;;;取得测量比例、绘图比例、小数位数及基准点、插入点
  (WHILE BG_ID
    (INITGET 128 "O B H D")
    ;;;设置初始测量比例
    (SETQ BGBL (VLAX-LDATA-GET "BGBL" "BGBL"))
    (IF (NOT BGBL) (SETQ BGBL (RTOS (GETVAR "DIMLFAC") 2 2)))
    ;;;设置初始绘图比例
    (SETQ HTBL (VLAX-LDATA-GET "BGBL" "HTBL"))
    (IF (NOT HTBL) (SETQ HTBL (RTOS (GETVAR "DIMSCALE") 2 2)))
    ;;;设置初始小数位数
    (SETQ BGDOT (VLAX-LDATA-GET "BGDOT" "BGDOT"))
    (IF (NOT BGDOT) (SETQ BGDOT "3"))
    ;;;信息提示
    (PRINC (STRCAT "\n***  当前标准样式测量比例为 [1:" BGBL "].绘图比例为 [1:" HTBL "]. 小数位数为 " BGDOT " 位.  ***"))
    ;;;输入关键字或得到基准点、插入点
    (SETQ BSPOINT (GETPOINT "\n请选择标注的起始点或[改标高基点(O)/测量比例(B)/绘图比例(H)/小数位数(D)]:"))
    (COND
      ;;;设置基准点或零米点
      ((OR (= BSPOINT "O") (= BSPOINT "o"))
       (SETQ ORGPOINT (GETPOINT "\n选择标注标高的基点[\"±0.00\"点]:"))
       (SETQ OHEIGHTSTR (RTOS (CADR ORGPOINT) 2 3))
       (VLAX-LDATA-PUT "ORGPOINTY" "ORGPOINTY" OHEIGHTSTR)
       (PRINC
     (STRCAT "\n选择的基点[\"±0.00\"点]在当前坐标系中的高度为: " OHEIGHTSTR " 单位.")
       )
      )
      ;;;设置测量比例
      ((OR (= BSPOINT "b") (= BSPOINT "B"))
       (SETQ BGBLS (GETREAL (STRCAT "请输入新的标高测量比例<" BGBL ">:")))
       (IF (NOT BGBLS)
     (SETQ BGBLS (ATOF BGBL))
     )
       (VLAX-LDATA-PUT "BGBL" "BGBL" (RTOS BGBLS 2 2))
       )
      ;;;设置绘图比例
      ((OR (= BSPOINT "h") (= BSPOINT "H"))
       (SETQ HTBLS (GETREAL (STRCAT "请输入新的标高绘图比例<" HTBL ">:")))
       (IF (NOT HTBLS)
     (SETQ HTBLS (ATOF HTBL))
     )
       (VLAX-LDATA-PUT "BGBL" "HTBL" (RTOS HTBLS 2 2))
       )
      ;;;设置小数位数
      ((OR (= BSPOINT "d") (= BSPOINT "D"))
       (SETQ BGDOTS (GETINT (STRCAT "请输入新的小数位数<" BGDOT ">:")))
       (IF (NOT BGDOTS)
     (SETQ BGDOTS (ATOI BGDOT))
     )
       (VLAX-LDATA-PUT "BGDOT" "BGDOT" (ITOA BGDOTS))
       )
      ;;;得到坐标，设置插入点
      ((= (TYPE BSPOINT) 'LIST)
       (SETQ BG_ID NIL)
       ;;;如果没有设置基准点，则设当前插入点为基准点
       (IF (NOT (VLAX-LDATA-GET "ORGPOINTY" "ORGPOINTY"))
     (PROGN
       (VLAX-LDATA-PUT "ORGPOINTY" "ORGPOINTY" (RTOS (CADR BSPOINT) 2 3))
       )
    )
       )
      (T (PRINC "\n无效的选择或者输入!请重新确认."))
      )
    ); END WHILE
  (SETQ DIMSC (ATOF HTBL));测量比例
  ;;;取得标高文字的默认值
  (SETQ BSPTX (CAR BSPOINT))
  (SETQ BSPTY (CADR BSPOINT))
  (SETQ ORGPTY (VLAX-LDATA-GET "ORGPOINTY" "ORGPOINTY"))
  (IF (NOT ORGPTY) (SETQ ORGPTY (RTOS BSPTY 2 3)))
  (SETQ DEF_BGTXT (RTOS (* 0.001 (- BSPTY (ATOF ORGPTY)) (ATOF BGBL)) 2 (ATOI BGDOT)))
  (PRINC "\n若同时标注多个,请将输入数字用逗号(\",\")隔开. 单位:m.")
  (SETQ BGTXT (GETSTRING (STRCAT "\n输入标高文字<" DEF_BGTXT ">:")))
  (IF (= BGTXT "") (SETQ BGTXT DEF_BGTXT))
  ;;;将输入的单个或多个标高文字组成表
  (SETQ BGTXT (STRCAT "(" BGTXT ")"))
  (SETQ SYMLST (LIST "," "，"))
  (FOREACH SYMBOL SYMLST
    (WHILE (VL-STRING-SEARCH SYMBOL BGTXT)
      (SETQ BGTXT (VL-STRING-SUBST " " SYMBOL BGTXT))
    )
  )
  (SETQ BGLST (READ BGTXT))
  ;;;判断表中的元素是否为数值型，否则剔除
  (SETQ I 0)
  (SETQ BGNUMLST NIL)
  (REPEAT (LENGTH BGLST)
    (SETQ NUM (NTH I BGLST))
    (IF (NUMBERP NUM)
      (SETQ BGNUMLST (CONS NUM BGNUMLST))
      )
    (SETQ I (1+ I))
    )
  (SETQ BGLST (REVERSE BGNUMLST))
  ;;;如果表中数值大于1个，提示标高标注在同一高度
  (IF (> (LENGTH BGLST) 1)
    (PROGN
      (INITGET "Yes No")
      (IF (NOT YESORNO)
    (SETQ YESORNO "Y")
    )
      (SETQ YESNO (GETSTRING (STRCAT "\n是否将标高数字标在同一位置<" (STRCASE YESORNO ) ">:")))
      (IF (= "" YESNO)
    (SETQ YESNO YESORNO)
    (SETQ YESORNO (STRCASE YESNO)) ;保留输入的判断，下次执行时自动转换
    )
      )
    )
  (SETVAR "OSMODE" 0)
  ;;;按照要求写出初始字符串
  (DRAW_FIRST)
  ;;;标高符号绘制预览及绘制
  (VIEW_BG)
  ;;;如果多个标高字符串在不同地方标注，则执行此函数
  (IF_COPYBG)
  ;;;恢复系统变量
  (SETVAR "CLAYER" OLDLAY)
  (SETVAR "OSMODE" OLDOS)
  (SETVAR "DIMZIN" OLDDIMZ)
  (SETVAR "TEXTSTYLE" OLDSTY)
  (SETVAR "CURSORSIZE" OLDCUR)
  (COMMAND ".UNDO" "E")
  (COMMAND ".UCS" "P")
  (SETVAR "CMDECHO" OLDCMD)
  (SETQ *ERROR* &OLDERR&)
  (REDRAW)
  (PRINC)
  )

;;;按照要求写出初始字符串,文字为右下对齐方式
(DEFUN DRAW_FIRST (/ CHK_LAYER     CHK_STYLE   DEF_BGTXTS     I
             NBGLST     TBOX         TEMPTXT     TEXTSTR
             TLENGTH     TXTLTHLST
            )
  (SETQ SSPLINES NIL)
  (SETQ SSPLINES (SSADD))
  ;;;检查并设置"标高标注"为当前图层
  (SETQ CHK_LAYER (TBLSEARCH "LAYER" "标高标注"))
  (IF (= CHK_LAYER NIL)
    (PROGN
      (ENTMAKE (LIST
         '(0 . "LAYER")
         '(100 . "AcDbSymbolTableRecord")
         '(100 . "AcDbLayerTableRecord")
         '(6 . "continuous")    ;线型
         '(62 . 251)        ;图层颜色
         '(70 . 0)        ;图层状态
         (CONS 2 "标高标注")    ;图层名
           )
      )
    )
  )
  (SETVAR "CLAYER" "标高标注")
  ;取得初始标高字符串的插入点
  (SETQ
    PT1    (LIST (+ BSPTX (* DIMSC 20.0)) (+ BSPTY (* DIMSC 3.0)) 0.00)
  )
  ;;;检查并设置"ROMANS"为当前文字样式
  (SETQ CHK_STYLE (TBLSEARCH "STYLE" "ROMANS"))
  (IF (= CHK_STYLE NIL)
    (ENTMAKE (LIST
           '(0 . "STYLE")        ;对象名称
           '(100 . "AcDbSymbolTableRecord")
           '(100
         .
         "AcDbTextStyleTableRecord"
        )            ;子类标记
           '(2 . "ROMANS")        ;字体样式名
           '(70 . 0)        ;标注位码
           '(40 . 0.0)        ;文字高度
           '(41 . 0.70)        ;宽度系数
           '(50 . 0.0)        ;字斜角
           '(71 . 0)        ;文字生成标注位码2＝反向，4＝颠倒
           '(3 . "ROMANS.shx")    ;西文字体名
           '(4 . "BIGFONT.shx")    ;中文字体名
         ) ;_ 结束LIST
    ) ;_ 结束ENTMAKE
  ) ;_ 结束IF
  (SETVAR "TEXTSTYLE" "ROMANS")
  (SETQ I 0)
  (SETQ SSTXTS (SSADD))
  (SETQ TXTPT (POLAR PT1 HPI (* DIMSC 0.6)));文字插入点
  (IF (OR (= YESNO "y") (= YESNO "Y"))
    (PROGN
      (SETQ TXTLTHLST NIL)
      (SETQ BGLST (VL-SORT BGLST '<));标高数值由小到大排序，剔除重复数值
      (REPEAT (LENGTH BGLST)
    (SETQ NBGLST (NTH I BGLST))
    (IF NBGLST
      (PROGN
        ;按照要求设置小数位数
        (SETQ TEXTSTR (RTOS (ATOF (VL-PRINC-TO-STRING NBGLST)) 2 (ATOI BGDOT)))
        ;若字符串为"0.00"，则变成"±0.00"
        (IF (= (RTOS 0 2 (ATOI BGDOT)) TEXTSTR) (SETQ TEXTSTR (STRCAT "%%P" TEXTSTR)))
        )
      )
    (COMMAND "_.TEXT" "J" "BR" TXTPT (* DIMSC 3.0) 0 TEXTSTR)
    (SETQ TEMPTXT (ENTLAST))
    (SETQ TBOX (TEXTBOX (IF (EQ (TYPE TEMPTXT) 'ENAME) (ENTGET TEMPTXT) TEMPTXT)))
        (SETQ TLENGTH (- (CAADR TBOX) (CAAR TBOX)));取得字符串的实际长度
    (SETQ TXTLTHLST (CONS TLENGTH TXTLTHLST))  ;将字符长度组成列表
    (SETQ SSTXTS (SSADD TEMPTXT SSTXTS))
    (SETQ TXTPT (POLAR TXTPT HPI (* DIMSC 4)))
    (SETQ I (1+ I))
    )
      )
    (PROGN
      (SETQ TXTLTHLST NIL)
      (IF (> (LENGTH BGLST) 1)
    (PROGN
      (SETQ BGLST (VL-SORT BGLST '<));标高数值由小到大排序，剔除重复数值
      (SETQ TXTPT (POLAR PT1 HPI (* DIMSC 0.6)))
      (IF (= 0 (ATOF DEF_BGTXT))
        ;若字符串为"0.00"，则变成"±0.00"
        (SETQ DEF_BGTXTS (STRCAT "%%P" DEF_BGTXT))
        (SETQ DEF_BGTXTS DEF_BGTXT)
      )
      (COMMAND "_.TEXT" "J" "BR" TXTPT (* DIMSC 3.0) 0 DEF_BGTXTS)
      (SETQ TEMPTXT (ENTLAST))
      (SETQ SSTXTS (SSADD TEMPTXT SSTXTS))
      )
    (PROGN
      (SETQ TXTPT (POLAR PT1 HPI (* DIMSC 0.6)))
      ;按照要求设置小数位数
      (SETQ TEXTSTR (RTOS (ATOF (VL-PRINC-TO-STRING (NTH 0 BGLST))) 2 (ATOI BGDOT)))
      ;若字符串为"0.00"，则变成"±0.00"
      (IF (= (RTOS 0 2 (ATOI BGDOT)) TEXTSTR) (SETQ TEXTSTR (STRCAT "%%P" TEXTSTR)))
      (COMMAND "_.TEXT" "J" "BR" TXTPT (* DIMSC 3.0) 0 TEXTSTR)
      (SETQ TEMPTXT (ENTLAST))
      (SETQ SSTXTS (SSADD TEMPTXT SSTXTS))
      )
    )
      (SETQ TBOX (TEXTBOX (IF (EQ (TYPE TEMPTXT) 'ENAME) (ENTGET TEMPTXT) TEMPTXT)))
      (SETQ TLENGTH (-(CAADR TBOX) (CAAR TBOX)))      ;取得字符的长度
      (SETQ TXTLTHLST (CONS TLENGTH TXTLTHLST))       ;将字符长度组成列表
      )
    );END IF
  (SETQ TXTLTHLST (VL-SORT TXTLTHLST '>))             ;对表中长度数值由大到小排序
  (SETQ BG_LENGTH (+ (NTH 0 TXTLTHLST) (* 2.0 DIMSC)));求出表中最大值，设置标高线的长度
  );END DEFUN

;;;标高符号绘制预览及绘制
(DEFUN VIEW_BG (/ LOOP_ID VPOINTENT)
  (SETQ LOOP_ID T)
  (SETVAR "CURSORSIZE" 1);将光标大小设置为1，最小尺寸
  (PRINC "\n选择标高文字的插入点:")
  (WHILE LOOP_ID
    (SETQ VPOINTENT (GRREAD T 4 0))
    (IF (= 5 (CAR VPOINTENT));鼠标跟踪
      (PROGN
    (REDRAW)
    (SETQ VPOINT (CADR VPOINTENT))
    (SETQ VPTX (CAR VPOINT))
    (SETQ VPTY (CADR VPOINT))
    (IF (< BSPTX VPTX);鼠标在插入点右边
      (COND
        ;;;以下四AND表示鼠标在第一象限时的预览
        ((AND (<= VPTX (+ BSPTX (+ BG_LENGTH (* DIMSC 8.0))))
          (< BSPTY VPTY)
          (<= VPTY (+ BSPTY (* DIMSC 3.0)))
         )
         (SETQ PT1 (LIST (+ BSPTX (+ BG_LENGTH (* DIMSC 8.0))) (+ BSPTY (* DIMSC 3.0)) 0.00))
         (SETQ PT2 (POLAR PT1 PI BG_LENGTH))
         (SETQ PT3 (POLAR PT2 PI (* DIMSC 6)))
         (SETQ PT4 (POLAR (POLAR PT2 PI (* DIMSC 3)) TPI (* DIMSC 3)))
         (SETQ PT5 (POLAR PT4 0 (* DIMSC 5)))
         (GRVECS (LIST 1 PT1 PT3 1 PT3 PT4 1 PT4 PT2 1 BSPOINT PT5))
         (SETQ MOVEPT (POLAR PT1 HPI (* DIMSC 0.6)))
         ;文字随鼠标移动，并改文字为右下对齐方式
         (MOVE_TEXTS1)
        )
        ((AND (> VPTX (+ BSPTX (+ BG_LENGTH (* DIMSC 8.0))))
          (< BSPTY VPTY)
          (<= VPTY (+ BSPTY (* DIMSC 3.0)))
         )
         (SETQ PT1 (LIST VPTX (+ BSPTY (* DIMSC 3.0)) 0.00))
         (SETQ PT2 (POLAR PT1 PI BG_LENGTH))
         (SETQ PT3 (POLAR PT2 PI (* DIMSC 6)))
         (SETQ PT4 (POLAR (POLAR PT2 PI (* DIMSC 3)) TPI (* DIMSC 3)))
         (SETQ PT5 (POLAR PT4 0 (* DIMSC 5)))
         (GRVECS (LIST 2 PT1 PT3 2 PT3 PT4 2 PT4 PT2 2 BSPOINT PT5))
         (MOVE_TEXTS1)
        )
        ((AND (> VPTX (+ BSPTX BG_LENGTH))
          (< BSPTY VPTY)
          (> VPTY (+ BSPTY (* DIMSC 3.0)))
         )
         (SETQ PT1 VPOINT)
         (SETQ PT2 (POLAR PT1 PI BG_LENGTH))
         (SETQ PT3 (POLAR PT2 TPI (ABS (- VPTY BSPTY))))
         (SETQ PT4 (POLAR (POLAR PT3 HPI (* DIMSC 3.0)) PI (* DIMSC 3.0)))
         (SETQ PT5 (POLAR PT4 0 (* DIMSC 6.0)))
         (SETQ PT6 (POLAR PT3 0 (* DIMSC 5.0)))
         (GRVECS (LIST 4    PT1  PT2  4    PT2  PT3     4    PT3  PT4
               4    PT4  PT5  4    PT5  PT3     4    BSPOINT
               PT6
              )
         )
         (MOVE_TEXTS1)
        )
        ((AND (< VPTX (+ BSPTX BG_LENGTH))
          (< BSPTY VPTY)
          (> VPTY (+ BSPTY (* DIMSC 3.0)))
         )
         (SETQ PT1 (LIST (+ BSPTX BG_LENGTH) VPTY 0.0))
         (SETQ PT2 (POLAR PT1 PI BG_LENGTH))
         (SETQ PT3 (POLAR PT2 TPI (ABS (- VPTY BSPTY))))
         (SETQ PT4 (POLAR (POLAR PT3 HPI (* DIMSC 3.0)) PI (* DIMSC 3.0)))
         (SETQ PT5 (POLAR PT4 0 (* DIMSC 6.0)))
         (GRVECS
           (LIST 5 PT1 PT2 5 PT2 PT3 5 PT3 PT4 5 PT4 PT5 5 PT5 PT3)
         )
         (MOVE_TEXTS1)
        )
            ;;;以下四AND表示鼠标在第四象限时的预览
        ((AND (<= VPTX (+ BSPTX (+ BG_LENGTH (* DIMSC 8.0))))
          (> BSPTY VPTY)
          (>= VPTY (- BSPTY (* DIMSC 3.0)))
         )
         (SETQ PT1 (LIST (+ BSPTX (+ BG_LENGTH (* DIMSC 8.0))) (- BSPTY (* DIMSC 3.0)) 0.00))
         (SETQ PT2 (POLAR PT1 PI BG_LENGTH))
         (SETQ PT3 (POLAR PT2 PI (* DIMSC 6)))
         (SETQ PT4 (POLAR (POLAR PT2 PI (* DIMSC 3)) HPI (* DIMSC 3)))
         (SETQ PT5 (POLAR PT4 0 (* DIMSC 5)))
         (GRVECS (LIST 1 PT1 PT3 1 PT3 PT4 1 PT4 PT2 1 BSPOINT PT5))
         ;文字随鼠标移动，并改文字为右上对齐方式
         (MOVE_TEXTS2)
        )
        ((AND (> VPTX (+ BSPTX (+ BG_LENGTH (* DIMSC 8.0))))
          (> BSPTY VPTY)
          (>= VPTY (- BSPTY (* DIMSC 3.0)))
         )
         (SETQ PT1 (LIST VPTX (- BSPTY (* DIMSC 3.0)) 0.00))
         (SETQ PT2 (POLAR PT1 PI BG_LENGTH))
         (SETQ PT3 (POLAR PT2 PI (* DIMSC 6)))
         (SETQ PT4 (POLAR (POLAR PT2 PI (* DIMSC 3)) HPI (* DIMSC 3)))
         (SETQ PT5 (POLAR PT4 0 (* DIMSC 5)))
         (GRVECS (LIST 2 PT1 PT3 2 PT3 PT4 2 PT4 PT2 2 BSPOINT PT5))
         (MOVE_TEXTS2)
        )
        ((AND (> VPTX (+ BSPTX BG_LENGTH))
          (> BSPTY VPTY)
          (<= VPTY (- BSPTY (* DIMSC 3.0)))
         )
         (SETQ PT1 VPOINT)
         (SETQ PT2 (POLAR PT1 PI BG_LENGTH))
         (SETQ PT3 (POLAR PT2 HPI (- BSPTY VPTY)))
         (SETQ PT4 (POLAR (POLAR PT3 TPI (* DIMSC 3.0)) PI (* DIMSC 3.0)))
         (SETQ PT5 (POLAR PT4 0 (* DIMSC 6.0)))
         (SETQ PT6 (POLAR PT3 0 (* DIMSC 5.0)))
         (GRVECS (LIST 4    PT1  PT2  4    PT2  PT3     4    PT3  PT4
               4    PT4  PT5  4    PT5  PT3     4    BSPOINT
               PT6
              )
         )
         (MOVE_TEXTS2)
        )
        ((AND (< VPTX (+ BSPTX BG_LENGTH))
          (> BSPTY VPTY)
          (<= VPTY (- BSPTY (* DIMSC 3.0)))
         )
         (SETQ PT1 (LIST (+ BSPTX BG_LENGTH) VPTY 0.0))
         (SETQ PT2 (POLAR PT1 PI BG_LENGTH))
         (SETQ PT3 (POLAR PT2 HPI (- BSPTY VPTY)))
         (SETQ PT4 (POLAR (POLAR PT3 TPI (* DIMSC 3.0)) PI (* DIMSC 3.0)))
         (SETQ PT5 (POLAR PT4 0 (* DIMSC 6.0)))
         (GRVECS
           (LIST 5 PT1 PT2 5 PT2 PT3 5 PT3 PT4 5 PT4 PT5 5 PT5 PT3)
         )
         (MOVE_TEXTS2)
        )
      )
      
          ;;;鼠标在插入点左边
      (COND
        ;;;以下四AND表示鼠标在第二象限时的预览
        ((AND (>= VPTX (- BSPTX (+ BG_LENGTH (* DIMSC 8.0))))
          (< BSPTY VPTY)
          (<= VPTY (+ BSPTY (* DIMSC 3.0)))
         )
         (SETQ PT1 (LIST (- BSPTX (+ BG_LENGTH (* DIMSC 8.0))) (+ BSPTY (* DIMSC 3.0)) 0.00))
         (SETQ PT2 (POLAR PT1 0 BG_LENGTH))
         (SETQ PT3 (POLAR PT2 0 (* DIMSC 6)))
         (SETQ PT4 (POLAR (POLAR PT2 0 (* DIMSC 3)) TPI (* DIMSC 3)))
         (SETQ PT5 (POLAR PT4 PI (* DIMSC 5)))
         (GRVECS (LIST 1 PT1 PT3 1 PT3 PT4 1 PT4 PT2 1 BSPOINT PT5))
         ;文字随鼠标移动，并改文字为左下对齐方式
         (MOVE_TEXTS3)
        )
        ((AND (< VPTX (- BSPTX (+ BG_LENGTH (* DIMSC 8.0))))
          (< BSPTY VPTY)
          (<= VPTY (+ BSPTY (* DIMSC 3.0)))
         )
         (SETQ PT1 (LIST VPTX (+ BSPTY (* DIMSC 3.0)) 0.00))
         (SETQ PT2 (POLAR PT1 0 BG_LENGTH))
         (SETQ PT3 (POLAR PT2 0 (* DIMSC 6)))
         (SETQ PT4 (POLAR (POLAR PT2 0 (* DIMSC 3)) TPI (* DIMSC 3)))
         (SETQ PT5 (POLAR PT4 PI (* DIMSC 5)))
         (GRVECS (LIST 2 PT1 PT3 2 PT3 PT4 2 PT4 PT2 2 BSPOINT PT5))
         (MOVE_TEXTS3)
        )
        ((AND (< VPTX (- BSPTX BG_LENGTH))
          (< BSPTY VPTY)
          (> VPTY (+ BSPTY (* DIMSC 3.0)))
         )
         (SETQ PT1 VPOINT)
         (SETQ PT2 (POLAR PT1 0 BG_LENGTH))
         (SETQ PT3 (POLAR PT2 TPI (ABS (- VPTY BSPTY))))
         (SETQ PT4 (POLAR (POLAR PT3 HPI (* DIMSC 3.0)) 0 (* DIMSC 3.0)))
         (SETQ PT5 (POLAR PT4 PI (* DIMSC 6.0)))
         (SETQ PT6 (POLAR PT3 PI (* DIMSC 5.0)))
         (GRVECS (LIST 4    PT1  PT2  4    PT2  PT3     4    PT3  PT4
               4    PT4  PT5  4    PT5  PT3     4    BSPOINT
               PT6
              )
         )
         (MOVE_TEXTS3)
        )
        ((AND (>= VPTX (- BSPTX BG_LENGTH))
          (< BSPTY VPTY)
          (> VPTY (+ BSPTY (* DIMSC 3.0)))
         )
         (SETQ PT1 (LIST (- BSPTX BG_LENGTH) VPTY 0.0))
         (SETQ PT2 (POLAR PT1 0 BG_LENGTH))
         (SETQ PT3 (POLAR PT2 TPI (ABS (- VPTY BSPTY))))
         (SETQ PT4 (POLAR (POLAR PT3 HPI (* DIMSC 3.0)) PI (* DIMSC 3.0)))
         (SETQ PT5 (POLAR PT4 0 (* DIMSC 6.0)))
         (GRVECS
           (LIST 5 PT1 PT2 5 PT2 PT3 5 PT3 PT4 5 PT4 PT5 5 PT5 PT3)
         )
         (MOVE_TEXTS3)
        )
            ;;;以下四AND表示鼠标在第三象限时的预览
        ((AND (>= VPTX (- BSPTX (+ BG_LENGTH (* DIMSC 8.0))))
          (> BSPTY VPTY)
          (>= VPTY (- BSPTY (* DIMSC 3.0)))
         )
         (SETQ PT1 (LIST (- BSPTX (+ BG_LENGTH (* DIMSC 8.0))) (- BSPTY (* DIMSC 3.0)) 0.00))
         (SETQ PT2 (POLAR PT1 0 BG_LENGTH))
         (SETQ PT3 (POLAR PT2 0 (* DIMSC 6)))
         (SETQ PT4 (POLAR (POLAR PT2 0 (* DIMSC 3)) HPI (* DIMSC 3)))
         (SETQ PT5 (POLAR PT4 PI (* DIMSC 5)))
         (GRVECS (LIST 1 PT1 PT3 1 PT3 PT4 1 PT4 PT2 1 BSPOINT PT5))
         ;文字随鼠标移动，并改文字为左上对齐方式
         (MOVE_TEXTS4)
        )
        ((AND (< VPTX (- BSPTX (+ BG_LENGTH (* DIMSC 8.0))))
          (> BSPTY VPTY)
          (>= VPTY (- BSPTY (* DIMSC 3.0)))
         )
         (SETQ PT1 (LIST VPTX (- BSPTY (* DIMSC 3.0)) 0.00))
         (SETQ PT2 (POLAR PT1 0 BG_LENGTH))
         (SETQ PT3 (POLAR PT2 0 (* DIMSC 6)))
         (SETQ PT4 (POLAR (POLAR PT2 0 (* DIMSC 3)) HPI (* DIMSC 3)))
         (SETQ PT5 (POLAR PT4 PI (* DIMSC 5)))
         (GRVECS (LIST 2 PT1 PT3 2 PT3 PT4 2 PT4 PT2 2 BSPOINT PT5))
         (MOVE_TEXTS4)
        )
        ((AND (< VPTX (- BSPTX BG_LENGTH))
          (> BSPTY VPTY)
          (< VPTY (- BSPTY (* DIMSC 3.0)))
         )
         (SETQ PT1 VPOINT)
         (SETQ PT2 (POLAR PT1 0 BG_LENGTH))
         (SETQ PT3 (POLAR PT2 HPI (ABS (- VPTY BSPTY))))
         (SETQ PT4 (POLAR (POLAR PT3 TPI (* DIMSC 3.0)) 0 (* DIMSC 3.0)))
         (SETQ PT5 (POLAR PT4 PI (* DIMSC 6.0)))
         (SETQ PT6 (POLAR PT3 PI (* DIMSC 5.0)))
         (GRVECS (LIST 4    PT1  PT2  4    PT2  PT3     4    PT3  PT4
               4    PT4  PT5  4    PT5  PT3     4    BSPOINT
               PT6
              )
         )
         (MOVE_TEXTS4)
        )
        ((AND (>= VPTX (- BSPTX BG_LENGTH))
          (> BSPTY VPTY)
          (< VPTY (- BSPTY (* DIMSC 3.0)))
         )
         (SETQ PT1 (LIST (- BSPTX BG_LENGTH) VPTY 0.0))
         (SETQ PT2 (POLAR PT1 0 BG_LENGTH))
         (SETQ PT3 (POLAR PT2 HPI (ABS (- VPTY BSPTY))))
         (SETQ PT4 (POLAR (POLAR PT3 TPI (* DIMSC 3.0)) 0 (* DIMSC 3.0)))
         (SETQ PT5 (POLAR PT4 PI (* DIMSC 6.0)))
         (GRVECS
           (LIST 5 PT1 PT2 5 PT2 PT3 5 PT3 PT4 5 PT4 PT5 5 PT5 PT3)
         )
         (MOVE_TEXTS4)
        )
      )
    )
    )
      )
    ;;;若点击鼠标左、右键或键盘任意按键，则取得当前鼠标位置，并绘制标高符号
    (IF (OR (= 3 (CAR VPOINTENT)) (= 2 (CAR VPOINTENT)) (= 11 (CAR VPOINTENT)))
      (PROGN
    (SETQ LOOP_ID NIL)
    ;;;绘制标高符号
    (DRAW_LINES)
    )
      )
    );END WHILE
  (PRINC)
  )

;;;文字设置成右下格式
(DEFUN MOVE_TEXTS1 (/ ENAME INSPT MPOINTS N INDEX ENT)
  (SETQ INDEX 0)
  (SETQ N (SSLENGTH SSTXTS))
  (SETQ INSPT (POLAR PT1 HPI (* DIMSC 0.6)))
  (WHILE (< INDEX N)
    (SETQ MPOINTS (POLAR INSPT (* 0.5 PI) (* INDEX DIMSC 4)))
    (SETQ ENAME (SSNAME SSTXTS INDEX))
    (SETQ ENT (ENTGET ENAME))
    (SETQ ENT (SUBST (CONS 11 MPOINTS) (ASSOC 11 ENT) ENT))
    (SETQ ENT (SUBST (CONS 72 2) (ASSOC 72 ENT) ENT))
    (SETQ ENT (SUBST (CONS 73 1) (ASSOC 73 ENT) ENT))
    (ENTMOD ENT)
    (ENTUPD ENAME)
    (SETQ INDEX (1+ INDEX))
  )
)

;;;文字设置成右上格式
(DEFUN MOVE_TEXTS2 (/ ENAME INSPT MPOINTS N INDEX ENT)
  (SETQ INDEX 0)
  (SETQ N (SSLENGTH SSTXTS))
  (SETQ INSPT (POLAR PT1 TPI (* DIMSC 0.8)))
  (WHILE (< INDEX N)
    (SETQ MPOINTS (POLAR INSPT (* 1.5 PI) (* INDEX DIMSC 4)))
    (SETQ ENAME (SSNAME SSTXTS (- N 1 INDEX)))
    (SETQ ENT (ENTGET ENAME))
    (SETQ ENT (SUBST (CONS 11 MPOINTS) (ASSOC 11 ENT) ENT))
    (SETQ ENT (SUBST (CONS 72 2) (ASSOC 72 ENT) ENT))
    (SETQ ENT (SUBST (CONS 73 3) (ASSOC 73 ENT) ENT))
    (ENTMOD ENT)
    (ENTUPD ENAME)
    (SETQ INDEX (1+ INDEX))
  )
)

;;;文字设置成左下格式
(DEFUN MOVE_TEXTS3 (/ ENAME INSPT MPOINTS N INDEX ENT)
  (SETQ INDEX 0)
  (SETQ N (SSLENGTH SSTXTS))
  (SETQ INSPT (POLAR PT1 HPI (* DIMSC 0.6)))
  (WHILE (< INDEX N)
    (SETQ MPOINTS (POLAR INSPT (* 0.5 PI) (* INDEX DIMSC 4)))
    (SETQ ENAME (SSNAME SSTXTS INDEX))
    (SETQ ENT (ENTGET ENAME))
    (SETQ ENT (SUBST (CONS 11 MPOINTS) (ASSOC 11 ENT) ENT))
    (SETQ ENT (SUBST (CONS 72 0) (ASSOC 72 ENT) ENT))
    (SETQ ENT (SUBST (CONS 73 1) (ASSOC 73 ENT) ENT))
    (ENTMOD ENT)
    (ENTUPD ENAME)
    (SETQ INDEX (1+ INDEX))
  )
)

;;;文字设置成左上格式
(DEFUN MOVE_TEXTS4 (/ ENAME INSPT MPOINTS N INDEX ENT)
  (SETQ INDEX 0)
  (SETQ N (SSLENGTH SSTXTS))
  (SETQ INSPT (POLAR PT1 TPI (* DIMSC 0.8)))
  (WHILE (< INDEX N)
    (SETQ MPOINTS (POLAR INSPT (* 1.5 PI) (* INDEX DIMSC 4)))
    (SETQ ENAME (SSNAME SSTXTS (- N 1 INDEX)))
    (SETQ ENT (ENTGET ENAME))
    (SETQ ENT (SUBST (CONS 11 MPOINTS) (ASSOC 11 ENT) ENT))
    (SETQ ENT (SUBST (CONS 72 0) (ASSOC 72 ENT) ENT))
    (SETQ ENT (SUBST (CONS 73 3) (ASSOC 73 ENT) ENT))
    (ENTMOD ENT)
    (ENTUPD ENAME)
    (SETQ INDEX (1+ INDEX))
  )
)

;;;绘制标高符号
(DEFUN DRAW_LINES ()
  (SETQ SSPLINES NIL)
  (SETQ SSPLINES (SSADD))
  (REDRAW)
  ;;;以下鼠标位置注释同预览注释
  (IF (< BSPTX VPTX)
    (COND
      ((AND (<= VPTX (+ BSPTX (+ BG_LENGTH (* DIMSC 8.0))))
        (< BSPTY VPTY)
        (<= VPTY (+ BSPTY (* DIMSC 3.0)))
       )
       (COMMAND "_.PLINE" PT1 "W" 0 0 PT3 PT4 PT2 "")
       (SETQ SSPLINES (SSADD (ENTLAST) SSPLINES))
       (COMMAND "_.PLINE" BSPOINT "W" 0 0 PT5 "")
       (SETQ SSPLINES (SSADD (ENTLAST) SSPLINES))
      )
      ((AND (> VPTX (+ BSPTX (+ BG_LENGTH (* DIMSC 8.0))))
        (< BSPTY VPTY)
        (<= VPTY (+ BSPTY (* DIMSC 3.0)))
       )
       (COMMAND "_.PLINE" PT1 "W" 0 0 PT3 PT4 PT2 "")
       (SETQ SSPLINES (SSADD (ENTLAST) SSPLINES))
       (COMMAND "_.PLINE" BSPOINT "W" 0 0 PT5 "")
       (SETQ SSPLINES (SSADD (ENTLAST) SSPLINES))
      )
      ((AND (> VPTX (+ BSPTX BG_LENGTH))
        (< BSPTY VPTY)
        (> VPTY (+ BSPTY (* DIMSC 3.0)))
       )
       (COMMAND "_.PLINE" PT1 "W" 0 0 PT2 PT3"")
       (SETQ SSPLINES (SSADD (ENTLAST) SSPLINES))
       (COMMAND "_.PLINE" PT3 "W" 0 0  PT4 PT5 "C")
       (SETQ SSPLINES (SSADD (ENTLAST) SSPLINES))
       (COMMAND "_.PLINE" BSPOINT "W" 0 0 PT6 "")
       (SETQ SSPLINES (SSADD (ENTLAST) SSPLINES))
      )
      ((AND (< VPTX (+ BSPTX BG_LENGTH))
        (< BSPTY VPTY)
        (> VPTY (+ BSPTY (* DIMSC 3.0)))
       )
       (COMMAND "_.PLINE" PT1 "W" 0 0 PT2 PT3"")
       (SETQ SSPLINES (SSADD (ENTLAST) SSPLINES))
       (COMMAND "_.PLINE" PT3 "W" 0 0  PT4 PT5 "C")
       (SETQ SSPLINES (SSADD (ENTLAST) SSPLINES))
      )
      ;;;BELOW
      ((AND (<= VPTX (+ BSPTX (+ BG_LENGTH (* DIMSC 8.0))))
        (> BSPTY VPTY)
        (>= VPTY (- BSPTY (* DIMSC 3.0)))
       )
       (COMMAND "_.PLINE" PT1 "W" 0 0 PT3 PT4 PT2 "")
       (SETQ SSPLINES (SSADD (ENTLAST) SSPLINES))
       (COMMAND "_.PLINE" BSPOINT "W" 0 0 PT5 "")
       (SETQ SSPLINES (SSADD (ENTLAST) SSPLINES))
      )
      ((AND (> VPTX (+ BSPTX (+ BG_LENGTH (* DIMSC 8.0))))
        (> BSPTY VPTY)
        (>= VPTY (- BSPTY (* DIMSC 3.0)))
       )
       (COMMAND "_.PLINE" PT1 "W" 0 0 PT3 PT4 PT2 "")
       (SETQ SSPLINES (SSADD (ENTLAST) SSPLINES))
       (COMMAND "_.PLINE" BSPOINT "W" 0 0 PT5 "")
       (SETQ SSPLINES (SSADD (ENTLAST) SSPLINES))
      )
      ((AND (> VPTX (+ BSPTX BG_LENGTH))
        (> BSPTY VPTY)
        (<= VPTY (- BSPTY (* DIMSC 3.0)))
       )
       (COMMAND "_.PLINE" PT1 "W" 0 0 PT2 PT3"")
       (SETQ SSPLINES (SSADD (ENTLAST) SSPLINES))
       (COMMAND "_.PLINE" PT3 "W" 0 0  PT4 PT5 "C")
       (SETQ SSPLINES (SSADD (ENTLAST) SSPLINES))
       (COMMAND "_.PLINE" BSPOINT "W" 0 0 PT6 "")
       (SETQ SSPLINES (SSADD (ENTLAST) SSPLINES))
      )
      ((AND (< VPTX (+ BSPTX BG_LENGTH))
        (> BSPTY VPTY)
        (<= VPTY (- BSPTY (* DIMSC 3.0)))
       )
       (COMMAND "_.PLINE" PT1 "W" 0 0 PT2 PT3"")
       (SETQ SSPLINES (SSADD (ENTLAST) SSPLINES))
       (COMMAND "_.PLINE" PT3 "W" 0 0  PT4 PT5 "C")
       (SETQ SSPLINES (SSADD (ENTLAST) SSPLINES))
      )
    )
    ;;;鼠标在插入点左边
    (COND
      ((AND (>= VPTX (- BSPTX (+ BG_LENGTH (* DIMSC 8.0))))
        (< BSPTY VPTY)
        (<= VPTY (+ BSPTY (* DIMSC 3.0)))
       )
       (COMMAND "_.PLINE" PT1 "W" 0 0 PT3 PT4 PT2 "")
       (SETQ SSPLINES (SSADD (ENTLAST) SSPLINES))
       (COMMAND "_.PLINE" BSPOINT "W" 0 0 PT5 "")
       (SETQ SSPLINES (SSADD (ENTLAST) SSPLINES))
      )
      ((AND (< VPTX (- BSPTX (+ BG_LENGTH (* DIMSC 8.0))))
        (< BSPTY VPTY)
        (<= VPTY (+ BSPTY (* DIMSC 3.0)))
       )
       (COMMAND "_.PLINE" PT1 "W" 0 0 PT3 PT4 PT2 "")
       (SETQ SSPLINES (SSADD (ENTLAST) SSPLINES))
       (COMMAND "_.PLINE" BSPOINT "W" 0 0 PT5 "")
       (SETQ SSPLINES (SSADD (ENTLAST) SSPLINES))
      )
      ((AND (< VPTX (- BSPTX BG_LENGTH))
        (< BSPTY VPTY)
        (> VPTY (+ BSPTY (* DIMSC 3.0)))
       )
       (COMMAND "_.PLINE" PT1 "W" 0 0 PT2 PT3"")
       (SETQ SSPLINES (SSADD (ENTLAST) SSPLINES))
       (COMMAND "_.PLINE" PT3 "W" 0 0  PT4 PT5 "C")
       (SETQ SSPLINES (SSADD (ENTLAST) SSPLINES))
       (COMMAND "_.PLINE" BSPOINT "W" 0 0 PT6 "")
       (SETQ SSPLINES (SSADD (ENTLAST) SSPLINES))
      )
      ((AND (>= VPTX (- BSPTX BG_LENGTH))
        (< BSPTY VPTY)
        (> VPTY (+ BSPTY (* DIMSC 3.0)))
       )
       (COMMAND "_.PLINE" PT1 "W" 0 0 PT2 PT3"")
       (SETQ SSPLINES (SSADD (ENTLAST) SSPLINES))
       (COMMAND "_.PLINE" PT3 "W" 0 0  PT4 PT5 "C")
       (SETQ SSPLINES (SSADD (ENTLAST) SSPLINES))
      )
      ;;;BELOW
      ((AND (>= VPTX (- BSPTX (+ BG_LENGTH (* DIMSC 8.0))))
        (> BSPTY VPTY)
        (>= VPTY (- BSPTY (* DIMSC 3.0)))
       )
       (COMMAND "_.PLINE" PT1 "W" 0 0 PT3 PT4 PT2 "")
       (SETQ SSPLINES (SSADD (ENTLAST) SSPLINES))
       (COMMAND "_.PLINE" BSPOINT "W" 0 0 PT5 "")
       (SETQ SSPLINES (SSADD (ENTLAST) SSPLINES))
      )
      ((AND (< VPTX (- BSPTX (+ BG_LENGTH (* DIMSC 8.0))))
        (> BSPTY VPTY)
        (>= VPTY (- BSPTY (* DIMSC 3.0)))
       )
       (COMMAND "_.PLINE" PT1 "W" 0 0 PT3 PT4 PT2 "")
       (SETQ SSPLINES (SSADD (ENTLAST) SSPLINES))
       (COMMAND "_.PLINE" BSPOINT "W" 0 0 PT5 "")
       (SETQ SSPLINES (SSADD (ENTLAST) SSPLINES))
      )
      ((AND (< VPTX (- BSPTX BG_LENGTH))
        (> BSPTY VPTY)
        (< VPTY (- BSPTY (* DIMSC 3.0)))
       )
       (COMMAND "_.PLINE" PT1 "W" 0 0 PT2 PT3"")
       (SETQ SSPLINES (SSADD (ENTLAST) SSPLINES))
       (COMMAND "_.PLINE" PT3 "W" 0 0  PT4 PT5 "C")
       (SETQ SSPLINES (SSADD (ENTLAST) SSPLINES))
       (COMMAND "_.PLINE" BSPOINT "W" 0 0 PT6 "")
       (SETQ SSPLINES (SSADD (ENTLAST) SSPLINES))
      )
      ((AND (>= VPTX (- BSPTX BG_LENGTH))
        (> BSPTY VPTY)
        (< VPTY (- BSPTY (* DIMSC 3.0)))
       )
       (COMMAND "_.PLINE" PT1 "W" 0 0 PT2 PT3"")
       (SETQ SSPLINES (SSADD (ENTLAST) SSPLINES))
       (COMMAND "_.PLINE" PT3 "W" 0 0  PT4 PT5 "C")
       (SETQ SSPLINES (SSADD (ENTLAST) SSPLINES))
      )
    )
  )
)

;;;如果多个标高数据在不同高度标注
(DEFUN IF_COPYBG (/ DEF_BGTXTS I IBASEPT MOVEPT TXTJUST GAP)
  (IF (AND (> (LENGTH BGLST) 1) (OR (= YESNO "N") (= YESNO "n")))
    (PROGN
      (SETQ BGLST (VL-SORT BGLST '<))
      (SUB_COPYBG)
      (SETQ TXTPT (POLAR PT1 HPI GAP))
      (SETQ IBASEPT (LIST (CAR TXTPT) (/ (ATOF DEF_BGTXT) 0.001 (ATOF BGBL)) 0.0));取得0m点
      (SETQ I 0)
      (REPEAT (LENGTH BGLST)
    (SETQ MOVEPT (POLAR TXTPT HPI (/  (- (NTH I BGLST) (ATOF DEF_BGTXT)) 0.001 (ATOF BGBL))))
    (COMMAND "_.COPY" SSPLINES "" TXTPT MOVEPT)
    (SETQ TEXTSTR (RTOS (ATOF (VL-PRINC-TO-STRING (NTH I BGLST))) 2 (ATOI BGDOT)))
    (IF (= 0 (ATOF TEXTSTR)) (SETQ TEXTSTR (STRCAT "%%P" TEXTSTR)))
    (COMMAND "_.TEXT" "J" TXTJUST MOVEPT (* DIMSC 3.0) 0 TEXTSTR)
    (SETQ I (1+ I))
    )
      )
    )
  )

;;;设置多重标注时的文字对齐方式及文字离线垂直距离
(DEFUN SUB_COPYBG ()
  (COND
    ((AND (< BSPTX VPTX) (< BSPTY VPTY))
     (SETQ TXTJUST "BR")
     (SETQ GAP (* DIMSC 0.6))
    )
    ((AND (< VPTX BSPTX) (< BSPTY VPTY))
     (SETQ TXTJUST "BL")
     (SETQ GAP (* DIMSC 0.6))
    )
    ((AND (< BSPTX VPTX) (< VPTY BSPTY))
     (SETQ TXTJUST "TR")
     (SETQ GAP (* DIMSC -0.6))
    )
    ((AND (< VPTX BSPTX) (< VPTY BSPTY))
     (SETQ TXTJUST "TL")
     (SETQ GAP (* DIMSC -0.6))
    )
  )
)
[/pcode]

goodday01

这个标高程序不错，很好用谢谢楼主

sahara124

相当适合给排水用户

sfgg99

不错不错。值得学习啊！

95021glq

代码很长，需要仔细研究一下。

gcho

确实厉害啊
下载慢慢研究学习！

yoyoho

感谢楼主
下载研究研究了!

tjuzkj

正需要！谢谢！

sahara124

多谢大家支持，标高在画图中相当实用

paladi

怎么用啊，是直接复制了做个LISP就行了吗？是不是有附件啊，我怎么看不到啊～

zdc51858

代码这么长，需要仔细学习一下！感谢引导！

xxbear

真是不错

keleccy

牛人，谢谢

lmt112233

标高程序不错，謝謝樓主

keleccy

嗯，非常实用