Внутренности dwg

Автор: | Дата: 18 Июнь 2010 · 6 коммент. 

Сайт autocad.ru / caduser.ru, к сожалению, иногда "переезжает". При этом теряется масса интереснейших вещей. С большим трудом я нашел функцию от Эдуарда (пока он лиспом еще занимался), показывающую все внутренности dwg (ссылка на данный момент)

Иногда бывает полезно заглянуть в потроха рисунка smile:)
Программка до ужаса простая. Тупо перебирает метки
переводя их из шестнадцатеричной системы исчисления в десятичную и обратно.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
;;;Функция преобразования числа из шестнадцатиричной в десятичную систему исчисления
;;;аргументы :
;;;а - число в шестнадцатиричной системе исчисления , тип string
;;;переменные:
;;;listst - список степеней числа 16. Длина списка равна количеству символов аргумента
(defun h-dec (a / i listst)
  (setq i (strlen a))
  (repeat i
    (setq listst (cons (expt 16 (1- i)) listst))
    (setq i (1- i))
    ) ;_ end of repeat
  (rtos
    (apply
      (function +)
      (mapcar
        (function *)
        (reverse
          (mapcar
            (function
              (lambda (x)
                (cond
                  (
                   (vl-symbolp (read (chr x)))
                   (+ (vl-position (chr x) '("A" "B" "C" "D" "E" "F"))
                      10
                      ) ;_ end of +
                   )
                  (t
                   (atoi (chr x))
                   )
                  ) ;_ end of cond
                ) ;_ end of lambda
              ) ;_ end of function
            (vl-string->list a)
            ) ;_ end of mapcar
          ) ;_ end of reverse
        (mapcar (function float) listst)
        ) ;_ end of mapcar
      ) ;_ end of apply
    ) ;_ end of rtos
  ) ;_ end of defun

;;;Функция преобразования числа из десятичной в шестнадцатиричную систему исчисления.
;;;Аргументы:
;;;b- число в десятичной системе исчисления , тип integer
;;;Переменные:
;;;blist - число в шестнадцатеричной системе исчисления , тип string
(defun dec-h (b / blist list16)
  (setq list16 '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "A" "B" "C" "D" "E" "F"))
  (while (>= b 16)
    (setq blist (cons (fix (rem b 16)) blist)
          b     (fix (/ b 16.00))
          ) ;_ end of setq
    ) ;_ end of while
  (apply (function strcat)
         (mapcar(function(lambda (x)
                    (nth x list16)
                    ))
                 (setq blist (cons b blist))
                 ) ;_ end of mapcar
         ) ;_ end of apply
  ) ;_ end of defun

;;; Функция экспорта базы данных рисунка в текстовой файл. Производит поиск графических и не графических примитивов в
;;; базе
;;; рисунка
;;;перебирая метки с 1 до метки последнего созданного примитива , выводит свойства примитивов в текстовой файл
;;; в виде :  "класс объекта"  "метка"  "метка в десятичном представлении" "имя объекта" (при его наличии)
;;; аргументов нет
;;; переменные :
;;;filename - имя файла вывода данных
;;;dsk - дескриптор файла
;;;lp - имя последнего созданного примитива
;;;m - метка примитива
;;;lm - список меток
(defun es_export_database (/ lm filename dsk lp m)
  (setq i 1)
  (if (and
        (setq filename (getfiled "Файл вывода " "C:\" "xls" 1))
          ;имя файла вывода
        (setq dsk (open filename "a")) ;дескриптор файла
        (setq lp (entmakex '((0 . "point") (10 0 0 0))))
          ; создаем примитив для определения количества повторов цикла перебора меток
        ) ;_ end of and
    (progn
      (repeat (1- (atoi (h-dec (cdr (assoc 5 (entget lp))))))
          ;цикл перебора меток
        (if
          (setq m (handent (dec-h i)))
           (setq lm (cons m lm)) ; список содержащий метки существующих в чертеже примитивов
           ) ;_ end of if
        (setq i (1+ i)
              ) ;_ end of setq
        ) ;_ end of repeat
      (entdel lp) ; удаляем рабочий примитив
      (mapcar
        '(lambda (x / nam prn)
           (setq prn (strcat (vla-get-objectname x)
                             "\t"
                             (vla-get-handle x)
                             "\t"
                             (h-dec (vla-get-handle x))
                             "\t"
                             (rtos (vla-get-objectid x) 2 0)
                             "\t"
                             ) ;_ end of strcat
                 ) ;_ end of setq
           (if
             (and
               (vlax-property-available-p x 'name)
               (not (vl-catch-all-error-p
                      (setq
                        nam (vl-catch-all-apply 'vla-get-name (list x))
                        ) ;_ end of setq
                      ) ;_ end of vl-catch-all-error-p
                    ) ;_ end of not
               ) ;_ end of and
              (setq prn (strcat prn nam "\t"))
              (setq prn (strcat prn "\t"))
              ) ;_ end of if
           (princ (strcat prn "\n") dsk)
           ) ;_ end of lambda
        (vl-remove 'nil
                   (mapcar 'vlax-ename->vla-object (reverse lm))
                   ) ;_ end of vl-remove
        ) ; функция печати данных примитива в файл
      (close dsk)
      ) ;_ end of progn
    ) ;_ end of if
  ) ;_ end of defun

Размещено в Код LISP, Новости, Функции LISP · Метки: ,



Комментарии

Есть 6 коммент. к “Внутренности dwg”
  1. Vildar пишет:
    28 Декабрь 2010 в 18:03

    При запуск (es_export_database), акад пишет:
    ; ошибка: no function definition: FUNTION

    Подправил на Function, ну думаю опечатка, и опять запустил
    ; ошибка: no function definition: nil

    Все я в тупике.
    Подскажите плиз.

  2. Кулик Алексей aka kpblc пишет:
    29 Декабрь 2010 в 1:03

    Доброго. Во-первых, спасибо за замеченную опечатку. Во-вторых, весьма странно: я только что специально прогнал код на практически пустом файле (AutoCAD 2011 Eng 64 bit + SP), все сработало корректно.
    Что-то странное - код не прикрепить никак :(

  3. Vildar пишет:
    29 Декабрь 2010 в 10:07

    Если можно уточню.
    Сообщение - ; ошибка: no function definition: nil
    Выскакивает в функции es_export_database, в строке:

    1
    2
    3
    (vl-remove 'nil
                       (mapcar 'vlax-ename->vla-object (reverse lm))
                       ) ;_ end of vl-remove

    А еще точнее в этом месте этой строки: (reverse lm)
    Может это поможет вам разобраться. Спасибо.
    Autocad2008 sp1, winXP, 32bit.

  4. Кулик Алексей aka kpblc пишет:
    29 Декабрь 2010 в 18:33

    Доброго. Только что проверил на AutoCAD 2008 Eng + SP 32 bit и AutoCAD 2011 Eng + SP 32 bit, Windows Vista Home 32 bit. Ошибка есть. Но, что самое интересное - ошибка появляется, если код выполнять не пошагово. После хотя бы одного прохода пошагово все работает корректно.
    Есть, конечно, вариант: попытаться сначала сформировать полноценный список, и лишь потом его выводить в файл. Но мне почему-то такой подход не кажется правильным :(
    Как бороться - не знаю, а Эдуарда сейчас уже сложно заманить на решение лисповых задач :( Если чего получится - попробую сделать решение. Хотя особых надежд на это я бы не возлагал...

  5. Vildar пишет:
    30 Декабрь 2010 в 12:44

    Алексей с Наступающим!
    А можно попросить выложить кусочек результатов этой программы. Меня только это интересует. Лисп мне сложно понять. А увидев результат, я сразу, надеюсь, пойму что же делает эта программа (функция).

    Спасибо.

  6. @rey7 пишет:
    4 Март 2011 в 8:13

    так работает:

    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    107
    108
    109
    110
    111
    112
    113
    114
    115
    116
    117
    118
    119
    120
    121
    122
    123
    124
    125
    126
    127
    128
    129
    130
    ;;;Функция преобразования числа из шестнадцатиричной в десятичную систему исчисления
    ;;;аргументы :
    ;;;а - число в шестнадцатиричной системе исчисления , тип string
    ;;;переменные:
    ;;;listst - список степеней числа 16. Длина списка равна количеству символов аргумента
    (defun c:h-dec (a / i listst)
      (setq i (strlen a))
      (repeat i
        (setq listst (cons (expt 16 (1- i)) listst))
        (setq i (1- i))
        ) ;_ end of repeat
      (rtos
        (apply
          (function +)
          (mapcar
            (function *)
            (reverse
              (mapcar
                (function
                  (lambda (x)
                    (cond
                      (
                       (vl-symbolp (read (chr x)))
                       (+ (vl-position (chr x) '("A" "B" "C" "D" "E" "F"))
                          10
                          ) ;_ end of +
                       )
                      (t
                       (atoi (chr x))
                       )
                      ) ;_ end of cond
                    ) ;_ end of lambda
                  ) ;_ end of function
                (vl-string->list a)
                ) ;_ end of mapcar
              ) ;_ end of reverse
            (mapcar (function float) listst)
            ) ;_ end of mapcar
          ) ;_ end of apply
        ) ;_ end of rtos
      ) ;_ end of defun

    ;;;Функция преобразования числа из десятичной в шестнадцатиричную систему исчисления.
    ;;;Аргументы:
    ;;;b- число в десятичной системе исчисления , тип integer
    ;;;Переменные:
    ;;;blist - число в шестнадцатеричной системе исчисления , тип string
    (defun c:dec-h (b / blist list16)
      (setq list16 '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "A" "B" "C" "D" "E" "F"))
      (while (>= b 16)
        (setq blist (cons (fix (rem b 16)) blist)
              b     (fix (/ b 16.00))
              ) ;_ end of setq
        ) ;_ end of while
      (apply (function strcat)
             (mapcar(function(lambda (x)
                        (nth x list16)
                        ))
                     (setq blist (cons b blist))
                     ) ;_ end of mapcar
             ) ;_ end of apply
      ) ;_ end of defun

    ;;; Функция экспорта базы данных рисунка в текстовой файл. Производит поиск графических и не графических примитивов в
    ;;; базе
    ;;; рисунка
    ;;;перебирая метки с 1 до метки последнего созданного примитива , выводит свойства примитивов в текстовой файл
    ;;; в виде :  "класс объекта"  "метка"  "метка в десятичном представлении" "имя объекта" (при его наличии)
    ;;; аргументов нет
    ;;; переменные :
    ;;;filename - имя файла вывода данных
    ;;;dsk - дескриптор файла
    ;;;lp - имя последнего созданного примитива
    ;;;m - метка примитива
    ;;;lm - список меток
    (defun c:es_export_database (/ lm filename dsk lp m)
      (setq i 1)
      (if (and
            (setq filename (getfiled "Файл вывода " "C:\" "xls" 1))
              ;имя файла вывода
            (setq dsk (open filename "    a")) ;дескриптор файла
            (setq lp (entmakex '((0 . "    point") (10 0 0 0))))
              ; создаем примитив для определения количества повторов цикла перебора меток
            ) ;_ end of and
        (progn
          (repeat (1- (atoi (h-dec (cdr (assoc 5 (entget lp))))))
              ;цикл перебора меток
            (if
              (setq m (handent (dec-h i)))
               (setq lm (cons m lm)) ; список содержащий метки существующих в чертеже примитивов
               ) ;_ end of if
            (setq i (1+ i)
                  ) ;_ end of setq
            ) ;_ end of repeat
          (entdel lp) ; удаляем рабочий примитив
          (mapcar
            '(lambda (x / nam prn)
               (setq prn (strcat (vla-get-objectname x)
                                 "    \t"
                                 (vla-get-handle x)
                                 "    \t"
                                 (h-dec (vla-get-handle x))
                                 "    \t"
                                 (rtos (vla-get-objectid x) 2 0)
                                 "    \t"
                                 ) ;_ end of strcat
                     ) ;_ end of setq
               (if
                 (and
                   (vlax-property-available-p x 'name)
                   (not (vl-catch-all-error-p
                          (setq
                            nam (vl-catch-all-apply 'vla-get-name (list x))
                            ) ;_ end of setq
                          ) ;_ end of vl-catch-all-error-p
                        ) ;_ end of not
                   ) ;_ end of and
                  (setq prn (strcat prn nam "    \t"))
                  (setq prn (strcat prn "    \t"))
                  ) ;_ end of if
               (princ (strcat prn "    \n") dsk)
               ) ;_ end of lambda
            (vl-remove 'nil
                       (mapcar 'vlax-ename->vla-object (reverse lm))
                       ) ;_ end of vl-remove
            ) ; функция печати данных примитива в файл
          (close dsk)
          ) ;_ end of progn
        ) ;_ end of if
      ) ;_ end of defun

Поделитесь своим мнением


Я не робот.