Если клетки надоели

Если «клетки» надоели,
Если хочется «кружков»,
Если вы на самом деле,
Вдруг, устали от оков

Этой жизни беспросветной,
И не мил вам белый свет, -
Вот, друзья, вам всем приветный
Дар последних моих лет.

То ли «Аленький цветочек»,
То ли «Цветик-Семицвет»,
То ли бабушкин клубочек
Шерстяной, что краше нет.

То ль «болванок» разноцветных
Ряд разложенный меж слов,
То ль блинов от щедрот бедным,
Что напёк я для пиров.

Получите дивный Макрос
Всем на радость и красу! –
Вот такой мой ныне «ракурс»,
Вот такой «призыв в лесу».

.   .   .   .   .

Что-чегой-откуда взялось?
Я поведать не смогу.
Ну, да ладно. Где помялось,
Там разгладим на бегу…



P.S.

А вот и сам Макрос для VB Word. Держите!
Выполняете на новом чистом листе в режиме WEB-странички.
См.подробнее на Прозе.ру мою записку «Попробуйте вот это» от 01.10.2023.

Мною замечено, что при увеличении масштаба от 100% и выше Макрос теряет визуализацию. Надо просто подождать. Хотя не видно, как он рисует, но он рисует! После выхода из ожидания построение проявляется на листе само целиком и сразу всё. Но, это у меня так работает. У вас компы крутые. У вас и на 150% тормозить не будет.

Пользуйтесь! И меня вспоминайте.




20:15:00 10.01.2024          1EEDB5F5C0





Sub NewMacros101()
'
' NewMacros101 Макрос
' Макрос создан 07.01.2024 Mudman
'

Dim W As Integer  'Толщина линии
Dim D As Integer  'Тип линии
Dim Ds As Integer 'Тип линии резервный для сохранения

'Область рисования
Dim xn As Integer, xk As Integer, yn As Integer, yk As Integer

'Цвета линий
Dim a1 As Integer, b1 As Integer, c1 As Integer
Dim a2 As Integer, b2 As Integer, c2 As Integer 'Цвет фона
Dim a3 As Integer, b3 As Integer, c3 As Integer

'Резервные цвета для сохранения значений
Dim a4 As Integer, b4 As Integer, c4 As Integer
Dim a5 As Integer, b5 As Integer, c5 As Integer

'Рабочие координаты
Dim x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer

Dim xr2 As Double, yr2 As Double 'Координата конца вектора R
Dim xr1 As Double, yr1 As Double 'Координата центра окружности
Dim Alfa As Double    'Настоящий угол
Dim Ugol_N As Integer 'Угол в градусах (начальное значение)
Dim Ugol_K As Integer 'Угол в градусах (конечное значение)

'Инициализация
x1 = 0: y1 = 0: x2 = 0: y2 = 0
xr2 = 0: yr2 = 0: Alfa = 0
W = 1 'Толщина линии

'Область рисования
xn = 186 '86
xk = 374 '274
yn = 82  '57
yk = 297 '272

Dim Radius As Double 'Радиус окружности
Radius = (xk - xn) / 3

'Установить ГСЧ в произвольное состояние
Randomize Timer

'Цвета линий
a2 = Int(Rnd * 256): b2 = Int(Rnd * 256): c2 = Int(Rnd * 256) 'Цвет фона

'Фон WEB-страницы
ActiveDocument.Background.Fill.ForeColor.RGB = RGB(a2, b2, c2)
ActiveDocument.Background.Fill.Visible = msoTrue
ActiveDocument.Background.Fill.Solid

D = Int(Rnd * 7) + 1 'Тип линии
'Новые цвета
a1 = Int(Rnd * 256): b1 = Int(Rnd * 256): c1 = Int(Rnd * 256)
a3 = Int(Rnd * 256): b3 = Int(Rnd * 256): c3 = Int(Rnd * 256)

'Координата центра окружности
'точка 3  = xn + ((xk - xn) / 2), yn
xr1 = xn + ((xk - xn) / 2)
yr1 = yn
GoSub METKA

'Сохранить тип линии и цвета
Ds = D: a4 = a1: b4 = b1: c4 = c1: a5 = a3: b5 = b3: c5 = c3

D = Int(Rnd * 7) + 1 'Тип линии
'Новые цвета
a1 = Int(Rnd * 256): b1 = Int(Rnd * 256): c1 = Int(Rnd * 256)
a3 = Int(Rnd * 256): b3 = Int(Rnd * 256): c3 = Int(Rnd * 256)

'Координата центра окружности
'точка 6  = xn, yn + ((yk - yn) / 4)
xr1 = xn
yr1 = yn + ((yk - yn) / 4)
GoSub METKA

'Координата центра окружности
'точка 9  = xk, yn + ((yk - yn) / 4)
xr1 = xk
yr1 = yn + ((yk - yn) / 4)
GoSub METKA

D = Int(Rnd * 7) + 1 'Тип линии
'Новые цвета
a1 = Int(Rnd * 256): b1 = Int(Rnd * 256): c1 = Int(Rnd * 256)
a3 = Int(Rnd * 256): b3 = Int(Rnd * 256): c3 = Int(Rnd * 256)

'Координата центра окружности
'точка 12  = xn + ((xk - xn) / 2), yn + ((yk - yn) / 2)
xr1 = xn + ((xk - xn) / 2)
yr1 = yn + ((yk - yn) / 2)
GoSub METKA

D = Int(Rnd * 7) + 1 'Тип линии
'Новые цвета
a1 = Int(Rnd * 256): b1 = Int(Rnd * 256): c1 = Int(Rnd * 256)
a3 = Int(Rnd * 256): b3 = Int(Rnd * 256): c3 = Int(Rnd * 256)

'Координата центра окружности
'точка 15  = xn, yk - ((yk - yn) / 4)
xr1 = xn
yr1 = yk - ((yk - yn) / 4)
GoSub METKA

'Координата центра окружности
'точка 18  = xk, yk - ((yk - yn) / 4)
xr1 = xk
yr1 = yk - ((yk - yn) / 4)
GoSub METKA

'Восстановить тип линии и цвета
D = Ds: a1 = a4: b1 = b4: c1 = c4: a3 = a5: b3 = b5: c3 = c5

'Координата центра окружности
'точка 21  = xn + ((xk - xn) / 2), yk
xr1 = xn + ((xk - xn) / 2)
yr1 = yk
GoSub METKA
Exit Sub

'Подпрограммка типа GOSUB - RETURN
METKA:
Ugol_N = 0   ' 0
Ugol_K = 360 ' 180

x1 = Int(xr1): y1 = Int(yr1) 'Рабочие координаты центра окружности

For i% = Ugol_N To Ugol_K Step 3
Alfa = i%  'Угол от горизонтали (настоящий)
Alfa = Alfa * 3.141592653 / 180 'Перевод в радианы
xr2 = xr1 + Radius * Cos(Alfa)
yr2 = yr1 - Radius * Sin(Alfa)

x2 = Int(xr2): y2 = Int(yr2) 'Рабочие координаты конца вектора R

Set myDocument = ActiveDocument
With myDocument.Shapes.AddLine(x1, y1, x2, y2).Line
    .DashStyle = D
    .ForeColor.RGB = RGB(a1, b1, c1)
    .Weight = W
End With
i% = i% + 1
Alfa = i% 'Угол от горизонтали (настоящий)
Alfa = Alfa * 3.141592653 / 180 'Перевод в радианы
xr2 = xr1 + Radius * Cos(Alfa)
yr2 = yr1 - Radius * Sin(Alfa)

x2 = Int(xr2): y2 = Int(yr2) 'Рабочие координаты конца вектора R

With myDocument.Shapes.AddLine(x1, y1, x2, y2).Line
'    .DashStyle = D
    .ForeColor.RGB = RGB(a2, b2, c2)
    .Weight = W
End With
i% = i% + 1
Alfa = i% 'Угол от горизонтали (настоящий)
Alfa = Alfa * 3.141592653 / 180 'Перевод в радианы
xr2 = xr1 + Radius * Cos(Alfa)
yr2 = yr1 - Radius * Sin(Alfa)

x2 = Int(xr2): y2 = Int(yr2) 'Рабочие координаты конца вектора R

With myDocument.Shapes.AddLine(x1, y1, x2, y2).Line
'    .DashStyle = D
    .ForeColor.RGB = RGB(a3, b3, c3)
    .Weight = W
End With
i% = i% - 2

Next i%
Return

End Sub





P.P.S.

Кстати, тип линии для клеток тоже можно сделать переменным параметром, и определять его случайным образом при помощи генератора случайных чисел от 1 до 8. И тогда клетки будут иногда полосатыми.

Вот как, например, в Макросе с именем «NewMacros»:



Sub NewMacros()
Randomize Timer
Dim W As Single
W = 1 'толщина линии

Dim xn As Integer, xk As Integer, yn As Integer, yk As Integer
xn = 86  '100 '86
xk = 386 '340 '551
yn = 27  '40  '27
yk = 227 '200 '380

Dim a1 As Integer, a2 As Integer, a3 As Integer
Dim b1 As Integer, b2 As Integer, b3 As Integer
Dim c1 As Integer, c2 As Integer, c3 As Integer
Dim d1 As Integer, d2 As Integer, d3 As Integer

a1 = Int(Rnd * 256): a2 = Int(Rnd * 256): a3 = Int(Rnd * 256)
b1 = Int(Rnd * 256): b2 = Int(Rnd * 256): b3 = Int(Rnd * 256)
c1 = Int(Rnd * 256): c2 = Int(Rnd * 256): c3 = Int(Rnd * 256)

ActiveDocument.Background.Fill.ForeColor.RGB = RGB(a2, b2, c2)
ActiveDocument.Background.Fill.Visible = msoTrue
ActiveDocument.Background.Fill.Solid

'Средний луч
a2 = Int(Rnd * 256): b2 = Int(Rnd * 256): c2 = Int(Rnd * 256)

'Тип линии
d1 = Int(Rnd * 7) + 1: d2 = Int(Rnd * 7) + 1: d3 = Int(Rnd * 7) + 1

For i% = xn To xk Step 3
Set myDocument = ActiveDocument
With myDocument.Shapes.AddLine(i%, yn, xk + xn - i%, yk).Line
    .DashStyle = d1 'msoLineSolid
    .ForeColor.RGB = RGB(a1, b1, c1)
    .Weight = W
End With
i% = i% + 1

With myDocument.Shapes.AddLine(i%, yn, xk + xn - i%, yk).Line
    .DashStyle = d2 'msoLineSolid
    .ForeColor.RGB = RGB(a2, b2, c2)
    .Weight = W
End With
i% = i% + 1

With myDocument.Shapes.AddLine(i%, yn, xk + xn - i%, yk).Line
    .DashStyle = d3 'msoLineSolid
    .ForeColor.RGB = RGB(a3, b3, c3)
    .Weight = W
End With
i% = i% - 2

Next i%

a1 = Int(Rnd * 256): a3 = Int(Rnd * 256)
b1 = Int(Rnd * 256): b3 = Int(Rnd * 256)
c1 = Int(Rnd * 256): c3 = Int(Rnd * 256)

'Средний луч
a2 = Int(Rnd * 256): b2 = Int(Rnd * 256): c2 = Int(Rnd * 256)

'Тип линии
d1 = Int(Rnd * 7) + 1: d2 = Int(Rnd * 7) + 1: d3 = Int(Rnd * 7) + 1

For i% = yn To yk Step 3
With myDocument.Shapes.AddLine(xk, i%, xn, yk + yn - i%).Line
    .DashStyle = d1 'msoLineSolid
    .ForeColor.RGB = RGB(a1, b1, c1)
    .Weight = W
End With
i% = i% + 1

With myDocument.Shapes.AddLine(xk, i%, xn, yk + yn - i%).Line
    .DashStyle = d2 'msoLineSolid
    .ForeColor.RGB = RGB(a2, b2, c2)
    .Weight = W
End With
i% = i% + 1

With myDocument.Shapes.AddLine(xk, i%, xn, yk + yn - i%).Line
    .DashStyle = d3 'msoLineSolid
    .ForeColor.RGB = RGB(a3, b3, c3)
    .Weight = W
End With
i% = i% - 2

Next i%

End Sub





7:40:16 02.02.2024          B8F0D94000