[编程交流] 在Ca中输入数据需要Lisp

;; local defun
;; entmake block
(defun makepoint  ()
 (if (not (tblsearch "BLOCK" "POINT_ELEV"))
   (progn
     (initget 6)
     (setq hgt (getreal "\n  Enter text height of attribute <2.5>: "))
     (if (not hgt)
(setq hgt 2.5))
     (entmake
(mapcar        'cons
        (list 0 8 2 70 10 3)
        (list "BLOCK" "0" "POINT_ELEV" 2 '(0 0 0) "POINT_ELEV")))
     (entmake
(mapcar        'cons
        (list 0 8 62 10 210 50)
        (list "POINT" "0" 0 (list 0 0 0) '(0 0 1) 0.0)))
     (entmake
(mapcar        'cons
        (list 0 8 62 10 40 70 1 210 3 2)
        (list "ATTDEF"
              "0"
              0
              (list (/ hgt 2) (* hgt 2.5) 0)
              2.5
              9
              "x"
              '(0 0 1)
              "Topo point X coordinate"
              "XCOORD")))
     (entmake
(mapcar        'cons
        (list 0 8 62 10 40 70 1 210 3 2)
        (list "ATTDEF"
              "0"
              0
              (list (/ hgt 2) (* hgt 1.5) 0)
              2.5
              9
              "y"
              '(0 0 1)
              "Topo point Y coordinate"
              "YCOORD")))
     (entmake
(mapcar        'cons
        (list 0 8 62 10 40 70 1 210 3 2)
        (list "ATTDEF"
              "0"
              6
              (list (/ hgt 2) (/ hgt 2) 0)
              2.5
              8
              "z"
              '(0 0 1)
              "Topo point Z coordinate"
              "ZCOORD")))
     (entmake
(mapcar        'cons
        (list 0 
        (list "ENDBLK" "0"))))))
;; main programm
(defun C:PP  (/ att_tag ent new_value next next_data osm point_list)
 (makepoint)
 (if (not (tblsearch "BLOCK" "POINT_ELEV"))
   (progn
     (alert "Something wrong\nprogramm stopped")
     (exit)
     (princ)))
 (setq osm (getvar "osmode"))
 (setvar "cmdecho" 0)
 (setvar "osmode" 0)
 (setq        point_list
 (list
   '(17 20 2.5)        '(21 24 3.4) '(25 28 4.3) '(29 32 5.2) '(33 36 2.5) '(37 40 3.4)))
 (foreach point  point_list
   (command "._-insert" "POINT_ELEV" point 1 1 0)
   (setq ent (entlast))
   (setq next ent)
   (while (setq next (entnext next))
     (setq next_data (entget next))
     (setq att_tag (cdr (assoc 2 next_data)))
     (cond
((eq (strcase "XCOORD") att_tag)
 (setq new_value (rtos (car point) 2 1)))
((eq (strcase "YCOORD") att_tag)
 (setq new_value (rtos (cadr point) 2 1)))
((eq (strcase "ZCOORD") att_tag)
 (setq new_value (rtos (caddr point) 2 1))))
     (entmod
(subst (cons 1 new_value) (assoc 1 next_data) next_data))
     (entupd ent)
     )
   )
 (command "._zoom" "_e");by suit
 (setvar "osmode" osm)
 (setvar "cmdecho" 1)
 (princ)
 )
;; TesT : (C:PP)
(prompt "\n====================================\n")
(prompt "\n\t>>>\tType PP to execute ... \t>>>\n")
(prompt "\n====================================\n")
(prin1)

;; PP.lsp
;; read Excel, draw points in Acad as blocks with attributes
;; local defun
;; entmake block
(defun makepoint  ()
 (if (not (tblsearch "BLOCK" "POINT_ELEV"))
   (progn
     (initget 6)
     (setq hgt (getreal "\n  Enter text height of attribute <2.5>: "))
     (if (not hgt)
(setq hgt 2.5))
     (entmake
(mapcar        'cons
        (list 0 8 2 70 10 3)
        (list "BLOCK" "0" "POINT_ELEV" 2 '(0 0 0) "POINT_ELEV")))
     (entmake
(mapcar        'cons
        (list 0 8 62 10 210 50)
        (list "POINT" "0" 0 (list 0 0 0) '(0 0 1) 0.0)))
     (entmake
(mapcar        'cons
        (list 0 8 62 10 40 70 1 210 3 2)
        (list "ATTDEF"
              "0"
              0
              (list (/ hgt 2) (* hgt 2.5) 0)
              2.5
              9
              "x"
              '(0 0 1)
              "Topo point X coordinate"
              "XCOORD")))
     (entmake
(mapcar        'cons
        (list 0 8 62 10 40 70 1 210 3 2)
        (list "ATTDEF"
              "0"
              0
              (list (/ hgt 2) (* hgt 1.5) 0)
              2.5
              9
              "y"
              '(0 0 1)
              "Topo point Y coordinate"
              "YCOORD")))
     (entmake
(mapcar        'cons
        (list 0 8 62 10 40 70 1 210 3 2)
        (list "ATTDEF"
              "0"
              6
              (list (/ hgt 2) (/ hgt 2) 0)
              2.5
              8
              "z"
              '(0 0 1)
              "Topo point Z coordinate"
              "ZCOORD")))
     (entmake
(mapcar        'cons
        (list 0 
        (list "ENDBLK" "0"))))))
;; local defun
;; to read the Excel range
(defun EXR  (FilePath ShtNum StrRange /        ExcelApp ExcData Sht UsdRange Wbk)
;; based on function "EXD" from this page:
;; http://www.cadforyou.spb.ru/index.php?current_section=section_functions_page
 (vl-load-com)
 (setq ExcelApp (vlax-get-or-create-object "Excel.Application"))
 (vla-put-visible ExcelApp :vlax-true)                  ; or :vlax-false if you want
 (vlax-put-property ExcelApp 'DisplayAlerts :vlax-false)
 (setq        Wbk (vl-catch-all-apply
      'vla-open
      (list (vlax-get-property ExcelApp "WorkBooks") FilePath)
      )
)
 (setq        Sht (vl-catch-all-apply
      'vlax-get-property
      (list (vlax-get-property Wbk "Sheets")
            "Item"
            ShtNum
            )
      )
)
 (vlax-invoke-method Sht "Activate")
 
 (setq        UsdRange (vlax-get-property
           (vlax-get-property Sht 'Cells)
           "Range"
           StrRange)
ExcData         (vlax-safearray->list
           (vlax-variant-value
             (vlax-get-property UsdRange 'Value2)
             )
           )
)
 (setq
   ExcData (mapcar
      (function (lambda (x) (mapcar 'vlax-variant-value x)))
      ExcData
      )
   )
 (vl-catch-all-apply
   'vlax-invoke-method
   (list Wbk "Close")
   )
 (vl-catch-all-apply
   'vlax-invoke-method
   (list ExcelApp "Quit")
   )
 (mapcar
   (function
     (lambda (x)
(vl-catch-all-apply
  (function (lambda ()
              (progn
                (if (not (vlax-object-released-p x))
                  (progn
                    (vlax-release-object x)
                    (setq x nil)
                    )
                  )
                )
              )
            )
  )
)
     )
   (list UsdRange Sht Wbk ExcelApp)
   )
 (gc)
 (gc)
 ExcData
 )
;;      main part       ;;
(defun C:PP  (/        Att_Tag        Ent Filepath Headflag New_Value        Next Next_Data
      Osm Poinlist Response Shtnum Strrange)
 (or (vl-load-com))
 (setq        FilePath (getfiled "Select Excel file to read :"
                   (getvar "dwgprefix")
                   "xls"
                   16
                   )
)
 (initget 6)
 (setq ShtNum (getint "\nEnter the sheet number <1> : "))
 (if (not ShtNum)
   (setq ShtNum 1))
 (setq        strRange (strcase
           (getstring "\n  Enter address of used range <A1:C99>: ")))
 (if (eq "" strRange)
   (setq strRange "A1:C99"))
 (initget "Yes No")
 (setq        Response (getkword
           "\n   Is the Excel table has the headers? (Y/N) <Y>: "))
 (if (not Response)
   (setq Response "Yes"))
 (if (eq "Yes" Response)
   (setq HeadFlag T)
   (setq HeadFlag nil))
 
 (setq PoinList (EXR FilePath ShtNum strRange))
 (if HeadFlag
   (setq PoinList (cdr PoinList)))
 
 (if PoinList
   (progn
     (makepoint)
     (if (not (tblsearch "BLOCK" "POINT_ELEV"))
(progn
  (alert "Something wrong\nprogramm stopped")
  (exit)
  (princ)))
     (setq osm (getvar "osmode"))
     (setvar "cmdecho" 0)
     (setvar "osmode" 0)
     (foreach point  PoinList
(command "._-insert" "POINT_ELEV" point 1 1 0)
(setq ent (entlast))
(setq next ent)
(while (setq next (entnext next))
  (setq next_data (entget next))
  (setq att_tag (cdr (assoc 2 next_data)))
  (cond
    ((eq (strcase "XCOORD") att_tag)
     (setq new_value (rtos (car point) 2 1)))
    ((eq (strcase "YCOORD") att_tag)
     (setq new_value (rtos (cadr point) 2 1)))
    ((eq (strcase "ZCOORD") att_tag)
     (setq new_value (rtos (caddr point) 2 1))))
  (entmod
    (subst (cons 1 new_value) (assoc 1 next_data) next_data))
  (entupd ent)
  )
)
     (command "._zoom" "_e");by suit
     )
   (alert "Trouble with reading Excel data")
   )
 (setvar "osmode" osm)
 (setvar "cmdecho" 1)
 (princ)
 )
;; TesT : (C:PP)
(prompt "\n====================================\n")
(prompt "\n\t>>>\tType PP to execute ... \t>>>\n")
(prompt "\n====================================\n")
(prin1)