+发表新主题
yangguorong 发布于2007-6-30 08:30 81 次浏览 4 位用户参与讨论
跳转到指定楼层
如题,先谢!
回复

使用道具 举报

已有4人评论

jwl123 发表于 2007-6-30 08:37:37
在高版本中可以如07、08
回复

使用道具 举报

yqzzxqd 发表于 2007-6-30 10:52:47

Just Sharing

;|
    ;**************************************
    ; Name: Linear Arc Dimension
    ; Description:That routine makes linear arc dimensions. The units depend on Dimension Style Setting Primary Units. By modifying the arc you automatically update the dimension.
    ; By: Michael Kolomiyets
    ;
    ;
    ; Inputs:None
    ;
    ; Returns:None
    ;
    ;Assumes:1. Make an application from this lisp routine or
    you can make just LSP file from this routine.
    (I made an application with 'VLX' extension)
    2. Appload either 'VLX' or 'FAS'(compiled version) or 'LSP' file.
    3. Before starting the routine have at least one arc.
    4. Type 'LAD' at command prompt;
    5. prompt offer: Pick the arc to Dimensionclick an arc)
    6. should you modify an arc the dimension will be updated automatically.
    Routine was tested on AutoCAD 2000i.
    ;
    ;Side Effects:None
    ;This code is copyrighted and has limited warranties.
    ;Please see http://www.Planet-Source-Code.co ... cripts/ShowCode.htm
    ;for details.
    ;**************************************
|;
    (vl-load-com)
    ;*****************************************************************************


(setq cls_dwg (vlr-dwg-reactor nil '((:VLR-beginClose . destroyobj))))
(defun destroyobj (rctr param)
    (if (type acadobj)
      (vlax-release-object acadobj)
    )
    (if (type doc)
      (vlax-release-object doc)
    )
    (if (type util)
      (vlax-release-object util)
    )
    (if (type s_sets)
      (vlax-release-object s_sets)
    )
    (setq       arc_dim_lst
         (if (type arc_dim_lst)
           nil
         )
    )
    (setq       initialized
         (if (type initialized)
           nil
         )
    )
    (mapcar
      '(lambda (rctr_lst)
         (foreach       rctr-itm rctr_lst
         (if (vlr-added-p rctr-itm)
           (vlr-remove rctr-itm)
         )                              ;if
         )                              ;for
       )                                        ;lambda
      (mapcar 'cdr (vlr-reactors))
    )                                   ;mapcar
    (vlr-remove-all)
)                                      ;defun
                                        ;***************************************
                                        ;     **************************************
(defun *error* (s)
    (if (= s "Function cancelled")
      (prompt "Function cancelled by usern")
      (princ)
    )
)
                                        ;***************************************
                                        ;     **************************************
(defun c:lad (/ sel_obj arc_pnt)
    (vla-getentity
      util
      'sel_obj
      'arc_pnt
      "Pick the arc to Dimension: "
    )
    (if (= (vla-get-objectname sel_obj) "AcDbArc")
      (core sel_obj)
      (progn
        (alert "You must select an arc!")
        (c:lad)
      )                                 ;progn
    )                                   ;if
    (princ)
)
  ;***************************************
  ;     **************************************
(defun dim_crtr       (arc_core    /           strtpnt     endpnt
                 cenvert     arclen      arclenstr   owner
                 radius      strtpntlst  endpntlst   cenvertlst
                 midpnt_x    midpnt_y    tan_midpnt  textpnt
                 new_dim
                )

    (setq strtpnt (vla-get-startpoint arc_core))
    (setq endpnt (vla-get-endpoint arc_core))
    (setq cenvert (vla-get-center arc_core))
    (setq arclen (vla-get-arclength arc_core))
    (setq arclenstr (rtos arclen (getvar "DIMLUNIT") (getvar "DIMDEC")))
    (setq radius (vla-get-radius arc_core))
    (setq strtpntlst (vlax-safearray->list (vlax-variant-value strtpnt)))
    (setq endpntlst (vlax-safearray->list (vlax-variant-value endpnt)))
    (setq cenvertlst (vlax-safearray->list (vlax-variant-value cenvert)))
    (setq midpnt_x (/ (+ (car strtpntlst) (car endpntlst)) 2))
    (setq midpnt_y (/ (+ (cadr strtpntlst) (cadr endpntlst)) 2))
    (setq midpnt_x_quart (- midpnt_x (car cenvertlst)))
    (setq midpnt_y_quart (- midpnt_y (cadr cenvertlst)))
    (setq strtangl (vla-get-startangle arc_core))
    (setq totangl (vla-get-totalangle arc_core))
    (setq       textpnt
         (vlax-3d-point
           (polar cenvertlst
                  (+ strtangl (/ totangl 2))
                  (+ (/ radius 10) radius)
           )
         )
    )
    (setq owner (vla-get-ownerid arc_core))
    (if (= owner (vla-get-objectid (vla-get-modelspace doc)))
      (progn
        (setq new_dim (vla-addDim3PointAngular
                      (vla-get-modelspace doc)
                      cenvert
                      strtpnt
                      endpnt
                      textpnt
                    )
        )                                       ;setq
      )                                 ;progn
      (progn
        (setq new_dim (vla-addDim3PointAngular
                      (vla-get-paperspace doc)
                      cenvert
                      strtpnt
                      endpnt
                      textpnt
                    )
        )                                       ;setq
      )                                 ;progn
    )                                   ;if
    (vla-put-textoverride new_dim arclenstr)
    new_dim
)                                     ;defun

  ;***************************************
  ;     **************************************
(defun core (arc_lad / rctr_owns new_dim del_dim_assoc del_dim)
    (setq rctr_owns (vlr-owners arc_rctr))
    (setq new_dim (dim_crtr arc_lad))
    (if (member arc_lad rctr_owns)
      (progn
        (setq del_dim_assoc (assoc arc_lad arc_dim_lst))
        (setq del_dim (cdr del_dim_assoc))
        (setq arc_dim_lst
             (subst (cons arc_lad new_dim)
                    del_dim_assoc
                    arc_dim_lst
             )
        )
        (vl-catch-all-apply 'vla-erase (list del_dim))
      )                                 ;progn
      (progn
        (vlr-owner-add arc_rctr arc_lad)
        (setq arc_dim_lst (cons (cons arc_lad new_dim) arc_dim_lst))
      )                                 ;progn
    )                                   ;if
)                                     ;defun

  ;***************************************
  ;     **************************************
(defun arc_mod (arc_ntfr mod_rctr plist)
    (if (not (vlax-erased-p arc_ntfr))
      (core arc_ntfr)
    )
)                                     ;defun

  ;***************************************
  ;     **************************************
(defun initialize (/             s_sets          fltr_cod_arc
                   fltr_val_arc    arc_col         fltr_cod_dim
                   fltr_val_dim    dim_col         dim_itm
                   dim_strt_pnt    dim_strt_lst    dim_end_pnt
                   dim_end_lst     dim_vrt         dim_vrt_lst
                   arc_itm         arc_strt_pnt    arc_strt_lst
                   arc_end_pnt     arc_end_lst     arc_cen
                   arc_cen_lst
                  )
    (if (not initialized)
      (progn
        (obj_set)
        (setq s_sets (vla-get-selectionsets doc))
        (setq arc_col (vla-add s_sets "arcs"))
        (setq dim_col (vla-add s_sets "dims"))
        (setq fltr_cod_arc (vlax-make-safearray vlax-vbinteger '(0 . 0)))
        (setq fltr_val_arc (vlax-make-safearray vlax-vbvariant '(0 . 0)))
        (vlax-safearray-fill fltr_cod_arc '(0))
        (vlax-safearray-fill fltr_val_arc '("ARC"))
        (vla-select
        arc_col acSelectionSetAll nil nil fltr_cod_arc fltr_val_arc)
        (setq fltr_cod_dim (vlax-make-safearray vlax-vbinteger '(0 . 1)))
        (setq fltr_val_dim (vlax-make-safearray vlax-vbvariant '(0 . 1)))
        (vlax-safearray-fill fltr_cod_dim '(0 70))
        (vlax-safearray-fill fltr_val_dim '("DIMENSION" 37))
        (vla-select dim_col acSelectionSetAll nil nil fltr_cod_dim fltr_val_dim)
        (vlax-map-collection
          dim_col
          '(lambda (dim_itm)
             (setq dim_strt_pnt (vla-get-ExtLine1EndPoint dim_itm))
             (setq dim_strt_lst
                    (vlax-safearray->list
                      (vlax-variant-value dim_strt_pnt)
                    )
             )
             (setq dim_end_pnt (vla-get-ExtLine2EndPoint dim_itm))
             (setq dim_end_lst
                    (vlax-safearray->list
                      (vlax-variant-value dim_end_pnt)
                    )
             )
             (setq dim_vrt (vla-get-anglevertex dim_itm))
             (setq dim_vrt_lst
                    (vlax-safearray->list
                      (vlax-variant-value dim_vrt)
                    )
             )
             (vlax-for arc_itm arc_col
               (setq arc_strt_pnt (vla-get-startpoint arc_itm))
               (setq arc_strt_lst
                      (vlax-safearray->list
                        (vlax-variant-value arc_strt_pnt)
                      )
               )
               (setq arc_end_pnt (vla-get-endpoint arc_itm))
               (setq arc_end_lst
                      (vlax-safearray->list
                        (vlax-variant-value arc_end_pnt)
                      )
               )
               (setq arc_cen (vla-get-center arc_itm))
               (setq arc_cen_lst
                      (vlax-safearray->list
                        (vlax-variant-value arc_cen)
                      )
               )
               (if
                 (and
                   (= (car arc_strt_lst) (car dim_strt_lst))
                   (= (cadr arc_strt_lst) (cadr dim_strt_lst))
                   (= (car arc_end_lst) (car dim_end_lst))
                   (= (cadr arc_end_lst) (cadr dim_end_lst))
                   (= (car arc_cen_lst) (car dim_vrt_lst))
                   (= (cadr arc_cen_lst) (cadr dim_vrt_lst))
                 )                        ;and
                  (setq arc_dim_lst
                         (cons (cons arc_itm dim_itm) arc_dim_lst)
                  )
               )                          ;if
             )                            ;for
           )                              ;lambda
        )                                 ;map
        (setq arc_rctr
             (vlr-object-reactor
               (mapcar 'car arc_dim_lst)
               "ArcRctMod"
               '((:vlr-modified . arc_mod))
             )                          ;rctr
        )                                       ;setq
        (setq initialized T)
        (prompt "nType LAD on prompt...n")
        (princ)
      )                                 ;progn
    )                                   ;if
)                                     ;defun

  ;***************************************
  ;     **************************************
(defun obj_set ()
    (setq acadobj (vlax-get-acad-object))
    (setq doc (vla-get-activedocument acadobj))
    (setq util (vla-get-utility doc))
)
  ;***************************************
  ;     **************************************
(initialize)
  ;***************************************
  ;     **************************************Linear_ Arc_Dimension.rar
回复

使用道具 举报

fuguangyi 发表于 2007-6-30 11:24:35
什么都没看到
回复

使用道具 举报

yangguorong 发表于 2007-6-30 16:10:54
二楼的回复太复杂了,不过还是谢谢,这是个程序,能先说下怎么用吗?
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

QQ| Archiver|手机版|小黑屋| 碧波制图网 Stonespider

Copyright © 2021-2023 Kangli Wu   All Rights Reserved.

Powered by Discuz! X3.5( 苏ICP备18011607号-1 )

快速
回复
返回
列表
返回
顶部