[分享]超快速五金模板自动坐标标注程序

jfxia · 发表于 2010-12-5 17:04:51

48楼上的朋友有好程序就分享下啊，

yutianweidi · 发表于 2010-12-5 18:39:13

以下程式可以达到楼主效果！

(DEFUN C:cad(/ VAR1 VAR2 PT DOT DIMOFFSET BASEPT1 BASEPT2 XNMIN YNMIN XNMAX YNMAX
            CENPTLIST LINEGRP WLINELISTX WLINELISTY NLINELISTX NLINELISTY
            WLISTPTX WLISTPTY NLISTPTX NLISTPTY COUNTER

yutianweidi · 发表于 2010-12-5 18:39:31

   WCENLISTX WCENLISTY NCENLISTX NCENLISTY DIMNUM)
  (SETQ VAR1 (GETVAR "BLIPMODE"))
  (SETQ VAR2 (GETVAR "CMDECHO"))
  (SETVAR "BLIPMODE" 0)
  (SETVAR "CMDECHO"  0)                   ;系统变量设定
  (SETQ DOT 2)                            ;数值比较精度
  (SETQ DIMOFFSET (* 5 (GETVAR "DIMSCALE")))
  (command "_undo" "mark")

  (SUBCTAG) (princ "\n Waiting for me......\n")          ;选择框
;--------------------------------------------------------圆心标注点过滤
  (SETQ CENPTLIST (SUBCTC))                            ;圆心
  (IF (/= NIL CENPTLIST ) (PROGN (SUBCTCENX CENPTLIST ) (SUBCTCENY CENPTLIST)) )
                           ;圆心分析 WCENTLISTX WCENLISTY NCENLISTX NCENLISTY

  (IF (/= NIL WCENLISTX) (SETQ WCENLISTX (SUBSTFX WCENLISTX)) )
  (IF (/= NIL NCENLISTX)
   (PROGN
      (SETQ NCENLISTX (SUBSTFX NCENLISTX))
      (IF (/= NIL WCENLISTX) (SETQ NCENLISTX (SUBCOMPFX NCENLISTX WCENLISTX)) )
   )
)

  (IF (/= NIL WCENLISTY) (SETQ WCENLISTY (SUBSTFY WCENLISTY)))
  (IF (/= NIL NCENLISTY)
   (PROGN
         (SETQ NCENLISTY (SUBSTFY NCENLISTY))
         (IF (/= NIL WCENLISTY) (SETQ NCENLISTY (SUBCOMPFY NCENLISTY WCENLISTY)) )
   )
)

;--------------------------------------------------------直线标注点过滤
  (SETQ LINEGRP (SSGET "W" BASEPT1 BASEPT2 '((0 . "LINE"))) )
  (IF (/= NIL LINEGRP )
   (PROGN
      (SETQ WLINELISTX (SUBCTLX))                      ;CREAT DIM X LIST PT
      (SETQ WLINELISTX (SUBSTFX WLINELISTX))          ;FILETER XLISTPT
      (IF (/= NIL NLINELISTX) (SETQ NLINELISTX (SUBCOMPFX (SUBSTFX NLINELISTX) WLINELISTX) ))
   )
)

  (IF (/= NIL LINEGRP  )
   (PROGN
   (SETQ WLINELISTY (SUBCTLY))
   (SETQ WLINELISTY (SUBSTFY WLINELISTY))
   (IF (/= NIL NLINELISTY) (SETQ NLINELISTY (SUBCOMPFY (SUBSTFY NLINELISTY) WLINELISTY) ))
   )
)
;----------------------------------------------------------标注点收集
  (SETQ WLISTPTX (APPEND WLINELISTX WCENLISTX) )
  (SETQ WLISTPTY (APPEND WLINELISTY WCENLISTY) )
  (SETQ NLISTPTX (APPEND NLINELISTX NCENLISTX) )
  (SETQ NLISTPTY (APPEND NLINELISTY NCENLISTY) )
  (SETQ DIMNUM (+ (LENGTH (APPEND WLISTPTX WLISTPTY NLISTPTX NLISTPTY)) ) )
;----------------------------------------------------------框外尺寸标注
  (SETQ COUNTER 0)
  (REPEAT (LENGTH WLISTPTX)
   (SETQ PT (NTH COUNTER WLISTPTX))
   (SUBDIMY PT YWMAX YWMIN)                ;DIM
   (SETQ COUNTER (1+ COUNTER))
)

  (SETQ COUNTER 0)
  (REPEAT (LENGTH WLISTPTY)
   (SETQ PT (NTH COUNTER WLISTPTY))
   (SUBDIMX PT XWMAX XWMIN)
   (SETQ COUNTER (1+ COUNTER))
)
;----------------------------------------------------------框内尺寸标注
  (SETQ COUNTER 0)
  (REPEAT (LENGTH NLISTPTX)
   (SETQ PT (NTH COUNTER NLISTPTX) )
   (SUBINITDIMY PT DIMOFFSET)
   (SETQ COUNTER (1+ COUNTER) )
)
  (SETQ COUNTER 0)
  (REPEAT (LENGTH NLISTPTY)
   (SETQ PT (NTH COUNTER NLISTPTY) )
   (SUBINITDIMX PT DIMOFFSET)
   (SETQ COUNTER (1+ COUNTER) )
)

  (SETVAR "BLIPMODE" VAR1)
  (SETVAR "CMDECHO"  VAR2)
  (PRINC "\n 共计标注尺寸:") (PRINC DIMNUM) (PRINC "个!!! \n")
  (PRINC)
)

;<========================MAIN FUNCTION(CAD) END  ==========================>

;<------------------------------SUB FUCTION---------------------------------->
(DEFUN SUBCTAG ( / basept3 basept4)  ;CREAT RANGE OF ENTITY
(setq basept1 (getpoint "\n 输入标注外文字区: "))
(setq basept2 (getcorner basept1 "\n 另一点: "))
(SETQ BASEPT1 (TRANS BASEPT1 1 0) BASEPT2 (TRANS BASEPT2 1 0))
(setq xWmax (max (car basept1) (car basept2)))
(setq xWmin (min (car basept1) (car basept2)))
(setq yWmax (max (cadr basept1) (cadr basept2)))
(setq yWmin (min (cadr basept1) (cadr basept2)))
(setq basept3 (getpoint "\n 输入标注内文字区: "))
(setq basept4 (getcorner basept3 "\n 另一点: "))
(SETQ BASEPT3 (TRANS BASEPT3 1 0) BASEPT4 (TRANS BASEPT4 1 0))
(setq xNmax (max (car basept3) (car basept4)))
(setq xNmin (min (car basept3) (car basept4)))
(setq yNmax (max (cadr basept3) (cadr basept4)))
(setq yNmin (min (cadr basept3) (cadr basept4)))
(SETQ BASEPT1 (TRANS BASEPT1 0 1) BASEPT2 (TRANS BASEPT2 0 1))
)
;<------------------------------SUB FUCTION------------------------------>
(DEFUN SUBSTFX (LIST1 / S D LIST2 lenth1 lenth2 tempt1 tempt2 count1 count2 flag )  ;POINT LIST SORT AND FLIETR X
  (SETQ LIST2 (LIST '(0 0)) )
  (SETQ LENTH1 (LENGTH LIST1))
  (SETQ COUNT1 0 )
  (REPEAT LENTH1
   (SETQ TEMPT1 (NTH COUNT1 LIST1))
   (SETQ LENTH2 (LENGTH LIST2))
   (SETQ COUNT2 0 FLAG 0)
   (REPEAT LENTH2
      (SETQ  TEMPT2 (NTH COUNT2 LIST2))
      (SETQ S (CAR TEMPT2) D (CAR TEMPT1))
      (SETQ S (ATOF (RTOS S 2 DOT)) D (ATOF (RTOS D 2 DOT)) )
      (IF (= S D )
         (PROGN
            (SETQ FLAG (1+ flag))
            (IF (> (CADR TEMPT2) (CADR TEMPT1))  (SETQ LIST2 (SUBST TEMPT1 TEMPT2 LIST2))  )
         )
      )
      (SETQ COUNT2 (1+ COUNT2))
   )
   (IF (= 0 FLAG) (setq list2 (cons TEMPT1 LIST2 )))
   (SETQ COUNT1 (1+ COUNT1))
)
(setq list2 (CDR (REVERSE LIST2)))
)

;<------------------------------SUB FUCTION------------------------------->
(DEFUN SUBSTFY (LIST1 / LIST2 lenth1 lenth2 tempt1 tempt2 count1 count2 flag )  ;POINT LIST SORT AND FLIETR Y
  (SETQ LIST2  (LIST '(0 0)) )
  (SETQ LENTH1 (LENGTH LIST1))
  (SETQ COUNT1 0 )
  (REPEAT LENTH1
   (SETQ TEMPT1 (NTH COUNT1 LIST1))
   (SETQ LENTH2 (LENGTH LIST2))
   (SETQ COUNT2 0 FLAG 0)
   (REPEAT LENTH2
      (SETQ  TEMPT2 (NTH COUNT2 LIST2))
      (SETQ S (CADR TEMPT2) D (CADR TEMPT1))
      (SETQ S (ATOF (RTOS S 2 DOT)) D (ATOF (RTOS D 2 DOT)) )
      (IF (= S D )
         (PROGN
         (SETQ FLAG (1+ flag) )
         (IF (> (CAR TEMPT2) (CAR TEMPT1) )  (SETQ LIST2 (SUBST TEMPT1 TEMPT2 LIST2))  )
         )
      )
      (SETQ COUNT2 (1+ COUNT2))
   )
   (IF (= 0 FLAG) (setq list2 (cons TEMPT1 LIST2 )))
   (SETQ COUNT1 (1+ COUNT1))
)
(setq list2 (CDR (REVERSE LIST2)))
)
;<-----------------------------SUB FUCTION-------------------------------->

(DEFUN SUBCTLX( / LINENTGRP  C TEMP1 COUNT ENT TEMPT STARTPT ENDPT LISTXPT S D) ;CREAT LINE PT
(SETQ LINENTGRP (SSGET "C" BASEPT1 BASEPT2 '((0 . "LINE"))))
(SETQ COUNT 0 )
(REPEAT (SSLENGTH LINENTGRP)       ;CREAT LISTXPT ALL OF LINE
   (SETQ ENT (SSNAME LINENTGRP  COUNT ))          ;GET ENTITY NAME
   (SETQ TEMPT (ENTGET ENT))             ;GET ENTITY DXF CODE
   (SETQ STARTPT (CDR (ASSOC 10 TEMPT)) ENDPT (CDR (ASSOC 11 TEMPT))) ;GET START AND END

   (SETQ S (CAR STARTPT) D (CAR ENDPT))
   (SETQ S (ATOF (RTOS S 2 DOT)) D (ATOF (RTOS D 2 DOT)) )
   (IF (= S D )
      (PROGN
         (IF (< (CADR STARTPT) (CADR ENDPT) )
               (PROGN (SETQ TEMPT STARTPT) (SETQ STARTPT ENDPT) (SETQ ENDPT TEMPT) )
            )          ;EXCHANGE DATA STARTPT>ENDPT
         (SETQ TEMPT NIL)
         (IF (< YNMAX (CADR STARTPT) YWMAX)    ;YNMAX YNMIN IS USER SYSTEM VAR
               (SETQ TEMPT STARTPT)
               (PROGN
                  (IF (< YWMIN (CADR ENDPT) YNMIN)
                     (SETQ TEMPT ENDPT)
                     (PROGN
                        (SETQ NLINELISTX (CONS STARTPT NLINELISTX) )
                        (SETQ TEMPT NIL)
                     )
                  )
               )
            )
            (IF (/= TEMPT NIL) (setq listxpt (CONS TEMPT LISTXPT))  )

yutianweidi · 发表于 2010-12-5 18:39:48

         )
   )
   (SETQ COUNT (1+ COUNT))
   (setq listxpt  LISTXPT )
) ;REPEAT END
)

;<------------------------------SUB FUCTION------------------------------->

(DEFUN SUBCTLY( / LINENTGRP S E TEMP1 COUNT ENT TEMPT STARTPT ENDPT LISTYPT S D ) ;CREAT LINE PT
(SETQ LINENTGRP (SSGET "C" BASEPT1 BASEPT2 '((0 . "LINE"))))
(SETQ COUNT 0 )
(REPEAT (SSLENGTH LINENTGRP)       ;CREAT LISTYPT ALL OF LINE
   (SETQ ENT (SSNAME LINENTGRP  COUNT ))          ;GET ENTITY NAME
   (SETQ TEMP1 (ENTGET ENT))             ;GET ENTITY DXF CODE
   (SETQ STARTPT (CDR (ASSOC 10 TEMP1)) ENDPT (CDR (ASSOC 11 TEMP1))) ;GET START AND END
   (SETQ S (CADR STARTPT) D (CADR ENDPT) )
   (SETQ S (ATOF (RTOS S 2 DOT)) D (ATOF (RTOS D 2 DOT)) )
   (IF (= S D )
      (PROGN
         (IF (< (CAR STARTPT) (CAR ENDPT) )
               (PROGN (SETQ TEMPT STARTPT) (SETQ STARTPT ENDPT) (SETQ ENDPT TEMPT) )
            )          ;EXCHANGE DATA STARTPT>ENDPT
         (SETQ TEMPT NIL)
         (IF (< XNMAX (CAR STARTPT) XWMAX)    ;XNMAX YNMIN IS USER SYSTEM VAR
               (SETQ TEMPT STARTPT)
               (PROGN
                  (IF (< XWMIN (CAR ENDPT) XNMIN)
                     (SETQ TEMPT ENDPT)
                     (PROGN
                        (SETQ NLINELISTY (CONS STARTPT NLINELISTY) )
                        (SETQ TEMPT NIL)
                     )
                  )
               )
            )
            (IF (/= TEMPT NIL) (setq listYpt (CONS TEMPT LISTYPT)))

         )
   )
   (SETQ COUNT (1+ COUNT))
   (setq listYpt  LISTYPT )
) ;REPEAT END
)

;<------------------------------SUB FUCTION--------------------------------->

(DEFUN SUBCTC(/ CIRCLENTGRP ENT TEMP1 CENTERPT CENLIST )

   (SETQ CIRCLENTGRP (SSGET "W" BASEPT1 BASEPT2 '((0 . "CIRCLE")) ) )
   (SETQ COUNT 0)
   (IF (= NIL CIRCLENTGRP)
         (SETQ CENLIST NIL)
         (REPEAT (SSLENGTH CIRCLENTGRP)       ;CREAT LISTYPT ALL OF LINE
         (SETQ ENT (SSNAME CIRCLENTGRP  COUNT ))          ;GET ENTITY NAME
         (SETQ TEMP1 (ENTGET ENT))             ;GET ENTITY DXF CODE
         (SETQ CENTERPT (CDR (ASSOC 10 TEMP1)))  ;GET CIRCLE CENTER
         (SETQ CENLIST (CONS CENTERPT CENLIST))
         (SETQ COUNT (1+ COUNT))
         )
   )
   (SETQ CENLIST CENLIST)
)

;<------------------------------SUB FUCTION------------------------------>

(DEFUN SUBDIMY(PTT YMAX YMIN / PT LY1 LY2 DIMY DIMYPT OMODE) ;DIMYMIN DIMYMAX IS USER SYSTEM VAR
(SETQ PT PTT)          ;LOOK UP PROGM "QDT"
(SETQ LY1 (ABS (- YMAX (CADR PT))))
(SETQ LY2 (ABS (- YMIN (CADR PT))))
(IF (< LY1 LY2) (SETQ DIMY YMAX) (SETQ DIMY YMIN))
(SETQ DIMYPT (LIST (CAR PT) DIMY))
(SETQ DIMYPT (TRANS DIMYPT 0 1) PT (TRANS PT 0 1 ))
(setq omode (getvar "osmode"))             ;暂时关闭目标捕捉
(setvar "osmode" 0)
(COMMAND "_DIMORDINATE" PT DIMYPT)
(SETVAR "OSMODE" OMODE)
)

;<------------------------------SUB FUCTION-------------------------------->

(DEFUN SUBDIMX(PTT  XMAX XMIN / PT LX1 LX2 DIMX DIMXPT OMODE)  ;DIMXMIN DIMXMAX IS USER SYSTEM VAR
(SETQ PT PTT)       ;LOOK UP PROGRAM "QDT"
(setq LX1 (ABS (- XMAX (CAR PT))))
(SETQ LX2 (ABS (- XMIN (CAR PT))))
(IF (< LX1 LX2) (SETQ DIMX XMAX) (SETQ DIMX XMIN))
(SETQ DIMXPT (LIST DIMX (CADR PT)))
(SETQ DIMXPT (TRANS DIMXPT 0 1) PT (TRANS PT 0 1 ))
(setq omode (getvar "osmode"))             ;暂时关闭目标捕捉
(setvar "osmode" 0)
(COMMAND "_DIMORDINATE" PT DIMXPT)
(SETVAR "OSMODE" OMODE)
)

;<------------------------------SUB FUCTION--------------------------------->
(DEFUN SUBINITDIMY(PTT OFFSET / PT DIMYPT OMODE)
(SETQ PT PTT)
(SETQ DIMYPT (LIST (CAR PT) (+ (CADR PT) OFFSET) ) )

yutianweidi · 发表于 2010-12-5 18:40:11

(SETQ DIMYPT (TRANS DIMYPT 0 1) PT (TRANS PT 0 1 ))
(SETQ OMODE (GETVAR "OSMODE"))
(SETVAR "OSMODE" 0)
(COMMAND "_DIMORDINATE" PT DIMYPT)
(SETVAR "OSMODE" OMODE)
)

;<------------------------------SUB FUCTION---------------------------------->

(DEFUN SUBINITDIMX(PTT OFFSET / PT DIMXPT OMODE)
(SETQ PT PTT)
(SETQ DIMXPT (LIST (+ (CAR PT) OFFSET) (CADR PT) ) )
(SETQ DIMXPT (TRANS DIMXPT 0 1) PT (TRANS PT 0 1 ))
(SETQ OMODE (GETVAR "OSMODE"))
(SETVAR "OSMODE" 0)
(COMMAND "_DIMORDINATE" PT DIMXPT)
(SETVAR "OSMODE" OMODE)
)

(defun SUBCOMPFx (list1 list2 / list3 tempt1 tempt2 count1 count2 flag S D )
   (SETQ COUNT1 0)
   (REPEAT (LENGTH LIST1)
      (SETQ TEMPT1 (NTH COUNT1 LIST1) COUNT2 0 FLAG 0)
      (REPEAT (LENGTH LIST2)
            (SETQ TEMPT2 (NTH COUNT2 LIST2))
            (SETQ S (ATOF (RTOS (CAR TEMPT1) 2 DOT) )  D (ATOF (RTOS (CAR TEMPT2) 2 DOT) ) )
            (IF (= S D ) (SETQ FLAG (1+ FLAG)))
            (SETQ COUNT2 (1+ COUNT2))
      )
      (IF (= 0 FLAG) (SETQ LIST3 (CONS TEMPT1 LIST3) ) )
      (SETQ COUNT1 (1+ COUNT1) )
   )
   (SETQ LSIT3 LIST3)
)

(defun SUBCOMPFY (list1 list2 / list3 tempt1 tempt2 count1 count2 flag S D )
   (SETQ COUNT1 0)
   (REPEAT (LENGTH LIST1)
      (SETQ TEMPT1 (NTH COUNT1 LIST1) COUNT2 0 FLAG 0)
      (REPEAT (LENGTH LIST2)
            (SETQ TEMPT2 (NTH COUNT2 LIST2) )
            (SETQ S (ATOF (RTOS (CADR TEMPT1) 2 DOT) )  D (ATOF (RTOS (CADR TEMPT2) 2 DOT) ) )
            (IF (= S D ) (SETQ FLAG (1+ FLAG)))
            (SETQ COUNT2 (1+ COUNT2))
      )
      (IF (= 0 FLAG) (SETQ LIST3 (CONS TEMPT1 LIST3) ) )
      (SETQ COUNT1 (1+ COUNT1) )
   )
   (SETQ LSIT3 LIST3)
)
;<------------------------------SUB FUCTION----------------------------------->
(DEFUN SUBCTCENX (LIST / COUNT TEMPT) ;PORT OUT WCENLISTX NCENLISTX
(SETQ COUNT 0)
(REPEAT (LENGTH LIST)
   (SETQ TEMPT (NTH COUNT LIST) )
   (IF (OR (< YWMIN (CADR TEMPT) YNMIN) (< YNMAX (CADR TEMPT) YWMAX) )
         (SETQ WCENLISTX (CONS TEMPT WCENLISTX) )
         (SETQ NCENLISTX (CONS TEMPT NCENLISTX) )
      )
      (SETQ COUNT (1+ COUNT))
)

)
(DEFUN SUBCTCENY (LIST / COUNT TEMPT)
(SETQ COUNT 0)
(REPEAT (LENGTH LIST)
   (SETQ TEMPT (NTH COUNT LIST) )
   (IF (OR (< XWMIN (CAR TEMPT) XNMIN) (< XNMAX (CAR TEMPT) XWMAX))
         (SETQ WCENLISTY (CONS TEMPT WCENLISTY) )
         (SETQ NCENLISTY (CONS TEMPT NCENLISTY) )
      )
   (SETQ COUNT (1+ COUNT) )
)

)

yutianweidi · 发表于 2010-12-5 18:40:44

以上LSP太长，不好一次性发好，我发料四次，其实是一个LSP!

xjf · 发表于 2011-1-16 17:40:34

谢楼主及52楼的,支持源码

MJCADLWF · 发表于 2011-1-18 00:53:22

感谢楼主分享！

MJCADLWF · 发表于 2011-1-18 01:09:43

支持楼主，感谢分享！

xiaxiang · 发表于 2011-1-18 09:02:18

52楼的，为啥不上传一个完整的lisp文件？是要考验一下大家吗

账号		自动登录	找回密码
密码			注册