412 lines
13 KiB
Common Lisp
412 lines
13 KiB
Common Lisp
; ---------------------------------------------------------------------------- ;
|
|
; RevitDwgImportCleaner.lsp ;
|
|
; ---------------------------------------------------------------------------- ;
|
|
|
|
; Use this script to clean bad quality dwgs before importing tham to Revit.
|
|
; Just drag the script to the autocad window.
|
|
; The script automatically starts after loading, no command needed.
|
|
|
|
; Version 1.6
|
|
; Created by Peter Gyetvai
|
|
; gyetpet@mailbox.org
|
|
; git repo: https://git.gyetpet.dynu.net/infeeeee/revitDwgImportCleaner
|
|
|
|
; ---------------------------------------------------------------------------- ;
|
|
; FUNCTIONS ;
|
|
; ---------------------------------------------------------------------------- ;
|
|
|
|
; ------------------------ XREFS: bind and detach all ------------------------ ;
|
|
(defun bindXrefs (/ ss really blk blklist xrefpath xreflist)
|
|
(vl-load-com)
|
|
(graphscr)
|
|
|
|
;; Check if there are inserts at all
|
|
(setq ss (ssget "_A" '((0 . "INSERT") (410 . "MODEL"))))
|
|
|
|
(if ss
|
|
(progn
|
|
;; Select all blocks and xrefs in model space
|
|
(foreach x
|
|
(mapcar 'cadr (ssnamex (ssget "_X" '((0 . "INSERT") (410 . "MODEL")))))
|
|
(setq blk (cdr (assoc 2 (entget x))))
|
|
(setq blklist (append blklist (list blk)))
|
|
)
|
|
|
|
;; Clean duplicates
|
|
(setq blklist (LM:Unique blklist))
|
|
|
|
(initget 1 "Yes No")
|
|
(setq really (getkword "Bind xrefs? [Yes/No]"))
|
|
(if
|
|
(= really "Yes")
|
|
(progn
|
|
(setq i 0);counter to zero
|
|
(setq imax 1);while variable
|
|
(while imax
|
|
|
|
;; (command "_.-xref" "_bind" (nth i xreflist))
|
|
(command "_.-xref" "_bind" (nth i blklist))
|
|
|
|
(setq i (1+ i));increments i
|
|
;; (if (= i (length xreflist)) (setq imax nil));finish function if i equals il
|
|
(if (= i (length blklist)) (setq imax nil));finish function if i equals il
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(defun LM:Unique ( l )
|
|
(if l (cons (car l) (LM:Unique (vl-remove (car l) (cdr l)))))
|
|
)
|
|
|
|
; ----------- deleteAllXlines.lsp: deletes all xlines in modelspace ---------- ;
|
|
(defun dax (/ ss)
|
|
(graphscr)
|
|
(setq ss (ssget "_A" '((0 . "XLINE"))))
|
|
(if ss
|
|
(command "._erase" ss "")
|
|
)
|
|
(princ)
|
|
)
|
|
|
|
; ------------- deleteAllPoints: deletes all points in modelspace ------------ ;
|
|
(defun dap (/ ss)
|
|
(graphscr)
|
|
(setq ss (ssget "_A" '((0 . "POINT"))))
|
|
(if ss
|
|
(command "._erase" ss "")
|
|
)
|
|
(princ)
|
|
)
|
|
|
|
; ------------------- rxl.lsp: removes xlines from blocks: ------------------- ;
|
|
(defun rxl (/ b d l lo nl x)
|
|
;; RJP - 04.30.2018
|
|
;; Deletes xlines within block definitions
|
|
(vlax-for a (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))
|
|
(if (= 0 (vlax-get a 'islayout))
|
|
(vlax-for b a
|
|
(if (and (vlax-write-enabled-p b) (= "AcDbXline" (vla-get-objectname b)))
|
|
(vl-catch-all-apply 'vla-delete (list b))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(princ)
|
|
)(vl-load-com)
|
|
|
|
; ----------------- sepHatch.lsp: Move hatches to new layers ----------------- ;
|
|
(defun sephatch (/ ss i il imax currElem layerName newLayerName layerSettings newLayerSettings newLayer newElem)
|
|
(graphscr)
|
|
(setq ss (ssget "_A" '((0 . "HATCH"))))
|
|
(if ss
|
|
(progn
|
|
(setq il (sslength ss));length of selection
|
|
(setq i 0);counter to zero
|
|
(setq imax 1);while variable
|
|
(while imax
|
|
(setq currElem (entget (ssname ss i) ))
|
|
(setq layerName (cdr (assoc 8 currElem)))
|
|
(setq newLayerName (strcat layerName "-hatch"))
|
|
(command "._-layer" "_M" newLayerName "")
|
|
(setq layerSettings (entget (tblobjname "LAYER" layerName)))
|
|
(setq newLayerSettings (entget (tblobjname "LAYER" newLayerName)))
|
|
(setq newLayer (subst (cons 62 (cdr (assoc 62 layerSettings))) (assoc 62 newLayerSettings) newLayerSettings))
|
|
(setq newLayer (subst (cons 70 (cdr (assoc 70 layerSettings))) (assoc 70 newLayer) newLayer))
|
|
(entmod newLayer)
|
|
(setq newElem(subst (cons 8 newLayerName) (assoc 8 currElem) currElem))
|
|
(entmod newElem)
|
|
(setq i (1+ i));increments i
|
|
(if (= i il) (setq imax nil));finish function if i equals il
|
|
)
|
|
)
|
|
)
|
|
(princ)
|
|
)
|
|
|
|
; ------------------------------- AttDef2Text: ------------------------------- ;
|
|
; Attribute definitions to txt by Lee Mac.
|
|
; Source: https://www.cadtutor.net/forum/topic/21700-convert-attribute-definition-to-text/
|
|
|
|
(defun cAttDef2Text ( / ss )
|
|
;; © Lee Mac ~ 01.06.10
|
|
(vl-load-com)
|
|
(if (setq ss (ssget "_A" '((0 . "ATTDEF"))))
|
|
(
|
|
(lambda ( i / e o )
|
|
(while (setq e (ssname ss (setq i (1+ i))))
|
|
(if
|
|
(
|
|
(if (and (vlax-property-available-p
|
|
(setq o (vlax-ename->vla-object e)) 'MTextAttribute)
|
|
(eq :vlax-true (vla-get-MTextAttribute o)))
|
|
MAttDef2MText AttDef2Text
|
|
)
|
|
(entget e)
|
|
)
|
|
(entdel e)
|
|
)
|
|
)
|
|
)
|
|
-1
|
|
)
|
|
)
|
|
(princ)
|
|
)
|
|
(defun AttDef2Text ( eLst / dx74 dx2 )
|
|
;; © Lee Mac ~ 01.06.10
|
|
(setq dx74 (cdr (assoc 74 eLst)) dx2 (cdr (assoc 2 eLst)))
|
|
(entmake
|
|
(append '( (0 . "TEXT") ) (RemovePairs '(0 100 1 2 3 73 74 70 280) eLst)
|
|
(list
|
|
(cons 73 dx74)
|
|
(cons 1 dx2)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(defun MAttDef2MText ( eLst )
|
|
;; © Lee Mac ~ 01.06.10
|
|
(entmake
|
|
(append '( (0 . "MTEXT") (100 . "AcDbEntity") (100 . "AcDbMText") )
|
|
(RemoveFirstPairs '(40 50 41 7 71 72 71 72 73 10 11 11 210)
|
|
(RemovePairs '(-1 102 330 360 5 0 100 101 1 2 3 42 43 51 74 70 280) eLst)
|
|
)
|
|
(list (cons 1 (cdr (assoc 2 eLst))))
|
|
)
|
|
)
|
|
)
|
|
(defun RemoveFirstPairs ( pairs lst )
|
|
;; © Lee Mac
|
|
(defun foo ( pair lst )
|
|
(if lst
|
|
(if (eq pair (caar lst))
|
|
(cdr lst)
|
|
(cons (car lst) (foo pair (cdr lst)))
|
|
)
|
|
)
|
|
)
|
|
(foreach pair pairs
|
|
(setq lst (foo pair lst))
|
|
)
|
|
lst
|
|
)
|
|
(defun RemovePairs ( pairs lst )
|
|
;; © Lee Mac
|
|
(vl-remove-if
|
|
(function
|
|
(lambda ( pair )
|
|
(vl-position (car pair) pairs)
|
|
)
|
|
)
|
|
lst
|
|
)
|
|
)
|
|
|
|
; --------------------------------- unitCheck -------------------------------- ;
|
|
;Check units with measurement, change if wrong
|
|
(defun unitcheck (/ setunits selectioncycling currunit domeasure testdist dochange newunit newunitnum)
|
|
(setq setunits (getvar "insunits"))
|
|
(setq selectioncycling (getvar "selectioncycling"))
|
|
|
|
(cond
|
|
((= setunits 0) (setq currunit "no units"))
|
|
((= setunits 1) (setq currunit "Inches"))
|
|
((= setunits 2) (setq currunit "Feet"))
|
|
((= setunits 3) (setq currunit "Miles"))
|
|
((= setunits 4) (setq currunit "Millimeters"))
|
|
((= setunits 5) (setq currunit "Centimeters"))
|
|
((= setunits 6) (setq currunit "Meters"))
|
|
((= setunits 7) (setq currunit "Kilometers"))
|
|
((= setunits 8) (setq currunit "Microinches"))
|
|
((= setunits 9) (setq currunit "Mils"))
|
|
((= setunits 10) (setq currunit "Yards"))
|
|
((= setunits 11) (setq currunit "Angstroms"))
|
|
((= setunits 12) (setq currunit "Nanometers"))
|
|
((= setunits 13) (setq currunit "Microns"))
|
|
((= setunits 14) (setq currunit "Decimeters"))
|
|
((= setunits 15) (setq currunit "Dekameters"))
|
|
((= setunits 16) (setq currunit "Hectometers"))
|
|
((= setunits 17) (setq currunit "Gigameters"))
|
|
((= setunits 18) (setq currunit "Astronomical Units"))
|
|
((= setunits 19) (setq currunit "Light Years"))
|
|
((= setunits 20) (setq currunit "Parsecs"))
|
|
((= setunits 21) (setq currunit "US Survey Feet"))
|
|
)
|
|
|
|
(initget 1 "Accept Verify")
|
|
(setq domeasure (getkword (strcat "Current units: " currunit " \n[Accept/Verify]")))
|
|
(princ domeasure)
|
|
|
|
(if
|
|
(= domeasure "Verify")
|
|
(progn
|
|
(setvar "selectioncycling" 0)
|
|
(setq testdist (getdist "\nMeasure now"))
|
|
(setvar "selectioncycling" selectioncycling)
|
|
|
|
(initget 1 "Yes No")
|
|
(setq dochange (getkword (strcat "Measurement: " (rtos testdist) " " currunit "\nAccept? [Yes/No]")))
|
|
(if
|
|
(= dochange "No")
|
|
(progn
|
|
(initget 1 "Inches Feet Millimeters Centimeters Decimeters Meters")
|
|
(setq newunit (getkword "Select new unit: [Inches/Feet/Millimeters/Centimeters/Decimeters/Meters]"))
|
|
|
|
(cond
|
|
((= newunit "Inches") (setq newunitnum 1))
|
|
((= newunit "Feet") (setq newunitnum 2))
|
|
((= newunit "Millimeters") (setq newunitnum 4))
|
|
((= newunit "Centimeters") (setq newunitnum 5))
|
|
((= newunit "Decimeters") (setq newunitnum 14))
|
|
((= newunit "Meters") (setq newunitnum 6))
|
|
)
|
|
(setvar "insunits" newunitnum)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(princ)
|
|
)
|
|
|
|
; -------------------------------- moveOrigin -------------------------------- ;
|
|
|
|
(defun moveOrigin (/ move wcs setCurrUcs newOrigin)
|
|
(vl-load-com)
|
|
(graphscr)
|
|
|
|
(initget 1 "Yes No")
|
|
(setq move (getkword "Move origin? [Yes/No]"))
|
|
(if
|
|
(= move "Yes")
|
|
(progn
|
|
(setq wcs (getvar "worlducs"))
|
|
(if
|
|
(= wcs 0)
|
|
(progn
|
|
;; it's not WCS
|
|
(initget 1 "UCS Pick")
|
|
(setq setCurrUcs (getkword "Set current UCS or pick point [UCS/Pick]"))
|
|
(if
|
|
(= setCurrUcs "UCS")
|
|
(progn
|
|
(setq newOrigin (trans '(0.0 0.0 0.0) 1 0))
|
|
(command "._UCS" "W")
|
|
(moveDrawing newOrigin)
|
|
)
|
|
(progn
|
|
;; Pick point selected
|
|
(command "._UCS" "W")
|
|
(pickPoint)
|
|
)
|
|
)
|
|
)
|
|
;;it's wcs:
|
|
(pickPoint)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(defun pickPoint ()
|
|
(setq newOrigin (getpoint "\nPick new origin"))
|
|
;; (print newOrigin)
|
|
(moveDrawing newOrigin)
|
|
)
|
|
|
|
(defun moveDrawing (point / ssX coords)
|
|
(setq ssX (ssget "x"))
|
|
(setq coords (strcat (rtos (car point) 2) "," (rtos (cadr point) 2)))
|
|
|
|
(command "move" ssX "" coords "0,0")
|
|
)
|
|
|
|
; ------------------------------- deleteLayouts ------------------------------ ;
|
|
(defun deleteLayouts ()
|
|
(vl-load-com)
|
|
(graphscr)
|
|
|
|
(initget 1 "Yes No")
|
|
(setq really (getkword "Delete all layouts? [Yes/No]"))
|
|
(if
|
|
(= really "Yes")
|
|
(vlax-for l (vla-get-layouts (vla-get-activedocument (vlax-get-acad-object)))
|
|
(if (/= (vla-get-name l) "Model")
|
|
(vla-delete l)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
; -------------------------- checkedExportToAutocad -------------------------- ;
|
|
;if the file length is too long, export to desktop
|
|
(defun checkedExportToAutocad (/ prefix basefilename fn1 fn2 fullength filename savepath)
|
|
(vl-load-com)
|
|
(setq prefix (getvar "dwgprefix"))
|
|
(setq basefilename (getvar "dwgname"))
|
|
(setq fn1 (strlen (getvar "dwgprefix")))
|
|
(setq fn2 (strlen (getvar "dwgname")))
|
|
(setq fullength (+ fn1 fn2 5 8))
|
|
(if (> fullength 255)
|
|
(progn
|
|
(setq prefix (strcat (getenv "USERPROFILE") "\\Desktop"))
|
|
(setq filename(vl-string-right-trim ".dwg" basefilename))
|
|
(setq savepath (strcat prefix "\\ACAD-" filename "_cleaned.dwg" ))
|
|
(command "._-AECEXPORTTOAUTOCAD" "f" "2013" "" savepath)
|
|
(print "Too long filename, saved to desktop!")
|
|
)
|
|
(command "._-AECEXPORTTOAUTOCAD" "f" "2013" "s" "_cleaned" "" "")
|
|
)
|
|
)
|
|
|
|
|
|
; ---------------------------------------------------------------------------- ;
|
|
; CODE ;
|
|
; ---------------------------------------------------------------------------- ;
|
|
|
|
;; Modelspace
|
|
(command "._MODEL")
|
|
|
|
;; Xrefs
|
|
(bindXrefs)
|
|
(command "._-xref" "d" "*")
|
|
|
|
;; Xlines
|
|
(dax)
|
|
(rxl)
|
|
|
|
;;Points
|
|
(dap)
|
|
|
|
;; Hatches
|
|
(sephatch)
|
|
|
|
;; Attdef to txt
|
|
(cAttDef2Text)
|
|
|
|
;; deleteLayouts
|
|
(deleteLayouts)
|
|
|
|
;; moveOrigin
|
|
(moveOrigin)
|
|
(command "._ZOOM" "e")
|
|
|
|
;; Units
|
|
(unitcheck)
|
|
|
|
;; Variables
|
|
(setvar "PROXYGRAPHICS" 1)
|
|
|
|
;; Zoom and regen
|
|
(command "._ZOOM" "e")
|
|
(command "._REGENALL")
|
|
|
|
;; Cleanup and fix
|
|
(command "._-PURGE" "a" "*" "n")
|
|
(command "._AUDIT" "y")
|
|
(command "._REGENALL")
|
|
|
|
;; Export
|
|
(checkedExportToAutocad) |