www.pudn.com > CADtool.rar > 块统计.lsp, change:2009-12-17,size:12762b


;;;-------------------------------------------------------------------------------- 
;;;从块选择集中选择指定块名的对象,并返回结果选择集 
(defun intCountSingleBlock (ssOriginal strTargetBlockName / 
                  strEntityName listEntityDXF strBlockName intSingleBlockCount k) 
 (setq intSingleBlockCount 0 
       k -1 ) 
 (repeat (sslength ssOriginal) ; 循环与所选择的对象数量相等的次数 
  (setq strEntityName (ssname ssOriginal (setq k (1+ k)))) ; strEntityName,取得第k个对象名 
  (setq listEntityDXF (entget strEntityName)) 
  (setq strBlockName (cdr (assoc 2 listEntityDXF))) 
  (if (= strBlockName strTargetBlockName) 
   (setq intSingleBlockCount (1+ intSingleBlockCount)) 
  ) 
 ) 
 intSingleBlockCount 
) 
;;;-------------------------------------------------------------------------------- 
;;;从块选择集中删除指定块名的对象,并返回结果选择集 
(defun ssDelEntitysFromBlockSelectionSet (ssOriginal strTargetBlockName 
                       / strEntityName listEntityDXF strBlockName ssResult k) 
 (setq ssResult (ssadd) 
       k -1 ) 
 (repeat (sslength ssOriginal) ; 循环与所选择的对象数量相等的次数 
  (setq strEntityName (ssname ssOriginal (setq k (1+ k)))) ; strEntityName,取得第k个对象名 
  (setq listEntityDXF (entget strEntityName)) 
  (setq strBlockName (cdr (assoc 2 listEntityDXF))) 
  (if (/= strBlockName strTargetBlockName) 
   (setq ssResult (ssadd strEntityName ssResult)) 
  ) 
 ) 
 ssResult 
) 
;;;-------------------------------------------------------------------------------- 
;;;插入块缩略图 
(defun PrintBlockMiniature (floatBasicPointX                  floatBasicPointY                  strBlockName 
                            /                                 floatMaxBlockWidth                floatMaxBlockHigh 
                            floatBlockOriginalWidth           floatBlockOriginalHigh            floatBlockWidthScale 
                            floatBlockHighScale               floatBlockBoundingBoxTargetMinPointX 
                            floatBlockBoundingBoxTargetMinPointY   floatBlockBoundingBoxTargetMaxPointX 
                            floatBlockBoundingBoxTargetMaxPointY   listTargetBlockCenterPoint 
                            listBlockBoundingBoxMinPoint      listBlockBoundingBoxMaxPoint      objectBlockEntity 
                            strEntityName                     listInsertPoint                   floatBlockScale 
                            listBlockEntityDXF                listBlockCenterPoint 
                           ) 
 ;; floatBasicPointX floatBasicPointY 缩略图所在表格单元左下角点坐标 
 ;;计算图块缩略图在图中允许放置范围的左下及右上角点坐标的X、Y数值 
 (setq floatMaxBlockWidth 21 
       floatMaxBlockHigh 8 
 ) 
 (setq floatBlockBoundingBoxTargetMinPointX (+ floatBasicPointX 2) 
       floatBlockBoundingBoxTargetMinPointY (+ floatBasicPointY 1) 
       floatBlockBoundingBoxTargetMaxPointX (+ floatBasicPointX floatMaxBlockWidth 2) 
       floatBlockBoundingBoxTargetMaxPointY (+ floatBasicPointY floatMaxBlockHigh 1) 
 ) 
 (setq listTargetBlockCenterPoint (list (/ (+ floatBlockBoundingBoxTargetMinPointX  floatBlockBoundingBoxTargetMaxPointX ) 2) 
                                        (/ (+ floatBlockBoundingBoxTargetMinPointY floatBlockBoundingBoxTargetMaxPointY )  2 ) 
                                        0 
                                  ) 
 ) 
 
 (setq listInsertPoint (list floatBlockBoundingBoxTargetMinPointX  floatBlockBoundingBoxTargetMinPointY  ) ) 
 (InsertBlock strBlockName listInsertPoint 0) 
 ;;以块缩略图允许放置范围的左下角点为块缩略图的基点插入图块 
 
 (setq strEntityName (entlast)) 
 (setq objectBlockEntity (vlax-ename->vla-object strEntityName)) 
 (if  (vl-catch-all-error-p (vl-catch-all-apply 'vla-GetBoundingBox  
                                                (list objectBlockEntity  'listBlockBoundingBoxMinPoint 'listBlockBoundingBoxMaxPoint )) 
         ) ;判断块是否存在边框,若块含无限长直线等时,则不存在边框 
    (AddText_AlignmentMiddle listBlockCenterPoint 3 0 "本块无缩略图" 0.8 "hztxt") 
     
    (progn 
 (setq listBlockBoundingBoxMinPoint (vlax-safearray->list listBlockBoundingBoxMinPoint) ) 
 (setq listBlockBoundingBoxMaxPoint (vlax-safearray->list listBlockBoundingBoxMaxPoint) ) 
   
 (if (> (car listBlockBoundingBoxMaxPoint)  (car listBlockBoundingBoxMinPoint) ) 
      (setq floatBlockWidthScale (/ floatMaxBlockWidth 
                                     (- (car listBlockBoundingBoxMaxPoint) (car listBlockBoundingBoxMinPoint) )  
                                     ) 
         ) 
       (setq  floatBlockWidthScale 0) 
     ) 
  
 (if (> (cadr listBlockBoundingBoxMaxPoint) (cadr listBlockBoundingBoxMinPoint)  ) 
    (setq   floatBlockHighScale  (/ floatMaxBlockHigh 
                                    (- (cadr listBlockBoundingBoxMaxPoint) (cadr listBlockBoundingBoxMinPoint) ) 
                                  ) 
      ) 
     (setq   floatBlockHighScale 0) 
    ) 
 ;计算块缩略图允许放置范围的边框长宽与块外框长宽的比值 
   
 (cond  
  ((= (+ floatBlockWidthScale floatBlockHighScale) 0)  (setq floatBlockScale 1)) ;块为单点时,缩放比例取为1 
  ((=  floatBlockWidthScale 0)  (setq floatBlockScale floatBlockHighScale) ) ;块为竖直短线时 
  ((=  floatBlockHighScale 0)  (setq floatBlockScale floatBlockWidthScale) ) ;块为水平短线时 
  ((> floatBlockWidthScale floatBlockHighScale )  (setq floatBlockScale floatBlockHighScale) ) ;数值较小者为块的控制缩放比例 
  (T  (setq floatBlockScale floatBlockWidthScale) )   
  )  
 
 (setq listBlockEntityDXF (entget strEntityName)) 
 (entmod (subst (cons 41 floatBlockScale) (assoc 41 listBlockEntityDXF) listBlockEntityDXF ) ) 
 (entupd strEntityName) 
 
 (setq listBlockEntityDXF (entget strEntityName)) 
 (entmod (subst (cons 42 floatBlockScale) (assoc 42 listBlockEntityDXF) listBlockEntityDXF ) ) 
 (entupd strEntityName) 
 
 (setq listBlockEntityDXF (entget strEntityName)) 
 (entmod (subst (cons 43 floatBlockScale) (assoc 43 listBlockEntityDXF) listBlockEntityDXF ) ) 
 (entupd strEntityName) 
 ;;缩放块 
 
 (vla-GetBoundingBox objectBlockEntity 'listBlockBoundingBoxMinPoint 'listBlockBoundingBoxMaxPoint) 
 (setq listBlockBoundingBoxMinPoint (vlax-safearray->list listBlockBoundingBoxMinPoint) ) 
 (setq listBlockBoundingBoxMaxPoint (vlax-safearray->list listBlockBoundingBoxMaxPoint) ) 
 (setq listBlockCenterPoint (list (* 0.5 (+ (car listBlockBoundingBoxMaxPoint) (car listBlockBoundingBoxMinPoint) ) ) 
                                  (* 0.5 (+ (cadr listBlockBoundingBoxMaxPoint) (cadr listBlockBoundingBoxMinPoint) ) ) 
                                  0 
                            ) 
 ) 
 (vla-move objectBlockEntity (vlax-3d-point listBlockCenterPoint) (vlax-3d-point listTargetBlockCenterPoint)) 
 ) 
 ) 
 
) 
;;;-------------------------------------------------------------------------------- 
;;;打印统计结果表 
(defun PrintCountResultList (listResult       /                i                ListLength       strBlockName 
                             intNumberOfSSSingleBlockName      strNumberOfSSSingleBlockName      pt               pt1 
                             pt2              pt3              x                y                x1               y1 
                             x2               x3               floatTextHigh 
                            ) 
 (setq pt (getpoint "\n点取要标注块统计结果信息的位置:")) 
 (setq x (car pt) 
       y (cadr pt) 
       i 0 
       floatTextHigh 4 
 ) 
 
 (setq ListLength (length listResult)) 
 
 (setq y1 (- y (* (1+ ListLength) 10))) ;行高取10 
 (while (<= i 3) 
  (setq x1 (+ x (* i 25))) ;列宽取25 
 
  (setq pt1 (list x1 y 0) 
        pt2 (list x1 y1 0) 
  ) 
 
  (AddLine pt1 pt2) 
  (setq i (1+ i)) 
 ) 
;;;画竖向表格线 
 
 (setq i 0) 
 (setq x1 (+ x (* 3 25))) 
 (while (<= i (1+ ListLength)) 
  (setq y1 (- y (* i 10))) 
 
  (setq pt1 (list x y1 0) 
        pt2 (list x1 y1 0) 
  ) 
 
  (AddLine pt1 pt2) 
  (setq i (1+ i)) 
 ) 
;;;画横向表格线 
 
;;;------------------------------------------------------------------------ 
 (setq x1 (+ x (* 0.5 25)) 
       x2 (+ x (* 1.5 25)) 
       x3 (+ x (* 2.5 25)) 
       y1 (- y 7) 
 ) 
 
 (setq pt1 (list x1 y1 0) 
       pt2 (list x2 y1 0) 
       pt3 (list x3 y1 0) 
 ) 
 
 (AddText_AlignmentMiddle pt1 floatTextHigh 0 "块缩略图" 0.8 "hztxt") 
 (AddText_AlignmentMiddle pt2 floatTextHigh 0 "块名称" 0.8 "hztxt") 
 (AddText_AlignmentMiddle pt3 floatTextHigh 0 "块数量" 0.8 "hztxt") 
 ;;输出表头 
;;;------------------------------------------------------------------------ 
 (setq i 0 
       floatTextHigh 3 ) 
 (while (< i ListLength) 
  (setq y1 (+ y (* -10 (+ i 2)))) 
 
  (setq ;pt1 (list x1 y1 0) 
        pt2 (list x2 (+ y1 3) 0) 
        pt3 (list x3 (+ y1 3) 0) 
  ) 
 
  (setq strBlockName (car (nth i listResult)) 
        intNumberOfSSSingleBlockName (cadr (nth i listResult)) 
  ) 
  (setq strNumberOfSSSingleBlockName (itoa intNumberOfSSSingleBlockName)) 
 
  (AddText_AlignmentMiddle pt2 floatTextHigh 0 strBlockName 0.8 "hztxt") 
  (AddText_AlignmentMiddle pt3 floatTextHigh 0 strNumberOfSSSingleBlockName 0.8 "hztxt") 
   
  (if (vl-catch-all-error-p (vl-catch-all-apply 'PrintBlockMiniature (list x y1 strBlockName))) 
     (AddText_AlignmentLeft (list (+ x 1) (+ y1 2)) 3 0 "生成块缩略图时出错" 0.8 "hztxt") 
   ) 
 
  (setq i (1+ i)) 
 ) 
;;;打印表内容 
) 
;;;-------------------------------------------------------------------------------- 
(defun GetBlocksSelectionRange (/ strDCLFileName listInputDefinements listKeysAndValues listKeysAndActions listKeysToGetValue 
                     listDCLReturn intButtonClick strSelectRange) 
 
 (setq strSelectRange  "UserSelection" ) 
 (setq strDCLFileName "BlocksSelectionRange") 
 (setq listInputDefinements '(("dialog" "指定统计范围" "") 
                               ("spacer") 
                                ("radio_column" "进行块统计的范围:") 
                                 ("btRadio" "手工选择" "brUserSelection") 
                                 ("btRadio" "整个图形" "brDrawingFile") 
                                ("end") 
                                ("text" "注:不统计含无限长直线的块!") 
                              ("spacer") 
                              ("btOK") 
                              ("end") 
                             ) 
 ) 
 (setq listKeysAndValues '(("brUserSelection" "1"))) 
 (setq listKeysAndActions '(("brUserSelection" "(setq strSelectRange \"UserSelection\")") 
                            ("brDrawingFile" "(setq strSelectRange \"DrawingFile\")")) ) 
 (setq listKeysToGetValue nil) 
 
 (setq listDCLReturn (listGenerateDCL strDCLFileName listInputDefinements listKeysAndValues listKeysAndActions listKeysToGetValue) ) 
 (setq intButtonClick (car listDCLReturn )  ) 
 strSelectRange 
) 
;;;-------------------------------------------------------------------------------- 
;;;块数量统计 
(defun c:CountBlocks (/                      ssObjects              strEntityName          listEntityDXF          strBlockName 
                      listResult  intSingleBlockCount  listMinPoint listInsertPoint        floatBlockRotateAngle 
                                             ;;listResult 用于记录统计结果,形式为((  块名  块数量  同名块中一个实体的对象名 )...) 
                     ) 
; (initget "D S _DrawingFile UserSelection") 
; (setq strSelectRange (getkword "\n统计块的范围[全图(D)/选择(S)]<S>:")) 
 (setq strSelectRange (GetBlocksSelectionRange)) 
 
 (if (= strSelectRange "DrawingFile") 
  (setq ssObjects  (ssget "X" '((0 . "insert")(100 . "AcDbBlockReference")))) ; 创建选择集 ssObjects 
 
  (progn 
   (princ "\n请选择需要统计的块:\n") 
   (setq ssObjects (ssget '((0 . "INSERT")(100 . "AcDbBlockReference")))) ; 创建选择集 ssObjects 
  ) 
 ) 
 
 (if ssObjects 
  (progn 
   (setq listResult nil) 
   (while (> (sslength ssObjects) 0) 
    (setq strEntityName (ssname ssObjects 0)) ; strEntityName,取得第1个对象名 
    (setq listEntityDXF (entget strEntityName)) 
    (setq strBlockName (cdr (assoc 2 listEntityDXF))) 
    (setq intSingleBlockCount (intCountSingleBlock ssObjects strBlockName ) ) 
    (setq ssObjects (ssDelEntitysFromBlockSelectionSet ssObjects strBlockName)) 
 
    (setq listResult (append listResult 
                             (list (list strBlockName intSingleBlockCount)) 
                     ) 
    ) 
   ) 
 
   (setvar "dimzin" 8) 
   (setvar "osmode" 0) 
  (if  (tblsearch "style" "hztxt") 
    ;;判断是否存在"hztxt"字体,有则设为当前,无则创建。 
       (setvar "textstyle" "hztxt") 
       (command "_style" "hztxt" "hztxt_e.shx,hztxt.shx" 0 0.8 0 "N" "N" "N") 
   ) 
 
   (PrintCountResultList listResult) 
   (setvar "osmode" 16383) 
  ) 
 ) 
 
 (princ) 
) 
;;;--------------------------------------------------------------------------------