www.pudn.com > CADtool.rar > smarttools.lsp, change:2009-12-18,size:18882b


(vl-load-com) 
;;;------------------------------------------------------------------------ 
;;;数值求和 
(defun c:PS_szqh (/ Sum ob obn obname obstr k SingleNumber strText RealN NonRealN strResult) 
 (princ "\n选择需要求和的数字:") 
 (setq ob (ssget '((0 . "text")))) ; 创建选择集 ob 
 (if ob 
  (progn 
   (setq Sum 0 
         k 0 
         RealN 0 
         NonRealN 0 
   ) 
   (repeat (sslength ob) 
 
    (setq obn (sslength ob)) 
    (setq obname (ssname ob k)) ; obname,取得第k个对象名 
    (setq obstr (entget obname)) 
    (setq strText (cdr (assoc 1 obstr))) ; 取得第k个对象的文字内容 
    (setq SingleNumber (read strText)) 
    (if (numberp SingleNumber) 
     (progn 
      (setq Sum (+ SingleNumber Sum)) 
      (setq RealN (1+ RealN)) 
     ) 
 
     (setq NonRealN (1+ NonRealN)) 
    ) 
 
    (setq k (1+ k)) 
   ) 
   (if (= RealN 0) 
    (princ "\n没有选择任何数字!") 
 
    (progn 
     (setvar "dimzin" 8) 
     (setq strResult (strcat "\n选择了" (rtos RealN 2 0) "个数据")) 
     (if (/= NonRealN 0) 
      (setq strResult (strcat strResult "," (rtos NonRealN 2 0) "个非数据文本")) 
     ) 
 
     (setq strResult (strcat strResult ":数值总和为" (rtos Sum 2 4))) 
     (princ strResult) 
    ) 
   ) 
 
  ) 
 ) 
 
 (princ) 
) 
;;;------------------------------------------------------------------------ 
;;;计算统计线长 
(defun c:PS_tjxc (/ ob obn obkname k sumlen klen) 
 (setvar "dimzin" 8) 
 (setq sumlen 0 
       k 0 
 ) 
 (princ "\n选择需要计算总长度的线:") 
 (repeat (sslength 
          (setq ob (ssget '((0 . "CIRCLE,ELLIPSE,*LINE,ARC")))) 
         ) 
  (setq obkname (ssname ob k)) ; obkname,取得第k个象名 
 
  (setq obkname (vlax-ename->vla-object obkname)) 
  (setq klen (vlax-curve-getDistAtParam obkname  (vlax-curve-getEndParam obkname)  )  ) 
 
  (setq sumlen (+ sumlen klen) 
        k      (1+ k) 
  ) 
 ) 
 (if (> sumlen 0) 
  (princ (strcat "\n所选择的线总长为:" (rtos sumlen 2 3))) 
 ) 
 (princ) 
 
) 
;;;------------------------------------------------------------- 
;;;绘制流水方向箭头 
(defun c:PS_arraw (/ floatRotateAngle listBasicPoint listAPointOnDirection floatScale) 
;;;------------------------------------------------------------------------ 
 (defun MakePSFX_Block ( / entPolyline) 
  (if (not (tblsearch "block" "PS_FX_Arrow")) 
    (progn 
      (vl-cmdf "pline" '(0 0) "w" 0.3 0.3 '(6 0) "w" 0.8 0 '(10 0) "") 
      (setq entPolyline (entlast)) 
      (vl-cmdf "-block" "PS_FX_Arrow" '(5 0) entPolyline "") 
      ) 
    ) 
  ) 
;;;------------------------------------------------------------- 
 (setvar "osmode" 0) 
 (princ "本功能所绘箭头大小与\"绘图环境\"设置中的\"长度测量比例\"及\"出图比例\"有关,需要时可修改这两个参数!\n") 
 (MakePSFX_Block) 
 (setq floatScale (* 0.8 #cdbl#  (/ #ctbl# 1000.0))) 
  
 (while (setq listBasicPoint (getpoint "\n选择箭头插入位置:")) 
  (if (setq listAPointOnDirection (getpoint listBasicPoint "\n选择箭头方向上一点:")) 
   (progn 
    (setq floatRotateAngle (angle listBasicPoint listAPointOnDirection)) 
    (entmake (list '(0 . "INSERT") 
                   '(100 . "AcDbEntity") 
                   '(100 . "AcDbBlockReference") 
                    (cons 2 "PS_FX_Arrow") 
                    (cons 10 listBasicPoint) 
                    (cons 41 floatScale) 
                    (cons 42 floatScale) 
                    (cons 43 floatScale) 
                    (cons 50 floatRotateAngle) 
                    ) 
              ) 
    ) 
   ) 
  ) 
 (setvar "osmode" 431) 
 (princ) 
) 
;;;------------------------------------------------------------- 
;;;绘制指路方向箭头 
(defun c:PS_road_arraw (/ StartPoint EndPoint ang dst kw i ;控制循环变量 
                         tmp TempPLineName ;临时变量 
                         tmpdist tmpAng tmppt ptList tmppt2 ptList2) 
;;;------------------------------------------------------------- 
;;;若已绘临时多义线,则删除 
 (defun ClearTempLine () 
  (if TempPLineName 
   (progn 
    (entdel TempPLineName) 
    (setq TempPLineName nil) 
   ) 
  ) 
 ) 
;;;------------------------------------------------------------- 
;;;出错时清除临时内容 
 (defun *error* (msg) 
  (ClearTempLine) 
  (princ) 
 ) 
;;;------------------------------------------------------------- 
 (setq TempPLineName nil) ;变量初始化 
 (setvar "osmode" 0) 
 (while (setq StartPoint (getpoint "\n选择箭头起点:")) 
  (setq kw t) 
  (princ "\n选择箭头终点:") 
  (while kw 
   (setq tmp (grread t 4 1)) 
   (cond 
    ((or (= (car tmp) 5) ;移动了光标,动态绘箭头 
         (= (car tmp) 3) 
     ) ;按下了鼠标左键,绘箭头 
     (setq EndPoint (cadr tmp)) 
 
     (setq ang (angle StartPoint EndPoint) 
           dst (distance StartPoint EndPoint) 
     ) 
 
     (setq tmpdist (* 0.25 dst) 
           tmpAng  (+ (/ pi 2) ang) 
     ) 
 
     (setq tmppt (polar StartPoint tmpAng tmpdist)) 
     (setq ptList (list tmppt)) 
 
     (setq tmppt2 (polar StartPoint (+ tmpAng pi) tmpdist)) 
     (setq ptList2 (list tmppt2)) 
 
     (setq tmpdist (* 0.35 dst) 
           tmpAng  ang 
     ) 
     (setq tmppt (polar tmppt tmpAng tmpdist)) 
     (setq ptList (append ptList (list tmppt))) 
 
     (setq tmppt2 (polar tmppt2 tmpAng tmpdist)) 
     (setq ptList2 (append ptList2 (list tmppt2))) 
 
     (setq tmpdist (* 0.25 dst) 
           tmpAng  (+ (/ pi 2) ang) 
     ) 
     (setq tmppt (polar tmppt tmpAng tmpdist)) 
     (setq ptList (append ptList (list tmppt))) 
 
     (setq tmppt2 (polar tmppt2 (+ tmpAng pi) tmpdist)) 
     (setq ptList2 (append ptList2 (list tmppt2))) 
 
     (setq ptList2 (reverse ptList2)) 
 
     (setq ptList (append ptList (list EndPoint) ptList2)) 
     ;;以上计算并生成箭头多段线的顶点坐标表 
 
     (if TempPLineName 
      (ClearTempLine) 
     ) 
 
     (command "pline") 
     (setq i 0) 
     (repeat (length ptList) 
      (command (nth i ptList)) 
      (setq i (1+ i)) 
     ) 
     (command (nth 0 ptList) "") 
 
     (setq TempPLineName (entlast)) 
 
     (if (= (car tmp) 3) ;按下了鼠标左键,绘箭头 
      (setq TempPLineName nil 
            kw nil 
      ) 
     ) 
    ) 
 
    (T ;其它情况,退出程序 
     (ClearTempLine) 
     (setq kw nil) 
    ) 
   ) 
  ) 
 ) 
 
 (setvar "osmode" 431) 
 (princ) 
) 
;;;------------------------------------------------------------- 
;;;文本自身计算 
(defun c:PS_zsjs (/ OptionType OptionSet NumberA NumberB ob obn obname obstr strText GoOn JingDu k NonNumberN NumberN) 
 (setvar "dimzin" 0) ; 使输出结果不消除后续0 
 (setq GoOn "Continue") ;GoOn用于控制是否继续运行 
 (setq OptionSet "未设定") ;OptionSet用于判断是否已经设定文本自身计算类型 
 
;;;------------------------------------------------------------------------ 
 (while (= GoOn "Continue") 
;;;输出计算结果 
;;;以下选择需要输入计算结果的文本 
  (setq ob nil) 
 
  (princ "\n选择需要进行自身计算的数值文本:") 
  (setq ob (ssget '((0 . "text")))) ; 创建选择集 ob 
  (if (not ob) 
   (setq GoOn "Stop") 
 
   (progn 
 
    (if (= OptionSet "未设定") 
     (progn 
      (initget "A S D F") 
      (setq OptionType (if (setq OptionType 
                                 (getkword 
                                  "\n所选择数字[加上(A)/减去(S)/乘上(D)/除以(F)]另一个数<A>:" 
                                 ) 
                           ) 
                        OptionType 
                        "A" 
                       ) 
      ) 
 
      (if (= OptionType "F") 
       (initget 3) 
      ) 
      (setq NumberB (if (setq NumberB (getreal "\n输入使文本进行自身计算的数值<0>:")) 
                     NumberB 
                     0 
                    ) 
      ) 
      (initget 4) 
      (setq JingDu (if (setq JingDu (getint "\n计算结果小数位数<3>:")) 
                    JingDu 
                    3 
                   ) 
      ) 
      (setq OptionSet "已设定") 
     ) 
 
    ) 
 
 
    (setq k 0 
          NonNumberN 0 
          NumberN 0 
    ) 
    (setq obn (sslength ob)) 
 
    (repeat obn 
     (setq obname (ssname ob k)) ; obname,取得第k个对象名 
     (setq obstr (entget obname)) 
 
     (setq strText (cdr (assoc 1 obstr))) ; 取得第k个对象的文字内容 
     (setq NumberA (read strText)) 
 
     (if (not (numberp NumberA)) 
      (setq NonNumberN (1+ NonNumberN)) 
      (progn 
       (setq NumberN (1+ NumberN)) 
 
       (cond 
        ((= OptionType "A") (setq NumberA (+ NumberA NumberB))) 
        ((= OptionType "S") (setq NumberA (- NumberA NumberB))) 
        ((= OptionType "D") (setq NumberA (* NumberA NumberB))) 
        (T (setq NumberA (/ NumberA NumberB))) 
       ) 
 
       (entmod (subst (cons 1 (rtos NumberA 2 JingDu)) 
                      (assoc 1 obstr) 
                      obstr 
               ) 
       ) 
       (entupd obname) 
      ) 
     ) 
 
     (setq k (1+ k)) 
    ) 
 
        
    (if (> NumberN 0) 
     (princ 
      (strcat "\n成功处理" (rtos NumberN 2 0) "个数值文本!") 
     ) 
    ) 
    (if (> NonNumberN 0) 
     (princ (strcat "\n没有处理的非数值文本为:" 
                    (rtos NonNumberN 2 0) 
                    "个!" 
            ) 
     ) 
    ) 
   ) 
  ) 
 ) 
 
 (princ) 
) 
;;;------------------------------------------------------------- 
;;;等差计算(根据起始数值及差值连续计算、输出文本,用于管底高程无管道标注文本时,计算管底高程) 
(defun c:PS_dcjs (/ OriginalNumber Originalstr ResultNumber ob obn obname obstr strText DeltaNumber GoOn JingDu) 
 (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 OriginalNumber (read strText)) 
    (if (not (numberp OriginalNumber)) 
     (progn 
      (princ "\n所择的文本不是数字,请重新选择!\n") 
      (setq ob  nil 
            obn 2 
      ) 
     ) 
    ) 
   ) 
   (T nil) 
  ) 
 ) 
 ;;限制只允许选择一个有效数值文本 
 ;;确定起始数值 
 (if (= GoOn "Continue") 
  (progn 
   (setq DeltaNumber (if (setq DeltaNumber (getreal "\n输入(后续数值-前一数值)值<0>:")) 
                      DeltaNumber 
                      0 
                     ) 
   ) 
   (initget 4) 
   (setq JingDu (if (setq JingDu (getint "\n计算结果小数位数<3>:")) 
                 JingDu 
                 3 
                ) 
   ) 
;;;------------------------------------------------------------------------ 
   (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 ResultNumber (+ OriginalNumber DeltaNumber)) 
       (setq OriginalNumber ResultNumber) 
 
       (entmod (subst (cons 1 (rtos ResultNumber 2 JingDu)) 
                      (assoc 1 obstr) 
                      obstr 
               ) 
       ) 
       (entupd obname) 
      ) 
 
      (T (princ "\n所择了多个单行文本,请重新选择!")) 
      ;;限制只允许选择一个文本 
     ) ;计算确定后续数值 
    ) 
   ) 
  ) 
 ) 
 (princ) 
) 
;;;------------------------------------------------------------- 
;;直接在图上写出封闭区域的面积 
(defun c:PS_cxmj (/ elast pt qarea sta) ;!!!点选面积 
 (setq pt (getpoint "\n点取区域内一点:")) 
 (setq sta (bpoly pt)) ;cad内部函数>>.. 
 (if (= sta nil) 
  (exit) 
 ) 
 (setq elast (entlast)) 
 (command "_.area" "e" elast) 
 (setq qarea (rtos (getvar "area") 2 2)) 
 (command "_.text" pt 3 "" qarea) 
 (princ (strcat "\n该区域面积为:" qarea)) 
) 
;;;------------------------------------------------------------- 
;;;计算总面积 
(defun c:PS_tjzmj (/ ob obn obkname k sumArea kArea) 
 (setvar "dimzin" 8) 
 (setq sumArea 0 
       k 0 
 ) 
 (princ "\n选择需要计算总面积的闭合图形:") 
 (repeat (sslength 
          (setq ob (ssget '((0 . "*POLYLINE,CIRCLE,ELLIPSE")))) 
         ) 
  (setq obkname (ssname ob k)) ; obkname,取得第k个象名 
  (command "_.area" "e" obkname) 
  (setq kArea (getvar "area")) 
  (if (numberp kArea) 
   (setq sumArea (+ sumArea kArea)) 
  ) 
  (setq k (1+ k)) 
 ) 
 (if (> sumArea 0) 
  (princ (strcat "\n所选择的图形总面积为:" (rtos sumArea 2 6)) 
  ) 
 ) 
 (princ) 
) 
;;;------------------------------------------------------------- 
(defun C:ClearXData( / ss k obname) 
 (princ "请选择需要清除扩展数据的对象:") 
 (setq ss (ssget )) 
 (setq k -1) 
 (if ss 
  (progn 
   (repeat (sslength ss) ; 循环与所选择的对象数量相等的次数 
     (setq obname (ssname ss (setq k (1+ k)))) ; obname,取得第k个对象名 
     (SetXdata obname nil) 
    ) 
     ;;;(SetXdata (car(entsel "请选择一个需要清除扩展数据的对象:")) nil) 
    (princ "\n成功清除了指定对象的扩展数据!") 
   ) 
  ) 
 (princ) 
) 
;;;------------------------------------------------------------- 
;沿指定方向多重复制对象,可以指定对象间距或数量。 
(defun CopyMuch ( / ob OM pt1 pt2 pt3 CTYPE  TotalDist sDist NewDist ANG 
                obNumber i ) 
  (setq OM (getvar "OSMODE")) 
  (setvar "OSMODE" 431) 
  (setq pt1 (getpoint "\n指定复制路径:\n拾取第一点:")) 
  (setq pt2 (getpoint "\n拾取第二点:" pt1))(terpri) 
   
  (setq TotalDist (distance pt1 pt2)) 
  (setq ANG (angle pt1 pt2)) 
   
  (initget 1 "M E N") 
  (setq CTYPE  (getkword "\n复制方式[最大间距(M)/精确间距(E)/数量(N)]:")) 
  (cond 
   ((= CTYPE "M") 
    (setq sDist (getdist "\n最大对象间距:")) 
	 
	(setq obNumber (fix (/ TotalDist sDist ) ) ) 
	(if (< obNumber (/ TotalDist sDist ) ) 
    	(setq obNumber (1+ obNumber ) ) ) 
		 
	(setq sDist (/ TotalDist obNumber ) ) 
	) 
	 
   ((= CTYPE "E")  (setq sDist (getdist "\n精确对象间距:"))) 
    
   ((= CTYPE "N")   
     (setq obNumber (getreal "\n需复制对象数量:") ) 
	 (setq sDist (/ TotalDist obNumber ) ) 
	) 
   ) 
    
  (setvar "OSMODE" 0) 
  (setq ob (ssget)) 
  (setq i 1) 
  (BeginUndoGroup) 
  (while (<= (setq NewDist (* i sDist ) ) TotalDist ) 
    (setq pt3 (polar pt1 ANG NewDist)) 
    (command "copy" ob "" pt1 pt3) 
	(setq i (1+ i) ) 
  ) 
  (EndUndoGroup) 
   
  (setvar "OSMODE" OM) 
  (princ) 
);;;-------------------------------------------------------------------------------- 
;;;标注圆弧半径 
(defun DimArcR (/                   ssObjects           strEntityName       listEntityDXF       listCentertPoint    listStartPoint 
                  listEndPoint        floatStartPointAngle                    floatEndPointAngle  floatRadius         listTextInsertPoint 
                  floatTextHigh       StrMid              floatMid            strText             floatTextRotateAngle   k 
                 ) 
 (princ "\n请选择需要标注半径的圆弧:") 
 (setq ssObjects (ssget '((0 . "arc")))) ; 创建选择集 ssObjects 
 
 (setq StrMid (strcat "\n输入出图时的字高<当前为3>:")) 
 (initget 6) 
 (setq floatTextHigh (if (setq floatTextHigh (getreal StrMid)) 
                      floatTextHigh 
                      3 
                     ) 
 ) 
 
 (setvar "dimzin" 8) 
 (setvar "osmode" 0) 
 (if (not (tblsearch "style" "hztxt") ) 
  ;;判断是否存在"hztxt"字体,有则设为当前,无则创建。 
 ; (setvar "textstyle" "hztxt") 
  (command "_style" "hztxt" "hztxt_e.shx,hztxt.shx" 0 0.8 0 "N" "N" "N") 
 ) 
 
 (BeginUndoGroup) 
 (setq k -1) ; k为循环控制变量,用于记录处理对象序号 
 
 (if ssObjects 
  (repeat (sslength ssObjects) ; 循环与所选择的对象数量相等的次数 
   (setq strEntityName (ssname ssObjects (setq k (1+ k)))) ; strEntityName,取得第k个对象名    
   (setq listEntityDXF (entget strEntityName)) 
 
   (setq listCentertPoint (cdr (assoc 10 listEntityDXF))) 
   (setq floatRadius (cdr (assoc 40 listEntityDXF))) 
   (setq floatStartPointAngle (cdr (assoc 50 listEntityDXF))) 
   (setq floatEndPointAngle (cdr (assoc 51 listEntityDXF))) 
 
    (if (> floatStartPointAngle floatEndPointAngle) 
     (setq floatMid (* 0.5 (+ floatEndPointAngle floatStartPointAngle (* 2 Pi)))) 
      
     (setq floatMid (* 0.5 (+ floatEndPointAngle floatStartPointAngle)))      
   ) 
 
   (setq listTextInsertPoint (polar listCentertPoint 
                                    floatMid 
                                    (- floatRadius (* 0.75 floatTextHigh)) 
                             ) 
   ) 
 
   (setq floatStartPointAngle (polar listCentertPoint floatStartPointAngle floatRadius)) 
   (setq listEndPoint (polar listCentertPoint floatEndPointAngle floatRadius)) 
    
  
   (setq floatTextRotateAngle  (angle floatStartPointAngle listEndPoint) ) 
   (setq floatTextRotateAngle (AngInHalfPi  floatTextRotateAngle)) 
 
   (setq strText (strcat "R" (rtos floatRadius 2 3))) 
 
  ; (AddText_AlignmentMiddle listTextInsertPoint floatTextHigh floatTextRotateAngle strText 0.8 "hztxt") 
    
    (entmake (list '(0 . "TEXT") 
                '(10 0 0 0) 
                (cons 11 listTextInsertPoint) 
                (cons 40 floatTextHigh) 
                (cons 1 strText) 
                (cons 50 floatTextRotateAngle) 
                (cons 41 0.8) 
                (cons 7 "hztxt") 
                '(72 . 1) 
                '(73 . 2) 
                '(100 . "AcDbText") 
          ) 
     ) 
  ) 
 ) 
  
 (EndUndoGroup) 
 (setvar "osmode" 16383) 
  
 (princ "\n圆弧半径标注完成!") 
 (princ) 
) 
;;;-------------------------------------------------------------------------------- 
;;;计算指定路径的总长度,调用命令为pll 
(defun PlineLength (/ listStartPoint listEndPoint listLines strLineEName floatLength) 
 (setvar "dimzin" 8) 
 (setq listLines nil 
       floatLength 0 
 ) 
 
 (setq listStartPoint (getpoint "\n指定测量起点:")) 
 (while (setq listEndPoint (getpoint listStartPoint "\n指定下一点(右键或回车退出):")) 
  (entmake (list '(0 . "LINE") 
                 (cons 10 listStartPoint) 
                 (cons 11 listEndPoint) 
           ) 
  ) 
  (setq listLines (append listLines (list (entlast)))) 
  (setq floatLength (+ floatLength (distance listStartPoint listEndPoint))) 
  (setq listStartPoint listEndPoint) 
 ) 
 
 (if (> floatLength 0) 
  (progn 
   (princ (strcat "\n所选择的线总长为:" (rtos floatLength 2 3)) 
   ) 
 
   (foreach strLineEName listLines 
    (entdel strLineEName) 
   ) 
  ) 
 ) 
 
 (princ) 
) 
;;;------------------------------------------------------------- 
;;;单点打断 
(defun BreakAtPoint( / strLine listBreakPoint)  
  (setvar "osmode" 16383 ) 
  (while (setq strLine (car(entsel "\n请选择一个需要进行单点打断的对象:"))) 
   (setq listBreakPoint (getpoint "\n请选择打断的位置:")) 
  
   (vl-cmdf "break" strLine "f" listBreakPoint listBreakPoint ) 
  ) 
 (princ) 
) 
;;;-------------------------------------------------------------