Jump to content

CAN YOU HELP ABOUT LISP


hmtpk

Recommended Posts

 

 

The ahmktable is my code so that part is easy to comment about.

 

(setq numcolumns 5) change 5 to 7.

 

(vla-settext objtable 1 0 "NO") 
(vla-settext objtable 1 1 "LINETYPE")
(vla-settext objtable 1 2 "LAYER COLOR")
(vla-settext objtable 1 3 "LAYER NAME") 
(vla-settext objtable 1 4 "LENGTH")
(vla-settext objtable 1 5 "HEIGHT")
(vla-settext objtable 1 6 "AREA")
(vla-Setcolumnwidth Objtable  0 50)
(vla-Setcolumnwidth Objtable  1 400)
(vla-Setcolumnwidth Objtable  2 400)
(vla-Setcolumnwidth Objtable  3 400)
(vla-Setcolumnwidth Objtable  4 100)
(vla-Setcolumnwidth Objtable  5 100)
(vla-Setcolumnwidth Objtable  6 150)

 

You need to look for linetype in cell 

(setq col laycol) ; layer color 1-254 RGB done similar VLA-set-rgb
(setq acm (vla-getinterfaceobject (vlax-get-acad-object) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
(vla-put-colorindex acm laycol)
(vla-setcellbackgroundcolor obj 2 2 acm) ; obj row col acm

 

NOT TESTED.

  • Like 1
Link to comment
Share on other sites

 

Yes, Mr. Bigal. The code is your code. Thank you again. I made the changes you mentioned, but it didn't work. Could you please make the changes in Lisp and publish them.

Link to comment
Share on other sites

12 hours ago, hmtpk said:

I made the changes you mentioned, but it didn't work.

@hmtpk Please could you upload your list with the modification you did? 

 

I made some modifications but I do not know how to set the cell at column 2 to show the LINE with  it's LINETYPE 

 

image.thumb.png.61e7cc7b9d9fbc0dd477896b1c734a95.png

 

(repeat (setq x (length lst2))
(setq itlst (nth i lst2))
(vla-settext objtable 0 0 "KALIP METRAJ   [ m² ]"); TABLE TITLE

(vla-settext objtable 1 0 "NO") 
(vla-settext objtable 1 1 "LINETYPE")
              
(vla-settext objtable 1 2 "LAYER COLOUR")
            
  
(vla-settext objtable 1 3"LAYER NAME")
            
(vla-settext objtable 1 4 "LENGTH")
            
(vla-settext objtable 1 5 "HEIGHT")
(vla-settext objtable 1 6 "AREA")
  
(vla-SetTextHeight Objtable (+ acDataRow acTitleRow acHeaderRow) 12)
(VLA-SETCOLUMNWIDTH OBJTABLE 0 50)
(VLA-SETCOLUMNWIDTH OBJTABLE 1 150)
(VLA-SETCOLUMNWIDTH OBJTABLE 2 200)
(VLA-SETCOLUMNWIDTH OBJTABLE 3 400)
(VLA-SETCOLUMNWIDTH OBJTABLE 4 100)
(VLA-SETCOLUMNWIDTH OBJTABLE 5 100)
(VLA-SETCOLUMNWIDTH OBJTABLE 6 150)

(setq col laycol) ; layer color 1-254 RGB done similar VLA-set-rgb
 ;(setq layer ( vla-item lay-coll (CAR ITLST)))
  (setq layer-data(tblsearch "layer" (CAR ITLST)))
  
  ;(setq col (vla-get-TrueColor layer))
  (setq col (cdr (assoc 62 layer-data)))
(setq acm (vla-getinterfaceobject (vlax-get-acad-object) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
(vla-put-colorindex acm col)

  
(vla-settext objtable  row 0 (rtos no 2 0))
  
;;;(vla-settext objtable  row 1               )
  (vla-setcellbackgroundcolor OBJTABLE 2 2 acm) ; obj row col acm

(VLA-SETTEXT OBJTABLE ROW 3 (CAR ITLST))
(VLA-SETTEXT OBJTABLE ROW 4 (RTOS (CADR ITLST) 2 3))
(VLA-SETTEXT OBJTABLE ROW 5 (RTOS (CADDR ITLST) 2 3))
(VLA-SETTEXT OBJTABLE ROW 6 (RTOS (* (CADR ITLST) (CADDR ITLST)) 2 3))


(setq voltot (+ (*(cadr itlst)(caddr itlst)) voltot))
(setq row (+ row 1))
(setq i (+ i 1))
(setq no (+ no 1))
)

 

 

 

 

Link to comment
Share on other sites

You can set background color & insert a block into a cell, not sure about a line in a cell.

 

May need to get the properties of the cell somehow, the box values and just draw a line. It may need to be worked out from 1st principles like row & column size values. The title row can be made bigger than the data rows. 

 

The top left corner is the table insert point, you picked so the X and -Y from it to work out where a line would be drawn.

 

y =pty - (1st height+row height+1/2 row height). Next row subtract row height from y.

x1=ptx + col 0 width+say2

x2=ptx + col 0 width+ col 1width - say 2

This should match you table

 

Post the updated code that you said did not work. It is better to see what was wrong and make corrections, then you learn.

Edited by BIGAL
Link to comment
Share on other sites

37 minutes ago, BIGAL said:

Post the updated code that you said did not work

@BIGAL The code is as I put , you can see I comment this line 

 

;;;(vla-settext objtable  row 1               )

 

because I can not get the way to put a LINE at ROW and column 1 . 

 

As it is show here.

 

image.png.f2533523c418b09440a78acded9162f8.png

 

It have no error , just a way to put a LINE at that CELL

 

I think a option to put a TEXT "___________" by underscore and then justify to fit a the cell center 

 

image.png.02daafbbbd3830ba45c10b044f1d66c6.png

 

(vla-settext objtable  row 1   "___________"            )

 

 

 

table with text as LINE.dwg

Link to comment
Share on other sites

Nice idea but what about -----G------ time to go and have a beer at fishing club will look into the draw a line in a cell note its exactly that a line nothing to do with a table.

  • Like 2
Link to comment
Share on other sites

Sorry lost the link I was trying to find it the title did not help if it had Table in it would have found sooner.

 

image.thumb.png.7f4e22fe61afd9e66f0d84221d9f4c1e.png

 

It only seems to do 1 layer.

; https://www.cadtutor.net/forum/topic/77165-can-you-help-about-lisp/

;;---------------------=={ Total Area }==---------------------;;
;;                                                            ;;
;;  Displays the total area of selected objects at the        ;;
;;  command line. The precision of the printed result is      ;;
;;  dependent on the setting of the LUPREC system variable.   ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2013 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;

; Total area modified by Alanh to allow multiple pick by layer
; uses height in layer name for volume expect metric
; Nov 2019

; Added a linetype to cells
; Added a layer color to cells
; BY AlanH April 2023

;; Parse Numbers  -  Lee Mac
;; Parses a list of numerical values from a supplied string.
;;  Author: Lee Mac, Copyright © 2013 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;

(defun LM:parsenumbers ( str )
    (   (lambda ( l )
            (read
                (strcat "("
                    (vl-list->string
                        (mapcar
                           '(lambda ( a b c )
                                (if (or (< 47 b 58)
                                        (and (= 45 b) (< 47 c 58) (not (< 47 a 58)))
                                        (and (= 46 b) (< 47 a 58) (< 47 c 58))
                                    )
                                    b 32
                                )
                            )
                            (cons nil l) l (append (cdr l) '(()))
                        )
                    )
                    ")"
                )
            )
        )
        (vl-string->list str)
    )
)


(defun ahdodrawline (llayer crow lcol / pt pt1 pt2 vdist acm )
(setq pts (vlax-safearray->list (vlax-variant-value (VLA-GETCELLEXTENTS objtable (+ crow 1) 1 :vlax-false))))
(setq pt1 (list (nth 0 pts)(nth 1 pts) 0.0))
(setq pt2 (list (nth 6 pts)(nth 7 pts) 0.0))
(setq vdist (/ (- (cadr pt1) (cadr pt2)) 2.0))
(setq pt1 (mapcar '+ pt1 (list 10.0 vdist 0.0)))
(setq pt2 (list (nth 3 pts)(nth 4 pts) 0.0))
(setq pt2 (mapcar '+ pt2 (list (- 10.0) vdist 0.0)))
(command "line" pt1 pt2 "")
(command "chprop" (entlast) "" "la" llayer "")
(setq acm (vla-getinterfaceobject (vlax-get-acad-object) (strcat "Autocad.AcCmcolor." (substr (getvar 'acadver) 1 2))))
(vla-put-colorindex acm lcol)
(vla-setcellbackgroundcolor objtable row 2 acm)
(princ)
)


(defun ahmktable ( numr / colwidth numcolumns numrows rowheight sp vgad vgao vgms)
(vl-load-com)
(setq sp (vlax-3d-point (getpoint "select point for table")))
(Setq vgms (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))) ;
(setq numrows numr)
(setq numcolumns 7)
(setq rowheight 40)
(setq colwidth 200)
(setq objtable (vla-addtable vgms sp numrows numcolumns rowheight colwidth))
(vla-settext objtable 0 0 "KALIP METRAJ   [ m² ]"); TABLE TITLE
(vla-settext objtable 1 0 "NO") 
(vla-settext objtable 1 1 "LINETYPE")
(vla-settext objtable 1 2 "COLOR")
(vla-settext objtable 1 3 "LAYER NAME") 
(vla-settext objtable 1 4 "LENGTH")
(vla-settext objtable 1 5 "HEIGHT")
(vla-settext objtable 1 6 "AREA")
(vla-SetTextHeight Objtable (+ acDataRow acTitleRow acHeaderRow) 12)
(vla-Setcolumnwidth Objtable  0 50)
(vla-Setcolumnwidth Objtable  1 100)
(vla-Setcolumnwidth Objtable  2 100)
(vla-Setcolumnwidth Objtable  3 400)
(vla-Setcolumnwidth Objtable  4 100)
(vla-Setcolumnwidth Objtable  5 100)
(vla-Setcolumnwidth Objtable  6 150)
(princ)
)

(defun c:klp ( / a i s ent lay ht objtable lst lst2 lst3 x voltot num row col)


(setq oldsnap (getvar 'osmode))
(setvar 'osmode 0)
(prompt "select plines")

(setq s (ssget  (list (cons 0  "LWPOLYLINE,LINE,ARC"))))

(setq lst '())
(repeat (setq x (sslength s))
(setq ent (entget (ssname s (setq x (- x 1)))))
(setq lay (cdr (assoc 8 ent)))
(setq lst (cons lay lst))

)
(setq lst (vl-sort lst  '(lambda (x y) (< x y))))

(setq lst3 '())
(setq x 0)
(repeat (-(length lst) 1)
(if (= (nth x lst)(nth (setq x (+ x 1)) lst))
(princ )
(setq lst3 (cons (nth (- x 1) lst) lst3))
)
)
(setq lst3 (cons (nth (-(length lst) 1) lst) lst3))

(setq lst2 '())
(repeat (setq x (length lst3))
    (setq lay  (nth (setq x (- x 1)) lst3))
    (setq ht (/ (nth 0 (LM:parsenumbers lay)) 1.0))
    (if (= (substr lay 1 1) "H")(setq ht (abs ht)))
    (if s
        (progn
            (setq a 0.0)
            (repeat (setq i (sslength s))
	       (setq e (ssname s (setq i (1- i))))
	        (if (= lay (cdr (assoc 8 (entget e))))
			(progn
	         (setq a (+ a (vla-get-length (vlax-ename->vla-object e))))
			 (setq col (vla-get-color (vlax-ename->vla-object e)))
			 (if (= col 256)
			 (setq col (cdr (assoc 62 (tblsearch "LAYER" lay))))
			 )
			 )
            )
			)
             (setq a (/ a 100))
        )
    )
   (setq lst2 (cons (list lay a ht col) lst2))
)

(ahmktable  (+ (length lst2) 3))

(setq voltot 0)
(setq num 1)
(setq row 2)
(setq i 0)

(repeat (setq x (length lst2))
(setq itlst (nth i lst2))
(vla-settext objtable  row 0 (rtos num 2 0))
(vla-settext objtable  row 3 (nth 0 itlst))
(vla-settext objtable  row 4 (rtos (nth 1 itlst) 2 3))
(vla-settext objtable  row 5 (rtos (nth 2 itlst) 2 3))
(vla-settext objtable  row 6 (rtos (*(nth 1 itlst)(nth 2 itlst)) 2 3))
;(alert "color is nth 3")

(ahdodrawline (nth 0 itlst) row (nth 3 itlst))
(setq num (1+ num))
(setq voltot (+ (* (nth 1 itlst)(nth 2 itlst)) voltot))
(setq row (+ row 1))
(setq i (+ i 1))
)


(vla-mergecells objtable (+ (length lst2) 2) (+ (length lst2) 2) 0 5)
(vla-settext objtable (+ (length lst2) 2) 0 "TOTAL AREA ")
(vla-settext objtable  (+ (length lst2) 2)  6 (rtos voltot 2 3))

(princ)
)
(C:KLP)

 

 

Edited by BIGAL
Link to comment
Share on other sites

Thank you for your interest, Mr. Bigal. Lisp works, but as you said, it only shows 1 layer. Is it possible to see all layers in the table at the same time?

Link to comment
Share on other sites

Wiil have a look I only added color and linetype so will see what original code does on a multi layer dwg. It may be totaling column 5 instead of column 7.

Link to comment
Share on other sites

Updated code please try.

 

; https://www.cadtutor.net/forum/topic/77165-can-you-help-about-lisp/

;;---------------------=={ Total Area }==---------------------;;
;;                                                            ;;
;;  Displays the total area of selected objects at the        ;;
;;  command line. The precision of the printed result is      ;;
;;  dependent on the setting of the LUPREC system variable.   ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2013 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;

; Total area modified by Alanh to allow multiple pick by layer
; uses height in layer name for volume expect metric
; Nov 2019

; Added Linetype in cell 
; Added color of layer to cell
; By AlanH April 2023

;; Parse Numbers  -  Lee Mac
;; Parses a list of numerical values from a supplied string.
;;  Author: Lee Mac, Copyright © 2013 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;

(defun LM:parsenumbers ( str )
    (   (lambda ( l )
            (read
                (strcat "("
                    (vl-list->string
                        (mapcar
                           '(lambda ( a b c )
                                (if (or (< 47 b 58)
                                        (and (= 45 b) (< 47 c 58) (not (< 47 a 58)))
                                        (and (= 46 b) (< 47 a 58) (< 47 c 58))
                                    )
                                    b 32
                                )
                            )
                            (cons nil l) l (append (cdr l) '(()))
                        )
                    )
                    ")"
                )
            )
        )
        (vl-string->list str)
    )
)


(defun ahdodrawline (llayer crow lcol / pt pt1 pt2 vdist acm )
(setq pts (vlax-safearray->list (vlax-variant-value (VLA-GETCELLEXTENTS objtable (+ crow 1) 1 :vlax-false))))
(setq pt1 (list (nth 0 pts)(nth 1 pts) 0.0))
(setq pt2 (list (nth 6 pts)(nth 7 pts) 0.0))
(setq vdist (/ (- (cadr pt1) (cadr pt2)) 2.0))
(setq pt1 (mapcar '+ pt1 (list 10.0 vdist 0.0)))
(setq pt2 (list (nth 3 pts)(nth 4 pts) 0.0))
(setq pt2 (mapcar '+ pt2 (list (- 10.0) vdist 0.0)))
(command "line" pt1 pt2 "")
(command "chprop" (entlast) "" "la" llayer "")
(setq acm (vla-getinterfaceobject (vlax-get-acad-object) (strcat "Autocad.AcCmcolor." (substr (getvar 'acadver) 1 2))))
(vla-put-colorindex acm lcol)
(vla-setcellbackgroundcolor objtable row 2 acm)
(princ)
)


(defun ahmktable ( numr / colwidth numcolumns numrows rowheight sp vgad vgao vgms)
(vl-load-com)
(setq sp (vlax-3d-point (getpoint "select point for table")))
(Setq vgms (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))) ;
(setq numrows numr)
(setq numcolumns 7)
(setq rowheight 40)
(setq colwidth 200)
(setq objtable (vla-addtable vgms sp numrows numcolumns rowheight colwidth))
(vla-settext objtable 0 0 "KALIP METRAJ   [ m² ]"); TABLE TITLE
(vla-settext objtable 1 0 "NO") 
(vla-settext objtable 1 1 "LINETYPE")
(vla-settext objtable 1 2 "COLOR")
(vla-settext objtable 1 3 "LAYER NAME") 
(vla-settext objtable 1 4 "LENGTH")
(vla-settext objtable 1 5 "HEIGHT")
(vla-settext objtable 1 6 "AREA")
(vla-SetTextHeight Objtable (+ acDataRow acTitleRow acHeaderRow) 12)
(vla-Setcolumnwidth Objtable  0 50)
(vla-Setcolumnwidth Objtable  1 100)
(vla-Setcolumnwidth Objtable  2 100)
(vla-Setcolumnwidth Objtable  3 400)
(vla-Setcolumnwidth Objtable  4 100)
(vla-Setcolumnwidth Objtable  5 100)
(vla-Setcolumnwidth Objtable  6 150)
(princ)
)

(defun c:klp ( / a i s ent lay ht objtable lst lst2 lst3 x voltot num row col)


(setq oldsnap (getvar 'osmode))
(setvar 'osmode 0)
(prompt "select plines")

(setq s (ssget  (list (cons 0  "LWPOLYLINE,LINE,ARC"))))

(setq lst '())
(repeat (setq x (sslength s))
(setq ent (entget (ssname s (setq x (- x 1)))))
(setq lay (cdr (assoc 8 ent)))
(setq lst (cons lay lst))

)
(setq lst (vl-sort lst  '(lambda (x y) (< x y))))

(setq lst3 '())
(setq x 0)
(repeat (-(length lst) 1)
(if (= (nth x lst)(nth (setq x (+ x 1)) lst))
(princ )
(setq lst3 (cons (nth (- x 1) lst) lst3))
)
)
(setq lst3 (cons (nth (-(length lst) 1) lst) lst3))

(setq lst2 '())
(repeat (setq x (length lst3))
    (setq lay  (nth (setq x (- x 1)) lst3))
    (setq ht (/ (nth 0 (LM:parsenumbers lay)) 1.0))
    (if (= (substr lay 1 1) "H")(setq ht (abs ht)))
    (if s
        (progn
            (setq a 0.0)
            (repeat (setq i (sslength s))
	       (setq e (ssname s (setq i (1- i))))
	        (if (= lay (cdr (assoc 8 (entget e))))
			(progn
	         (setq a (+ a (vla-get-length (vlax-ename->vla-object e))))
			 (setq col (vla-get-color (vlax-ename->vla-object e)))
			 (if (= col 256)
			 (setq col (cdr (assoc 62 (tblsearch "LAYER" lay))))
			 )
			 )
            )
			)
             (setq a (/ a 100))
        )
    )
   (setq lst2 (cons (list lay a ht col) lst2))
)

(ahmktable  (+ (length lst2) 3))

(setq voltot 0)
(setq num 1)
(setq row 2)
(setq i 0)

(repeat (setq x (length lst2))
(setq itlst (nth i lst2))
(vla-settext objtable  row 0 (rtos num 2 0))
(vla-settext objtable  row 3 (nth 0 itlst))
(vla-settext objtable  row 4 (rtos (nth 1 itlst) 2 3))
(vla-settext objtable  row 5 (rtos (nth 2 itlst) 2 3))
(vla-settext objtable  row 6 (rtos (*(nth 1 itlst)(nth 2 itlst)) 2 3))
;(alert "color is nth 3")

(ahdodrawline (nth 0 itlst) row (nth 3 itlst))
(setq num (1+ num))
(setq voltot (+ (* (nth 1 itlst)(nth 2 itlst)) voltot))
(setq row (+ row 1))
(setq i (+ i 1))
)


(vla-mergecells objtable (+ (length lst2) 2) (+ (length lst2) 2) 0 5)
(vla-settext objtable (+ (length lst2) 2) 0 "TOTAL AREA ")
(vla-settext objtable  (+ (length lst2) 2)  6 (rtos voltot 2 3))
(setvar 'osmode oldsnap)
(princ)
)
(C:KLP)

 

Some areas are -ve are they meant to be added to total as a positive number ?

Edited by BIGAL
Link to comment
Share on other sites

Mr. Bigal, your work has been great.congratulations.fields will not be added to the sum positive.now the lisp is working perfectly.if it is poyline in the project, it assigns it as a line to the linetype section of the table.polyline in the project and polyline in the table.can this be done?

It also resets the osnap settings settings. Can this be fixed?

Edited by hamit
Link to comment
Share on other sites

Change this forgot to do it down at end of code.

 

(vla-settext objtable  (+ (length lst2) 2)  6 (rtos voltot 2 3))
(setvar 'osmode oldsnap)
(princ)

 

Link to comment
Share on other sites

Hello ; First of all, thank you for your attention. I still have the problem of closing the osnap settings when Lisp is running. Also, I request that the polylines in the orije be thrown into the table as polylines, not lines.

Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • Create New...