Поздравления с помощью AutoCAD

Автор: | Дата: 13 Февраль 2015 · 1 комментарий 

Близятся первые праздники “общенационального” масштаба, хочется поздравить. Вопрос - как сделать так, чтобы сам ACAD поздравлял народ.

Сначала нарисуем простую функцию, вываливающую стандартное поздравление:

Простое поздравление
1
2
3
4
(defun c:congr1 ()
  (alert "Поздравляем с праздником!")
  (princ)
  ) ;_ end of defun

Грустно, тупо и неинтересно. Намного любопытнее будет, если у нас в каком-то серверном каталоге лежит текстовый файлик примерно такого содержания:

1
<Логин пользователя>;<Домен пользователя>;<Полные Фамилия, Имя, Отчество>

Тогда обращение можно будет персонализировать:

Персонализированное поздравления
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
(defun c:conrg2 (/ _kpblc-conv-string-to-list handle file lst str user)

  (defun _kpblc-conv-string-to-list (string separator / i)
                                    ;|
*    Функция разбора строки. Возвращает список либо точечную пару.
*    Параметры вызова:
*  string    разбираемая строка
*  separator  символ, используемый в качестве разделителя частей
*    Примеры вызова:
(_kpblc-conv-string-to-list "1;2;3;4;5;6" ";")  ;'(1 2 3 4 5 6)
(_kpblc-conv-string-to-list "1;2" ";")    ;'(1 2)
*    За основу взяты уроки Евгения Елпанова по рекурсиям
|;
    (cond
      ((= string "") nil)
      ((vl-string-search separator string)
       ((lambda (/ pos res)
          (while (setq pos (vl-string-search separator string))
            (setq res    (cons (substr string 1 pos) res)
                  string (substr string (+ (strlen separator) 1 pos))
                  ) ;_ end of setq
            ) ;_ end of while
          (reverse (cons string res))
          ) ;_ end of lambda
        )
       )
      ((wcmatch (strcase string) (strcat "*" (strcase separator) "*"))
       ((lambda (/ pos res _str prev)
          (setq pos  1
                prev 1
                _str (substr string pos)
                ) ;_ end of setq
          (while (<= pos (1+ (- (strlen string) (strlen separator))))
            (if ;; (wcmatch (strcase (substr string pos)) (strcase (strcat separator "*")))
                (wcmatch (strcase (substr string pos (strlen separator))) (strcase separator))
              (setq res    (cons (substr string 1 (1- pos)) res)
                    string (substr string (+ (strlen separator) pos))
                    pos    0
                    ) ;_ end of setq
              ) ;_ end of if
            (setq pos (1+ pos))
            ) ;_ end of while
          (if (< (strlen string) (strlen separator))
            (setq res (cons string res))
            ) ;_ end of if
          (if (or (not res) (= _str string))
            (setq res (list string))
            (reverse res)
            ) ;_ end of if
          ) ;_ end of lambda
        )
       )
      (t (list string))
      ) ;_ end of cond
    ) ;_ end of defun

  (setq file   "\\\\server\\библиотека\\test\\users.txt" ;; Путь к текстовому файлу
        handle (open file "r")
        ) ;_ end of setq
  (while (setq str (read-line handle))
    (setq lst
           (cons
             (mapcar (function cons) '("user" "domain" "name") (_kpblc-conv-string-to-list str ";"))
             lst
             ) ;_ end of cons
          ) ;_ end of setq
    ) ;_ end of while
  (close handle)
  (if (setq user (car (vl-remove-if-not
                        (function
                          (lambda (x)
                            (and (= (strcase (getenv "username")) (strcase (cdr (assoc "user" x))))
                                 (= (strcase (getenv "userdomain")) (strcase (cdr (assoc "domain" x))))
                                 ) ;_ end of and
                            ) ;_ end of lambda
                          ) ;_ end of function
                        lst
                        ) ;_ end of vl-remove-if-not
                      ) ;_ end of car
            ) ;_ end of setq
    (alert (strcat "Уважаемый(ая) "
                   (cdr (assoc "name" user))
                   "!"
                   "\n\nПоздравляем с праздником!"
                   ) ;_ end of strcat
           ) ;_ end of alert
    ) ;_ end of if
  (princ)
  ) ;_ end of defun

Но это поздравление тоже не совсем "нормальное": что значит "Уважаемый(ая)"? Добавим пол: мужской-женский в файл:

1
<Логин пользователя>;<Домен пользователя>;<Полные Фамилия, Имя, Отчество>;<Пол>

и поменяем код (указываем пол “м” - мужской; “ж” - женский):

Персонализированное поздравление, часть 2
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
(defun c:conrg3 (/ _kpblc-conv-string-to-list handle file lst str user)

  (defun _kpblc-conv-string-to-list (string separator / i)
                                    ;|
*    Функция разбора строки. Возвращает список либо точечную пару.
*    Параметры вызова:
*  string    разбираемая строка
*  separator  символ, используемый в качестве разделителя частей
*    Примеры вызова:
(_kpblc-conv-string-to-list "1;2;3;4;5;6" ";")  ;'(1 2 3 4 5 6)
(_kpblc-conv-string-to-list "1;2" ";")    ;'(1 2)
*    За основу взяты уроки Евгения Елпанова по рекурсиям
|;
    (cond
      ((= string "") nil)
      ((vl-string-search separator string)
       ((lambda (/ pos res)
          (while (setq pos (vl-string-search separator string))
            (setq res    (cons (substr string 1 pos) res)
                  string (substr string (+ (strlen separator) 1 pos))
                  ) ;_ end of setq
            ) ;_ end of while
          (reverse (cons string res))
          ) ;_ end of lambda
        )
       )
      ((wcmatch (strcase string) (strcat "*" (strcase separator) "*"))
       ((lambda (/ pos res _str prev)
          (setq pos  1
                prev 1
                _str (substr string pos)
                ) ;_ end of setq
          (while (<= pos (1+ (- (strlen string) (strlen separator))))
            (if ;; (wcmatch (strcase (substr string pos)) (strcase (strcat separator "*")))
                (wcmatch (strcase (substr string pos (strlen separator))) (strcase separator))
              (setq res    (cons (substr string 1 (1- pos)) res)
                    string (substr string (+ (strlen separator) pos))
                    pos    0
                    ) ;_ end of setq
              ) ;_ end of if
            (setq pos (1+ pos))
            ) ;_ end of while
          (if (< (strlen string) (strlen separator))
            (setq res (cons string res))
            ) ;_ end of if
          (if (or (not res) (= _str string))
            (setq res (list string))
            (reverse res)
            ) ;_ end of if
          ) ;_ end of lambda
        )
       )
      (t (list string))
      ) ;_ end of cond
    ) ;_ end of defun

  (setq file   "\\\\server\\библиотека\\test\\users.txt" ;; Путь к текстовому файлу
        handle (open file "r")
        ) ;_ end of setq
  (while (setq str (read-line handle))
    (setq lst
           (cons
             (mapcar (function cons) '("user" "domain" "name" "sex") (_kpblc-conv-string-to-list str ";"))
             lst
             ) ;_ end of cons
          ) ;_ end of setq
    ) ;_ end of while
  (close handle)
  (if (setq user (car (vl-remove-if-not
                        (function
                          (lambda (x)
                            (and (= (strcase (getenv "username")) (strcase (cdr (assoc "user" x))))
                                 (= (strcase (getenv "userdomain")) (strcase (cdr (assoc "domain" x))))
                                 ) ;_ end of and
                            ) ;_ end of lambda
                          ) ;_ end of function
                        lst
                        ) ;_ end of vl-remove-if-not
                      ) ;_ end of car
            ) ;_ end of setq
    (alert (strcat "Уважаем"
                   (if (member (strcase (cdr (assoc "sex" user))) '("M" "М"))
                     "ый"
                     "ая"
                     ) ;_ end of if
                   " "
                   (cdr (assoc "name" user))
                   "!"
                   "\n\nПоздравляем с праздником!"
                   ) ;_ end of strcat
           ) ;_ end of alert
    ) ;_ end of if
  (princ)
  ) ;_ end of defun

Слегка пообщавшись с пользователями, решили добавить вариант “данных о пользователе нет”:

Персонализированное поздравление, часть 3 (с учетом отсутствия данных)
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
(defun c:conrg4 (/ _kpblc-conv-string-to-list handle file lst str user)

  (defun _kpblc-conv-string-to-list (string separator / i)
                                    ;|
*    Функция разбора строки. Возвращает список либо точечную пару.
*    Параметры вызова:
*  string    разбираемая строка
*  separator  символ, используемый в качестве разделителя частей
*    Примеры вызова:
(_kpblc-conv-string-to-list "1;2;3;4;5;6" ";")  ;'(1 2 3 4 5 6)
(_kpblc-conv-string-to-list "1;2" ";")    ;'(1 2)
*    За основу взяты уроки Евгения Елпанова по рекурсиям
|;
    (cond
      ((= string "") nil)
      ((vl-string-search separator string)
       ((lambda (/ pos res)
          (while (setq pos (vl-string-search separator string))
            (setq res    (cons (substr string 1 pos) res)
                  string (substr string (+ (strlen separator) 1 pos))
                  ) ;_ end of setq
            ) ;_ end of while
          (reverse (cons string res))
          ) ;_ end of lambda
        )
       )
      ((wcmatch (strcase string) (strcat "*" (strcase separator) "*"))
       ((lambda (/ pos res _str prev)
          (setq pos  1
                prev 1
                _str (substr string pos)
                ) ;_ end of setq
          (while (<= pos (1+ (- (strlen string) (strlen separator))))
            (if ;; (wcmatch (strcase (substr string pos)) (strcase (strcat separator "*")))
                (wcmatch (strcase (substr string pos (strlen separator))) (strcase separator))
              (setq res    (cons (substr string 1 (1- pos)) res)
                    string (substr string (+ (strlen separator) pos))
                    pos    0
                    ) ;_ end of setq
              ) ;_ end of if
            (setq pos (1+ pos))
            ) ;_ end of while
          (if (< (strlen string) (strlen separator))
            (setq res (cons string res))
            ) ;_ end of if
          (if (or (not res) (= _str string))
            (setq res (list string))
            (reverse res)
            ) ;_ end of if
          ) ;_ end of lambda
        )
       )
      (t (list string))
      ) ;_ end of cond
    ) ;_ end of defun

  (setq file   "\\\\server\\библиотека\\test\\users.txt" ;; Путь к текстовому файлу
        handle (open file "r")
        ) ;_ end of setq
  (while (setq str (read-line handle))
    (setq lst
           (cons
             (mapcar (function cons) '("user" "domain" "name" "sex") (_kpblc-conv-string-to-list str ";"))
             lst
             ) ;_ end of cons
          ) ;_ end of setq
    ) ;_ end of while
  (close handle)
  (if (setq user (car (vl-remove-if-not
                        (function
                          (lambda (x)
                            (and (= (strcase (getenv "username")) (strcase (cdr (assoc "user" x))))
                                 (= (strcase (getenv "userdomain")) (strcase (cdr (assoc "domain" x))))
                                 ) ;_ end of and
                            ) ;_ end of lambda
                          ) ;_ end of function
                        lst
                        ) ;_ end of vl-remove-if-not
                      ) ;_ end of car
            ) ;_ end of setq
    (alert (strcat "Уважаем"
                   (if (member (strcase (cdr (assoc "sex" user))) '("M" "М"))
                     "ый"
                     "ая"
                     ) ;_ end of if
                   " "
                   (cdr (assoc "name" user))
                   "!"
                   "\n\nПоздравляем с праздником!"
                   ) ;_ end of strcat
           ) ;_ end of alert
    (alert "Принимайте поздравления!")
    ) ;_ end of if
  (princ)
  ) ;_ end of defun

Если файл конфигурировать лениво или долго, поступим так: прямо внутрь кода загоняем возможные тексты поздравлений и вызываем:

Перечень поздравлений
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
(defun c:conrg5 (/ lst _dwgru-random)

  (defun _dwgru-random (/ modulus multiplier increment)
;;; Генерирует случайное вещественное число в диапазоне от 0 до 1
;;; Используется глобальная переменная *DWGRU_SEED*
    (if (not *dwgru_seed*)
      (setq *dwgru_seed* (getvar "DATE"))
      ) ;_ end of if
    (setq modulus 65536
          multiplier
           25173
          increment 13849
          *dwgru_seed*
           (rem (+ (* multiplier *dwgru_seed*) increment) modulus)
          ) ;_ end of setq
    (/ *dwgru_seed* modulus)
    ) ;_ end of defun

  (setq lst '("Поздравление 1"
              "Поздравление 2"
              "Поздравление 3"
              "Поздравление 4"
              )
        ) ;_ end of setq
  (alert (nth (fix (* (length lst) (_dwgru-random))) lst))
  (princ)
  ) ;_ end of defun

Если нарисовать такую команду да еще на нее и кнопочку дать, пользователи могут запросто забыть про работу и начать играться. Поэтому сделаем по-другому: во-первых, введем контроль по датам - команда должна срабатывать в последний рабочий день перед праздником (праздниками): Новый Год, 23 февраля, 8 Марта… Сделаем так, чтобы код не давал запускаться в нерабочий день и если до праздника меньше 4 календарных дней. А заодно сделаем так, чтобы он запускался только раз в сутки :)

Внимание! Коды, которые будут показаны ниже, работают таким образом, что больше одного раза в сутки срабатывать не будут! Если это надо снять, то сообщи

Поздравления в списке, запуск раз в сутки
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
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
(defun congr6 (/ curday date _kpblc-conv-string-to-list _kpblc-conv-date-to-day _dwgru-random reghive regkey)

  (setq reghive "HKEY_CURRENT_USER\\Software\\kpblc\\AutodeskCommunity"
        regkey  "LastStart"
        lst     '("Поздравление 1"
                  "Поздравление 2"
                  "Поздравление 3"
                  "Поздравление 4"
                  )
        ) ;_ end of setq


  (defun _dwgru-random (/ modulus multiplier increment)
;;; Генерирует случайное вещественное число в диапазоне от 0 до 1
;;; Используется глобальная переменная *DWGRU_SEED*
    (if (not *dwgru_seed*)
      (setq *dwgru_seed* (getvar "DATE"))
      ) ;_ end of if
    (setq modulus 65536
          multiplier
           25173
          increment 13849
          *dwgru_seed*
           (rem (+ (* multiplier *dwgru_seed*) increment) modulus)
          ) ;_ end of setq
    (/ *dwgru_seed* modulus)
    ) ;_ end of defun

  (defun _kpblc-conv-string-to-list (string separator / i)
                                    ;|
*    Функция разбора строки. Возвращает список либо точечную пару.
*    Параметры вызова:
*  string    разбираемая строка
*  separator  символ, используемый в качестве разделителя частей
*    Примеры вызова:
(_kpblc-conv-string-to-list "1;2;3;4;5;6" ";")  ;'(1 2 3 4 5 6)
(_kpblc-conv-string-to-list "1;2" ";")    ;'(1 2)
*    За основу взяты уроки Евгения Елпанова по рекурсиям
|;
    (cond
      ((= string "") nil)
      ((vl-string-search separator string)
       ((lambda (/ pos res)
          (while (setq pos (vl-string-search separator string))
            (setq res    (cons (substr string 1 pos) res)
                  string (substr string (+ (strlen separator) 1 pos))
                  ) ;_ end of setq
            ) ;_ end of while
          (reverse (cons string res))
          ) ;_ end of lambda
        )
       )
      ((wcmatch (strcase string) (strcat "*" (strcase separator) "*"))
       ((lambda (/ pos res _str prev)
          (setq pos  1
                prev 1
                _str (substr string pos)
                ) ;_ end of setq
          (while (<= pos (1+ (- (strlen string) (strlen separator))))
            (if ;; (wcmatch (strcase (substr string pos)) (strcase (strcat separator "*")))
                (wcmatch (strcase (substr string pos (strlen separator))) (strcase separator))
              (setq res    (cons (substr string 1 (1- pos)) res)
                    string (substr string (+ (strlen separator) pos))
                    pos    0
                    ) ;_ end of setq
              ) ;_ end of if
            (setq pos (1+ pos))
            ) ;_ end of while
          (if (< (strlen string) (strlen separator))
            (setq res (cons string res))
            ) ;_ end of if
          (if (or (not res) (= _str string))
            (setq res (list string))
            (reverse res)
            ) ;_ end of if
          ) ;_ end of lambda
        )
       )
      (t (list string))
      ) ;_ end of cond
    ) ;_ end of defun

  (defun _kpblc-conv-date-to-day (date / lst)
                                 ;|
*    Преобразование даты (в днях) в число от 01.01.1990 (пн)
*    Параметры вызова:
  date  обрабатываемая дата
    Возможные значения:
     string    ; Строка вида ГГГГММДД
     string    ; Строка вида ГГГГ.ММ.ДД
     string    ; Строка вида ГГММДД
     string    ; Строка вида ГГ.ММ.ДД
     integer  ; Число вида ГГГГММДД
     list    ; Список. Варианты:
       '(year month day)
       '(("year" . <year>) ("month" . <month>) ("day" . <day>))
|;
    (cond
      ((= (type date) 'str)
       (if (= (length (setq lst (_kpblc-conv-string-to-list date "."))) 1)
         (cond
           ((= (strlen date) 6)
            (_kpblc-conv-date-to-day
              (list (cons "year"
                          (+ (/ (- (fix (getvar "cdate")) (rem (fix (getvar "cdate")) 1e6)) 1e4)
                             (atoi (substr date 1 2))
                             ) ;_ end of +
                          ) ;_ end of cons
                    (cons "month" (atoi (substr date 3 2)))
                    (cons "day" (atoi (substr date 5 2)))
                    ) ;_ end of list
              ) ;_ end of _kpblc-conv-date-to-day
            )
           ((= (strlen date) 8)
            (_kpblc-conv-date-to-day
              (list (cons "year" (atoi (substr date 1 4)))
                    (cons "month" (atoi (substr date 5 2)))
                    (cons "day" (atoi (substr date 7 2)))
                    ) ;_ end of list
              ) ;_ end of _kpblc-conv-date-to-day
            )
           ) ;_ end of cond
         (_kpblc-conv-date-to-day
           (list (cons "year" (car lst))
                 (cons "month"
                       (cond ((cadr lst))
                             (t 1)
                             ) ;_ end of cond
                       ) ;_ end of cons
                 (cons "day"
                       (cond ((caddr lst))
                             (t 1)
                             ) ;_ end of cond
                       ) ;_ end of cons
                 ) ;_ end of list
           ) ;_ end of _kpblc-conv-date-to-day
         ) ;_ end of if
       )
      ((= (type date) 'int)
       (_kpblc-conv-date-to-day (vl-princ-to-string date))
       )
      ((and (listp date)
            (not (listp (car date)))
            ) ;_ end of and
       (_kpblc-conv-date-to-day
         (list (cons "year" (car date)) (cons "month" (cadr date)) (cons "day" (caddr date)))
         ) ;_ end of _kpblc-conv-date-to-day
       )
      ((and (listp date)
            (listp (car date))
            ) ;_ end of and
       ((lambda (/ start_year fun_is-year-leap _d y)
          (defun fun_is-year-leap (yy / tt)
            (setq tt (/ yy 4.0))
            (if (equal (- tt (fix tt)) 0.0 0.00001)
              (progn
                ;; Divisible by 4, test for 100 year exception
                (setq tt (/ yy 100.0))
                (if (equal (- tt (fix tt)) 0.0 0.00001)
                  (progn
                    ;; Divisible by 100, test for 400 year double exception
                    (setq tt (/ yy 400.0))
                    (if (equal (- tt (fix tt)) 0.0 0.00001)
                      t ;divisible by 400 is leap year
                      nil ;divisible by 100 is not leap year
                      ) ;_ end of if
                    ) ;_ end of progn
                  t ;divisible by 4 but not 100, is leap year
                  ) ;_ end of if
                ) ;_ end of progn
              nil
              ) ;not divisible by 4, not a leap year
            ) ;_ end of defun
          (setq start_year 2012
                _d         (if (fun_is-year-leap
                                 (setq y (cond ((cdr (assoc "year" date)))
                                               (t start_year)
                                               ) ;_ end of cond
                                       ) ;_ end of setq
                                 ) ;_ end of fun_is-year-leap
                             '(0 31 60 91 121 152 182 213 244 274 305 335)
                             '(0 31 59 90 120 151 181 212 243 273 304 334)
                             ) ;_ end of if
                ) ;_ end of setq
          (+ (* (- y start_year) 365)
             ;; (if (= 0 (rem (1- y) 4)) 1 0)
             (1+ (/ (- y start_year) 4))
             ;; (/ (1- y) 4)
          ; 29 февраля всех весокосных лет кроме текущего
             (nth (1- (cond ((cdr (assoc "month" date)))
                            (t 1)
                            ) ;_ end of cond
                      ) ;_ end of 1-
                  _d
                  ) ; дней с начала года до начала месяца
             (cond ((cdr (assoc "day" date)))
                   (t 1)
                   ) ; число
             ) ;_ end of +
          ) ;_ end of lambda
        )
       )
      ) ;_ end of cond
    ) ;_ end of defun

  (if (and (<= (setq curday (1- (rem (_kpblc-conv-date-to-day (itoa (setq date (fix (getvar "cdate"))))) 7)))
               5
               ) ;_ end of <=
           ;; День до пятницы включительно
           (apply (function or)
                  (mapcar
                    (function
                      (lambda (x)
                        ;; Разница между датой праздница и текущей меньше 4 дней.
                        (< (- (atoi (strcat (itoa (fix (/ date 10000))) x)) date) 4)
                        ) ;_ end of lambda
                      ) ;_ end of function
                    '("1231"
                      "0223"
                      "0308"
                      )
                    ) ;_ end of mapcar
                  ) ;_ end of apply
           (or (not (vl-registry-read reghive regkey))
               (/= date (vl-registry-read reghive regkey))
               ) ;_ end of or
           ) ;_ end of and
    (progn
      (vl-registry-write reghive regkey date)
      (alert (nth (fix (* (length lst) (_dwgru-random))) lst))
      ) ;_ end of progn
    ) ;_ end of if
  (princ)
  ) ;_ end of defun

Теперь будет достаточно добавить строку (conrg6) в любой автозагружаемый лисп - и viola, поздравления будут только раз в день, и случайным образом.

Попробуем теперь сделать так, чтобы ACAD вываливал html-страницу с поздравительной картинкой.

Сначала нарисуем код, который будет выводить картинку (jpg / png / gif), которая просто хранится на сервере в определенном каталоге (я для примера взял каталог c:\congrat):

Поздравления картинкой, запуск раз в сутки
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
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
(defun congr7 (/ curday date _kpblc-conv-string-to-list _kpblc-conv-date-to-day _dwgru-random reghive regkey path)

  (setq reghive "HKEY_CURRENT_USER\\Software\\kpblc\\AutodeskCommunity"
      regkey  "LastStart"
      lst   '("Поздравление 1"
                "Поздравление 2"
                "Поздравление 3"
                "Поздравление 4"
                )
      path  "c:\\congrat"
      ) ;_ end of setq

  (defun _dwgru-random (/ modulus multiplier increment)
;;; Генерирует случайное вещественное число в диапазоне от 0 до 1
;;; Используется глобальная переменная *DWGRU_SEED*
  (if (not *dwgru_seed*)
    (setq *dwgru_seed* (getvar "DATE"))
    ) ;_ end of if
  (setq modulus 65536
        multiplier
        25173
        increment 13849
        *dwgru_seed*
        (rem (+ (* multiplier *dwgru_seed*) increment) modulus)
        ) ;_ end of setq
  (/ *dwgru_seed* modulus)
  ) ;_ end of defun

  (defun _kpblc-conv-string-to-list (string separator / i)
                                  ;|
* Функция разбора строки. Возвращает список либо точечную пару.
* Параметры вызова:
*  string разбираемая строка
*  separator  символ, используемый в качестве разделителя частей
* Примеры вызова:
(_kpblc-conv-string-to-list "1;2;3;4;5;6" ";")  ;'(1 2 3 4 5 6)
(_kpblc-conv-string-to-list "1;2" ";")  ;'(1 2)
* За основу взяты уроки Евгения Елпанова по рекурсиям
|;
  (cond
    ((= string "") nil)
    ((vl-string-search separator string)
    ((lambda (/ pos res)
        (while (setq pos (vl-string-search separator string))
          (setq res (cons (substr string 1 pos) res)
                string (substr string (+ (strlen separator) 1 pos))
                ) ;_ end of setq
          ) ;_ end of while
        (reverse (cons string res))
        ) ;_ end of lambda
      )
    )
    ((wcmatch (strcase string) (strcat "*" (strcase separator) "*"))
    ((lambda (/ pos res _str prev)
        (setq pos  1
              prev 1
              _str (substr string pos)
              ) ;_ end of setq
        (while (<= pos (1+ (- (strlen string) (strlen separator))))
          (if ;; (wcmatch (strcase (substr string pos)) (strcase (strcat separator "*")))
              (wcmatch (strcase (substr string pos (strlen separator))) (strcase separator))
            (setq res (cons (substr string 1 (1- pos)) res)
                  string (substr string (+ (strlen separator) pos))
                  pos 0
                  ) ;_ end of setq
            ) ;_ end of if
          (setq pos (1+ pos))
          ) ;_ end of while
        (if (< (strlen string) (strlen separator))
          (setq res (cons string res))
          ) ;_ end of if
        (if (or (not res) (= _str string))
          (setq res (list string))
          (reverse res)
          ) ;_ end of if
        ) ;_ end of lambda
      )
    )
    (t (list string))
    ) ;_ end of cond
  ) ;_ end of defun

  (defun _kpblc-conv-date-to-day (date / lst)
                              ;|
* Преобразование даты (в днях) в число от 01.01.1990 (пн)
* Параметры вызова:
  date  обрабатываемая дата
  Возможные значения:
  string  ; Строка вида ГГГГММДД
  string  ; Строка вида ГГГГ.ММ.ДД
  string  ; Строка вида ГГММДД
  string  ; Строка вида ГГ.ММ.ДД
  integer  ; Число вида ГГГГММДД
  list  ; Список. Варианты:
    '(year month day)
    '(("year" . <year>) ("month" . <month>) ("day" . <day>))
|;
  (cond
    ((= (type date) 'str)
    (if (= (length (setq lst (_kpblc-conv-string-to-list date "."))) 1)
      (cond
        ((= (strlen date) 6)
          (_kpblc-conv-date-to-day
            (list (cons "year"
                        (+ (/ (- (fix (getvar "cdate")) (rem (fix (getvar "cdate")) 1e6)) 1e4)
                          (atoi (substr date 1 2))
                          ) ;_ end of +
                        ) ;_ end of cons
                  (cons "month" (atoi (substr date 3 2)))
                  (cons "day" (atoi (substr date 5 2)))
                  ) ;_ end of list
            ) ;_ end of _kpblc-conv-date-to-day
          )
        ((= (strlen date) 8)
          (_kpblc-conv-date-to-day
            (list (cons "year" (atoi (substr date 1 4)))
                  (cons "month" (atoi (substr date 5 2)))
                  (cons "day" (atoi (substr date 7 2)))
                  ) ;_ end of list
            ) ;_ end of _kpblc-conv-date-to-day
          )
        ) ;_ end of cond
      (_kpblc-conv-date-to-day
        (list (cons "year" (car lst))
              (cons "month"
                    (cond ((cadr lst))
                          (t 1)
                          ) ;_ end of cond
                    ) ;_ end of cons
              (cons "day"
                    (cond ((caddr lst))
                          (t 1)
                          ) ;_ end of cond
                    ) ;_ end of cons
              ) ;_ end of list
        ) ;_ end of _kpblc-conv-date-to-day
      ) ;_ end of if
    )
    ((= (type date) 'int)
    (_kpblc-conv-date-to-day (vl-princ-to-string date))
    )
    ((and (listp date)
          (not (listp (car date)))
          ) ;_ end of and
    (_kpblc-conv-date-to-day
      (list (cons "year" (car date)) (cons "month" (cadr date)) (cons "day" (caddr date)))
      ) ;_ end of _kpblc-conv-date-to-day
    )
    ((and (listp date)
          (listp (car date))
          ) ;_ end of and
    ((lambda (/ start_year fun_is-year-leap _d y)
        (defun fun_is-year-leap (yy / tt)
          (setq tt (/ yy 4.0))
          (if (equal (- tt (fix tt)) 0.0 0.00001)
            (progn
              ;; Divisible by 4, test for 100 year exception
              (setq tt (/ yy 100.0))
              (if (equal (- tt (fix tt)) 0.0 0.00001)
                (progn
                  ;; Divisible by 100, test for 400 year double exception
                  (setq tt (/ yy 400.0))
                  (if (equal (- tt (fix tt)) 0.0 0.00001)
                    t ;divisible by 400 is leap year
                    nil ;divisible by 100 is not leap year
                    ) ;_ end of if
                  ) ;_ end of progn
                t ;divisible by 4 but not 100, is leap year
                ) ;_ end of if
              ) ;_ end of progn
            nil
            ) ;not divisible by 4, not a leap year
          ) ;_ end of defun
        (setq start_year 2012
              _d      (if (fun_is-year-leap
                              (setq y (cond ((cdr (assoc "year" date)))
                                            (t start_year)
                                            ) ;_ end of cond
                                    ) ;_ end of setq
                              ) ;_ end of fun_is-year-leap
                          '(0 31 60 91 121 152 182 213 244 274 305 335)
                          '(0 31 59 90 120 151 181 212 243 273 304 334)
                          ) ;_ end of if
              ) ;_ end of setq
        (+ (* (- y start_year) 365)
          ;; (if (= 0 (rem (1- y) 4)) 1 0)
          (1+ (/ (- y start_year) 4))
          ;; (/ (1- y) 4)
        ; 29 февраля всех весокосных лет кроме текущего
          (nth (1- (cond ((cdr (assoc "month" date)))
                          (t 1)
                          ) ;_ end of cond
                    ) ;_ end of 1-
                _d
                ) ; дней с начала года до начала месяца
          (cond ((cdr (assoc "day" date)))
                (t 1)
                ) ; число
          ) ;_ end of +
        ) ;_ end of lambda
      )
    )
    ) ;_ end of cond
  ) ;_ end of defun

  (if (and (<= (setq curday (1- (rem (_kpblc-conv-date-to-day (itoa (setq date (fix (getvar "cdate"))))) 7)))
            5
            ) ;_ end of <=
        ;; День до пятницы включительно
        (apply (function or)
                (mapcar
                  (function
                    (lambda (x)
                      ;; Разница между датой праздница и текущей меньше 4 дней.
                      (< (- (atoi (strcat (itoa (fix (/ date 10000))) x)) date) 4)
                      ) ;_ end of lambda
                    ) ;_ end of function
                  '("1231"
                    "0223"
                    "0308"
                    )
                  ) ;_ end of mapcar
                ) ;_ end of apply
        (or (not (vl-registry-read reghive regkey))
            (/= date (vl-registry-read reghive regkey))
            ) ;_ end of or
        ) ;_ end of and
  (progn
    (vl-registry-write reghive regkey date)
    (alert (nth (fix (* (length lst) (_dwgru-random))) lst))

    ;; Выводим окно
    (vl-catch-all-apply
      (function
        (lambda (/ files file objiea doc body)
          (if (setq files (vl-remove-if
                            (function
                              (lambda (x)
                                (or (member x '("." ".."))
                                    (vl-file-directory-p x)
                                    (not (vl-filename-extension x))
                                    (not (vl-filename-base x))
                                    (not (wcmatch (strcase (vl-filename-extension x)) ".JPG,.PNG,.GIF"))
                                    ) ;_ end of or
                                ) ;_ end of LAMBDA
                              ) ;_ end of function
                            (vl-directory-files path "*.*" 1)
                            ) ;_ end of vl-remove-if
                    ) ;_ end of setq
            (progn (setq file   (nth (fix (* (length files) (_dwgru-random))) files)
                        objiea (vlax-create-object "InternetExplorer.Application")
                        ) ;_ end of setq
                  (vlax-put-property objiea "Toolbar" 0)
                  (vlax-put-property objiea "StatusBar" 0)
                  (vlax-put-property objiea "Visible" :vlax-true)
                  (vlax-invoke
                    objiea
                    "Navigate"
                    (strcat (vl-string-right-trim "\" path)
                            "\"
                            file
                            ) ;_ end of strcat
                    ) ;_ end of vlax-invoke
                  (while (/= 4 (vlax-get-property objiea "ReadyState"))
                    (princ ".")
                    ) ;_ end of while
                  (setq
                    doc  (vlax-get-property objiea "Document")
                    body (vlax-get-property doc "Body")
                    ) ;_ end of setq
                  ;; И записываем в реестр соответствующие данные
                  ;; (vl-registry-write hive key (rtos date 2 4))
                  (command "_.delay" 10000)
                  ) ;_ end of progn
            ) ;_ end of if
          ) ;_ end of lambda
        ) ;_ end of function
      ) ;_ end of vl-catch-all-apply

    ) ;_ end of progn
  ) ;_ end of if
  (princ)
  ) ;_ end of defun

Но возникает вопрос: а, может, стоит сделать так, чтобы создать подкаталоги, например, “0223” (февраль 23), “0308” (март 8) и тому подобное? И тогда уже делать подкаталоги картинок, чтобы на 23 народ получал танчики и девушек в форме, а на 8 марта - котят и цветы?
Давайте попробуем ;)

Поздравления с картинкой, раз в сутки, автоматический учет дат поздравлений
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
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
(defun congr8 (/ curday date _kpblc-conv-string-to-list _kpblc-conv-date-to-day _dwgru-random reghive regkey path subpath)

  (setq reghive "HKEY_CURRENT_USER\\Software\\kpblc\\AutodeskCommunity"
      regkey  "LastStart"
      lst   '("Поздравление 1"
                "Поздравление 2"
                "Поздравление 3"
                "Поздравление 4"
                )
      path  "c:\\congrat"
      ) ;_ end of setq

  (defun _dwgru-random (/ modulus multiplier increment)
;;; Генерирует случайное вещественное число в диапазоне от 0 до 1
;;; Используется глобальная переменная *DWGRU_SEED*
  (if (not *dwgru_seed*)
    (setq *dwgru_seed* (getvar "DATE"))
    ) ;_ end of if
  (setq modulus 65536
        multiplier
        25173
        increment 13849
        *dwgru_seed*
        (rem (+ (* multiplier *dwgru_seed*) increment) modulus)
        ) ;_ end of setq
  (/ *dwgru_seed* modulus)
  ) ;_ end of defun

  (defun _kpblc-conv-string-to-list (string separator / i)
                                  ;|
* Функция разбора строки. Возвращает список либо точечную пару.
* Параметры вызова:
*  string разбираемая строка
*  separator  символ, используемый в качестве разделителя частей
* Примеры вызова:
(_kpblc-conv-string-to-list "1;2;3;4;5;6" ";")  ;'(1 2 3 4 5 6)
(_kpblc-conv-string-to-list "1;2" ";")  ;'(1 2)
* За основу взяты уроки Евгения Елпанова по рекурсиям
|;
  (cond
    ((= string "") nil)
    ((vl-string-search separator string)
    ((lambda (/ pos res)
        (while (setq pos (vl-string-search separator string))
          (setq res (cons (substr string 1 pos) res)
                string (substr string (+ (strlen separator) 1 pos))
                ) ;_ end of setq
          ) ;_ end of while
        (reverse (cons string res))
        ) ;_ end of lambda
      )
    )
    ((wcmatch (strcase string) (strcat "*" (strcase separator) "*"))
    ((lambda (/ pos res _str prev)
        (setq pos  1
              prev 1
              _str (substr string pos)
              ) ;_ end of setq
        (while (<= pos (1+ (- (strlen string) (strlen separator))))
          (if ;; (wcmatch (strcase (substr string pos)) (strcase (strcat separator "*")))
              (wcmatch (strcase (substr string pos (strlen separator))) (strcase separator))
            (setq res (cons (substr string 1 (1- pos)) res)
                  string (substr string (+ (strlen separator) pos))
                  pos 0
                  ) ;_ end of setq
            ) ;_ end of if
          (setq pos (1+ pos))
          ) ;_ end of while
        (if (< (strlen string) (strlen separator))
          (setq res (cons string res))
          ) ;_ end of if
        (if (or (not res) (= _str string))
          (setq res (list string))
          (reverse res)
          ) ;_ end of if
        ) ;_ end of lambda
      )
    )
    (t (list string))
    ) ;_ end of cond
  ) ;_ end of defun

  (defun _kpblc-conv-date-to-day (date / lst)
                              ;|
* Преобразование даты (в днях) в число от 01.01.1990 (пн)
* Параметры вызова:
  date  обрабатываемая дата
  Возможные значения:
  string  ; Строка вида ГГГГММДД
  string  ; Строка вида ГГГГ.ММ.ДД
  string  ; Строка вида ГГММДД
  string  ; Строка вида ГГ.ММ.ДД
  integer  ; Число вида ГГГГММДД
  list  ; Список. Варианты:
    '(year month day)
    '(("year" . <year>) ("month" . <month>) ("day" . <day>))
|;
  (cond
    ((= (type date) 'str)
    (if (= (length (setq lst (_kpblc-conv-string-to-list date "."))) 1)
      (cond
        ((= (strlen date) 6)
          (_kpblc-conv-date-to-day
            (list (cons "year"
                        (+ (/ (- (fix (getvar "cdate")) (rem (fix (getvar "cdate")) 1e6)) 1e4)
                          (atoi (substr date 1 2))
                          ) ;_ end of +
                        ) ;_ end of cons
                  (cons "month" (atoi (substr date 3 2)))
                  (cons "day" (atoi (substr date 5 2)))
                  ) ;_ end of list
            ) ;_ end of _kpblc-conv-date-to-day
          )
        ((= (strlen date) 8)
          (_kpblc-conv-date-to-day
            (list (cons "year" (atoi (substr date 1 4)))
                  (cons "month" (atoi (substr date 5 2)))
                  (cons "day" (atoi (substr date 7 2)))
                  ) ;_ end of list
            ) ;_ end of _kpblc-conv-date-to-day
          )
        ) ;_ end of cond
      (_kpblc-conv-date-to-day
        (list (cons "year" (car lst))
              (cons "month"
                    (cond ((cadr lst))
                          (t 1)
                          ) ;_ end of cond
                    ) ;_ end of cons
              (cons "day"
                    (cond ((caddr lst))
                          (t 1)
                          ) ;_ end of cond
                    ) ;_ end of cons
              ) ;_ end of list
        ) ;_ end of _kpblc-conv-date-to-day
      ) ;_ end of if
    )
    ((= (type date) 'int)
    (_kpblc-conv-date-to-day (vl-princ-to-string date))
    )
    ((and (listp date)
          (not (listp (car date)))
          ) ;_ end of and
    (_kpblc-conv-date-to-day
      (list (cons "year" (car date)) (cons "month" (cadr date)) (cons "day" (caddr date)))
      ) ;_ end of _kpblc-conv-date-to-day
    )
    ((and (listp date)
          (listp (car date))
          ) ;_ end of and
    ((lambda (/ start_year fun_is-year-leap _d y)
        (defun fun_is-year-leap (yy / tt)
          (setq tt (/ yy 4.0))
          (if (equal (- tt (fix tt)) 0.0 0.00001)
            (progn
              ;; Divisible by 4, test for 100 year exception
              (setq tt (/ yy 100.0))
              (if (equal (- tt (fix tt)) 0.0 0.00001)
                (progn
                  ;; Divisible by 100, test for 400 year double exception
                  (setq tt (/ yy 400.0))
                  (if (equal (- tt (fix tt)) 0.0 0.00001)
                    t ;divisible by 400 is leap year
                    nil ;divisible by 100 is not leap year
                    ) ;_ end of if
                  ) ;_ end of progn
                t ;divisible by 4 but not 100, is leap year
                ) ;_ end of if
              ) ;_ end of progn
            nil
            ) ;not divisible by 4, not a leap year
          ) ;_ end of defun
        (setq start_year 2012
              _d      (if (fun_is-year-leap
                              (setq y (cond ((cdr (assoc "year" date)))
                                            (t start_year)
                                            ) ;_ end of cond
                                    ) ;_ end of setq
                              ) ;_ end of fun_is-year-leap
                          '(0 31 60 91 121 152 182 213 244 274 305 335)
                          '(0 31 59 90 120 151 181 212 243 273 304 334)
                          ) ;_ end of if
              ) ;_ end of setq
        (+ (* (- y start_year) 365)
          ;; (if (= 0 (rem (1- y) 4)) 1 0)
          (1+ (/ (- y start_year) 4))
          ;; (/ (1- y) 4)
        ; 29 февраля всех весокосных лет кроме текущего
          (nth (1- (cond ((cdr (assoc "month" date)))
                          (t 1)
                          ) ;_ end of cond
                    ) ;_ end of 1-
                _d
                ) ; дней с начала года до начала месяца
          (cond ((cdr (assoc "day" date)))
                (t 1)
                ) ; число
          ) ;_ end of +
        ) ;_ end of lambda
      )
    )
    ) ;_ end of cond
  ) ;_ end of defun

  (if (and (<= (setq curday (1- (rem (_kpblc-conv-date-to-day (itoa (setq date (fix (getvar "cdate"))))) 7)))
            5
            ) ;_ end of <=
        ;; День до пятницы включительно
        (apply (function or)
                (mapcar
                  (function
                    (lambda (x)
                      ;; Разница между датой праздница и текущей меньше 4 дней.
                      (< (- (atoi (strcat (itoa (fix (/ date 10000))) x)) date) 4)
                      ) ;_ end of lambda
                    ) ;_ end of function
                  '("1231"
                    "0223"
                    "0308"
                    )
                  ) ;_ end of mapcar
                ) ;_ end of apply
        (setq subpath (car (vl-sort (vl-remove-if-not  (function (LAMBDA(x) (WCMATCH x "####"))) (VL-DIRECTORY-FILES path "*.*" -1)) (function (LAMBDA(a b)
(< (atoi (strcat (itoa (fix (/ date 10000))) a))(atoi (strcat (itoa (fix (/ date 10000))) b))))))))
        (or (not (vl-registry-read reghive regkey))
            (/= date (vl-registry-read reghive regkey))
            ) ;_ end of or
        ) ;_ end of and
  (progn
    (vl-registry-write reghive regkey date)
    (alert (nth (fix (* (length lst) (_dwgru-random))) lst))

    ;; Выводим окно
    (vl-catch-all-apply
      (function
        (lambda (/ files file objiea doc body)
          (if (setq files (vl-remove-if
                            (function
                              (lambda (x)
                                (or (member x '("." ".."))
                                    (vl-file-directory-p x)
                                    (not (vl-filename-extension x))
                                    (not (vl-filename-base x))
                                    (not (wcmatch (strcase (vl-filename-extension x)) ".JPG,.PNG,.GIF"))
                                    ) ;_ end of or
                                ) ;_ end of LAMBDA
                              ) ;_ end of function
                            (vl-directory-files (strcat (VL-STRING-RIGHT-TRIM "\" path)"\" subpath) "*.*" 1)
                            ) ;_ end of vl-remove-if
                    ) ;_ end of setq
            (progn (setq file   (nth (fix (* (length files) (_dwgru-random))) files)
                        objiea (vlax-create-object "InternetExplorer.Application")
                        ) ;_ end of setq
                  (vlax-put-property objiea "Toolbar" 0)
                  (vlax-put-property objiea "StatusBar" 0)
                  (vlax-put-property objiea "Visible" :vlax-true)
                  (vlax-invoke
                    objiea
                    "Navigate"
                    (strcat (VL-STRING-RIGHT-TRIM "\" path)"\" subpath
                            "\"
                            file
                            ) ;_ end of strcat
                    ) ;_ end of vlax-invoke
                  (while (/= 4 (vlax-get-property objiea "ReadyState"))
                    (princ ".")
                    ) ;_ end of while
                  (setq
                    doc  (vlax-get-property objiea "Document")
                    body (vlax-get-property doc "Body")
                    ) ;_ end of setq
                  ;; И записываем в реестр соответствующие данные
                  ;; (vl-registry-write hive key (rtos date 2 4))
                  (command "_.delay" 10000)
                  ) ;_ end of progn
            ) ;_ end of if
          ) ;_ end of lambda
        ) ;_ end of function
      ) ;_ end of vl-catch-all-apply

    ) ;_ end of progn
  ) ;_ end of if
  (princ)
  ) ;_ end of defun

Теперь, вместо (congr6) вбиваем (congr8) и наслаждаемся и текстовым поздравлением, и - отдельно - картинкой, показываемой в окне Internet Explorer’a.

P.S. Если надо сделать код, чтобы он срабатывал не "раз в сутки", а "при каждом новом запуске AutoCAD", сообщите - сделаем ;)

Совет дня, запуск один раз в сессии AutoCAD
Лена Талхина, основной заказчик кода, попросила добавить нечто типа “Совета дня”, и чтобы запускался только раз в каждой сессии AutoCAD.

Отлично, не вопрос. Правда, код, который здесь будет представлен, может использовать только уже оформленные html / htm – страницы. Если в наличии есть Help&Manual, то можно разработать справку и опубликовать ее в html-формате (я именно так и поступил). Теперь собственно код:

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
(defun tip-of-the-day (/ _dwgru-random vl-browsefiles-in-directory-nested path files file)
  ;; Путь к html-страницам с советами. Именно это надо менять в своих конкретных условиях:
  (setq path "\\\\server\\kulik\\HTML\")
  ;; Обратите внимание: слеши должны быть двойными!

  (defun _dwgru-random (/ modulus multiplier increment)
;;; Генерирует случайное вещественное число в диапазоне от 0 до 1
;;; Используется глобальная переменная *DWGRU_SEED*
    (if (not *dwgru_seed*)
      (setq *dwgru_seed* (getvar "DATE"))
      ) ;_ end of if
    (setq modulus 65536
          multiplier
           25173
          increment 13849
          *dwgru_seed*
           (rem (+ (* multiplier *dwgru_seed*) increment) modulus)
          ) ;_ end of setq
    (/ *dwgru_seed* modulus)
    ) ;_ end of defun

  (defun vl-browsefiles-in-directory-nested (path mask)
                                            ;|
*    Функция возвращает список файлов указанной маски, находящихся в
* заданном каталоге
*    Параметры вызова:
  path  путь к корневому каталогу. nil недопустим
  mask  маска имени файла. nil или список недопустим
*    Примеры вызова:
(vl-browsefiles-in-directory-nested "c:\\documents" "*.dwg")
|;
    (apply
      (function append)
      (cons
        (if (vl-directory-files path mask)
          (mapcar
            (function (lambda (x)
                        (strcat (vl-string-right-trim "\" path) "\" x)
                        ) ;_ end of lambda
                      ) ;_ end of function
            (vl-directory-files path mask)
            ) ;_ end of mapcar
          ) ;_ if
        (mapcar (function
                  (lambda (x)
                    (vl-browsefiles-in-directory-nested
                      (strcat (vl-string-right-trim "\" path) "\" x)
                      mask
                      ) ;_ end of vl-browsefiles-in-directory-nested
                    ) ;_ end of lambda
                  ) ;_ end of function
                (vl-remove ".."
                           (vl-remove "." (vl-directory-files path nil -1))
                           ) ;_ end of vl-remove
                ) ;_ mapcar
        ) ;_ cons
      ) ;_ end of apply
    ) ;_ end of defun

  (if (not (vl-bb-ref '*kpblc-tip-of-the-day*))
    (progn
      (setq files (vl-remove-if
                    (function
                      (lambda (x)
                        (or (member x '("." ".."))
                            (vl-file-directory-p x)
                            (not (wcmatch (strcase (vl-filename-extension x)) ".HTM*"))
                            ) ;_ end of or
                        ) ;_ end of lambda
                      ) ;_ end of function
                    (vl-browsefiles-in-directory-nested path "*.*")
                    ) ;_ end of vl-remove-if
            file  (nth (fix (* (_dwgru-random) (length files))) files)
            ) ;_ end of setq
      (vla-launchbrowserdialog (vla-get-utility (vla-get-activedocument (vlax-get-acad-object)))
                               file
                               "Совет дня"
                               "Открыть"
                               file
                               ""
                               :vlax-false
                               ) ;_ end of vla-LaunchBrowserDialog
      (vl-bb-set '*kpblc-tip-of-the-day* t)
      ) ;_ end of progn
    ) ;_ end of if
  ) ;_ end of defun

(tip-of-the-day)

Добавлю: внося минимальные изменения в код, можно добиться и показа "совета дня", и "поздравления", и чего угодно - хоть в alert'e, хоть в окне MSIE, хоть еще как.

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



Комментарии

Есть 1 комментарий к “Поздравления с помощью AutoCAD”
  1. Кулик Алексей aka kpblc пишет:
    14 Февраль 2015 в 22:20

    Лен, так дальше допиливать? Есть идея хранить все советы в отдельном текстовом файле, а показывать чуть ли не обычный алерт со случайно выбранным текстом из этого файла. Практически повтор варианта №4 ("Перечень поздравлений"), но с хранением текста не в коде.

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


Я не робот.