area capacity table
Accepted solution
Try this new version:
How to use:
Command: ACAP2
1. Select impoundment contours.
The program will only select polylines closed (2DPolyline and LWPolyline)
2. Pick normal water line.
3. Pick point to locate table.
4. Text Height for a table.
Attached Lisp File and DWG Testing
Here the code:
(vl-load-com)
;;********************************** C:ACAP2 **************************************;;
;; Jose L. García G. - 30/09/17 ;;
;; For forums.autodesk.com (djohnson and john.uhden) ;;
;; Description: Calulates area of polylines in acres, determins elevation, ;;
;; computes area-capacity table & creates object table in dwg. ;;
;;*********************************************************************************;;
(defun C:ACAP2 ( / *acad* *adoc* ActSpace filter sty_Tbl_Name *tableStyles* LstDatos PtTable NormalWaterLine
RowHeight ColWidth oCol *TableIns* nRow nCol Tot_ACCUM elevNWL NWL_ACCUM
;|functions|; MakeTableStyle jlgg-rtos GetDatosPols
)
;;____________________________________________________________;;
;; Collects and sorts data of polylines
(defun GetDatosPols ( / filter ss lstPols ACCUM LASTAREAR LASTELEV cnt TotDat)
;;Select closed polylines:
(prompt "\nSelect impoundment contours: ")
(setq filter '((0 . "*POLYLINE")(-4 . "<OR") (70 . 1)(70 . 129)(-4 . "OR>")))
(setq ss (vl-catch-all-apply 'ssget (list filter)))
(cond
((vl-catch-all-error-p ss))
((not ss)(prompt "\nNot select polylines.."))
(t
(setq lstPols (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq lstPols (mapcar (function vlax-ename->vla-object) lstPols))
(setq lstPols
(mapcar
(function (lambda (oPol) (cons (vla-get-Elevation oPol) oPol)))
lstPols
)
)
(setq lstPols
(vl-sort
lstPols
(function (lambda (pr1 pr2)(< (car pr1)(car pr2))))
)
)
(setq ACCUM 0.0)
(setq LASTAREAR 0.0)
(setq LASTELEV 0.0)
(setq cnt 0)
(mapcar
(function
(lambda (Elev-Pol / elev oPol area AreaR AvgArea Incr tmpLst1)
(setq oPol (cdr Elev-Pol))
(setq elev (car Elev-Pol))
(setq tmpLst1 (cons (cons "ELEV" elev) tmpLst1))
(setq area (vla-get-Area oPol))
(setq tmpLst1 (cons (cons "AREA" area) tmpLst1))
(setq AreaR (/ area 43560.0))
(setq tmpLst1 (cons (cons "AREAR" AreaR) tmpLst1))
(cond
((> cnt 0)
(setq AvgArea (/ (+ LASTAREAR AreaR) 2.0))
(setq tmpLst1 (cons (cons "AVGAREA" AvgArea) tmpLst1))
(setq Incr (* (- elev LASTELEV) AvgArea))
(setq tmpLst1 (cons (cons "INCR" Incr) tmpLst1))
(setq ACCUM (+ ACCUM Incr))
)
(T (setq cnt 1))
)
(setq tmpLst1 (cons (cons "ACCUM" ACCUM) tmpLst1))
(setq TotDat (append TotDat (list (reverse tmpLst1))))
(setq LASTAREAR AreaR)
(setq LASTELEV elev)
)
)
lstPols
);c.mapcar
)
);c.cond
TotDat
);c.defun
;;____________________________________________________________;;
;; rtos estable
(defun jlgg-rtos ( real units prec / dimzin result )
(if (not prec)(setq prec (getvar "luprec")))
(if (not units)(setq units (getvar "lunits")))
(setq dimzin (getvar 'dimzin))
(setvar 'dimzin 0)
(setq result (vl-catch-all-apply (function rtos) (list real units prec)))
(setvar 'dimzin dimzin)
(if (not (vl-catch-all-error-p result))
result
)
)
;;____________________________________________________________;;
;; Make Table Style
(defun MakeTableStyle (Alt_Txt NameStyTbl
/
*acad* *adoc* *TextStyles* *tableStyles* *tblTtxt* StyleTxt
dimscale$ TitleHTxt HeaderHTxt DataHTxt cellmarginV cellmarginH
TitleSuppressed HeaderSuppressed oStyTable oCol
)
(setq StyleTxt "TABLE_CAPACITY")
(vl-cmdf "_.style" StyleTxt "ROMANS" "0" "1" "0" "" "" "")
(setq *acad*(vlax-get-acad-object)
*adoc* (vla-get-activedocument *acad*)
*TextStyles* (vla-get-TextStyles *adoc*)
)
;;Datos de Estilo de Tabla
(setq dimscale$ 1.0);;(/ 1.0 (* 1000 (/ 1.0 Esc_Plot))))
(setq TitleHTxt (* (* Alt_Txt 1.75) dimscale$)
HeaderHTxt (* Alt_Txt dimscale$)
DataHTxt (* Alt_Txt dimscale$)
cellmarginV (* Alt_Txt 0.5 dimscale$)
cellmarginH (* Alt_Txt 0.75 dimscale$)
TitleSuppressed nil
HeaderSuppressed nil
)
(setq *tableStyles* (vla-item (vla-get-dictionaries *adoc*) "acad_tablestyle"))
;;Estylo de Tabla y diccionario de Tabla:
(setq oStyTable (vla-addObject *tableStyles* NameStyTbl "AcDbTableStyle"))
(cond
((vl-catch-all-error-p oStyTable)
(prompt (strcat "\nCould not create Table style: [" NameStyTbl "]."))
(setq oStyTable nil)
)
(T
;;propiedades de texto
(vla-SetTextHeight oStyTable acTitleRow TitleHTxt)
(vla-SetTextHeight oStyTable acHeaderRow HeaderHTxt)
(vla-SetTextHeight oStyTable acDataRow DataHTxt)
(vla-SetTextStyle oStyTable acHeaderRow StyleTxt)
(vla-SetTextStyle oStyTable acTitleRow StyleTxt)
(vla-SetTextStyle oStyTable acDataRow StyleTxt)
(vla-SetAlignment oStyTable acDataRow acBottomRight)
(vla-SetAlignment oStyTable (+ acTitleRow acHeaderRow) acMiddleCenter)
(vla-put-Vertcellmargin oStyTable cellmarginV)
(vla-put-Horzcellmargin oStyTable cellmarginH)
(vla-put-TitleSuppressed oStyTable (if TitleSuppressed :vlax-false :vlax-true))
(vla-put-HeaderSuppressed oStyTable (if HeaderSuppressed :vlax-false :vlax-true))
;;fondos y color
(setq oCol (vla-getinterfaceobject
(vlax-get-acad-object)
(strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
;;Titulo:
(vla-put-ColorMethod oCol acColorMethodByRGB)
(vla-SetRGB oCol 163 163 163)
(vla-SetBackgroundColor oStyTable acTitleRow oCol)
(vla-SetRGB oCol 255 255 255)
(vla-SetColor oStyTable acTitleRow oCol)
;;Encabezados
(vla-SetRGB oCol 222 222 222)
(vla-SetBackgroundColor oStyTable acHeaderRow oCol)
(vla-SetRGB oCol 28 28 28)
(vla-SetColor oStyTable acHeaderRow oCol)
;;Datos
(vla-SetBackgroundColorNone oStyTable acDataRow :vlax-true)
(vla-put-ColorMethod oCol acColorMethodByACI)
(vla-put-ColorIndex oCol 7)
(vla-SetColor oStyTable acDataRow oCol)
)
);c.cond
oStyTable
)
;;--------------------------- MAIN PROGRAM -------------------------------
(or *Alt_Txt_Table* (setq *Alt_Txt_Table* 3.0))
(setq *acad* (vlax-get-acad-object)
*adoc* (vla-get-activedocument *acad*)
ActSpace (vlax-get-property *adoc* (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace))
)
(setq filter '((0 . "*POLYLINE")(-4 . "<OR") (70 . 1)(70 . 129)(-4 . "OR>")))
;;____________________________________________
(cond
((not (setq LstDatos (GetDatosPols))))
((and (not (prompt "\nPick normal water line: "))
(vl-catch-all-error-p
(setq NormalWaterLine (vl-catch-all-apply 'ssget (list "_:S:E" Filter))))
)
)
((not NormalWaterLine)(prompt "\nNo select normal water line."))
((vl-catch-all-error-p
(setq PtTable (vl-catch-all-apply 'getpoint (list "\nPick point to locate table: ")))
)
)
((not PtTable)(prompt "\nNo point has been indicated."))
((and (not (initget (+ 2 4)))
(vl-catch-all-error-p
(setq Tmp (vl-catch-all-apply 'getdist
(list (strcat "\nText Height: <" (jlgg-rtos *Alt_Txt_Table* nil nil) ">: "))))
)
)
)
(T
(if Tmp (setq *Alt_Txt_Table* Tmp))
(setq NormalWaterLine (ssname NormalWaterLine 0)
NormalWaterLine (vlax-ename->vla-object NormalWaterLine))
(setq elevNWL (vla-get-elevation NormalWaterLine))
(setq sty_Tbl_Name (strcat "TBL_HTxt_" (jlgg-rtos *Alt_Txt_Table* 2 2)))
(setq *tableStyles* (vla-item
(vla-get-dictionaries
(vla-get-activedocument (vlax-get-acad-object))) "acad_tablestyle"))
(if (vl-catch-all-error-p
(setq oStyTable (vl-catch-all-apply 'vla-item (list *tableStyles* sty_Tbl_Name)))
)
(setq oStyTable (MakeTableStyle *Alt_Txt_Table* sty_Tbl_Name))
)
(cond
((not oStyTable))
(T ;;Create table:
(vla-startundomark *adoc*)
(setq oCol (vla-getinterfaceobject
(vlax-get-acad-object)
(strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
(setq RowHeight (* *Alt_Txt_Table* 3.0))
(setq ColWidth (* *Alt_Txt_Table* 10.0))
;;Insert Table
(setq *TableIns* (vla-addTable ActSpace (vlax-3d-point PtTable) 4 7 RowHeight ColWidth))
(vla-put-regeneratetablesuppressed *TableIns* :vlax-true)
(vla-put-StyleName *TableIns* sty_Tbl_Name)
;;Title:
(vla-setText *TableIns* 0 0 "AREA CAPACITY TABLE")
;;Headers:
(vla-MergeCells *TableIns* 1 2 0 0)
(vla-setText *TableIns* 1 0 "CAPACITY")
(vla-MergeCells *TableIns* 1 2 1 1)
(vla-setText *TableIns* 1 1 "ELEVATION\n\n(ft)")
(vla-MergeCells *TableIns* 1 2 2 2)
(vla-setText *TableIns* 1 2 "AREA\n\n(ac)")
(vla-MergeCells *TableIns* 1 2 3 3)
(vla-setText *TableIns* 1 3 "AVG.\nAREA\n(ac)")
(vla-SetCellStyle *TableIns* 2 4 "_HEADER");"_DATA"
(vla-SetCellStyle *TableIns* 2 5 "_HEADER")
(vla-MergeCells *TableIns* 1 1 4 5)
(vla-setText *TableIns* 1 4 "CAPACITY (ac-ft)")
(vla-setText *TableIns* 2 4 "INCR.")
(vla-setText *TableIns* 2 5 "ACCUM.")
(vla-MergeCells *TableIns* 1 2 6 6)
(vla-setText *TableIns* 1 6 "INDUSTRIAL\nPOLLUTION\nCONTROL")
;;Datos:
(setq nRow 3 nCol 1)
(vla-insertrows *TableIns* nRow RowHeight (1- (length LstDatos)))
(mapcar
(function
(lambda (lData / nCol ELEV AREA AREAR AVGAREA INCR ACCUM)
;;lData = (("ELEV" . 6806.0) ("AREA" . 77248.7) ("AREAR" . 1.77339)
;; ("AVGAREA" . 1.71588) ("INCR" . 3.43176) ("ACCUM" . 3.43176))
(setq nCol 1)
(mapcar (function (lambda (pair) (set (read (car pair))(cdr pair)))) lData)
(if (equal elevNWL ELEV 1.0e-04)
(setq nRowNWL nRow
NWL_ACCUM ACCUM)
)
;;
(vla-setCellValue *TableIns* nRow nCol ELEV)
(vla-SetCellDataType *TableIns* nRow nCol acDouble acUnitless)
(vla-SetCellFormat *TableIns* nRow nCol "%lu2%pr1")
;;
(vla-setCellValue *TableIns* nRow (+ nCol 1) AREAR)
(vla-SetCellDataType *TableIns* nRow (+ nCol 1) acDouble acUnitless)
(vla-SetCellFormat *TableIns* nRow (+ nCol 1) "%lu2%pr2")
;;
(if AVGAREA
(progn
(vla-setCellValue *TableIns* nRow (+ nCol 2) AVGAREA)
(vla-SetCellDataType *TableIns* nRow (+ nCol 2) acDouble acUnitless)
(vla-SetCellFormat *TableIns* nRow (+ nCol 2) "%lu2%pr2")
)
)
;;;
(if INCR
(progn
(vla-setCellValue *TableIns* nRow (+ nCol 3) INCR)
(vla-SetCellDataType *TableIns* nRow (+ nCol 3) acDouble acUnitless)
(vla-SetCellFormat *TableIns* nRow (+ nCol 3) "%lu2%pr2")
)
)
;;
(vla-setCellValue *TableIns* nRow (+ nCol 4) ACCUM)
(vla-SetCellDataType *TableIns* nRow (+ nCol 4) acDouble acUnitless)
(vla-SetCellFormat *TableIns* nRow (+ nCol 4) "%lu2%pr2")
;;
(setq Tot_ACCUM ACCUM)
(setq nRow (1+ nRow))
)
)
LstDatos
);c.mapcar
(setq nRowTot (1- nRow))
(vla-put-ColorMethod oCol acColorMethodByRGB)
(vla-SetRGB oCol 255 117 117)
;;
;(vla-setText *TableIns* nRowNWL 0 "<--->")
(vla-SetCellGridVisibility *TableIns* nRowNWL 0 (+ acBottomMask acTopMask) :vlax-false)
(vla-setcellalignment *TableIns* nRowNWL 0 acMiddleCenter)
(vla-SetCellBackgroundColor *TableIns* nRowNWL 0 oCol)
;;
;(vla-setText *TableIns* nRowNWL 6 "<--->")
(vla-SetCellGridVisibility *TableIns* nRowNWL 6 (+ acBottomMask acTopMask) :vlax-false)
(vla-setcellalignment *TableIns* nRowNWL 6 acMiddleCenter)
(vla-SetCellBackgroundColor *TableIns* nRowNWL 6 oCol)
;;
(vla-put-ColorMethod oCol acColorMethodByACI)
(cond
((not (vl-catch-all-error-p
(vl-catch-all-apply 'vla-MergeCells (list *TableIns* 3 (1- nRowNWL) 0 0))))
(vla-put-ColorIndex oCol 1)
(vla-setText *TableIns* 3 0 (strcat "INACTIVE\n" (jlgg-rtos NWL_ACCUM 2 2) " ac-ft"))
(vla-SetCellTextHeight *TableIns* 3 0 (* *Alt_Txt_Table* 0.75))
(vla-setcellalignment *TableIns* 3 0 acMiddleCenter)
(vla-SetCellContentColor *TableIns* 3 0 oCol)
;;
(vla-MergeCells *TableIns* 3 (1- nRowNWL) 6 6)
(vla-setText *TableIns* 3 6
(strcat "SEDIMENT\nSTORAGE\n" (jlgg-rtos NWL_ACCUM 2 2) " ac-ft")
)
(vla-SetCellTextHeight *TableIns* 3 6 (* *Alt_Txt_Table* 0.75))
(vla-setcellalignment *TableIns* 3 6 acMiddleCenter)
(vla-SetCellContentColor *TableIns* 3 6 oCol)
)
)
(cond
((not (vl-catch-all-error-p
(vl-catch-all-apply 'vla-MergeCells (list *TableIns* (1+ nRowNWL) nRowTot 0 0))))
(vla-put-ColorIndex oCol 3)
(vla-setText *TableIns* (1+ nRowNWL) 0
(strcat "ACTIVE\n" (jlgg-rtos (- Tot_ACCUM NWL_ACCUM) 2 2) " ac-ft")
)
(vla-SetCellTextHeight *TableIns* (1+ nRowNWL) 0 (* *Alt_Txt_Table* 0.75))
(vla-setcellalignment *TableIns* (1+ nRowNWL) 0 acMiddleCenter)
(vla-SetCellContentColor *TableIns* (1+ nRowNWL) 0 oCol)
;;
(vla-MergeCells *TableIns* (1+ nRowNWL) nRowTot 6 6)
(vla-setText *TableIns* (1+ nRowNWL) 6
(strcat "DUST\nABATEMENT\n" (jlgg-rtos (- Tot_ACCUM NWL_ACCUM) 2 2) " ac-ft")
)
(vla-SetCellTextHeight *TableIns* (1+ nRowNWL) 6 (* *Alt_Txt_Table* 0.75))
(vla-setcellalignment *TableIns* (1+ nRowNWL) 6 acMiddleCenter)
(vla-SetCellContentColor *TableIns* (1+ nRowNWL) 6 oCol)
)
)
(vla-put-regeneratetablesuppressed *TableIns* :vlax-false)
(vla-endundomark *adoc*)
);Create table.
);c.cond
)
);c.cond
(princ)
);c.defun
regards
