批量分图lisp

admin1

[code](vl-ACAD-defun
  (DEFUN C:PF (/ ODOSM I OJ_SS BLOCK_NAME DWG_LIST DWG_PATH PT1 PT2 DWGNO MIN_PT
               MAX_PT 图框类型 多种类型
              )
    (VL-LOAD-COM)
    (DEFUN OPENPATH (EXT / SHELL)
      (VL-LOAD-COM)
      (setq SHELL (vlax-create-object "shell.application"))
      (vlax-invoke SHELL 'OPEN EXT)
      (vlax-release-object SHELL)
    )
    (DEFUN GETBLKREC (BLK_NAME / ENTTYPE MAXX MAXY MINX MINY)
      (DEFUN ROTATE_POINT (PT ANG / DIS)
        (setq DIS (DISTANCE '(0 0) PT))
        (setq ANG (+ (ANGLE '(0 0) PT) ANG))
        (setq PT (POLAR '(0 0) ANG DIS))
      )
      (DEFUN AYGETALLENTINBLK (BLKENTNAME TX0 TY0 TXN TYN TAN / XBLKNAME XBLKDEF
                               ENTNAME1 ENTTYPE ENTNAMELIST X0 Y0 XN YN AN
                              )
        (setq OJ_TEMP (ENTGET BLKENTNAME))
        (setq AN (CDR (ASSOC 50 OJ_TEMP)))
        (setq XN (CDR (ASSOC 41 OJ_TEMP)))
        (setq YN (CDR (ASSOC 42 OJ_TEMP)))
        (setq BASE_POINT (CDR (ASSOC 10 OJ_TEMP)))
        (setq AN (* (+ AN TAN) (/ XN (ABS XN)) (/ YN (ABS YN))))
        (setq XN (* TXN XN))
        (setq YN (* TYN YN))
        (setq BASE_POINT (ROTATE_POINT BASE_POINT TAN))
        (setq X0 (CAR BASE_POINT))
        (setq Y0 (CADR BASE_POINT))
        (setq X0 (+ (* X0 TXN) TX0))
        (setq Y0 (+ (* Y0 TYN) TY0))
        (setq XBLKNAME (CDR (ASSOC 2 (ENTGET BLKENTNAME))))
        (setq ENTNAMELIST (CONS (LIST XBLKNAME X0 Y0 XN YN AN) ENTNAMELIST))
        (setq XBLKDEF (TBLOBJNAME "Block" XBLKNAME))
        (while (and (setq ENTNAME1 (ENTNEXT XBLKDEF)))
          (setq ENTTYPE (CDR (ASSOC 0 (ENTGET ENTNAME1))))
          (if (= ENTTYPE "INSERT")
            (PROGN
              (setq ENTNAMELIST (CONS
                                  (AYGETALLENTINBLK ENTNAME1 X0 Y0 XN YN AN)
                                  ENTNAMELIST
                                )
              )
            )
            (PROGN
              (if (= ENTTYPE "LINE")
                (PROGN (setq LINE1 (vlax-ename->vla-object ENTNAME1))
                       (setq PT1 (vlax-get LINE1 'STARTPOINT))
                       (setq PT2 (vlax-get LINE1 'ENDPOINT))
                       (setq PT1 (ROTATE_POINT PT1 AN))
                       (setq PT2 (ROTATE_POINT PT2 AN))
                       (setq X1 (CAR PT1))
                       (setq Y1 (CADR PT1))
                       (setq X1 (+ (* X1 XN) X0))
                       (setq Y1 (+ (* Y1 YN) Y0))
                       (setq X2 (CAR PT2))
                       (setq Y2 (CADR PT2))
                       (setq X2 (+ (* X2 XN) X0))
                       (setq Y2 (+ (* Y2 YN) Y0))
                       (if (NULL MAXX)
                         (PROGN (setq MAXX X1))
                       )
                       (if (NULL MAXY)
                         (PROGN (setq MAXY Y1))
                       )
                       (if (NULL MINX)
                         (PROGN (setq MINX X1))
                       )
                       (if (NULL MINY)
                         (PROGN (setq MINY Y1))
                       )
                       (setq MAXX (MAX MAXX X1 X2))
                       (setq MAXY (MAX MAXY Y1 Y2))
                       (setq MINX (MIN MINX X1 X2))
                       (setq MINY (MIN MINY Y1 Y2))
                )
              )
              (if (= ENTTYPE "LWPOLYLINE")
                (PROGN
                  (setq PL_DATE (ENTGET ENTNAME1))
                  (FOREACH DATE1 PL_DATE
                    (if (= (CAR DATE1) 10)
                      (PROGN (setq PT1 (LIST (CADR DATE1) (CADDR DATE1)))
                             (setq PT1 (ROTATE_POINT PT1 AN))
                             (setq X1 (CAR PT1))
                             (setq Y1 (CADR PT1))
                             (setq X1 (+ (* X1 XN) X0))
                             (setq Y1 (+ (* Y1 YN) Y0))
                             (if (NULL MAXX)
                               (PROGN (setq MAXX X1))
                             )
                             (if (NULL MAXY)
                               (PROGN (setq MAXY Y1))
                             )
                             (if (NULL MINX)
                               (PROGN (setq MINX X1))
                             )
                             (if (NULL MINY)
                               (PROGN (setq MINY Y1))
                             )
                             (setq MAXX (MAX MAXX X1))
                             (setq MAXY (MAX MAXY Y1))
                             (setq MINX (MIN MINX X1))
                             (setq MINY (MIN MINY Y1))
                      )
                    )
                  )
                )
              )
            )
          )
          (setq XBLKDEF ENTNAME1)
        )
        (REVERSE ENTNAMELIST)
      )
      (setq ENTTYPE (CDR (ASSOC 0 (ENTGET BLK_NAME))))
      (if (= ENTTYPE "INSERT")
        (PROGN (setq MAXX nil)
               (setq MAXY nil)
               (setq MINX nil)
               (setq MINY nil)
               (AYGETALLENTINBLK BLK_NAME 0 0 1 1 0)
        )
      )
      (LIST (LIST MAXX MAXY) (LIST MINX MINY))
    )
    (DEFUN VLEX-GETATTRIBUTES (ENT / BLKREF LST)
      (if
        (=
          (vla-get-ObjectName
            (setq BLKREF (vlax-ename->vla-object ENT))
          )
          "AcDbBlockReference"
        )
        (PROGN
          (if (vla-get-HasAttributes BLKREF)
            (PROGN
              (MAPCAR
                '(LAMBDA (X)
                   (SETQ LST (CONS
                               (CONS (vla-get-TagString X)
                                     (vla-get-TextString X)
                               )
                               LST
                             )
                   )
                 )
                (vlax-safearray->list
                  (vlax-variant-value (vla-GetAttributes BLKREF))
                )
              )
            )
          )
        )
      )
      (REVERSE LST)
    )
    (PRINC "选择图框：")
    (SETVAR "cmdecho" 0)
    (VL-CMDF "ucs" "w")
    (setq OJ_SS (SSGET
                  '((2 . "Elivate*,Elicc*,BoRui*,Fortune*,TK-A*,TK-JG-*,TK-MT-"))
                )
    )
    (setq ODOSM (GETVAR "osmode"))
    (setq ERROR_LIST (LIST))
    (setq I -1)
    (setq DWG_LIST (LIST))
    (setq 重复 "no")
    (setq 空白 "no")
    (if OJ_SS
      (PROGN
        (if
          (setq OJ_SY (SSGET
                        "X"
                        '((8 . "Dimension") (100 . "AcDbBlockReference"))
                      )
          )
          (PROGN (VL-CMDF "_DRAWORDER" OJ_SY "" "F"))
        )
        (setq FILE_PATH (vlax-get
                          (vlax-get (vlax-get-acad-object) 'ACTIVEDOCUMENT)
                          'FULLNAME
                        )
        )
        (setq ERROR_LIST (LIST))
        (REPEAT (SSLENGTH OJ_SS)
          (setq BLOCK_NAME (SSNAME OJ_SS (setq I (1+ I))))
          (setq BLOCK_ENAME (vla-get-EffectiveName
                              (vlax-ename->vla-object BLOCK_NAME)
                            )
          )
          (if (NULL 图框类型)
            (PROGN (setq 图框类型 BLOCK_ENAME))
            (PROGN
              (if (/= 图框类型 BLOCK_ENAME)
                (PROGN (setq 多种类型 T))
              )
            )
          )
          (setq RECPT (GETBLKREC BLOCK_NAME))
          (setq MAX_PT (CAR RECPT))
          (setq MIN_PT (CADR RECPT))
          (setq DWG_PATH (STRCAT (GETVAR "DWGPREFIX") "DWG"))
          (VL-MKDIR DWG_PATH)
          (setq ATTLIST (VLEX-GETATTRIBUTES BLOCK_NAME))
          (COND
            ((ASSOC "图纸编号" ATTLIST)
             (setq DWGNO (CDR (ASSOC "图纸编号" ATTLIST)))
            )
            ((ASSOC "DRAWING-NO." ATTLIST)
             (setq DWGNO (CDR (ASSOC "DRAWING-NO." ATTLIST)))
            )
            ((ASSOC "图纸编号DRAWINGNO." ATTLIST)
             (setq DWGNO (CDR (ASSOC "图纸编号DRAWINGNO." ATTLIST)))
            )
            ((ASSOC "SHEET-NO." ATTLIST)
             (setq DWGNO (CDR (ASSOC "SHEET-NO." ATTLIST)))
            )
          )
          (if (ASSOC "版号VERSION" ATTLIST)
            (PROGN (setq REV (CDR (ASSOC "版号VERSION" ATTLIST))))
          )
          (if (AND DWGNO (/= DWGNO ""))
            (PROGN
              (if (ASSOC DWGNO DWG_LIST)
                (PROGN
                  (command "CIRCLE")
                  (command "2p")
                  (command MIN_PT)
                  (command MAX_PT)
                  (PRINC (STRCAT "\n已有图纸与" DWGNO "重复，请检查！"))
                  (setq 重复 "yes")
                )
                (PROGN
                  (setq DWG_LIST (CONS (LIST DWGNO BLOCK_NAME MIN_PT MAX_PT)
                                       DWG_LIST
                                 )
                  )
                )
              )
            )
            (PROGN (setq 空白 "yes")
                   (command "CIRCLE")
                   (command "2p")
                   (command MIN_PT)
                   (command MAX_PT)
            )
          )
        )
        (if (= 重复 "yes")
          (PROGN (ALERT "有图纸编号重复，请核查！"))
        )
        (if (= 空白 "yes")
          (PROGN (ALERT "还有图纸没有填图号，请核查！"))
        )
        (if (AND (/= 空白 "yes") (/= 重复 "yes"))
          (PROGN
            (FOREACH DWG1 DWG_LIST
              (setq DWGNO (CAR DWG1))
              (setq BLOCK_NAME (CADR DWG1))
              (setq MIN_PT (CADDR DWG1))
              (setq MAX_PT (CADDDR DWG1))
              (setq PTLIST (LIST MIN_PT
                                 (LIST (CAR MAX_PT) (CADR MIN_PT))
                                 MAX_PT
                                 (LIST (CAR MIN_PT) (CADR MAX_PT))
                           )
              )
              (VL-FILE-DELETE (STRCAT DWG_PATH "\\" DWGNO ".dwg"))
              (VL-FILE-DELETE (STRCAT DWG_PATH "\\" DWGNO ".DWG"))
              (setq DWG_NAME (STRCAT DWG_PATH "\\" DWGNO ".dwg"))
              (SETVAR "osmode" 0)
              (VL-CMDF "zoom" "w" MAX_PT MIN_PT)
              (setq SSS nil)
              (if (WCMATCH DWGNO "*-AS-*-*-*,*-FA-*-*-*,*-FD-*-*-*")
                (PROGN
                  (setq SSS (SSGET
                              "w"
                              MAX_PT
                              MIN_PT
                              '((-4 . "<NOT")
                                (2 . "Elivate*,Elicc*,BoRui*,Fortune*,TK-A*,TK-JG-*,TK-MT-")
                                (-4 . "NOT>")
                               )
                            )
                  )
                )
                (PROGN
                  (setq SSS (SSGET "w"
                                   MAX_PT
                                   MIN_PT
                                   '((-4 . "<AND")
                                     (-4 . "<NOT")
                                     (8 . "Defpoints")
                                     (-4 . "NOT>")
                                     (-4 . "<NOT")
                                     (2 . "Elicc_ANSI*")
                                     (-4 . "NOT>")
                                     (-4 . "AND>")
                                    )
                            )
                  )
                )
              )
              (setq SSS (SSADD BLOCK_NAME SSS))
              (command "-WBLOCK")
              (command DWG_NAME)
              (command "")
              (command MIN_PT)
              (command SSS)
              (command "")
              (command "oops")
              (command "zoom")
              (command "p")
            )
          )
        )
      )
      (PROGN (PRINC "\n 没有选择到对象！"))
    )
    (if 多种类型
      (PROGN (ALERT "分图过程中发现有多种图框，请检查！"))
    )
    (if (AND (/= 空白 "yes") (/= 重复 "yes"))
      (if DWG_PATH
        (PROGN
          (if (FINDFILE DWG_PATH)
            (PROGN (OPENPATH DWG_PATH))
          )
        )
      )
    )
    (SETVAR "cmdecho" 1)
    (SETVAR "osmode" ODOSM)
    (PRINC)
  )
)[/code]