[LISP程序]：PKPM结果取大

qiaqiadeng

本程序用来处理PKPM中wpj*.t、wpjc*.t等图中结果取大，使用方法为：将若干层的wpj文件插入CAD图中，然后将要归并的几层摞在一起，框选梁每一跨的结果文字，程序自动将取大结果写成文字，并将之置于defpoints图层，颜色为红色，程序不支持整层框选，因为那样出错了都不知道，可以处理如下情况：
G1.5-1.2
11-7-0
VT1-0.0
Lc 、Ls、H、psv
代码如下：
(defun *$dyq-error$* (msg)
  ;(command ".undo" "")
  (setq *error* &olderr&)
  ;(princ)
)

(defun dyq-findstr (strstr fstr ii / i lenstr astr)
  ;若自左向右查找则ii=1，否则ii=-1，ii为其他数字将不被允许
  (setq lenstr (strlen strstr))
  (setq lenfstr (strlen fstr))
  (setq astr 0)
  (if (= ii 1)
    (setq i 1)
    (setq i (- lenstr lenfstr -1))
  )
  (repeat (- lenstr lenfstr -1)
    (if        (= (substr strstr i lenfstr) fstr)
      (setq astr i)
    )
    (setq i (+ i ii))
  )
  astr
)

(defun dyq-dist-between-text (obj1 obj2 / objlist1 objlist2 ang p1 p2 ps pe p3)
  ;dyq-dist-between-text等高平行文字之间的距离
  (setq objlist1 (entget obj1))
  (setq objlist2 (entget obj2))
  (setq ang (cdr (assoc '50 objlist1)))
  (setq p1 (cdr (assoc '10 objlist1)))
  (setq p2 (polar p1 (- ang (* 0.5 pi)) 100))
  (setq ps (cdr (assoc '10 objlist2)))
  (setq pe (polar ps ang 100))
  (setq p3 (inters p1 p2 ps pe nil))
  (distance p1 p3)
)

(defun dyq-get-oldstatus (/ oldstatus) ;存储系统原状态
  (setq oldstatus (list "oldstatus"))
  (setq oldstatus (cons "CLAYER" oldstatus))
  (setq oldstatus (cons (getvar "CLAYER") oldstatus))
  (setq oldstatus (cons "OSMODE" oldstatus))
  (setq oldstatus (cons (getvar "OSMODE") oldstatus))
  (setq oldstatus (cons "ORTHOMODE" oldstatus))
  (setq oldstatus (cons (getvar "ORTHOMODE") oldstatus))
  (setq oldstatus (cons "TEXTSTYLE" oldstatus))
  (setq oldstatus (cons (getvar "TEXTSTYLE") oldstatus))
  (setq oldstatus (cons "TEXTSIZE" oldstatus))
  (setq oldstatus (cons (getvar "TEXTSIZE") oldstatus))
  (setq oldstatus (cons "PICKSTYLE" oldstatus))
  (setq oldstatus (cons (getvar "PICKSTYLE") oldstatus))
  (setq oldstatus (cons "pickbox" oldstatus))
  (setq oldstatus (cons (getvar "pickbox") oldstatus))
  ;当前标注样式要修改
  (setq oldstatus (reverse oldstatus))
)

(defun dyq-put-oldstatus (oldstatus) ;还原系统原系统变量
  (setq num (length oldstatus))
  (setq i 1)
  (repeat (/ (- num 1) 2)
    (setvar (nth i oldstatus) (nth (+ i 1) oldstatus))
    (setq i (+ i 2))
  )
)

(princ "\nad  将PKPM中结果文字取大")
(defun c:ad (/ xz num i        left mid right strtype numtext str j1 j2 key1 key2 left1 mid1 right1 numstr typeofstr as
             oldstatus xzx)
  (prompt "将PKPM结果文字取大\n")
  (setq &olderr& *error*)
  (setq *error* *$dyq-error$*)
  (vl-load-com)
  (setq oldstatus (dyq-get-oldstatus))
  (setvar "OSMODE" 0)
  (setq distmohu 50.0) ;字符间模糊距离
  (setq layerAdd "Defpoints") ;辅助图层
  (command "layer" "C" 1 layerAdd "")
  (command "layer" "on" "*" "")
  (command "layer" "u" "*" "")
  (setq p1 (getpoint "\n第一个角点:"))
  (setq p2 (getcorner p1 "\n对角点:"))
  (if (ssget "c" p1 p2 '((0 . "TEXT") (1 . "G*-*"))) ;以下处理箍筋G1.5-1.2情况
    (progn
      (setq xz (ssget "c" p1 p2 '((0 . "TEXT") (1 . "G*-*"))))
      (setq num (sslength xz)) ;选择集的数量
      (setq i 0)
      (setq left 0)
      (setq mid 0)
      (setq right 0)
      (repeat num
        (setq obj (entget (ssname xz i))) ;获得对象的列表
        (setq numtext i)
        (setq str (cdr (assoc '1 obj))) ;获得文字内容
        (setq key1 (dyq-findstr str "-" 1)) ;获得-的位置
        (setq left1 (atof (substr str 2 (- key1 1))))
        (setq right1 (atof (substr str (+ key1 1))))
        (if (> left1 left)
          (setq left left1)
        )
        (if (> right1 right)
          (setq right right1)
        )
        (setq i (+ i 1))
      )
      (setq str (strcat "G" (rtos left 2 1) "-" (rtos right 2 1)))
      (command "copy" (ssname xz 0) "" '(0 0 0) '(0 0 0))
      (vla-put-TextString (vlax-ename->vla-object (entlast)) str)
      (command "change" (entlast) "" "p" "la" layerAdd "")
    )
  )

  (if (ssget "c" p1 p2 '((0 . "TEXT") (1 . "VT*-*"))) ;以下处理扭筋VT1-0.0情况
    (progn
      (setq xz (ssget "c" p1 p2 '((0 . "TEXT") (1 . "VT*-*"))))
      (setq num (sslength xz)) ;选择集的数量
      (setq i 0)
      (setq left 0)
      (setq mid 0)
      (setq right 0)
      (repeat num
        (setq obj (entget (ssname xz i))) ;获得对象的列表
        (setq numtext i)
        (setq str (cdr (assoc '1 obj))) ;获得文字内容
        (setq key1 (dyq-findstr str "-" 1)) ;获得-的位置
        (setq left1 (atof (substr str 3 (- key1 1))))
        (setq right1 (atof (substr str (+ key1 1))))
        (if (> left1 left)
          (setq left left1)
        )
        (if (> right1 right)
          (setq right right1)
        )
        (setq i (+ i 1))
      )
      (setq str (strcat "VT" (rtos left 2 1) "-" (rtos right 2 1)))
      (command "copy" (ssname xz 0) "" '(0 0 0) '(0 0 0))
      (vla-put-TextString (vlax-ename->vla-object (entlast)) str)
      (command "change" (entlast) "" "p" "la" layerAdd "")
    )
  )

  (if (setq xz (ssget "c"
                      p1
                      p2
                      '((0 . "*TEXT") (1 . "*AS*,*as*,*As*,*aS*"))
               )
      ) ;以下处理墙主筋As1259情况
    (progn
      (setq num (sslength xz))
      (setq i 0)
      (setq key 0)
      (setq asmax -9999.0)
      (repeat num
        (setq as (atof
                   (substr (vl-string-trim " " (cdr (assoc '1 (entget (ssname xz i)))))
                           3
                   )
                 )
        )
        (if (>= as asmax)
          (progn
            (setq asmax as)
            (setq key i)
          )
        )
        (setq i (+ i 1))
      )
      (command "copy" (ssname xz key) "" '(0 0 0) '(0 0 0))
      (command "change" (entlast) "" "p" "la" layerAdd "")
    )
  )

  (if (setq xz (ssget "c"
                      p1
                      p2
                      '((0 . "*TEXT") (1 . "*LC*,*lc*,*Lc*,*lC*"))
               )
      ) ;以下处理LC400情况
    (progn
      (setq num (sslength xz))
      (setq i 0)
      (setq key 0)
      (setq asmax -9999.0)
      (repeat num
        (setq as (atof
                   (substr (vl-string-trim " " (cdr (assoc '1 (entget (ssname xz i)))))
                           3
                   )
                 )
        )
        (if (>= as asmax)
          (progn
            (setq asmax as)
            (setq key i)
          )
        )
        (setq i (+ i 1))
      )
      (command "copy" (ssname xz key) "" '(0 0 0) '(0 0 0))
      (command "change" (entlast) "" "p" "la" layerAdd "")
    )
  )

  (if (setq xz (ssget "c"
                      p1
                      p2
                      '((0 . "*TEXT") (1 . "*LS*,*ls*,*Ls*,*lS*"))
               )
      ) ;以下处理LC400情况
    (progn
      (setq num (sslength xz))
      (setq i 0)
      (setq key 0)
      (setq asmax -9999.0)
      (repeat num
        (setq as (atof
                   (substr (vl-string-trim " " (cdr (assoc '1 (entget (ssname xz i)))))
                           3
                   )
                 )
        )
        (if (>= as asmax)
          (progn
            (setq asmax as)
            (setq key i)
          )
        )
        (setq i (+ i 1))
      )
      (command "copy" (ssname xz key) "" '(0 0 0) '(0 0 0))
      (command "change" (entlast) "" "p" "la" layerAdd "")
    )
  )

  (if (setq xz (ssget "c"
                      p1
                      p2
                      '((0 . "*TEXT") (1 . "H*"))
               )
      ) ;以下处理墙分布筋H2.3情况
    (progn
      (setq num (sslength xz))
      (setq i 0)
      (setq key 0)
      (setq asmax -9999.0)
      (repeat num
        (setq as (atof
                   (substr (vl-string-trim " " (cdr (assoc '1 (entget (ssname xz i)))))
                           2
                   )
                 )
        )
        (if (>= as asmax)
          (progn
            (setq asmax as)
            (setq key i)
          )
        )
        (setq i (+ i 1))
      )
      (command "copy" (ssname xz key) "" '(0 0 0) '(0 0 0))
      (command "change" (entlast) "" "p" "la" layerAdd "")
    )
  )

  (if (setq xz (ssget "c"
                      p1
                      p2
                      '((0 . "*TEXT") (1 . "Psv*%"))
               )
      ) ;以下处理暗柱体积配箍率Psv0.68%情况
    (progn
      (setq num (sslength xz))
      (setq i 0)
      (setq key 0)
      (setq asmax -9999.0)
      (repeat num
        (setq str (vl-string-trim " " (cdr (assoc '1 (entget (ssname xz i))))))
        (setq str (vl-string-trim "%" str))
        (setq as (atof (substr str 4)))
        (if (>= as asmax)
          (progn
            (setq asmax as)
            (setq key i)
          )
        )
        (setq i (+ i 1))
      )
      (setq str (strcat "Psv" (rtos asmax 2 2) "%"))
      (command "copy" (ssname xz 0) "" '(0 0 0) '(0 0 0))
      (vla-put-TextString (vlax-ename->vla-object (entlast)) str)
      (command "change" (entlast) "" "p" "la" layerAdd "")
    )
  )

  (if (setq xz (ssget "c"
                      p1
                      p2
                      '((0 . "*TEXT") (1 . "*-*-*"))
               )
      ) ;以下处理梁主筋3-8-9情况,将上下分开
    (progn

      (defun gangjin (xzx layerAdd / num i left        mid right obj str key1 ke2 left1 mid1 right1)
        (setq num (sslength xzx)) ;选择集的数量
        (setq i 0)
        (setq left 0)
        (setq mid 0)
        (setq right 0)
        (repeat        num
          (setq obj (entget (ssname xzx i))) ;获得对象的列表
          (setq str (cdr (assoc '1 obj))) ;获得文字内容
          (setq key1 (dyq-findstr str "-" -1)) ;获得-的位置
          (setq key2 (dyq-findstr str "-" 1)) ;获得-的位置
          (setq left1 (atof (substr str 1 (- key1 1))))
          (setq mid1 (atof (substr str (+ key1 1) (- key2 key1))))
          (setq right1 (atof (substr str (+ key2 1))))
          (if (> left1 left)
            (setq left left1)
          )
          (if (> mid1 mid)
            (setq mid mid1)
          )
          (if (> right1 right)
            (setq right right1)
          )
          (setq i (+ i 1))
        )
        (setq str (strcat (rtos left 2 0)
                          "-"
                          (rtos mid 2 0)
                          "-"
                          (rtos right 2 0)
                  )
        )
        (command "copy" (ssname xzx 0) "" '(0 0 0) '(0 0 0))
        (vla-put-TextString (vlax-ename->vla-object (entlast)) str)
        (command "change" (entlast) "" "p" "la" layerAdd "")
      )

      (setq distmohu 50.0)
      (setq xz1 (ssadd))
      (setq obj (ssname xz 0))
      (setq xz (ssdel obj xz))
      (setq xz1 (ssadd obj xz1))
      (setq xz2 (ssadd))
      (while (> (sslength xz) 0)
        (if (< (dyq-dist-between-text obj (ssname xz 0)) distmohu)
          (progn
            (setq objtemp (ssname xz 0))
            (setq xz (ssdel objtemp xz))
            (setq xz1 (ssadd objtemp xz1))
          )
          (progn
            (setq objtemp (ssname xz 0))
            (setq xz (ssdel objtemp xz))
            (setq xz2 (ssadd objtemp xz2))
          )
        )
      )
      (gangjin xz1 layerAdd)
      (gangjin xz2 layerAdd)
  ;(command "change" xz1 "" "p" "c" 1 "")
  ;(command "change" xz2 "" "p" "c" 2 "")
    )
  )
  (dyq-put-oldstatus oldstatus)
  (setq *error* &olderr&)
  (princ)
)

xyz

不错，支持一下，收藏试用！

dwg001

首先对楼主的劳动表示敬意。
建议程序支持整层框选，否则程序的实际应用价值就不大。
这方面有好多人做了类似的工作，如“无极”。。。