[编程交流] 带d的力层平移

(defun c:survey_transform ()
   ; First construct our entity list
   (setq vl1 (list
       (cons 0 "LAYER")        ;Name of entity
       (cons 100 "AcDbSymbolTableRecord")                    ;Open Records
       (cons 100 "AcDbLayerTableRecord")                    ;Locate Layer Table
       (cons 2 "CCC_SURVEY_EXISTING_Feature")                ;Name of Layer
       (cons 6 "Continuous")                        ;Linetype
       (cons 62 150)                            ;colour = light grey
       (cons 70 0)                            ;state
       (cons 290 1)                            ;1=plot, 0=Don't plot
           )                            ;End of entity list
       )
       (entmake vl1)
   (setq vl1 (list
       (cons 0 "LAYER")        ;Name of entity
       (cons 100 "AcDbSymbolTableRecord")                    ;Open Records
       (cons 100 "AcDbLayerTableRecord")                    ;Locate Layer Table
       (cons 2 "CCC_SURVEY_EXISTING_Number")                ;Name of Layer
       (cons 6 "Continuous")                        ;Linetype
       (cons 62 1)                            ;colour = light grey
       (cons 70 0)                            ;state
       (cons 290 1)                            ;1=plot, 0=Don't plot
           )                            ;End of entity list
       )
       (entmake vl1)
   (setq vl1 (list
       (cons 0 "LAYER")        ;Name of entity
       (cons 100 "AcDbSymbolTableRecord")                    ;Open Records
       (cons 100 "AcDbLayerTableRecord")                    ;Locate Layer Table
       (cons 2 "CCC_SURVEY_EXISTING_Level")                ;Name of Layer
       (cons 6 "Continuous")                        ;Linetype
       (cons 62 84)                            ;colour = light grey
       (cons 70 0)                            ;state
       (cons 290 1)                            ;1=plot, 0=Don't plot
           )                            ;End of entity list
       )
       (entmake vl1)
   (setq vl1 (list
       (cons 0 "LAYER")        ;Name of entity
       (cons 100 "AcDbSymbolTableRecord")                    ;Open Records
       (cons 100 "AcDbLayerTableRecord")                    ;Locate Layer Table
       (cons 2 "CCC_SURVEY_Level")                    ;Name of Layer
       (cons 6 "Continuous")                        ;Linetype
       (cons 62 84)                            ;colour = light grey
       (cons 70 0)                            ;state
       (cons 290 1)                            ;1=plot, 0=Don't plot
           )                            ;End of entity list
       )
       (entmake vl1)
   (setq vl1 (list
       (cons 0 "LAYER")        ;Name of entity
       (cons 100 "AcDbSymbolTableRecord")                    ;Open Records
       (cons 100 "AcDbLayerTableRecord")                    ;Locate Layer Table
       (cons 2 "CCC_SURVEY_Number")                    ;Name of Layer
       (cons 6 "Continuous")                        ;Linetype
       (cons 62 1)                            ;colour = light grey
       (cons 70 0)                            ;state
       (cons 290 1)                            ;1=plot, 0=Don't plot
           )                            ;End of entity list
       )
       (entmake vl1)
   ; First construct our entity list
   (setq vl1 (list
       (cons 0 "LAYER")        ;Name of entity
       (cons 100 "AcDbSymbolTableRecord")                    ;Open Records
       (cons 100 "AcDbLayerTableRecord")                    ;Locate Layer Table
       (cons 2 "CCC_SURVEY_Feature")            ;Name of Layer
       (cons 6 "Continuous")                        ;Linetype
       (cons 62 150)                            ;colour = light grey
       (cons 70 0)                            ;state
       (cons 290 1)                            ;1=plot, 0=Don't plot
           )                            ;End of entity list
       )
       (entmake vl1)
(and (setq ss (ssget "X" '((8 . "*CODE")))) 
    (command "_.CHPROP" ss "" "_LA" "CCC_SURVEY_EXISTING_Feature" ""))
(and (setq ss (ssget "X" '((8 . "*ID")))) 
    (command "_.CHPROP" ss "" "_LA" "CCC_SURVEY_EXISTING_Number" ""))
(and (setq ss (ssget "X" '((8 . "*_Z")))) 
    (command "_.CHPROP" ss "" "_LA" "CCC_SURVEY_EXISTING_Level" ""))
(and (setq ss (ssget "X" '((8 . "*Points")))) 
    (command "_.CHPROP" ss "" "_LA" "CCC_SURVEY_EXISTING_Level" ""))
(and (setq text1(ssget "x" (list '(0 . "TEXT") (cons 62 70))))
   (command "_.CHPROP" TEXT1 "" "_LA" "CCC_SURVEY_Level" ""))
(and (setq text2(ssget "x" (list '(0 . "TEXT") (cons 62 12))))
   (command "_.CHPROP" TEXT2 "" "_LA" "CCC_SURVEY_Number" ""))    
(and (setq text3(ssget "x" (list '(0 . "TEXT") (cons 62 152))))
   (command "_.CHPROP" TEXT3 "" "_LA" "CCC_SURVEY_Feature" ""))
(and (setq ss (ssget "X" (list (cons 0 "INSERT") (cons 62 70))))
    (command "_.CHPROP" ss "" "_LA" "CCC_SURVEY_Level" ""))
(and (setq ss (ssget "X" (list (cons 0 "INSERT") (cons 62 12))))
    (command "_.CHPROP" ss "" "_LA" "CCC_SURVEY_Number" ""))
(and (setq ss (ssget "X" (list (cons 0 "INSERT") (cons 62 152))))
    (command "_.CHPROP" ss "" "_LA" "CCC_SURVEY_Feature" ""))
(command "_.CHPROP" "all" "" "C" "BYLAYER" "")
(command "_.-layer" "_C" "84" "CCC_SURVEY_Level" "_C" "150" "CCC_SURVEY_Feature" "" )
(ImportLayers "T:\\Drawing Tools\\AutoCad 2010_WARNING_Do Not Modify\\CCC_Survey.dwt" T T)
(command "_-purge" "a" "*" "N")
(princ)
)
;;; -------------------------------------------------------------------------------------
;;; Global var to hold last used source drawing
;;; -------------------------------------------------------------------------------------
(setq *ImportLayersFrom* "T:\\Drawing Tools\\AutoCad 2010_WARNING_Do Not Modify\\CCC_Survey.dwt")
;;; -------------------------------------------------------------------------------------
;;; Command to match the current drawing's layers to a specified DWG file
;;; -------------------------------------------------------------------------------------
(defun ImportLayers (/ ans fn update import)
;(setq *ImportLayersFrom* "T:\\Drawing Tools\\AutoCad 2010_WARNING_Do Not Modify\\CCC_Survey.dwt")
 (if (not (setq fn *ImportLayersFrom*))
   (setq fn (if (and (= (getvar "FILEDIA") 1) (= (logand (getvar "CMDACTIVE") 4) 0))
              (getfiled "Select source drawing" (getvar "DWGPREFIX") "dwg" (+ 4 8 16))
              (getstring "\nSource DWG path: ")
            )
   )
 )
 (if (setq fn (findfile fn))
   (progn
     (setq *ImportLayersFrom* fn)
     (princ (strcat "\nLoading from Source: " fn))
     (while (progn
              (princ (strcat "\nExisting layers will"
                             (if update
                               ""
                               " NOT"
                             )
                             " be Updated; Linetypes will"
                             (if import
                               ""
                               " NOT"
                             )
                             " be Improted"
                     )
              )
              (initget "Source Update Import Run Cancel")
              (and (setq ans (getkword "\n[source/Update/Import/Run/Cancel] <Run>: "))
                   (not (wcmatch ans "Run,Cancel"))
              )
            )
       (cond
         ((eq ans "Update") (setq update (not update)))
         ((eq ans "Import") (setq import (not import)))
         ((and (eq ans "Source")
               (setq fn (if (and (= (getvar "FILEDIA") 1) (= (logand (getvar "CMDACTIVE") 4) 0))
                          (getfiled "Select source drawing" (vl-filename-directory fn) "dwg" (+ 4 8 16))
                          (getstring "\nSource DWG path: ")
                        )
               )
          )
          (if (setq fn (findfile fn))
            (setq *ImportLayersFrom* fn)
            (progn
              (print (strcat fn " could not be found."))
              (setq fn *ImportLayersFrom*)
            )
          )
         )
       )
     )
     (if (not (eq ans "Cancel"))
       (ImportLayers fn update import)
     )
   )
 )
 (princ)
)
;;; -------------------------------------------------------------------------------------
;;; Function to match the current drawing's layers to a specified DWG file
;;; -------------------------------------------------------------------------------------
;;; Arguments:
;;; fn     : File name (incl. path) of source DWG
;;; update : T to change existing layer to match, else nil
;;; ltypes : T to import linetypes if not existing, else nil
;;; -------------------------------------------------------------------------------------
;;; Result : T if done, nil if failed
;;; -------------------------------------------------------------------------------------
(defun ImportLayers (fn update ltypes / dbx1 complete dbxLayers dbxLay Lay val)
 (setq complete nil)
 (if (setq dbx (vla-GetInterfaceObject
                 (vlax-get-acad-object)
                 (strcat "ObjectDBX.AxDbDocument." (itoa (atoi (getvar "ACADVER"))))
               )
     )
   (progn
     (if (not
           (vl-catch-all-error-p (vl-catch-all-apply 'vlax-invoke (list dbx 'open fn)))
         )
       (progn
         ;; Ensure all vla objects for current dwg
         (or *acad* (setq *acad* (vlax-get-acad-object)))
         (or *doc* (setq *doc* (vla-get-ActiveDocument *acad*)))
         (or *layers* (setq *layers* (vla-get-Layers *doc*)))
         (or *linetypes* (setq *linetypes* (vla-get-LineTypes *doc*)))
         ;; Step through all layers of source dwg
         (setq dbxLayers (vla-get-Layers dbx))
         (vlax-for dbxLay dbxLayers
           (if (vl-catch-all-error-p
                 (setq Lay (vl-catch-all-apply 'vla-Item (list *layers* (vla-get-Name dbxLay))))
               )
             (setq Lay (vla-Add *layers* (vla-get-Name dbxLay))) ;Create if not existing
             (if (not update)
               (setq Lay nil)
             ) ;Only continue if updating layers as well
           )
           (if Lay
             (progn
               ;; Match description
               (if (not
                     (vl-catch-all-error-p (setq val (vl-catch-all-apply 'vla-get-Description (list dbxLay))))
                   )
                 (vla-put-Description Lay val)
               )
               ;; Match Plottable
               (if (not
                     (vl-catch-all-error-p (setq val (vl-catch-all-apply 'vla-get-Plottable (list dbxLay))))
                   )
                 (vla-put-Plottable Lay val)
               )
               ;; Match ViewportDefault
               (if (not
                     (vl-catch-all-error-p
                       (setq val (vl-catch-all-apply 'vla-get-ViewportDefault (list dbxLay)))
                     )
                   )
                 (vla-put-ViewportDefault Lay val)
               )
               ;; Match LineWeight
               (if (not
                     (vl-catch-all-error-p (setq val (vl-catch-all-apply 'vla-get-LineWeight (list dbxLay))))
                   )
                 (vla-put-LineWeight Lay val)
               )
               ;; Match colour
               (if (not
                     (vl-catch-all-error-p (setq val (vl-catch-all-apply 'vla-get-TrueColor (list dbxLay))))
                   )
                 (vla-put-TrueColor Lay val)
               )
               ;; Match linetype
               (if (not
                     (vl-catch-all-error-p (setq val (vl-catch-all-apply 'vla-get-LineType (list dbxLay))))
                   )
                 (if (or (tblsearch "LTYPE" val)
                         (and ltypes ;Load linetype if not existing
                              (not (vl-catch-all-error-p
                                     (vl-catch-all-apply
                                       'vla-Load
                                       (list *linetypes*
                                             val
                                             (if (= (getvar "MEASUREMENT") 0)
                                               "acad.lin"
                                               "acadiso.lin"
                                             )
                                       )
                                     )
                                   )
                              )
                         )
                     )
                   (vla-put-LineType Lay val)
                 )
               )
             )
           )
         )
         (setq complete T)
       )
     )
     (vlax-release-object dbx)
   )
 )
 complete
)

Command: survey_transform
Initializing...
Initializing...
Initializing...
Initializing...
Initializing...
Initializing...
Initializing...
Initializing...
Initializing...
Initializing...
Initializing...
Initializing...

7

8