Тип линий

Тип линий · 18.07.2005, 22:01

Есть такая програмка для отрисовки осевой линии

(defun C:Osl (/ sna cmd lin scal LAY col ooi first SECOND dist add)
(SETQ sna (GETVAR "osmode"))
(setq cmd (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq lin (getvar "celtype"))
(setq scal (getvar "celtscale"))
(SETQ LAY (GETVAR "CLAYER"))
(SETQ col (GETVAR "Cecolor"))

(setq ooi (GETDIST "\nУвеличение осевой линии с каждой стороны <5>: ")

ooi (if (null ooi)
5
ooi
)
)

(setq first 1
second 2
)
(while (and first second)
(setvar "osmode" 15359)
(setq first (getpoint "\n Осевая линия>> Первая точка: "))
(if (null first)
'(0)
(setq SECOND (getpoint first "\n Осевая линия>> Вторая точка: "))
)
(cond
((equal first second)
(print "Ошибка >> Введенные точки совпадают!")
)

((and first second)
(command "linetype" "s" "Acad_iso04w100" "")
(COMMAND "LAYER" "M" "ОСИ" "C" "RED" "" "")
(setvar "cecolor" "bylayer")
(setq dist (distance first second))

(setq add (list (* (/ (- (car first) (car second)) dist) ooi)
(* (/ (- (cadr first) (cadr second)) dist) ooi)
(* (/ (- (caddr first) (caddr second)) dist) ooi)
)
first (mapcar '+ first add)
second (mapcar '- second add)
)
(setvar "celtscale" (* (DISTANCE FIRST SECOND) 0.01) )
(command "Line" first second "")
)
)
)
(setvar "celtscale" scal)
(setvar "celtype" lin)
(SETVAR "CLAYER" LAY)
(SETVAR "Cecolor" col)
(SETVAR "osmode" sna)
(setvar "cmdecho" cmd)
)

Подскажите пожалуйста,
Можно ли ее как-нибудь переделать чтобы она рисовала обозначение сетей ВК, например
-----------В1------------В1------------ то же самое Т3, Т4, К1, К2.
А если она еще будет спрашивать какой из предложенных типов линий нарисовать, то будет вообще прекрасно.

Кулик Алексей aka kpblc · 19.07.2005, 10:58

Блин, пока отвечал первый раз, система сказала "ква". Поэтому ответ №2. Без объяснений

. Хватай, пока мне некогда

Код:

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

;|=======================================================================================
*    Нормализация системы. Последовательно выполняется _kpblc-sysvar-list для проверки и
* заполнения *kpblc-sysvar-list*, потом из *kpblc-layer-list* читаются настройки слоя
*
=======================================================================================|;
(defun _kpblc-norm-system(norm-layer-name
			norm-snapmode
			restore-system
			/
			sysvar_name
			sysvar_value
			old_cmdecho
			old_nomutt
			)

  ;;; Возвращает список настроек слоя (цвет, тип линии и т.п.)
  (defun _kpblc-get-layer(layer-name / layer_list alert_msg)
    (setq layer_list (cdr (assoc layer-name *kpblc-layer-list*)))
    (if (not layer_list)
      (progn
	(setq alert_msg (strcat "Не определено описание слоя " layer-name " в общем списке!\n"
				"Будет создан слой со следующими настройками: \n"
				"Имя слоя : " layer-name " \n"
				"Цвет слоя : белый \n"
				"Тип линии : непрерывный \n"
				"Вес линии слоя : 0.25 мм \n"
				"Слой печатается"
				))
	(alert alert_msg)
	(setq layer-list (list layer-name (vl-list* 1 7) (vl-list* 2 nil) (vl-list* 3 nil) (vl-list* 4 0.25) (vl-list* 5 "_Plot")))
	);_progn
      );_if
    layer_list
    );_defun
  ;;; Возвращает цвет слоя
  (defun _kpblc-get-layer-color(layer-name / layer_color)
    (if (not (_kpblc-get-layer layer-name))
      (progn
	(setq layer_color (cdr (assoc 1 (_kpblc-get-layer layer-name))))
	(if (not layer_color)
	  (setq layer_color 7)
	  );_if
	);_progn
      (setq layer_color (cdr (assoc 1 (_kpblc-get-layer layer-name))))
      );_if
    layer_color
    );_defun
  ;;; Возращает тип линии слоя и при необходимости подгружает его
  (defun _kpblc-get-layer-ltype(layer-name / layer_ltype layer_linedef_file)
    (setq layer_ltype (cdr (assoc 2 (_kpblc-get-layer layer-name)))
	  layer_linedef_file (cdr (assoc 3 (_kpblc-get-layer layer-name)))
	  )
    (if (not layer_ltype)
      (setq layer_ltype "Continuous")
      );_if layer_ltype
    (if (not layer_linedef_file)
      (setq layer_linedef_file "acadiso.lin")
      )
    (if (not (tblsearch "LTYPE" layer_ltype))	;Если не найдено такое описание линии
      (command "_.-Linetype" "_Load" layer_ltype layer_linedef_file "") ;Загрузить
      );_if tblsearch
    layer_ltype
    );_defun
  ;;; возвращает вес линии слоя
  (defun _kpblc-get-layer-lweight(layer-name / layer_lweight)
    (cdr(assoc 4 (_kpblc-get-layer layer-name)))
    );_defun
  ;;; Возвращает, печатается или нет слой
  (defun _kpblc-get-layer-plot(layer-name)
    (cdr (assoc 5 (_kpblc-get-layer layer-name)))
    );_defun

  ;; Окончание локальных функций

  (setq old_cmdecho (getvar "cmdecho")
	old_nomutt (getvar "nomutt"))
  (setvar "cmdecho" 0)
  (setvar "nomutt" 1)
  
  (if (not *kpblc-error*)	; сначала проверяется обработчик ошибок
    (kpblc-error-init)
    );_if
  (if (not norm-layer-name)
    (setq norm-layer-name "0")
    );_if
  (if (/= norm-snapmode nil)
    ; : not nil, устанавливать значение с дополнительной проверкой на 0
    (progn
      (setvar "snapmode" norm-snapmode)
      (if (/= norm-snapmode 0)
	(setvar "snapunit" (list norm-snapmode norm-snapmode))
	);_if
      );_progn
    );if

  ;; создание или (при наличии) переназначение текстового стиля
  (if (tblsearch "STYLE" "SPDS")
    (command "_.-style"
	     "SPDS"
	     "spds.shx"
	     0 0.75 0 "_No" "_No" "_No"
	     );_command style
        (command "_.-style"
	     "SPDS"
	     "spds.shx"
	     0 0.75 0 "_No" "_No"
	     );_command style
    );_if

  (if (not (tblsearch "DIMSTYLE" "SPDS"))
    ;; создание размерного стиля
    ;; в конце задается dimscale
    (command "_-dimstyle"
	     "_Save"
	     "SPDS"
	     "_Yes"
	     )
    );_if
  (setq layer_color (_kpblc-get-layer-color norm-layer-name))
  (setq layer_ltype (_kpblc-get-layer-ltype norm-layer-name))	;Проверка с одновременной подгрузкой
  (setq layer_lweight (_kpblc-get-layer-lweight norm-layer-name))
  (setq layer_plot (_kpblc-get-layer-plot norm-layer-name))

  ;; Теперь проверяем наличие слоя. Если он есть - то для него только сделать активным и подгрузить
  ;; тип линии. Если нет - то по полной программе.
  (if (tblsearch "LAYER" norm-layer-name)
    (command "_.-Layer"
	     "_Make" norm-layer-name
	     "_On" norm-layer-name
	     "_LType" layer_ltype norm-layer-name
	     "_Thaw" norm-layer-name
	     "_Unlock" norm-layer-name
	     ""
	     );_command
    (command "_.-Layer"
	     "_Make" norm-layer-name
	     "_On" norm-layer-name
	     "_Color" layer_color norm-layer-name
	     "_LType" layer_ltype norm-layer-name
	     "_LWeight" layer_lweight norm-layer-name
	     "_Plot" layer_plot norm-layer-name
	     "_Thaw" norm-layer-name
	     "_Unlock" norm-layer-name
	     ""
	     );_command
    );_if
  (command "wipeout" "_frames" "off")
  ;; Если restore-system = T, то восстанавливать систему из *old-kpblc-sysvar-list*
  ;; Иначе - установить значения из *kpblc-sysvar-list*
  (if restore-system
    (foreach sysvar_counter *old-kpblc-sysvar-list*
      (setq sysvar_name (car sysvar_counter)
	    sysvar_value (cadr sysvar_counter))
      (setvar sysvar_name sysvar_value)
      );_foreach
    (foreach sysvar_counter *kpblc-sysvar-list*
      (setq sysvar_name (car sysvar_counter)
	    sysvar_value (cadr sysvar_counter)
	    sysvar_name (strcase sysvar_name))
      (if (/= (substr sysvar_name 1 3) "DIM")	; не восстанавливать значения размерного стиля
	(setvar sysvar_name sysvar_value)
	);_if
      );_foreach
    );_if
  
  (setvar "cmdecho" old_cmdecho)
  (setvar "nomutt" old_nomutt)

  (princ "\nЗакончена нормализация системы...\n")
  (princ)
  
  );_defun

Используются следующие списки:

Код:

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

;|=======================================================================================
*    Создание списка системных переменных и их "нормализованных" значений. Попутно
* создается список тех же переменных, но со значениями на момент вызова. Если список
* старых значений уже есть, то он не заполняется
=======================================================================================|;
(defun _kpblc-sysvar-list( / sysvar_name sysvar_value)
  (setq *kpblc-sysvar-list*
	 (list
	   '("acadlspasdoc" 1)
	   '("attdia" 1)
	   '("attmode" 1)
	   '("aunits" 1)
	   '("auprec" 4)
	   '("cecolor" "BYLAYER")	;цвет примитивов - по слою
	   '("celtype" "BYLAYER")	;тип линии - по слою
	   '("celweight" -1)		;вес линии - по слою
	   '("dispsilh" 1)
	   '("filedia" 1)
	   '("hidetext" 1)
	   '("insunits" 4)
	   '("insunitsdefsource" 4)
	   '("insunitsdeftarget" 4)
	   '("lunits" 2)
	   '("luprec" 0)
	   '("lwdefault" 25)
	   '("lwunits" 1)
	   '("mirrtext" 0)
	   '("OBSCUREDLTYPE" 0)	;Вид скрытых линий на 3Д-моделях - не отображать
	   '("pdmode" 34)		;Отображение точки как кружка с прицелом
	   '("pickauto" 1)		;Выделять окном
	   '("pickfirst" 1)		;любая последовательность команды - выбора объектов
	   '("pickstyle" 1)		; Выделять только штриховку
	   '("pdsize" 0)		;Точка отображается как 5% от экрана
	   '("psltscale" 1)		;Печать несплошных линий одинаково на листах и в модели.
	                                ;Возможно, придется отказаться от нее
	   '("textfill" 1)		;Заливка ttf-фонтов
	   '("texteval" 1)
	   '("whiparc" 1)

;|========= Переменные размерного стиля ===============================================|;
	   '("DIMADEC" 1)
	   '("DIMALT" 0)
	   '("DIMAPOST" "")
	   '("dimassoc" 2)
	   '("DIMASZ" 2.5000)
	   '("DIMATFIT" 3)
	   '("DIMAUNIT" 1)		; Angular unit format
	   '("DIMAZIN" 2)		; Angular zero supression
	   '("DIMBLK" "_ArchTick")	; Arrow block name
	   '("DIMBLK1" ".")		; First arrow block name
	   '("DIMBLK2" ".")		; Second arrow block name
	   '("DIMCEN" -2.5)		; Center mark size
	   '("DIMCLRD" 256)		; Dimension line and leader color
	   '("DIMCLRE" 256)		; Extension line color
	   '("DIMCLRT" 256)		; Dimension text color
	   '("DIMDEC" 0)		; Decimal places
	   '("DIMDLE" 2)		; Dimension line extension
	   '("DIMDLI" 3.75)		; Dimension line spacing
	   '("DIMDSEP" ",")		; Decimal separator
	   '("DIMEXE" 1.25)		; Extension above dimension line
	   '("DIMEXO" 0.625)		; Extension line origin offset
	   '("DIMFRAC" 0)		; Fraction format
	   '("DIMGAP" 0.625)		; Gap from dimension line to text
	   '("DIMJUST" 0)		; Justification of text on dimension line
	   '("DIMLDRBLK" ".")		; Leader block name
	   '("DIMLFAC" 1)		; Linear unit scale factor
	   '("DIMLIM" 0)		; Generate dimension limits
	   '("DIMLUNIT" 2)		; Linear unit format
	   '("DIMLWD" -1)		; Dimension line and leader lineweight
	   '("DIMLWE" -1)		; Extension line lineweight
	   '("DIMPOST" "")		; Prefix and suffix for dimension text
	   '("DIMRND" 0.5)		; Rounding value
	   '("DIMSAH" 0)		; Separate arrow blocks
	   '("DIMSD1" 0)		; Suppress the first dimension line
	   '("DIMSD2" 0)		; Suppress the second dimension line
	   '("DIMSE1" 0)		; Suppress the first extension line
	   '("DIMSE2" 0)		; Suppress the second extension line
	   '("DIMSOXD" 0)		; Suppress outside dimension lines
	   '("DIMTAD" 1)		; Place text above the dimension line
	   '("DIMTDEC" 1)		; Tolerance decimal places
	   '("DIMTFAC" 1)		; Tolerance text height scaling factor
	   '("DIMTIH" 0)		; Text inside extensions is horizontal
	   '("DIMTIX" 0)		; Place text inside extensions
	   '("DIMTMOVE" 0)		; Text movement
	   '("DIMTOFL" 1)		; Force line inside extension lines
	   '("DIMTOH" 1)		; Text outside horizontal On -> всегда горизонтально
	   '("DIMTOL" 0)		; Tolerance dimensioning
	   '("DIMTOLJ" 0)		; Tolerance vertical justification
	   '("DIMTP" 0)			; Plus tolerance
	   '("DIMTSZ" 0)		; Tick size
	   '("DIMTVP" 0)		; Text vertical position
	   '("DIMTXSTY" "SPDS")		; Text style
	   '("DIMTXT" 2.5)		; Text height
	   '("DIMTZIN" 8)		; Tolerance zero suppression
	   '("DIMUPT" 0)	; User positioned text
	   '("DIMZIN" 8)		; Zero suppression
	   );_list
	);_setq
  (if (not *old-kpblc-sysvar-list*)
    (progn
      (foreach sysvar_counter *kpblc-sysvar-list*
	(setq sysvar_name (car sysvar_counter)
	      sysvar_value (getvar sysvar_name))
	(setq *old-kpblc-sysvar-list* (cons (list sysvar_name sysvar_value) *old-kpblc-sysvar-list*))
	);_foreach
      (reverse *old-kpblc-sysvar-list*)
      );_progn
    );_if
  (if (not *kpblc-scale*)	; первый запуск, надо установить значение системной переменной *kpblc-scale*
    (setq *kpblc-scale* (max
			   (getvar "celtscale")
			   (getvar "dimscale")
			   (getvar "hpspace")
			   (getvar "hpscale")
			   );_max
	  );_setq
    );_if
  );_defun
;|=======================================================================================
*    Составление списка слоев. Если список существует, то ничего не производится.
=======================================================================================|;
(defun _kpblc-layer-list()
  ;; Список создается из точечных пар с кодами:
  ;; (но сначала идет имя слоя)
  ;;	1	Цвет слоя
  ;;	2	Тип линии слоя nil -> "Cont..." (тип линии - русскими буквами, всегда)
  ;;	3	Файл описания линии nil -> "acadiso.lin"
  ;;	4	Толщина линии слоя
  ;;	5	Печатается или нет "_Plot"/"_No"
  (setq *kpblc-layer-list*
	 (list
	   ;; Общие
	   (list "0"      (vl-list* 1 7) (vl-list* 2 nil) (vl-list* 3 nil) (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   (list "VPORS"  (vl-list* 1 7) (vl-list* 2 nil) (vl-list* 3 nil) (vl-list* 4 0.09) (vl-list* 5 "_No"))
	   (list "_Общие" (vl-list* 1 6) (vl-list* 2 nil) (vl-list* 3 nil) (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   (list "Осевая" (vl-list* 1 6) (vl-list* 2 "Осевая") (vl-list* 3 "gosted.lin") (vl-list* 4 0.5) (vl-list* 5 "_Plot"))
	   (list "_Блоки" (vl-list* 1 43) (vl-list* 2 nil) (vl-list* 3 nil) (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   ;; В* :
	   (list "В0" (vl-list* 1 110) (vl-list* 2 "В0") (vl-list* 3 "gosted.lin") (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   (list "В1" (vl-list* 1 111) (vl-list* 2 "В1") (vl-list* 3 "gosted.lin") (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   (list "В2" (vl-list* 1 112) (vl-list* 2 "В2") (vl-list* 3 "gosted.lin") (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   (list "В3" (vl-list* 1 113) (vl-list* 2 "В3") (vl-list* 3 "gosted.lin") (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   (list "В4" (vl-list* 1 114) (vl-list* 2 "В4") (vl-list* 3 "gosted.lin") (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   (list "В5" (vl-list* 1 120) (vl-list* 2 "В5") (vl-list* 3 "gosted.lin") (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   (list "В6" (vl-list* 1 121) (vl-list* 2 "В6") (vl-list* 3 "gosted.lin") (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   (list "В7" (vl-list* 1 122) (vl-list* 2 "В7") (vl-list* 3 "gosted.lin") (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   (list "В8" (vl-list* 1 123) (vl-list* 2 "В8") (vl-list* 3 "gosted.lin") (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   (list "В9" (vl-list* 1 124) (vl-list* 2 "В9") (vl-list* 3 "gosted.lin") (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   ;; К* :
           (list "К0" (vl-list* 1 12) (vl-list* 2 "К0") (vl-list* 3 "gosted.lin") (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   (list "К1" (vl-list* 1 13) (vl-list* 2 "К1") (vl-list* 3 "gosted.lin") (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   (list "К2" (vl-list* 1 14) (vl-list* 2 "К2") (vl-list* 3 "gosted.lin") (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   (list "К3" (vl-list* 1 15) (vl-list* 2 "К3") (vl-list* 3 "gosted.lin") (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   (list "К4" (vl-list* 1 22) (vl-list* 2 "К4") (vl-list* 3 "gosted.lin") (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   (list "К5" (vl-list* 1 23) (vl-list* 2 "К5") (vl-list* 3 "gosted.lin") (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   (list "К6" (vl-list* 1 24) (vl-list* 2 "К6") (vl-list* 3 "gosted.lin") (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   (list "К7" (vl-list* 1 25) (vl-list* 2 "К7") (vl-list* 3 "gosted.lin") (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   (list "К8" (vl-list* 1 32) (vl-list* 2 "К8") (vl-list* 3 "gosted.lin") (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   (list "К9" (vl-list* 1 33) (vl-list* 2 "К9") (vl-list* 3 "gosted.lin") (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   (list "К10" (vl-list* 1 34) (vl-list* 2 "К10") (vl-list* 3 "gosted.lin") (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   (list "К11" (vl-list* 1 35) (vl-list* 2 "К11") (vl-list* 3 "gosted.lin") (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   (list "К12" (vl-list* 1 42) (vl-list* 2 "К12") (vl-list* 3 "gosted.lin") (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   ;; Т* :
	   (list "Т0" (vl-list* 1 210) (vl-list* 2 "Т0") (vl-list* 3 "gosted.lin") (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   (list "Т1" (vl-list* 1 211) (vl-list* 2 "Т1") (vl-list* 3 "gosted.lin") (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   (list "Т2" (vl-list* 1 212) (vl-list* 2 "Т2") (vl-list* 3 "gosted.lin") (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   (list "Т3" (vl-list* 1 213) (vl-list* 2 "Т3") (vl-list* 3 "gosted.lin") (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   (list "Т4" (vl-list* 1 214) (vl-list* 2 "Т4") (vl-list* 3 "gosted.lin") (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   (list "Т5" (vl-list* 1 220) (vl-list* 2 "Т5") (vl-list* 3 "gosted.lin") (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   (list "Т6" (vl-list* 1 221) (vl-list* 2 "Т6") (vl-list* 3 "gosted.lin") (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   (list "Т7" (vl-list* 1 222) (vl-list* 2 "Т7") (vl-list* 3 "gosted.lin") (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   (list "Т8" (vl-list* 1 223) (vl-list* 2 "Т8") (vl-list* 3 "gosted.lin") (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   ;; ОВ_Арматура :
	   (list "ОВ_Оборуд" (vl-list* 1 2) (vl-list* 2 nil) (vl-list* 3 nil) (vl-list* 4 0.5) (vl-list* 5 "_Plot"))
	   ;; ЭО_Оборуд
	   (list "ЭО_Оборуд" (vl-list* 1 3) (vl-list* 2 nil) (vl-list* 3 nil) (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   ;; ГП_Объекты
	   (list "ГП_Объекты" (vl-list* 1 6) (vl-list* 2 nil) (vl-list* 3 nil) (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   ;; ГП* :
	   (list "ГП_Объекты" (vl-list* 1 140)    (vl-list* 2 nil)           (vl-list* 3 nil)          (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   (list "ГП_Осевая" (vl-list* 1 2)       (vl-list* 2 "Осевая")      (vl-list* 3 "gosted.lin") (vl-list* 4 0.25) (vl-list* 5 "_Plot"))
	   (list "ГП_ОгрСтрПлощ" (vl-list* 1 80)  (vl-list* 2 "ОгрСтрПлощ")  (vl-list* 3 "gosted.lin") (vl-list* 4 0.5) (vl-list* 5 "_Plot"))
	   (list "ГП_ВремОгр" (vl-list* 1 81) 	  (vl-list* 2 "ВремОгр")     (vl-list* 3 "gosted.lin") (vl-list* 4 0.5) (vl-list* 5 "_Plot"))
	   (list "ГП_Забор" (vl-list* 1 82)       (vl-list* 2 "Забор")	     (vl-list* 3 "gosted.lin") (vl-list* 4 0.5) (vl-list* 5 "_Plot"))
	   (list "ГП_ОгрКрана" (vl-list* 1 83)	  (vl-list* 2 "ОгрКрана")    (vl-list* 3 "gosted.lin") (vl-list* 4 0.5) (vl-list* 5 "_Plot"))
	   (list "ГП_ГраницаРаб" (vl-list* 1 84)  (vl-list* 2 nil)           (vl-list* 3 "gosted.lin") (vl-list* 4 0.5) (vl-list* 5 "_Plot"))
	   (list "ГП_ГраницаОпас" (vl-list* 1 90) (vl-list* 2 "ГраницаОпас") (vl-list* 3 "gosted.lin") (vl-list* 4 0.5) (vl-list* 5 "_Plot"))
	   (list "ГП_СигнОсь" (vl-list* 1 1)      (vl-list* 2 "СигнОсь")     (vl-list* 3 "gosted.lin") (vl-list* 4 0.5) (vl-list* 5 "_Plot"))
	   (list "ГП_ЛЭП" (vl-list* 1 1)          (vl-list* 2 "ЛЭП")         (vl-list* 3 "gosted.lin") (vl-list* 4 0.5) (vl-list* 5 "_Plot"))
	   (list "ГП_КранПуть" (vl-list* 1 1)     (vl-list* 2 nil)           (vl-list* 3 nil)          (vl-list* 4 0.7) (vl-list* 5 "_Plot"))
	   );_list
	);_setq
  );_defun

Подход, может и замороченный, зато масштабируется на ура.
Во вложении - rar-архив с типами линий. Смени расширение и распаковывай (надеюсь, Admin меня не съест за столь наглое поведение

). Зарарено WinRAR 3.50.
[ATTACH]1121756300.dwg[/ATTACH]

Кулик Алексей aka kpblc · 19.07.2005, 11:25

Да, вот еще - обработчик ошибок:

Код:

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

;|=======================================================================================
*  Переназначение обработки ошибок.
*  Переназначен или нет обработчик проверяется по значению переменной *orig-error*
=======================================================================================|;
(defun kpblc-error-init()
  (if (not *kpblc-error*)
    (setq *kpblc-error* *error*
	  *error* kpblc-error)
    (setq *error* *kpblc-error*
	  *kpblc-error* nil)
    );_if
  );_defun
;|=======================================================================================
*    Стандартный обработчик ошибок AutoCAD
=======================================================================================|;
(defun kpblc-error(message)
  (if (member message '("console break"
			"Function cancelled"
			"Функция отменена"
			"quit / exit abort"
			"выйти прервать");_list
	      );_member
    (princ "\nКоманда прервана пользователем")
    (princ
      (strcat "\ERRNO # "
	      (itoa (getvar "ERRNO"));_itoa
	      ": "
	      message
	      "\n"
	      );_strcat
      );_princ
    );_if
  ;; Завершение активных команд
  (while (/= (getvar "cmdactive") 0) (command nil)
    );_while
  ;; восстановление состояния системы
  (_kpblc-norm-system nil nil T)
  (setvar "cmdecho" 1)
  (setvar "nomutt" 0)
  (princ)
  );_defun

---

Добавлено: Мне интересно, хоть кто-то читает или нет такие длинные посты? Шутка.
Теперь собственно функция рисования линии:

Код:

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

;|=======================================================================================
*   Рисует линию (отрезок) на указанном слое.
*   Параметры вызова:
*	draw-layer		- слой, на котором рисовать nil = "0"
*	draw-snapmode		- шаг. 0 - снять; nil - не менять.
*	draw-point-list		- список точек, по которым строить отрезок (отрезки). nil =
*				  запрос от пользователя. Количество точек - не менее 2.
*   примеры вызова:
(_kpblc-draw-line "В0" nil)
* рисует линию на слое В0, слой получает цвет 11, тип линии "В0", толщину линии 0.25,
*   точки линии задаются пользователем.
(_kpblc-draw-line nil nil nil)
=======================================================================================|;
(defun _kpblc-draw-line(draw-layer
		      draw-snapmode
		      draw-point-list
		      /
		      draw_osmode
		      ent_line
		      )
  (vl-load-com)
  (if draw-point-list
    (progn
      (_kpblc-norm-system draw-layer draw-snapmode nil)
      ;; Теперь последовательно ставим линии от первой точки в списке до последующих
      (vl-cmdf "_.Line")
      (if (= (length draw-point-list) 2)
	(progn
	  (setq ent_line (list (cons 0 "LINE") (cons 8 draw-layer) (cons 10 (car draw-point-list)) (cons 11 (cadr draw-point-list))))
	  (entmake ent_line)
	  );_progn
	(progn
	  (setq draw_osmode (getvar "osmode"))
	  (setvar "osmode" 0)
	  (foreach point-counter draw-point-list
	    (command point-counter)
	    );_foreach
	  (setvar "osmode" draw_osmode)
	  );_progn
	);_if
      );_progn : TRUE. draw-point-list <> nil
    (progn
      (_kpblc-norm-system draw-layer draw-snapmode nil)
      (vl-cmdf "_.Line")
      (while (/= (getvar "cmdactive") 0)
	(command pause)
	);_while
      );_progn : FALSE. draw-point-list = nil
    );_if
  (command nil)
  );_defun

Alan · 19.07.2005, 13:49

>kpblc
Читает, читает... И обратили внимание на некоторую недостачу в длинных постах (Вт Июл 19, 2005 08:58).
Длины не хватило?!

Кулик Алексей aka kpblc · 19.07.2005, 13:54

А там чего не хватило? Вторая часть именно для компенсации и была сварганена. Кстати, как профи, погляди, может, там лишнего тьма набахана.

Alan · 19.07.2005, 14:23

>kpblc
Текст хороший и сразу оценить его пожалуй трудно, но обещаю посмотреть. Но вот на первый взгляд.

Код:

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

;; создание или (при наличии) переназначение текстового стиля 
  (if (tblsearch "STYLE" "SPDS") 
    (command "_.-style" 
        "SPDS" 
        "spds.shx" 
        0 0.75 0 "_No" "_No" "_No" 
        );_command style 
        (command "_.-style" 
        "SPDS" 
        "spds.shx" 
        0 0.75 0 "_No" "_No" 
        );_command style 
    );_if

См. столько проверок, а вот findfile spds.shx отсуствует, что приводит к нетипичному зависанию.
Проверь, убери файлик, получишь удовольствие. ИМХО

Кулик Алексей aka kpblc · 19.07.2005, 14:29

Нда, что-то упустил я этот момент. shx-то у меня на всех машинах лежит в одном и том же месте, которое вдобавок прописано в support, т.е. его и искать не надо. Ок, в таком варианте надо по идее сделать:

Код:

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

;; создание или (при наличии) переназначение текстового стиля
  (if (not (findfile "spds.shx"))
   (setq font_file_name "simplex.shx")
   (setq font_file_name "spds.shx")
    );_if
  (if (tblsearch "STYLE" "SPDS")
    (command "_.-style"
        "SPDS"
        forn_file_name
        0 0.75 0 "_No" "_No" "_No"
        );_command style
        (command "_.-style"
        "SPDS"
        font_file_name
        0 0.75 0 "_No" "_No"
        );_command style
    );_if

Ну это так, на уровне моих знаний.
Если фонт нужен, скажите, сюда же закину.

fixo · 19.07.2005, 15:13

Мне кажется нужно положить все вышеизложенное в загашник,
спору нет хорошие рутины, а пока нужно попрошшэ для начала,
что-то вроде ниже и кстати можешь добавить обработчик ошибок
тот что сверху

IMHO

(defun C:tras (/ cmd col color lay lin ltp point_list scal sna)

(setq sna (getvar "osmode"))
(setq cmd (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq lin (getvar "celtype"))
(setq scal (getvar "celtscale"))
(setq lay (getvar "clayer"))
(setq col (getvar "cecolor"))

; ;

(defun defpoints ()
(setq lst nil)
(setq loop T)
(setq pt (getpoint "\nПервая точка :")
lst (cons pt lst)
)
(while
(setq pt (getpoint "\nСледующая точка :" pt))
(if (null pt)
(setq loop nil)
)
(setq lst (cons pt lst))
)
(reverse lst)
);eof defpoints

; ;

(initget "B1 T3 K1")
(setq ltp (getkword "\nВыбрать тип линии (B1/T3/K1)<B1>:\n"))
(setq ltp
(cond ((not ltp) "B1")
(T ltp)
)
)
(setq color
(cond ((eq ltp "B1") "5")
((eq ltp "T3") "10")
((eq ltp "K1") "72")
(T "256")
)
)

(if (null (tblobjname "ltype" ltp))
(command "_.linetype" "_l" ltp "acad.lin" "") ;=> или acadiso.lin
)
(setvar "osmode" 0)
(setq point_list (defpoints))
(if point_list
(progn
(command "linetype" "s" ltp "")
(if (null (tblobjname "layer" ltp))
(command "layer" "m" ltp "c" color "" "")
);а что со слоями делать? тут просто создаю слой с тем же выменем
(command "._line")
(foreach p point_list (command p))
(command "")
)
)
; ;

(setvar "celtscale" scal)
(setvar "celtype" lin)
(setvar "clayer" lay)
(setvar "cecolor" col)
(setvar "osmode" sna)
(setvar "cmdecho" cmd)
(princ)
)

getr · 16.08.2005, 18:16

-->DDlis
Есть вариант еще проще:
;;;TIP1222.LSP: TB.LSP Text Break (c)1996, Yuqun Lian
;;;
;;; This routine writes a text string to the drawing and then breaks any
;;; lines, polylines, etc. that intersect an imaginary box around the text.
;;; The text is placed on the current layer using the current style. The
;;; default input and repeat capabilities of TB.LSP make multiple labeling
;;; very convenient.
;;; Yuqun Lian - SimpleCAD, http://www.simplecad.com
;;;========================================
;;;Изменена:getr, genatr@mail.ru,проверялась на AutoCAD 2004(eng).
;;;Теперь эта прога пишет строку текста в чертеже и затем "подкладывает" под него невидимую
;;;рамку (wipeout) вокруг текста. Текст помещен в текущий слой, используя текущий стиль.
;;;Есть вход по умолчанию,что удобно для многократной маркировки.Например очень быстро можно
;;;простую линию типа --------- превратить в типа ----В1--- ,----Т7--- и т.д.
;;;Или выполнить надпись на заштрихованном поле....
;;;------------------------------------------------------------------------
(defun tberror (S)
(if (/= S "Function cancelled")
(princ (strcat "\nError: " S))
)
(setvar "CLAYER" TEMPLA)
(setvar "BLIPMODE" TEMPBLIP)
(setvar "OSMODE" TEMPOS)
(setvar "CMDECHO" TEMPCMD)
(command "ucs" "_w")
(setq *error* OLDERR)
(princ)
) ;end tberror

(defun C:TB (/ TEMP FIRST TX ANG TEMPLA TEMPCMD TEMPBLIP TEMPOS TXTST
TXTH)
(setq OLDERR *error*
*error* TBERROR
)
(setq TEMPCMD (getvar "CMDECHO")
TEMPLA (getvar "CLAYER")
TEMPBLIP (getvar "BLIPMODE")
TEMPOS (getvar "OSMODE")
TXTST (getvar "TEXTSTYLE")
*TXTH (getvar "TEXTSIZE")
)
(setvar "CMDECHO" 0)
(setvar "BLIPMODE" 0)
(setq TXTH (cdr (assoc 40 (tblsearch "style" TXTST))))

(setq TEMP T)
(setq FIRST T)
(while TEMP
(setvar "OSMODE" 512)
(setq PT1 (getpoint "\nInsertion point for text: "))
(setvar "OSMODE" 0) ;привязка отсутствует
(cond
((/= PT1 nil)
(if FIRST
(progn

(if (= TXTH 0) ;если высота символов текущего стиля=0,то
(progn
(princ "\nHeight <")
(princ *TXTH)
(setq H (getreal ">: ")) ;ввод действительного числа
(if (= H nil)
(setq H *TXTH)
(setq *TXTH H)
)
)
)

(if (not *ANG)
(setq *ANG 0)
)
(princ "\nRotation angle <")
(princ (* *ANG (/ 180 pi)))
(setq ANG (getangle PT1 ">: ")) ;указание угла
(if (not ANG)
(setq ANG *ANG)
(setq *ANG ANG)
)
(setq ANG (* ANG (/ 180 pi)))

(if (not *TEXT)
(setq *TEXT "В1")
)
(princ "\nНаберите текст или по умолчанию <")
(princ *TEXT)
(setq TX (getstring T ">: ")) ;ввод строковой константы
(if (= TX "")
(setq TX *TEXT)
(setq *TEXT TX)
)
) ;end progn
) ;end first

(if (= TXTH 0)
(command "text" "j" "mc" PT1 *TXTH ANG TX)
(command "text" "j" "mc" PT1 ANG TX)
)

(wipebox) ;вставка невидимой рамки

) ;end pt1

((null PT1)
(setq TEMP nil)
)

) ;end cond
(setq FIRST nil)
) ;end while

(command "ucs" "_w")
(setvar "CLAYER" TEMPLA)
(setvar "BLIPMODE" TEMPBLIP)
(setvar "OSMODE" TEMPOS)
(setvar "CMDECHO" TEMPCMD)

(princ)
)

(defun wipebox (/ TEXTENT TRIMFACT TB GAP FGAP
LL UR PTB1 PTB2 PTB3 PTB4 PTF4)
(setq TEXTENT (entlast))
(setq TRIMFACT 0.5)
(command "ucs" "Entity" TEXTENT)
(setq TB (textbox (list (cons -1 TEXTENT)))
LL (car TB)
UR (cadr TB)
)
(setq GAP (* *TXTH TRIMFACT))
(setq FGAP (* GAP 0.5))
(setq PTB1 (list (- (car LL) GAP) (- (cadr LL) GAP))
PTB3 (list (+ (car UR) GAP) (+ (cadr UR) GAP))
PTB2 (list (car PTB3) (cadr PTB1))
PTB4 (list (car PTB1) (cadr PTB3))
)
(command "_wipeout" PTB1 PTB2 PTB3 PTB4 "c")
(command "_wipeout" "f" "off")
(command "draworder" "last" "" "_f" "")
(redraw TEXTENT)
(command "ucs" "_p")
(princ)
) ;end wipebox

(princ "\nType TB to start")
(princ) ; end tb.lsp
Недостаток:несколько неудобно редактировать линии(точнее перемещать обозначения типа В1),
т.к. подложка невидима,и невозможно за один прием выбрать В1 и wipeout.
Приходится его включать.Обединить их в блок у меня не получилось.Знаний по LISPу мало.

18.07.2005, 22:01		#1
Тип линий DDlis Регистрация: 03.02.2005 Сообщений: 583 Есть такая програмка для отрисовки осевой линии (defun C:Osl (/ sna cmd lin scal LAY col ooi first SECOND dist add) (SETQ sna (GETVAR "osmode")) (setq cmd (getvar "cmdecho")) (setvar "cmdecho" 0) (setq lin (getvar "celtype")) (setq scal (getvar "celtscale")) (SETQ LAY (GETVAR "CLAYER")) (SETQ col (GETVAR "Cecolor")) (setq ooi (GETDIST "\nУвеличение осевой линии с каждой стороны <5>: ") ooi (if (null ooi) 5 ooi ) ) (setq first 1 second 2 ) (while (and first second) (setvar "osmode" 15359) (setq first (getpoint "\n Осевая линия>> Первая точка: ")) (if (null first) '(0) (setq SECOND (getpoint first "\n Осевая линия>> Вторая точка: ")) ) (cond ((equal first second) (print "Ошибка >> Введенные точки совпадают!") ) ((and first second) (command "linetype" "s" "Acad_iso04w100" "") (COMMAND "LAYER" "M" "ОСИ" "C" "RED" "" "") (setvar "cecolor" "bylayer") (setq dist (distance first second)) (setq add (list (* (/ (- (car first) (car second)) dist) ooi) (* (/ (- (cadr first) (cadr second)) dist) ooi) (* (/ (- (caddr first) (caddr second)) dist) ooi) ) first (mapcar '+ first add) second (mapcar '- second add) ) (setvar "celtscale" (* (DISTANCE FIRST SECOND) 0.01) ) (command "Line" first second "") ) ) ) (setvar "celtscale" scal) (setvar "celtype" lin) (SETVAR "CLAYER" LAY) (SETVAR "Cecolor" col) (SETVAR "osmode" sna) (setvar "cmdecho" cmd) ) Подскажите пожалуйста, Можно ли ее как-нибудь переделать чтобы она рисовала обозначение сетей ВК, например -----------В1------------В1------------ то же самое Т3, Т4, К1, К2. А если она еще будет спрашивать какой из предложенных типов линий нарисовать, то будет вообще прекрасно.
Просмотров: 6706