;; Get Anonymous References

(defun LM:getanonymousreferences ( blk / ano def lst rec ref )
    (setq blk (strcase blk))
    (while (setq def (tblnext "block" (null def)))
        (if
            (and (= 1 (logand 1 (cdr (assoc 70 def))))
                (setq rec
                    (entget
                        (cdr
                            (assoc 330
                                (entget
                                    (tblobjname "block"
                                        (setq ano (cdr (assoc 2 def)))
                                    )
                                )
                            )
                        )
                    )
                )
            )
            (while
                (and
                    (not (member ano lst))
                    (setq ref (assoc 331 rec))
                )
                (if
                    (and
                        (entget (cdr ref))
                        (= blk (strcase (LM:al-effectivename (cdr ref))))
                    )
                    (setq lst (cons ano lst))
                )
                (setq rec (cdr (member (assoc 331 rec) rec)))
            )
        )
    )
    (reverse lst)
)
                        
;; Effective Block Name

(defun LM:al-effectivename ( ent / blk rep )
    (if (wcmatch (setq blk (cdr (assoc 2 (entget ent)))) "`**")
        (if
            (and
                (setq rep
                    (cdadr
                        (assoc -3
                            (entget
                                (cdr
                                    (assoc 330
                                        (entget
                                            (tblobjname "block" blk)
                                        )
                                    )
                                )
                               '("AcDbBlockRepBTag")
                            )
                        )
                    )
                )
                (setq rep (handent (cdr (assoc 1005 rep))))
            )
            (setq blk (cdr (assoc 2 (entget rep))))
        )
    )
    blk
)

;;  Groups elements in sublist by criteria

(defun subtrack (test lst)
(apply 'append (mapcar '(lambda (x)
(if (eq (car x) test)(list x))) lst)))

;;  Counts equivalent subs in list

(defun countsub	(lst sub)
  (cond	((null lst) 0)
	((and (equal (caar lst) (car sub) 0.00001)
	      (equal (cadar lst) (cadr sub) 0.00001)
	 )
	 (1+ (countsub (cdr lst) sub))
	)
	(T (countsub (cdr lst) sub))
  )
)
;;  Get info from block include from constant attributes in following form:
;; (("TAG1" . "VALUE1") ("TAG2" . "VALUE2") ...("*CONSTANT*: TAGN" . "VALUEN"))

  (defun get-all-atts (obj / atts att_list const_atts const_list ent)
    (and
	 (if (and obj 
		  (vlax-property-available-p obj 'Hasattributes)
		  (eq :vlax-true (vla-get-hasattributes obj))
	     )
	   (progn
	     (setq atts (vlax-invoke obj 'Getattributes))
	     (foreach att atts
	       (setq att_list
		      (cons (cons (vla-get-tagstring att)
				  (vla-get-textstring att)
			    )
			    att_list
		      )
	       )
	     )
	   )
	 )
    )
    (cond ((vlax-method-applicable-p obj 'Getconstantattributes)
	   (setq const_atts (vlax-invoke obj 'Getconstantattributes))
	   (foreach att	const_atts
	     (setq const_list
		    (cons (cons	(vla-get-tagstring att)
				(vla-get-textstring att)
			  )
			  const_list
		    )
	     )
	   )
	   (setq att_list (reverse (append const_list att_list)))
	  )
	  (T (reverse att_list))
    )
  )





(defun getblockselection ( blk )
    (ssget "_X"
        (list '(0 . "INSERT")
            (cons 2
                (apply 'strcat
                    (cons blk
                        (mapcar '(lambda ( x ) (strcat ",`" x))
                            (LM:getanonymousreferences blk)
                        )
                    )
                )
            )
        )
    )
)



;;			Main part			;;
  (defun C:LISTOUT (/	 acsp	  adoc	   aexc	    awb	     axss
		bname	 cll	  colm	   com_data csht     data
		exc_data fname	  header_list	    info     nwb
		osm	 row	  sht	   ss	    str1     str2
		subtot	 tmp_data tmp_get  tmp_snip tot     blkname
		blk	ANDRITZ	LISTTYPE	ANDRITZFonto	ListFonto
		ANDRITZRang	ListRang fcol1 HeaderRang HeaderFonto
		HeaderRange	BorderRang	RightB	RightD	Bord
		WARNING	WARNINGRang WARNINGFonto	ANDRITZLogo AB
		EndRange EndRang EndFonto EndBord LastBord
	       )

    (vl-load-com)
    (setq adoc (vla-get-activedocument
		 (vlax-get-acad-object)
	       )
	  acsp (vla-get-modelspace adoc)
    )
    (setq osm (getvar "osmode"))
    (setvar "osmode" 0)
    (setvar "cmdecho" 0)
    (vla-endundomark adoc)
    (vla-startundomark adoc)

;;    (vl-cmdf "zoom" "a")
;;    (vl-cmdf "zoom" ".85x")

    (initget 1 "Valve Tank Pump Motor") 											;;Gibt die Blocknamen vor, die ausgewählt werden können
    (setq blk (getkword "\Specify Blockname: [Valve/Tank/Pump/Motor]"))								;;Eingabemaske mit Blocknamen
    (if (tblsearch "block" blk)
        (sssetfirst nil (getblockselection blk))
        (princ (strcat "\n" blk " doesn't exist."))
        )
    (princ)
    
        (setq axss (vla-get-activeselectionset adoc))

    (vlax-for a	axss
      (setq tmp_get (get-all-atts a))
      (setq tmp_data (append (list (vla-get-name a)(vla-get-handle a)) tmp_get))
      (setq com_data (cons tmp_data com_data))
      (setq tmp_data nil)
    )	
    (setq tot (length com_data))
    (while com_data
      (setq tmp_snip
	     (subtrack (caar com_data) com_data)
      )
      (setq str1 (strcat "Subtotal " blk "s"
			 "\"" (caar com_data) "\""
                         ": "
		 )
	    str2
		 (itoa (length tmp_snip))
      )
      (setq exc_data (append exc_data
			     (list (append tmp_snip (list (list str2 str1))))
		     )
	    com_data (vl-remove-if
		       (function not)
		       (mapcar (function (lambda (x)
					   (if (not (member x tmp_snip))
					     x
					   )
					 )
			       )
			       com_data
		       )
		     )
	    tmp_snip nil
      )
    )
    (setq exc_data
           (mapcar (function (lambda (x)
               (mapcar (function (lambda (y)                
                   (append (list (cadr y)(car y))(cddr y))))
                       x
                       )
                               )
                             )
                   exc_data)
                   )
    ;;		Eof calc part		;;

    ;;	***	Excel part	***	;;
    (setq fn (strcat blk "list"))											;;Legt den Dateinamen je nach Blocknamen fest
;;;    (setq fn (vl-filename-base (getstring "\n***Filename:\n")))
;;;    (setq fname (strcat (getvar "dwgprefix") fn ".xls"))
    
    (setq fname (strcat "C:\\TEMP\\" fn ".xls"))									;;Erstellt den Dateipfad
    
    (setq fx (open fname "W"))
    (close fx)
;;;    (alert (strcat "Select file " "C:\\TEMP\\" (strcat fn ".xls") "\""))
;;;    (setq fname (getfiled "Excel Spreadsheet File" "" "XLS" 8))
;;;    (setq fname (findfile fname))

    (setq aexc (vlax-get-or-create-object "Excel.Application")
	  awb  (vlax-get-property aexc "Workbooks")
	  nwb  (vlax-invoke-method awb "Open" fname)
	  sht  (vlax-get-property nwb "Sheets")
	  csht (vlax-get-property sht "Item" 1)
	  cll  (vlax-get-property csht "Cells")
    )
    (vlax-put-property csht 'Name blk)											;;Gibt dem Tabellenblatt den Blocknamen

    (vla-put-visible aexc :vlax-true)

   (setq row 6
	  colm 1
    )

  (setq header_list													;;Gibt die Spaltenüberschriften an
           '("HANDLE"
             "BLOCK NAME"
             "EQUIPMENTNUMBER"
             "CODE"
             "NOMINAL SIZE"
	     "SCOPE"
             "REMARK"
             "REV"
             "SUPPLIER"
             "PRODUCT"
             "TYPE"
	     "SPECIFICATION 1"
	     "SPECIFICATION 2"

;;;             "TAG9"
;;;             "TAG10"
            )
    ) 
    (repeat (length header_list)
      (vlax-put-property
	cll
	"Item"
	row
	colm
	(vl-princ-to-string (strcat "'" (car header_list)))
      )
      (setq colm (1+ colm)
	    header_list
	     (cdr header_list)
      )
    )
    (setq row 7														;;Hier beginnen die Attributwerte
	  colm 1
    )
    (repeat (length exc_data)
      (setq data   (reverse (cdr (reverse (car exc_data))))
;;;	    subtot (last (car exc_data))
      )
      (repeat (length data)
	(setq info (car data))
	(repeat	(length info)
	  (vlax-put-property
	    cll
	    "Item"
	    row
	    colm
            (if (< colm 3)
	    (vl-princ-to-string (strcat "'" (car info)))
            (vl-princ-to-string (strcat "'" (cdar info)))
	      )
	  )
	  (setq colm (1+ colm))
	  (setq info (cdr info))
	)
        (setq data (cdr data))
	(
	setq row  (1+ row)
	      colm 1
	)
      )

;;;      (vlax-put-property
;;;	cll
;;;	"Item"
;;;	row
;;;	colm
;;;	(vl-princ-to-string (strcat "'" (car subtot)))
;;;      )
;;;      (setq colm (1+ colm))
;;;      (vlax-put-property
;;;	cll
;;;	"Item"
;;;	row
;;;	colm
;;;	(vl-princ-to-string (strcat "'" (cadr subtot)))
;;;      )

      (setq exc_data (cdr exc_data))
;;;      (setq row	 (1+ row)
;;;	    colm 1
;;;      )
    )

    (setq row  (1+ row)
	  colm 1
    )
    (vlax-put-property
      cll
      "Item"
      row
      colm
      (vl-princ-to-string (strcat "Total " blk "s :"))								;;Schreibt die Anzahl ans Ende der Liste
    )
    (setq colm (1+ colm))
    (vlax-put-property
      cll
      "Item"
      row
      colm
      (vl-princ-to-string tot)
    )
	(setq RangeStringAB (strcat "A7:B" (itoa row)))
	(setq AB (vlax-get-property csht "Range" RangeStringAB))
      	(vlax-put-property (vlax-get-property AB "Interior") "Colorindex" (vlax-make-variant 48))		;;Färbt die Spalten A und B grau ein

    	(setq RangeStringBorder (strcat "A1:M" (itoa row)))
        (setq BorderRang (vlax-get-property csht "Range" RangeStringBorder))
	(setq Bord (vlax-get-property BorderRang "Borders"))							;;Rahmenlinien
;;;      	(vlax-put-property Bord "Color" (vlax-make-variant -1 3)) ; borders off
      	(vlax-put-property Bord "Color" (vlax-make-variant 1 3)) ;borders on

	      
	(setq row  (1+ row)
	  colm 11
    	)
    	(setq lastrow  (1+ row))
	(vlax-put-property
		cll
		"Item"
		row
		colm
		(vl-princ-to-string "Handle and Blockname must not be changed\nColumns must not be changed or reordered")		;;Text im Tabellenende
  	)
	(setq RangeString (strcat "A" (itoa row) ":M" (itoa lastrow)))
	(setq EndRang (vlax-get-property csht "Range" RangeString))
	(setq EndRange (vlax-get-property csht "Range" RangeString))
;;;	(vlax-put-property EndRange "MergeCells" :vlax-true)
    	(vlax-put-property EndRange "Horizontalalignment" (vlax-make-variant -4131 3))
    	(vlax-put-property EndRange "VerticalAlignment" (vlax-make-variant -4108 3))
    	(setq EndFonto (vlax-get-property EndRang "Font"))							;;Formatierung des Tabellenendes
;;;    	(vlax-put-property EndFonto "Bold" (vlax-make-variant 1 11))
;;;    	(vlax-put-property EndFonto "Size" (vlax-make-variant 12 5))
;;;	(vlax-put-property EndFonto "Name" (vlax-make-variant "Aharoni" 12))
;;;    	(vlax-put-property EndFonto "Colorindex" (vlax-make-variant 41))
    	(vlax-put-property (vlax-get-property EndRange "Interior") "Colorindex" (vlax-make-variant 48))
;;;    	(setq EndBord (vlax-get-property EndRang "Borders"))
;;;    	(vlax-put-property EndBord "Color" (vlax-make-variant 1 3))
    	

    	(setq RangeStringWarning (strcat "K" (itoa row) ":M" (itoa row)))
	(setq WARNINGRang (vlax-get-property csht "Range" RangeStringWarning))
	(setq WARNING (vlax-get-property csht "Range" RangeStringWarning))					;;Warnung im Tabellenende
	(vlax-put-property WARNING "MergeCells" :vlax-true)
    	(vlax-put-property WARNING "WrapText" :vlax-true)
    	(vlax-put-property WARNING "RowHeight" (vlax-make-variant 25.5 3))

    	

    
   	(setq 	row 1
	  	colm 10
    	)
        (vlax-put-property
		cll
		"Item"
		row
		colm
		(vl-princ-to-string "ANDRITZ")
      	)
    	(setq ANDRITZRang (vlax-get-property csht "Range" "J1:M5"))
	(setq ANDRITZ (vlax-get-property csht "Range" "J1:M5"))
	(vlax-put-property ANDRITZ "MergeCells" :vlax-true)
    	(vlax-put-property ANDRITZ "Horizontalalignment" (vlax-make-variant -4108 3))
    	(vlax-put-property ANDRITZ "VerticalAlignment" (vlax-make-variant -4108 3))
;;;    	(setq ANDRITZLogo (vlax-Pictures-insert (""))
;;;    	(vlax-invoke-method (vlax-put-property ANDRITZRang "OLEObjects") "Add")
    	;;(vlax-put-property ANDRITZLogo "Insert")
    	(setq ANDRITZFonto (vlax-get-property ANDRITZRang "Font"))
    	(vlax-put-property ANDRITZFonto "Bold" (vlax-make-variant 1 11))					;;Andritz Schriftzug im Header
    	(vlax-put-property ANDRITZFonto "Size" (vlax-make-variant 48 5))
	(vlax-put-property ANDRITZFonto "Name" (vlax-make-variant "Aharoni" 12))
    	(vlax-put-property ANDRITZFonto "Colorindex" (vlax-make-variant 41))
;;;    	(vlax-put-property ANDRITZRang "ColumnWidth" (vlax-make-variant 40.0 3))
      
    
   	(setq 	row 1
	  	colm 5
    	)
        (vlax-put-property
		cll
		"Item"
		row
		colm
		(vl-princ-to-string (strcat blk " List"))
      	)
	(setq ListRang (vlax-get-property csht "Range" "E1:I5"))
;;;    	(setq ListRang (vlax-get-property csht "Range" StartRow StartCol EndRow EndCol))
	(setq LISTTYPE (vlax-get-property csht "Range" "E1:I5"))
;;;    	(setq LISTTYPE (vlax-get-property csht "Range" StartRow StartCol EndRow EndCol))
	(vlax-put-property LISTTYPE "MergeCells" :vlax-true)							;;Überschrift im Header je nach Blockname
    	(vlax-put-property LISTTYPE "Horizontalalignment" (vlax-make-variant -4108 3))
    	(vlax-put-property LISTTYPE "VerticalAlignment" (vlax-make-variant -4108 3))
    	(setq ListFonto (vlax-get-property ListRang "Font"))
    	(vlax-put-property ListFonto "Bold" (vlax-make-variant 1 11))
    	(vlax-put-property ListFonto "Size" (vlax-make-variant 24 5))


	(setq HeaderRang (vlax-get-property csht "Range" "A6:M6"))
	(setq HeaderRange (vlax-get-property csht "Range" "A6:M6"))
    	(setq HeaderFonto (vlax-get-property HeaderRang "Font"))						;;Formatierung der Spaltenüberschriften
    	(vlax-put-property HeaderFonto "Bold" (vlax-make-variant 1 11))
        (vlax-put-property (vlax-get-property HeaderRange "Interior") "Colorindex" (vlax-make-variant 48))





	(setq RightB (vlax-get-property csht "Range" "B1:B5"))
    	(vlax-put-property RightB "Horizontalalignment" (vlax-make-variant -4152 3))				;;Schriftausrichtung Header

	(setq RightD (vlax-get-property csht "Range" "D1:D5"))
    	(vlax-put-property RightD "Horizontalalignment" (vlax-make-variant -4152 3))

    
	(setq 	row 1
	  	colm 1
    	)
        (vlax-put-property
		cll
		"Item"
		row
		colm
		(vl-princ-to-string "Project:")
      	)

    	(setq 	row 2
	  	colm 1
    	)
        (vlax-put-property
		cll
		"Item"
		row
		colm
		(vl-princ-to-string "Project no.:")
      	)

    	(setq 	row 3
	  	colm 1
    	)
        (vlax-put-property
		cll
		"Item"
		row
		colm
		(vl-princ-to-string "Designation:")
      	)

	(setq 	row 4
	  	colm 1
    	)
        (vlax-put-property
		cll
		"Item"
		row
		colm
		(vl-princ-to-string "Created by:")
      	)
    
    	(setq 	row 5
	  	colm 1
    	)
        (vlax-put-property
		cll
		"Item"
		row
		colm
		(vl-princ-to-string "Creation date:")
      	)

    	(setq 	row 1
	  	colm 3
    	)
        (vlax-put-property
		cll
		"Item"
		row
		colm
		(vl-princ-to-string "Draw. No. AAG:")
      	)

    	(setq 	row 2
	  	colm 3
    	)
        (vlax-put-property
		cll
		"Item"
		row
		colm
		(vl-princ-to-string "Status:")
      	)

    	(setq 	row 3
	  	colm 3
    	)
        (vlax-put-property
		cll
		"Item"
		row
		colm
		(vl-princ-to-string "Rev:")
      	)

    	(setq 	row 4
	  	colm 3
    	)
        (vlax-put-property
		cll
		"Item"
		row
		colm
		(vl-princ-to-string "Checked by:")
      	)

    	(setq 	row 5
	  	colm 3
	)
        (vlax-put-property
		cll
		"Item"
		row
		colm
		(vl-princ-to-string "Check date:")
      	)


    
    (setq fcol (vlax-get-property csht 'UsedRange))
    (vlax-put-property fcol "NumberFormat" "@")
    (vlax-invoke (vlax-get-property csht "Columns") "AutoFit")    								;;Automatische Spaltenbreite
    (vlax-release-object cll)
    (vlax-release-object fcol)
    (vlax-release-object csht)
    (vlax-release-object sht)
    (vlax-release-object nwb)
    (vlax-release-object awb)
    (vlax-release-object aexc)

    (setq aexc nil)
    (setvar "osmode" osm)
    (setvar "cmdecho" 1)
    (vla-clear axss)
    (vlax-release-object axss)
    (vla-regen adoc acactiveviewport)
    (vla-endundomark adoc)
    (gc)
    (gc)
;;;    (alert "Save Excel manually as .xlsx !")
    (alert 	"Temporary .xls-file written to C:\TEMP
and opened in excel -> SEE MS EXCEL
Save excel sheet with 'Save As' as .xlsx
to your working folder to protect formatting!")											;;POPUP Message
    (princ)
    )
(princ "\n\t\t***\tStart command with LISTOUT...\t***")
(princ)