字典操作

dcl1214 · 发表于 2025-6-1 14:28:29

本帖最后由 dcl1214 于 2025-6-1 14:30 编辑

字典操作，一起测试
感谢石总帮助

(defun $zi-dian-xie-ru$
(ent name values lst /
_setxrecord alls dict dicts
list->vbarray news obj obj0
olds xd xlst xrec xt
)
;字典写入
;($zi-dian-xie-ru$(CAR (entsel)) "ZXCAD" '((1000 . "HELLO WORLD") (1070 . 1) (1040 . 1.0))nil)
(defun _setxrecord (obj lst)
(vla-setxrecorddata
obj
(list->vbarray (mapcar 'car lst) vlax-vbinteger)
(list->vbarray (mapcar 'cdr lst) vlax-vbvariant)
)
)
(defun list->vbarray (ptsList TYPE1 / arraySpace sArray)
(setq arraySpace
(vlax-make-safearray
TYPE1
(cons 0 (- (length ptsList) 1))
)
)
(setq sArray (vlax-safearray-fill arraySpace ptsList))
(vlax-make-variant sArray)
)
(if (and ent (= (type ent)) 'ename)
(setq obj0 (vlax-ename->vla-object ent))
)
(and obj0 (setq obj (VLA-GetExtensionDictionary obj0)))
(if (= (vla-get-objectname obj) "AcDbDictionary")
(progn
(vlax-for d obj
(if (and (= (vla-get-objectname d) "AcDbXrecord")
(= (strcase (vla-get-name d)) (strcase name))
)
(setq xrec d)
)
)
(if xrec
(progn
(vla-getxrecorddata xrec 'xt 'xd)
(if xt
(progn
(setq olds
(mapcar 'cons
(safearray-value xt)
(mapcar 'variant-value (safearray-value xd))
)
)
(setq
alls (vl-remove nil (append olds values))
)
(cond
((vl-position (cdr (assoc "模式" lst)) (list "追加"))
(setq news alls)
)
(t (setq news values))
)
(_setxrecord xrec news)
)
(_setxrecord xrec values)
)
)
(progn
(setq xrec (vla-addxrecord obj name))
(_setxrecord xrec values)
)
)
)
(if (= (vla-get-hasExtensionDictionary obj) :vlax-true)
(progn
(setq dicts (vla-GetExtensionDictionary obj))
(vlax-for dict dicts
(if (and (= (vla-get-objectname dict) "AcDbXrecord")
(= (strcase (vla-get-name dict)) (strcase name))
)
(setq xrec dict)
)
)
(if xrec
(progn
(vla-getxrecorddata xrec 'xt 'xd)
(_setxrecord
xrec
(append
(mapcar 'cons
(safearray-value xt)
(mapcar 'variant-value (safearray-value xd))
)
values
)
)
)
)
)
(progn
(setq dict (vla-getextensiondictionary obj)
xrec (vla-addxrecord dict name)
)
(_setxrecord xrec values)
)
)
)
($zi-dian-du-qu$ ent "*" nil)
)
(defun $zi-dian-du-qu$
(ent name lst / _getxrecord dicts e obj obj0 xd xt)
;字典读取
;($zi-dian-du-qu$(CAR (entsel)) "*" nil)
;($zi-dian-du-qu$(CAR (entsel)) "ZXCAD" nil)
(defun _getxrecord (dc / xt xd)
(if (= (vla-get-objectname dc) "AcDbXrecord")
(progn (vla-getxrecorddata dc 'xt 'xd)
(if (and xt xd)
(setq lst
(cons
(cons (vla-get-name dc)
(mapcar
'cons
(safearray-value xt)
(mapcar 'variant-value (safearray-value xd))
)
)
lst
)
)
(setq lst (cons (vla-get-name dc) lst))
)
)
)
)
(if (and ent (= (type ent)) 'ename)
(setq obj0 (vlax-ename->vla-object ent))
)
(and obj0 (setq obj (VLA-GetExtensionDictionary obj0)))
(if (= (vla-get-objectname obj) "AcDbDictionary")
(vlax-for dict obj (_getxrecord dict))
(if (= (vla-get-hasExtensionDictionary obj) :vlax-true)
(progn (setq dicts (vla-GetExtensionDictionary obj))
(vlax-for dict dicts (_getxrecord dict))
)
)
)
(if
(= name "*")
lst
(vl-remove-if-not
(function (lambda (x) (= (strcase (car x)) (strcase name))))
lst
)
)
)
(defun $zi-dian-shan-chu$
(ent name vars lst / E1 obj obj0 OLDS SS TF X)
;字典删除
;($zi-dian-shan-chu$(CAR (entsel)) "ZXCAD" '((1070 . 1) (1040 . 2.0)) nil)
(if (and ent (= (type ent)) 'ename)
(setq obj0 (vlax-ename->vla-object ent))
)
(and obj0 (setq obj (VLA-GetExtensionDictionary obj0)))
(if (setq OLDS ($zi-dian-du-qu$ ent name NIL))
(progn
(setq olds (cdr (assoc name OLDS)))
(COND
((AND obj name vars)
(setq OLDS (vl-remove-if
(function (lambda (a) (assoc (car a) vars)))
OLDS
)
)
(if OLDS
($zi-dian-xie-ru$ ent name OLDS lst)
)
)
(T
(if (= (vla-get-objectname obj) "AcDbDictionary")
(vlax-for d obj
(if (= (vla-get-objectname d) "AcDbXrecord")
(if (= name "*")
(vla-delete d)
)
(if (= (strcase (vla-get-name d)) (strcase name))
(vla-delete d)
)
)
)
(if (vla-get-hasextensiondictionary obj)
(vlax-for d (vla-getextensiondictionary obj)
(if (= (vla-get-objectname d) "AcDbXrecord")
(if (= name "*")
(vla-delete d)
)
(if (= (strcase (vla-get-name d)) (strcase name))
(vla-delete d)
)
)
)
)
)
)
)
(setq OLDS ($zi-dian-du-qu$ ent name NIL))
)
)
OLDS
)

(defun $zi-dian-xie-ru$ 
                        (ent          name           values   lst             / 
                         _setxrecord           alls            dict     dicts 
                         list->vbarray           news            obj             obj0 
                         olds          xd           xlst            xrec     xt 
                        ) 
                                        ;字典写入 
                                        ;($zi-dian-xie-ru$(CAR (entsel))  "ZXCAD" '((1000 . "HELLO WORLD") (1070 . 1) (1040 . 1.0))nil) 
  (defun _setxrecord (obj lst) 
    (vla-setxrecorddata 
      obj 
      (list->vbarray (mapcar 'car lst) vlax-vbinteger) 
      (list->vbarray (mapcar 'cdr lst) vlax-vbvariant) 
    ) 
  ) 
  (defun list->vbarray (ptsList TYPE1 / arraySpace sArray) 
    (setq arraySpace 
           (vlax-make-safearray 
             TYPE1 
             (cons 0 (- (length ptsList) 1)) 
           ) 
    ) 
    (setq sArray (vlax-safearray-fill arraySpace ptsList)) 
    (vlax-make-variant sArray) 
  ) 
  (if (and ent (= (type ent)) 'ename) 
    (setq obj0 (vlax-ename->vla-object ent)) 
  ) 
  (and obj0 (setq obj (VLA-GetExtensionDictionary obj0))) 
  (if (= (vla-get-objectname obj) "AcDbDictionary") 
    (progn 
      (vlax-for        d obj 
        (if (and (= (vla-get-objectname d) "AcDbXrecord") 
                 (= (strcase (vla-get-name d)) (strcase name)) 
            ) 
          (setq xrec d) 
        ) 
      ) 
      (if xrec 
        (progn 
          (vla-getxrecorddata xrec 'xt 'xd) 
          (if xt 
            (progn 
              (setq olds 
                     (mapcar 'cons 
                             (safearray-value xt) 
                             (mapcar 'variant-value (safearray-value xd)) 
                     ) 
              ) 
              (setq 
                alls (vl-remove nil (append olds values)) 
              ) 
              (cond 
                ((vl-position (cdr (assoc "模式" lst)) (list "追加")) 
                 (setq news alls) 
                ) 
                (t (setq news values)) 
              ) 
              (_setxrecord xrec news) 
            ) 
            (_setxrecord xrec values) 
          ) 
        ) 
        (progn 
          (setq xrec (vla-addxrecord obj name)) 
          (_setxrecord xrec values) 
        ) 
      ) 
    ) 
    (if        (= (vla-get-hasExtensionDictionary obj) :vlax-true) 
      (progn 
        (setq dicts (vla-GetExtensionDictionary obj)) 
        (vlax-for dict dicts 
          (if (and (= (vla-get-objectname dict) "AcDbXrecord") 
                   (= (strcase (vla-get-name dict)) (strcase name)) 
              ) 
            (setq xrec dict) 
          ) 
        ) 
        (if xrec 
          (progn 
            (vla-getxrecorddata xrec 'xt 'xd) 
            (_setxrecord 
              xrec 
              (append 
                (mapcar        'cons 
                        (safearray-value xt) 
                        (mapcar 'variant-value (safearray-value xd)) 
                ) 
                values 
              ) 
            ) 
          ) 
        ) 
      ) 
      (progn 
        (setq dict (vla-getextensiondictionary obj) 
              xrec (vla-addxrecord dict name) 
        ) 
        (_setxrecord xrec values) 
      ) 
    ) 
  ) 
  ($zi-dian-du-qu$ ent "*" nil) 
) 
(defun $zi-dian-du-qu$ 
       (ent name lst / _getxrecord dicts e obj obj0 xd xt) 
                                        ;字典读取 
                                        ;($zi-dian-du-qu$(CAR (entsel))   "*"  nil) 
                                        ;($zi-dian-du-qu$(CAR (entsel))   "ZXCAD"  nil) 
  (defun _getxrecord (dc / xt xd) 
    (if        (= (vla-get-objectname dc) "AcDbXrecord") 
      (progn (vla-getxrecorddata dc 'xt 'xd) 
             (if (and xt xd) 
               (setq lst 
                      (cons 
                        (cons (vla-get-name dc) 
                              (mapcar 
                                'cons 
                                (safearray-value xt) 
                                (mapcar 'variant-value (safearray-value xd)) 
                              ) 
                        ) 
                        lst 
                      ) 
               ) 
               (setq lst (cons (vla-get-name dc) lst)) 
             ) 
      ) 
    ) 
  ) 
  (if (and ent (= (type ent)) 'ename) 
    (setq obj0 (vlax-ename->vla-object ent)) 
  ) 
  (and obj0 (setq obj (VLA-GetExtensionDictionary obj0))) 
  (if (= (vla-get-objectname obj) "AcDbDictionary") 
    (vlax-for dict obj (_getxrecord dict)) 
    (if        (= (vla-get-hasExtensionDictionary obj) :vlax-true) 
      (progn (setq dicts (vla-GetExtensionDictionary obj)) 
             (vlax-for dict dicts (_getxrecord dict)) 
      ) 
    ) 
  ) 
  (if 
    (= name "*") 
     lst 
     (vl-remove-if-not 
       (function (lambda (x) (= (strcase (car x)) (strcase name)))) 
       lst 
     ) 
  ) 
) 
(defun $zi-dian-shan-chu$ 
       (ent name vars lst / E1 obj obj0 OLDS SS TF X) 
                                        ;字典删除 
                                        ;($zi-dian-shan-chu$(CAR (entsel))   "ZXCAD" '((1070 . 1) (1040 . 2.0))  nil) 
  (if (and ent (= (type ent)) 'ename) 
    (setq obj0 (vlax-ename->vla-object ent)) 
  ) 
  (and obj0 (setq obj (VLA-GetExtensionDictionary obj0))) 
  (if (setq OLDS ($zi-dian-du-qu$ ent name NIL)) 
    (progn 
      (setq olds (cdr (assoc name OLDS))) 
      (COND 
        ((AND obj name vars) 
         (setq OLDS (vl-remove-if 
                      (function (lambda (a) (assoc (car a) vars))) 
                      OLDS 
                    ) 
         ) 
         (if OLDS 
           ($zi-dian-xie-ru$ ent name OLDS lst) 
         ) 
        ) 
        (T 
         (if (= (vla-get-objectname obj) "AcDbDictionary") 
           (vlax-for d obj 
             (if (= (vla-get-objectname d) "AcDbXrecord") 
               (if (= name "*") 
                 (vla-delete d) 
               ) 
               (if (= (strcase (vla-get-name d)) (strcase name)) 
                 (vla-delete d) 
               ) 
             ) 
           ) 
           (if (vla-get-hasextensiondictionary obj) 
             (vlax-for d (vla-getextensiondictionary obj) 
               (if (= (vla-get-objectname d) "AcDbXrecord") 
                 (if (= name "*") 
                   (vla-delete d) 
                 ) 
                 (if (= (strcase (vla-get-name d)) (strcase name)) 
                   (vla-delete d) 
                 ) 
               ) 
             ) 
           ) 
         ) 
        ) 
      ) 
      (setq OLDS ($zi-dian-du-qu$ ent name NIL)) 
    ) 
  ) 
  OLDS 
)

树櫴希德 · 发表于 2025-9-28 22:08:53

(defun $zi-dian-xie-ru$
(ent name values lst /
_setxrecord alls dict dicts
list->vbarray news obj obj0
olds xd xlst xrec xt
)
;字典写入
;($zi-dian-xie-ru$(CAR (entsel)) "ZXCAD" '((1000 . "HELLO WORLD") (1070 . 1) (1040 . 1.0))nil)
(defun _setxrecord (obj lst)
(vla-setxrecorddata
obj
(list->vbarray (mapcar 'car lst) vlax-vbinteger)
(list->vbarray (mapcar 'cdr lst) vlax-vbvariant)
)
)
(defun list->vbarray (ptsList TYPE1 / arraySpace sArray)
(setq arraySpace
(vlax-make-safearray
TYPE1
(cons 0 (- (length ptsList) 1))
)
)
(setq sArray (vlax-safearray-fill arraySpace ptsList))
(vlax-make-variant sArray)
)
(if (and ent (= (type ent)) 'ename)
(setq obj0 (vlax-ename->vla-object ent))
)
(and obj0 (setq obj (VLA-GetExtensionDictionary obj0)))
(if (= (vla-get-objectname obj) "AcDbDictionary")
(progn
(vlax-for d obj
(if (and (= (vla-get-objectname d) "AcDbXrecord")
(= (strcase (vla-get-name d)) (strcase name))
)
(setq xrec d)
)
)
(if xrec
(progn
(vla-getxrecorddata xrec 'xt 'xd)
(if xt
(progn
(setq olds
(mapcar 'cons
(safearray-value xt)
(mapcar 'variant-value (safearray-value xd))
)
)
(setq
alls (vl-remove nil (append olds values))
)
(cond
((vl-position (cdr (assoc "模式" lst)) (list "追加"))
(setq news alls)
)
(t (setq news values))
)
(_setxrecord xrec news)
)
(_setxrecord xrec values)
)
)
(progn
(setq xrec (vla-addxrecord obj name))
(_setxrecord xrec values)
)
)
)
(if (= (vla-get-hasExtensionDictionary obj) :vlax-true)
(progn
(setq dicts (vla-GetExtensionDictionary obj))
(vlax-for dict dicts
(if (and (= (vla-get-objectname dict) "AcDbXrecord")
(= (strcase (vla-get-name dict)) (strcase name))
)
(setq xrec dict)
)
)
(if xrec
(progn
(vla-getxrecorddata xrec 'xt 'xd)
(_setxrecord
xrec
(append
(mapcar 'cons
(safearray-value xt)
(mapcar 'variant-value (safearray-value xd))
)
values
)
)
)
)
)
(progn
(setq dict (vla-getextensiondictionary obj)
xrec (vla-addxrecord dict name)
)
(_setxrecord xrec values)
)
)
)
($zi-dian-du-qu$ ent "*" nil)
)
(defun $zi-dian-du-qu$
(ent name lst / _getxrecord dicts e obj obj0 xd xt)
;字典读取
;($zi-dian-du-qu$(CAR (entsel)) "*" nil)
;($zi-dian-du-qu$(CAR (entsel)) "ZXCAD" nil)
(defun _getxrecord (dc / xt xd)
(if (= (vla-get-objectname dc) "AcDbXrecord")
(progn (vla-getxrecorddata dc 'xt 'xd)
(if (and xt xd)
(setq lst
(cons
(cons (vla-get-name dc)
(mapcar
'cons
(safearray-value xt)
(mapcar 'variant-value (safearray-value xd))
)
)
lst
)
)
(setq lst (cons (vla-get-name dc) lst))
)
)
)
)
(if (and ent (= (type ent)) 'ename)
(setq obj0 (vlax-ename->vla-object ent))
)
(and obj0 (setq obj (VLA-GetExtensionDictionary obj0)))
(if (= (vla-get-objectname obj) "AcDbDictionary")
(vlax-for dict obj (_getxrecord dict))
(if (= (vla-get-hasExtensionDictionary obj) :vlax-true)
(progn (setq dicts (vla-GetExtensionDictionary obj))
(vlax-for dict dicts (_getxrecord dict))
)
)
)
(if
(= name "*")
lst
(vl-remove-if-not
(function (lambda (x) (= (strcase (car x)) (strcase name))))
lst
)
)
)
(defun $zi-dian-shan-chu$
(ent name vars lst / E1 obj obj0 OLDS SS TF X)
;字典删除
;($zi-dian-shan-chu$(CAR (entsel)) "ZXCAD" '((1070 . 1) (1040 . 2.0)) nil)
(if (and ent (= (type ent)) 'ename)
(setq obj0 (vlax-ename->vla-object ent))
)
(and obj0 (setq obj (VLA-GetExtensionDictionary obj0)))
(if (setq OLDS ($zi-dian-du-qu$ ent name NIL))
(progn
(setq olds (cdr (assoc name OLDS)))
(COND
((AND obj name vars)
(setq OLDS (vl-remove-if
(function (lambda (a) (assoc (car a) vars)))
OLDS
)
)
(if OLDS
($zi-dian-xie-ru$ ent name OLDS lst)
)
)
(T
(if (= (vla-get-objectname obj) "AcDbDictionary")
(vlax-for d obj
(if (= (vla-get-objectname d) "AcDbXrecord")
(if (= name "*")
(vla-delete d)
)
(if (= (strcase (vla-get-name d)) (strcase name))
(vla-delete d)
)
)
)
(if (vla-get-hasextensiondictionary obj)
(vlax-for d (vla-getextensiondictionary obj)
(if (= (vla-get-objectname d) "AcDbXrecord")
(if (= name "*")
(vla-delete d)
)
(if (= (strcase (vla-get-name d)) (strcase name))
(vla-delete d)
)
)
)
)
)
)
)
(setq OLDS ($zi-dian-du-qu$ ent name NIL))
)
)
OLDS
)
;
(defun $objid>ent$ (objID / ent)
(if objID
(setq ent (vl-catch-all-apply
'vlax-vla-object->ename
(list
(vl-catch-all-apply
'vla-ObjectIdToObject
(list
(vla-get-activedocument (vlax-get-acad-object))
objID
)
)
)
)
)
)
(if (vl-catch-all-error-p ent)
(setq ent nil)
)
ent
)
;
(defun MKEn001 (insertpt jd / obj obj1 axErr basept insertpt axErr1 HatchobjAray ExplodeList objary objLay LineTypeErr objStyle entdata enMlStyle flag ACAD_MLINESTYLE osmode cmdecho filedia)
(setq osmode (getvar "osmode") cmdecho (getvar "cmdecho") filedia (getvar "filedia"))
(mapcar 'setvar '("osmode" "cmdecho" "filedia") '(0 0 0))
(setq basept '(0.000000000000000 0.000000000000000 0.000000000000000))
(setvar "osmode" 15359)
;(setq insertpt (getpoint "\选择插入基点<0,0,0>："))
(setvar "osmode" 0)
(if (null insertpt) (setq insertpt '(0 0 0)))
;;;******本函数代码由Gu_xl的自动Lisp代码生成器自动生成******
(cond ((not (TBLSEARCH "block" "yyy12345"))
(setvar "clayer" "0")
(setq obj (vla-add (vla-get-Blocks (vla-get-activedocument (vlax-get-acad-object))) (vlax-3d-point '(0 0 0)) "yyy12345"))
(vla-put-color (vla-item (vla-get-Layers (vla-get-activedocument (vlax-get-acad-object))) "0") "7")
(setvar "Clayer" "0")
(setvar "CeColor" "256")
(setq axErr (VL-CATCH-ALL-APPLY 'vla-load (list (vla-get-Linetypes (vla-get-activedocument (vlax-get-acad-object))) "ByLayer" "acadiso.lin")))
(if (VL-CATCH-ALL-ERROR-P axErr) (setq axErr (VL-CATCH-ALL-APPLY 'vla-load (list (vla-get-Linetypes (vla-get-activedocument (vlax-get-acad-object))) "ByLayer" "EstateCADTools.lin"))))
(if (not (VL-CATCH-ALL-ERROR-P axErr)) (setvar "CeLtype" "ByLayer"))
(setvar "CeLTScale" 8.00000000)
(setvar "CeLweight" -1)
(setq obj1 (vla-AddLightWeightPolyline obj (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray vlax-vbdouble (cons 1 28))'(-0.0144651222462674 -0.4053455131440885 -0.0145257768700013 -0.3825020637239967 0.0165568161537094 -0.3824195322748336 0.0166460323127025 -0.4160196882061602 0.0004574601199830 -0.4220542435516649 -0.1403521516702209 -0.4383852072630968 -0.1687346743282201 -0.4767672243487655 -0.1680778656339516 -0.7241313206464043 -0.1394919184126529 -0.7623620733130406 0.0014024322404991 -0.7779450480700849 0.0176228222128363 -0.7838935501506218 0.0177120383718294 -0.8174937060819484 -0.0133705546518813 -0.8175762375311116 -0.0134312092756151 -0.7947327881110198)))))
(vla-SetBulge obj1 5 0.3310486734302698)
(vla-SetBulge obj1 7 0.3310486734302700)
(vla-put-color (vla-item (vla-get-Layers (vla-get-activedocument (vlax-get-acad-object))) "0") "7")
(setvar "Clayer" "0")
(setvar "CeColor" "256")
(setq axErr (VL-CATCH-ALL-APPLY 'vla-load (list (vla-get-Linetypes (vla-get-activedocument (vlax-get-acad-object))) "ByLayer" "acadiso.lin")))
(if (VL-CATCH-ALL-ERROR-P axErr) (setq axErr (VL-CATCH-ALL-APPLY 'vla-load (list (vla-get-Linetypes (vla-get-activedocument (vlax-get-acad-object))) "ByLayer" "EstateCADTools.lin"))))
(if (not (VL-CATCH-ALL-ERROR-P axErr)) (setvar "CeLtype" "ByLayer"))
(setvar "CeLTScale" 8.00000000)
(setvar "CeLweight" -1)
(ENTMAKE '((0 . "SPLINE")(100 . "AcDbEntity")(67 . 0)(8 . "0")(48 . 8.000000000000000)(100 . "AcDbSpline")(210 0.000000000000000 0.000000000000000 1.000000000000000)(70 . 12)(71 . 2)(72 . 30)(73 . 27)(74 . 0)(42 . 0.0000000010000000)(43 . 0.0000000001000000)(40 . 0.000000000000000)(40 . 0.000000000000000)(40 . 0.000000000000000)(40 . 1.000000000000000)(40 . 1.000000000000000)(40 . 2.000000000000000)(40 . 2.000000000000000)(40 . 3.000000000000000)(40 . 3.000000000000000)(40 . 4.000000000000000)(40 . 4.000000000000000)(40 . 5.000000000000000)(40 . 5.000000000000000)(40 . 6.278771812875807)(40 . 6.278771812875807)(40 . 7.278771812875806)(40 . 7.278771812875806)(40 . 8.557543625767296)(40 . 8.557543625767296)(40 . 9.557543625767296)(40 . 9.557543625767296)(40 . 10.55754362576729)(40 . 10.55754362576729)(40 . 11.55754362576729)(40 . 11.55754362576729)(40 . 12.55754362576730)(40 . 12.55754362576730)(40 . 13.55754362576729)(40 . 13.55754362576729)(40 . 13.55754362576729)(10 0.0155553835746105 -0.0052643917728117 0.000000000000000)(41 . 1.000000000000000)(10 0.0155250562627468 0.0061573329360090 0.000000000000000)(41 . 1.000000000000000)(10 0.0154947289508831 0.0175790576448296 0.000000000000000)(41 . 1.000000000000000)(10 -0.0000465675342787 0.0175377919203188 0.000000000000000)(41 . 1.000000000000000)(10 -0.0155878640194405 0.0174965261958080 0.000000000000000)(41 . 1.000000000000000)(10 -0.0155432559399488 0.0006964482319469 0.000000000000000)(41 . 1.000000000000000)(10 -0.0154986478604570 -0.0161036297319142 0.000000000000000)(41 . 1.000000000000000)(10 -0.0073884528882055 -0.0190778807718981 0.000000000000000)(41 . 1.000000000000000)(10 0.0007217420840460 -0.0220521318118820 0.000000000000000)(41 . 1.000000000000000)(10 0.0711689172896572 -0.0298436191898695 0.000000000000000)(41 . 1.000000000000000)(10 0.1416160924952683 -0.0376351065678569 0.000000000000000)(41 . 1.000000000000000)(10 0.1701230638911251 -0.0461223743165809 0.000000000000000)(41 . 0.8024623404975734)(10 0.1702020396998372 -0.0758658592304283 0.000000000000000)(41 . 1.000000000000000)(10 0.1705304440147311 -0.1995479073660651 0.000000000000000)(41 . 1.000000000000000)(10 0.1708588483618303 -0.3232299555016165 0.000000000000000)(41 . 1.000000000000000)(10 0.1709378242027548 -0.3529734404158654 0.000000000000000)(41 . 0.8024623404928947)(10 0.1424763257449687 -0.3616119725574273 0.000000000000000)(41 . 1.000000000000000)(10 0.0720715199786027 -0.3697774544375848 0.000000000000000)(41 . 1.000000000000000)(10 0.0016667142044611 -0.3779429362921238 0.000000000000000)(41 . 1.000000000000000)(10 -0.0064275718779832 -0.3809602139645178 0.000000000000000)(41 . 1.000000000000000)(10 -0.0145218579604275 -0.3839774916369119 0.000000000000000)(41 . 1.000000000000000)(10 -0.0144772498809358 -0.4007775696007730 0.000000000000000)(41 . 1.000000000000000)(10 -0.0144326418014440 -0.4175776475646340 0.000000000000000)(41 . 1.000000000000000)(10 0.0011086546837179 -0.4175363818401233 0.000000000000000)(41 . 1.000000000000000)(10 0.0166499511688797 -0.4174951161156127 0.000000000000000)(41 . 1.000000000000000)(10 0.0166196238570160 -0.4060733914067920 0.000000000000000)(41 . 1.000000000000000)(10 0.0165892965451524 -0.3946516666979714 0.000000000000000)(41 . 1.000000000000000)))
(setq obj1 (vlax-ename->vla-object (entlast)))
(if (not (or (= (vla-get-name obj) "*Model_Space") (WCMATCH (vla-get-name obj) "*Paper_Space*")))
(progn
(setq objary (vla-CopyObjects (vla-get-ActiveDocument (vlax-get-acad-object)) (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray vlax-vbObject (cons 0 0)) (list obj1))) obj))
(vla-delete obj1)
(setq obj1 (car (vlax-safearray->list (vlax-variant-value objary))))
) ;_ progn
) ;_ if
)
)
(setq obj (vla-get-ModelSpace(vla-get-ActiveDocument (vlax-get-acad-object))))
(vla-put-color (vla-item (vla-get-Layers (vla-get-activedocument (vlax-get-acad-object))) "0") "7")
(setvar "Clayer" "0")
(setvar "CeColor" "256")
(setq axErr (VL-CATCH-ALL-APPLY 'vla-load (list (vla-get-Linetypes (vla-get-activedocument (vlax-get-acad-object))) "ByLayer" "acadiso.lin")))
(if (VL-CATCH-ALL-ERROR-P axErr) (setq axErr (VL-CATCH-ALL-APPLY 'vla-load (list (vla-get-Linetypes (vla-get-activedocument (vlax-get-acad-object))) "ByLayer" "EstateCADTools.lin"))))
(if (not (VL-CATCH-ALL-ERROR-P axErr)) (setvar "CeLtype" "ByLayer"))
(setvar "CeLTScale" 1.00000000)
(setvar "CeLweight" -1)
(entmake (list '(0 . "INSERT") (cons 2 "yyy12345") (cons 10 insertpt) (cons 50 (+ (/ pi 2) jd) ) ))
;(setq obj1 (vla-InsertBlock obj (vlax-3d-point '(0.000000000000000 0.000000000000000 0.000000000000000)) "yyy12345" 1.00000000 1.00000000 1.00000000 1.57079633))
;(vla-put-layer obj1 "0")
;(command "move" (entlast) "" basept insertpt)
(mapcar 'setvar '("osmode" "cmdecho" "filedia") (list osmode cmdecho filedia))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun vxs (e / i v lst ppp)
(setq i 0)
(while
(setq v (vlax-curve-getpointatparam e (setq i (1+ i))))
(setq lst (cons v lst))
)
(setq ppp (reverse lst) )
(append (list(vlax-curve-getpointatparam e 0)) ppp )
)
;;;;;;;;;;;;;;;;;;;;;
(defun bm1005 (c ent / jb )
(setq jb (cdr (assoc 5 (entget c))))
(regapp "ZXCAD");必须先注册一个app的名字
(princ)
)
;;;;
(defun bm10051 (ent-text ent-line / OBJ text-objid txt-jb)
;(setq jb (cdr (assoc 5 (entget c))))
(regapp "ZXCAD");必须先注册一个app的名字
;两个图元绑定，支持复制粘贴，绑定关系依然不变，试试下面这个代码
;(setq ent-text(car(entsel "请点击一个文字")))
;(setq ent-line(car(entsel "请点击一根直线")))
(setq obj(vlax-ename->vla-object ent-text))
(setq text-objid(vla-get-objectid obj));文字的objid
(setq txt-jb(cdr(assoc 5(entget ent-text))));文字句柄
($zi-dian-xie-ru$ ent-line "ZXCAD" (list(cons 330 txt-jb))nil);将文字的id写入到直线里面，当用户复制图纸的时候，绑定关系依然成立
;(vlax-safearray->list(cdr(assoc 330(cdr(assoc "ZXCAD"($zi-dian-du-qu$ (CAR (entsel)) "ZXCAD" nil))))));读取看看
;(entget(cdr(assoc 330(cdr(assoc "ZXCAD"($zi-dian-du-qu$ (CAR (entsel)) "ZXCAD" nil))))));读取看看
;(entget(cdr(assoc 330(entget(car(entsel))))))
($zi-dian-xie-ru$ ent-line "ZXCAD" (list(cons 330 txt-jb))nil)
(princ)
)
;;;;;
(defun c:gbz11 ( / cc p1 plst zbb juli jiaodu i )
(vl-load-com)
(setq cc (car(entsel "\n 请选择坡顶线：")))
(bm10051 cc cc)
(setq plst (vxs cc) )
(setq p1 nil)
(setq zbb (mapcar'list plst (cdr plst)) )
(foreach x zbb
(setq juli (distance (car x) (cadr x)))
(setq jiaodu (angle (car x) (cadr x) ))
(MKEn001 (car x) jiaodu )
;(bm1005 cc (entlast))
(bm10051 cc (entlast))
(setq i 0)
(repeat (fix ( / juli 0.8) )
(MKEn001 (polar (car x) jiaodu (* 0.8 (1+ i) )) jiaodu )
;(bm1005 cc (entlast))
(bm10051 cc (entlast))
(setq i (1+ i))
)
)
(princ)
)
;(MKEn001 (getpoint)(angle (getpoint)(getpoint)))
; (cdr(assoc 1005(cdr(car(cdr(assoc -3 (entget(car(entsel))'("*"))))))))
;选择对象: "691"
(defun c:300xz ( / cc ss sss i ent)
(setq cc (car(entsel "\n 请选择坡顶线：")))
(setq ss (ssget "x" '((0 . "insert")(2 . "yyy12345"))))
(setq i 0)(setq sss (ssadd))
(repeat (sslength ss)
(setq ent (ssname ss i))
(if (equal (vlax-safearray->list(cdr(assoc 330(cdr(assoc "ZXCAD"($zi-dian-du-qu$ ent "ZXCAD" nil))))))
(vlax-safearray->list(cdr(assoc 330(cdr(assoc "ZXCAD"($zi-dian-du-qu$ cc "ZXCAD" nil))))))
)
;(= (cdr(assoc 1005(cdr(car(cdr(assoc -3 (entget ent '("*")))))))) (cdr (assoc 5 (entget cc))) )
(ssadd ent sss)
)
(setq i (1+ i))
) (SSSETFIRST nil sss)
(princ)
)
;;;;
(defun c:1005xz ( / cc ss sss i ent)
(setq cc (car(entsel "\n 请选择坡顶线：")))
(setq ss (ssget "x" '((0 . "insert")(2 . "yyy12345"))))
(setq i 0)(setq sss (ssadd))
(repeat (sslength ss)
(setq ent (ssname ss i))
(if (= (cdr(assoc 1005(cdr(car(cdr(assoc -3 (entget ent '("*")))))))) (cdr (assoc 5 (entget cc))) )
(ssadd ent sss)
)
(setq i (1+ i))
) (SSSETFIRST nil sss)
(princ)
)

(defun $zi-dian-xie-ru$ 
                        (ent          name           values   lst             / 
                         _setxrecord           alls            dict     dicts 
                         list->vbarray           news            obj             obj0 
                         olds          xd           xlst            xrec     xt 
                        ) 
                                        ;字典写入 
                                        ;($zi-dian-xie-ru$(CAR (entsel))  "ZXCAD" '((1000 . "HELLO WORLD") (1070 . 1) (1040 . 1.0))nil) 
  (defun _setxrecord (obj lst) 
    (vla-setxrecorddata 
      obj 
      (list->vbarray (mapcar 'car lst) vlax-vbinteger) 
      (list->vbarray (mapcar 'cdr lst) vlax-vbvariant) 
    ) 
  ) 
  (defun list->vbarray (ptsList TYPE1 / arraySpace sArray) 
    (setq arraySpace 
           (vlax-make-safearray 
             TYPE1 
             (cons 0 (- (length ptsList) 1)) 
           ) 
    ) 
    (setq sArray (vlax-safearray-fill arraySpace ptsList)) 
    (vlax-make-variant sArray) 
  ) 
  (if (and ent (= (type ent)) 'ename) 
    (setq obj0 (vlax-ename->vla-object ent)) 
  ) 
  (and obj0 (setq obj (VLA-GetExtensionDictionary obj0))) 
  (if (= (vla-get-objectname obj) "AcDbDictionary") 
    (progn 
      (vlax-for        d obj 
        (if (and (= (vla-get-objectname d) "AcDbXrecord") 
                 (= (strcase (vla-get-name d)) (strcase name)) 
            ) 
          (setq xrec d) 
        ) 
      ) 
      (if xrec 
        (progn 
          (vla-getxrecorddata xrec 'xt 'xd) 
          (if xt 
            (progn 
              (setq olds 
                     (mapcar 'cons 
                             (safearray-value xt) 
                             (mapcar 'variant-value (safearray-value xd)) 
                     ) 
              ) 
              (setq 
                alls (vl-remove nil (append olds values)) 
              ) 
              (cond 
                ((vl-position (cdr (assoc "模式" lst)) (list "追加")) 
                 (setq news alls) 
                ) 
                (t (setq news values)) 
              ) 
              (_setxrecord xrec news) 
            ) 
            (_setxrecord xrec values) 
          ) 
        ) 
        (progn 
          (setq xrec (vla-addxrecord obj name)) 
          (_setxrecord xrec values) 
        ) 
      ) 
    ) 
    (if        (= (vla-get-hasExtensionDictionary obj) :vlax-true) 
      (progn 
        (setq dicts (vla-GetExtensionDictionary obj)) 
        (vlax-for dict dicts 
          (if (and (= (vla-get-objectname dict) "AcDbXrecord") 
                   (= (strcase (vla-get-name dict)) (strcase name)) 
              ) 
            (setq xrec dict) 
          ) 
        ) 
        (if xrec 
          (progn 
            (vla-getxrecorddata xrec 'xt 'xd) 
            (_setxrecord 
              xrec 
              (append 
                (mapcar        'cons 
                        (safearray-value xt) 
                        (mapcar 'variant-value (safearray-value xd)) 
                ) 
                values 
              ) 
            ) 
          ) 
        ) 
      ) 
      (progn 
        (setq dict (vla-getextensiondictionary obj) 
              xrec (vla-addxrecord dict name) 
        ) 
        (_setxrecord xrec values) 
      ) 
    ) 
  ) 
  ($zi-dian-du-qu$ ent "*" nil) 
) 
(defun $zi-dian-du-qu$ 
       (ent name lst / _getxrecord dicts e obj obj0 xd xt) 
                                        ;字典读取 
                                        ;($zi-dian-du-qu$(CAR (entsel))   "*"  nil) 
                                        ;($zi-dian-du-qu$(CAR (entsel))   "ZXCAD"  nil) 
  (defun _getxrecord (dc / xt xd) 
    (if        (= (vla-get-objectname dc) "AcDbXrecord") 
      (progn (vla-getxrecorddata dc 'xt 'xd) 
             (if (and xt xd) 
               (setq lst 
                      (cons 
                        (cons (vla-get-name dc) 
                              (mapcar 
                                'cons 
                                (safearray-value xt) 
                                (mapcar 'variant-value (safearray-value xd)) 
                              ) 
                        ) 
                        lst 
                      ) 
               ) 
               (setq lst (cons (vla-get-name dc) lst)) 
             ) 
      ) 
    ) 
  ) 
  (if (and ent (= (type ent)) 'ename) 
    (setq obj0 (vlax-ename->vla-object ent)) 
  ) 
  (and obj0 (setq obj (VLA-GetExtensionDictionary obj0))) 
  (if (= (vla-get-objectname obj) "AcDbDictionary") 
    (vlax-for dict obj (_getxrecord dict)) 
    (if        (= (vla-get-hasExtensionDictionary obj) :vlax-true) 
      (progn (setq dicts (vla-GetExtensionDictionary obj)) 
             (vlax-for dict dicts (_getxrecord dict)) 
      ) 
    ) 
  ) 
  (if 
    (= name "*") 
     lst 
     (vl-remove-if-not 
       (function (lambda (x) (= (strcase (car x)) (strcase name)))) 
       lst 
     ) 
  ) 
) 
(defun $zi-dian-shan-chu$ 
       (ent name vars lst / E1 obj obj0 OLDS SS TF X) 
                                        ;字典删除 
                                        ;($zi-dian-shan-chu$(CAR (entsel))   "ZXCAD" '((1070 . 1) (1040 . 2.0))  nil) 
  (if (and ent (= (type ent)) 'ename) 
    (setq obj0 (vlax-ename->vla-object ent)) 
  ) 
  (and obj0 (setq obj (VLA-GetExtensionDictionary obj0))) 
  (if (setq OLDS ($zi-dian-du-qu$ ent name NIL)) 
    (progn 
      (setq olds (cdr (assoc name OLDS))) 
      (COND 
        ((AND obj name vars) 
         (setq OLDS (vl-remove-if 
                      (function (lambda (a) (assoc (car a) vars))) 
                      OLDS 
                    ) 
         ) 
         (if OLDS 
           ($zi-dian-xie-ru$ ent name OLDS lst) 
         ) 
        ) 
        (T 
         (if (= (vla-get-objectname obj) "AcDbDictionary") 
           (vlax-for d obj 
             (if (= (vla-get-objectname d) "AcDbXrecord") 
               (if (= name "*") 
                 (vla-delete d) 
               ) 
               (if (= (strcase (vla-get-name d)) (strcase name)) 
                 (vla-delete d) 
               ) 
             ) 
           ) 
           (if (vla-get-hasextensiondictionary obj) 
             (vlax-for d (vla-getextensiondictionary obj) 
               (if (= (vla-get-objectname d) "AcDbXrecord") 
                 (if (= name "*") 
                   (vla-delete d) 
                 ) 
                 (if (= (strcase (vla-get-name d)) (strcase name)) 
                   (vla-delete d) 
                 ) 
               ) 
             ) 
           ) 
         ) 
        ) 
      ) 
      (setq OLDS ($zi-dian-du-qu$ ent name NIL)) 
    ) 
  ) 
  OLDS 
) 
; 
(defun $objid>ent$ (objID / ent) 
  (if objID 
    (setq ent (vl-catch-all-apply 
                'vlax-vla-object->ename 
                (list 
                  (vl-catch-all-apply 
                    'vla-ObjectIdToObject 
                    (list 
                      (vla-get-activedocument (vlax-get-acad-object)) 
                      objID 
                    ) 
                  ) 
                ) 
              ) 
    ) 
  ) 
  (if (vl-catch-all-error-p ent) 
    (setq ent nil) 
  ) 
  ent 
) 
; 
 
  (defun MKEn001 (insertpt jd / obj obj1 axErr basept insertpt axErr1 HatchobjAray ExplodeList objary objLay LineTypeErr objStyle entdata enMlStyle flag ACAD_MLINESTYLE osmode cmdecho filedia) 
    (setq osmode (getvar "osmode") cmdecho (getvar "cmdecho") filedia (getvar "filedia")) 
    (mapcar 'setvar '("osmode" "cmdecho" "filedia") '(0 0 0)) 
    (setq basept '(0.000000000000000 0.000000000000000 0.000000000000000)) 
  (setvar "osmode" 15359) 
    ;(setq insertpt (getpoint "\选择插入基点<0,0,0>：")) 
  (setvar "osmode" 0) 
    (if (null insertpt) (setq insertpt '(0 0 0))) 
 ;;;******本函数代码由Gu_xl的自动Lisp代码生成器自动生成****** 
   (cond ((not (TBLSEARCH "block" "yyy12345")) 
   (setvar "clayer" "0") 
   (setq obj (vla-add (vla-get-Blocks (vla-get-activedocument (vlax-get-acad-object))) (vlax-3d-point '(0 0 0)) "yyy12345")) 
   (vla-put-color (vla-item (vla-get-Layers (vla-get-activedocument (vlax-get-acad-object))) "0") "7") 
   (setvar "Clayer" "0") 
   (setvar "CeColor" "256") 
   (setq axErr (VL-CATCH-ALL-APPLY 'vla-load (list (vla-get-Linetypes (vla-get-activedocument (vlax-get-acad-object))) "ByLayer" "acadiso.lin"))) 
   (if (VL-CATCH-ALL-ERROR-P axErr) (setq axErr (VL-CATCH-ALL-APPLY 'vla-load (list (vla-get-Linetypes (vla-get-activedocument (vlax-get-acad-object))) "ByLayer" "EstateCADTools.lin")))) 
   (if (not (VL-CATCH-ALL-ERROR-P axErr)) (setvar "CeLtype" "ByLayer")) 
   (setvar "CeLTScale" 8.00000000) 
   (setvar "CeLweight" -1) 
   (setq obj1 (vla-AddLightWeightPolyline obj (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray vlax-vbdouble (cons 1 28))'(-0.0144651222462674 -0.4053455131440885 -0.0145257768700013 -0.3825020637239967 0.0165568161537094 -0.3824195322748336 0.0166460323127025 -0.4160196882061602 0.0004574601199830 -0.4220542435516649 -0.1403521516702209 -0.4383852072630968 -0.1687346743282201 -0.4767672243487655 -0.1680778656339516 -0.7241313206464043 -0.1394919184126529 -0.7623620733130406 0.0014024322404991 -0.7779450480700849 0.0176228222128363 -0.7838935501506218 0.0177120383718294 -0.8174937060819484 -0.0133705546518813 -0.8175762375311116 -0.0134312092756151 -0.7947327881110198))))) 
  (vla-SetBulge obj1 5 0.3310486734302698) 
  (vla-SetBulge obj1 7 0.3310486734302700) 
   (vla-put-color (vla-item (vla-get-Layers (vla-get-activedocument (vlax-get-acad-object))) "0") "7") 
   (setvar "Clayer" "0") 
   (setvar "CeColor" "256") 
   (setq axErr (VL-CATCH-ALL-APPLY 'vla-load (list (vla-get-Linetypes (vla-get-activedocument (vlax-get-acad-object))) "ByLayer" "acadiso.lin"))) 
   (if (VL-CATCH-ALL-ERROR-P axErr) (setq axErr (VL-CATCH-ALL-APPLY 'vla-load (list (vla-get-Linetypes (vla-get-activedocument (vlax-get-acad-object))) "ByLayer" "EstateCADTools.lin")))) 
   (if (not (VL-CATCH-ALL-ERROR-P axErr)) (setvar "CeLtype" "ByLayer")) 
   (setvar "CeLTScale" 8.00000000) 
   (setvar "CeLweight" -1) 
   (ENTMAKE  '((0 . "SPLINE")(100 . "AcDbEntity")(67 . 0)(8 . "0")(48 . 8.000000000000000)(100 . "AcDbSpline")(210 0.000000000000000 0.000000000000000 1.000000000000000)(70 . 12)(71 . 2)(72 . 30)(73 . 27)(74 . 0)(42 . 0.0000000010000000)(43 . 0.0000000001000000)(40 . 0.000000000000000)(40 . 0.000000000000000)(40 . 0.000000000000000)(40 . 1.000000000000000)(40 . 1.000000000000000)(40 . 2.000000000000000)(40 . 2.000000000000000)(40 . 3.000000000000000)(40 . 3.000000000000000)(40 . 4.000000000000000)(40 . 4.000000000000000)(40 . 5.000000000000000)(40 . 5.000000000000000)(40 . 6.278771812875807)(40 . 6.278771812875807)(40 . 7.278771812875806)(40 . 7.278771812875806)(40 . 8.557543625767296)(40 . 8.557543625767296)(40 . 9.557543625767296)(40 . 9.557543625767296)(40 . 10.55754362576729)(40 . 10.55754362576729)(40 . 11.55754362576729)(40 . 11.55754362576729)(40 . 12.55754362576730)(40 . 12.55754362576730)(40 . 13.55754362576729)(40 . 13.55754362576729)(40 . 13.55754362576729)(10 0.0155553835746105 -0.0052643917728117 0.000000000000000)(41 . 1.000000000000000)(10 0.0155250562627468 0.0061573329360090 0.000000000000000)(41 . 1.000000000000000)(10 0.0154947289508831 0.0175790576448296 0.000000000000000)(41 . 1.000000000000000)(10 -0.0000465675342787 0.0175377919203188 0.000000000000000)(41 . 1.000000000000000)(10 -0.0155878640194405 0.0174965261958080 0.000000000000000)(41 . 1.000000000000000)(10 -0.0155432559399488 0.0006964482319469 0.000000000000000)(41 . 1.000000000000000)(10 -0.0154986478604570 -0.0161036297319142 0.000000000000000)(41 . 1.000000000000000)(10 -0.0073884528882055 -0.0190778807718981 0.000000000000000)(41 . 1.000000000000000)(10 0.0007217420840460 -0.0220521318118820 0.000000000000000)(41 . 1.000000000000000)(10 0.0711689172896572 -0.0298436191898695 0.000000000000000)(41 . 1.000000000000000)(10 0.1416160924952683 -0.0376351065678569 0.000000000000000)(41 . 1.000000000000000)(10 0.1701230638911251 -0.0461223743165809 0.000000000000000)(41 . 0.8024623404975734)(10 0.1702020396998372 -0.0758658592304283 0.000000000000000)(41 . 1.000000000000000)(10 0.1705304440147311 -0.1995479073660651 0.000000000000000)(41 . 1.000000000000000)(10 0.1708588483618303 -0.3232299555016165 0.000000000000000)(41 . 1.000000000000000)(10 0.1709378242027548 -0.3529734404158654 0.000000000000000)(41 . 0.8024623404928947)(10 0.1424763257449687 -0.3616119725574273 0.000000000000000)(41 . 1.000000000000000)(10 0.0720715199786027 -0.3697774544375848 0.000000000000000)(41 . 1.000000000000000)(10 0.0016667142044611 -0.3779429362921238 0.000000000000000)(41 . 1.000000000000000)(10 -0.0064275718779832 -0.3809602139645178 0.000000000000000)(41 . 1.000000000000000)(10 -0.0145218579604275 -0.3839774916369119 0.000000000000000)(41 . 1.000000000000000)(10 -0.0144772498809358 -0.4007775696007730 0.000000000000000)(41 . 1.000000000000000)(10 -0.0144326418014440 -0.4175776475646340 0.000000000000000)(41 . 1.000000000000000)(10 0.0011086546837179 -0.4175363818401233 0.000000000000000)(41 . 1.000000000000000)(10 0.0166499511688797 -0.4174951161156127 0.000000000000000)(41 . 1.000000000000000)(10 0.0166196238570160 -0.4060733914067920 0.000000000000000)(41 . 1.000000000000000)(10 0.0165892965451524 -0.3946516666979714 0.000000000000000)(41 . 1.000000000000000))) 
   (setq obj1 (vlax-ename->vla-object (entlast))) 
(if (not (or (= (vla-get-name obj) "*Model_Space") (WCMATCH (vla-get-name obj) "*Paper_Space*"))) 
    (progn 
   (setq objary (vla-CopyObjects (vla-get-ActiveDocument (vlax-get-acad-object)) (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray vlax-vbObject (cons 0 0)) (list obj1))) obj)) 
   (vla-delete obj1) 
    (setq obj1 (car (vlax-safearray->list (vlax-variant-value objary)))) 
   ) ;_ progn 
  ) ;_ if 
   ) 
  ) 
   (setq obj (vla-get-ModelSpace(vla-get-ActiveDocument (vlax-get-acad-object)))) 
   (vla-put-color (vla-item (vla-get-Layers (vla-get-activedocument (vlax-get-acad-object))) "0") "7") 
   (setvar "Clayer" "0") 
   (setvar "CeColor" "256") 
   (setq axErr (VL-CATCH-ALL-APPLY 'vla-load (list (vla-get-Linetypes (vla-get-activedocument (vlax-get-acad-object))) "ByLayer" "acadiso.lin"))) 
   (if (VL-CATCH-ALL-ERROR-P axErr) (setq axErr (VL-CATCH-ALL-APPLY 'vla-load (list (vla-get-Linetypes (vla-get-activedocument (vlax-get-acad-object))) "ByLayer" "EstateCADTools.lin")))) 
   (if (not (VL-CATCH-ALL-ERROR-P axErr)) (setvar "CeLtype" "ByLayer")) 
   (setvar "CeLTScale" 1.00000000) 
   (setvar "CeLweight" -1) 
    (entmake (list '(0 . "INSERT") (cons 2 "yyy12345") (cons 10 insertpt)  (cons 50   (+ (/ pi 2) jd) )  )) 
   ;(setq obj1 (vla-InsertBlock obj (vlax-3d-point '(0.000000000000000 0.000000000000000 0.000000000000000)) "yyy12345" 1.00000000 1.00000000 1.00000000 1.57079633)) 
    ;(vla-put-layer obj1 "0") 
    ;(command "move" (entlast) "" basept insertpt) 
    (mapcar 'setvar '("osmode" "cmdecho" "filedia") (list osmode cmdecho filedia)) 
  ) 
 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
(defun vxs (e / i v lst ppp) 
  (setq i 0) 
  (while 
    (setq v (vlax-curve-getpointatparam e (setq i (1+ i)))) 
     (setq lst (cons v lst)) 
  ) 
  (setq ppp (reverse lst) ) 
(append (list(vlax-curve-getpointatparam e 0)) ppp ) 
   
  ) 
;;;;;;;;;;;;;;;;;;;;; 
(defun bm1005 (c ent / jb ) 
(setq jb (cdr (assoc 5 (entget c)))) 
(regapp "ZXCAD");必须先注册一个app的名字 
 
 
 
   
(princ) 
 
) 
;;;; 
(defun bm10051 (ent-text ent-line /  OBJ text-objid txt-jb) 
;(setq jb (cdr (assoc 5 (entget c)))) 
(regapp "ZXCAD");必须先注册一个app的名字 
;两个图元绑定，支持复制粘贴，绑定关系依然不变，试试下面这个代码 
;(setq ent-text(car(entsel "请点击一个文字"))) 
;(setq ent-line(car(entsel "请点击一根直线"))) 
(setq obj(vlax-ename->vla-object ent-text)) 
(setq text-objid(vla-get-objectid obj));文字的objid 
(setq txt-jb(cdr(assoc 5(entget ent-text))));文字句柄 
($zi-dian-xie-ru$ ent-line  "ZXCAD" (list(cons 330 txt-jb))nil);将文字的id写入到直线里面，当用户复制图纸的时候，绑定关系依然成立 
;(vlax-safearray->list(cdr(assoc 330(cdr(assoc "ZXCAD"($zi-dian-du-qu$ (CAR (entsel))   "ZXCAD"  nil))))));读取看看 
;(entget(cdr(assoc 330(cdr(assoc "ZXCAD"($zi-dian-du-qu$ (CAR (entsel))   "ZXCAD"  nil))))));读取看看 
 
  ;(entget(cdr(assoc 330(entget(car(entsel)))))) 
($zi-dian-xie-ru$ ent-line  "ZXCAD" (list(cons 330 txt-jb))nil) 
 
   
(princ) 
 
) 
;;;;; 
(defun c:gbz11 ( / cc p1 plst zbb juli jiaodu i ) 
(vl-load-com) 
  (setq cc (car(entsel "\n 请选择坡顶线："))) 
  (bm10051 cc cc) 
(setq plst (vxs cc) ) 
(setq p1 nil) 
(setq zbb (mapcar'list plst (cdr plst)) ) 
(foreach x zbb 
     (setq juli (distance (car x) (cadr x))) 
     (setq jiaodu (angle (car x) (cadr x) )) 
    (MKEn001  (car x) jiaodu ) 
  ;(bm1005 cc (entlast)) 
  (bm10051 cc (entlast)) 
(setq i 0) 
  (repeat   (fix ( / juli 0.8) ) 
   (MKEn001 (polar (car x) jiaodu (* 0.8 (1+ i) ))  jiaodu ) 
    ;(bm1005 cc (entlast)) 
    (bm10051 cc (entlast)) 
(setq i (1+ i)) 
    ) 
   
  ) 
(princ) 
) 
 
 
 
 
 
;(MKEn001  (getpoint)(angle (getpoint)(getpoint))) 
 
; (cdr(assoc 1005(cdr(car(cdr(assoc -3 (entget(car(entsel))'("*")))))))) 
;选择对象: "691" 
(defun c:300xz  ( / cc ss sss i ent) 
(setq cc (car(entsel "\n 请选择坡顶线："))) 
(setq ss (ssget "x" '((0 . "insert")(2 . "yyy12345")))) 
 
(setq  i 0)(setq sss (ssadd)) 
(repeat  (sslength ss) 
    (setq ent (ssname ss i)) 
    (if  (equal (vlax-safearray->list(cdr(assoc 330(cdr(assoc "ZXCAD"($zi-dian-du-qu$ ent   "ZXCAD"  nil)))))) 
      (vlax-safearray->list(cdr(assoc 330(cdr(assoc "ZXCAD"($zi-dian-du-qu$ cc   "ZXCAD"  nil)))))) 
      ) 
 
 
      ;(= (cdr(assoc 1005(cdr(car(cdr(assoc -3 (entget ent '("*")))))))) (cdr (assoc 5 (entget cc))) ) 
     (ssadd  ent sss) 
      ) 
(setq i (1+ i)) 
 
  ) (SSSETFIRST nil sss) 
  (princ) 
       ) 
;;;; 
(defun c:1005xz  ( / cc ss sss i ent) 
(setq cc (car(entsel "\n 请选择坡顶线："))) 
(setq ss (ssget "x" '((0 . "insert")(2 . "yyy12345")))) 
 
(setq  i 0)(setq sss (ssadd)) 
(repeat  (sslength ss) 
    (setq ent (ssname ss i)) 
    (if  (= (cdr(assoc 1005(cdr(car(cdr(assoc -3 (entget ent '("*")))))))) (cdr (assoc 5 (entget cc))) ) 
     (ssadd  ent sss) 
      ) 
(setq i (1+ i)) 
 
  ) (SSSETFIRST nil sss) 
  (princ) 
       )

dcl1214 · 发表于 2025-6-2 10:06:50

本帖最后由 dcl1214 于 2025-6-6 21:52 编辑

(defun $objid>ent$ (objID / ent)
(if objID
(setq ent (vl-catch-all-apply
'vlax-vla-object->ename
(list
(vl-catch-all-apply
'vla-ObjectIdToObject
(list
(vla-get-activedocument (vlax-get-acad-object))
objID
)
)
)
)
)
)
(if (vl-catch-all-error-p ent)
(setq ent nil)
)
ent
)

q3_2006 · 发表于 2025-9-25 12:20:00

dcl1214 发表于 2025-6-2 10:06

(defun SetXrecord2 (txt zx name / dict satypes savalues vlaen vtobject vttypes vtvalues xrcd)
;(setq txt (car (entsel "\n点取文字:")))
;(setq zx (car (entsel "\n点取直线:")))
(setq vlaen (vlax-ename->vla-object txt))
(setq dict (vla-GetExtensionDictionary vlaen))
(setq saTypes (vlax-make-safearray vlax-vbInteger '(0 . 0)))
(vlax-safearray-fill saTypes (list 331))
(setq vtTypes (vlax-make-variant saTypes))
(setq saValues (vlax-make-safearray vlax-vbVariant '(0 . 0)))
(setq vtObject (vlax-make-variant (cdr (assoc 5 (entget zx)))))
(vlax-safearray-fill saValues (list vtObject))
(setq vtValues (vlax-make-variant saValues))
(setq xrcd (vla-AddXRecord dict name))
(vla-SetXRecordData xrcd vtTypes vtValues)
)
;(setq e1 (get-dict-ename-entget (car (entsel "\n点取文字")) "00"))
(defun get-dict-ename-entget (txt key / en xrec-ent xrec-handle xx);
  (setq en (cdr (assoc 360 (entget txt))))
  (setq xrec-handle (cdr (assoc -1 (dictsearch en key))))
  (setq xrec-ent (entget xrec-handle))
  (setq xx (cdr (assoc 331 xrec-ent))) ; 返回ENAME
)
这样写应该也能达到目的

664571221 · 发表于 2025-6-1 15:01:38

强哥这么厉害吗，大佬你厉害还是强哥厉害.

czb203 · 发表于 2025-6-1 17:00:10

大佬介绍下怎么使用呀

Bao_lai · 发表于 2025-6-1 21:27:25

增删读，改？

dcl1214 · 发表于 2025-6-1 23:58:30

本帖最后由 dcl1214 于 2025-6-6 21:51 编辑

两个图元绑定，支持复制粘贴，绑定关系依然不变，试试下面这个代码

(setq ent-text(car(entsel "请点击一个文字")))
(setq ent-line(car(entsel "请点击一根直线")))
(setq obj(vlax-ename->vla-object ent-text))
(setq text-objid(vla-get-objectid obj));文字的objid
(setq txt-jb(cdr(assoc 5(entget ent-text))));文字句柄
($zi-dian-xie-ru$ ent-line "ZXCAD" (list(cons 330 txt-jb))nil);将文字的id写入到直线里面，当用户复制图纸的时候，绑定关系依然成立
(cdr(assoc 330(cdr(assoc "ZXCAD"($zi-dian-du-qu$ (CAR (entsel)) "ZXCAD" nil)))));读取看看

czb203 · 发表于 2025-6-3 17:10:15

大佬介绍下运用场景~

黄翔 · 发表于 2025-6-4 12:16:10

dcl1214 发表于 2025-6-1 23:58

(cdr(assoc 330(cdr(assoc "ZXCAD"($zi-dian-du-qu$ (CAR (entsel)) "ZXCAD" nil)))));读取看看
读取了,是个安全数组.vlax-safearray->list 解析了是个表.如何返回实体的objectID啊.

xudongchu · 发表于 2025-6-5 08:46:50

有错误~~~~~

qwsss31 · 发表于 2025-6-5 08:59:06

就这么完事调试了可以啊

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

字典操作

评分

本帖子中包含更多资源

本帖子中包含更多资源

浏览过的版块