Jump to content

ARES Commander LISP not Working

khrys

By khrys
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

khrys Newbie

khrys

Posted
Posted (edited)

can anyone help me with this, this lisp work in autocad perfectly but i want to use this to ares but it doesn't work 

  

(defun c:KKK ( / TBName TBTemp s flag ctr SheetSize chk PrjName LaynName i n e x 1p 2p o1p o2p y1p y2p s1 i1 n1 e1 x1 s2 i2 n2 e2 x2 Psize Size file tempViewName DwgTitle )
  
  (setvar "CMDECHO" 0)

  (setq TBName "Title Block_R2.R")
  (setq TBTemp "FT NEW TEMPLATE 2.0")
  (setq s nil)
  (setq flag 1)
  (setq ctr 1)
  (setq SheetSize nil)
  (setq chk nil)
  (setq LaynName (car (layoutlist)))
  (setq DwgTitle "Title_info")
  (setq tempViewName "_TEMP_ORIGINAL_VIEW")
  
  (if (setq s (ssget (list '(0 . "INSERT") )))
        (progn
            (command "-VIEW" "S" tempViewName)
            (setq chk T)
            (setq i 0
                  n (sslength s)
            )
            (while (< i n)
                (setq e (ssname s i)
                      x (cdr (assoc 2 (entget e)))
                      i (1+ i)
                )
              ;(print x)
                (if (= (LM:name->effectivename x) TBName )
                  (progn
                    (command "_zoom" "_object" (cdr(car(entget e))) "")
                    (setq 1P (car(LM:boundingbox (vlax-ename->vla-object (cdr(car(entget e)))))))
                    (setq 2P (nth 2 (LM:boundingbox (vlax-ename->vla-object (cdr(car(entget e)))))))
                    (setq o1P 1P)
                    (setq o2P 2P)
                    (setq y1p (strcat (rtos (car 1P) 2 0) "," (rtos (car (cdr 2P)) 2 0)))
                    (setq y2p y1p)
                    
                    (setq s1 (ssget "W" 1P 2P (list '(0 . "INSERT") )))
                    
                                (setq i1 0
                                      n1 (sslength s1)
                                )
                                (while (< i1 n1)
                                  (setq e1 (ssname s1 i1)
                                      x1 (cdr (assoc 2 (entget e1)))
                                      i1 (1+ i1)
                                  )
                                  
                                  (if (= (cdr (assoc 0 (entget e1))) "INSERT")
                                    (cond 
                                      ((= (LM:getvisibilitystate (vlax-ename->vla-object (cdr (car (entget e1))))) "NESTED")
                                        (setq SheetSize (LM:assoc++ (setq Size (strcat (LM:getattributevalue (cdr (car(entget e1))) "SHEET_WIDTH") "X" (LM:getattributevalue (cdr (car(entget e1))) "SHEET_HEIGHT"))) SheetSize))
                                        (setq PSize (assoc Size SheetSize))
                                        (setq Psize (strcat (car Psize)"-" (fixitoa (cdr Psize) 2)))
                                        
                                      )
                                      ((= (LM:getvisibilitystate (vlax-ename->vla-object (cdr (car (entget e1))))) "SINGLE PANEL")
                                        (setq s2 (ssget "W" (subst (- (car 1p) 450) (car 1p) 1p) 2P (list '(0 . "INSERT") )))
                                        (setq i2 0
                                                    n2 (sslength s2)
                                              )
                                              (while (< i2 n2)
                                                  (setq e2 (ssname s2 i2)
                                                        x2 (cdr (assoc 0 (entget e2)))
                                                        i2 (1+ i2)
                                                  )
                                                (if (= (LM:name->effectivename (cdr (assoc 2 (entget e2)))) "NestedPanelTitle")
                                                  (setq Psize (LM:getattributevalue (cdr (car(entget e2))) "PANELNAME"))
                                                )
                                                (if (= (LM:name->effectivename (cdr (assoc 2 (entget e2)))) "AWC")
                                                  (LM:setattributevalue e2 "RUN_PROGRAM" "-")
                                                )
                                              ) 
                                            
                                      )
                                      ((= (LM:getvisibilitystate (vlax-ename->vla-object (cdr (car (entget e1))))) "NESTED (OFFCUT)")
                                        (setq SheetSize (LM:assoc++ "OFFCUT" SheetSize))
                                        (setq PSize (assoc "OFFCUT" SheetSize))
                                        (setq Psize (strcat (car Psize)"-" (fixitoa (cdr Psize) 2)))
                                        
                                      )
                                       ((= x1 DwgTitle)
                                       (setq PrjName (vl-string-trim "Model" (LM:getattributevalue e1 "PROGRAM_NAME:")))

                                      ) 
                                    );cond
                                  );if
                                );while
                  );progn
                );if
            )
          (if (= PSIZE nil)
            (setq flag 0)
            (progn
              
              (CreateScript)
            )
          )
        )
    (progn
    (setq flag 0)
    (setq ctr 0)
    )
    );if
    (princ)
  
  
(while (= flag 1)
  (while (= ctr 1)
    (setq 1P (list (car 1P)(- (car(cdr 1P)) 4127 )))
    (setq 2P (list (car 2P)(- (car(cdr 2P)) 4127 )))
    (setq y1p (strcat (rtos (car 1P) 2 0) "," (rtos (car (cdr 2P)) 2 0)))
    
    (command "._zoom" "non" 1P "non" 2P)
    
    (if (setq s (ssget "_W" 1P 2P)) 
        (progn
            (setq i 0
                  n (sslength s)
            )
            (while (< i n)
                (setq e (ssname s i)
                      x (cdr (assoc 0 (entget e)))
                      i (1+ i)
                )
              (if (= x "INSERT")
                (cond 
                  ((= (LM:getvisibilitystate (vlax-ename->vla-object (cdr (car (entget e))))) "NESTED")
                    (setq SheetSize (LM:assoc++ (setq Size (strcat (LM:getattributevalue (cdr (car(entget e))) "SHEET_WIDTH") "X" (LM:getattributevalue (cdr (car(entget e))) "SHEET_HEIGHT"))) SheetSize))
                    (setq PSize (assoc Size SheetSize))
                    (setq Psize (strcat (car Psize)"-" (fixitoa (cdr Psize) 2)))
                    (WriteScript)
                    (setq ctr 1)
                  )
                  ((= (LM:getvisibilitystate (vlax-ename->vla-object (cdr (car (entget e))))) "SINGLE PANEL")
                    (setq s2 (ssget "W" (subst (- (car 1p) 450) (car 1p) 1p) 2P (list '(0 . "INSERT") )))
                    (setq i2 0
                                n2 (sslength s2)
                          )
                          (while (< i2 n2)
                              (setq e2 (ssname s2 i2)
                                    x2 (cdr (assoc 0 (entget e2)))
                                    i2 (1+ i2)
                              )
                            (if (= (LM:name->effectivename (cdr (assoc 2 (entget e2)))) "NestedPanelTitle")
                              (setq Psize (LM:getattributevalue (cdr (car(entget e2))) "PANELNAME"))
                            )
                            (if (= (LM:name->effectivename (cdr (assoc 2 (entget e2)))) "AWC")
                              (LM:setattributevalue e2 "RUN_PROGRAM" "-")
                            )
                          ) 
                    (WriteScript)
                    (setq ctr 1)
                  )
                  ((= (LM:getvisibilitystate (vlax-ename->vla-object (cdr (car (entget e))))) "NESTED (OFFCUT)")
                    (setq SheetSize (LM:assoc++ "OFFCUT" SheetSize))
                    (setq PSize (assoc "OFFCUT" SheetSize))
                    (setq Psize (strcat (car Psize)"-" (fixitoa (cdr Psize) 2)))
                    (WriteScript)
                    (setq ctr 1)
                  )
                );cond
                
              )
            );WHILE
        );PROGN
    );IF
    (if (= s nil) (setq ctr 0))
    (princ)
  );while
    (setq 1P (list (+ (car o1P) 6830 )(car(cdr o1P))))
    (setq 2P (list (+ (car o2P) 6830 )(car(cdr o2P))))
    (setq y1p (strcat (rtos (car 1P) 2 0) "," (rtos (car (cdr 2P)) 2 0)))
    (setq o1P 1P)
    (setq o2P 2P)
    (command "_zoom" 1P 2P)
  
    (if (setq s (ssget "_W" 1P 2P))
        (progn
            (setq i 0
                  n (sslength s)
            )
            (while (< i n)
                (setq e (ssname s i)
                      x (cdr (assoc 0 (entget e)))
                      i (1+ i)
                )
              
              (if (= x "INSERT")
                (cond 
                  ((= (LM:getvisibilitystate (vlax-ename->vla-object (cdr (car (entget e))))) "NESTED")
                    (setq SheetSize (LM:assoc++ (setq Size (strcat (LM:getattributevalue (cdr (car(entget e))) "SHEET_WIDTH") "X" (LM:getattributevalue (cdr (car(entget e))) "SHEET_HEIGHT"))) SheetSize))
                    (setq PSize (assoc Size SheetSize))
                    (setq Psize (strcat (car Psize)"-" (fixitoa (cdr Psize) 2)))
                    (WriteNextScript)
                    (setq ctr 1)
                    
                  )
                  ((= (LM:getvisibilitystate (vlax-ename->vla-object (cdr (car (entget e))))) "SINGLE PANEL")
                    (setq s2 (ssget "W" (subst (- (car 1p) 450) (car 1p) 1p) 2P (list '(0 . "INSERT") )))
                    (setq i2 0
                                n2 (sslength s2)
                          )
                          (while (< i2 n2)
                              (setq e2 (ssname s2 i2)
                                    x2 (cdr (assoc 0 (entget e2)))
                                    i2 (1+ i2)
                              )
                            (if (= (LM:name->effectivename (cdr (assoc 2 (entget e2)))) "NestedPanelTitle")
                              (setq Psize (LM:getattributevalue (cdr (car(entget e2))) "PANELNAME"))
                            )
                            (if (= (LM:name->effectivename (cdr (assoc 2 (entget e2)))) "AWC")
                              (LM:setattributevalue e2 "RUN_PROGRAM" "-")
                            )                            
                          ) 
                    (WriteNextScript)
                    (setq ctr 1)
                    
                  )
                  ((= (LM:getvisibilitystate (vlax-ename->vla-object (cdr (car (entget e))))) "NESTED (OFFCUT)")
                    (setq SheetSize (LM:assoc++ "OFFCUT" SheetSize))
                    (setq PSize (assoc "OFFCUT" SheetSize))
                    (setq Psize (strcat (car Psize)"-" (fixitoa (cdr Psize) 2)))
                    (WriteNextScript)
                    (setq ctr 1)
                  )
                  
                );cond
                
              )
            );WHILE
        );PROGN
    );IF
  
  (if (= nil s)(setq flag 0))
);while
  (DelAllLayout)
  (if (= chk nil)
    (princ "\nInvalid Object")
      (progn
        (setq file (open (strcat (getvar "dwgprefix") "CreateScript.scr") "A"))
        (write-line "LockAllVp" file)
        (write-line "MODEL" file)
        (write-line (strcat "-VIEW\tR " tempViewName "\n ") file)
        (write-line (strcat "-VIEW\tD " tempViewName "\n ") file)
        (write-line "REGENALL" file)
        (close file)
        (command "_.Layout" "Set" (car (layoutlist)))
        (command "_.script" (strcat (getvar "dwgprefix") "CreateScript.scr"))
      )
  )
  (setvar "CMDECHO" 1)
  (princ)
);defun

;=========================================================================

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

;=========================================================================

(defun LM:boundingbox ( obj / a b lst )
    (if
        (and
            (vlax-method-applicable-p obj 'getboundingbox)
            (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list obj 'a 'b))))
            (setq lst (mapcar 'vlax-safearray->list (list a b)))
        )
        (mapcar '(lambda ( a ) (mapcar '(lambda ( b ) ((eval b) lst)) a))
           '(
                (caar   cadar)
                (caadr  cadar)
                (caadr cadadr)
                (caar  cadadr)
            )
        )
    )
)

;=========================================================================

(defun LM:getattributevalue ( blk tag / enx )
    (if (and (setq blk (entnext blk)) (= "ATTRIB" (cdr (assoc 0 (setq enx (entget blk))))))
        (if (= (strcase tag) (strcase (cdr (assoc 2 enx))))
            (cdr (assoc 1 (reverse enx)))
            (LM:getattributevalue blk tag)
        )
    )
)

;=========================================================================

(defun LM:setattributevalue ( blk tag val / enx )
    (if (and (setq blk (entnext blk)) (= "ATTRIB" (cdr (assoc 0 (setq enx (entget blk))))))
        (if (= (strcase tag) (strcase (cdr (assoc 2 enx))))
            (if (entmod (subst (cons 1 val) (assoc 1 (reverse enx)) enx))
                (progn
                    (entupd blk)
                    val
                )
            )
            (LM:setattributevalue blk tag val)
        )
    )
)

;=========================================================================

(defun LM:effectivename ( obj )
    (vlax-get-property obj
        (if (vlax-property-available-p obj 'effectivename)
            'effectivename
            'name
        )
    )
)

;=========================================================================

(defun LM:assoc++ ( key lst / itm )
    (if (setq itm (assoc key lst))
        (subst (cons key (1+ (cdr itm))) itm lst)
        (cons  (cons key 1) lst)
    )
)

;=========================================================================

(defun CreateScript ()
  (setq file (open (strcat (getvar "dwgprefix") "CreateScript.scr") "W"))
  (write-line (strcat ".mview\tL\tOFF\tALL \nLAYOUT\tR\t" LaynName "\t" "-") file)
  (write-line (strcat "LAYOUT\tR\t" "-" "\t" PSize) file)
  (close file)
  (setq LaynName PSize)
  (crText (mapcar '+ '(150 2200) (list (car 1p) (cadr 1p))) 75 (strcat PrjName laynname))
)

;=========================================================================

(defun WriteScript ()
  
  (setq file (open (strcat (getvar "dwgprefix") "CreateScript.scr") "A"))
  (write-line (strcat "LAYOUT\tC\t" LaynName "\t" PSize "\tLAYOUT\tS\t" PSize "\tGoLast\tMspace\t-pan\t" y1p "\t" y2p "\tPspace") file)
  (close file)
  (setq LaynName PSize)
  (setq y2p y1p)
  (crText (mapcar '+ '(150 2200) (list (car 1p) (cadr 1p))) 75 (strcat PrjName laynname))
)

;=========================================================================

(defun WriteNextScript ()
  (setq file (open (strcat (getvar "dwgprefix") "CreateScript.scr") "A"))
  (write-line (strcat "LAYOUT\tC\t" LaynName "\t" PSize "\tLAYOUT\tS\t" PSize "\tGoLast\tMspace\t-pan\t" y1p "\t" y2p "\tPspace") file)
  (close file)
  (setq LaynName PSize)
  (setq y2p y1p)
  (crText (mapcar '+ '(150 2200) (list (car 1p) (cadr 1p))) 75 (strcat PrjName laynname))
)

;=========================================================================

(defun fixitoa ( #i #n / s ) (setq s (itoa #i))(while (> #n (strlen s))(setq s (strcat "0" s))) s)

;=========================================================================

(defun LM:getvisibilitystate ( blk / vis )
    (if (setq vis (LM:getvisibilityparametername blk))
        (LM:getdynpropvalue blk vis)
    )
)

;=========================================================================

(defun LM:getvisibilityparametername ( blk / vis )  
    (if
        (and
            (vlax-property-available-p blk 'effectivename)
            (setq blk
                (vla-item
                    (vla-get-blocks (vla-get-document blk))
                    (vla-get-effectivename blk)
                )
            )
            (= :vlax-true (vla-get-isdynamicblock blk))
            (= :vlax-true (vla-get-hasextensiondictionary blk))
            (setq vis
                (vl-some
                   '(lambda ( pair )
                        (if
                            (and
                                (= 360 (car pair))
                                (= "BLOCKVISIBILITYPARAMETER" (cdr (assoc 0 (entget (cdr pair)))))
                            )
                            (cdr pair)
                        )
                    )
                    (dictsearch
                        (vlax-vla-object->ename (vla-getextensiondictionary blk))
                        "ACAD_ENHANCEDBLOCK"
                    )
                )
            )
        )
        (cdr (assoc 301 (entget vis)))
    )
)

;=========================================================================

(defun LM:getdynpropvalue ( blk prp )
    (setq prp (strcase prp))
    (vl-some '(lambda ( x ) (if (= prp (strcase (vla-get-propertyname x))) (vlax-get x 'value)))
        (vlax-invoke blk 'getdynamicblockproperties)
    )
)

;=========================================================================

(defun DelAllLayout ( / ll)
  (command "_.Layout" "Set" (car (getLayoutOrderList)))
  (while (/= 0 (setq ll (- (setq ll (length (getLayoutOrderList))) 1 )))
      (progn 
        (if (> ll 0)
          (command "_-LAYOUT" "DELETE" (nth ll (getLayoutOrderList)))
        )
      );progn 
  );while
  (command "Model")
)

;=========================================================================

(defun getLayoutOrderList( / lst mklist mappend flatten)
    (defun mklist (x) (if (listp x) x (list x)))
    (defun mappend (fn lst)(apply 'append (mapcar fn lst))) 
    (defun flatten (expr)(mappend 'mklist expr))
    (vlax-for lay 
        (vla-get-layouts (vla-get-activedocument (vlax-get-acad-object)))
        (setq lst (cons (list (vla-get-taborder lay)(vla-get-name lay)) lst))
    )
    (cdr(flatten(mapcar 'cdr (vl-sort lst '(lambda (a b) (< (car a)(car b)))))))
)

;=========================================================================

(defun c:GoLast (/ l)

  (if (and (< 2
              (vla-get-count
                (setq l (vla-get-Layouts
                          (vla-get-ActiveDocument (vlax-get-acad-object))
                        )
                )
              )
           )
           (eq 0 (getvar 'TILEMODE))
      )
    (vla-put-taborder
      (vla-item l (getvar 'CTAB))
      (1- (vla-get-count l))
    )
    (princ "\n ** Command is not allowed in Model Space **")
  )
  (princ)
)

;=========================================================================

(defun C:LockAllVp ( / i oldlo oldcmde)
 (setq oldcmde (getvar "CMDECHO"))
 (setvar "CMDECHO" 0)
 (setq oldlo (getvar "CTAB"))
;cannot lock model
; (setvar "CTAB" "Model")
;all layouts
 (foreach i (layoutlist)
  (progn 
   (setvar "CTAB" i)
   (command "_-VPORTS" "_Lock" "_on" "_all" "")
   );progn 
 )
 (setvar "CTAB" oldlo)
 (setvar "CMDECHO" oldcmde)
 (princ "\nAll viewports locked.")
 (princ)
)

;=========================================================================

(defun crText ( ins hgt str / ent )
  (entmake 
    (list 
      '(000 . "TEXT")      
      '(100 . "AcDbText")
      '(7 .   "TEXT")
      '(8 .   "Defpoints")
      (cons 010 ins)      
      (cons 040 hgt)      
      (cons 001 str)      
    )
  )
)

;=========================================================================

  (defun *error* (msg)
    (if (not (wcmatch msg "quit/exit abort,function canceled"))
      (princ (strcat "\nError: " msg)) ; Display message for actual errors
    )
    (setvar "CMDECHO" 1) ; Ensure settings are reset
    (princ) ; Quiet exit
  )

;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
(princ
    (strcat
        "\n:: Version 1.1 | \\U+00A9 FT ::"
        "\n:: This Progam also works with Single Panel ::"
        "\n:: \"CRL\" to Create Layout ::"
    )
)
(princ)

 

Edited by SLW210
Added Code Tags!!
SLW210 Grand Master

SLW210

Posted
Posted

I have moved your post to a new thread ARES Commander LISP not Working in the AutoLISP, Visual LISP & DCL Forum. 

 

Please use Code Tags for posted code in the future. (<> in the editor toolbar)

 

Where did you get the LISP and what does it do? 

 

Do other LISPs run in your Ares Commander?

 

What does not work?

 

Do you have the Visual Studio Code and the Graebert LISP Extension for troubleshooting the LISP?

  • Like 1
Steven P Grand Master

Steven P

Posted
Posted

As SWL says, what is the error? Where does it fail? That would help identify a problem.

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.

×
 Share
Go to topic listing
×
×
  • Create New...