(vl-load-com)

(defun c:KALIP ()



;;;;;;;;;;;;;;;;; layer ve xls tanımları ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

      (setq dosyaxls (strcat (getvar "dwgprefix") (substr (getvar "dwgname") 1 (- (strlen (getvar "dwgname")) 4 )) ))
      (setq tk (open (strcat dosyaxls ".xls") "a"))
  (setq k -1)
      (setq d -1)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;;;;;;;;;;;;;;; döşeme ve kiriş adı seç ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;DÖŞEME ADI
(princ "\nDoseme Adi Sec: ")
(setq dd (ssget (list (cons 0 "insert") (cons 2 "DAD") ) ))
(setq dosadi (LM:GetAttributeValue (ssname dd 0) "DD202"))
(setq dosyuks (LM:GetAttributeValue (ssname dd 0) "14"))
;KİRİŞ ADI
(princ "\nKiris/Kolon/Merdiven Adi Sec: ")



(setq kiradi (cdr (assoc 1 (entget (ssname (ssget '((0 . "Text")
(-4 . "<AND")
(-4 . "<NOT")
(1 . "*ES*")
(-4 . "NOT>")

(-4 . "<OR")
(8 . "Mpi_YKKIA")
(8 . "Mpi_KIA")
(8 . "Mpi_KOLAD")
(8 . "Mpi_PERAD")
(8 . "Mpi_MERAD")
(-4 . "OR>")
(-4 . "AND>") )) 0)))))


;;;;;;;; KİRİŞ VE DÖŞEME YUKSEKLIK VE DERINLIGINI HESAPLAYAN BOLUM;;;;;;;;;;;;;;
(setq kirkesme1 (vl-string-search "(" kiradi))
(setq kirtextuz (strlen kiradi))
(setq subkir1 (substr kiradi (+ kirkesme1 2) kirtextuz))

(setq kirkesme2 (vl-string-search "/" subkir1))
(setq subkir1textuz (strlen subkir1))
(setq subkir2 (substr subkir1 (+ kirkesme2 1) subkir1textuz))
(setq kirgenislik (vl-string-subst "" subkir2 subkir1))

(setq subkir3 (substr subkir1 (+ kirkesme2 2) subkir1textuz))
(setq kirderinlik (vl-string-right-trim ")" subkir3))


(setq subkiradi (substr kiradi 1 kirkesme1 ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;LAYER CHECK AND CREATE


  (setq ltname "continuous"
        layname (strcat (rtos (- (atoi kirderinlik) (atoi dosyuks) ) 2 2 ) "'lik kiris kanat")
        laycol (rtos (- (atoi kirderinlik) (atoi dosyuks) ) 2 2 )
        cmdold (getvar "CMDECHO"))
  (setvar "CMDECHO" 0)

  ;; Loading Linetype  ~ Another option to consider:

  (if (not (tblsearch "LTYPE" ltname))
    (vla-load
      (vla-get-Linetypes
        (vla-get-ActiveDocument
          (vlax-get-acad-object))) ltname "acad.lin"))

  ;; Layer Checking & Creation

  (if (not (tblsearch "LAYER" layname))
    (command "_.-layer" "_M" layname "_L" ltname layname "_C" laycol layname "")
    (setvar "CLAYER" layname))

  ;; Another Option for Layer Creation to Consider:

  (if (not (tblsearch "LAYER" layname))
    (progn
      (setq lay (vla-add
                  (vla-get-layers
                    (vla-get-ActiveDocument
                      (vlax-get-acad-object))) layname))
      (vla-put-color lay laycol)
      (vla-put-linetype lay ltname)))
  (setvar "CLAYER" layname)

  ;; Reset CMDECHO

  (setvar "CMDECHO" cmdold)
  (princ)

;;;LAYER CHECK AND CREATE

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;(command "._CHANGE" "p" "" "Properties" "Layer" layname "")
(write-line (strcat subkiradi  "\t" dosadi)  tk)
;;;;;Kalıp boyları;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(princ "\nKalip Parcasi Sec: ")
  (setq ss (ssget '( (0 . "POLYLINE,ARC,LINE,LWPOLYLINE,2DPOLYLINE") (-4 . "<NOT") (62 . 18) (-4 . "NOT>"))))
   
    (initget (+ 1 2 4))
    ;check user input
    ;(setq sc (getdist "\nEnter Text Height : "))
(setq sc 0.1)
    ;get the text height

    ;check user input
    ;(setq ndg (getint "\nEnter No of digits : "))
(setq ndg 2)
    ;get the text height
     


  (repeat (setq cnt (sslength ss))
    (setq obj (vlax-ename->vla-object (ssname ss (setq cnt (1- cnt)))))
    (if (vlax-property-available-p obj 'arclength)
      (setq len (/ (vla-get-arclength obj) 2.0))
      (setq len (/ (vla-get-length obj) 2.0))
    );APE
    (setq
      tp1   (vlax-curve-getPointAtDist obj (+ len 0.1))
          tp2   (vlax-curve-getPointAtDist obj (- len 0.1))
x (/ (+ (car tp1)(car tp2)) 2)
y (/ (+ (cadr tp1)(cadr tp2)) 2)
z (/ (+ (caddr tp1)(caddr tp2)) 2)
midpt (list x y z)
     ang   (* (angle tp2 tp1) (/ 180.0 pi))
    )


  ;(setq uzunluklar (rtos (* len 2.0) 2 ndg))
  (vl-string-translate "." "," (rtos (* len 2.0) 2 ndg))
  (setq uzunluklar (vl-string-translate "." "," (rtos (* len 2.0) 2 ndg)))
  ;(command "._CHANGE" ss "" "Properties" "Color" "18" "")
   
  (command "._CHANGE" ss "" "Properties" "layer" layname "")
  (write-line (strcat "" "\t" "" "\t" "1" "\t" "1" "\t" uzunluklar "\t" dosyuks "\t" kirgenislik "\t" kirderinlik) tk)
    (command "text" "J" "TC" midpt sc ang (strcat "L= " uzunluklar " m"))
)
(close tk)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;





)


;;;;;;;;;;;;;;;;; ATTRIB DEFUN  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (defun LM:GetAttributeValue (blk tag / val enx)
    (while
      (and
        (null val)
        (= "ATTRIB"
           (cdr (assoc 0 (setq enx (entget (setq blk (entnext blk))))))
        )
      )
       (if (= (strcase tag) (strcase (cdr (assoc 2 enx))))
         (setq val (cdr (assoc 1 enx)))
       )
    )
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;