Построение строительных координат с помощью lisp в nanoCAD

Olga94 · 29.01.2025, 07:07

Здравствуйте Уважаемые специалисты!

Есть код ниже lisp-nanocad (autocad) для простановки строительных координат с шагом 100 (работает в любой ПСК, полка по X). Подскажите пожалуйста, как исправить этот код - пояснение на приложенном рисунке.

Предполагаю, что нужно корректно учитывать 100 - если сотня есть, то включать/исключать ее в целое число как 1, т.е. должно быть не "180Б+100,00", а "181Б+0,00". Т.е. если +100,00, то включить как +1, а вместо 100 должно быть 0,00.
Фрагмент файла dwg приложен.

Код:

[Выделить все]

(defun trap1 (errmsg)
  (setq *error* temperr)
  (setvar "clayer" clay)
  ; (command "_ucs" "_p")
  (princ)
)

(defun C:strxy-usc ( / sztxt p1 pt1 p2 gs up_txt dn_txt)
  (command "cmdecho" 0)
  (setq clay (getvar "clayer"))
  (setq temperr *error*)
  (setq *error* trap1)

  (setq sztxt (getreal (strcat "\nВведите высоту текста <" (rtos (getvar "TEXTSIZE")) ">: ")))
  (if (null sztxt)
    (setq sztxt (getvar "TEXTSIZE"))
    (setvar "TEXTSIZE" sztxt)
  )

(defun _addleader (up-string low-string start-point end-point / lead_obj ann_obj point-list)
  (if (not low-string)
    (setq low-string "")
  )

  (setq point-list (apply 'append (list start-point end-point)))
  (setq ann_obj (vla-addmtext
         (if (and (zerop (vla-get-activespace (vla-get-activedocument (vlax-get-acad-object))))
           (= :vlax-false (vla-get-mspace (vla-get-activedocument (vlax-get-acad-object))))
             )
             (vla-get-paperspace (vla-get-activedocument (vlax-get-acad-object)))
             (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))
         )
         (vlax-3d-point end-point)
         0
         (if (/= low-string "")
           (strcat up-string "\\P" low-string)
           up-string
         )
        )
  )

  (if (vlax-property-available-p ann_obj 'BackgroundFill)
    (vla-put-BackgroundFill ann_obj :vlax-true)
  )

  (setq lead_obj (vla-addleader
        (if (and (zerop (vla-get-activespace (vla-get-activedocument (vlax-get-acad-object))))
           (= :vlax-false (vla-get-mspace (vla-get-activedocument (vlax-get-acad-object)))))
    (vla-get-paperspace (vla-get-activedocument (vlax-get-acad-object)))
    (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
        (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray vlax-vbdouble
             (cons 0 (1- (length point-list)))) point-list)) ann_obj  acLineNoArrow)
   )

  (vla-GetBoundingBox ann_obj 'minp 'maxp)
  (setq dx (- (car (vlax-safearray->list maxp))
              (car (vlax-safearray->list minp))
           )
  )

  (cond
    ((> (car end-point) (car start-point))
     (vla-put-attachmentpoint
       ann_obj
       acAttachmentPointMiddleLeft
     )
     (vla-put-insertionpoint ann_obj (vlax-3d-point end-point))
    )
    (T
     (vla-put-attachmentpoint
       ann_obj
       acAttachmentPointMiddleLeft
     )
     (setq new_pt (append (list (- (car end-point) dx)) (cdr end-point)))
     (vla-put-insertionpoint ann_obj (vlax-3d-point new_pt))
    )
  )

  (vla-put-verticaltextposition lead_obj acOutside)
  (vla-put-coordinate lead_obj 1 (vlax-3d-point end-point))
  lead_obj
)

  (vl-load-com)
  (princ "\nLUPREC value = ")
  (princ (getvar "LUPREC"))
  (princ "  TEXTSIZE value = ")
  (princ (getvar "TEXTSIZE"))

  (progn
    (setq p1 (getpoint "\nУкажите точку для считывания координат: "))
    (setq pt1 p1)
    (setq p2 (getpoint pt1 "\nУкажите размещение полки с текстом: "))

    (setq gs 100 ;шаг сетки
          up_txt (gstr p1 gs 'y)
          dn_txt (gstr p1 gs 'x))

    (_addleader
      (strcat up_txt)
      (strcat dn_txt)
      (trans pt1 1 0)
      (trans p2 1 0))
  )

  (setq ssldr (entlast))
  (vla-put-scalefactor
    (vlax-ename->vla-object ssldr)
    (* 0.2 (getvar "TEXTSIZE"))
  )
  ; (command "_explode" ssldr)

  ((lambda ( / rot vla_lead l_pt vla_anno da dc)
    (setq
        rot (atan (/ (cadr (getvar "UCSXDIR")) (car (getvar "UCSXDIR"))))
        vla_lead (vlax-ename->vla-object (entlast))
        l_pt (vlax-get vla_lead 'Coordinates)
        vla_anno (vlax-get vla_lead 'Annotation)
    )

    ; (setq a (car (entsel)) da (entget a))
    (setq da (entget ssldr))
    (setq dc (subst '(213 0 0 0) (assoc 213 da) da))
    (entmod dc)
    (command "_rotate" (entlast) "" p1 (conv-rad-to-degree rot))
    (command "_explode" ssldr)

    (mapcar
        '(lambda (x)
            (vlax-invoke x 'Rotate (list (car l_pt) (cadr l_pt) (caddr l_pt)) rot)
        )
        ; (list vla_lead vla_anno)
        (list vla_anno)
    )
  ))

  ; (command "_ucs" "_p")
  (princ)
)

;Функция вычисления координат вида: "0A+50"
(defun gstr (p1 gs xw / getel tpart bstep btail stxt)
    (if (= xw 'x) (setq getel 'car tpart "Б+") (setq getel 'cadr tpart "А+"))
    (setq bstep (fix (/ ((eval getel) p1) gs)))
    (setq btail (- ((eval getel) p1) (* bstep gs)))
    (setq stxt (strcat (itoa bstep) tpart (vl-string-translate "." "," (rtos btail 2))))
    (princ stxt)
)

;Функция перевода из радиан в градусы
(defun conv-rad-to-degree (value) (/ (* value 180.) pi))

Заранее спасибо!

Olga94 · 30.01.2025, 10:22

Подскажите пожалуйста, код ниже работает вроде бы правильно ,но будет ли ошибка в координате, если добавить округление до 0,05?

Код:

[Выделить все]

(defun trap1 (errmsg)
  (setq *error* temperr)
  (setvar "clayer" clay)
  ; (command "_ucs" "_p")
  (princ)
)

(defun C:strxygn-uscrr ( / sztxt p1 pt1 p2 gs up_txt dn_txt)
  (command "cmdecho" 0)
  (setq clay (getvar "clayer"))
  (setq temperr *error*)
  (setq *error* trap1)

  (setq sztxt (getreal (strcat "\nВведите высоту текста <" (rtos (getvar "TEXTSIZE")) ">: ")))
  (if (null sztxt)
    (setq sztxt (getvar "TEXTSIZE"))
    (setvar "TEXTSIZE" sztxt)
  )

(defun _addleader (up-string low-string start-point end-point / lead_obj ann_obj point-list)
  (if (not low-string)
    (setq low-string "")
  )

  (setq point-list (apply 'append (list start-point end-point)))
  (setq ann_obj (vla-addmtext
         (if (and (zerop (vla-get-activespace (vla-get-activedocument (vlax-get-acad-object))))
           (= :vlax-false (vla-get-mspace (vla-get-activedocument (vlax-get-acad-object))))
		     )
             (vla-get-paperspace (vla-get-activedocument (vlax-get-acad-object)))
             (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))
	     )
         (vlax-3d-point end-point)
         0
         (if (/= low-string "")
		   (strcat up-string "\\P" low-string)
		   up-string
		 )
		)
  )

  (if (vlax-property-available-p ann_obj 'BackgroundFill)
    (vla-put-BackgroundFill ann_obj :vlax-true)
  )

  (setq lead_obj (vla-addleader
        (if (and (zerop (vla-get-activespace (vla-get-activedocument (vlax-get-acad-object))))
           (= :vlax-false (vla-get-mspace (vla-get-activedocument (vlax-get-acad-object)))))
    (vla-get-paperspace (vla-get-activedocument (vlax-get-acad-object)))
    (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
        (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray vlax-vbdouble
             (cons 0 (1- (length point-list)))) point-list)) ann_obj  acLineNoArrow)
   )

  (vla-GetBoundingBox ann_obj 'minp 'maxp)
  (setq dx (- (car (vlax-safearray->list maxp))
              (car (vlax-safearray->list minp))
           )
  )

  (cond
    ((> (car end-point) (car start-point))
     (vla-put-attachmentpoint
       ann_obj
       acAttachmentPointMiddleLeft
     )
     (vla-put-insertionpoint ann_obj (vlax-3d-point end-point))
    )
    (T
     (vla-put-attachmentpoint
       ann_obj
       acAttachmentPointMiddleLeft
     )
     (setq new_pt (append (list (- (car end-point) dx)) (cdr end-point)))
     (vla-put-insertionpoint ann_obj (vlax-3d-point new_pt))
    )
  )

  (vla-put-verticaltextposition lead_obj acOutside)
  (vla-put-coordinate lead_obj 1 (vlax-3d-point end-point))
  lead_obj
)

  (vl-load-com)
  (princ "\nLUPREC value = ")
  (princ (getvar "LUPREC"))
  (princ "  TEXTSIZE value = ")
  (princ (getvar "TEXTSIZE"))
  
   (progn
    (setq p1 (getpoint "\nУкажите точку для считывания координат: "))
	(setq pt1 p1)
    (setq p2 (getpoint pt1 "\nУкажите размещение полки с текстом: "))

	(setq gs 100 ;шаг сетки
          up_txt (gstr (cadr p1) gs 'y)
          dn_txt (gstr (car p1) gs 'x))

    (_addleader
      (strcat up_txt)
      (strcat dn_txt)
      (trans pt1 1 0)
	  (trans p2 1 0))
  )

  (setq ssldr (entlast))
  (vla-put-scalefactor
    (vlax-ename->vla-object ssldr)
    (* 0.2 (getvar "TEXTSIZE"))
  )
  ; (command "_explode" ssldr)

  ((lambda ( / rot vla_lead l_pt vla_anno da dc)
	(setq
		rot (atan (/ (cadr (getvar "UCSXDIR")) (car (getvar "UCSXDIR"))))
		vla_lead (vlax-ename->vla-object (entlast))
		l_pt (vlax-get vla_lead 'Coordinates)
		vla_anno (vlax-get vla_lead 'Annotation)
	)

	; (setq a (car (entsel)) da (entget a))
	(setq da (entget ssldr))
	(setq dc (subst '(213 0 0 0) (assoc 213 da) da))
	(entmod dc)
	(command "_rotate" (entlast) "" p1 (conv-rad-to-degree rot))
	(command "_explode" ssldr)

	(mapcar
		'(lambda (x)
			(vlax-invoke x 'Rotate (list (car l_pt) (cadr l_pt) (caddr l_pt)) rot)
		)
		; (list vla_lead vla_anno)
		(list vla_anno)
	)
  ))

  ; (command "_ucs" "_p")
  (princ)
)

;Функция вычисления координат вида: "0A+50"
(defun gstr (p1 gs xw / getel tpart bstep btail stxt)
	(if (= xw 'x) (setq getel 'car tpart "Б+") (setq getel 'cadr tpart "А+"))
	
	(setq bstep (fix (/ (round p1 0.05) gs)))
	
	(setq btail (- p1 (* bstep gs)))
	
	(setq stxt (strcat (itoa bstep) tpart (vl-string-translate "." "," (rtos btail 2))))
	(princ stxt)
)

;Функция перевода из радиан в градусы
(defun conv-rad-to-degree (value) (/ (* value 180.) pi))

;Функция округления
(defun round (value to)
  (if (zerop to)
    value
    (* (atoi (rtos (/ (float value) to) 2 0)) to)
  )
)

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
Lisp простой нумератор для Nanocad	gizmo_zx	LISP	2	17.03.2015 11:50
Как перенести координаты из AUTOCAD в Excel и обратно с помощью LISP?	aydinkhalil	LISP	11	24.12.2014 10:51
Работа с таблицой Autocad с помощью Lisp	ILMIR	LISP	3	06.11.2014 20:54
Как с помощью LISP нарисовать окно линиями?	Aндрeй	LISP	13	24.06.2011 14:37