连续模设计相关技术及AutoCAD二次开发lisp

模板孔自動對齊座標標注


;;;********************************************************************1
;;;原作者不詳,我改了一下,就叫 [模板孔自動對齊座標標注] 吧
;;;模板孔自動對齊座標標注 command c:AD1
;;;2006-01-03     Chen Jian
;;;Version 1.0
;;;MADE IN CHINA
(defun c:AD1 ()
  (setvar "cmdecho" 0)
  (command "undo" "be")
  (setq pto '(0 0 0))
  (setq oldmode (getvar "osmode"))
  (if (null the-plate-rightpt)
    (setq the-plate-rightpt (getpoint "\n模板右上角: "))
  )
  (princ "\n當前模板大小---")
  (princ the-plate-rightpt)
  (setq pt1 the-plate-rightpt)
  (setq pt2 (list 0 0))
  (setq pt1x (car pt1))
  (setq pt1y (cadr pt1))
  (setq pc1 pto)
  (setq pc2 the-plate-rightpt)
  (command "zoom" "all")
  (setq        sel1 (ssget "c"
                    pc1
                    pc2
             )
  )
  (command "zoom" "p")
  (grdraw '(0 0) (list pt1x 0) 1)
  (grdraw (list pt1x 0) pt1 1)
  (grdraw pt1 (list 0 pt1y) 1)
  (grdraw (list 0 pt1y) '(0 0) 1)
  (setvar "osmode" 0)
  (setq dwgsc 1.0)
  (if (= nil texth)
    (setq texth 2.5)
  )
  (setvar "dimtxt" texth)
  (setq txth (/ texth dwgsc))
  (setq Acc 1)
  (setq        ptox (car pc1)
        ptoy (cadr pc1)
  )
  (setq        ptcx (car pc2)
        ptcy (cadr pc2)
  )
  (setq dlen (/ 5 dwgsc))
  (setq        phtlx -10000.0
        phtly -100000.0
        phtrx -100000.0
        phtry -100000.0
  )
  (autodim)
  (setvar "osmode" oldmode)
  (Princ
    "\n---Bye c:AD1 模板孔自動對齊座標標注---"
  )
  (command "undo" "e")
  (prin1)
)

模板孔自動對齊座標標注-SUB

;;;********************************************************************1
;;;原作者不詳,我改了一下,就叫 [模板孔自動對齊座標標注] 吧
;;;模板孔自動對齊座標標注 command c:AD1
;;;2006-01-03     Chen Jian
;;;Version 1.0
;;;MADE IN CHINA

;;;;;;;;;;;;;;;;;;;;;;;;;;;SUB
(defun compare (pt1 pt2)
  (setq        pt1x (car pt1)
        pt1y (cadr pt1)
  )
  (setq        pt2x (car pt2)
        pt2y (cadr pt2)
  )
  (if (> 0.0001 (abs (- pt1x pt2x)))
    (progn
      (setq comp "VER")
      (if (< pt1y pt2y)
        (if (< (abs (- leny2 pt2y)) (abs (- pt1y leny1)))
          (setq        ptdim pt2
                leny  leny2
          )
          (setq        ptdim pt1
                leny  leny1
          )
        )
        (if (< (abs (- leny2 pt1y)) (abs (- pt2y leny1)))
          (setq        ptdim pt1
                leny  leny2
          )
          (setq        ptdim pt2
                leny  leny1
          )
        )
      )
    )
    (setq comp "DIFF")
  )
  (if (> 0.0001 (abs (- pt1y pt2y)))
    (progn
      (setq comp "HOR")
      (if (< pt1x pt2x)
        (if (< (abs (- lenx2 pt2x)) (abs (- pt1x lenx1)))
          (setq        ptdim pt2
                lenx  lenx2
          )
          (setq        ptdim pt1
                lenx  lenx1
          )
        )
        (if (< (abs (- lenx2 pt1x)) (abs (- pt2x lenx1)))
          (setq        ptdim pt1
                lenx  lenx2
          )
          (setq        ptdim pt2
                lenx  lenx1
          )
        )
      )
    )
  )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;SUB
;;vertical dimension
;;input origin vertical texthigh accurate point
(defun dimhor (Pv PVt)
  (setq V (rtos (abs (- (cadr PVt) (cadr Pto))) 2 Acc))
  (setq L (abs (- PV (car PVt))))
  (setq Lg (/ Txth 2))
  (cond
    ((> PV (car PVt))
     (if (>= (- (cadr pvt) phtry) txth)
       (progn
         (setq pt1 (list (+ (car PVt) 0) (- (cadr PVt) (cadr Pto))))
         (setq pt2 (list (- PV Lg) (cadr PVt)))
         (setq pt3 (list PV (- (cadr PVt) (/ Txth 3))))
         (command "DIM" "ORD" pt1 pt2 "" "exit")
         (setq phtry (cadr pt2))
       )
       (progn
         (setq pt1 (list (+ (car PVt) Lg) (- (cadr PVt) (cadr Pto))))
         (setq pt2 (list (- pv (/ 10 dwgsc)) (cadr pvt)))
         (setq pt3 (list (- pv (/ 5 dwgsc)) (+ phtry (* 1.5 txth))))
         (setq pt4 (list (- pv lg) (+ phtry (* 1.5 txth))))
         (setq pt5 (list pv (- (+ phtry (* 1.5 txth)) (/ Txth 3))))
         (command "DIM" "ORD" pt1 pt4 "" "exit")
         (setq phtry (cadr pt4))
       )
     )
    )
    (t
     (if (>= (- (cadr pvt) phtly) txth)
       (progn
         (setq pt1 (list (- (car PVt) 0) (- (cadr PVt) (cadr Pto))))
         (setq pt2 (list (+ PV Lg) (cadr PVt)))
         (setq pt3 (list PV (- (cadr PVt) (/ Txth 3))))
         (command "DIM" "ORD" pt1 pt2 "" "exit")
         (setq phtly (cadr pt2))
       )
       (progn
         (setq pt1 (list (- (car PVt) 0) (- (cadr PVt) (cadr Pto))))
         (setq pt2 (list (+ pv (/ 10 dwgsc)) (cadr pvt)))
         (setq pt3 (list (+ pv (/ 5 dwgsc)) (+ phtly (* 1.5 txth))))
         (setq pt4 (list (+ pv lg) (+ phtly (* 1.5 txth))))
         (setq pt5 (list pv (- (+ phtly (* 1.5 txth)) (/ Txth 3))))
         (command "DIM" "ORD" pt1 pt4 "" "exit")
         (setq phtly (cadr pt4))
       )
     )
    )
  )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;SUB
;;horizontal dimension
;;input origin horizontal texthigh accurate point
(defun dimver (Ph PHt)
  (setq H (rtos (abs (- (car PHt) (car Pto))) 2 Acc))

  (setq L (abs (- PH (cadr PHt))))
  (setq Lg (/ Txth 2))
  (cond
    ((> PH (cadr PHt))
     (if (>= (- (car pht) phtrx) txth)
       (progn
         (setq pt1 (list (- (car PHt) (car Pto)) (+ (cadr PHt) 0)))
         (setq pt2 (list (car PHt) (- PH Lg)))
         (setq pt3 (list (+ (car PHt) (/ Txth 3)) PH))
         (command "DIM" "ORD" pt1 pt2 "" "exit")
         (setq phtrx (car pt2))
       )
       (progn
         (setq pt1 (list (- (car PHt) (car Pto)) (+ (cadr PHt) 0)))
         (setq pt2 (list (car PHt) (- ph (/ 10 dwgsc))))
         (setq pt3 (list (+ phtrx (* 1.5 txth)) (- ph (/ 5 dwgsc))))
         (setq pt4 (list (+ phtrx (* 1.5 txth)) (- ph lg)))
         (setq pt5 (list (+ phtrx (* 1.5 txth) (/ Txth 3)) PH))
         (command "DIM" "ORD" pt1 pt4 "" "exit")
         (setq phtrx (car pt4))
       )
     )
    )
    (t
     (if (>= (- (car pht) phtlx) txth)
       (progn
         (setq pt1 (list (- (car PHt) (car Pto)) (- (cadr PHt) 0)))
         (setq pt2 (list (car PHt) (+ PH Lg)))
         (setq pt3 (list (+ (car PHt) (/ Txth 3)) PH))
         (Command "DIM" "ORD" pt1 pt2 "" "exit")
         (setq phtlx (car pt2))
       )
       (progn
         (setq pt1 (list (- (car PHt) (car Pto)) (- (cadr PHt) 0)))
         (setq pt2 (list (car PHt) (+ ph (/ 10 dwgsc))))
         (setq pt3 (list (+ phtlx (* 1.5 txth)) (+ ph (/ 5 dwgsc))))
         (setq pt4 (list (+ phtlx (* 1.5 txth)) (+ ph lg)))
         (setq pt5 (list (+ phtlx (* 1.5 txth) (/ Txth 3)) PH))
         (command "DIM" "ORD" pt1 pt4 "" "exit")
         (setq phtlx (car pt4))
       )
     )
    )
  )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;SUB
(defun dimpt (pt)
  (if (< (- (car pt) lenx1) (- lenx2 (car pt)))
    (progn
      (setq comp "HOR")
      (compare2 comp pt lenx1)
    )
    (progn
      (setq comp "HOR")
      (compare2 comp pt lenx2)
    )
  )
  (if (< (- (cadr pt) leny1) (- leny2 (cadr pt)))
    (progn
      (setq comp "VER")
      (compare2 comp pt leny1)
    )
    (progn
      (setq comp "VER")
      (compare2 comp pt leny2)
    )
  )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;SUB
(defun autodim ()
  (if (< ptox ptcx)
    (setq lenx1        (- ptox dlen)
          lenx2        (+ ptcx dlen)
    )
    (setq lenx2        (+ ptox dlen)
          lenx1        (- ptcx dlen)
    )
  )
  (if (< ptoy ptcy)
    (setq leny1        (- ptoy dlen)
          leny2        (+ ptcy dlen)
    )
    (setq leny2        (+ ptoy dlen)
          leny1        (- ptcy dlen)
    )
  )
  (setq pltoh (list (list pto lenx1)))
  (setq pltov (list (list pto leny1)))
  (setq emno (sslength sel1))
  (setq count1 0)
  (while (/= count1 emno)
    (progn
      (setq entno (ssname sel1 count1))
      (setq ent1 (entget entno))
      (setq ent0 (cdr (assoc '0 ent1)))
      (setq lnty (cdr (assoc '6 ent1)))
      (setq lnt8 (cdr (assoc '8 ent1)))
      (setq laty (cdr (assoc '0 laty)))

      (if (= ent0 "CIRCLE")
        (progn
          (setq pt1z (cdr (assoc '10 ent1)))
          (setq pt1 (trans pt1z 0 1))
          (dimpt pt1)
        )
      )
      (if (= ent0 "INSERT")
        (progn
          (setq pt1z (cdr (assoc '10 ent1)))
          (setq pt1 (trans pt1z 0 1))
          (dimpt pt1)
        )
      )
    )
    (setq count1 (+ count1 1))
  )

  (dimalh)
  (dimalv)

)
;;dimall
(defun dimalh ()
  (setq pltoh (reverse pltoh))
  (setq        lenno (length pltoh)
        no1   0
  )
  (while (< no1 lenno)
    (setq dimda (nth no1 pltoh))
    (setq ptd (car dimda))
    (setq lend2 (cadr dimda))
    (dimhor lend2 ptd)
    (setq no1 (+ no1 1))
  )
  (command "DIMORDINATE" the-plate-rightpt "y" "@3.75,0")
)
(defun dimalv ()
  (setq pltov (reverse pltov))
  (setq        lenn1 (length pltov)
        no2   0
  )
  (while (< no2 lenn1)
    (setq dimda1 (nth no2 pltov))
    (setq ptd1 (car dimda1))
    (setq lend1 (cadr dimda1))
    (dimver lend1 ptd1)
    (setq no2 (+ no2 1))
  )
  (command "DIMORDINATE" the-plate-rightpt "x" "@0,3.75")
)
;;compare the same data or not
(defun compare2        (hv ptp lena / no lis p1 p2 l1 l2)
  (setq        p1 (car ptp)
        p2 (cadr ptp)
        ch "nil"
  )
  (if (= hv "HOR")
    (progn
      (setq nol (length pltoh))
      (setq no 0)
      (while (and (/= ch "E") (<= no (- nol 1)))
        (setq lis (nth no pltoh))
        (setq l2 (cadr (car lis)))
        (setq l3 (car (car lis)))
        (setq lis1 (cadr lis))
        (cond ((= l2 p2)
               (if (> (abs (- l3 lis1)) (abs (- p1 lena)))
                 (setq pltoh (subst (list ptp lena) lis pltoh))
               )
               (setq ch "E")
              )
              ((> l2 p2)
               (if (= no (- nol 1))
                 (progn
                   (setq lis4 (reverse pltoh))
                   (setq pltoh (reverse (cons (list ptp lena) lis4)))
                 )
                 (setq lisl lis)
               )
              )
              (T
               (if (/= no 0)
                 (progn
                   (setq lis2 (member lis pltoh))
                   (setq lis3 (reverse (member lisl (reverse pltoh))))
                   (setq lis2 (cons (list ptp lena) lis2))
                   (setq pltoh (append lis3 lis2))
                   (setq ch "E")
                 )
                 (progn
                   (setq pltoh (cons (list ptp lena) pltoh))
                   (setq ch "E")
                 )
               )
              )
        )
        (setq no (+ no 1))
      )
    )
    (progn
      (setq nol (length pltov))
      (setq no 0)
      (while (and (/= ch "E") (<= no (- nol 1)))
        (setq lis (nth no pltov))
        (setq l2 (car (car lis)))
        (setq l3 (cadr (car lis)))
        (setq lis1 (cadr lis))
        (cond ((= l2 p1)
               (if (> (abs (- l3 lis1)) (abs (- p2 lena)))
                 (setq pltov (subst (list ptp lena) lis pltov))
               )
               (setq ch "E")
              )
              ((> l2 p1)
               (if (= no (- nol 1))
                 (progn
                   (setq lis5 (reverse pltov))
                   (setq pltov (reverse (cons (list ptp lena) lis5)))
                 )
                 (setq lisl lis)
               )
              )
              (T
               (if (/= no 0)
                 (progn
                   (setq lis2 (member lis pltov))
                   (setq lis3 (reverse (member lisl (reverse pltov))))
                   (setq lis2 (cons (list ptp lena) lis2))
                   (setq pltov (append lis3 lis2))
                   (setq ch "E")
                 )
                 (progn
                   (setq pltov (cons (list ptp lena) pltov))
                   (setq ch "E")
                 )
               )
              )
        )
        (setq no (1+ no))
      )
    )
  )
)

我设计的模具-内勾的弹片，产品剪口外形公差0.02

不錯,很欣賞!我有大量的lisp程序,可以交流
qq:253351316

谢谢
我不用QQ,没那么多时间。写程序的目的是要解决工作中的问题，如你有实用的东西可以贴出来给大家

零件編號



;;;********************************************************************1
;;;零件編序號
;;;command: PARTNO1
;;;2005-12-06    Chen Jian
;;;Version 1.0
;;;MADE IN CHINA
(defun cARTNO1        (/ i dia inpoint temptxt ss ssn        sstyp box dda cen p1 p2
                 p3 p4)
  (setvar "cmdecho" 0)
  (setq i nil)
  (setq i (getint "Enter a start number<1>:"))
  (if (null i)
    (setq i 1)
  )
  (setq dia 10)
  (Princ "\n---Enter---to  EXIT...")
  (setq os (getvar "osmode"))
  (setvar "osmode" 0)
  (setq inpoint (getpoint))
  (while inpoint
    (setq temptxt (rtos i 2 0))
    (if        (< i 100)
      (setq temptxt (strcat "0" (rtos i 2 0)))
    )
    (if        (< i 10)
      (setq temptxt (strcat "00" (rtos i 2 0)))
    )
    (command "text" inpoint 3.0 "" temptxt)
    (setq ss (ssget "L"))
    (setq ssn (ssname ss 0))
    (setq ssdata (entget ssn))
    (setq sstyp (cdr (assoc 0 ssdata)))
    (if        (= sstyp "TEXT")
      (progn
        (command "ucs" "e" ssn)
        (setq box (textbox ssdata))
        (setq p1 (car box))
        (setq p3 (cadr box))
        (setq p2 (list (car p3) (cadr p1)))
        (setq p4 (list (car p1) (cadr p3)))
        (setq dda (+ (/ (distance p1 p2) 2) 1))
        (setq cen (inters p1 p3 p2 p4))
        (command "circle" cen (* dia 0.5))
        (command "ucs" "")
      )
    )
    (setq i (1+ i))
    (setq inpoint nil)
    (setq inpoint (getpoint))
  )
  (setvar "osmode" os)
;;;  (command "ucs" "")
  (Princ
    "\n---------------Bye cARTNO1 零件編號---------------"
  )
  (prin1)
)

楼主别把软件里的程序资料放在这里逗大家了，要么就传个软件上来嘛

你这些都是抄软件上的东西，没意思

源程序你不要你要什么？
是我自己开发的，不是抄的。

我主要目的是连续模，不是软件