[Иван]

ДД!МОжет есть у кого-нить лисп для черчения бергшрихов.Имеем кучу горизонталей,к которым надо прорисовать бергшрихи.
Ориентировочно вот такой:
1.Выбор обекта(ов) (линии,сплайны)
2.размер бергштриха
3.Указать направление
Отрисовка из центра объекта

Заранее сенгс откликнувшимся)))

[Иван]

2VVA Низкий поклон те Проги работают,рулез.
А мона попросить дописать
Чтобы наряду с бергштрихом под горизонталью появлялся DText со всеми своими функциями акромя угла наклона,так как он уже задан.Значения по умолчанию-стиль как и обычно,высота - 1,25 , текст-99. Чтобы получилось,как в 3 варианте,только с подписанными горизонтальками 99. Буду очень признателен,если не затруднит. :roll:

2Alxd Чет то ли я не понимаю,толи не фурычит

[VVA]

Код:

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

(defun RTD (a)(/ (* a 180.0) pi))
(defun mip-var-clear-osnap ()(setq *MIP-OSNAP* (getvar "OSMODE"))(setvar "OSMODE" 0))
(defun mip-var-restore-osnap ()(if *MIP-OSNAP* (setvar "OSMODE" *MIP-OSNAP*))(setq *MIP-OSNAP* nil))
(defun mip-text-draw (txt pnt height rotation justification)
  (mip-var-clear-osnap)
  (if (= (cdr (assoc 40 (tblsearch "STYLE" (getvar "TEXTSTYLE")))) 0.0)(progn ;; нулевая высота текста
    (if justification
       (vl-cmdf "_.TEXT" "_J" justification pnt height rotation txt)
       (vl-cmdf "_.TEXT" pnt height rotation txt)))
     (progn  ;; фиксированнная высота
    (if justification
       (vl-cmdf "_.TEXT" "_J" justification pnt rotation txt)
       (vl-cmdf "_.TEXT" pnt rotation txt))))
  (mip-var-restore-osnap)(entlast))
;|=======================================================================================
* Ф-ция mip_TextOnLine_once
* Подписывет текст над линиией без запросов 
* Arguments [Type]:
   txtON = тест над линиией [String]
   Pt_draw = t-запрос точки отрисовки или nil-точка отрисовки (cadr e10N)
      h = высота текста [REAL]
     e10N  - примитив для подписи и точка
             указания. Как в (entsel) '([ENAME] [LIST])
     Rotate - запрашивать угол поворота t - да nil - нет (если Pt_draw t)
     vir    - выравнивение (как в _text) или nil
* Возвращает [Type]:
   список добавленных примитивов (( ep e1) ... (epN e1N))
   ep - имя примитива [ENAME] над чем написан текст
   e1 - имя примитива [ENAME] или текст или Wipeout
   =======================================================================================|; 
(defun mip_TextOnLine_once ( txtON Pt_draw h e1ON Rotate vir / ed e1 txt pt vobj param ang pt1 ug lst_ret ep ugt1 ugt2 *error* sn ort)
(defun *error* (message)(setq adoc (vla-get-activedocument (vlax-get-acad-object)))
(while (> (getvar "CMDACTIVE") 0)(command))(princ message)(mip-var-restore-osnap)
  (mapcar '(lambda ( item)(cond ((and (= (type item) 'ENAME)(entget item))(entdel item))
      ((and (= (type item) 'VLA-OBJECT)(vlax-read-enabled-p item))(vl-catch-all-apply 'vla-Delete (list item)))
      (t nil))) *MIP-DELETE-ITEM*)
  (setq *MIP-DELETE-ITEM* nil)(vla-endundomark adoc)(princ))
(if (or txtON (/= (setq txtON (VL-STRING-TRIM " " (getstring "\nВведите значение текста <пропустить>: "))) ""))
  (progn (setq txt txtON)
(setq e1 (car e1ON) pt (cadr e1ON) pt (trans pt 1 0) 
    vobj (vlax-ename->vla-object e1) pt (vlax-curve-getClosestPointTo vobj pt) 
   param (vlax-curve-getParamAtPoint vobj pt) ang (vlax-curve-getFirstDeriv vobj param) 
     pt1 (list (+ (car pt) (car ang)) (+ (cadr pt) (cadr ang))) 
      pt (trans pt 0 1) pt1 (trans pt1 0 1)  ang (angle pt pt1)  ug (rtd ang))
(if (and (> ug 90.0) (<= ug 270.0))(setq ang (+ ang PI) ug (rtd ang)))
(setq ep e1)(if Pt_draw (progn (mip-text-draw txt (cadr e1ON) h ug vir)
  (setq e1 (entlast) ed (entget e1))(setq pt (cadr e1ON))
  (setvar "LASTPOINT" pt)(setq *MIP-DELETE-ITEM* (append *MIP-DELETE-ITEM* (list e1)))
  (princ "\t Точка отрисовки <оставить>:")
  (setq ugt1 (cdr(assoc 50 (entget e1))))(command "_.MOVE" e1 "" (cadr e1ON) pause)
  (setq pt1 (getvar "LASTPOINT"))
  (if (equal pt pt1 0.000001)(progn
      (while (> (getvar "CMDACTIVE") 0)(command ""))(entmod ed)
      (setq *MIP-DELETE-ITEM* (vl-remove e1 *MIP-DELETE-ITEM*)))
     (progn (if Rotate (progn (initget "Y N")
       (setq ugt2 (getkword "\nРазвернуть на 180? [да Y/нет N] <нет>: "))
       (if (= ugt2 "Y")(progn (vla-put-Rotation (vlax-ename->vla-object e1)(+ ugt1 pi))
         (princ "\n Новая точка <не менять>:")(command "_.MOVE" e1 "" pt1 pause)))
           (setq *MIP-DELETE-ITEM* (vl-remove e1 *MIP-DELETE-ITEM*)))))))
  (progn (mip-text-draw txt Pt h ug vir)(setq e1 (entlast))))))
(setq lst_ret (append lst_ret (list (list ep e1)))))
(defun C:M2 ( / adoc *error* selset len Fpt Spt Mpt ang what par) 
(defun *error* (msg)(vla-Regen adoc acActiveViewport)(vla-EndUndoMark adoc)) 
;******************************** 
; Векторное произведение векторов 
;******************************** 
; W1, W2 - вектора 
; Возвращает: вектор нормали к плоскости заданной векторами  в правой системе координат. 
;W1 и W2 не должны лежать на одной прямой). 
(defun 3d_Wnorm (W1 W2)(list (- (* (cadr W1)(caddr W2))(* (caddr W1)(cadr W2))) 
        (- (* (caddr W1)(car W2)) (* (car W1)(caddr W2)))(- (* (car W1)(cadr W2)) (* (cadr W1)(car W2))))) 
(defun group-by-num (lst num / ls ret) 
 (if (= (rem (length lst) num ) 0)(progn (setq ls nil) 
  (repeat (/ (length lst) num)(repeat num (setq ls (cons (car lst) ls) 
  lst (cdr lst)))(setq ret (append ret (list (reverse ls))) ls nil)))) 
  ret) 
(defun getcoors (obj / objname crs)(setq objname (vla-get-ObjectName obj) crs (cond 
 ((= objname "AcDbLine")(list (vlax-curve-getStartPoint obj)(vlax-curve-getEndPoint obj))) 
 ((wcmatch objname "*Polyline")((lambda ( / i lst)(while (<= (setq i (if i (1+ i) 0))(vlax-curve-getEndParam obj)) 
  (setq lst (append lst (list (vlax-curve-getPointAtParam obj i))))) lst))) 
((= objname "AcDbSpline")(group-by-num (vlax-safearray->list(vlax-variant-value(vla-get-fitpoints obj))) 3)) 
(t nil)))) 
(vl-load-com)(setq adoc (vla-get-activedocument (vlax-get-acad-object))) 
(vla-StartUndoMark adoc)(princ "\nВыберите горизонтали ")(setvar "CMDECHO" 0) 
(if (setq selset (ssget "_:L" '((0 . "*LINE"))))(progn 
  (setq lst (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex selset))))) 
  (foreach item lst (setq crs (getcoors item) Fpt (car crs)) 
   (while (setq crs (cdr crs))(setq Spt (car crs)) 
    (setq par (+(* (- (if (cdr crs)(vlax-curve-getParamAtPoint item Spt) 
         (vlax-curve-getEndParam item)) 
      (vlax-curve-getParamAtPoint item Fpt)) 0.5) 
          (vlax-curve-getParamAtPoint item Fpt))) 
     (if (null len)(progn (initget 6)(setq len (getdist "\nРазмер бергштриха <0.5>: ")) 
        (if (null len)(setq len 0.5))(initget 1)(setq Mpt (getpoint 
            (trans (vlax-curve-getPointAtParam item par) 0 1) "\nНаправление бергштриха: ") 
            Mpt (trans Mpt 1 0) Mpt (mapcar '- Mpt Fpt) ang (mapcar '- Spt Fpt) 
            ang (last (3d_Wnorm ang Mpt)))(if (minusp ang)(setq what -)(setq what +)))) 
   (setq ang (what (angle (setq Mpt (vlax-curve-getPointAtParam item par)) 
          (vlax-curve-getPointAtParam item (+ par 0.0001))) (* 0.5 PI))) 
   (vla-AddLine (vla-get-block (vla-get-ActiveLayout adoc)) 
     (vlax-3d-point Mpt)(vlax-3d-point (setq ang (polar Mpt ang len))))
(mip_TextOnLine_once nil ;_Текст nil - запрос "99" - текст 99
                  t
                 1.25     ;_Высота
 (list (vlax-vla-object->ename item)
(polar ang (angle ang Mpt)(+(distance ang Mpt) 0.2))) t "_C")
   (setq Fpt Spt)))(vla-EndUndoMark adoc)))(princ)) 
(princ "\nНаберите в командной строке M2")

[Иван]

2VVA Спасибо,только немного не то.Хотелось бы,чтобы Dtext остался со всеми своими функциями,кроме угла поворота текста.Т.е.выбор стиля,высоту и сам текст надо было подтверждать или вводить другое значение.
У меня после загрузки выдает еще
Command: ; error: extra right paren on input
И текст повернут вверх ногами :cry:

[VVA]

Попробуй еще раз с VVA № 22
1. Стиль установить нужный текущим до вызова команды
2. Высота и значение текста задаются здесь

Код:

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

(mip_TextOnLine_once nil ;_Текст nil - запрос "99" - текст 99 
                  t 
                 1.25     ;_Высота

[Иван]

Сообщение от VVA Попробуй еще раз с VVA № 22 1. Стиль установить нужный текущим до вызова команды 2. Высота и значение текста задаются здесь Код: [Выделить все] (mip_TextOnLine_once nil ;_Текст nil - запрос "99" - текст 99 t 1.25 ;_Высота

Большое человеческое спасибо Прикольный лиспик,только вот у меня иногда бывает вот такая надпись

bad argument type: numberp: nil

Т.е. пару горизонталек подпишет,а на очередной выдает.
Возможно это файл кривой или от 3D сносит его мальца :cry:
Может в курсе,что это ознаечает,чего эму не так?

[VVA]

Вышли на мыло, погоняю

[Иван]

Сообщение от VVA Вышли на мыло, погоняю

Отмылил

[mahony]

Очень понравилась программка.
А можно её усовершенствовать?
Дополнить рисование бергштрихов почаще и разной длины и толщины?
Надо: допустим большой штрих (например 12 мм) тонкий - на расстоянии (например 5 мм) короткий штрих (треть от длинного 4 мм) толщиной вдвое больше тонкого и т.д...
Конечно длины и расстояния между штрихами желательно спросить у проектировщика...

Тогда чудная была бы программка для отрисовки заготовки откосов.
Если бы она на разных слоях делала бы толстые и короткие и длинные и тонкие - вообще бы круто было бы!

[Иван]

Сообщение от mahony Очень понравилась программка. А можно её усовершенствовать? Дополнить рисование бергштрихов почаще и разной длины и толщины? Надо: допустим большой штрих (например 12 мм) тонкий - на расстоянии (например 5 мм) короткий штрих (треть от длинного 4 мм) толщиной вдвое больше тонкого и т.д... Конечно длины и расстояния между штрихами желательно спросить у проектировщика... Тогда чудная была бы программка для отрисовки заготовки откосов. Если бы она на разных слоях делала бы толстые и короткие и длинные и тонкие - вообще бы круто было бы!

Для отрисовки откосов есть ряд афигенных програмулек :wink: Пройдись поиском,откосы в лет рисуют,надо только указать 2 линии и растояние между бергштрихами и откос готов

[Завхоз]

А показать ссылки можно? Потому что то, что я видел, мягко говоря, требовало "доработки" под себя.

[mahony]

Сообщение от Иван Для отрисовки откосов есть ряд афигенных програмулек :wink: Пройдись поиском,откосы в лет рисуют,надо только указать 2 линии и растояние между бергштрихами и откос готов

Есть. Это точно. Но все они рисуют без учёта толщины и длина короткого половина длинной, а у нас принято треть...
Вернее нам так говорили. В ГОСТе - от трети до половины.
И ещё. Для полезного ископаемого необходимо два коротких штриха подряд!

[Иван]

Сообщение от Завхоз А показать ссылки можно? Потому что то, что я видел, мягко говоря, требовало "доработки" под себя.

Млин,неужели тяжело набрать в поисковике? Там не так много выдает ссылок,я уже не помню как и где,но прога которая мне приглянулась вроде так называется alxddike.попробуй сразу ее забить в поиск

[VVA]

А показать ссылки можно?

А заглянуть в download?
http://dwg.ru/dnl/60

[Иван]

[/quote]Есть. Это точно. Но все они рисуют без учёта толщины и длина короткого половина длинной, а у нас принято треть...[/quote]

Треть?ХЗ,у нас половина А чем Вам половина-то не угодила,зачем порубали ее? :wink:

[mahony]

Сообщение от Иван Треть?ХЗ,у нас половина А чем Вам половина-то не угодила,зачем порубали ее? :wink:

"А те, кто ГОСТы пишут, они что - такие умные? Нет, просто у них московская прописка..." Вольная цитата из Жванецкого...

[Завхоз]

Иван, думаешь меня там не было? Было, даж выгнали.
Что делать тем, у кого 2007 ACAD? Alxdike ведь не запустится. Настройки "коротких" бергштрихов тоже могут быть разными (о чем сказано в соседней ветке). И чо делать?
Как быть, если горизонтали отрисованы не предусмотренными типами примитивов, да еще и в непонятных системах координат (сам тут недавно пробовал сделать для отрезков, легких полилиний, 3д-полилиний и сплайнов одновременно, помер делавши)? Вот так

[Иван]

Сообщение от Завхоз Иван, думаешь меня там не было? Было, даж выгнали. Что делать тем, у кого 2007 ACAD? Alxdike ведь не запустится. Настройки "коротких" бергштрихов тоже могут быть разными (о чем сказано в соседней ветке). И чо делать? Как быть, если горизонтали отрисованы не предусмотренными типами примитивов, да еще и в непонятных системах координат (сам тут недавно пробовал сделать для отрезков, легких полилиний, 3д-полилиний и сплайнов одновременно, помер делавши)? Вот так

насчет 2007-можно поставить кад 2004 спешл для откосов,к примеру .А насчет остального несовсем понял,причем тут горизонтали,ежели надо отрисоваьт откос,чисто графически,а не расчитать где он будет и как пройдет.

[Завхоз]

Поставить другую версию не всегда возможно, это во-первых. Во-вторых, я говорю именно об отрисовке (расчет отдельная песня).

[Иван]

Сообщение от Завхоз Поставить другую версию не всегда возможно, это во-первых. Во-вторых, я говорю именно об отрисовке (расчет отдельная песня).

Твоей ситуации не знает никто акромя тя.Поэтому те решать как выкручиваться.Некоторые вообще считают,что лиспом пользоваться недостойно муЗчины :wink: Так же как и афта с АКПП

[KAI]

На мой взгляд, бергштрихи лучше отрисовывать по линии, которую задает пользователь и которая пересекает горизонтали, имеющие отметки Z, тогда направление бергштрихов будет определено программно, ну а лишние (как сказал ShaggyDoc) несложно и стереть, хотя можно и задать кратность отрисовки бергштрихов, например, через 5 м.
Естественно, бергштрихи должны быть перпендикулярны горизонталям в месте пересечения.
Для одиночных горизонталей направление задается линией бергштрихов, задаваемой пользователем.
Так я и поступил в программе CHELEV.
Хотя ShaggyDoc прав, лучше их отрисовывать блоками, а не линиями, как у меня.