AutoCAD attribute özelliklerini excelde listeleme lispi - Metraj Lispi

Ekranda bir attribute tıklıyorsunuz, o attributelere ait bütün özellikleri ekcelde listeler

Autocad lisp kodlar

(defun c:ATT-EXCELDE-LISTELE (/ AtR Books EbL ExB ExceLApp ExCeLLs myerr n NewBook olderr PaT
               PvT rn Sheet1 Sheets sTn sTr VaL)
  (defun myerr (errmsg)
    (if (/= errmsg "\nFunction cancelled") (prompt (strcat "\n" errmsg)))
    (command "._undo" "_e") (command "._U") (setq *error* olderr) (princ))
  (setvar "cmdecho" 0) (command "undo" "group") (vl-load-com) (princ "\n")
  (setq olderr *error* *error* myerr) (*push-error-using-command*)
  (while (not ExB) (princ "\r Attribute Export edilecek Block'u seçiniz.")
    (setq ExB (ssget ":s" (list (cons 0 "INSERT")))
          ExB (cdr (assoc 2 (entget (ssname ExB 0)))))
    (if (/= (cdr(assoc 70 (entget(tblobjname "Block" ExB)))) 2)(setq ExB nil)))
  (setq ExceLApp (vlax-get-or-create-object "Excel.Application"))
  (if (setq NewBook (vlax-get-property ExceLApp "ActiveWorkbook"))
    (setq Books  (vlax-get-property ExceLApp "Workbooks")
          Sheets (vlax-get-property NewBook "Sheets")
          Sheet1 (vlax-invoke-method Sheets "Add"))
    (setq Books   (vlax-get-property ExceLApp "Workbooks")
          NewBook (vlax-invoke-method Books "Add")
          Sheets  (vlax-get-property NewBook "Sheets")
          Sheet1  (vlax-get-property Sheets "Item" 1)))
  (setq ExCeLLs (vlax-get-property Sheet1 "Cells"))
  (vlax-put-property ExceLApp "UseSystemSeparators" :vlax-false)
  (vlax-put-property ExceLApp "DecimalSeparator" ".")
  (vlax-put-property ExceLApp "ThousandsSeparator" " ")
  (vla-put-visible ExceLApp :vlax-true)
  (setq PvT (tblobjname "Block" ExB) sTn 0 sTr 1)
  (while (setq PvT (entnext PvT))
    (if (= (cdr (assoc 0 (entget PvT))) "ATTDEF") 
      (progn (setq sTn (1+ sTn)
                   AtR (append AtR (list (cdr (assoc 2 (entget PvT))))))
     (vlax-put-property ExCeLLs "Item" sTr sTn (cdr (assoc 3 (entget PvT)))))))
  (setq EbL (ssget "x" (list (cons 0 "INSERT") (cons 2 ExB))) n -1)
  (while (< (setq n (1+ n)) (sslength EbL))
    (setq sTr (1+ sTr) PvT (ssname EbL n))
    (while (= "ATTRIB" (cdr (assoc 0 (entget (setq PvT (entnext PvT))))))
      (setq PaT (cdr (assoc 2 (entget PvT))) VaL (cdr (assoc 1 (entget PvT))))
      (vlax-put-property ExCeLLs "Item" sTr (1+ (vl-position Pat AtR)) VaL)))
  (setq rn (vlax-get-property ExCeLLs "Range"
             (vlax-variant-value (vlax-get-property ExCeLLs 'Item 1 1))
             (vlax-variant-value (vlax-get-property ExCeLLs 'Item sTr sTn))))
  (vlax-invoke-method (vlax-get-property rn 'Columns) 'AutoFit)
  (vlax-invoke-method (vlax-get-property rn 'Rows) 'AutoFit)
  (vlax-put-property (vlax-get-property rn 'Borders) 'Color
    (vlax-make-variant "0.0"))
  (vlax-put-property (vlax-get-property rn 'Borders) 'LineStyle 
    (vlax-make-variant "1"))
  (vlax-put-property ExcelApp "UseSystemSeparators" :vlax-true)
  (mapcar 'vlax-release-object 
          (list rn ExCeLLs Sheet1 Sheets NewBook Books ExcelApp))
  (setq ExcelApp nil) (gc) (gc)
  (command "_.undo" "end") (setq *error* olderr) (*pop-error-mode*) (prin1))

Lisp dosyasını oluşturmayı ve AutoCAD"e yüklemeyi bilmiyorsanız. Lispi bilgisayara kaydetmek ve AutoCAD"e yüklemek için AutoCAD lisp dosyasını kaydetme ve yükleme nasıl yapılır yazısını okuyun