www.pudn.com > CADtool.rar > PS_jdgc.lsp, change:2008-10-20,size:5656b


;;;------------------------------------------------------------------------ 
;;;计算、标注井底高程 
(vl-load-com) 
(defun c:PS_jdgc (/           StrFenGe    ListPI      OriginalGaoCheng        strGPI 
                   ResultGaoCheng          ob          obn         obname      obstr 
                   strText     keyW        GoOn 
                  ) 
;;;------------------------------------------------------------------------ 
;;;返回表 ( (管长,坡度)   )  , 若原字串格式有误,则返回nil 
 (defun DLIStrToList (OriginalStr / NewStr ListReturn ch PoDu GuanChang) 
  (if (not (vl-string-search StrFenGe OriginalStr)) 
   (setq ListReturn nil) 
;;;如果字串中一个分隔符也没有,说明字串格式不对,返回值设置为nil 
   (progn 
    (if (/= StrFenGe "  ") 
     (setq NewStr (vl-string-subst "  " StrFenGe OriginalStr)) 
    ) 
    ;;把分隔符替换为两个空格:一个空格会出错;换为空格后,lisp容易处理 
    (while (/= (setq ch (substr NewStr 1 1)) " ") 
     (setq NewStr (substr NewStr 2)) 
    ) 
    ;;消去管径字符 
 
    (while (= (setq ch (substr NewStr 1 1)) " ") 
     (setq NewStr (substr NewStr 2)) 
    ) 
    ;;消去第一个分隔符 
 
    (if (not (vl-string-search StrFenGe NewStr)) 
     (setq ListReturn nil) 
;;;如果字串中没有第二个分隔符,说明字串格式不对,返回值设置为nil 
 
     (progn 
      (if (/= StrFenGe "  ") 
       (setq NewStr (vl-string-subst "  " StrFenGe NewStr)) 
      ) 
      ;;把分隔符替换为两个空格:一个空格会出错;换为空格后,lisp容易处理 
      (setq GuanChang (read NewStr)) 
      ;;取得管长数值 
 
      (while (/= (setq ch (substr NewStr 1 1)) " ") 
       (setq NewStr (substr NewStr 2)) 
      ) 
      ;;消去管长字符 
 
      (while (= (setq ch (substr NewStr 1 1)) " ") 
       (setq NewStr (substr NewStr 2)) 
      ) 
      ;;消去第二个分隔符 
 
      (setq PoDu (read NewStr)) 
      ;;取得坡度数值 
 
      (if (and (numberp GuanChang) (numberp PoDu)) 
       (setq ListReturn (list GuanChang PoDu)) 
       (setq ListReturn nil) 
      ) 
     ) 
    ) 
   ) 
  ) 
  ListReturn 
 ) 
;;;------------------------------------------------------------------------ 
 (setvar "dimzin" 0) ; 使输出结果不消除后续0 
 (princ "\n选择起点的管道标高文本:") 
 (setq GoOn "Continue") ;GoOn用于控制是否继续运行 
 (setq obn 2) 
 (while (> obn 1) 
  (setq ob (ssget '((0 . "text")))) ; 创建选择集 ob 
  (if (not ob) 
   (setq obn 0) 
   (setq obn (sslength ob)) 
  ) 
  (cond 
   ((= obn 0) (setq GoOn "Stop")) 
   ((= obn 1) 
    (setq obname (ssname ob 0)) ; obname,取得第1个对象名 
    (setq obstr (entget obname)) 
    (setq strText (cdr (assoc 1 obstr))) ; 取得第1个对象的文字内容 
    (setq OriginalGaoCheng (read strText)) 
    (if (not (numberp OriginalGaoCheng)) 
     (progn 
      (princ "\n所择的文本不是数字,请重新选择!\n") 
      (setq ob  nil 
            obn 2 
      ) 
     ) 
    ) 
   ) 
   (T nil) 
  ) 
 ) 
 ;;限制只允许选择一个有效高程文本 
 ;;确定起点井底高程 
 (if (= GoOn "Continue") 
  (progn 
   (if (= "" 
          (setq StrFenGe (getstring "\n输入文本中管径,管长及坡度的分隔符号<\"-\">:")) 
       ) 
    (setq StrFenGe "-") 
   ) 
   (princ "\n后续井底高程相对于起点井底高程:") 
   (initget "A S") 
   (setq keyW (getkword "\n增加(A)/减少(S)<S>:")) 
;;;------------------------------------------------------------------------ 
   (while (= GoOn "Continue") 
;;;------------------------------------------------------------------------ 
;;;以下控制选择正确的"管径-管道-标高"文本 
    (setq obn 2 
          ob  nil 
    ) 
    (while (> obn 1) 
     (princ "\n选择一个\"管径-管道-标高\"文本:") 
     (setq ob (ssget '((0 . "text")))) ; 创建选择集 ob 
     (if (not ob) 
      (setq obn 0) 
      (setq obn (sslength ob)) 
     ) 
     (cond 
      ((= obn 0) (setq GoOn "Stop")) 
      ((= obn 1) 
       (setq obname (ssname ob 0)) ; obname,取得第1个对象名 
       (setq obstr (entget obname)) 
       (setq strGPI (cdr (assoc 1 obstr))) ; 取得第1个对象的文字内容 
       (setq ListPI (DLIStrToList strGPI)) 
       (if (not ListPI) 
        (progn 
         (princ "\n所择的文本格式有误,请重新选择!") 
         (setq ob  nil 
               obn 2 
         ) 
        ) 
       ) 
      ) 
      (T (princ "\n所择了多个单行文本,请重新选择!")) 
     ) 
    ) 
;;;------------------------------------------------------------------------ 
;;;输出计算结果 
    (if (= GoOn "Continue") 
     (progn 
;;;以下选择需要输入计算结果的本 
      (setq obn 2 
            ob  nil 
      ) 
      (while (> obn 1) 
       (princ "\n选择输出计算结果的文本:") 
       (setq ob (ssget '((0 . "text")))) ; 创建选择集 ob 
       (if (not ob) 
        (setq obn 0) 
        (setq obn (sslength ob)) 
       ) 
       (cond 
        ((= obn 0) (setq GoOn "Stop")) 
 
        ((= obn 1) 
         (setq obname (ssname ob 0)) ; obname,取得第1个对象名 
         (setq obstr (entget obname)) 
 
         (setq ResultGaoCheng (/ (* (car ListPI) (cadr ListPI)) 1000.0)) 
         (if (= keyW "A") 
          (setq ResultGaoCheng (+ OriginalGaoCheng ResultGaoCheng)) 
          (setq ResultGaoCheng (- OriginalGaoCheng ResultGaoCheng)) 
         ) 
 
         (setq OriginalGaoCheng ResultGaoCheng) 
         (entmod (subst (cons 1 (rtos ResultGaoCheng 2 3)) 
                        (assoc 1 obstr) 
                        obstr 
                 ) 
         ) 
         (entupd obname) 
        ) 
 
        (T (princ "\n所择了多个单行文本,请重新选择!")) 
       ) 
      ) 
      ;;限制只允许选择一个有效高程文本 
     ) 
     ;;确定起点井底高程 
;;;------------------------------------------------------------------------ 
    ) 
   ) 
  ) 
 ) 
 (princ) 
) 
;;;------------------------------------------------------------------------