[LISP程序]：绘制中心线程序.zip

yuancuang

绘制中心线程序.zip

KENSHIN709

我这里有一个，请参考!!
;;; --------------------------------------------------------------------------;
;;; CL.LSP
;;;   Copyright (C) 1990 by Autodesk, Inc.
;;;  
;;;   Permission to use, copy, modify, and distribute this software and its
;;;   documentation for any purpose and without fee is hereby granted.  
;;;
;;;   THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED WARRANTY.
;;;   ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR PURPOSE AND OF
;;;   MERCHANTABILITY ARE HEREBY DISCLAIMED.
;;;
;;;   By Simon Jones    Autodesk Ltd , London      March 1987
;;;
;;; --------------------------------------------------------------------------;
;;; DESCRIPTION
;;;
;;;  This macro constructs a pair of center lines through the
;;;  center of a circle. The lines are put on a layer "CL".
;;;
;;; --------------------------------------------------------------------------;

(defun clerr (s)
  (if (/= s "Function cancelled")     ; If an error (such as CTRL-C) occurs
    (princ (strcat "\nError: " s))    ; while this command is active...
  )
  (command "UCS" "P")                 ; Restore previous UCS
  (setvar "BLIPMODE" sblip)           ; Restore saved modes
  (setvar "GRIDMODE" sgrid)
  (setvar "HIGHLIGHT" shl)
  (setvar "UCSFOLLOW" sucsf)
  (command "LAYER" "S" clay "")
  (command "undo" "e")
  (setvar "CMDECHO" scmde)
  (setq *error* olderr)               ; Restore old *error* handler
  (princ)                             
)

;;; --------------------------- Main Program ---------------------------------;

(defun C:CL (/ olderr clay sblip scmde sgrid shl sucsf e cen rad d ts xx)
  (setq olderr *error*
        *error* clerr)
  (setq scmde (getvar "CMDECHO"))
  (command "undo" "group")
  (setq clay (getvar "CLAYER"))
  (setq sblip (getvar "BLIPMODE"))
  (setq sgrid (getvar "GRIDMODE"))
  (setq shl (getvar "HIGHLIGHT"))
  (setq sucsf (getvar "UCSFOLLOW"))
  (setvar "CMDECHO" 0)
  (setvar "GRIDMODE" 0)
  (setvar "UCSFOLLOW" 0)
  (setq e nil
        xx "Yes")
  (setq ts (tblsearch "LAYER" "CL"))
  (if (null ts)
    (prompt "\nCreating new layer - CL. ")
    (progn
      (if (= (logand 1 (cdr (assoc 70 ts))) 1)
        (progn
          (prompt "\nLayer CL is frozen. ")
          (initget "Yes No")
          (setq xx (getkword "\nProceed? <N>: "))
          (if (= xx "Yes")
            (command "LAYER" "T" "CL" "")
          )
        )
      )
    )
  )
  (if (= xx "Yes")
    (progn
      (while (null e)
        (setq e (entsel "\nSelect arc or circle: "))
        (if e
          (progn
            (setq e (car e))
            (if (and (/=
                         (cdr (assoc 0 (entget e))) "ARC")
                         (/= (cdr (assoc 0 (entget e))) "CIRCLE")
                )
              (progn
                (prompt "\nEntity is a ")
                (princ (cdr (assoc 0 (entget e))))
                (setq e nil)
              )
            )
          )
        )
      )
      (command "UCS" "e" e)
      (setq cen (trans (cdr (assoc 10 (entget e))) e 1))
      (setq rad (cdr (assoc 40 (entget e))))
      (prompt "\nRadius is ")
      (princ (rtos rad))
      (initget 7 "Length")
      (setq d (getdist "\nLength/<Extension>: "))
      (if (= d "Length")
        (progn
          (initget 7)
          (setq d (getdist cen "\nLength: "))
        )
        (setq d (+ rad d))
      )
      (setvar "BLIPMODE" 0)
      (setvar "HIGHLIGHT" 0)
      (command "LAYER" "M" "CL" "")
      (command "LINE" (list (car cen) (- (cadr cen) d) (caddr cen))
               (list (car cen) (+ (cadr cen) d) (caddr cen)) ""
      )
      (command "CHANGE" "l" "" "P" "LT" "CENTER" "")
      (command "LINE" (list (- (car cen) d) (cadr cen) (caddr cen))
               (list (+ (car cen) d) (cadr cen) (caddr cen)) ""
      )
      (command "CHANGE" "l" "" "P" "LT" "CENTER" "")
      (command "LAYER" "S" clay "")
    )
  )
  (command "UCS" "P")                 ; Restore previous UCS
  (setvar "BLIPMODE" sblip)           ; Restore saved modes
  (setvar "GRIDMODE" sgrid)
  (setvar "HIGHLIGHT" shl)
  (setvar "UCSFOLLOW" sucsf)
  (command "undo" "e")
  (setvar "CMDECHO" scmde)
  (setq *error* olderr)               ; Restore old *error* handler
  (princ)
)
(defun c:ml (/ a a1 a2 b c e f g c1 e1 f1 pt3 pt4 m1 m2)
  (setq a (ssget))
  (setq b (ssname a 0))
  (setq c (entget b))
  (setq e  (cdr (assoc 10 c)))
  (setq f  (cdr (assoc 11 c)))
  (setq g (ssname a 1))
  (setq c1 (entget g))
  (setq e1  (cdr (assoc 10 c1)))
  (setq f1  (cdr (assoc 11 c1)))
  (defun shen (a1 a2)
         (list (/ (+ (car a1) (car a2)) 2)
                 (/ (+ (cadr a1) (cadr a2)) 2)
         )
  )
  (setq m1 (shen e e1))
  (setq m2 (shen f f1))
  (command "line" m1 m2 "")
  (princ)

;;; --------------------------------------------------------------------------;

PFD8667

二楼的确实使用方便又不收币

2150011

二楼能说明怎么用啊,谢谢

lsjjm

REFER TO:
http://www.xdcad.net/forum/showt ... =%D6%D0%D0%C4%CF%DF

pppk

二楼能说明怎么用啊,谢谢  






向版主反映该贴 | IP: 已记录

lxhdyl

2楼的程序还可以

justin_thunder

谢谢2楼的提供！！！谢谢！

found

感謝2樓大大的分享....
好用的工具....

它山之石

功能不详，看了一下，只是知道最后画了一根线。

以后最好给个较详细的说明，功能是什么，怎么用。
不过二楼楼主的共享精神还是值得学习。

86524559

2楼的工具怎么用？谁能给我说明一下吗？

renyonghua2014

看看楼主的提供

yamjqq

感谢好心人，下载学习啦

wei0429

正需要 谢谢