;2
;;----------------------=={ Add Objects to Block }==--------------------;;
;;    blok icine  nesne  ekleme
                                                                  ;;
;;  This program enables the user to add a selection of objects to the  ;;
;;  definition of a selected block.                                     ;;
;;                                                                      ;;
;;  Upon issuing the command syntax 'addtoblock' at the AutoCAD         ;;
;;  command line, the program prompts the user for a selection of       ;;
;;  objects residing on unlocked layers to be added to a chosen block   ;;
;;  definition.                                                         ;;
;;                                                                      ;;
;;  Following a valid selection, the program prompts the user to select ;;
;;  a reference of a block whose definition is to be modified to        ;;
;;  incorporate all objects in the selection.                           ;;
;;                                                                      ;;
;;  At this prompt, the program will permit selection of any standard   ;;
;;  (non-dynamic) uniformly scaled block reference which is not         ;;
;;  referenced within the selection (as a block reference cannot be     ;;
;;  added to its own definition).                                       ;;
;;                                                                      ;;
;;  Every object in the selection will then be transformed relative to  ;;
;;  the position, scale, rotation, and orientation of the selected      ;;
;;  block reference, before being copied to the definition of the       ;;
;;  block and removed from the drawing.                                 ;;
;;----------------------------------------------------------------------;;
;;  Author:  Lee Mac, Copyright © 2011  -   lee-mac                     ;;
;;----------------------------------------------------------------------;;
;;  Version 1.1    -    2011-05-31                                      ;;
;;                                                                      ;;
;;  - First release.                                                    ;;
;;----------------------------------------------------------------------;;
;;  Version 1.2    -    2020-11-15                                      ;;
;;                                                                      ;;
;;  - Program completely rewritten to incorporate a check for           ;;
;;    references of the target block within the selected objects.       ;;
;;----------------------------------------------------------------------;;
(defun c:addtoblock ( / *error* bln bnl btr def ent enx idx lst sel tmp )
    (defun *error* ( msg )
        (LM:endundo (LM:acdoc))
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\nError: " msg))
        )
        (princ)
    )
    (LM:startundo (LM:acdoc))
    (cond
        (   (not (setq sel (LM:ssget "\nSelect objects to add to block: " '("_:L")))))
        (   (progn
                (repeat (setq idx (sslength sel))
                    (setq idx (1- idx)
                          ent (ssname sel idx)
                          enx (entget ent)
                          lst (cons (vlax-ename->vla-object ent) lst)
                    )
                    (if (and (= "INSERT" (cdr (assoc 0 enx)))
                             (not (member (setq bln (strcase (cdr (assoc 2 enx)))) bnl))
                        )
                        (setq bnl (cons bln bnl))
                    )
                )
                (while (setq def (tblnext "block" (not def)))
                    (setq ent (tblobjname "block" (cdr (assoc 2 def))))
                    (while (setq ent (entnext ent))
                        (if (= "INSERT" (cdr (assoc 0 (setq enx (entget ent)))))
                            (setq tmp (cons (strcase (cdr (assoc 2 enx))) tmp))
                        )
                    )
                    (if tmp
                        (setq btr (cons (cons (strcase (cdr (assoc 2 def))) tmp) btr)
                              tmp nil
                        )
                    )
                )
                (while
                    (progn (setvar 'errno 0) (setq ent (car (entsel "\nSelect block: ")))
                        (cond
                            (   (= 7 (getvar 'errno))
                                (princ "\nMissed, try again.")
                            )
                            (   (null ent)
                                nil
                            )
                            (   (/= "INSERT" (cdr (assoc 0 (setq enx (entget ent)))))
                                (princ "\nThe selected object is not a block.")
                            )
                            (   (not
                                    (and
                                        (equal (abs (cdr (assoc 41 enx))) (abs (cdr (assoc 42 enx))) 1e-8)
                                        (equal (abs (cdr (assoc 41 enx))) (abs (cdr (assoc 43 enx))) 1e-8)
                                    )
                                )
                                (princ "\nThis program is not currently compatible with non-uniformly scaled blocks - sorry.")
                            )
                            (   (= :vlax-true (vla-get-isdynamicblock (vlax-ename->vla-object ent)))
                                (princ "\nThis program is not currently compatible with dynamic blocks - sorry.")
                            )
                            (   (vl-some '(lambda ( bln ) (member bln bnl))
                                    (
                                        (lambda ( / rtn )
                                            (setq bln (strcase (cdr (assoc 2 enx))))
                                            (foreach def btr
                                                (cond
                                                    (   (= bln (car def)))
                                                    (   (member (car def) rtn))
                                                    (   (addtoblock:referenced-p bln (cdr def) btr) (setq rtn (cons (car def) rtn)))
                                                )
                                            )
                                            (cons bln rtn)
                                        )
                                    )
                                )
                                (princ "\nThe selected block is referenced by a block in the selection.")
                            )
                        )
                    )
                )
                ent
            )
            (   (lambda ( mat )
                    (foreach obj lst (vla-transformby obj mat))
                    (vla-copyobjects (LM:acdoc)
                        (vlax-make-variant
                            (vlax-safearray-fill
                                (vlax-make-safearray vlax-vbobject (cons 0 (1- (length lst))))
                                lst
                            )
                        )
                        (vla-item (vla-get-blocks (LM:acdoc)) (cdr (assoc 2 (entget ent))))
                    )
                    (foreach obj lst (vla-delete obj))
                    (vla-regen (LM:acdoc) acallviewports)
                )
                (apply
                    (function
                        (lambda ( mat vec )
                            (vlax-tmatrix
                                (append
                                    (mapcar
                                        (function
                                            (lambda ( x v )
                                                (append x (list v))
                                            )
                                        )
                                        mat vec
                                    )
                                   '((0.0 0.0 0.0 1.0))
                                )
                            )
                        )
                    )
                    (revrefgeom ent)
                )
            )
        )
    )
    (LM:endundo (LM:acdoc))
    (princ)
)
(defun addtoblock:referenced-p ( bln def lst )
    (or (member bln def)
        (vl-some '(lambda ( nst ) (addtoblock:referenced-p bln (cdr (assoc nst lst)) lst)) def)
    )
)
;; RevRefGeom (gile)
;; The inverse of RefGeom
(defun revrefgeom ( ent / ang enx mat ocs )
    (setq enx (entget ent)
          ang (cdr (assoc 050 enx))
          ocs (cdr (assoc 210 enx))
    )
    (list
        (setq mat
            (mxm
                (list
                    (list (/ 1.0 (cdr (assoc 41 enx))) 0.0 0.0)
                    (list 0.0 (/ 1.0 (cdr (assoc 42 enx))) 0.0)
                    (list 0.0 0.0 (/ 1.0 (cdr (assoc 43 enx))))
                )
                (mxm
                    (list
                        (list (cos ang)     (sin ang) 0.0)
                        (list (- (sin ang)) (cos ang) 0.0)
                       '(0.0 0.0 1.0)
                    )
                    (mapcar '(lambda ( v ) (trans v ocs 0 t))
                        '(
                             (1.0 0.0 0.0)
                             (0.0 1.0 0.0)
                             (0.0 0.0 1.0)
                         )
                    )
                )
            )
        )
        (mapcar '- (cdr (assoc 10 (tblsearch "block" (cdr (assoc 2 enx)))))
            (mxv mat (trans (cdr (assoc 10 enx)) ocs 0))
        )
    )
)
;; Matrix Transpose  -  Doug Wilson
;; Args: m - nxn matrix
(defun trp ( m )
    (apply 'mapcar (cons 'list m))
)
;; Matrix x Matrix  -  Vladimir Nesterovsky
;; Args: m,n - nxn matrices
(defun mxm ( m n )
    ((lambda ( a ) (mapcar '(lambda ( r ) (mxv a r)) m)) (trp n))
)
;; Matrix x Vector  -  Vladimir Nesterovsky
;; Args: m - nxn matrix, v - vector in R^n
(defun mxv ( m v )
    (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)
;; ssget  -  Lee Mac
;; A wrapper for the ssget function to permit the use of a custom selection prompt
;; msg - [str] selection prompt
;; arg - [lst] list of ssget arguments
(defun LM:ssget ( msg arg / sel )
    (princ msg)
    (setvar 'nomutt 1)
    (setq sel (vl-catch-all-apply 'ssget arg))
    (setvar 'nomutt 0)
    (if (not (vl-catch-all-error-p sel)) sel)
)
;; Start Undo  -  Lee Mac
;; Opens an Undo Group.
(defun LM:startundo ( doc )
    (LM:endundo doc)
    (vla-startundomark doc)
)
;; End Undo  -  Lee Mac
;; Closes an Undo Group.
(defun LM:endundo ( doc )
    (while (= 8 (logand 8 (getvar 'undoctl)))
        (vla-endundomark doc)
    )
)
;; Active Document  -  Lee Mac
;; Returns the VLA Active Document Object
(defun LM:acdoc nil
    (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
    (LM:acdoc)
)
;;----------------------------------------------------------------------;;
(vl-load-com)
(princ
    (strcat
        "\n:: AddObjectsToBlock.lsp | Version 1.2 | \\U+00A9 Lee Mac "
        ((lambda ( y ) (if (= y (menucmd "m=$(edtime,0,yyyy)")) y (strcat y "-" (menucmd "m=$(edtime,0,yyyy)")))) "2011")
        "     lee-mac     ::"
        "\n:: Type "addtoblock" to Invoke ::"
    )
)
(princ)
;;----------------------------------------------------------------------;;
;;                             End of File                              ;;
;;----------------------------------------------------------------------;;

;4
;|=================================================================================|
|    -.txt dosyalarindaki koordinatlari projeye nitelikli blok olarak cizer       |
|   ve yanlarina nokta adlari ve kotlarini yazdirir . ayrim bosluk veya virguldur |
| (burst komutunu kullanilsaniz cizilen objeler,cember ve textlere  ayrilir .     |
| ihtiyaciniz olan  eger point  ise patlatmadan once                              |
| blogun icine cemberin merkezine bir tane nokta atin)                            |
|         bu lisp                                                                 |
|       cadtutor    Trudy  den alinmistir  , tr cevri thecocuk07                  |
|_________________________________________________________________________________|;
(defun Check_for_TT_P (/)
(progn
(if (= (tblsearch "style" "TT_style") 'nil)
(entmakex
'(
(0 . "STYLE")
(100 . "AcDbSymbolTableRecord")
(100 . "AcDbTextStyleTableRecord")
(2 . "TT_style")
(70 . 0)
(40 . 0.0)
(41 . 1.0)
(50 . 0.0)
(71 . 0)
(42 . 2.0)
(3 . "Times New Roman.ttf")
(4 . "")
)
)
)
(if (tblsearch "block" "TT_P") (princ)
(progn
  (entmake '((0 . "BLOCK") (100 . "AcDbEntity") (67 . 0) (8 . "0") (100 . "AcDbBlockReference") (66 . 1) (2 . "TT_P") (10 0 0 0) (70 . 2)))
  (entmake '((0 . "CIRCLE") (100 . "AcDbEntity") (67 . 0) (8 . "insert_TT") (100 . "AcDbCircle") (10 0 0 0) (40 . 0.2)))
  (entmake '((0 . "ATTDEF") (100 . "AcDbEntity") (67 . 0) (8 . "TT_NOMER") (100 . "AcDbText") (10 1.200949140349962 0.4 0) (40 . 1.6) (1 . "") (50 . 0) (41 . 1) (51 . 0) (7 . "TT_style") (71 . 0) (72 . 0) (11 1.200949140349962 2.4 0) (100 . "AcDbAttributeDefinition") (280 . 0) (3 . "Nomer") (2 . "NOMER") (70 . 0) (73 . 0) (74 . 3) (280 . 0)))
  (entmake '((0 . "ATTDEF") (100 . "AcDbEntity") (67 . 0) (8 . "TT_KOTA") (100 . "AcDbText") (10 1.200949140349962 -2.0 0) (40 . 1.6) (1 . "") (50 . 0) (41 . 1) (51 . 0) (7 . "TT_style") (71 . 0) (72 . 0) (11 1.200949140349962 0.0 0) (100 . "AcDbAttributeDefinition") (280 . 0) (3 . "KOTA") (2 . "KOTA") (70 . 0) (73 . 0) (74 . 3) (280 . 0)))
  (entmake '((0 . "ATTDEF") (100 . "AcDbEntity") (67 . 0) (8 . "TT_KOTA") (100 . "AcDbText") (10 10.87217454063124 -0.947849610037641 0) (40 . 1.6) (1 . "") (50 . 0) (41 . 1) (51 . 0) (7 . "TT_style") (71 . 0) (72 . 0) (11 10.87217454063124 1.052150389962359 0) (100 . "AcDbAttributeDefinition") (280 . 0) (3 . "DESC") (2 . "DESC") (70 . 1) (73 . 0) (74 . 3) (280 . 1)))
  (entmake '((0 . "ENDBLK") (100 . "AcDbBlockEnd") (8 . "0")))
  (princ)
)
)
(if (tblsearch "block" "TT_PT") (princ)
(progn
  (entmake '((0 . "BLOCK") (100 . "AcDbEntity") (67 . 0) (8 . "0") (100 . "AcDbBlockReference") (66 . 1) (2 . "TT_PT") (10 0.0 0.0 0.0) (70 . 2)))
  (entmake '((0 . "CIRCLE") (100 . "AcDbEntity") (67 . 0) (8 . "insert_TT") (100 . "AcDbCircle") (10 0.0 0.0 0.0) (40 . 0.7)))
  (entmake '((0 . "CIRCLE") (100 . "AcDbEntity") (67 . 0) (8 . "insert_TT") (100 . "AcDbCircle") (10 0.0 0.0 0.0) (40 . 0.525)))
  (entmake '((0 . "CIRCLE") (100 . "AcDbEntity") (67 . 0) (8 . "insert_TT") (100 . "AcDbCircle") (10 0.0 0.0 0.0) (40 . 0.07)))
  (entmake '((0 . "CIRCLE") (100 . "AcDbEntity") (67 . 0) (8 . "insert_TT") (100 . "AcDbCircle") (10 0.0 0.0 0.0) (40 . 0.035)))
  (entmake '((0 . "CIRCLE") (100 . "AcDbEntity") (67 . 0) (8 . "insert_TT") (100 . "AcDbCircle") (10 0.0 0.0 0.0) (40 . 0.042)))
  (entmake '((0 . "CIRCLE") (100 . "AcDbEntity") (67 . 0) (8 . "insert_TT") (100 . "AcDbCircle") (10 0.0 0.0 0.0) (40 . 0.049)))
  (entmake '((0 . "CIRCLE") (100 . "AcDbEntity") (67 . 0) (8 . "insert_TT") (100 . "AcDbCircle") (10 0.0 0.0 0.0) (40 . 0.056)))
  (entmake '((0 . "CIRCLE") (100 . "AcDbEntity") (67 . 0) (8 . "insert_TT") (100 . "AcDbCircle") (10 0.0 0.0 0.0) (40 . 0.063)))
  (entmake '((0 . "LWPOLYLINE") (100 . "AcDbEntity") (67 . 0) (8 . "insert_TT") (100 . "AcDbPolyline") (90 . 2) (70 . 128) (43 . 0.0) (38 . 0.0) (39 . 0.0) (10 0.0 -0.7) (40 . 0.0) (41 . 0.0) (42 . 0.0) (91 . 0) (10 0.0 -0.525) (40 . 0.0) (41 . 0.0) (42 . 0.0) (91 . 0)))
  (entmake '((0 . "LWPOLYLINE") (100 . "AcDbEntity") (67 . 0) (8 . "insert_TT") (100 . "AcDbPolyline") (90 . 2) (70 . 128) (43 . 0.0) (38 . 0.0) (39 . 0.0) (10 0.0 0.525) (40 . 0.0) (41 . 0.0) (42 . 0.0) (91 . 0) (10 0.0 0.7) (40 . 0.0) (41 . 0.0) (42 . 0.0) (91 . 0)))
  (entmake '((0 . "ARC") (100 . "AcDbEntity") (67 . 0) (8 . "insert_TT") (100 . "AcDbCircle") (10 0.000000000016861 0.0 0.0) (40 . 0.6769) (100 . "AcDbArc") (50 . 1.570796326818983) (51 . 4.712388980360603)))
  (entmake '((0 . "ARC") (100 . "AcDbEntity") (67 . 0) (8 . "insert_TT") (100 . "AcDbCircle") (10 0.000000000016861 0.0 0.0) (40 . 0.5383) (100 . "AcDbArc") (50 . 1.570796326818983) (51 . 4.712388980360603)))
  (entmake '((0 . "ARC") (100 . "AcDbEntity") (67 . 0) (8 . "insert_TT") (100 . "AcDbCircle") (10 0.000000000016861 0.0 0.0) (40 . 0.5614) (100 . "AcDbArc") (50 . 1.570796326818983) (51 . 4.712388980360603)))
  (entmake '((0 . "ARC") (100 . "AcDbEntity") (67 . 0) (8 . "insert_TT") (100 . "AcDbCircle") (10 0.000000000016861 0.0 0.0) (40 . 0.5845) (100 . "AcDbArc") (50 . 1.570796326818983) (51 . 4.712388980360603)))
  (entmake '((0 . "ARC") (100 . "AcDbEntity") (67 . 0) (8 . "insert_TT") (100 . "AcDbCircle") (10 0.000000000016861 0.0 0.0) (40 . 0.6076) (100 . "AcDbArc") (50 . 1.570796326818983) (51 . 4.712388980360603)))
  (entmake '((0 . "ARC") (100 . "AcDbEntity") (67 . 0) (8 . "insert_TT") (100 . "AcDbCircle") (10 0.000000000016861 0.0 0.0) (40 . 0.6307) (100 . "AcDbArc") (50 . 1.570796326818983) (51 . 4.712388980360603)))
  (entmake '((0 . "ARC") (100 . "AcDbEntity") (67 . 0) (8 . "insert_TT") (100 . "AcDbCircle") (10 0.000000000016861 0.0 0.0) (40 . 0.6538) (100 . "AcDbArc") (50 . 1.570796326818983) (51 . 4.712388980360603)))
  (entmake '((0 . "LWPOLYLINE") (100 . "AcDbEntity") (67 . 0) (8 . "insert_TT") (100 . "AcDbPolyline") (90 . 2) (70 . 128) (43 . 0.0) (38 . 0.0) (39 . 0.0) (10 1.132571537455078 0.0) (40 . 0.0) (41 . 0.0) (42 . 0.0) (91 . 0) (10 8.428731937368866 0.0) (40 . 0.0) (41 . 0.0) (42 . 0.0) (91 . 0)))
  (entmake '((0 . "ATTDEF") (100 . "AcDbEntity") (67 . 0) (8 . "TT_Nomer_PT") (100 . "AcDbText") (10 1.200949140349962 1 0.0) (40 . 1.8) (1 . "") (50 . 0.0) (41 . 1.0) (51 . 0.0) (7 . "TT_style") (71 . 0) (72 . 0) (11 1.200949140349962 2 0.0) (100 . "AcDbAttributeDefinition") (280 . 0) (3 . "Nomer") (2 . "NOMER") (70 . 0) (73 . 0) (74 . 3) (280 . 0)))
  (entmake '((0 . "ATTDEF") (100 . "AcDbEntity") (67 . 0) (8 . "TT_KOTA") (100 . "AcDbText") (10 1.200949140349962 -1.594007840240374 0.0) (40 . 1.8) (1 . "") (50 . 0.0) (41 . 1.0) (51 . 0.0) (7 . "TT_style") (71 . 0) (72 . 0) (11 1.200949140349962 -0.194007840240374 0.0) (100 . "AcDbAttributeDefinition") (280 . 0) (3 . "KOTA") (2 . "KOTA") (70 . 0) (73 . 0) (74 . 3) (280 . 0)))
  (entmake '((0 . "ATTDEF") (100 . "AcDbEntity") (67 . 0) (8 . "TT_KOTA") (100 . "AcDbText") (10 10.87217454063124 -0.347849610037641 0.0) (40 . 1.8) (1 . "") (50 . 0.0) (41 . 1.0) (51 . 0.0) (7 . "TT_style") (71 . 0) (72 . 0) (11 10.87217454063124 1.052150389962359 0.0) (100 . "AcDbAttributeDefinition") (280 . 0) (3 . "DESC") (2 . "DESC") (70 . 1) (73 . 0) (74 . 3) (280 . 1)))
  (entmake '((0 . "ENDBLK") (100 . "AcDbBlockEnd") (8 . "0")))
  (princ)
)
)
(if (tblsearch "block" "TT_TT") (princ)
(progn
  (entmake '((0 . "BLOCK") (100 . "AcDbEntity") (67 . 0) (8 . "0") (100 . "AcDbBlockReference") (66 . 1) (2 . "TT_TT") (10 0.0 0.0 0.0) (70 . 2)))
  (entmake '((0 . "CIRCLE") (100 . "AcDbEntity") (67 . 0) (8 . "insert_TT") (100 . "AcDbCircle") (10 0.0 0.0 0.0) (40 . 0.07)))
  (entmake '((0 . "CIRCLE") (100 . "AcDbEntity") (67 . 0) (8 . "insert_TT") (100 . "AcDbCircle") (10 0.0 0.0 0.0) (40 . 0.035)))
  (entmake '((0 . "CIRCLE") (100 . "AcDbEntity") (67 . 0) (8 . "insert_TT") (100 . "AcDbCircle") (10 0.0 0.0 0.0) (40 . 0.042)))
  (entmake '((0 . "CIRCLE") (100 . "AcDbEntity") (67 . 0) (8 . "insert_TT") (100 . "AcDbCircle") (10 0.0 0.0 0.0) (40 . 0.049)))
  (entmake '((0 . "CIRCLE") (100 . "AcDbEntity") (67 . 0) (8 . "insert_TT") (100 . "AcDbCircle") (10 0.0 0.0 0.0) (40 . 0.056)))
  (entmake '((0 . "CIRCLE") (100 . "AcDbEntity") (67 . 0) (8 . "insert_TT") (100 . "AcDbCircle") (10 0.0 0.0 0.0) (40 . 0.063)))
  (entmake '((0 . "LWPOLYLINE") (100 . "AcDbEntity") (67 . 0) (8 . "insert_TT") (100 . "AcDbPolyline") (90 . 2) (70 . 128) (43 . 0.0) (38 . 0.0) (39 . 0.0) (10 1.132571537455078 0.0) (40 . 0.0) (41 . 0.0) (42 . 0.0) (91 . 0) (10 8.428731937368866 0.0) (40 . 0.0) (41 . 0.0) (42 . 0.0) (91 . 0)))
  (entmake '((0 . "LWPOLYLINE") (100 . "AcDbEntity") (67 . 0) (8 . "Terrain") (100 . "AcDbPolyline") (90 . 3) (70 . 129) (43 . 0.0) (38 . 0.0) (39 . 0.0) (10 0. 1.0) (40 . 0.0) (41 . 0.0) (42 . 0.0) (91 . 0) (10 -0.866025403784439 -0.5) (40 . 0.0) (41 . 0.0) (42 . 0.0) (91 . 0) (10 0.866025403784439 -0.500000000000001) (40 . 0.0) (41 . 0.0) (42 . 0.0) (91 . 0)))
  (entmake '((0 . "ATTDEF") (100 . "AcDbEntity") (67 . 0) (8 . "TT_Nomer_PT") (100 . "AcDbText") (10 1.200949140349962 1 0.0) (40 . 1.8) (1 . "") (50 . 0.0) (41 . 1.0) (51 . 0.0) (7 . "TT_style") (71 . 0) (72 . 0) (11 1.200949140349962 2 0.0) (100 . "AcDbAttributeDefinition") (280 . 0) (3 . "Nomer") (2 . "NOMER") (70 . 0) (73 . 0) (74 . 3) (280 . 0)))
  (entmake '((0 . "ATTDEF") (100 . "AcDbEntity") (67 . 0) (8 . "TT_KOTA") (100 . "AcDbText") (10 1.200949140349962 -1.594007840240374 0.0) (40 . 1.8) (1 . "") (50 . 0.0) (41 . 1.0) (51 . 0.0) (7 . "TT_style") (71 . 0) (72 . 0) (11 1.200949140349962 -0.194007840240374 0.0) (100 . "AcDbAttributeDefinition") (280 . 0) (3 . "KOTA") (2 . "KOTA") (70 . 0) (73 . 0) (74 . 3) (280 . 0)))
  (entmake '((0 . "ATTDEF") (100 . "AcDbEntity") (67 . 0) (8 . "TT_KOTA") (100 . "AcDbText") (10 8.741424319139914 -0.347849610037641 0.0) (40 . 1.8) (1 . "") (50 . 0.0) (41 . 1.0) (51 . 0.0) (7 . "TT_style") (71 . 0) (72 . 0) (11 8.741424319139914 1.052150389962359 0.0) (100 . "AcDbAttributeDefinition") (280 . 0) (3 . "DESC") (2 . "DESC") (70 . 1) (73 . 0) (74 . 3) (280 . 1)))
  (entmake '((0 . "ENDBLK") (100 . "AcDbBlockEnd") (8 . "0")))
  (princ)
)
)
)
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun insD (X Y nam scal listt / block)
(vl-load-com)
(setq block (vla-InsertBlock
              (vla-get-modelspace
                (vla-get-activedocument
                  (vlax-get-acad-object)
                )
              )
              (vlax-3D-point Y X)
              nam
              scal
              scal
              scal
              0
            )
      )
(mapcar '(lambda (j k)
(vla-put-textstring k (eval j))
  )
listt
(vlax-invoke block 'GetAttributes)
)
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;rlx lisps
(defun _Exit2 () (setq *error* old-err)(term_dialog)
  (if dialog-fp (progn (close dialog-fp)(setq dialog-fp nil)))
  (if dialog-dcl (unload_dialog dialog-dcl))
  (if (and dialog-fn-kpt (findfile dialog-fn-kpt))(vl-file-delete dialog-fn-kpt))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;rlx lisps
(defun tabbenize (l) (apply 'strcat (cdr (apply 'append (mapcar '(lambda (x) (list "\t" x)) l)))))
(defun update_TTs_list ( / )
  (start_list "lb_TTs_list")(mapcar 'add_list (mapcar 'tabbenize listc2))(end_list)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun T:spaceremover (lst / ttr ttr2)
(setq ttr (subst 32 47 (subst 32 44 (subst 32 9 (vl-string->list lst)))))
(repeat (length ttr)
(if (and (= (car ttr) 32) (= (cadr ttr) 32)) (princ) (setq ttr2 (cons (car ttr) ttr2)))
(setq ttr (cdr ttr))
)
(vl-string-trim " " (vl-list->string (reverse ttr2)))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun numtxt  (str)
(vl-every '(lambda (x) (<= 46 x 57)) (vl-string->list str)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;rlx lisps
(defun Write_Dialog_kpt ( / )
  (if (and (setq dialog-fn-kpt (vl-filename-mktemp "kptin.dcl")) (setq dialog-fp (open dialog-fn-kpt "w")))
    (mapcar
      '(lambda (x)(write-line x dialog-fp))
       (list "kpt_in_dialog : dialog {label="Koordinatlara gore nokta ekle)";"
                ":boxed_column {label="Koordinatlar";"
": row {"
"tabs="10 20 40";"
" : text { label = "No";}"
" : text { label = "X";}
  : text { label = "Y";}
  : text { label = "Z";}
  : text { label = "D";}}
: column {"
             ": list_box {key="lb_TTs_list";width=60;height=15;allow_accept=true;tabs="0 15 30 50 65";multiple_select=false;}
: row {
: text { label = "Nokta sayisi:";key = "br";}
: button { label = "Kayit Sil";key = "del"; width=5; fixed_width = true;}
: button { label = "Kayit ekle";key = "add"; width=5; fixed_width = true;}}
: image {key = "progbar"; fixed_width  = 50; height = 1;}}}"
    " : boxed_column {"
" : boxed_row { label = "Secin .kpt yada .txt dosya ile Koordinatlar No X Y Z, D - eger varsa";"
": button {key = "brow"; width=5; fixed_width = true; label = "Dosya yolu...";}"
": edit_box {key = "fil1";width=65; fixed_width = true;}}"
": boxed_column {spacer;"
": edit_box {key = "scal";label = "Olcek --> ";width=55;edit_width = 25;fixed_width = true;alignment = left;}"
": edit_box {key = "cif1"; label = "Ondalik basamak sayisi --> ";width=55;edit_width = 25;fixed_width = true;alignment = left;}}}"
               "ok_cancel_help;}"
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
             "edit_dialog2 : dialog {width=30;label="Properties";"
":boxed_row {label="Data editor";"
               ":column {fixed_width=true;width=0;"
                ":text {label="No";}:text {label="Х [m]";}:text {label="Y [m]";}:text {label="Z [m]";}:text {label="Desc.";}}"
               ":column {:edit_box {key="nom1";width=15; fixed_width = true;}
    :edit_box {key="coordx1";width=15; fixed_width = true;}
:edit_box {key="coordy1";width=15; fixed_width = true;}
:edit_box {key="coordz1";width=15; fixed_width = true;}
:edit_box {key="desc1";width=15; fixed_width = true;}}}"
"ok_cancel;}"
       )
    )
  )
  (if dialog-fp (close dialog-fp))(gc)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun Start_kpt_in_dialog ( / drv dialog-fn-kpt dialog-dcl dialog-fp)
  (if (null dialog-fn-kpt)(Write_Dialog_kpt))
  (if (and (setq dialog-dcl (load_dialog dialog-fn-kpt)) (new_dialog "kpt_in_dialog" dialog-dcl))
    (progn
  (Check_for_TT_P)
      (Activate_kpt_in_dialog)
      (setq drv (start_dialog))
      (cond
((= drv  0)(princ)); eger verirsen "cancel"
((= drv  1)(alert "ok")); eger verirsen OK
      )
    )
  )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun Activate_kpt_in_dialog ( / Tbr)
  (mapcar '(lambda (x)(action_tile (car x) (cadr x)))
    '(("cancel" "(done_dialog 0)")
      ("accept" "(Insert)(done_dialog 1)")
      ;;; rest of the buttons
      ("fil1" "(ClickedOnAddButton)")
  ("brow" "(Browse)(Update_kpt_in_dialog)")
  ("scal" "(setq scal2 $value)(scall)")
  ("cif1" "(setq cif2 $value)(ciff)")
  ("del" "(T:delete)")
  ("add" "(zeroed)(Start_edit_kptin_dialog)")
  ("help" "(t:help)")
    )
  )
  (set_tile "scal" "1000")
  (set_tile "cif1" "3")
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun Start_edit_kptin_dialog ( / drv dialog-fn-kpt dialog-dcl dialog-fp)
  (if (null dialog-fn-kpt)(Write_Dialog_kpt))
  (if (and (setq dialog-dcl (load_dialog dialog-fn-kpt)) (new_dialog "edit_dialog2" dialog-dcl))
    (progn
      (Active_edit_kptin_dialog)
      (setq drv (start_dialog))
      (cond
((= drv  0)(princ)); eger verirsen "cancel"
((= drv  1)(alert "ok")); eger verirsen OK
      )
    )
  )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun Active_edit_kptin_dialog ( / Tbr)
  (mapcar '(lambda (x)(action_tile (car x) (cadr x)))
    '(("cancel" "(done_dialog 0)")
      ("accept" "(OKK)")
      ;;; rest of the buttons
      ("nom1" "(nom)")
  ("coordx1" "(coordxx $value)")
  ("coordy1" "(coordyy $value)")
  ("coordz1" "(coordzz $value)")
  ("desc1" "(desc $value)")
    )
  )
)
(defun Update_kpt_in_dialog () (update_TTs_list))
(defun scall ()
(if (equal (numtxt scal2) 'T) (setq scal1 (/ (atof scal2) 1000)) (progn (set_tile "scal" "1000")(alert "olcegi dogru yazin")))
)
(defun ciff ()
(if (and (equal (numtxt cif2) 'T) (<= 0 (atof cif2) 10)) (setq cif3 cif2) (progn (set_tile "cif1" "3")(alert "bir kisinin 2-3 karaktere ulasmasi yeterliydi")))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun nom (/)
(if (equal (get_tile "nom1") "") (alert "Bir seyler yaz...") (setq nomm (get_tile "nom1")))
nomm)
(defun coordxx (coordx /)
(if (and (or (equal coordx2 "") (equal coordx2 'nil)) (or (equal coordx "") (equal coordx 'nil))) (alert "YAZ X" ) (progn
(if (equal (numtxt coordx) 'T) (setq coordx2 coordx)(progn (alert "Integer ...") (set_tile "coordx1" "")))))coordx2)
(defun coordyy (coordy /)
(if (or (equal coordy "") (equal coordy 'nil)) (alert "YAZ Y" ) (progn
(if (equal (numtxt coordy) 'T) (setq coordy2 coordy)(progn (alert "Integer ...") (set_tile "coordy1" "")))))
coordy2)
(defun coordzz (coordz /)
(if (or (equal coordz "") (equal coordz 'nil)) (setq coordz2 "miss H")(progn
(if (equal (numtxt coordz) 'T) (setq coordz2 coordz)(progn (alert "Integer ...") (set_tile "coordz1" "")))))
coordz2)
(defun desc (descc /)
(if (or (equal descc 'nil) (equal (get_tile "desc1") "")) (setq descc2 "miss D") (setq descc2 descc)))
(defun OKK ()
(nom)
(setq aa (coordxx (get_tile "coordx1")))
(setq bb (coordyy (get_tile "coordy1")))
(setq cc (coordzz (get_tile "coordz1")))
(if coordz2 (princ) (setq coordz2 "miss H"))
(if descc2 (princ) (setq descc2 "miss D"))
(if (/= nomm 'nil) (if aa (if bb (if cc (if descc2 (setq add1 (list nomm coordx2 coordy2 coordz2 descc2)) (progn (setq descc2 "miss D") (setq add1 nil))) (setq coordz2 "miss H")) (setq add1 nil)) (setq add1 nil)) (nom))
(if (= add1 'nil) (princ)
(progn
(setq listc2 (append listc2 (list add1)))
(done_dialog 2)
(start_list "lb_TTs_list")(mapcar 'add_list (mapcar 'tabbenize listc2))(end_list)
(set_tile "br" (strcat "Nuber of points: " (rtos (length listc2) 2 0)))
)
;(done_dialog 2)
)
(setq coordz2 nil coordx2 nil coordy2 nil nomm nil descc nil add1 nil descc2 nil)
)
(defun zeroed ()
(setq coordz2 nil coordx2 nil coordy2 nil nomm nil descc nil add1 nil descc2 nil)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:TXTOKU ( / listc2 listc)
(setq dzin (getvar 'dimzin))
(setvar 'dimzin 1)
(_Exit2)
(setvar 'cmdecho 0)
(setq coordz2 nil coordx2 nil coordy2 nil nomm nil descc nil add1 nil descc2 nil)
;(vl-cmdf "purge" "all" "*" "N")
(purge "TT_PT")
(purge "TT_P")
(purge "TT_TT")
(setvar 'cmdecho 1)
(setq st (getvar 'textstyle))
(setq listc2 nil)
(Start_kpt_in_dialog) (_Exit2)
(setvar 'textstyle st)
(setvar 'dimzin dzin)
(princ)
)
;from Internet
(defun purge (bNme)
(and (tblsearch "BLOCK" bNme)
      (setvar "CMDECHO" 0)
      (vl-cmdf "_.-purge" "_b" bNme "_n")
      (setvar "CMDECHO" 1)
      (not (tblsearch "BLOCK" bNme))))
(defun Browse ( / lst kpt lst2)
(vl-load-com)
(setq listc2 nil)
(setq sl (getfiled "SEC kpt DOSYA"
(getvar "dwgprefix")
    "txt;kpt;*"
   16
);getfiled
)
(if sl
(progn
(setq kp (open sl "r"))
  (while
(setq kpt (read-line kp))
;(setq kpt (strcat "(" kpt ")"))
    (setq lst (cons kpt lst))
  )
  (setq lst (reverse lst))
(setq llcoord '())
(repeat (length lst)
(setq lst2 nil)
(setq str (T:spaceremover (car lst)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        (setq i 0 n (strlen " "))
(while (setq j (vl-string-search " " str i))
   (setq lst2 (cons (substr str (1+ i)(- j i)) lst2)
i (+ j n)
)
)
(setq lst2 (reverse (cons (substr str (1+ i)) lst2)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setq listc (cons (append lst2 llcoord) listc))
(setq lst (cdr lst))
)
(setq listc (reverse listc))
(mode_tile "fil1" 1)(set_tile "fil1" (strcat sl))
(foreach x listc (if
(and
(>= (length x) 3) (equal (numtxt (nth 1 x)) 'T)(equal (numtxt (nth 2 x)) 'T))
(if (and (nth 3 x) (nth 4 x)) (setq listc2 (cons x listc2)) (if (nth 3 x) (setq listc2 (cons (append x (list "miss D")) listc2)) (setq listc2 (cons (append x (list "miss H" "miss D")) listc2))))))
(setq listc2 (reverse listc2))
(set_tile "br" (strcat "Nuber of points: " (rtos (length listc2) 2 0)))
))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun Insert ()
(if listc2
(progn
(setvar 'textstyle "TT_style")
(setvar 'clayer "insert_TT")
(setq fillx (dimx_tile "progbar"))
(setq filly (dimy_tile "progbar"))
(fill_image 0 0 fillx filly -15)
(end_image)
(if scal2 (princ) (setq scal1 1))
(if cif2 (princ) (setq cif3 "3"))
(setq numb 0)
(setq allnum (length listc2))
(mapcar '(lambda (x) (progn (insD (atof (nth 1 x)) (atof (nth 2 x)) (if (wcmatch (strcase (nth 0 x)) "PT*") "TT_PT" (if (wcmatch (strcase (nth 0 x)) "TT*") "TT_TT" "TT_P")) scal1 (list (strcat (strcase (nth 0 x))) (if (equal (nth 3 x) "miss H") "" (if (equal (numtxt (nth 3 x)) 'T) (if (equal (atof (nth 3 x)) 0) "" (rtos (atof (nth 3 x)) 2 (atoi cif3))))) (if (equal (nth 4 x) "miss D") "" (strcat (nth 4 x)))))
(progn (start_image "progbar")(fill_image 0 0 (/ (* numb fillx) allnum) filly 5)(end_image) (setq numb (1+ numb))(set_tile "progbar" (strcat "                                                      "(rtos (/(* numb 100) allnum) 2 2)))))) listc2)
(setq scal2 nil cif2 nil)
(princ)
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun LM:RemoveNth ( n l / i ); Lee mac lisp
    (setq i -1)
    (vl-remove-if '(lambda ( x ) (= (setq i (1+ i)) n)) l)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun T:delete (/ listc3 dell)
(setq dell (get_tile "lb_TTs_list"))
(setq listc2 (LM:RemoveNth (atof dell) listc2))
(start_list "lb_TTs_list")(mapcar 'add_list (mapcar 'tabbenize listc2))(end_list)
(set_tile "br" (strcat "Nuber of points: " (rtos (length listc2) 2 0)))
)
(defun t:help ()
(alert "Creator"))
(vl-load-com)
(princ)

;6
;|===========================================================================|
|    secilen textlerin Z degerini textin icerigi olarak degistirir          |
|                   Z_alltextmove.lsp     lispinin tersidir                 |
|___________________________________________________________________________|;
(defun c:t2rl ( / ss obj str)
(setq ss (ssget (list (cons 0 "*TEXT"))))
(repeat (setq x (sslength ss))
(setq obj (vlax-ename->vla-object (ssname ss (setq x (- x 1)))))
(setq str   (strcat "%<\\AcObjProp Object(%<\\_ObjId " (itoa (vla-get-Objectid obj)) ">%).InsertionPoint \\f  "%lu6%pt4">%"))
(vla-put-textstring obj str)
)
(command "regen")
(princ)
)

;8
;;-----------------------=={ 3-Point Rectangle }==----------------------;;
;;     uc noktadan  dikdortgen cizer                                                                 ;;
;;  This program enables the user to dynamically construct a rectangle  ;;
;;  defined by three supplied points.                                   ;;
;;                                                                      ;;
;;  The program offers two commands: '3PR' and '3PRD' which represent   ;;
;;  a standard & dynamic version of the program respectively.           ;;
;;                                                                      ;;
;;  Upon issuing either command at the AutoCAD command-line, the user   ;;
;;  is first prompted to specify two points defining one of the two     ;;
;;  pairs of parallel sides of the resulting rectangle.                 ;;
;;                                                                      ;;
;;  Following valid responses to these prompts, the user is then        ;;
;;  prompted for a third point to determine the length and direction    ;;
;;  of the second pair of edges, which are constructed perpendicular    ;;
;;  to the edges defined by the first two points.                       ;;
;;                                                                      ;;
;;  If the dynamic command is used ('3PRD') the program will display a  ;;
;;  real-time preview of the resulting rectangle whilst the user is     ;;
;;  prompted for the third point.                                       ;;
;;                                                                      ;;
;;  The user may exit the program at any time by pressing 'Enter' or    ;;
;;  right-clicking at any prompt.                                       ;;
;;                                                                      ;;
;;  Following valid specification of all three points, the program      ;;
;;  will proceed to construct the defined rectangle using an            ;;
;;  LWPolyline object.                                                  ;;
;;                                                                      ;;
;;  The dynamic version of the program utilises my GrSnap utility to    ;;
;;  enable full Object Snap functionality during the dynamic prompt.    ;;
;;  The latest version and full documentation for this application may  ;;
;;  be found at: lee-mac                  ;;
;;                                                                      ;;
;;  Finally, this program has been designed to perform successfully     ;;
;;  under all UCS & View settings.                                      ;;
;;----------------------------------------------------------------------;;
;;  Author:  Lee Mac, Copyright © 2013  -  lee-mac              ;;
;;----------------------------------------------------------------------;;
;;  Version 1.0    -    2013-12-27                                      ;;
;;                                                                      ;;
;;  - First release.                                                    ;;
;;----------------------------------------------------------------------;;
;;  Version 1.1    -    2020-10-31                                      ;;
;;                                                                      ;;
;;  - Modified the dynamic version to incorporate the ability to        ;;
;;    specify a side length when prompted for the third point.          ;;
;;----------------------------------------------------------------------;;
;;  Version 1.2    -    2021-10-06                                      ;;
;;                                                                      ;;
;;  - Modified to fix LWPolyline elevation relative to the active UCS.  ;;
;;----------------------------------------------------------------------;;
(defun c:3pr  nil (3p-rec nil)) ;; Standard version
(defun c:3prd nil (3p-rec  t )) ;; Dynamic version
;;----------------------------------------------------------------------;;
(defun 3p-rec ( dyn / *error* gr1 gr2 len lst msg ocs osf osm pt1 pt2 pt3 pt4 pt5 pt6 str tmp vec )
    (defun *error* ( msg )
        (LM:endundo (LM:acdoc))
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\nError: " msg))
        )
        (redraw) (princ)
    )
    (if
        (and
            (setq pt1 (getpoint "\nSpecify 1st point: "))
            (setq pt2 (getpoint "\nSpecify 2nd point: " pt1))
            (or   dyn (setq pt3 (getpoint "\nSpecify 3rd point: " pt1)))
            (setq vec (trans (mapcar '- pt2 pt1) 1 0 t)
                  ocs (trans '(0.0 0.0 1.0) 1 0 t)
                  pt4 (trans pt1 1 vec)
                  pt5 (trans pt2 1 vec)
            )
            (if dyn
                (progn
                    (setq osf (LM:grsnap:snapfunction)
                          osm (getvar 'osmode)
                          msg "\nSpecify 3rd point: "
                          str ""
                    )
                    (princ msg)
                    (while
                        (progn
                            (setq gr1 (grread t 15 0)
                                  gr2 (cadr gr1)
                                  gr1 (car  gr1)
                            )
                            (cond
                                (   (or (= 5 gr1) (= 3 gr1))
                                    (redraw)
                                    (osf gr2 osm)
                                    (setq pt6 (trans gr2 1 vec))
                                    (mapcar '(lambda ( a b ) (grdraw a b 1 1))
                                        (setq lst
                                            (list pt1 pt2
                                                (trans (list (car pt6) (cadr pt6) (caddr pt5)) vec 1)
                                                (trans (list (car pt6) (cadr pt6) (caddr pt4)) vec 1)
                                            )
                                        )
                                        (cons (last lst) lst)
                                    )
                                    (= 5 gr1)
                                )
                                (   (= 2 gr1)
                                    (cond
                                        (   (= 6 gr2)
                                            (if (zerop (logand 16384 (setq osm (setvar 'osmode (boole 6 16384 (getvar 'osmode))))))
                                                (princ "\n<Osnap on>")
                                                (princ "\n<Osnap off>")
                                            )
                                            (princ msg)
                                        )
                                        (   (= 8 gr2)
                                            (if (< 0 (strlen str))
                                                (progn
                                                    (princ "\010\040\010")
                                                    (setq str (substr str 1 (1- (strlen str))))
                                                )
                                            )
                                            t
                                        )
                                        (   (< 32 gr2 127)
                                            (setq str (strcat str (princ (chr gr2))))
                                        )
                                        (   (member gr2 '(13 32))
                                            (cond
                                                (   (= "" str) nil)
                                                (   (setq gr2 (LM:grsnap:parsepoint pt1 str))
                                                    (setq osm 16384)
                                                    nil
                                                )
                                                (   (setq tmp (LM:grsnap:snapmode str))
                                                    (setq osm tmp
                                                          str ""
                                                    )
                                                )
                                                (   (and pt6
                                                        (setq len (distof str))
                                                        (setq pt6 (list (car pt6) (cadr pt6) (caddr pt4)))
                                                        (not (equal 0.0 (setq tmp (distance pt4 pt6)) 1e-8))
                                                    )
                                                    (setq gr2 (trans (mapcar '(lambda ( a b ) (+ b (* len (/ (- a b) tmp)))) pt6 pt4) vec 1)
                                                          osm 16384
                                                    )
                                                    nil
                                                )
                                                (   (setq str "")
                                                    (princ (strcat "\n2D / 3D Point Required." msg))
                                                )
                                            )
                                        )
                                    )
                                )
                            )
                        )
                    )
                    (if (listp gr2)
                        (setq pt6 (trans (osf gr2 osm) 1 vec))
                    )
                )
                (setq pt6 (trans pt3 1 vec))
            )
        )
        (progn
            (LM:startundo (LM:acdoc))
            (entmake
                (list
                   '(000 . "LWPOLYLINE")
                   '(100 . "AcDbEntity")
                   '(100 . "AcDbPolyline")
                   '(090 . 4)
                   '(070 . 1)
                    (cons 038 (caddr (trans pt1 1 ocs)))
                    (cons 010 (trans pt1 1 ocs))
                    (cons 010 (trans pt2 1 ocs))
                    (cons 010 (trans (list (car pt6) (cadr pt6) (caddr pt5)) vec ocs))
                    (cons 010 (trans (list (car pt6) (cadr pt6) (caddr pt4)) vec ocs))
                    (cons 210 ocs)
                )
            )
            (LM:endundo (LM:acdoc))
        )
    )
    (redraw) (princ)
)
;; Object Snap for grread: Snap Function  -  Lee Mac
;; Returns: [fun] A function requiring two arguments:
;; p - [lst] UCS Point to be snapped
;; o - [int] Object Snap bit code
;; The returned function returns either the snapped point (displaying an appropriate snap symbol)
;; or the supplied point if the snap failed for the given Object Snap bit code.
(defun LM:grsnap:snapfunction ( )
    (eval
        (list 'lambda '( p o / q )
            (list 'if '(zerop (logand 16384 o))
                (list 'if
                   '(setq q
                        (cdar
                            (vl-sort
                                (vl-remove-if 'null
                                    (mapcar
                                        (function
                                            (lambda ( a / b )
                                                (if (and (= (car a) (logand (car a) o)) (setq b (osnap p (cdr a))))
                                                    (list (distance p b) b (car a))
                                                )
                                            )
                                        )
                                       '(
                                            (0001 . "_end")
                                            (0002 . "_mid")
                                            (0004 . "_cen")
                                            (0008 . "_nod")
                                            (0016 . "_qua")
                                            (0032 . "_int")
                                            (0064 . "_ins")
                                            (0128 . "_per")
                                            (0256 . "_tan")
                                            (0512 . "_nea")
                                            (2048 . "_app")
                                            (8192 . "_par")
                                        )
                                    )
                                )
                               '(lambda ( a b ) (< (car a) (car b)))
                            )
                        )
                    )
                    (list 'LM:grsnap:displaysnap '(car q)
                        (list 'cdr
                            (list 'assoc '(cadr q)
                                (list 'quote
                                    (LM:grsnap:snapsymbols
                                        (atoi (cond ((getenv "AutoSnapSize")) ("5")))
                                    )
                                )
                            )
                        )
                        (LM:OLE->ACI
                            (if (= 1 (getvar 'cvport))
                                (atoi (cond ((getenv "Layout AutoSnap Color")) ("117761")))
                                (atoi (cond ((getenv  "Model AutoSnap Color")) ("104193")))
                            )
                        )
                    )
                )
            )
           '(cond ((car q)) (p))
        )
    )
)
;; Object Snap for grread: Display Snap  -  Lee Mac
;; pnt - [lst] UCS point at which to display the symbol
;; lst - [lst] grvecs vector list
;; col - [int] ACI colour for displayed symbol
;; Returns nil
(defun LM:grsnap:displaysnap ( pnt lst col / scl )
    (setq scl (/ (getvar 'viewsize) (cadr (getvar 'screensize)))
          pnt (trans pnt 1 2)
    )
    (grvecs (cons col lst)
        (list
            (list scl 0.0 0.0 (car  pnt))
            (list 0.0 scl 0.0 (cadr pnt))
            (list 0.0 0.0 scl 0.0)
           '(0.0 0.0 0.0 1.0)
        )
    )
)
;; Object Snap for grread: Snap Symbols  -  Lee Mac
;; p - [int] Size of snap symbol in pixels
;; Returns: [lst] List of vector lists describing each Object Snap symbol
(defun LM:grsnap:snapsymbols ( p / -p -q -r a c i l q r )
    (setq -p (- p) q (1+  p)
          -q (- q) r (+ 2 p)
          -r (- r) i (/ pi 6.0)
           a 0.0
    )
    (repeat 12
        (setq l (cons (list (* r (cos a)) (* r (sin a))) l)
              a (- a i)
        )
    )
    (setq c (apply 'append (mapcar 'list (cons (last l) l) l)))
    (list
        (list 1
            (list -p -p) (list p -p) (list p -p) (list p p) (list p p) (list -p p) (list -p p) (list -p -p)
            (list -q -q) (list q -q) (list q -q) (list q q) (list q q) (list -q q) (list -q q) (list -q -q)
        )
        (list 2
            (list -r -q) (list 0  r) (list 0  r) (list r -q)
            (list -p -p) (list p -p) (list p -p) (list 0  p) (list 0  p) (list -p -p)
            (list -q -q) (list q -q) (list q -q) (list 0  q) (list 0  q) (list -q -q)
        )
        (cons 4 c)
        (vl-list* 8 (list -r -r) (list r r) (list r -r) (list -r r) c)
        (list 16
            (list p 0) (list 0 p) (list 0 p) (list -p 0) (list -p 0) (list 0 -p) (list 0 -p) (list p 0)
            (list q 0) (list 0 q) (list 0 q) (list -q 0) (list -q 0) (list 0 -q) (list 0 -q) (list q 0)
            (list r 0) (list 0 r) (list 0 r) (list -r 0) (list -r 0) (list 0 -r) (list 0 -r) (list r 0)
        )
        (list 32
            (list  r r) (list -r -r) (list  r q) (list -q -r) (list  q r) (list -r -q)
            (list -r r) (list  r -r) (list -q r) (list  r -q) (list -r q) (list  q -r)
        )
        (list 64
            '( 0  1) (list  0  p) (list  0  p) (list -p  p) (list -p  p) (list -p -1) (list -p -1) '( 0 -1)
            '( 0 -1) (list  0 -p) (list  0 -p) (list  p -p) (list  p -p) (list  p  1) (list  p  1) '( 0  1)
            '( 1  2) (list  1  q) (list  1  q) (list -q  q) (list -q  q) (list -q -2) (list -q -2) '(-1 -2)
            '(-1 -2) (list -1 -q) (list -1 -q) (list  q -q) (list  q -q) (list  q  2) (list  q  2) '( 1  2)
        )
        (list 128
            (list (1+ -p) 0) '(0 0) '(0 0) (list 0 (1+ -p))
            (list (1+ -p) 1) '(1 1) '(1 1) (list 1 (1+ -p))
            (list -p q) (list -p -p) (list -p -p) (list q -p)
            (list -q q) (list -q -q) (list -q -q) (list q -q)
        )
        (vl-list* 256 (list -r r)  (list r r) (list -r (1+ r)) (list r (1+ r)) c)
        (list 512
            (list -p -p) (list  p -p) (list -p  p) (list p p) (list -q -q) (list  q -q)
            (list  q -q) (list -q  q) (list -q  q) (list q q) (list  q  q) (list -q -q)
        )
        (list 2048
            (list   -p     -p) (list    p      p) (list   -p      p) (list    p     -p)
            (list (+ p 05) -p) (list (+ p 06) -p) (list (+ p 05) -q) (list (+ p 06) -q)
            (list (+ p 09) -p) (list (+ p 10) -p) (list (+ p 09) -q) (list (+ p 10) -q)
            (list (+ p 13) -p) (list (+ p 14) -p) (list (+ p 13) -q) (list (+ p 14) -q)
            (list -p -p) (list p -p) (list p -p) (list p p) (list p p) (list -p p) (list -p p) (list -p -p)
            (list -q -q) (list q -q) (list q -q) (list q q) (list q q) (list -q q) (list -q q) (list -q -q)
        )
        (list 8192 (list r 1) (list -r -q) (list r 0) (list -r -r) (list r q) (list -r -1) (list r r) (list -r 0))
    )
)
;; Object Snap for grread: Parse Point  -  Lee Mac
;; bpt - [lst] Basepoint for relative point input, e.g. @5,5
;; str - [str] String representing point input
;; Returns: [lst] Point represented by the given string, else nil
(defun LM:grsnap:parsepoint ( bpt str / str->lst lst )
    (defun str->lst ( str / pos )
        (if (setq pos (vl-string-position 44 str))
            (cons (substr str 1 pos) (str->lst (substr str (+ pos 2))))
            (list str)
        )
    )
    (if (wcmatch str "`@*")
        (setq str (substr str 2))
        (setq bpt '(0.0 0.0 0.0))
    )
    (if
        (and
            (setq lst (mapcar 'distof (str->lst str)))
            (vl-every 'numberp lst)
            (< 1 (length lst) 4)
        )
        (mapcar '+ bpt lst)
    )
)
;; Object Snap for grread: Snap Mode  -  Lee Mac
;; str - [str] Object Snap modifier
;; Returns: [int] Object Snap bit code for the given modifier, else nil
(defun LM:grsnap:snapmode ( str )
    (vl-some
        (function
            (lambda ( x )
                (if (wcmatch (car x) (strcat (strcase str t) "*"))
                    (progn
                        (princ (cadr x)) (caddr x)
                    )
                )
            )
        )
       '(
            ("endpoint"      " of " 00001)
            ("midpoint"      " of " 00002)
            ("center"        " of " 00004)
            ("node"          " of " 00008)
            ("quadrant"      " of " 00016)
            ("intersection"  " of " 00032)
            ("insert"        " of " 00064)
            ("perpendicular" " to " 00128)
            ("tangent"       " to " 00256)
            ("nearest"       " to " 00512)
            ("appint"        " of " 02048)
            ("parallel"      " to " 08192)
            ("none"          ""     16384)
        )
    )
)
;; OLE -> ACI  -  Lee Mac
;; Args: c - [int] OLE Colour
(defun LM:OLE->ACI ( c )
    (apply 'LM:RGB->ACI (LM:OLE->RGB c))
)
;; OLE -> RGB  -  Lee Mac
;; Args: c - [int] OLE Colour
(defun LM:OLE->RGB ( c )
    (mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(24 16 8))
)
;; RGB -> ACI  -  Lee Mac
;; Args: r,g,b - [int] Red, Green, Blue values
(defun LM:RGB->ACI ( r g b / c o )
    (if (setq o (vla-getinterfaceobject (LM:acapp) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
        (progn
            (setq c (vl-catch-all-apply '(lambda ( ) (vla-setrgb o r g b) (vla-get-colorindex o))))
            (vlax-release-object o)
            (if (vl-catch-all-error-p c)
                (prompt (strcat "\nError: " (vl-catch-all-error-message c)))
                c
            )
        )
    )
)
;; Start Undo  -  Lee Mac
;; Opens an Undo Group.
(defun LM:startundo ( doc )
    (LM:endundo doc)
    (vla-startundomark doc)
)
;; End Undo  -  Lee Mac
;; Closes an Undo Group.
(defun LM:endundo ( doc )
    (while (= 8 (logand 8 (getvar 'undoctl)))
        (vla-endundomark doc)
    )
)
;; Active Document  -  Lee Mac
;; Returns the VLA Active Document Object
(defun LM:acdoc nil
    (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
    (LM:acdoc)
)
;; Application Object  -  Lee Mac
;; Returns the VLA Application Object
(defun LM:acapp nil
    (eval (list 'defun 'LM:acapp 'nil (vlax-get-acad-object)))
    (LM:acapp)
)
;;----------------------------------------------------------------------;;
(vl-load-com)
(princ
    (strcat
        "\n:: 3P-Rec.lsp | Version 1.2 | \\U+00A9 Lee Mac "
        ((lambda ( y ) (if (= y (menucmd "m=$(edtime,0,yyyy)")) y (strcat y "-" (menucmd "m=$(edtime,0,yyyy)")))) "2013")
        " lee-mac ::"
        "\n:: "3pr" - Standard | "3prd" - Dynamic ::"
    )
)
(princ)
;;----------------------------------------------------------------------;;
;;                             End of File                              ;;
;;----------------------------------------------------------------------;;

;10
;;--------------------=={ Change Block Base Point }==-------------------;;
;;        bloklarin referans  nokasini  degistirir                                                              ;;
;;  This program allows the user to change the base point for all       ;;
;;  block references of a block definition in a drawing.                ;;
;;                                                                      ;;
;;  The program offers two commands:                                    ;;
;;                                                                      ;;
;;  ------------------------------------------------------------------  ;;
;;  CBP (Change Base Point)                                             ;;
;;  ------------------------------------------------------------------  ;;
;;                                                                      ;;
;;  This command will retain the insertion point coordinates for all    ;;
;;  references of the selected block. Hence visually, the block         ;;
;;  components will be moved around the insertion point when the        ;;
;;  base point is changed.                                              ;;
;;                                                                      ;;
;;  ------------------------------------------------------------------  ;;
;;  CBPR (Change Base Point Retain Reference Position)                  ;;
;;  ------------------------------------------------------------------  ;;
;;                                                                      ;;
;;  This command will retain the position of the each block reference   ;;
;;  of the selected block. Hence, each block reference will be moved    ;;
;;  to retain the visual position when the base point is changed.       ;;
;;                                                                      ;;
;;  ------------------------------------------------------------------  ;;
;;                                                                      ;;
;;  Upon issuing a command syntax at the AutoCAD command-line, the      ;;
;;  program will prompt the user to select a block for which to change  ;;
;;  the base point.                                                     ;;
;;                                                                      ;;
;;  Following a valid selection, the user is then prompted to specify   ;;
;;  a new base point relative to the selected block.                    ;;
;;                                                                      ;;
;;  The block definition (and block reference depending on the command  ;;
;;  used) will then be modified to reflect the new block base point.    ;;
;;                                                                      ;;
;;  If the selected block is attributed, an ATTSYNC operation will      ;;
;;  also be performed to ensure all attributes are in the correct       ;;
;;  positions relative to the new base point.                           ;;
;;                                                                      ;;
;;  Finally, the active viewport is regenerated to reflect the changes  ;;
;;  throughout all references of the block.                             ;;
;;                                                                      ;;
;;  The program will furthermore perform successfully with rotated &    ;;
;;  scaled block references, constructed in any UCS plane.              ;;
;;                                                                      ;;
;;  ------------------------------------------------------------------  ;;
;;  Please Note:                                                        ;;
;;  ------------------------------------------------------------------  ;;
;;                                                                      ;;
;;  A REGEN is required if the UNDO command is used to undo the         ;;
;;  operations performed by this program.                               ;;
;;                                                                      ;;
;;----------------------------------------------------------------------;;
;;  Author:  Lee Mac, Copyright © 2013  -  lee-mac             ;;
;;----------------------------------------------------------------------;;
;;  Version 1.5    -    20-10-2013                                      ;;
;;----------------------------------------------------------------------;;
;; Retains Insertion Point Coordinates
(defun c:cbp  nil (LM:changeblockbasepoint nil))
;; Retains Block Reference Position
(defun c:cbpr nil (LM:changeblockbasepoint t))
;;----------------------------------------------------------------------;;
(defun LM:changeblockbasepoint ( flg / *error* bln cmd ent lck mat nbp vec )
    (defun *error* ( msg )
        (foreach lay lck (vla-put-lock lay :vlax-true))
        (if (= 'int (type cmd)) (setvar 'cmdecho cmd))
        (LM:endundo (LM:acdoc))
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\nError: " msg))
        )
        (princ)
    )
    (while
        (progn (setvar 'errno 0) (setq ent (car (entsel "\nSelect Block: ")))
            (cond
                (   (= 7 (getvar 'errno))
                    (princ "\nMissed, try again.")
                )
                (   (= 'ename (type ent))
                    (if (/= "INSERT" (cdr (assoc 0 (entget ent))))
                        (princ "\nSelected object is not a block.")
                    )
                )
            )
        )
    )
    (if (and (= 'ename (type ent)) (setq nbp (getpoint "\nSpecify New Base Point: ")))
        (progn
            (setq mat (car (revrefgeom ent))
                  vec (mxv mat (mapcar '- (trans nbp 1 0) (trans (cdr (assoc 10 (entget ent))) ent 0)))
                  bln (LM:blockname (vlax-ename->vla-object ent))
            )
            (LM:startundo (LM:acdoc))
            (vlax-for lay (vla-get-layers (LM:acdoc))
                (if (= :vlax-true (vla-get-lock lay))
                    (progn
                        (vla-put-lock lay :vlax-false)
                        (setq lck (cons lay lck))
                    )
                )
            )
            (vlax-for obj (vla-item (vla-get-blocks (LM:acdoc)) bln)
                 (vlax-invoke obj 'move vec '(0.0 0.0 0.0))
            )
            (if flg
                (vlax-for blk (vla-get-blocks (LM:acdoc))
                    (if (= :vlax-false (vla-get-isxref blk))
                        (vlax-for obj blk
                            (if
                                (and
                                    (= "AcDbBlockReference" (vla-get-objectname obj))
                                    (= bln (LM:blockname obj))
                                    (vlax-write-enabled-p obj)
                                )
                                (vlax-invoke obj 'move '(0.0 0.0 0.0) (mxv (car (refgeom (vlax-vla-object->ename obj))) vec))
                            )
                        )
                    )
                )
            )
            (if (= 1 (cdr (assoc 66 (entget ent))))
                (progn
                    (setq cmd (getvar 'cmdecho))
                    (setvar 'cmdecho 0)
                    (vl-cmdf "_.attsync" "_N" bln)
                    (setvar 'cmdecho cmd)
                )
            )
            (foreach lay lck (vla-put-lock lay :vlax-true))
            (vla-regen  (LM:acdoc) acallviewports)
            (LM:endundo (LM:acdoc))
        )
    )
    (princ)
)
;; RefGeom (gile)
;; Returns a list whose first item is a 3x3 transformation matrix and
;; second item the object insertion point in its parent (xref, block or space)
(defun refgeom ( ent / ang enx mat ocs )
    (setq enx (entget ent)
          ang (cdr (assoc 050 enx))
          ocs (cdr (assoc 210 enx))
    )
    (list
        (setq mat
            (mxm
                (mapcar '(lambda ( v ) (trans v 0 ocs t))
                   '(
                        (1.0 0.0 0.0)
                        (0.0 1.0 0.0)
                        (0.0 0.0 1.0)
                    )
                )
                (mxm
                    (list
                        (list (cos ang) (- (sin ang)) 0.0)
                        (list (sin ang) (cos ang)     0.0)
                       '(0.0 0.0 1.0)
                    )
                    (list
                        (list (cdr (assoc 41 enx)) 0.0 0.0)
                        (list 0.0 (cdr (assoc 42 enx)) 0.0)
                        (list 0.0 0.0 (cdr (assoc 43 enx)))
                    )
                )
            )
        )
        (mapcar '- (trans (cdr (assoc 10 enx)) ocs 0)
            (mxv mat (cdr (assoc 10 (tblsearch "block" (cdr (assoc 2 enx))))))
        )
    )
)
;; RevRefGeom (gile)
;; The inverse of RefGeom
(defun revrefgeom ( ent / ang enx mat ocs )
    (setq enx (entget ent)
          ang (cdr (assoc 050 enx))
          ocs (cdr (assoc 210 enx))
    )
    (list
        (setq mat
            (mxm
                (list
                    (list (/ 1.0 (cdr (assoc 41 enx))) 0.0 0.0)
                    (list 0.0 (/ 1.0 (cdr (assoc 42 enx))) 0.0)
                    (list 0.0 0.0 (/ 1.0 (cdr (assoc 43 enx))))
                )
                (mxm
                    (list
                        (list (cos ang)     (sin ang) 0.0)
                        (list (- (sin ang)) (cos ang) 0.0)
                       '(0.0 0.0 1.0)
                    )
                    (mapcar '(lambda ( v ) (trans v ocs 0 t))
                        '(
                             (1.0 0.0 0.0)
                             (0.0 1.0 0.0)
                             (0.0 0.0 1.0)
                         )
                    )
                )
            )
        )
        (mapcar '- (cdr (assoc 10 (tblsearch "block" (cdr (assoc 2 enx)))))
            (mxv mat (trans (cdr (assoc 10 enx)) ocs 0))
        )
    )
)
;; Matrix x Vector  -  Vladimir Nesterovsky
;; Args: m - nxn matrix, v - vector in R^n
(defun mxv ( m v )
    (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)
;; Matrix x Matrix  -  Vladimir Nesterovsky
;; Args: m,n - nxn matrices
(defun mxm ( m n )
    ((lambda ( a ) (mapcar '(lambda ( r ) (mxv a r)) m)) (trp n))
)
;; Matrix Transpose  -  Doug Wilson
;; Args: m - nxn matrix
(defun trp ( m )
    (apply 'mapcar (cons 'list m))
)
;; Block Name  -  Lee Mac
;; Returns the true (effective) name of a supplied block reference
(defun LM:blockname ( obj )
    (if (vlax-property-available-p obj 'effectivename)
        (defun LM:blockname ( obj ) (vla-get-effectivename obj))
        (defun LM:blockname ( obj ) (vla-get-name obj))
    )
    (LM:blockname obj)
)
;; Start Undo  -  Lee Mac
;; Opens an Undo Group.
(defun LM:startundo ( doc )
    (LM:endundo doc)
    (vla-startundomark doc)
)
;; End Undo  -  Lee Mac
;; Closes an Undo Group.
(defun LM:endundo ( doc )
    (while (= 8 (logand 8 (getvar 'undoctl)))
        (vla-endundomark doc)
    )
)
;; Active Document  -  Lee Mac
;; Returns the VLA Active Document Object
(defun LM:acdoc nil
    (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
    (LM:acdoc)
)
;;----------------------------------------------------------------------;;
(vl-load-com)
(princ
    (strcat
        "\n:: ChangeBlockBasePoint.lsp | Version 1.5 | \\U+00A9 Lee Mac "
        (menucmd "m=$(edtime,0,yyyy)")
        " lee-mac::"
        "\n:: Available Commands:"
        "\n::    "CBP"  -  Retain Insertion Point Position"
        "\n::    "CBPR" -  Retain Block Reference Position"
    )
)
(princ)
;;----------------------------------------------------------------------;;
;;                             End of File                              ;;
;;----------------------------------------------------------------------;;

;12
; Otomatik Koordinat Ekleme
; Sertan Turkan
;
; Automatic coordinate labeling
; Edwin Prakoso
;
;
; Kisitlama
; ----------
; Gecerli kilavuz "leader" stili ve birim ayarlari kullanilacaktir.
(defun c:lb (/  p x y ptcoord textloc)
  (while
    (setq p (getpoint "\nKOORDINATINI YAZDIRMAK ISTEDIGINIZ NOKTAYI TIKLAYIN: "))
    (setq textloc (getpoint "\nKILAVUZUN KONUMUNU TIKLAYIN: "))
    (setq x (rtos (car p)))
    (setq y (rtos (cadr p)))
    (setq z (rtos (caddr p)))
    (setq ptcoord (strcat y "
" x "
" z))
    (command "_LEADER" p textloc "" ptcoord "")
  )
)

;14
;|=======================================================|
|    istenilen uzunlukta yay arc  ciziyor               |
|         ehya - cizimokulu                             |
|_______________________________________________________|;
(defun ad_hata (s)
  (if (/= s "Function cancelled")
    (princ (strcat "\nError: " s))
  )
  (setq *error* olderr)
  (princ)
)
(defun c:AUC (/ cen str len rdi ang yarcapbul)
  (setq olderr *error*
*error* ad_hata
  )
  (setq cmd (getvar "cmdecho"))
  (setvar "cmdecho" 0)
  (setq cen (getpoint "\nMerkez Nokta:"))
  (setq str (getpoint cen "\nBaclangic Noktasi:"))
  (setq rdi (distance cen str))
  (setq len (getreal "\nArcin uzunlugunu giriniz...:"))
  (setq ang (/ (* len 360) (* 2 pi rdi)))
  (setq yarcapbul (* 2 pi rdi))
  (if (<= yarcapbul len)
    (progn
      (alert
"\nVerilen uzunluk bu yay icin cok fazla.."
      )
    )
  )
  (if (>= yarcapbul len)
    (progn
      (command "_.ARC" "C" cen str "A" ang)
    )
  )
  (setvar "cmdecho" cmd)
  (princ)
)

;16-1
;;  Paralel olmayan iki hattin orta aksini cizer
;;  LineBetween.lsp [command name: LBL]
;;  To draw a Line whose endpoints are halfway Between those of two
;;    User-selected Lines or Polyline [of any variety] line segments.
;;  Draws Line on current Layer.
;;  Accounts for Lines or Polyline line segments running generally in
;;    same or opposite directions, and for 3rd dimension if applicable.
;;  May draw Line between "wrong" halfway-between points if objects
;;    cross, or if one crosses their apparent intersection, because routine
;;    has no way to judge which possibility is expected -- try reversing
;;    one object to get "right" result.
;;  Result will not necessarily lie along angle bisector between selected
;;    objects; will do so only if objects' relationship is symmetrical.
;;  Kent Cooper, 5 March 2013
(defun C:LBL ; = Line Between
  (/ *error* noZ svnames svvals esel ent edata etype pick s1 e1 s2 e2 int)
  (defun *error* (errmsg)
    (if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
      (princ (strcat "\nError: " errmsg))
    ); if
    (command "_.undo" "_end")
    (mapcar 'setvar svnames svvals)
    (princ)
  ); defun - *error*
  (defun noZ (pt) (list (car pt) (cadr pt)))
  (setq
    svnames '(cmdecho aperture); = System Variable NAMES
    svvals (mapcar 'getvar svnames); = System Variable VALueS
  ); setq
  (mapcar 'setvar svnames (list 0 (getvar 'pickbox)))
    ; aperture = pickbox to prevent Osnap Center seeing wrong object
  (command "_.undo" "_begin")
  (foreach num '("1" "2")
    (while
      (not
        (and
          (setq esel (entsel (strcat "\nSelect Line/Polyline line segment #" num ": ")))
          (setq
            ent (car esel)
            edata (entget ent)
            etype (cdr (assoc 0 edata))
            pick (osnap (cadr esel) "nea"); for (vlax-curve-...) later
          ); setq
          (wcmatch etype "LINE,*POLYLINE")
          (not (osnap pick "_cen")); if Polyline, not fit-curved or on arc segment
          (if (= etype "POLYLINE") (= (boole 1 4 (cdr (assoc 70 edata))) 0) T)
            ; not spline-curved 2D "heavy" or 3D Polyline [T for Line]
        ); and
      ); not
      (prompt "\nNothing, or Polyline curve, or invalid object type, selected --")
    ); while
    (set (read (strcat "s" num)); s1 or s2 [start]
      (if (= etype "LINE")
        (cdr (assoc 10 edata)); then
        (vlax-curve-getPointAtParam ent (fix (vlax-curve-getParamAtPoint ent pick))); else
      ); if
    ); set
    (set (read (strcat "e" num)); e1 or e2 [end]
      (if (= etype "LINE")
        (cdr (assoc 11 edata)); then
        (vlax-curve-getPointAtParam ent (1+ (fix (vlax-curve-getParamAtPoint ent pick)))); else
      ); if
    ); set
  ); foreach
  (setq int (inters (noZ s1) (noZ s2) (noZ e1) (noZ e2))); T or nil -- opposite directions
  (entmake
    (list
      '(0 . "LINE")
      (cons 10 (mapcar '/ (mapcar '+ s1 (if int e2 s2)) '(2 2 2)))
      (cons 11 (mapcar '/ (mapcar '+ e1 (if int s2 e2)) '(2 2 2)))
    ); list
  ); entmake
  (command "_.undo" "_end")
  (mapcar 'setvar svnames svvals)
  (princ)
); defun
(prompt "\nType LBL to draw a Line halfway Between two Lines/Polyline line segments.")

;16-2
;;  Paralel olmayan iki hattin orta aksini cizer.(pline hattin tamamini tek seferde cizer)
;;  PLineBetween.lsp [command name: LBL]
;;  duzenleyen   cadtutor     alanjt
;; Draw (LW)Polyline between two selected curves (at midpoint of vertices).
(defun c:LBL (/ foo AT:GetSel _pnts _pline _lwpline _dist e1 e2)
(vl-load-com)
(defun foo (e)
  (and (wcmatch (cdr (assoc 0 (entget (car e)))) "LINE,*POLYLINE,SPLINE")
   (not (vlax-curve-isClosed (car e)))))
(defun AT:GetSel (meth msg fnc / ent)
  (while
   (progn
    (setvar 'ERRNO 0)
    (setq ent (meth (cond (msg) ("\nSelect object: "))))
    (cond
   ((eq (getvar 'ERRNO) 7) (princ "\nMissed, try again."))
     ((eq (type (car ent)) 'ENAME)
      (if (and fnc (not (fnc ent)))
       (princ "\nInvalid object!"))))))
  ent)
(defun _pnts (e / p l)
  (if e
   (cond
    ((wcmatch (cdr (assoc 0 (entget e))) "ARC,LINE,SPLINE")
     (list (vlax-curve-getStartPoint e) (vlax-curve-getEndPoint e)))
    ((wcmatch (cdr (assoc 0 (entget e))) "*POLYLINE")
     (repeat (setq p (1+ (fix (vlax-curve-getEndParam e))))
      (setq l (cons (vlax-curve-getPointAtParam e (setq p (1- p))) l)))))))
(defun _pline (lst)
  (if
   (and
    (> (length lst) 1)
    (entmakex '((0 . "POLYLINE") (10 0. 0. 0.) (70 . 8)))
    (foreach x lst (entmakex (list '(0 . "VERTEX") (cons 10 x) '(70 . 32)))))
   (cdr (assoc 330 (entget (entmakex '((0 . "SEQEND"))))))))
(defun _lwpline (lst)
  (if (> (length lst) 1)
   (entmakex (append
     (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length lst)) (cons 70 (* (getvar 'plinegen) 128)))
     (mapcar (function (lambda (p) (list 10 (car p) (cadr p)))) lst)))))
(defun _dist (a b)
  (distance (list (car a) (cadr a)) (list (car b) (cadr b))))
  (if
   (and
    (setq e1 (_pnts (car (AT:GetSel entsel "\nilk hatti secin: " foo))))
    (setq e2 (_pnts (car (AT:GetSel entsel "\nikinci hatti secin: " foo))))
    (not (initget 0 "Lwpolyline Polyline"))
    (setq *LBL:Opt* (cond ((getkword (strcat "\nSpecify line to draw: [Lwpolyline/Polyline] <" (cond (*LBL:Opt*) ((setq *LBL:Opt* "Lwpolyline"))) ">: "))) (*LBL:Opt*))))
   ((if (eq *LBL:Opt* "Lwpolyline") _lwpline _pline)
    (vl-remove nil
     (mapcar (function (lambda(a b)
   (if (and a b (not (grdraw (trans a 0 1) (trans b 0 1) 1 1)))
    (mapcar (function (lambda (a b) (/ (+ a b) 2.))) a b))))
       e1
      (if (< (_dist (car e1) (car e2)) (_dist (car e1) (last e2))) e2 (reverse e2))))))
(vla-Regen (vla-get-ActiveDocument (vlax-get-acad-object)) acActiveViewport)
(princ))
(prompt "\nType LBL to draw a Line halfway Between two Lines/Polyline line segments.")

;18
;;; alanlari,cevre uzunlugunu ve mahal isimlerini  tabloya yazdirir (mahal ismi manuel onceden verilecek )
;;; Poly-Pts (gile)
;;; Returns the vertices list of any type of polyline (WCS coordinates)
;;;
;;; Argument
;;; pl : a polyline (ename or vla-object)
;;;_gile
;;;http://forums.augi.com/showthread.php?83935-Creating-a-list-Polyline-vertices
;;; duzenleyen  cizim okulu
(defun Poly-Pts (pl / pa pt lst)
        (setvar "dimzin" 0)
  (vl-load-com)
  (setq pa (if (vlax-curve-IsClosed pl)
     (vlax-curve-getEndParam pl)
     (+ (vlax-curve-getEndParam pl) 1)
   )
  )
  (while (setq pt (vlax-curve-getPointAtParam pl (setq pa (- pa 1))))
    (setq lst (cons pt lst))
  )
)
(defun c:RoomArea ( / AllSlctn pobj pobjArea pobjPoints RoomText RoomTextObj pnt loc cnt)
(setq AllSlctn (ssget  '((0 . "LWPOLYLINE"))))
(if AllSlctn
(progn
(setq pnt (getpoint "\nPick the point for table: "))
(setq loc  (vla-get-modelspace(vla-get-activedocument(vlax-get-acad-object))))
(setq table (vla-AddTable loc (vlax-3d-point pnt) 2 3 1 40))
(vla-settext table 0 0 "Area Table")             ; "Alan Tablosu"
            (vla-settext table 1 0 "Room Label") ; "Mahal No"
            (vla-settext table 1 1 "Area")       ; "Alan"
            (vla-settext table 1 2 "length")     ; "uzunluk"
(setq cnt 0)
(repeat (sslength AllSlctn)
(setq pobj (ssname AllSlctn cnt))
(setq vlpobj (vlax-ename->vla-object pobj))
(setq pobjArea (vla-get-area vlpobj))
(setq pobjPoints (Poly-Pts pobj))
(setq RoomTextObj (ssget "_WP" pobjPoints '((0 . "*TEXT"))))
(if RoomTextObj
(progn
(setq RoomText (vlax-ename->vla-object(ssname RoomTextObj 0 )))
(vla-insertrows table (+ 2 cnt) 1 1)
(vla-settext table (+ 2 cnt) 0 (vla-get-TextString RoomText))
(vla-settext table (+ 2 cnt) 1 (rtos (/(vla-get-area vlpobj)1.)2 3))
(vla-settext table (+ 2 cnt) 2 (rtos (/(vla-get-length vlpobj)1.)2 3))
);progn
);if
(setq cnt ( + cnt 1))
);repeat
);progn
);if
);defun