Extracting block data to a report

[jamami]

i am trying to develop code that will run the clean up routine on each file in a chosen folder (i have previously been doing this with multiple script files using a directory listing to list every file, will the code below work if the text files are being left open for append access? would it be 'cleaner' to have the audit report as a separate routine rather than requiring the processing of all drawings each time to rebuild?

 

 

(defun c:BatchDPSR (/ folder dwglist dwg dwgproc)
  (vl-load-com)
  (prompt "\nSelect folder containing DWG files...")
  
  ;; Prompt for folder
  (setq folder (getfolder "Select Folder of DWG Files"))

  (if (and folder (setq dwglist (vl-directory-files folder "*.dwg" 1)))
    (progn
      (foreach dwg dwglist
        (prompt (strcat "\nProcessing: " dwg))
        (setq dwgproc (strcat folder "\" dwg))

        ;; Open DWG in background and run c:dpsr
        (command "_.OPEN" dwgproc)
        (c:dpsr)
        (command "_.QSAVE")
        (command "_.CLOSE")
      )
      (prompt "\nBatch processing complete.")
    )
    (prompt "\nNo DWG files found or folder selection cancelled.")
  )
  (princ)
)

;; Folder selection dialog
(defun getfolder (msg / sh fol)
  (setq sh (vlax-create-object "Shell.Application"))
  (setq fol (vlax-invoke-method sh 'BrowseForFolder 0 msg 0))
  (vlax-release-object sh)
  (if fol
    (vlax-get-property (vlax-get-property fol 'Self) 'Path)
  )
)

 

[Saxlle]

Try to replace this block of code (replace original code with code from below)

 

........
(vlax-for ent	ms
    (setq ename (vla-get-objectname ent)
	   clr (vla-get-color ent)
	   lt (vla-get-linetype ent)
	   lyr (vla-get-layer ent)
	 )
	 ;; Move objects by type & color
	 (cond
	   ((wcmatch ename "AcDb3dSolid,AcDbSurface")
	    (vla-put-layer ent "D-3D-SOL")
	   )
	   ((and (member ename '("AcDbLine" "AcDbPolyline" "AcDbCircle"))
		 (< clr 5)
	    )
	    (vla-put-layer ent "D-3D-CLG")
	   )
	   ((and (member ename '("AcDbLine" "AcDbPolyline" "AcDbCircle"))
		 (>= clr 5)
	    )
	    (vla-put-layer ent "D-3D-CLM")
	   )
	 )
    
	 ;; Set ByLayer
	 (if (/= clr 256)
	   (progn (vla-put-color ent 256)
		  (setq prop-errors (1+ prop-errors))
	   )
	 )
	 (if (/= (strcase lt) "BYLAYER")
	   (progn (vla-put-linetype ent "BYLAYER")
		  (setq prop-errors (1+ prop-errors))
	   )
	 )
     (command "-layer" "tr" 0 lyr "")
;;;	 (vla-put-transparency ent (vlax-make-variant 0))
	 ;; Track wrong types
	 (if (not (member ename
			  '("AcDbLine"	       "AcDbPolyline"
			    "AcDbCircle"       "AcDb3dSolid"
			    "AcDbSurface"
			   )
		  )
	     )
	   (setq enttype-errors (1+ enttype-errors))
	 )
	 ;; Track wrong linetypes
	 (if (not
	       (member (strcase lt) '("BYLAYER" "CONTINUOUS" "CENTER"))
	     )
	   (setq ltype-errors (1+ ltype-errors))
	 )
    )
    ........

 

After executing the code in file "AA0003-3D-LWT.dwg", I get this in .csv (file name "DWG_Audit_Report").

 

 

And, I forget, this part also:

 

;; Create or set a layer
  (defun makelayer (name color lw tran)
    (if	(not (tblsearch "layer" name))
      (vla-add (vla-get-layers doc) name)
    )
    (vla-put-color (vla-item (vla-get-layers doc) name) color)
    (vla-put-lineweight (vla-item (vla-get-layers doc) name) lw)
    (command "-layer" "tr" tran name "")
;;;    (vla-put-transparency
;;;      (vla-item (vla-get-layers doc) name)
;;;      (vlax-make-variant tran)
;;;    )
  )

 

Edited Monday at 01:15 PM by Saxlle

[jamami]

I have run a couple of tests and there is an issue with the colours.

all lines/pline/circles are being placed on layer D-3D-CLM. Layer D-3D-CLG is then being purged 

 

i need entitles with a colour less than 5, or whos colour is BYLAYER and residing on a layer of a colour < 5 to be moved to D-3D-CLG.

The remaining lines/pline/circles are moved to D-3D-CLM

 

i think the issue is that the code is looking a colour <5 which it will be if set bylayer?

i have checked the code below and it seems to be flagging entities either coloured or bylayer  (although it is picking up way more entities tan actually in the drawing?)

Could  a return value from this  be used in the dwg processor to ensure line/pline and circles are filtered correctly?

  

 

(defun c:test (/ ent lay typ ss i ltype entData)
  ;; Get all entities in the drawing
  (setq ss (ssget "_X"))
  (if ss
    (progn
      (setq i 0)
      (while (< i (sslength ss))
        (setq ent (ssname ss i))
        (setq entData (entget ent))
        (setq typ (cdr (assoc 0 entData)))
        (setq lay (cdr (assoc 8 entData)))
        (setq ltype (cdr (assoc 6 entData)))

        ;; Check color logic here
        (CheckEntColor ent)

        (setq i (1+ i))
      )
    )
  )
  (princ)
)

(defun CheckEntColor (ent / entData color layer layerData layerColor)
  (setq entData (entget ent))
  (setq color (cdr (assoc 62 entData)))
  (cond
    ;; If entity color is set and greater than 5
    ((and color (/= color 256) (> color 5))
     (princ (strcat "\nEntity " (rtos (cdr (assoc -1 entData)) 2 0) " has entity color > 5"))
    )
    ;; If BYLAYER (color is nil or 256) ;check layer color
    ((or (not color) (= color 256))
     (setq layer (cdr (assoc 8 entData)))
     (setq layerData (tblsearch "LAYER" layer))
     (setq layerColor (cdr (assoc 62 layerData)))
     (if (> layerColor 5)
       (princ (strcat "\nEntity on layer " layer " has layer color > 5"))
       (princ (strcat "\nEntity on layer " layer " has layer color < 5"))
     )
    )
  )
  (princ)
)

 

[jamami]

is the below a correct approach ?

 

i have noticed in some code being posted that some function (defun name) are defined within the overall (defun c:namea). I am used to Vb where a function is ended and cannot contain another function, if the sub functions are not defined within the main c:namea  ie they appear after the closing parentheses can they be used publicly?

;; Move objects by type & color
	 (cond
	   ((wcmatch ename "AcDb3dSolid,AcDbSurface")
	    (vla-put-layer ent "D-3D-SOL")
	   )
	   ((and (member ename '("AcDbLine" "AcDbPolyline" "AcDbCircle"))
		 (not((CheckEntColor ent))
	    )
	    (vla-put-layer ent "D-3D-CLG")
	   )
	   ((and (member ename '("AcDbLine" "AcDbPolyline" "AcDbCircle"))
		 (CheckEntColor ent)
	    )
	    (vla-put-layer ent "D-3D-CLM")
	   )
	 )

 

[Saxlle]

16 minutes ago, jamami said:

Could  a return value from this  be used in the dwg processor to ensure line/pline and circles are filtered correctly?

You can use something like this from the image below (when I run it, it only selects entities with color < 5 and entities with color BYLAYER), this replaces your code from above. After that, you can iterate through the selection set and do what you want to achieve.

 

 

 

[Saxlle]

2 minutes ago, jamami said:

i have noticed in some code being posted that some function (defun name) are defined within the overall (defun c:namea)

Yes, it can be done.

[jamami]

I have added a line re color selection part, BUT, as soon as I add anything it fails to run any longer  . Your code is below, i think we are nearly there, if only it would run!  I  have tried to debug in the vlide and it is reporting a crash on the first line of the checkentcolor code:-

 

this ran fine when i tested it, are you able to advise why this is happening?

 

 

;;; Clean drawings to match standards                                                                       |
;;;                                                                                                         |
;;; https://www.cadtutor.net/forum/topic/98263-extracting-block-data-to-a-report/page/4/#findComment-674064 |
;;;                                                                                                         |
;;; SLW210 (a.k.a. Steve Wilson)                                                                            |
;;;                                                                                                         |
;;; DWGProcessor.lsp                                                                                        |
;;;                                                                                                         |
;;; Made to specific request                                                                                |
;;;*********************************************************************************************************|

(defun c:dpsr (/             doc       ms
               result         layers-ok   ltypes-ok
               ents-ok         props-ok   layer-errors
               ltype-errors  enttype-errors
               prop-errors   csv-line
              )
  (vl-load-com)
  (setq doc (vla-get-activedocument (vlax-get-acad-object)))
  (setq ms (vla-get-modelspace doc))
  ;; CSV path (same folder as drawing)
  (setq *audit-csv-path*
     (strcat (getvar "DWGPREFIX")
         "DWG_Audit_Report.csv"
     )
  )
  ;; /////////////////////////
  ;;Append to CSV
  (defun append2csv (line / file)
    (setq file (open *audit-csv-path* "a"))
    (if file
      (progn (write-line line file) (close file))
      (prompt "\nERROR: Cannot write to audit CSV.")
    )
  )
  ;; //////////////////////////
  ;;Write header
  (defun writecsvheader ()
    (if (not (findfile *audit-csv-path*))
      (append2csv
    "DWGNAME,LAYERSTATES,LINETYPES,ENTITYTYPES,ENTITYDEF,LAYER-ERRS,LT-ERRS,TYPE-ERRS,PROP-ERRS"
      )
    )
  )
 
;;///////////////////////////////////////////////////////////////
;; Create or set a layer
  (defun makelayer (name color lw tran)
    (if	(not (tblsearch "layer" name))
      (vla-add (vla-get-layers doc) name)
    )
    (vla-put-color (vla-item (vla-get-layers doc) name) color)
    (vla-put-lineweight (vla-item (vla-get-layers doc) name) lw)
    (command "-layer" "tr" tran name "")
;;;    (vla-put-transparency
;;;      (vla-item (vla-get-layers doc) name)
;;;      (vlax-make-variant tran)
;;;    )
  )

  
  ;; Explode blocks
  (vlax-for ent ms
    (if (and (= "AcDbBlockReference" (vla-get-objectname ent))
         (vlax-method-applicable-p ent 'explode)
    )
      (vla-explode ent)
    )
  )
  ;; Create layers
  (makelayer "D-3D-SOL" 7 30 0)        ; black, 0.3mm
  (makelayer "D-3D-CLG" 1 18 0)        ; red, 0.18mm
  (makelayer "D-3D-CLM" 5 18 0)        ; blue, 0.18mm
  (makelayer "0" 7 25 0)        ; default lw
  ;; Error counters
  (setq layer-errors 0
    ltype-errors 0
    enttype-errors 0
    prop-errors 0
  )
  ;; Process objects
 (vlax-for ent	ms
    (setq ename (vla-get-objectname ent)
	   clr (vla-get-color ent)
	   lt (vla-get-linetype ent)
	   lyr (vla-get-layer ent)
	 )
	 ;; Move objects by type & color
	 (cond
	   ((wcmatch ename "AcDb3dSolid,AcDbSurface")
	    (vla-put-layer ent "D-3D-SOL")
	   )
	   ((and (member ename '("AcDbLine" "AcDbPolyline" "AcDbCircle"))
		 (not(CheckEntColor ent))
	    )
	    (vla-put-layer ent "D-3D-CLG")
	   )
	   ((and (member ename '("AcDbLine" "AcDbPolyline" "AcDbCircle"))
		 (CheckEntColor ent)
	    )
	    (vla-put-layer ent "D-3D-CLM")
	   )
	 )
    
	 ;; Set ByLayer
	 (if (/= clr 256)
	   (progn (vla-put-color ent 256)
		  (setq prop-errors (1+ prop-errors))
	   )
	 )
	 (if (/= (strcase lt) "BYLAYER")
	   (progn (vla-put-linetype ent "BYLAYER")
		  (setq prop-errors (1+ prop-errors))
	   )
	 )
     (command "-layer" "tr" 0 lyr "")
;;;	 (vla-put-transparency ent (vlax-make-variant 0))
	 ;; Track wrong types
	 (if (not (member ename
			  '("AcDbLine"	       "AcDbPolyline"
			    "AcDbCircle"       "AcDb3dSolid"
			    "AcDbSurface"
			   )
		  )
	     )
	   (setq enttype-errors (1+ enttype-errors))
	 )
	 ;; Track wrong linetypes
	 (if (not
	       (member (strcase lt) '("BYLAYER" "CONTINUOUS" "CENTER"))
	     )
	   (setq ltype-errors (1+ ltype-errors))
	 )
    )
  ;; Delete everything on layer "0"
  (vlax-for ent ms
    (if (= (strcase (vla-get-layer ent)) "0")
      (vla-delete ent)
    )
  )
  ;; Set layer 0 current
  (vla-put-activelayer
    doc
    (vla-item (vla-get-layers doc) "0")
  )
  ;; Purge All (3 times)
  (repeat 3 (command "_.PURGE" "ALL" "*" "N"))
  ;; Purge Regapps (2 times)
  (repeat 2 (command "_.PURGE" "Regapps" "*" "N"))
  ;; Set UCS/view
  (command "_.UCS" "_W")
  (command "_.VISUALSTYLES" "_CONCEPTUAL")
  (command "_.VIEW" "_SWISO")
  (command "_.ZOOM" "_E")
  ;; Final checks
  (setq layers-ok (and (tblsearch "layer" "0")
               (tblsearch "layer" "D-3D-SOL")
               (tblsearch "layer" "D-3D-CLG")
               (tblsearch "layer" "D-3D-CLM")
          )
  )
  ;; Build audit status
  (setq result (strcat (getvar "DWGNAME")
               ","
               (if layers-ok
             "PASS"
             "FAIL"
               )
               ","
               (if (= ltype-errors 0)
             "PASS"
             "FAIL"
               )
               ","
               (if (= enttype-errors 0)
             "PASS"
             "FAIL"
               )
               ","
               (if (= prop-errors 0)
             "PASS"
             "FAIL"
               )
               ","
               (itoa layer-errors)
               ","
               (itoa ltype-errors)
               ","
               (itoa enttype-errors)
               ","
               (itoa prop-errors)
           )
  )
  ;; Write header and result
  (writecsvheader)
  (append2csv result)
  (prompt (strcat "\nDWGProcessor Complete. Audit: " result))
  (princ)

)
;;//////////////////////////////////////////////////
;; checkcolor

(defun CheckEntColor (ent / entData color layer layerData layerColor)
  (setq entData (entget ent))
  (setq color (cdr (assoc 62 entData)))
  (cond
    ;; If entity color is set and greater than 5
    ((and color (/= color 256) (> color 5))
     T ;(princ (strcat "\nEntity " (rtos (cdr (assoc -1 entData)) 2 0) " has entity color > 5"))
    )
    ;; If BYLAYER (color is nil or 256) ;check layer color
    ((or (not color) (= color 256))
     (setq layer (cdr (assoc 8 entData)))
     (setq layerData (tblsearch "LAYER" layer))
     (setq layerColor (cdr (assoc 62 layerData)))
     (if (> layerColor 5)
       T ;(princ (strcat "\nEntity on layer " layer " has layer color > 5"))
       nil ;(princ (strcat "\nEntity on layer " layer " has layer color < 5"))
     )
    )
  )
  (princ)
 )

 

[SLW210]

I was wasting time, looks like @Saxlle has you going.

 

FWIW, I found this which looks promising for transparency in the future... Get and set layer and entity transparency using LISP - AutoCAD DevBlog

 

For your last issue, you're calling CheckEntColor function before it's been defined.

LISP processes code sequentially, so if a function isn't defined yet, you can't call it.

 

Maybe like this... (I didn't test it and didn't add comments where Saxlle provided the answers)

 

;;//////////////////////////////////////////////////
;; checkcolor

(defun CheckEntColor (ent / entData color layer layerData layerColor)
  (setq entData (entget ent))
  (setq color (cdr (assoc 62 entData)))
  (cond
    ;; If entity color is set and greater than 5
    ((and color (/= color 256) (> color 5)) T)

    ;; If BYLAYER (color is nil or 256) ;check layer color
    ((or (not color) (= color 256))
     (setq layer (cdr (assoc 8 entData)))
     (setq layerData (tblsearch "LAYER" layer))
     (setq layerColor (cdr (assoc 62 layerData)))
     (if (and layerColor (> layerColor 5))
       T
       nil
     )
    )
    (T nil)
  )
)

(defun c:dpsr (/	    doc		 ms	      result
	       layers-ok    ltypes-ok	 ents-ok      props-ok
	       layer-errors ltype-errors enttype-errors
	       prop-errors  csv-line	 ename	      clr
	       lt	    lyr
	      )

  (vl-load-com)

  (setq doc (vla-get-activedocument (vlax-get-acad-object)))
  (setq ms (vla-get-modelspace doc))

  ;; CSV path (same folder as drawing)
  (setq	*audit-csv-path*
	 (strcat (getvar "DWGPREFIX") "DWG_Audit_Report.csv")
  )

  ;; /////////////////////////
  ;;Append to CSV
  (defun append2csv (line / file)
    (setq file (open *audit-csv-path* "a"))
    (if	file
      (progn (write-line line file) (close file))
      (prompt "\nERROR: Cannot write to audit CSV.")
    )
  )

  ;; //////////////////////////
  ;;Write header
  (defun writecsvheader	()
    (if	(not (findfile *audit-csv-path*))
      (append2csv
	"DWGNAME,LAYERSTATES,LINETYPES,ENTITYTYPES,ENTITYDEF,LAYER-ERRS,LT-ERRS,TYPE-ERRS,PROP-ERRS"
      )
    )
  )

  ;;///////////////////////////////////////////////////////////////
  ;; Create or set a layer
  (defun makelayer (name color lw tran)
    (if	(not (tblsearch "layer" name))
      (vla-add (vla-get-layers doc) name)
    )
    (vla-put-color (vla-item (vla-get-layers doc) name) color)
    (vla-put-lineweight (vla-item (vla-get-layers doc) name) lw)
    (command "-layer" "tr" tran name "")
  )

  ;; Explode blocks
  (vlax-for ent	ms
    (if	(and (= "AcDbBlockReference" (vla-get-objectname ent))
	     (vlax-method-applicable-p ent 'explode)
	)
      (vla-explode ent)
    )
  )


  ;; Create layers
  (makelayer "D-3D-SOL" 7 30 0)		; black, 0.3mm
  (makelayer "D-3D-CLG" 1 18 0)		; red, 0.18mm
  (makelayer "D-3D-CLM" 5 18 0)		; blue, 0.18mm
  (makelayer "0" 7 25 0)		; default lw

  ;; Error counters
  (setq	layer-errors
		       0
	ltype-errors
		       0
	enttype-errors
		       0
	prop-errors    0
  )


  ;; Process objects
  (vlax-for ent	ms
    (setq ename	(vla-get-objectname ent)
	  clr	(vla-get-color ent)
	  lt	(vla-get-linetype ent)
	  lyr	(vla-get-layer ent)
    )

    ;; Move objects by type & color
    (cond
      ((wcmatch ename "AcDb3dSolid,AcDbSurface")
       (vla-put-layer ent "D-3D-SOL")
      )

      ((and (member ename '("AcDbLine" "AcDbPolyline" "AcDbCircle"))
	    (not (CheckEntColor ent))
       )
       (vla-put-layer ent "D-3D-CLG")
      )

      ((and (member ename '("AcDbLine" "AcDbPolyline" "AcDbCircle"))
	    (CheckEntColor ent)
       )
       (vla-put-layer ent "D-3D-CLM")
      )
    )

    ;; Set ByLayer
    (if	(/= clr 256)
      (progn (vla-put-color ent 256)
	     (setq prop-errors (1+ prop-errors))
      )
    )
    (if	(/= (strcase lt) "BYLAYER")
      (progn (vla-put-linetype ent "BYLAYER")
	     (setq prop-errors (1+ prop-errors))
      )
    )

    (command "-layer" "tr" 0 lyr "")

    ;; Track wrong types
    (if	(not (member ename
		     '("AcDbLine"	  "AcDbPolyline"
		       "AcDbCircle"	  "AcDb3dSolid"
		       "AcDbSurface"
		      )
	     )
	)
      (setq enttype-errors (1+ enttype-errors))
    )

    ;; Track wrong linetypes
    (if	(not
	  (member (strcase lt) '("BYLAYER" "CONTINUOUS" "CENTER"))
	)
      (setq ltype-errors (1+ ltype-errors))
    )
  )

  ;; Delete everything on layer "0"
  (vlax-for ent	ms
    (if	(= (strcase (vla-get-layer ent)) "0")
      (vla-delete ent)
    )
  )


  ;; Set layer 0 current
  (vla-put-activelayer
    doc
    (vla-item (vla-get-layers doc) "0")
  )

  ;; Purge All (3 times)
  (repeat 3 (command "_.PURGE" "ALL" "*" "N"))
  (repeat 2 (command "_.PURGE" "Regapps" "*" "N"))

  ;; Set UCS/view
  (command "_.UCS" "_W")
  (command "_.VISUALSTYLES" "_CONCEPTUAL")
  (command "_.VIEW" "_SWISO")
  (command "_.ZOOM" "_E")

  ;; Final checks
  (setq	layers-ok (and (tblsearch "layer" "0")
		       (tblsearch "layer" "D-3D-SOL")
		       (tblsearch "layer" "D-3D-CLG")
		       (tblsearch "layer" "D-3D-CLM")
		  )
  )


  ;; Build audit status
  (setq	result (strcat (getvar "DWGNAME")
		       ","
		       (if layers-ok
			 "PASS"
			 "FAIL"
		       )
		       ","
		       (if (= ltype-errors 0)
			 "PASS"
			 "FAIL"
		       )
		       ","
		       (if (= enttype-errors 0)
			 "PASS"
			 "FAIL"
		       )
		       ","
		       (if (= prop-errors 0)
			 "PASS"
			 "FAIL"
		       )
		       ","
		       (itoa layer-errors)
		       ","
		       (itoa ltype-errors)
		       ","
		       (itoa enttype-errors)
		       ","
		       (itoa prop-errors)
	       )
  )

  ;; Write header and result
  (writecsvheader)
  (append2csv result)
  (prompt (strcat "\nDWGProcessor Complete. Audit: " result))
  (princ)
)

 

[jamami]

sadly, it still doesnt run 

; error: bad argument type: lentityp #<VLA-OBJECT IAcadLine 0000026ee6d45a78>
 

[jamami]

I have set CheckEntColor to T or nil, does this need to be "T" and nil

 

[SLW210]

;;//////////////////////////////////////////////////
;; checkcolor

(defun CheckEntColor (ent / entData color layer layerData layerColor)
  (setq entData (entget ent))
  (setq color (cdr (assoc 62 entData)))
  (cond
    ((and color (/= color 256) (> color 5)) T)
    ((or (not color) (= color 256))
     (setq layer (cdr (assoc 8 entData)))
     (setq layerData (tblsearch "LAYER" layer))
     (setq layerColor (cdr (assoc 62 layerData)))
     (if (and layerColor (> layerColor 5))
       T
       nil
     )
    )
    (T nil)
  )
)

(defun c:dpsr (/	    doc		 ms	      result
	       layers-ok    ltypes-ok	 ents-ok      props-ok
	       layer-errors ltype-errors enttype-errors
	       prop-errors  csv-line	 ename	      clr
	       lt	    lyr
	      )

  (vl-load-com)
  (setq doc (vla-get-activedocument (vlax-get-acad-object)))
  (setq ms (vla-get-modelspace doc))
  (setq	*audit-csv-path*
	 (strcat (getvar "DWGPREFIX")
		 "DWG_Audit_Report.csv"
	 )
  )

  ;; CSV functions
  (defun append2csv (line / file)
    (setq file (open *audit-csv-path* "a"))
    (if	file
      (progn (write-line line file) (close file))
      (prompt "\nERROR: Cannot write to audit CSV.")
    )
  )

  (defun writecsvheader	()
    (if	(not (findfile *audit-csv-path*))
      (append2csv
	"DWGNAME,LAYERSTATES,LINETYPES,ENTITYTYPES,ENTITYDEF,LAYER-ERRS,LT-ERRS,TYPE-ERRS,PROP-ERRS"
      )
    )
  )

  ;; Create or set a layer
  (defun makelayer (name color lw tran)
    (if	(not (tblsearch "layer" name))
      (vla-add (vla-get-layers doc) name)
    )
    (vla-put-color (vla-item (vla-get-layers doc) name) color)
    (vla-put-lineweight (vla-item (vla-get-layers doc) name) lw)
    (command "-layer" "tr" (rtos tran 2 0) name "")
  )

  ;; Explode blocks
  (vlax-for ent	ms
    (if	(and (= "AcDbBlockReference" (vla-get-objectname ent))
	     (vlax-method-applicable-p ent 'explode)
	)
      (vla-explode ent)
    )
  )

  ;; Create layers
  (makelayer "D-3D-SOL" 7 30 0)
  (makelayer "D-3D-CLG" 1 18 0)
  (makelayer "D-3D-CLM" 5 18 0)
  (makelayer "0" 7 25 0)

  ;; Error counters
  (setq	layer-errors   0
	ltype-errors   0
	enttype-errors 0
	prop-errors    0
  )

  ;; Process objects
  (vlax-for ent	ms
    (setq ename	(vla-get-objectname ent)
	  clr	(vla-get-color ent)
	  lt	(vla-get-linetype ent)
	  lyr	(vla-get-layer ent)
    )

    ;; Classification and move to appropriate layer
    (cond
      ((wcmatch ename "AcDb3dSolid,AcDbSurface")
       (vla-put-layer ent "D-3D-SOL")
      )
      ((and (member ename '("AcDbLine" "AcDbPolyline" "AcDbCircle"))
	    (not (CheckEntColor (vlax-vla-object->ename ent)))             ;; Was (not (CheckEntColor ent))
       )
       (vla-put-layer ent "D-3D-CLG")
      )
      ((and (member ename '("AcDbLine" "AcDbPolyline" "AcDbCircle"))
	    (CheckEntColor (vlax-vla-object->ename ent))
       )
       (vla-put-layer ent "D-3D-CLM")
      )
    )

    ;; Set ByLayer color and linetype
    (if	(/= clr 256)
      (progn (vla-put-color ent 256)
	     (setq prop-errors (1+ prop-errors))
      )
    )
    (if	(/= (strcase lt) "BYLAYER")
      (progn (vla-put-linetype ent "BYLAYER")
	     (setq prop-errors (1+ prop-errors))
      )
    )

    ;; Track invalid types and linetypes
    (if	(not (member ename
		     '("AcDbLine"	  "AcDbPolyline"
		       "AcDbCircle"	  "AcDb3dSolid"
		       "AcDbSurface"
		      )
	     )
	)
      (setq enttype-errors (1+ enttype-errors))
    )
    (if	(not
	  (member (strcase lt) '("BYLAYER" "CONTINUOUS" "CENTER"))
	)
      (setq ltype-errors (1+ ltype-errors))
    )
  )

  ;; Delete entities on layer "0"
  (vlax-for ent	ms
    (if	(= (strcase (vla-get-layer ent)) "0")
      (vla-delete ent)
    )
  )

  ;; Set layer 0 current
  (vla-put-activelayer
    doc
    (vla-item (vla-get-layers doc) "0")
  )

  ;; Purge all
  (repeat 3 (command "_.PURGE" "ALL" "*" "N"))
  (repeat 2 (command "_.PURGE" "Regapps" "*" "N"))

  ;; Set UCS/view
  (command "_.UCS" "_W")
  (command "_.-VISUALSTYLES" "C" "_CONCEPTUAL") ;; Fixed
  (command "_.VIEW" "_SWISO")
  (command "_.ZOOM" "_E")

  ;; Final checks
  (setq	layers-ok (and (tblsearch "layer" "0")
		       (tblsearch "layer" "D-3D-SOL")
		       (tblsearch "layer" "D-3D-CLG")
		       (tblsearch "layer" "D-3D-CLM")
		  )
  )

  ;; Build CSV output
  (setq	result
	 (strcat (getvar "DWGNAME")
		 ","
		 (if layers-ok
		   "PASS"
		   "FAIL"
		 )
		 ","
		 (if (= ltype-errors 0)
		   "PASS"
		   "FAIL"
		 )
		 ","
		 (if (= enttype-errors 0)
		   "PASS"
		   "FAIL"
		 )
		 ","
		 (if (= prop-errors 0)
		   "PASS"
		   "FAIL"
		 )
		 ","
		 (itoa layer-errors)
		 ","
		 (itoa ltype-errors)
		 ","
		 (itoa enttype-errors)
		 ","
		 (itoa prop-errors)
	 )
  )

  (writecsvheader)
  (append2csv result)

  (prompt (strcat "\nDWGProcessor Complete. Audit: " result))
  (princ)
)

 

 

Tested and works

 

I changed 

 

(not (CheckEntColor ent))

 

To

 

(not (CheckEntColor (vlax-vla-object->ename ent)))

 

 

Also you need _.-VISUALSTYLES

[jamami]

excellent it does run

but it is changing all the centrelines to layer D-3D-CLG now and then purging out CLM.

the attached drawing shows the issue.

if i run the processor on it I lose D-3D-CLM centrelines, they are all oved to GLG and then the layer purged.

 

Layer D-3D-CLG is colour 1 

Layer D-3D-CLM is colour 160

 

In this case I would expect everything to stay where it is and the layers changed to correct settings.

 

 

 

 

 

 

 

V03210-3D-LWT.dwg

[jamami]

for the test drawing attached it works beautifully

is the problem because the layers already exist in the previous drawing? 

Drawing1.dwg

[jamami]

i also need to run the exporttoacad routine on the drawings after all the work has been done to get rid of the bogus line types and blocks, can this be added to the main routine or will i need to script this separately on each folder .

 

Rather than write script's it would be ideal to select the folder to be processed and for the routine to process each file therein. I am trying to get the below to work but get :-

; error: malformed string on input

vlide doesn't indicate where the issue is, any suggestions on how to fix this error would be appreciated.

 

 

;; BatchDWGProcessor.lsp
;; Batch runs c:dpsr on multiple DWG files in a folder
;; Requires DWGProcessor.lsp to be loaded

(defun c:BatchDPSR (/ folder dwglist dwg dwgproc)
  (vl-load-com)
  (prompt "\nSelect folder containing DWG files...")
  
  ;; Prompt for folder
  (setq folder (getfolder "Select Folder of DWG Files"))

  (if (and folder (setq dwglist (vl-directory-files folder "*.dwg" 1)))
    (progn
      (foreach dwg dwglist
        (prompt (strcat "\nProcessing: " dwg))
        (setq dwgproc (strcat folder "\" dwg))

        ;; Open DWG in background and run c:dpsr
        (command "_.OPEN" dwgproc)
        (c:dpsr)
        (command "_.QSAVE")
        (command "_.CLOSE")
      )
      (prompt "\nBatch processing complete.")
    )
    (prompt "\nNo DWG files found or folder selection cancelled.")
  )
  (princ)
)

;; Folder selection dialog
(defun getfolder (msg / sh fol)
  (setq sh (vlax-create-object "Shell.Application"))
  (setq fol (vlax-invoke-method sh 'BrowseForFolder 0 msg 0))
  (vlax-release-object sh)
  (if fol
    (vlax-get-property (vlax-get-property fol 'Self) 'Path)
  )
)

 

[jamami]

I have found the error in the debug routine the code was adding a single \ causing the issue, fix :-

(setq dwgproc 
  (strcat 
    (if (= (substr folder (strlen folder) 1) "\\") folder (strcat folder "\\")) 
    dwg
  )
)

 

[jamami]

Good morning SLW210. I changed the >5 parameter for the colour to >= and it seems to have solved the issue. The batch routine I tried  doesnt work as it stops each time a drawing is closed so I have processed another folder using a script as below.

open "C:\ASSETS\DWG\3D\LIGHT\V03110-3D-LWT.dwg" dpsr m2a qsave close
open "C:\ASSETS\DWG\3D\LIGHT\V03112-3D-LWT.dwg" dpsr m2a qsave close
open "C:\ASSETS\DWG\3D\LIGHT\V03114-3D-LWT.dwg" dpsr m2a qsave close
open "C:\ASSETS\DWG\3D\LIGHT\V03116-3D-LWT.dwg" dpsr m2a qsave close

 

one issue with this I have noticed is the excellent audit report is prepared during the dpsr routine so the changes made by m2a are not recorded. Another issue is that it some of the dwgs have arcs so I need to add arc member type into the check as below:-

(member ename '("AcDbLine" "AcDbPolyline" "AcDbCircle" "AcDbArc")

 

besides the above everything worked brilliantly, thank you once again for your highly valued help with this.

 

 

[SLW210]

I'll have to do some thinking on a Batch LISP, I tried and same issue, the Delay should do it, but if You go back to your STPOUT thread I posted a link to some SAT2DWG, DGN2DWG, etc. that I set up to run on a selected folder. I tried quickly to get something like that going with the -EXPORTTOAUTOCAD and had the same trouble.

 

Do you have the LISP loading on startup of a drawing? Loading Programs Automatically | Lee Mac Programming

 

That's why I posted the information on running a Batch with Core Console.

 

Up and Running with the 2013 Core Console | AutoCAD Tips

 

You might have luck with adding the LISP command at the bottom to self-start on load.

 

(defun c:dpsr (/	    doc		 ms	      result
	       layers-ok    ltypes-ok	 ents-ok      props-ok
	       layer-errors ltype-errors enttype-errors
	       prop-errors  csv-line	 ename	      clr
	       lt	    lyr
	      )

     Body of Code Here

    (princ)

    ) 

    (c:dpsr)

 

I forgot to try that.

 

I have in the works a DCL edition, should include options to run things individually as well as a dropdown to add the drawings, to be run. It's just going to take me some time, this was a start, but I am also redesigning it.

 

[SLW210]

6 hours ago, jamami said:

...

one issue with this I have noticed is the excellent audit report is prepared during the dpsr routine so the changes made by m2a are not recorded. Another issue is that it some of the dwgs have arcs so I need to add arc member type into the check as below:-

(member ename '("AcDbLine" "AcDbPolyline" "AcDbCircle" "AcDbArc")

 

besides the above everything worked brilliantly, thank you once again for your highly valued help with this.

 

 

Initially you indicated the report was to determine which drawings need cleaned, that's why the report runs during the main routine (the only routine at the time). 

 

Initially I had just the check routine and make the reports, that might could be run on drawings after the -EXPORTTOAUTOCAD or just run the dpsr again, though theoretically it should be cleaned and up to standards after -EXPORTTOAUTOCAD.

 

-EXPORTTOAUTOCAD could be run first correct?

[jamami]

It’s best to run M2A after as if there are objects on say layer AM-7 with an AM linetype they remain when M2A is run .

I have processed over 600 files today but I have to do it 3x using scripts 

dwgprocessor 

m2a

audit report 

 

no chance to to do all at once as M2A creates a new drawing .

i copied  the  audit report code from the dwg processor and created a separate routine 

 

it’s  time consuming opening each drawing to process each time and then closing would be good run as a ‘background task’ akin to batch plot.. it is still a lot quicker than doing it manually though which is very helpful .

 

[jamami]

8 hours ago, SLW210 said:

I'll have to do some thinking on a Batch LISP, I tried and same issue, the Delay should do it, but if You go back to your STPOUT thread I posted a link to some SAT2DWG, DGN2DWG, etc. that I set up to run on a selected folder. I tried quickly to get something like that going with the -EXPORTTOAUTOCAD and had the same trouble.

 

Do you have the LISP loading on startup of a drawing? Loading Programs Automatically | Lee Mac Programming

 

That's why I posted the information on running a Batch with Core Console.

 

Up and Running with the 2013 Core Console | AutoCAD Tips

 

You might have luck with adding the LISP command at the bottom to self-start on load.

 

(defun c:dpsr (/	    doc		 ms	      result
	       layers-ok    ltypes-ok	 ents-ok      props-ok
	       layer-errors ltype-errors enttype-errors
	       prop-errors  csv-line	 ename	      clr
	       lt	    lyr
	      )

     Body of Code Here

    (princ)

    ) 

    (c:dpsr)

 

I forgot to try that.

 

I have in the works a DCL edition, should include options to run things individually as well as a dropdown to add the drawings, to be run. It's just going to take me some time, this was a start, but I am also redesigning it.

 

This looks awesome .

i added dwgprocessor and M2A to the startup functions in the app load dialogue so the there for every file .

i didn’t quite grasp the lisp console and it looked like it needed something installed which means contacting group IT , not something I like doing to be honest as it can be a painful experience .