(defun c:Contact (/ *error* lst2str dcl_write ATT1 ATT2 DCTAG DESTTAGLST ELST1
ELST2 ENT1 ENT2 OFILE PTR SOURCETAG TAG TLST UFLAG)
(vl-load-com)
;; Lee Mac~04.02.10
(setq SourceTag "RDN" DestTagLst '("RDN1" "RDN2"))
(setq *doc (cond (*doc) ((vla-get-ActiveDocument
(vlax-get-acad-object)))))
(defun *error* (msg)
(and uFlag (vla-EndUndoMark *doc))
(and ofile (close ofile))
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
(princ (strcat "\n** Error: " msg " **")))
(princ))
(defun lst2str (lst sep)
(if (cdr lst)
(strcat (car lst) sep (lst2str (cdr lst) sep))
(car lst)))
(defun dcl_write (fname / wPath ofile)
(if (not (findfile fname))
(if (setq wPath (findfile "ACAD.PAT"))
(progn
(setq wPath (vl-filename-directory wPath))
(or (eq "\\" (substr wPath (strlen wPath)))
(setq wPath (strcat wPath "\\")))
(setq ofile (open (strcat wPath fname) "w"))
(foreach str '("fldtag : dialog { label = \"Choose Tag\";"
"spacer; : list_box { key = \"tags\"; }"
"spacer;ok_cancel; }")
(write-line str ofile))
(setq ofile (close ofile)) t) nil) t))
(while
(progn
(setq ent1 (nentsel (strcat "\nSelect Block or Attrib to get " SourceTag ": ")))
(cond ((eq 'ENAME (type (car ent1)))
(if (or (and (eq "ATTRIB"(cdr (assoc 0 (setq eLst1 (entget (car ent1))))))
(eq SourceTag (strcase (cdr (assoc 2 eLst1))))
(setq att1 (vlax-ename->vla-object (car ent1))))
(and (= 4 (length ent1))
(eq "INSERT" (cdr (assoc 0 (entget (setq ent1 (car (last ent1)))))))
(= 1 (cdr (assoc 66 (entget ent1))))
(progn
(while (not (eq "SEQEND" (cdr (assoc 0 (entget (setq ent1 (entnext ent1)))))))
(if (eq SourceTag (strcase (cdr (assoc 2 (entget ent1)))))
(setq att1 (vlax-ename->vla-object ent1))))
att1)))
(while
(progn
(setq ent2 (nentsel (strcat "\nSelect Destination Attrib for " SourceTag ": ")))
(cond ((eq 'ENAME (type (car ent2)))
(if (or (and (eq "ATTRIB" (cdr (assoc 0 (setq eLst2 (entget (car ent2))))))
(vl-position (strcase (cdr (assoc 2 eLst2))) DestTagLst)
(setq att2 (vlax-ename->vla-object (car ent2))))
(and (= 4 (length ent2))
(eq "INSERT" (cdr (assoc 0 (entget (setq ent2 (car (last ent2)))))))
(= 1 (cdr (assoc 66 (entget ent2))))
(progn
(while (not (eq "SEQEND" (cdr (assoc 0 (entget (setq ent2 (entnext ent2)))))))
(if (vl-position (setq tag (strcase (cdr (assoc 2 (entget ent2))))) DestTagLst)
(setq tLst (cons (cons tag ent2) tLst))))
(if tLst
(if (< 1 (length tLst))
(if (dcl_write "LMAC_Contact.dcl")
(cond ((<= (setq dcTag (load_dialog "LMAC_Contact.dcl")) 0)
(princ "\n** Error Loading Dialog **"))
((not (new_dialog "fldtag" dcTag))
(princ "\n** Error Loading Dialog **"))
(t
(setq ptr "0")
(start_list "tags")
(mapcar (function add_list)
(mapcar (function car) tLst))
(end_list)
(action_tile "tags" "(setq ptr $value)")
(action_tile "accept" "(done_dialog)")
(action_tile "cancel" "(setq ptr nil) (done_dialog)")
(start_dialog)
(unload_dialog dcTag)
(if ptr
(setq att2 (vlax-ename->vla-object
(cdr (nth (read ptr) tLst))))))))
(setq att2 (vlax-ename->vla-object (cdar tLst))))
(princ (strcat "\n** ATTRIB Must be Either " (lst2str DestTagLst ",") " **")))
(setq tLst nil)
att2)))
(progn
(setq uFlag (not (vla-StartUndoMark *doc)))
(vla-put-TextString att2
(strcat "%<\\AcObjProp Object(%<\\_ObjId "
(itoa
(vla-get-ObjectId att1)) ">%).TextString>%"))
(vla-update att2)
(setq uFlag (vla-EndUndoMark *doc)))
(princ "\n** Object Must be an INSERT or ATTRIB **"))))))
(princ (strcat "\n** Object Must be an INSERT or ATTRIB with Tag \"" SourceTag "\" **")))))))
(vla-regen *doc acActiveViewport)
(princ))
好啊太可怕了！！！！！就是这个。我欠你几品脱。（和其他许多人一起……干杯！）
不客气，我很喜欢写
页:
1
[2]