| Правила | Регистрация | Пользователи | Поиск | Сообщения за день | Все разделы прочитаны |  Справка по форуму | Файлообменник |

Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > (GRREAD) и привязка

(GRREAD) и привязка

Ответ
Поиск в этой теме
Непрочитано 13.01.2009, 14:52 #1
(GRREAD) и привязка
Ева
 
Воронеж
Регистрация: 01.04.2008
Сообщений: 40

Добрый день! Столкнуласьс такой проблемой в коде - при работе функции (grread) почему то в Autocad не срабатывает привязка, хотя значение OSMODE = 7(привязка включена).

(princ "\nУкажите точку или цифру:")
(setvar "OSMODE" 7)
(Setq K2(grread))
Пытаюсь указать точку - привязка не срабатывает. Помогите, пожалуйста, разобраться!
Просмотров: 6894
 
Непрочитано 13.01.2009, 15:00
#2
Profan


 
Регистрация: 25.12.2005
Москва
Сообщений: 13,627


Посмотрите сюда:
http://www.caduser.ru/cgi-bin/f1/board.cgi?t=20084JC
Profan вне форума  
 
Автор темы   Непрочитано 13.01.2009, 15:08
#3
Ева


 
Регистрация: 01.04.2008
Воронеж
Сообщений: 40
<phrase 1=


Profan, в этой теме речь о том как совсем исключить (grread), мне же наоборот нужно ее взаимодействие с включенной привязкой. Это вообще возможно, работа привязки при указании точки через (grread)?
Ева вне форума  
 
Непрочитано 13.01.2009, 15:15
#4
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 39,787


Ева, загоняй свои примитивы в анонимный блок и используй либо _.change, либо _.-insert. Также просмотри тему "На заметку программистам" (название именно такое, автор темы ShaggyDoc).
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 13.01.2009, 15:17
#5
Profan


 
Регистрация: 25.12.2005
Москва
Сообщений: 13,627


Еще посмотрите и сюда:
http://www.caduser.ru/cgi-bin/f1/board.cgi?t=36171KD
Profan вне форума  
 
Автор темы   Непрочитано 13.01.2009, 15:23
#6
Ева


 
Регистрация: 01.04.2008
Воронеж
Сообщений: 40
<phrase 1=


Кулик Алексей aka kpblc, я не использую примитивы, мне нужно вернуть точку или цифру через (grread) и все, но при указании точки нужно чтобы работала привязка.Вопрос, как это осуществить и возможно ли это вообще.
Ева вне форума  
 
Непрочитано 13.01.2009, 15:38
#7
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 39,787


А чем тогда не устраивает конструкция наподобие
Код:
[Выделить все]
(defun test (/ _res)
  (if (member (type (setq _res (vl-catch-all-apply
                                 (function
                                   (lambda ()
                                     (initget 6 "Точка Число Point Number _ P N P N")
                                     (getkword "\nВведите [Точка/Число] <Отмена> : ")
                                     ) ;_ end of lambda
                                   ) ;_ end of function
                                 ) ;_ end of vl-catch-all-apply
                          ) ;_ end of setq
                    ) ;_ end of type
              (list 'list 'str 'int)
              ) ;_ end of member
    (cond
      ((= (type _res) 'int)
       _res
       )
      ((listp _res) _res)
      ((= (type _res) 'str)
       (cond
         ((= _res "Т") (getpoint "\nУкажи точку <Отмена> : "))
         ((= _res "Ч") (getint "\nВведи число <Отмена> : "))
         ) ;_ end of cond
       )
      ) ;_ end of cond
    ) ;_ end of if
  ) ;_ end of defun
:?:
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Автор темы   Непрочитано 13.01.2009, 15:42
#8
Ева


 
Регистрация: 01.04.2008
Воронеж
Сообщений: 40
<phrase 1=


Кулик Алексей aka kpblc, не устраивает лишний запрос - точка или число. Нужно сразу результат в первом запросе.
Ева вне форума  
 
Непрочитано 13.01.2009, 15:52
#9
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 39,787


Ну тогда можно так (проверки все посносил):
Код:
[Выделить все]
(defun test (/ _res)
  (initget 169 "Точка Число Point Number _ P N P N")
  (setq _res (getpoint "\nВводим [Точка/Число] <Отмена> : "))
  (cond
    ((listp _res) _res)
    ((= (type _res) 'str)
     (cond
       ((= _res "") nil)
       ((= _res "P") (getpoint "\nТочка <Отмена> : "))
       ((= _res "N") (getreal "\nЧисло <Отмена> : "))
       (t (atof _res))
       ) ;_ end of cond
     )
    ) ;_ end of cond
  ) ;_ end of defun
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.

Последний раз редактировалось Кулик Алексей aka kpblc, 13.01.2009 в 15:58. Причина: Исправил код
Кулик Алексей aka kpblc вне форума  
 
Автор темы   Непрочитано 13.01.2009, 16:06
#10
Ева


 
Регистрация: 01.04.2008
Воронеж
Сообщений: 40
<phrase 1=


Кулик Алексей aka kpblc, да, это работает, но в программе еще требуется обработка правой клавиши мыши - те можно ввести точку, число или нажать правую клавишу мыши.
Ева вне форума  
 
Непрочитано 13.01.2009, 16:07
#11
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 39,787


Ева, прогони последний код (я его менял - сначала забыл обработку конт.меню). Во всех режимах.
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Автор темы   Непрочитано 13.01.2009, 16:14
#12
Ева


 
Регистрация: 01.04.2008
Воронеж
Сообщений: 40
<phrase 1=


Кулик Алексей aka kpblc, все поняла, спасибо большое!
Ева вне форума  
 
Непрочитано 17.12.2009, 13:44
#13
Do$

AutoCAD/Civil3D LISP/C#
 
Регистрация: 15.08.2008
Санкт-Петербург
Сообщений: 1,702
Отправить сообщение для Do$ с помощью Skype™


Тоже захотелось, чтоб при grread срабатывали привязки. Все что наработал, выложу тут, мало ли кому пригодится.
Для начала, выяснил какие в данный момент привязки включены:

Код:
[Выделить все]
(defun bitlist (sum / bit lst n)
;;;    (bitlist (getvar "osmode"))
  (setq n 0)
  (while (< (expt 2 n) sum)
    (setq n (1+ n))
  ) ;_ end of while
  (repeat (1+ n)
    (if (>= sum (setq bit (expt 2 n)))
      (setq lst (cons bit lst)
     sum (- sum bit)
      ) ;_ end of setq
    ) ;_ end of if
    (setq n (1- n))
  ) ;_ end of repeat
  (if lst
    lst
    (list 0)
  ) ;_ end of if
) ;_ end of defun

Затем, составил функцию отрисовки значков привязки. Размер значка установил в 5 пикселей, потому как не нашел системной переменной, отвечающей за это. Значки привязки рисуются с помощью функции GRVECS.

Код:
[Выделить все]
(defun osnap_marker (typ pnt l col / circle-for-grvecs-list)
      (defun circle-for-grvecs-list (pnt l col n / ang pnt_lst rez)
;;; (grvecs (circle-for-grvecs-list (setq pt (getpoint "\nCenter point:")) (getdist pt "\nRadius:") 2 100))
 (setq
   ang   0.0
   pnt_lst (list (mapcar (function +) pnt (list l 0.0 0.0)))
 ) ;_ end of setq
 (repeat (1- n)
   (setq
     pnt_lst
      (cons (polar pnt (setq ang (+ ang (/ pi (/ n 2)))) l)
     pnt_lst
      ) ;_ end of cons
   ) ;_ end of setq
 ) ;_ end of repeat
 (while pnt_lst
   (if (cdr pnt_lst)
     (setq rez   (append rez
      (list col (car pnt_lst) (cadr pnt_lst))
     ) ;_ end of append
    pnt_lst (cdr pnt_lst)
     ) ;_ end of setq
     (setq rez
     (append rez (list col (car pnt_lst) (cadr rez)))
    pnt_lst nil
     ) ;_ end of setq
   ) ;_ end of if
 ) ;_ end of while
 rez
      ) ;_ end of defun
      (setq pnt (trans pnt 1 2))
      (grvecs
 (mapcar
   (function (lambda (a)
        (if (listp a)
   (trans a 2 1)
   a
        ) ;_ end of if
      ) ;_ end of lambda
   ) ;_ end of function
   (cond
     ((= typ "end")
      (
       (lambda (pt1 pt2 pt3 pt4)
  (list col pt1 pt2 col pt2 pt3 col pt3 pt4 col pt4 pt1)
       ) ;_ end of lambda
        (mapcar '+ pnt (list (- l) l 0.0))
        (mapcar '+ pnt (list (- l) (- l) 0.0))
        (mapcar '+ pnt (list l (- l) 0.0))
        (mapcar '+ pnt (list l l 0.0))
      )
     )
     ((= typ "mid")
      (
       (lambda (pt1 pt2 pt3)
  (list col pt1 pt2 col pt2 pt3 col pt3 pt1)
       ) ;_ end of lambda
        (mapcar '+ pnt (list 0.0 l 0.0))
        (mapcar '+ pnt (list (- l) (- l) 0.0))
        (mapcar '+ pnt (list l (- l) 0.0))
      )
     )
     ((= typ "cen")
      (circle-for-grvecs-list pnt l 2 12)
     )
     ((= typ "nod")
      (append (circle-for-grvecs-list pnt l 2 12)
       (list col
      (mapcar '+ pnt (list (- l) l 0.0))
      (mapcar '+ pnt (list l (- l) 0.0))
      col
      (mapcar '+ pnt (list l l 0.0))
      (mapcar '+ pnt (list (- l) (- l) 0.0))
       ) ;_ end of list
      ) ;_ end of append
     )
     ((= typ "qua")
      ((lambda (pt1 pt2 pt3 pt4)
  (list col pt1 pt2 col pt2 pt3 col pt3 pt4 col pt4 pt1)
       ) ;_ end of lambda
        (mapcar '+ pnt (list (- l) 0.0 0.0))
        (mapcar '+ pnt (list 0.0 (- l) 0.0))
        (mapcar '+ pnt (list l 0.0 0.0))
        (mapcar '+ pnt (list 0.0 l 0.0))
      )
     )
     ((= typ "int")
      (list col
     (mapcar '+ pnt (list (- l) l 0.0))
     (mapcar '+ pnt (list l (- l) 0.0))
     col
     (mapcar '+ pnt (list l l 0.0))
     (mapcar '- pnt (list l l 0.0))
      ) ;_ end of list
     )
     ((= typ "ins")
      (
       (lambda (pt1 pt2 pt3 pt4 pt5 pt6)
  (list
    col pt1   pt2   col   pt2 pt3   col   pt3   pt6
    col pt6   pt5   col   pt5 pt4   col   pt4   pt1
   ) ;_ end of list
 ;_ end of list
       ) ;_ end of lambda
        (mapcar '+ pnt (list 0.0 l 0.0))
        (mapcar '+ pnt (list (- l) l 0.0))
        (mapcar '- pnt (list l 0.0 0.0))
        (mapcar '- pnt (list 0.0 l 0.0))
        (mapcar '+ pnt (list l (- l) 0.0))
        (mapcar '+ pnt (list l 0.0 0.0))
      )
     )
     ((= typ "per")
      (
       (lambda (pt1 pt2 pt3 pt4 pt5)
  (list col pt1 pt2 col pt2 pt3 col pt4 pnt col pnt pt5)
       ) ;_ end of lambda
        (mapcar '+ pnt (list (- l) l 0.0))
        (mapcar '+ pnt (list (- l) (- l) 0.0))
        (mapcar '+ pnt (list l (- l) 0.0))
        (mapcar '+ pnt (list (- l) 0.0 0.0))
        (mapcar '+ pnt (list 0.0 (- l) 0.0))
      )
     )
     ((= typ "tan")
      (append (circle-for-grvecs-list pnt l 2 12)
       (list col
      (mapcar '+ pnt (list (- l) l 0.0))
      (mapcar '+ pnt (list l l 0.0))
       ) ;_ end of list
      ) ;_ end of append
     )
     ((= typ "nea")
      (
       (lambda (pt1 pt2 pt3 pt4)
  (list col pt1 pt3 col pt4 pt2 col pt1 pt4 col pt2 pt3)
       ) ;_ end of lambda
        (mapcar '+ pnt (list (- l) l 0.0))
        (mapcar '+ pnt (list (- l) (- l) 0.0))
        (mapcar '+ pnt (list l (- l) 0.0))
        (mapcar '+ pnt (list l l 0.0))
      )
     )
     ((= typ "app")
      ((lambda (pt1 pt2 pt3 pt4)
  (list
    col pt1   pt2   col   pt2 pt3   col   pt3   pt4
    col pt4   pt1   col   pt1 pt3   col   pt2   pt4
   ) ;_ end of list
 ;_ end of list
       ) ;_ end of lambda
        (mapcar '+ pnt (list (- l) l 0.0))
        (mapcar '+ pnt (list (- l) (- l) 0.0))
        (mapcar '+ pnt (list l (- l) 0.0))
        (mapcar '+ pnt (list l l 0.0))
      )
     )
     ((= typ "ext")
      (list col
     (mapcar '+ pnt (list (- l) l 0.0))
     (mapcar '+ pnt (list l (- l) 0.0))
     col
     (mapcar '+ pnt (list l l 0.0))
     (mapcar '- pnt (list l l 0.0))
      ) ;_ end of list
     )
     ((= typ "par")
      (list col
     (mapcar '- pnt (list l 0.0 0.0))
     (mapcar '+ pnt (list l l 0.0))
     col
     (mapcar '- pnt (list l l 0.0))
     (mapcar '+ pnt (list l 0.0 0.0))
      ) ;_ end of list
     )
   ) ;_ end of cond
 ) ;_ end of mapcar
      ) ;_ end of grvecs
    ) ;_ end of defun

Тут стоит отдельно обратить внимание на отрисовку окружности:

Код:
[Выделить все]
(defun circle-for-grvecs-list (pnt l col n / ang pnt_lst rez)
;;;col - цвет
;;;n - количество точек разбиения окружности    
;;; (grvecs (circle-for-grvecs-list (setq pt (getpoint "\nCenter point:")) (getdist pt "\nRadius:") 2 100))
    (setq
      ang     0.0
      pnt_lst (list (mapcar (function +) pnt (list l 0.0 0.0)))
    ) ;_ end of setq
    (repeat (1- n)
      (setq
 pnt_lst
  (cons (polar pnt (setq ang (+ ang (/ pi (/ n 2)))) l)
        pnt_lst
  ) ;_ end of cons
      ) ;_ end of setq
    ) ;_ end of repeat
    (while pnt_lst
      (if (cdr pnt_lst)
 (setq rez     (append rez
         (list col (car pnt_lst) (cadr pnt_lst))
        ) ;_ end of append
       pnt_lst (cdr pnt_lst)
 ) ;_ end of setq
 (setq rez
        (append rez (list col (car pnt_lst) (cadr rez)))
       pnt_lst nil
 ) ;_ end of setq
      ) ;_ end of if
    ) ;_ end of while
    rez
  ) ;_ end of defun

Ко всему этому добавил обработку различных событий, результат - функция корректирования точки с помощью включенных на данный момент режимов привязки и отрисовкой символа привязки из временных линий (довольно сырая, но работоспособная ):

Код:
[Выделить все]
(defun alt_osnap
     (pt       pt_last /   bitlist   osnap_marker
      blst      len pt_os   os_lst    lst
     )
     ;|
pt - координаты точки в ПСК
pt_last - координаты точки для тангенсальной и перпендикулярной привязки или nil
  |;
(defun bitlist (sum / bit lst n)
;;;    (bitlist (getvar "osmode"))
  (setq n 0)
  (while (< (expt 2 n) sum)
    (setq n (1+ n))
  ) ;_ end of while
  (repeat (1+ n)
    (if (>= sum (setq bit (expt 2 n)))
      (setq lst (cons bit lst)
     sum (- sum bit)
      ) ;_ end of setq
    ) ;_ end of if
    (setq n (1- n))
  ) ;_ end of repeat
  (if lst
    lst
    (list 0)
  ) ;_ end of if
) ;_ end of defun
    (defun osnap_marker (typ pnt l col / circle-for-grvecs-list)
  (defun circle-for-grvecs-list (pnt l col n / ang pnt_lst rez)
;;;col - цвет
;;;n - количество точек разбиения окружности    
;;; (grvecs (circle-for-grvecs-list (setq pt (getpoint "\nCenter point:")) (getdist pt "\nRadius:") 2 100))
    (setq
      ang     0.0
      pnt_lst (list (mapcar (function +) pnt (list l 0.0 0.0)))
    ) ;_ end of setq
    (repeat (1- n)
      (setq
 pnt_lst
  (cons (polar pnt (setq ang (+ ang (/ pi (/ n 2)))) l)
        pnt_lst
  ) ;_ end of cons
      ) ;_ end of setq
    ) ;_ end of repeat
    (while pnt_lst
      (if (cdr pnt_lst)
 (setq rez     (append rez
         (list col (car pnt_lst) (cadr pnt_lst))
        ) ;_ end of append
       pnt_lst (cdr pnt_lst)
 ) ;_ end of setq
 (setq rez
        (append rez (list col (car pnt_lst) (cadr rez)))
       pnt_lst nil
 ) ;_ end of setq
      ) ;_ end of if
    ) ;_ end of while
    rez
  ) ;_ end of defun
      (setq pnt (trans pnt 1 2))
      (grvecs
 (mapcar
   (function (lambda (a)
        (if (listp a)
   (trans a 2 1)
   a
        ) ;_ end of if
      ) ;_ end of lambda
   ) ;_ end of function
   (cond
     ((= typ "end")
      (
       (lambda (pt1 pt2 pt3 pt4)
  (list col pt1 pt2 col pt2 pt3 col pt3 pt4 col pt4 pt1)
       ) ;_ end of lambda
        (mapcar '+ pnt (list (- l) l 0.0))
        (mapcar '+ pnt (list (- l) (- l) 0.0))
        (mapcar '+ pnt (list l (- l) 0.0))
        (mapcar '+ pnt (list l l 0.0))
      )
     )
     ((= typ "mid")
      (
       (lambda (pt1 pt2 pt3)
  (list col pt1 pt2 col pt2 pt3 col pt3 pt1)
       ) ;_ end of lambda
        (mapcar '+ pnt (list 0.0 l 0.0))
        (mapcar '+ pnt (list (- l) (- l) 0.0))
        (mapcar '+ pnt (list l (- l) 0.0))
      )
     )
     ((= typ "cen")
      (circle-for-grvecs-list pnt l 2 12)
     )
     ((= typ "nod")
      (append (circle-for-grvecs-list pnt l 2 12)
       (list col
      (mapcar '+ pnt (list (- l) l 0.0))
      (mapcar '+ pnt (list l (- l) 0.0))
      col
      (mapcar '+ pnt (list l l 0.0))
      (mapcar '+ pnt (list (- l) (- l) 0.0))
       ) ;_ end of list
      ) ;_ end of append
     )
     ((= typ "qua")
      ((lambda (pt1 pt2 pt3 pt4)
  (list col pt1 pt2 col pt2 pt3 col pt3 pt4 col pt4 pt1)
       ) ;_ end of lambda
        (mapcar '+ pnt (list (- l) 0.0 0.0))
        (mapcar '+ pnt (list 0.0 (- l) 0.0))
        (mapcar '+ pnt (list l 0.0 0.0))
        (mapcar '+ pnt (list 0.0 l 0.0))
      )
     )
     ((= typ "int")
      (list col
     (mapcar '+ pnt (list (- l) l 0.0))
     (mapcar '+ pnt (list l (- l) 0.0))
     col
     (mapcar '+ pnt (list l l 0.0))
     (mapcar '- pnt (list l l 0.0))
      ) ;_ end of list
     )
     ((= typ "ins")
      (
       (lambda (pt1 pt2 pt3 pt4 pt5 pt6)
  (list
    col pt1   pt2   col   pt2 pt3   col   pt3   pt6
    col pt6   pt5   col   pt5 pt4   col   pt4   pt1
   ) ;_ end of list
       ) ;_ end of lambda
        (mapcar '+ pnt (list 0.0 l 0.0))
        (mapcar '+ pnt (list (- l) l 0.0))
        (mapcar '- pnt (list l 0.0 0.0))
        (mapcar '- pnt (list 0.0 l 0.0))
        (mapcar '+ pnt (list l (- l) 0.0))
        (mapcar '+ pnt (list l 0.0 0.0))
      )
     )
     ((= typ "per")
      (
       (lambda (pt1 pt2 pt3 pt4 pt5)
  (list col pt1 pt2 col pt2 pt3 col pt4 pnt col pnt pt5)
       ) ;_ end of lambda
        (mapcar '+ pnt (list (- l) l 0.0))
        (mapcar '+ pnt (list (- l) (- l) 0.0))
        (mapcar '+ pnt (list l (- l) 0.0))
        (mapcar '+ pnt (list (- l) 0.0 0.0))
        (mapcar '+ pnt (list 0.0 (- l) 0.0))
      )
     )
     ((= typ "tan")
      (append (circle-for-grvecs-list pnt l 2 12)
       (list col
      (mapcar '+ pnt (list (- l) l 0.0))
      (mapcar '+ pnt (list l l 0.0))
       ) ;_ end of list
      ) ;_ end of append
     )
     ((= typ "nea")
      (
       (lambda (pt1 pt2 pt3 pt4)
  (list col pt1 pt3 col pt4 pt2 col pt1 pt4 col pt2 pt3)
       ) ;_ end of lambda
        (mapcar '+ pnt (list (- l) l 0.0))
        (mapcar '+ pnt (list (- l) (- l) 0.0))
        (mapcar '+ pnt (list l (- l) 0.0))
        (mapcar '+ pnt (list l l 0.0))
      )
     )
     ((= typ "app")
      ((lambda (pt1 pt2 pt3 pt4)
  (list
    col pt1   pt2   col   pt2 pt3   col   pt3   pt4
    col pt4   pt1   col   pt1 pt3   col   pt2   pt4
   ) ;_ end of list
       ) ;_ end of lambda
        (mapcar '+ pnt (list (- l) l 0.0))
        (mapcar '+ pnt (list (- l) (- l) 0.0))
        (mapcar '+ pnt (list l (- l) 0.0))
        (mapcar '+ pnt (list l l 0.0))
      )
     )
     ((= typ "ext")
      (list col
     (mapcar '+ pnt (list (- l) l 0.0))
     (mapcar '+ pnt (list l (- l) 0.0))
     col
     (mapcar '+ pnt (list l l 0.0))
     (mapcar '- pnt (list l l 0.0))
      ) ;_ end of list
     )
     ((= typ "par")
      (list col
     (mapcar '- pnt (list l 0.0 0.0))
     (mapcar '+ pnt (list l l 0.0))
     col
     (mapcar '- pnt (list l l 0.0))
     (mapcar '+ pnt (list l 0.0 0.0))
      ) ;_ end of list
     )
   ) ;_ end of cond
 ) ;_ end of mapcar
      ) ;_ end of grvecs
    ) ;_ end of defun
    (if
      (and
 (or (= (getvar "osmode") 16383)
     (not
       (or (member 0 (setq blst (bitlist (getvar "osmode"))))
    (member 1024 blst)
    (member 16384 blst)
       ) ;_ end of or
     ) ;_ end of not
 ) ;_ end of or
      ) ;_ end of and
       (progn
  (setq len (* (/ (getvar "viewsize") (cadr (getvar "screensize"))) 5)
        lst (quote ((1 . "end")
       (2 . "mid")
       (4 . "cen")
       (8 . "nod")
       (16 . "qua")
       (32 . "int")
       (64 . "ins")
       (128 . "per")
       (256 . "tan")
       (512 . "nea")
       (2048 . "app")
       (4096 . "ext")
       (8192 . "par")
     )
     ) ;_ end of quote
  ) ;_ end of setq
  (if pt_last
    (setvar "lastpoint" pt_last)
    (foreach
       b
        (list '(128 . "per") '(256 . "tan"))
      (setq lst (vl-remove b lst))
    ) ;_ end of foreach
  ) ;_ end of if
  (setq os_lst nil)
  (foreach
     a
      lst
    (if
      (and (member (car a) blst)
    (setq pt_os (osnap pt (strcat "_" (cdr a))))
    (not (equal pt pt_os 1.0e-008))
      ) ;_ end of and
       (setq
  os_lst (cons (list (cdr a) pt pt_os (distance pt pt_os))
        os_lst
         ) ;_ end of cons
       ) ;_ end of setq
    ) ;_ end of if
  ) ;_ end of foreach
  (if os_lst
    (progn
      (setq
        os_lst (vl-sort
   os_lst
   (function (lambda (a b) (< (last a) (last b))))
        ) ;_ end of vl-sort
      ) ;_ end of setq
      (if
        (not (and (= (caar os_lst) "nea")
    (setq os (cadr os_lst))
    (<= (last os) (* (/ len 5) (getvar "aperture")))
      ) ;_ end of and
        ) ;_ end of not
  (setq os (car os_lst))
      ) ;_ end of if
      (osnap_marker (car os) (caddr os) len 2)
      os
    ) ;_ end of progn
  ) ;_ end of if
       ) ;_ end of progn
    ) ;_ end of if
  ) ;_ end of defun

Ну и напоследок, пример использования - рисование объемной стрелки. После загрузки, запускать коммандой arrow.

Код:
[Выделить все]
(defun drawing_arrow (pt_st   pt_end  col     m       /       ang
        ang1    ang2    col     dist    dist_temp
        pt_temp pt_lst  lst
       )
       ;|
  pt_st - координаты начала стрелки в ПСК
  pt_end - координаты конца стрелки в ПСК
  col - цвет стрелки, если nil - стрелка не рисуется
  m - толщина стрелки в пикселах
 (drawing_arrow
   (getpoint "\nStart point:")
   (getpoint "\nEnd point:")
   1
   10   
 ) ;_ end of drawing_arrow
  |;
  (if (> m 0)
    (progn
      (setq
 pt_lst   (list pt_st pt_end)
 pt_st   (trans pt_st 1 2)
 pt_end   (trans pt_end 1 2)
 dist   (* (/ (getvar "viewsize") (cadr (getvar "screensize"))) m)
 dist_temp (/ (distance pt_st pt_end) 2)
 dist   (if (> dist dist_temp)
      dist_temp
      dist
    ) ;_ end of if
 ang   (angle pt_st pt_end)
 pt_temp   (polar pt_end (+ pi ang) (* 2 dist))
 ang1   (+ ang (/ pi 2))
 ang2   (- ang (/ pi 2))
 lst   (mapcar
      (function (lambda (a) (trans a 2 1)))
      (list pt_end
     (polar pt_temp ang2 dist)
     (polar pt_temp ang2 (/ dist 2))
     (polar pt_st ang2 (/ dist 2))
     (polar pt_st ang1 (/ dist 2))
     (polar pt_temp ang1 (/ dist 2))
     (polar pt_temp ang1 dist)
      ) ;_ end of list
    ) ;_ end of mapcar
      ) ;_ end of setq
      (if col
 (grvecs
   (apply (function (lambda (color pt1 pt2 pt3 pt4 pt5 pt6 pt7)
        (list
          color  pt1    pt2    color  pt2
          pt3    color  pt3    pt4    color
          pt4    pt5    color  pt5    pt6
          color  pt6    pt7    color  pt7
          pt1
         ) ;_ end of list
      ) ;_ end of lambda
   ) ;_ end of function
   (cons col lst)
   ) ;_ end of apply
 ) ;_ end of grvecs
      ) ;_ end of if
      lst
    ) ;_ end of progn
    (progn
      (if col
 (apply 'grvecs (cons col pt_lst))
      ) ;_ end of if
      pt_lst
    ) ;_ end of progn
  ) ;_ end of if
) ;_ end of defun
 
(defun alt_getpoint
      (pt1 msg wd / alt_osnap cs gr len pt os cr_pt)
;;;  pt1 - координаты точки в ПСК или nil
 
  (defun alt_osnap
     (pt       pt_last /   bitlist   osnap_marker
      blst      len pt_os   os_lst    lst
     )
     ;|
pt - координаты точки в ПСК
pt_last - координаты точки для тангенсальной и перпендикулярной привязки или nil
  |;
(defun bitlist (sum / bit lst n)
;;;    (bitlist (getvar "osmode"))
  (setq n 0)
  (while (< (expt 2 n) sum)
    (setq n (1+ n))
  ) ;_ end of while
  (repeat (1+ n)
    (if (>= sum (setq bit (expt 2 n)))
      (setq lst (cons bit lst)
     sum (- sum bit)
      ) ;_ end of setq
    ) ;_ end of if
    (setq n (1- n))
  ) ;_ end of repeat
  (if lst
    lst
    (list 0)
  ) ;_ end of if
) ;_ end of defun
    (defun osnap_marker (typ pnt l col / circle-for-grvecs-list)
  (defun circle-for-grvecs-list (pnt l col n / ang pnt_lst rez)
;;;col - цвет
;;;n - количество точек разбиения окружности    
;;; (grvecs (circle-for-grvecs-list (setq pt (getpoint "\nCenter point:")) (getdist pt "\nRadius:") 2 100))
    (setq
      ang     0.0
      pnt_lst (list (mapcar (function +) pnt (list l 0.0 0.0)))
    ) ;_ end of setq
    (repeat (1- n)
      (setq
 pnt_lst
  (cons (polar pnt (setq ang (+ ang (/ pi (/ n 2)))) l)
        pnt_lst
  ) ;_ end of cons
      ) ;_ end of setq
    ) ;_ end of repeat
    (while pnt_lst
      (if (cdr pnt_lst)
 (setq rez     (append rez
         (list col (car pnt_lst) (cadr pnt_lst))
        ) ;_ end of append
       pnt_lst (cdr pnt_lst)
 ) ;_ end of setq
 (setq rez
        (append rez (list col (car pnt_lst) (cadr rez)))
       pnt_lst nil
 ) ;_ end of setq
      ) ;_ end of if
    ) ;_ end of while
    rez
  ) ;_ end of defun
      (setq pnt (trans pnt 1 2))
      (grvecs
 (mapcar
   (function (lambda (a)
        (if (listp a)
   (trans a 2 1)
   a
        ) ;_ end of if
      ) ;_ end of lambda
   ) ;_ end of function
   (cond
     ((= typ "end")
      (
       (lambda (pt1 pt2 pt3 pt4)
  (list col pt1 pt2 col pt2 pt3 col pt3 pt4 col pt4 pt1)
       ) ;_ end of lambda
        (mapcar '+ pnt (list (- l) l 0.0))
        (mapcar '+ pnt (list (- l) (- l) 0.0))
        (mapcar '+ pnt (list l (- l) 0.0))
        (mapcar '+ pnt (list l l 0.0))
      )
     )
     ((= typ "mid")
      (
       (lambda (pt1 pt2 pt3)
  (list col pt1 pt2 col pt2 pt3 col pt3 pt1)
       ) ;_ end of lambda
        (mapcar '+ pnt (list 0.0 l 0.0))
        (mapcar '+ pnt (list (- l) (- l) 0.0))
        (mapcar '+ pnt (list l (- l) 0.0))
      )
     )
     ((= typ "cen")
      (circle-for-grvecs-list pnt l 2 12)
     )
     ((= typ "nod")
      (append (circle-for-grvecs-list pnt l 2 12)
       (list col
      (mapcar '+ pnt (list (- l) l 0.0))
      (mapcar '+ pnt (list l (- l) 0.0))
      col
      (mapcar '+ pnt (list l l 0.0))
      (mapcar '+ pnt (list (- l) (- l) 0.0))
       ) ;_ end of list
      ) ;_ end of append
     )
     ((= typ "qua")
      ((lambda (pt1 pt2 pt3 pt4)
  (list col pt1 pt2 col pt2 pt3 col pt3 pt4 col pt4 pt1)
       ) ;_ end of lambda
        (mapcar '+ pnt (list (- l) 0.0 0.0))
        (mapcar '+ pnt (list 0.0 (- l) 0.0))
        (mapcar '+ pnt (list l 0.0 0.0))
        (mapcar '+ pnt (list 0.0 l 0.0))
      )
     )
     ((= typ "int")
      (list col
     (mapcar '+ pnt (list (- l) l 0.0))
     (mapcar '+ pnt (list l (- l) 0.0))
     col
     (mapcar '+ pnt (list l l 0.0))
     (mapcar '- pnt (list l l 0.0))
      ) ;_ end of list
     )
     ((= typ "ins")
      (
       (lambda (pt1 pt2 pt3 pt4 pt5 pt6)
  (list
    col pt1   pt2   col   pt2 pt3   col   pt3   pt6
    col pt6   pt5   col   pt5 pt4   col   pt4   pt1
   ) ;_ end of list
       ) ;_ end of lambda
        (mapcar '+ pnt (list 0.0 l 0.0))
        (mapcar '+ pnt (list (- l) l 0.0))
        (mapcar '- pnt (list l 0.0 0.0))
        (mapcar '- pnt (list 0.0 l 0.0))
        (mapcar '+ pnt (list l (- l) 0.0))
        (mapcar '+ pnt (list l 0.0 0.0))
      )
     )
     ((= typ "per")
      (
       (lambda (pt1 pt2 pt3 pt4 pt5)
  (list col pt1 pt2 col pt2 pt3 col pt4 pnt col pnt pt5)
       ) ;_ end of lambda
        (mapcar '+ pnt (list (- l) l 0.0))
        (mapcar '+ pnt (list (- l) (- l) 0.0))
        (mapcar '+ pnt (list l (- l) 0.0))
        (mapcar '+ pnt (list (- l) 0.0 0.0))
        (mapcar '+ pnt (list 0.0 (- l) 0.0))
      )
     )
     ((= typ "tan")
      (append (circle-for-grvecs-list pnt l 2 12)
       (list col
      (mapcar '+ pnt (list (- l) l 0.0))
      (mapcar '+ pnt (list l l 0.0))
       ) ;_ end of list
      ) ;_ end of append
     )
     ((= typ "nea")
      (
       (lambda (pt1 pt2 pt3 pt4)
  (list col pt1 pt3 col pt4 pt2 col pt1 pt4 col pt2 pt3)
       ) ;_ end of lambda
        (mapcar '+ pnt (list (- l) l 0.0))
        (mapcar '+ pnt (list (- l) (- l) 0.0))
        (mapcar '+ pnt (list l (- l) 0.0))
        (mapcar '+ pnt (list l l 0.0))
      )
     )
     ((= typ "app")
      ((lambda (pt1 pt2 pt3 pt4)
  (list
    col pt1   pt2   col   pt2 pt3   col   pt3   pt4
    col pt4   pt1   col   pt1 pt3   col   pt2   pt4
   ) ;_ end of list
       ) ;_ end of lambda
        (mapcar '+ pnt (list (- l) l 0.0))
        (mapcar '+ pnt (list (- l) (- l) 0.0))
        (mapcar '+ pnt (list l (- l) 0.0))
        (mapcar '+ pnt (list l l 0.0))
      )
     )
     ((= typ "ext")
      (list col
     (mapcar '+ pnt (list (- l) l 0.0))
     (mapcar '+ pnt (list l (- l) 0.0))
     col
     (mapcar '+ pnt (list l l 0.0))
     (mapcar '- pnt (list l l 0.0))
      ) ;_ end of list
     )
     ((= typ "par")
      (list col
     (mapcar '- pnt (list l 0.0 0.0))
     (mapcar '+ pnt (list l l 0.0))
     col
     (mapcar '- pnt (list l l 0.0))
     (mapcar '+ pnt (list l 0.0 0.0))
      ) ;_ end of list
     )
   ) ;_ end of cond
 ) ;_ end of mapcar
      ) ;_ end of grvecs
    ) ;_ end of defun
    (if
      (and
 (or (= (getvar "osmode") 16383)
     (not
       (or (member 0 (setq blst (bitlist (getvar "osmode"))))
    (member 1024 blst)
    (member 16384 blst)
       ) ;_ end of or
     ) ;_ end of not
 ) ;_ end of or
      ) ;_ end of and
       (progn
  (setq len (* (/ (getvar "viewsize") (cadr (getvar "screensize"))) 5)
        lst (quote ((1 . "end")
       (2 . "mid")
       (4 . "cen")
       (8 . "nod")
       (16 . "qua")
       (32 . "int")
       (64 . "ins")
       (128 . "per")
       (256 . "tan")
       (512 . "nea")
       (2048 . "app")
       (4096 . "ext")
       (8192 . "par")
     )
     ) ;_ end of quote
  ) ;_ end of setq
  (if pt_last
    (setvar "lastpoint" pt_last)
    (foreach
       b
        (list '(128 . "per") '(256 . "tan"))
      (setq lst (vl-remove b lst))
    ) ;_ end of foreach
  ) ;_ end of if
  (setq os_lst nil)
  (foreach
     a
      lst
    (if
      (and (member (car a) blst)
    (setq pt_os (osnap pt (strcat "_" (cdr a))))
    (not (equal pt pt_os 1.0e-008))
      ) ;_ end of and
       (setq
  os_lst (cons (list (cdr a) pt pt_os (distance pt pt_os))
        os_lst
         ) ;_ end of cons
       ) ;_ end of setq
    ) ;_ end of if
  ) ;_ end of foreach
  (if os_lst
    (progn
      (setq
        os_lst (vl-sort
   os_lst
   (function (lambda (a b) (< (last a) (last b))))
        ) ;_ end of vl-sort
      ) ;_ end of setq
      (if
        (not (and (= (caar os_lst) "nea")
    (setq os (cadr os_lst))
    (<= (last os) (* (/ len 5) (getvar "aperture")))
      ) ;_ end of and
        ) ;_ end of not
  (setq os (car os_lst))
      ) ;_ end of if
      (osnap_marker (car os) (caddr os) len 2)
      os
    ) ;_ end of progn
  ) ;_ end of if
       ) ;_ end of progn
    ) ;_ end of if
  ) ;_ end of defun
  (prompt msg)
  (while
    (and (not (vl-catch-all-error-p
  (setq gr (vl-catch-all-apply
      (function (lambda () (grread T 13 1)))
    ) ;_ end of vl-catch-all-apply
  ) ;_ end of setq
       ) ;_ end of vl-catch-all-error-p
  ) ;_ end of not
  (/= 3 (car gr))
    ) ;_ end of and
     (if (= (car gr) 5)
       (progn
  (setq pt (cadr gr)
        cs (* (/ (getvar "viewsize") 100) (getvar "cursorsize"))
  ) ;_ end of setq
  (redraw)
  (if (setq os (alt_osnap pt pt1))
    (progn
      (setq pt (caddr os))
      (if (wcmatch (car os) "nea")
        (setq cr_pt (cadr os))
        (setq cr_pt (caddr os))
      ) ;_ end of if
    ) ;_ end of progn
    (setq cr_pt pt)
  ) ;_ end of if
  (if pt1
;;;    (grvecs (list 7 pt1 pt))
    (drawing_arrow pt1 pt -251 wd)
  ) ;_ end of if
  (setq cr_pt (trans cr_pt 1 2))
  (grvecs
    (mapcar
      (function (lambda (a)
    (if (listp a)
      (trans a 2 1)
      a
    ) ;_ end of if
         ) ;_ end of lambda
      ) ;_ end of function
      (list 7
     (mapcar '+ cr_pt (list cs 0.0 0.0))
     (mapcar '+ cr_pt (list (- cs) 0.0 0.0))
     7
     (mapcar '+ cr_pt (list 0.0 cs 0.0))
     (mapcar '+ cr_pt (list 0.0 (- cs) 0.0))
      ) ;_ end of list
    ) ;_ end of mapcar
  ) ;_ end of grvecs
       ) ;_ end of progn
     ) ;_ end of if
  ) ;_ end of while
  (redraw)
  (if (vl-catch-all-error-p gr)
    nil
    pt
  ) ;_ end of if
) ;_ end of defun
(defun c:arrow (/ lst wd ort pt1 pt2)
  (defun ort (vec / leng)
      ;|
Функция получения единичного вектора из произвольного вектора
Автор: Пастух
http://www.caduser.ru/forum/index.ph...#message231325
 vec - список из 2х или 3х чисел (координаты вектора).
  |;
    (cond
      ((not vec) nil)
      ((equal (setq leng (sqrt (apply '+ (mapcar '* vec vec))))
       0.0
       1.0e-012
       ) ;_ end of equal
       nil
      )
      ((caddr vec) ;_ 3х мерный.
       (list (/ (car vec) leng)
      (/ (cadr vec) leng)
      (/ (caddr vec) leng)
       ) ;_ end of list
      )
      (T (list (/ (car vec) leng) (/ (cadr vec) leng))) ;_ 2х мерный.
    ) ;_ end of cond
  ) ;_ end of defun
 
  (if (not *ARROWWIDTH*)
    (setq *ARROWWIDTH* 10)
  ) ;_ end of if
  (while (not (or (and (listp pt1) (= 3 (length pt1)))
    (vl-catch-all-error-p pt1)
       ) ;_ end of or
  ) ;_ end of not
    (if (= pt1 "Width")
      (setq
 *ARROWWIDTH*
  (vl-catch-all-apply
    (function
      (lambda ()
        (initget 7)
        (getint
   "\nТолщина стрелки (кол-во пикселей):"
        ) ;_ end of getint
      ) ;_ end of lambda
    ) ;_ end of function
  ) ;_ end of vl-catch-all-apply
      ) ;_ end of setq
    ) ;_ end of if
    (setq
      wd  *ARROWWIDTH*
      pt1 (vl-catch-all-apply
     (function
       (lambda ()
  (initget 1 "Толщина _Width")
  (getpoint "\nПервая точка:[Толщина]")
       ) ;_ end of lambda
     ) ;_ end of function
   ) ;_ end of vl-catch-all-apply
    ) ;_ end of setq
  ) ;_ end of while
  (if
    (and
      (not (vl-catch-all-error-p pt1))
      (setq pt2 (alt_getpoint pt1 "\nВторая точка:" wd))
      (setq lst (drawing_arrow pt1 pt2 nil wd))
    ) ;_ end of and
     (entmakex
       (append
  (list
    (cons 0 "LWPOLYLINE")
    (cons 100 "AcDbEntity")
    (cons 100 "AcDbPolyline")
    (cons 90 (length lst))
    (cons 70 1)
  ) ;_ end of list
  (mapcar
    (function
      (lambda (x)
        (cons 10 (trans x 1 (trans (ort (getvar "viewdir")) 1 0)))
      ) ;_ end of lambda
    ) ;_ end of function
    lst
  ) ;_ end of mapcar
  (list (cons 210 (trans (ort (getvar "viewdir")) 1 0)))
       ) ;_ end of append
     ) ;_ end of entmakex
  ) ;_ end of if
  (princ)
) ;_ end of defun
Do$ вне форума  
 
Непрочитано 17.12.2009, 16:05
#14
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,990
<phrase 1= Отправить сообщение для VVA с помощью Skype™


В дополнение к #13 советую ознакомиться с этой темой: osnaps for grread
__________________
Как использовать код на Лиспе читаем здесь
VVA вне форума  
 
Непрочитано 17.12.2009, 16:13
#15
Елпанов Евгений

программист
 
Регистрация: 20.12.2005
Москва
Сообщений: 1,439
Отправить сообщение для Елпанов Евгений с помощью Skype™


Цитата:
Сообщение от VVA Посмотреть сообщение
В дополнение к #13 советую ознакомиться с этой темой:
тогда, уж лучше сразу с Examples of usage GRREAD - let's share, там есть мои примеры с привязкой и контекстным меню...

ps. правда только демо
__________________
Чем гениальнее ваш план, тем меньше людей с ним будут согласны.
/Сунь Цзы/

Последний раз редактировалось Елпанов Евгений, 17.12.2009 в 17:36.
Елпанов Евгений вне форума  
 
Непрочитано 17.12.2009, 17:24
#16
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,990
<phrase 1= Отправить сообщение для VVA с помощью Skype™


Елпанов Евгений, По названию нашел эти ссылки:
Examples of usage GRREAD - let's share и
Grread and pick point with osnap on !?
Offtop: Пример по grread можно опубликовать и на твоем сайте
__________________
Как использовать код на Лиспе читаем здесь
VVA вне форума  
 
Непрочитано 17.12.2009, 17:37
#17
Елпанов Евгений

программист
 
Регистрация: 20.12.2005
Москва
Сообщений: 1,439
Отправить сообщение для Елпанов Евгений с помощью Skype™


Цитата:
Сообщение от VVA Посмотреть сообщение
По названию нашел эти ссылки:
Спасибо!
а я уж и не заметил, что вместо ссылки выбрал другой тег и перебил адрес названием...
__________________
Чем гениальнее ваш план, тем меньше людей с ним будут согласны.
/Сунь Цзы/
Елпанов Евгений вне форума  
 
Непрочитано 18.12.2009, 09:10
#18
Do$

AutoCAD/Civil3D LISP/C#
 
Регистрация: 15.08.2008
Санкт-Петербург
Сообщений: 1,702
Отправить сообщение для Do$ с помощью Skype™


Цитата:
Сообщение от Елпанов Евгений Посмотреть сообщение
тогда, уж лучше сразу с Examples of usage GRREAD - let's share, там есть мои примеры с привязкой и контекстным меню...

ps. правда только демо
Мда... ведь искал, долго искал до того, как начал писать то, что в #13. И по этой ссылке тоже побывал. Вот только пост до конца не дочитал .
Для таких как я, продублирую Ваш код здесь:

Код:
[Выделить все]
(defun menu-pop500 (d / lst s)
  ; Choice function of OSNAP through the shortcut menu.
  ; Only, as an example.
  ; Is checked up in AutoCad 2004-2007 (En)
  ; by ElpanovEvgeniy
  ; (2006-10-11)
  ; (menu-pop500 (grread t 5))
  (setq
    lst (reverse
          (menu-index
            ((lambda (x) (list (1- (vla-get-count x)) x))
              (vla-item
                (vla-get-menus
                  (vla-item
                    (vla-get-menugroups
                      (vlax-get-acad-object)
                    ) ;_  vla-get-MenuGroups
                    "ACAD"
                  ) ;_  vla-item
                ) ;_  vla-get-Menus
                "&Object Snap Cursor Menu"
              ) ;_  vla-item
            )
          ) ;_  menu-index
        ) ;_  reverse
  ) ;_  setq
  (while (and
           (listp d)
           (or (= (car d) 5)
               (= (car d) 11)
               (= (car d) 12)
               (= (car d) 25) ; For old version AutoCad
           ) ;_  or
         ) ;_  and
    (cond
      ((= (car d) 25) (menucmd "POP500=*")) ; For old version AutoCad
      ((equal d '(11 0)) (menucmd "POP500=*"))
      ((= (car d) 11) (setq s (nth (- (cadr d) 500) lst)))
    ) ;_  cond
    (if s
      (setq d s)
      (setq d (grread t 5))
    ) ;_  if
  ) ;_  while
  (substr s 1 4)
) ;_  defun
(defun menu-index (l)
  ; Creation of the list of choices of choice of OSNAP
  ; Is checked up in AutoCad 2004-2007 (En)
  ; by ElpanovEvgeniy
  ; (2006-10-11)
                  ;|
(menu-index
 ((lambda (x) (list (1-(vla-get-count x)) x))
  (vla-item
   (vla-get-menus
    (vla-item
     (vla-get-menugroups
      (vlax-get-acad-object)
      ) ;_  vla-get-MenuGroups
     "ACAD"
     ) ;_  vla-item
    ) ;_  vla-get-Menus
   "&Object Snap Cursor Menu"
   ) ;_  vla-item
  )
 ) ;_  menu-index
 |;
  (if (not (minusp (car l)))
    (cond
      ((= (vla-get-type (vla-item (cadr l) (car l))) 0)
       (cons
         (vla-get-macro (vla-item (cadr l) (car l)))
         (menu-index (cons (1- (car l)) (cdr l)))
       ) ;_  cons
      )
      ((= (vla-get-type (vla-item (cadr l) (car l))) 1)
       (menu-index (cons (1- (car l)) (cdr l)))
      )
      ((= (vla-get-type (vla-item (cadr l) (car l))) 2)
       (append
         (menu-index
           ((lambda (x) (list (1- (vla-get-count x)) x))
             (vla-get-submenu (vla-item (cadr l) (car l)))
           ) ;_  menu-index
         ) ;_  menu-index
         (menu-index (cons (1- (car l)) (cdr l)))
       ) ;_  append
      )
    ) ;_  cond
  ) ;_  if
) ;_  defun
(defun get_osmode nil
  ; Function create list osmode macro
  ; for result (getvar "OSMODE")
  ; by Evgeniy Elpanov
  ; (get_osmode)
  (mapcar
    (function cdr)
    (vl-remove-if
      (function
        (lambda (x)
          (zerop (logand (getvar "OSMODE") (car x)))
        ) ;_  lambda
      ) ;_  function
      (append
        (if (< 0 (setq cur_mode (getvar "osmode")) 16384)
          '((1 . "_end")
            (2 . "_mid")
            (4 . "_cen")
            (8 . "_nod")
            (16 . "_qua")
            (32 . "_int")
  ;(4096 . "_ext") ; Is not realized
           )
        ) ;_  if
        (if (not (zerop (logand (getvar "autosnap") 16)))
          '((64 . "_ins")
            (128 . "_per")
            (256 . "_tan")
            (512 . "_nea")
  ;(1024 . "_qui") ; Is not realized
            (2048 . "_app")
  ;(8192 . "_par") ; Is not realized
           )
        ) ;_  if
      ) ;_  append
    ) ;_  substr
  ) ;_  mapcar
) ;_  defun
 
 
(defun osmode-grvecs-lst (/ -ASS ASS COL)
  ; Function create list
  ; for drawing icons osmode with the function grvecs
  ; by Evgeniy Elpanov
  ; (osmode-grvecs-lst)
  (setq
    col  (atoi (getenv "AutoSnapColor"))
    ass  (atof (getenv "AutoSnapSize"))
    -ass (- ass)
  ) ;_  setq
  (list
    (list
      "tracking"
      col
      (list (* -ass 0.2) 0.)
      (list (* ass 0.2) 0.)
      col
      (list 0. (* -ass 0.2))
      (list 0. (* ass 0.2))
    ) ;_  list
    (list
      "_end"
      col
      (list -ass -ass)
      (list -ass ass)
      col
      (list (1- -ass) (1- -ass))
      (list (1- -ass) (1+ ass))
      col
      (list -ass ass)
      (list ass ass)
      col
      (list (1- -ass) (1+ ass))
      (list (1+ ass) (1+ ass))
      col
      (list ass ass)
      (list ass -ass)
      col
      (list (1+ ass) (1+ ass))
      (list (1+ ass) (1- -ass))
      col
      (list ass -ass)
      (list -ass -ass)
      col
      (list (1+ ass) (1- -ass))
      (list (1- -ass) (1- -ass))
    ) ;_  list
    (list
      "_mid"
      col
      (list -ass -ass)
      (list 0. ass)
      col
      (list (1- -ass) (1- -ass))
      (list 0. (1+ ass))
      col
      (list 0. ass)
      (list ass -ass)
      col
      (list 0. (1+ ass))
      (list (1+ ass) (1- -ass))
      col
      (list ass -ass)
      (list -ass -ass)
      col
      (list (1+ ass) (1- -ass))
      (list (1- -ass) (1- -ass))
    ) ;_  list
    (list
      "_cen"
      7
      (list (* -ass 0.2) 0.)
      (list (* ass 0.2) 0.)
      7
      (list 0. (* -ass 0.2))
      (list 0. (* ass 0.2))
      col
      (list -ass 0.)
      (list (* -ass 0.86) (* ass 0.5))
      col
      (list (* -ass 0.86) (* ass 0.5))
      (list (* -ass 0.5) (* ass 0.86))
      col
      (list (* -ass 0.5) (* ass 0.86))
      (list 0. ass)
      col
      (list 0. ass)
      (list (* ass 0.5) (* ass 0.86))
      col
      (list (* ass 0.5) (* ass 0.86))
      (list (* ass 0.86) (* ass 0.5))
      col
      (list (* ass 0.86) (* ass 0.5))
      (list ass 0.)
      col
      (list ass 0.)
      (list (* ass 0.86) (* -ass 0.5))
      col
      (list (* ass 0.86) (* -ass 0.5))
      (list (* ass 0.5) (* -ass 0.86))
      col
      (list (* ass 0.5) (* -ass 0.86))
      (list 0. -ass)
      col
      (list 0. -ass)
      (list (* -ass 0.5) (* -ass 0.86))
      col
      (list (* -ass 0.5) (* -ass 0.86))
      (list (* -ass 0.86) (* -ass 0.5))
      col
      (list (* -ass 0.86) (* -ass 0.5))
      (list -ass 0.)
    ) ;_  list
    (list
      "_nod"
      col
      (list -ass -ass)
      (list ass ass)
      col
      (list -ass ass)
      (list ass -ass)
      col
      (list -ass 0.)
      (list (* -ass 0.86) (* ass 0.5))
      col
      (list (* -ass 0.86) (* ass 0.5))
      (list (* -ass 0.5) (* ass 0.86))
      col
      (list (* -ass 0.5) (* ass 0.86))
      (list 0. ass)
      col
      (list 0. ass)
      (list (* ass 0.5) (* ass 0.86))
      col
      (list (* ass 0.5) (* ass 0.86))
      (list (* ass 0.86) (* ass 0.5))
      col
      (list (* ass 0.86) (* ass 0.5))
      (list ass 0.)
      col
      (list ass 0.)
      (list (* ass 0.86) (* -ass 0.5))
      col
      (list (* ass 0.86) (* -ass 0.5))
      (list (* ass 0.5) (* -ass 0.86))
      col
      (list (* ass 0.5) (* -ass 0.86))
      (list 0. -ass)
      col
      (list 0. -ass)
      (list (* -ass 0.5) (* -ass 0.86))
      col
      (list (* -ass 0.5) (* -ass 0.86))
      (list (* -ass 0.86) (* -ass 0.5))
      col
      (list (* -ass 0.86) (* -ass 0.5))
      (list -ass 0.)
    ) ;_  list
    (list
      "_qua"
      col
      (list 0. -ass)
      (list -ass 0.)
      col
      (list 0. (1- -ass))
      (list (1- -ass) 0.)
      col
      (list -ass 0.)
      (list 0. ass)
      col
      (list (1- -ass) 0.)
      (list 0. (1+ ass))
      col
      (list 0. ass)
      (list ass 0.)
      col
      (list 0. (1+ ass))
      (list (1+ ass) 0.)
      col
      (list ass 0.)
      (list 0. -ass)
      col
      (list (1+ ass) 0.)
      (list 0. (1- -ass))
    ) ;_  list
    (list
      "_int"
      col
      (list -ass -ass)
      (list ass ass)
      col
      (list -ass (1+ -ass))
      (list ass (1+ ass))
      col
      (list (1+ -ass) -ass)
      (list (1+ ass) ass)
      col
      (list -ass ass)
      (list ass -ass)
      col
      (list -ass (1+ ass))
      (list ass (1+ -ass))
      col
      (list (1+ -ass) ass)
      (list (1+ ass) -ass)
    ) ;_  list
    (list
      "_ins"
      col
      (list (* -ass 0.1) (* -ass 0.1))
      (list -ass (* -ass 0.1))
      col
      (list -ass (* -ass 0.1))
      (list -ass ass)
      col
      (list -ass ass)
      (list (* ass 0.1) ass)
      col
      (list (* ass 0.1) ass)
      (list (* ass 0.1) (* ass 0.1))
      col
      (list (* ass 0.1) (* ass 0.1))
      (list ass (* ass 0.1))
      col
      (list ass (* ass 0.1))
      (list ass -ass)
      col
      (list ass -ass)
      (list (* -ass 0.1) -ass)
      col
      (list (* -ass 0.1) -ass)
      (list (* -ass 0.1) (* -ass 0.1))
      col
      (list (1- (* -ass 0.1)) (1- (* -ass 0.1)))
      (list (1- -ass) (1- (* -ass 0.1)))
      col
      (list (1- -ass) (1- (* -ass 0.1)))
      (list (1- -ass) (1+ ass))
      col
      (list (1- -ass) (1+ ass))
      (list (1+ (* ass 0.1)) (1+ ass))
      col
      (list (1+ (* ass 0.1)) (1+ ass))
      (list (1+ (* ass 0.1)) (1+ (* ass 0.1)))
      col
      (list (1+ (* ass 0.1)) (1+ (* ass 0.1)))
      (list (1+ ass) (1+ (* ass 0.1)))
      col
      (list (1+ ass) (1+ (* ass 0.1)))
      (list (1+ ass) (1- -ass))
      col
      (list (1+ ass) (1- -ass))
      (list (1- (* -ass 0.1)) (1- -ass))
      col
      (list (1- (* -ass 0.1)) (1- -ass))
      (list (1- (* -ass 0.1)) (1- (* -ass 0.1)))
    ) ;_  list
    (list
      "_tan"
      col
      (list -ass ass)
      (list ass ass)
      col
      (list (1- -ass) (1+ ass))
      (list (1+ ass) (1+ ass))
      col
      (list -ass 0.)
      (list (* -ass 0.86) (* ass 0.5))
      col
      (list (* -ass 0.86) (* ass 0.5))
      (list (* -ass 0.5) (* ass 0.86))
      col
      (list (* -ass 0.5) (* ass 0.86))
      (list 0. ass)
      col
      (list 0. ass)
      (list (* ass 0.5) (* ass 0.86))
      col
      (list (* ass 0.5) (* ass 0.86))
      (list (* ass 0.86) (* ass 0.5))
      col
      (list (* ass 0.86) (* ass 0.5))
      (list ass 0.)
      col
      (list ass 0.)
      (list (* ass 0.86) (* -ass 0.5))
      col
      (list (* ass 0.86) (* -ass 0.5))
      (list (* ass 0.5) (* -ass 0.86))
      col
      (list (* ass 0.5) (* -ass 0.86))
      (list 0. -ass)
      col
      (list 0. -ass)
      (list (* -ass 0.5) (* -ass 0.86))
      col
      (list (* -ass 0.5) (* -ass 0.86))
      (list (* -ass 0.86) (* -ass 0.5))
      col
      (list (* -ass 0.86) (* -ass 0.5))
      (list -ass 0.)
    ) ;_  list
    (list
      "_per"
      col
      (list -ass -ass)
      (list -ass ass)
      col
      (list (1- -ass) (1- -ass))
      (list (1- -ass) (1+ ass))
      col
      (list ass -ass)
      (list -ass -ass)
      col
      (list (1+ ass) (1- -ass))
      (list (1- -ass) (1- -ass))
      col
      (list -ass 0.)
      (list 0. 0.)
      col
      (list -ass -1.)
      (list 0. -1.)
      col
      (list 0. 0.)
      (list 0. -ass)
      col
      (list -1. 0.)
      (list -1. -ass)
    ) ;_  list
    (list
      "_nea"
      col
      (list -ass -ass)
      (list ass ass)
      col
      (list -ass ass)
      (list ass ass)
      col
      (list (1- -ass) (1+ ass))
      (list (1+ ass) (1+ ass))
      col
      (list -ass ass)
      (list ass -ass)
      col
      (list ass -ass)
      (list -ass -ass)
      col
      (list (1+ ass) (1- -ass))
      (list (1- -ass) (1- -ass))
    ) ;_  list
    (list
      "_app"
      col
      (list -ass -ass)
      (list ass ass)
      col
      (list ass -ass)
      (list -ass ass)
 
      col
      (list -ass -ass)
      (list -ass ass)
      col
      (list (1- -ass) (1- -ass))
      (list (1- -ass) (1+ ass))
      col
      (list -ass ass)
      (list ass ass)
      col
      (list (1- -ass) (1+ ass))
      (list (1+ ass) (1+ ass))
      col
      (list ass ass)
      (list ass -ass)
      col
      (list (1+ ass) (1+ ass))
      (list (1+ ass) (1- -ass))
      col
      (list ass -ass)
      (list -ass -ass)
      col
      (list (1+ ass) (1- -ass))
      (list (1- -ass) (1- -ass))
    ) ;_  list
    ;; Is not realized
    ;;    (list
    ;;    "_par"
    ;;      col
    ;;      (list (* -ass 0.8) -ass)
    ;;      (list ass (* ass 0.8))
    ;;      col
    ;;      (list -ass (* -ass 0.8))
    ;;      (list (* ass 0.8) ass)
    ;;    )
 
  ) ;_  list
) ;_  defun
(defun c:test (/ GR O OSM-LST OSMODE S TP)
  ; Example drawing icons osmode with
  ; Return point, for osmode
  ; by Evgeniy Elpanov
  ; (c:test)
  (setq osm-lst (osmode-grvecs-lst)
        osmode (get_osmode))
  (while (or (= (car (setq gr (grread nil 5 0))) 5)
               (= (car gr) 11)
               (= (car gr) 25) ; For old version AutoCad
           )
    (if (or (= (car gr) 11)
            (= (car gr) 25)
        ) ;_  or
      (setq osmode(list(menu-pop500 gr)))
      (progn
 
        (if (setq
              o (vl-remove-if
                  (function null)
                  (mapcar
                    (function
                      (lambda (x / o)
                        (if (setq o (osnap (cadr gr) x))
                          (list (distance (cadr gr) o) o x (cadr gr))
                        ) ;_  if
                      ) ;_  lambda
                    ) ;_  function
                    osmode
                  ) ;_  mapcar
                ) ;_  vl-remove-if
            ) ;_  setq
          (setq
            o (cdar
                (vl-sort
                  o
                  (function
                    (lambda (a b)
                      (< (car a) (car b))
                    ) ;_  lambda
                  ) ;_  function
                ) ;_  vl-sort
              ) ;_  cdar
          ) ;_  setq
        ) ;_  if
 
        (setq s (/ (getvar "viewsize") (cadr (getvar "SCREENSIZE"))))
        (cond
          ((not o))
          ((= (cadr o) "_non")(setq tp(redraw)))
          ((WCMATCH (cadr o) "_end,_mid,_cen,_nod,_int,_ins")
           (setq tp (car o))
           (setvar "lastpoint" tp)
           (setq o (cons (trans (car o) 1 3) (cdr o)))
           (redraw)
           (grvecs
             (cdr (assoc "tracking" osm-lst))
             (list (list s 0. 0. (caar o))
                   (list 0. s 0. (cadar o))
                   (list 0. 0. s 0.)
                   '(0. 0. 0. 1.)
             ) ;_  list
           ) ;_  grvecs
           (grvecs
             (cdr (assoc (cadr o) osm-lst))
             (list (list s 0. 0. (caar o))
                   (list 0. s 0. (cadar o))
                   (list 0. 0. s 0.)
                   '(0. 0. 0. 1.)
             ) ;_  list
           ) ;_  grvecs
          )
          ((WCMATCH (cadr o) "_nea,_qua,_app")
           (setq o (cons (trans (car o) 1 3) (cdr o)))
           (redraw)
           (grvecs
             (cdr (assoc (cadr o) osm-lst))
             (list (list s 0. 0. (caar o))
                   (list 0. s 0. (cadar o))
                   (list 0. 0. s 0.)
                   '(0. 0. 0. 1.)
             ) ;_  list
           ) ;_  grvecs
          )
          ((and tp (not (equal tp (car o) 1e-8)))
           (redraw)
           (grdraw (car o) tp 7 1)
           (setq o (cons (trans (car o) 1 3) (cdr o)))
           (grvecs
             (cdr (assoc (cadr o) osm-lst))
             (list (list s 0. 0. (caar o))
                   (list 0. s 0. (cadar o))
                   (list 0. 0. s 0.)
                   '(0. 0. 0. 1.)
             ) ;_  list
           ) ;_  grvecs
          )
        ) ;_  cond
        (if tp
          (grvecs
            (cdr (assoc "tracking" osm-lst))
            (list (list s 0. 0. (car (trans tp 1 3)))
                  (list 0. s 0. (cadr (trans tp 1 3)))
                  (list 0. 0. s 0.)
                  '(0. 0. 0. 1.)
            ) ;_  list
          ) ;_  grvecs
        ) ;_  if
      ) ;_  progn
    ) ;_  if
  ) ;_  while
  (redraw)
  (if o
    (osnap (caddr o) (cadr o))
    (cadr gr)
  ) ;_  if
) ;_  defun

После загрузки, запускать коммандой test
Do$ вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > (GRREAD) и привязка

Размещение рекламы
Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
В Mechanical Desktop отсутствует привязка к размерным линиям и размерному тексту Kirill1980 AutoCAD 7 13.10.2008 18:23
Привязка к размерам и строка состояния Krieger AutoCAD 7 05.03.2008 14:44
привязка Натали AutoCAD 2 05.10.2006 10:56
объектная привязка не востанавливается Polika AutoCAD 8 15.12.2005 20:09
Привязка Quadrant в блоке. Mikhail AutoCAD 3 29.09.2004 14:29