[编程交流] 需要AutoLisp例程

(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))