@ Επικοινωνία
Autolisp/Visual Lisp
Autolisp

Γιατί Autolisp

Ο βασικός λόγος που χρησιμοποιώ αυτήν την γλώσσα και όχι άλλη, είναι η ευελιξία της. Στην αρχή μπορεί να φαίνεται περίεργη η σύνταξη της για κάποιον που έχει συνηθίσει σε άλλες γλώσσες, επειδή χρησιμοποιεί λίστες για τα πάντα, όπως επίσης προτάσσει τους τελεστές (π.χ. σε μια οποιαδήποτε γλώσσα η πρόσθεση είναι χ = 1 + 1, ενώ στη autolisp είναι (setq x (+ 1 1)), αλλά αυτό συνηθίζεται αρκετά γρήγορα. Το γεγονός δε, ότι μπορείς να αναμίξεις διαφόρων τύπων μεταβλητές, δίνει τη δυνατότητα να δημιουργηθούν λίστες με ότι μπορεί να φανταστεί κάποιος.
Συν τοις άλλοις, είναι και η αρχική γλώσσα που ενσωμάτωσε το Autocad (είναι κάτι σαν η φυσική του γλώσσα), που σημαίνει ότι, δεν χρειάζεται με κάθε έκδοση του Autocad καμιά αλλαγή. Οι ρουτίνες της autolisp τρέχουν σε όλες τις εκδόσεις (εκτός βέβαια και αν χρησιμοποιείται κάποια ιδιότητα ενός αντικειμένου, που υπάρχει σε μεταγενέστερη, αλλά όχι σε προγενέστερη έκδοση). Είναι αρκετές οι εντολές του autocad, που οι προγραμματιστές του τις έχουν συντάξει σε autolisp.

Σ' αυτήν την σελίδα υπάρχουν μερικές χρήσιμες functions γενικής χρήσης σε AutoLisp/Visual Lisp. Σχεδόν σε όλες έχω κάνει τεστ ταχύτητας. Αυτό βέβαια δεν σημαίνει πως ο κώδικάς μου είναι πάντα ο βέλτιστος. Γι' αυτό, αν κάποιος έχει βρει καλύτερο κώδικα σε κάποια διαδικασία, θα τον παρακαλούσα να μου τον στείλει κι εμένα. Αν θέλετε να κάνετε τεστ ταχύτητας σε κάποια function, χρησιμοποιήστε τον κώδικα που θα βρείτε πιο κάτω.

ΚΑΙ ΜΗΝ ΞΕΧΝΑΤΕ η Visual Lisp ΔΕΝ φορτώνεται αυτόματα στο AutoCad. Πρέπει οπωσδήποτε να δοθεί η εντολή (VL-LOAD-COM). Η καλύτερη πρακτική για να φορτώνεται κάθε φορά αυτόματα είναι να μπει στο αρχείο acaddoc.lsp.

Τεστ ταχύτητας

(defun C:test ( / i timer endtimer)
  (defun date2sec ( / s)
    (setq s (getvar "DATE"))
    (* 86400.0 (- s (fix s)))
  )
  (setq i 1 timer (date2sec))
  (while (< i 2000) ; το ανώτατο όριο εξαρτάται από το τι θα δοκιμάσετε
    ; βάλτε εδώ το τμήμα κώδικα που θέλετε να δοκιμάσετε
    (setq i (1+ i))
  )
  (setq endtimer (date2sec))
  (alert (rtos (- endtimer timer) 2 8))
)

Πολλές φορές χρειαζόμαστε το τρέχον space. Καλό είναι να υπάρχουν γενικές μεταβλητές, οι οποίες μπορούν να χρησιμοποιούνται σε όλες τις διαδικασίες που χρειάζεται η ύπαρξη του space.

(vl-load-com)
;; Γενικές μεταβλητές σε vla objects
(setq
  _ACAD_ (vlax-get-acad-object) ; το ίδιο το autocad
  _CDOC_ (vla-get-activedocument _ACAD_) ; το σχέδιο
  _MSPACE_ (vla-get-modelspace _CDOC_) ; το model space του σχεδίου
  _PSPACE_ (vla-get-paperspace _CDOC_) ; το paper space του σχεδίου
)

Αυτή η διαδικασία επιστρεφει το τρέχον space σε vla object
ακόμη και αν είσαστε σε layout, αλλά σε κατάσταση model μέσα
σε κάποιο παράθυρο, θα επιστρέψει το σωστό space.

(defun GetCSpace()
  (if (= (getvar "TILEMODE") 1)
    _MSPACE_
    (if (= (vla-get-modelspace _CDOC_) :vlax-true)
      _MSPACE_
      _PSPACE_
    )
  )
)

Επιλογή αντικειμένων από το layer τους.

Η εντολή είναι ένα γρήγορο φίλτρο layers
Zητά να επιλεγούν αντικείμενα και στην συνέχεια όσα έχουν ίδιο layer με αυτά, τα επιλέγει όλα.
Παράδειγμα: Θέλετε να διαγράψετε όλα τα αντικείμενα που ανήκουν στα layers "Layer1", "Layer2"
Δώστε την εντολή erase και στην προτροπή του AutoCad "Select objects:" γράψτε (sslay).  Το AutoCad πάλι θα αποκριθεί με το "Select objects:". Εσείς επιλέξτε ΜΟΝΟ 2 αντικείμενα που ανήκουν στα "Layer1", "Layer2". Πατήστε Enter και θα δείτε ότι έχουν επιλεγεί ΟΛΑ τα αντικείμενα αυτών των δύο layers. Πατήστε ξανά enter για να τελειώσετε την επιλογή και όλα τα αντικείμενα θα διαγραφούν.

(defun sslay( / ss lays i obj)
  (setq ss (ssget))
  (if ss
    (progn
      (setq i 0 lays '((-4 . "<OR")))
      (while (setq obj (ssname ss i))
(setq lays (append lays (list (assoc 8 (entget obj))))) (setq i (1+ i)) ) (setq ss nil lays (append lays (list (cons -4 "OR>")))) ) ) (ssget "X" lays) )

Υπολογισμός εμβαδού μιας λίστας σημείων

Οριζόντια επιφάνεια λίστας σημείων. Χρησιμοποιούνται μόνο οι Χ και Υ συντεταγμένες
Αν υπάρχει η Ζ αγνοείται
Η παράμετρος lst πρέπει να έχει τη μορφή ((X1 Y1) (X2 Y2) (X3 Y3) ... (Xi Yi))

(defun larea(lst / lst1 a:ar)
  (setq a:ar 0.0 lst1 (append (cdr lst) (list (car lst))))
  (mapcar '(lambda (x y) 
             (setq a:ar (+ a:ar (* (- (car y) (car x)) (+ (cadr y) (cadr x)))))
           )
    lst
    lst1
  )
  (abs (/ a:ar 2))
)

Κατασκευή 2D ανοικτής polyline από λίστα σημείων

Η παράμετρος plst πρέπει να έχει τη μορφή ((Χ1 Υ1) (Χ2 Υ2) ... (Χι Υι))
Ακόμη και αν η λίστα περιέχει και τις τρεις συντεταγμένες, η ρουτίνα λειτουργεί, γιατί αγνοεί την Ζ
Σημείωση: Για να την κάνετε κλειστή, δεν έχετε παρά να αντικαταστήσετε την παράμετρο '(70 . 0) με την παράμετρο '(70 . 1)

(defun lwpline(plst)
  (entmake
    (append
      (list
        '(0 . "LWPOLYLINE")
        '(100 . "AcDbEntity") ; χρειάζεται οπωσδήποτε
        '(100 . "AcDbPolyline") ; χρειάζεται οπωσδήποτε
        (cons 90 (length plst))
        '(70 . 0)
        '(43 . 0.0)
      )
      (mapcar '(lambda(x) (list 10 (car x) (cadr x))) plst)
    )
  )
  (entlast)
)

Χειρισμός λιστών

Για να αφαιρέσετε όλα τα ίδια στοιχεία από μια λίστα, χρησιμοποιήστε την ρουτίνα της Visual Lisp
(vl-remove item lst)

Η παρακάτω ρουτίνα αφαιρει μόνο το πρώτο στοιχείο που βρίσκει στη λίστα
Αν υπάρχουν κι άλλα ίδια τα αφήνει

(defun RemMember (item lst / pos i)
  (setq pos (vl-position item lst) i -1)
  (if pos
    (vl-remove-if '(lambda(x) (setq i (1+ i)) (= i pos)) lst)
    lst
  )
)

Αφαιρει το στοιχειο από την θεση pos της λιστας lst
Π.χ. (remnth 0 '(3 2 0)) επιστρέφει τη λίστα (2 0). Το πρώτο στοιχείο κάθε λίστας έχει index 0

(defun RemNth(pos lst)
  (setq i -1)
  (vl-remove-if '(lambda(x) (setq i (1+ i)) (= i pos)) lst)
)

Επιστροφή σε λίστα όλων των κορυφών μιας 2d polyline

Σημειώστε πως οι συντ/νες που επιστρέφονται είναι πάντα σε WCS. Για να μετατραπούν σε οποιοδήποτε σύστημα συντ/νων πρέπει να χρησιμοποιηθεί η function trans.
ent = το ename της polyline

(defun GetLwPoints(ent)
  (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= 10 (car x))) (entget ent)))
)

Επιστροφή σε λίστα όλων των κορυφών μιας 3D Polyline

Σημειώστε πως οι συντ/νες που επιστρέφονται είναι πάντα σε WCS
poly = το ename της polyline

(defun GetPolyCoos(poly / ret)
  (setq poly (entnext poly))
  (while (/= (cdr(assoc 0 (entget poly))) "SEQEND")
    (setq ret (append ret (list (cdr(assoc 10 (entget poly))))))
    (setq poly (entnext poly))
  )
)

Μετατροπή από WCS στο τρέχον UCS λίστας σημείων

(defun toCUCS(lst)
  (mapcar '(lambda(x) (setq x (trans x 0 1))) lst)
)

XData

Πάρτε τα XData οποιασδήποτε εφαρμογής
Παράμετροι
ent = το ename του αντικειμένου
app = η εφαρμογή που θέλετε να πάρετε τα XData της
Π.χ. (GetXData (car(entsel)) "ACAD")

(defun GetXData(ent app)
  (cdadr(assoc -3 (entget ent (list app))))
)

Τοποθέτηση ΧData σε αντικείμενο
Παράμετροι
ent = το ename του αντικειμένου
app = η ονομασία της εφαρμογής που θέλετε
data = data list της μορφής ((1000 . "test") (1005 . "F5") (1041 . 40.4567) ...)
ΠΡΟΣΟΧΗ μόνο ώστε στη λίστα δεδομένων να ορίζονται επιτρεπτοί DXF κωδικοί αν data = nil αποσυνδέεται το αντικείμενο από την εφαρμογή

(defun SetXData(ent app data / obj exdata)
  (regapp app)
  (setq
    obj (entget ent)
    exdata (list -3 (cons app data))
  )
  (if (< (xdsize exdata) (xdroom ent))
    (entmod (append obj (list exdata)))
) )

XRecord

Ανάκτηση μιας εγγραφής από το κάποιο DICTIONARY
Παράμετροι
xname = το string της εγγραφής π.χ. "my_application_1"
xdic = το string του dictionary π.χ. "my_all_applications"

(defun GetXRec(xname xdic / dic)
  (setq dic (cdar(dictsearch (namedobjdict) xdic)))
  (if dic (dictsearch dic xname))
)

Τοποθετεί μια XRECORD σε ένα DICTIONARY
Παράμετροι
lst = λίστα των δεδομένων (αν δεν υπάρχουν οι DXF 0 και 100 τους τοποθετεί)
xname = το string της εγγραφής π.χ. "my_application_1"
xdic = το string του dictionary π.χ. "my_all_applications"
Παρατηρήσεις
Αν υπάρχει ήδη η εγγραφή xname τη διαγράφει (επειδη δυστυχώς δεν τροποποιείται
παρ' όλο που υπάρχει η ανάλογη εντολή - μια παραξενιά του AutoCad), και βάζει τα
νέα στοιχεία. Αρα πρέπει να περιέχονται στη μεταβλητή lst και τα παλιά, αν θέλετε
να διατηρηθούν.Δηλαδή υπάρχει ανάλογη αντιμετώπιση όπως στην entmod.
Αγνοεί τις Nil τιμές (αν υπάρχουν) καθ' όσον θα προκληθεί σφάλμα σε μια τέτοια περίπτωση. 
Επιστρέφει το ename της εγγραφής

(defun SetXRec (lst xname xdic / dic xlist)
  (setq dic (cdar(dictsearch (namedobjdict) xdic)))
  (if (not (assoc 0 lst))
    (setq lst (append (list (cons 0 "XRECORD") (cons 100 "AcDbXrecord")) lst))
  )
  (while lst
(if (cdr(car lst)) (setq xlist(append xlist (list (car lst))))) (setq lst (cdr lst)) ) (cond (dic (dictremove dic xname)) (t (setq dic (dictadd (namedobjdict) xdic (entmakex '((0 . "DICTIONARY") (100 . "AcDbDictionary")))) ) ) ) (dictadd dic xname (entmakex xlist)) )

Μια πιο εξελιγμένη μορφή τοποθέτησης εγγραφής XRECORD
Αυτή η ρουτίνα μπορεί να αντικαταστήσει πλήρως την SetXRec, εκτός και αν θέλετε να διαγράψετε όλα τα στοιχεία μιας παλιάς εγγραφήςκαι να τα αντικαταστήσετε με νέα.
Παρατηρήσεις
Δεν χρειάζεται να ανακτήσετε τα παλιά στοιχεία και σ' αυτά να προσθέσετε τα νέα. Απλά βάζετε την πληροφορία που θέλετε και η ρουτίνα τα αντιμετωπίζει ανάλογα. Δηλαδή ...
Αν δεν υπάρχει καν η εγγραφή xname τη δημιουργεί
Τα νέα στοιχεία της lst προστίθενται στα παλιά δεδομένα (αν υπάρχουν).
Αν υπάρχουν στα παλιά δεδομένα οι κωδικοί DXF των νέων, τότε τα νέα δεδομένα αντικαθιστούν τα παλιά.
Αν σε κάποιον κωδικό DXF υπάρχει μια τιμή nil, τότε αφαιρεί αυτό το δεδομένο από την εγγραφή.
Επιστρέφει το ename της εγγραφής

(defun PutXRec(lst xname xdic / dic xlist item)
  (setq dic (cdar(dictsearch (namedobjdict) xdic)))
  (cond
(dic (setq xlist (GetXRec xname)) (if xlist ; αν υπάρχει η εγγραφή xname (while lst (setq item (assoc (caar lst) xlist)) (cond ((not (cdr(car lst))) ; αν το δευτερο στοιχείο του DXF είναι nil το αφαιρεί (setq xlist (RemMember item xlist)) ) (item (setq xlist (subst (car lst) item xlist)) ; αντικατάσταση στοιχείου ) (t (setq xlist (append xlist (list (car lst)))) ; πρόσθεση στοιχείου ) ) (setq lst (cdr lst)) ) (while lst (if (cdr(car lst)) (setq xlist(append xlist (list (car lst))))) (setq lst (cdr lst)) ) ) (dictremove dic xname) ) (t (setq dic (dictadd (namedobjdict) xdic (entmakex '((0 . "DICTIONARY") (100 . "AcDbDictionary"))) ) ) (setq xlist lst) ) ) (if (not (assoc 0 xlist)) (setq xlist (append (list (cons 0 "XRECORD") (cons 100 "AcDbXrecord")) xlist)) ) (dictadd dic xname (entmakex xlist)) )