Форум программистов, компьютерный форум, киберфорум
Наши страницы

VBA

Войти
Регистрация
Восстановить пароль
 
 
Рейтинг: Рейтинг темы: голосов - 2, средняя оценка - 5.00
аналитика
здесь больше нет...
3331 / 1660 / 184
Регистрация: 03.02.2010
Сообщений: 1,219
#1

Авторские программы, библиотеки, надстройки и шаблоны - VBA

12.02.2010, 17:42. Просмотров 108956. Ответов 143
Метки нет (Все метки)

 Комментарий модератора 
Коллектив модераторов раздела оставляет за собой право использовать данный пост аналитики для размещения и обновления оглавления темы.

Оглавление
- по тематике:

Утилиты


Инструменты программиста

Графические редакторы



Защита программного кода

Офисные операции

Веб-сервис


Игры




- по автору:
A-Z





Конец оглавления

Оригинальное сообщение от аналитики:

Надстройка для VBE "IndenterVBA" - позволяет редактировать стиль оформления программного кода.
27
Вложения
Тип файла: rar IndenterVBA.rar (253.1 Кб, 1493 просмотров)
Надоела реклама? Зарегистрируйтесь и она исчезнет полностью.
Similar
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
12.02.2010, 17:42
Здравствуйте! Я подобрал для вас темы с ответами на вопрос Авторские программы, библиотеки, надстройки и шаблоны (VBA):

Подключение библиотеки в коде программы - VBA
Добрый день, уважаемые форумчане. При переносе макроса из 2003 в 2007 Excel возникла проблема с библиотекой Microsoft Office Web Components...

ошибка в коде надстройки - VBA
Надстройка выдает ошибку 13. В коде ругается на строку: prob = frmMain.txtSignifLevel.Value. :rtfm: Что значит эта строка? Совсем не...

Редактирование надстройки EXCEL - VBA
Ситуация: есть файл start.xla (при запуске сам не показывается, а формирует и запускает временный файл _start.xls с главным меню...

Временно отключить надстройки - VBA
Здравствуйте! Необходимо в начале действия макрос отключить (или приостановить) действие всех надстроек, а в конце снова включить....

Вызов надстройки через VBA - VBA
Здравствуйте. Очень нужна Ваша помощь. Задача следующая: В VBA для Excel 2003 необходимо написать макрос с использованием (вызовом)...

Всё про надстройки .XLA - VBA
Предлагаю в этой теме обсудить все аспекты надстроек .XLA . Частично эти вопросы затрагивались в теме ...

143
OLEGOFF
313 / 244 / 86
Регистрация: 27.02.2013
Сообщений: 1,049
04.05.2014, 16:57 #61
Предлагаю вашему вниманию Некоторые работы по анимации в Excel.
0
Вложения
Тип файла: zip Винни Пух.zip (77.4 Кб, 99 просмотров)
OLEGOFF
313 / 244 / 86
Регистрация: 27.02.2013
Сообщений: 1,049
04.05.2014, 17:04 #62
Черно белое фото
0
Вложения
Тип файла: zip Фото чб.zip (18.5 Кб, 59 просмотров)
OLEGOFF
313 / 244 / 86
Регистрация: 27.02.2013
Сообщений: 1,049
04.05.2014, 17:13 #63
Коррекция цвета
0
Вложения
Тип файла: zip кот (4).zip (79.4 Кб, 47 просмотров)
OLEGOFF
313 / 244 / 86
Регистрация: 27.02.2013
Сообщений: 1,049
04.05.2014, 19:22 #64
Анекдот программиста
0
Вложения
Тип файла: zip Анекдот.zip (226.4 Кб, 97 просмотров)
Антихакер32
Заблокирован
27.05.2014, 10:57 #65
DllErr

нативная dll (используется без регистрации)
для создания своих собственных обработчиков ошибки
с описанием ошибки, дескриптором и источником


Как использовать !?
просто перенесите эту dll в свою папку, где будет находиться Ваш проект
Visual Basic
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
Option Explicit
 
Private Declare Function cErr Lib "dllERR.dll" Alias "cErr_A" () As Object
'Function Add(Number&, Description$) As Long
'    'Создаёт номер и дискриптор ошибки
'    'Возвращает успешно добавленный номер
'Sub Raise(Expression As Boolean, ByVal Index$, Optional Source$)
'    'Вызов ошибки по указанному индексу
'    'Арг: выражение // номер или ключ // источник
'Function Remove(ByVal Index$) As Boolean
'    'Удаляет указанный индекс ошибки
'    'Возвращает успех
Dim mErr As Object
 
Private Sub Form_Click()
    mErr.Raise 1, 101, "Form_Click"
End Sub
 
Private Sub Form_Load()
    Set mErr = cErr
    With mErr
        'Добавляем данные об ошибке ...
        .Add 101, "Проверочная ошибка"
    End With
End Sub
Подробнее здесь

Решил немного адаптировать под VBA
перенесите эту dll в свою папку, где будет находиться Ваш документ

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Private Declare Function cErr Lib "dllERR.dll" Alias "cErr_A" () As Object
Dim mErr As Object
 
Sub Макрос1()
'
' Макрос1 Макрос
' Макрос записан 27.05.2014 (© Антихакер32)
'
    ChDir ThisWorkbook.Path
    Set mErr = cErr
    With mErr
        'Добавляем данные об ошибке ...
        .Add 999, "Проверочная ошибка"
        .Raise 1 > 0, 999, "Макрос1" 
    End With
    
End Sub
2
Миниатюры
Авторские программы, библиотеки, надстройки и шаблоны  
Антихакер32
Заблокирован
27.05.2014, 11:08 #66
...
0
Вложения
Тип файла: rar dllERR.rar (5.6 Кб, 38 просмотров)
Аксима
5727 / 1177 / 185
Регистрация: 12.12.2012
Сообщений: 963
25.06.2014, 17:19 #67
Предлагаемая вашему вниманию статья дает краткий обзор массивов и операций над массивами, а также содержит проект "Библиотека AksiArrays".

Часть первая: "Введение в массивы"

Вступление
С самого зарождения вселенной жизнь - это удивительное сочетание единственного и множественного чисел. Мы живем во вселенной, которую представляем единственным числом (хотя на самом деле очень даже может, что вселенных несколько, просто они существуют в параллельных измерениях), а внутри этой вселенной - множество солнц, планет, астероидов и других небесных объектов. На одной из планет - на планете Земля климатические условия оказались наиболее благоприятными для эволюции, и в итоге на ней возникло множество рыб, зверей, птиц и, наконец, людей. А каждый человек в свою очередь - мини-вселенная, состоящая из множества клеток организма, пищевых бактерий, помогающих нам усваивать пищу, и других микроорганизмов... Данный процесс перехода от единственного числа к множественному можно повторять, наверное, до бесконечности, и поэтому так важно, чтобы программы умели обрабатывать однородные совокупности, представленные множеством элементов.
Необходимость в такой обработке привела к появлению в языках программирования массивов. Введем определение массива:
Массив - это...
...набор однотипных данных, имеющих одинаковое имя, но разные номера (индексы).
Если вернуться к нашей картине вселенной и рассмотреть массив планет Солнечной системы, то мы обнаружим, что все они имеют одинаковое имя (планета), но разные номера. Если вести отсчет планет от Солнца, то планетой №1 будет Меркурий, планетой №2 - Венера и т.д. Наша планета, Земля, в этом массиве займет третий номер.
В памяти компьютера для массивов выделяется непрерывная область памяти, в которой элементы следуют непосредственно друг за другом. Благодаря этому доступ к каждому элементу массива осуществляется очень быстро: для этого компьютеру нужен лишь указатель на первый элемент массива (определяемый именем массива) и смещение искомого элемента массива относительно первого элемента (определяемое индексом элемента).
Ввиду того, что область памяти, занимаемая массивом, выделяется заранее, массив перед его использованием необходимо объявить. Делается это с помощью ключевого слова Dim, которое расшифровывается как Dimension - "размерность". Данное ключевое слово было введено специально для объявления массивов, но, что любопытно, сейчас с его помощью объявляются не только переменные типа массив, но и все прочие переменные - настолько удобным оно оказалсь.
Формат объявления статистического массива (есть еще динамические массивы, но они будут упоминаться позже - в спецглавах).
Код
Dim <имя_массива>([<нижний_индекс> To ]<верхний_индекс>[,[<нижний_индекс> To ]<верхний_индекс>][,...])[ As <тип>]
Здесь <имя_массива> - имя, под которым мы будем обращаться к элементам массива.
<нижний_индекс> - наименьшее значение, которое может принимать индекс массива. По умолчанию равно либо значению, заданному опцией Option Base, либо нулю.
<верхний_индекс> - наибольшее значение, которое может принимать индекс массива.
Размер массива определяется так: количество элементов = <верхний_индекс> - <нижний_индекс> + 1. Таким образом, если мы определили массив как Dim arr(10), и не задавали Option Base, то массив arr будет содержать 10 - 0 + 1 = 11 элементов.
<тип> - определяет тип элементов массива. Хотя его можно не указывать, лучше это сделать, так как в качестве типа элементов массива по умолчанию берется довольно ресурсоемкий тип Variant.
Обратите внимание, что мы можем объявить несколько размерностей через запятую. Чаще всего объявляется массив с одной размерностью, который называется одномерным массивом, или вектором. Также применяются массивы с двумя размерностями (двухмерные массивы, или матрицы) и с тремя размерностями (трехмерные массивы, или кубы). Массивы с более чем тремя размерностями также возможны, но на практике применяются редко.

Глава первая: "Одномерные массивы"
Подробный разбор массивов и их использования мы начнем с одномерных массивов, так как именно такие массивы чаще всего используются на практике. Мы помним, что общий формат объявления массивов таков:
Код
Dim <имя_массива>([<нижний_индекс> To ]<верхний_индекс>[,[<нижний_индекс> To ]<верхний_индекс>][,...])[ As <тип>]
Одномерные массивы имеют только одну размерность, поэтому формат их объявления короче:
Код
Dim <имя_массива>([<нижний_индекс> To ]<верхний_индекс>)[ As <тип>]
Примеры объявления одномерного массива:
Visual Basic
1
2
3
Dim arr(0 To 9) As Long
Dim arr(9) As Long
Dim arr(0 To 9)
В первом примере объявляется массив целых чисел (массив элементов типа Long: тип Long определяет целые числа от -2147483648 до 2147483647). Нижняя граница массива равна 0, а верхняя - 9, таким образом, массив состоит из 9 - 0 + 1 = 10 элементов.
Во втором примере объявляется массив, эквивалентный предыдущему в том случае, если опция Option Base установлена равной 0 или не установлена (так как по умолчанию считается, что массивы индексируются с нуля). Если же опция Option Base установлена равной 1, то будет объявлен массив, нижняя граница которого равна 1, а верхняя граница - 9. Ввиду подобной неоднозначности эту форму записи объявления можно рекомендовать к использованию только в личных проектах или программах, в которых значение опции Option Base точно известно. Если же проект выполяется в расчете на то, что им будут пользоваться другие лица, то, пожалуй, лучше будет использовать первую форму записи объявления массива.
В третьем примере указание типа элементов массива опущено, поэтому элементы массива имеют тип Variant. Индексы массива, как и в первом примере, находятся в диапазоне от 0 до 9.
Рассмотрим несколько задач, для которых характерно использование массивов:
Задача №1
Предположим, что члены кружка природоведения дали нам набор показаний температуры, которые снимались ежедневно в течение января, и попросили составить программу, которая поможет проанализировать эти данные, например, определить среднюю температуру января.
Будь количество измерений в наборе невелико, можно было бы, например, воспользоваться следующей программой:
Visual Basic
1
2
3
4
5
6
Sub AverageTemperature1()
    Dim a As Double, b As Double, c As Double, d As Double, e As Double, result As Double
    a = -19.4: b = -24#: c = -20.9: d = -18.5: e = -16.8
    result = (a + b + c + d + e) / 5
    MsgBox "Средняя температура января: " & Format(result, "0.0")
End Sub
Однако, наш набор показаний температуры состоит из 31 числа. И если бы мы воспользовались программой, подобной той, что приведена выше, нам пришлось бы объявить тридцать одну переменную. Соответствующие строки нашей программы оказались бы очень длинными и неудобными при вводе, кроме того, при вводе таких строк легко сделать ошибки.
При небольшом наборе данных вполне приемлемо использовать несколько переменных для записи его элементов. Когда же набор данных большой, использовать такой подход явно неблагоразумно. Для того, чтобы преодолеть подобные трудности, мы и используем массивы.
Вспомним основные правила использования массива:
  1. Перед использованием массивов в программе на VBA мы должны сообщить компьютеру его размер с помощью ключевого слова Dim. После ключевого слова Dim записывается имя массива и в скобках указывается его верхняя размерность (размерности), а также и нижняя размерность (размерности), если это необходимо. Кроме того, можно указать тип элементов массива.
  2. Для обозначения отдельного элемента массива используется имя массива, за которым следует индекс (индексы) элемента, заключенный в круглые скобки.
Вернемся к задаче определения средней температуры января. Дадим массиву для записи ежедневных температур имя Т. Массив будет выглядеть так, как показано на следующей таблице:
Дата...........Элемент..Температура.
1 январяT(1)-19,4
2 январяT(2)-24
3 январяT(3)-20,9
4 январяT(4)-17,5
5 январяT(5)-16,8
6 январяT(6)-23,4
7 январяT(7)-23,3
8 январяT(8)-23
9 январяT(9)-23,6
10 январяT(10)-15,4
11 январяT(11)-16,7
12 январяT(12)-15
13 январяT(13)-14,3
14 январяT(14)-24,8
15 январяT(15)-22,7
16 январяT(16)-24,9
17 январяT(17)-21
18 январяT(18)-16,5
19 январяT(19)-18,9
20 январяT(20)-13,7
21 январяT(21)-19,5
22 январяT(22)-20,2
23 январяT(23)-20
24 январяT(24)-23,3
25 январяT(25)-15,9
26 январяT(26)-22,7
27 январяT(27)-11,6
28 январяT(28)-10,2
29 январяT(29)-9
30 январяT(30)-9,2
31 январяT(31)-7,5
Обратите внимание на то, что имена элементов массива отличаются лишь индексами. Поэтому мы можем обратиться ко всем его элементам, просто перебрав их индексы с помощью цикла For.
Данное наблюдение поможет нам написать программу:
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Option Explicit
Option Base 1 'Индексируем массивы с единицы (по умолчанию они индексируются с нуля).
 
Sub AverageTemperature2()
    Const DAYS_IN_JAN = 31 'Количество дней в январе.
    Dim i As Long, T(DAYS_IN_JAN) As Double, result As Double
    'Заполняем массив данными.
    T(1) = -19.4:   T(9) = -23.6:   T(17) = -21#:   T(25) = -15.9
    T(2) = -24#:    T(10) = -15.4:  T(18) = -16.5:  T(26) = -22.7
    T(3) = -20.9:   T(11) = -16.7:  T(19) = -18.9:  T(27) = -11.6
    T(4) = -17.5:   T(12) = -15#:   T(20) = -13.7:  T(28) = -10.2
    T(5) = -16.8:   T(13) = -14.3:  T(21) = -19.5:  T(29) = -9#
    T(6) = -23.4:   T(14) = -24.8:  T(22) = -20.2:  T(30) = -9.2
    T(7) = -23.3:   T(15) = -22.7:  T(23) = -20#:   T(31) = -7.5
    T(8) = -23#:    T(16) = -24.9:  T(24) = -23.3
    'Вычисляем сумму всех температур.
    For i = 1 To DAYS_IN_JAN
        result = result + T(i)
    Next i
    'Находим среднюю температуру.
    result = result / DAYS_IN_JAN
    'Выводим результат.
    MsgBox "Средняя температура января: " & Format(result, "0.0") & " градуса."
End Sub
Благодаря массивам, нам удалось помочь членам кружка природоведения получить то, что они хотели!


Задача №2
В классе 20 учащихся писали контрольную работу по математике. Составьте программу, которая помогла бы определить, сколько из них получили оценку 2, оценку 3, оценку 4, оценку 5.
Решение: нам нужно осуществить поиск в массиве заданных чисел. Поиск - это одна из фундаментальных операций, производимых над наборами данных. В случае массива поиск производится путем перебора всех его элементов и их сравнения с заданным значением (или набором значений).
Предположим, что классный журнал выглядит следующим образом:
Фамилия.....Код учащегося.Оценка.
Ивановpupil(1)5
Петровpupil(2)4
Сидоровpupil(3)2
Барановаpupil(4)3
Семеновpupil(5)5
Агафоновpupil(6)2
Дмитриеваpupil(7)4
Булатоваpupil(8)3
Прокопчукpupil(9)5
Молчановpupil(10)5
Фоминаpupil(11)4
Орловаpupil(12)2
Соловьеваpupil(13)4
Гуровpupil(14)5
Ильинpupil(15)3
Ясеневpupil(16)5
Павловpupil(17)4
Гаврилинаpupil(18)4
Панфиловаpupil(19)3
Захаровpupil(20)4
Тогда программа перебора с поиском будет выглядеть примерно так:
Visual Basic
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
Option Explicit
Option Base 1 'Индексируем массивы с единицы.
 
Sub ControlWorkRatings()
    Const PUPILS_N = 20 'Количество учащихся в классе.
    Dim i As Long, j As Long, pupil(PUPILS_N) As Long, rates(2 To 5) As Long
    'Заполняем массив данными.
    pupil(1) = 5:   pupil(8) = 3:   pupil(15) = 3
    pupil(2) = 4:   pupil(9) = 5:   pupil(16) = 5
    pupil(3) = 2:   pupil(10) = 5:  pupil(17) = 4
    pupil(4) = 3:   pupil(11) = 4:  pupil(18) = 4
    pupil(5) = 5:   pupil(12) = 2:  pupil(19) = 3
    pupil(6) = 2:   pupil(13) = 4:  pupil(20) = 4
    pupil(7) = 4:   pupil(14) = 5
    'Осуществляем перебор учащихся и подсчет оценок.
    For i = 1 To PUPILS_N
        For j = 2 To 5
            If pupil(i) = j Then 'Оценка определена...
                rates(j) = rates(j) + 1 '...увеличиваем счетчик, соответствующий оценке...
                Exit For '... и выходим из цикла.
            End If
        Next j
    Next i
    'Выводим результат.
    MsgBox "Отличных оценок получено: " & rates(5) & vbCr & _
    "Хороших оценок получено: " & rates(4) & vbCr & _
    "Удовлетворительных оценок получено: " & rates(3) & vbCr & _
    "Неудовлетворительных оценок получено: " & rates(2), , "Итоги контрольной"
End Sub


Задача №3
Дан числовой массив, в котором записано 80 чисел. Найти наибольший элемент этого массива.
Решение: для того, чтобы лучше понять решение этой задачи, представим себе следующую ситуацию. У нас имеется длинный-предлинный стол, и на нем разложены 100 камней, из которых нужно выбрать самый большой. Как это можно сделать? Берём первый камень и идем вдоль стола. Когда мы видим камень, который больше имеющегося у нас - мы заменяем старый камень новым, а старый - убираем. Если мы пройдем вдоль всего стола, перебрав все камни таким образом, то на финише у нас будет самый большой камень.
Аналогичным образом можно поступить и при обработке числового массива. Сначала записываем в переменную для хранения максимального элемента первый элемент массива, затем сравниваем значения всех остальных элементов массива со значением этой переменной. Если какой-то из элементов массива окажется больше - запишем его значение в переменную, и т.д.
Соответствующая программа будет иметь вид:
Код программы
Visual Basic
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
Option Explicit
Option Base 1 'Индексируем массивы с единицы.
 
Sub FindMaxNumber()
    Const N = 80
    Dim i As Long, k As Long, max_elem As Long, arr(N) As Long, line As String, line_old As String, msg As String
    'Заполняем массив данными.
    For i = 1 To N
        arr(i) = Int(Rnd * 100) - 50
    Next i
    'Выводим массив.
    For i = 1 To N
        line_old = line
        line = line & arr(i) & Space(3)
        If Len(line) > 50 Then
            If Len(line_old) < 50 Then
                k = 50 - Len(line_old)
                line_old = Replace(line_old, Space(3), Space(4), , k)
            End If
            msg = msg & line_old & vbCrLf
            line = vbNullString
        End If
    Next i
    MsgBox msg, , "Массив"
    'Берем первый элемент в качестве максимального.
    max_elem = arr(1)
    'Cравниваем значения всех остальных элементов массива
    'со значением, принятым за максимум.
    For i = 1 To N
        'Если какой-то из элементов массива окажется больше, запишем
        'его значение в переменную, выделенную для хранения максимума.
        If arr(i) > max_elem Then max_elem = arr(i)
    Next i
    'Выводим максимальный элемент.
    MsgBox "Максимальный элемент массива равен: " & max_elem
End Sub


Задача №4
Дан массив размера N. Преобразовать этот массив таким образом, чтобы значения элементов этого массива не убывали.
Решение: при решении задач с помощью компьютера, упорядочивание массивов приходится выполнять так часто, что по оценкам специалистов, более четверти времени работы компьютеров приходится на выполнение этого процесса, который называют также сортировкой. По этой причине для решения задачи сортировки с помощью компьютера придумано много различных алгоритмов, но мы для начала рассмотрим только один - «Метод пузырька».
Суть этого метода состоит в следующем: просматриваем массив в порядке возрастания индексов элементов до тех пор, пока не найдём пару соседних элементов (индексы этих элементов отличаются на единицу), таких, что значение второго элемента меньше, чем значение первого: если такая пара найдена, то меняем местами значения этих элементов и продолжаем просмотр массива, пока не дойдём до элемента массива с наибольшим индексом. После такого просмотра значение этого элемента будет наибольшим. Следующий просмотр записывает в предпоследний элемент массива (элемент с индексом п-1) второе по величине значение. Очевидно, что повторение указанных действий n-1 раз приводит к упорядочиванию массива.
Движение элементов в массиве, происходящее во время этого процесса, напоминает движение пузырьков воздуха в жидкости, откуда этот метод и получил свое название.
Программа, реализующая этот метод, имеет следующий вид:
Код программы
Visual Basic
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
Option Explicit
Option Base 1 'Индексируем массивы с единицы.
 
Sub SortNumbers()
    Const N = 50
    Dim i As Long, j As Long, k As Long, t As Long, arr(N) As Long, line As String, line_old As String, msg As String
    'Заполняем массив данными.
    For i = 1 To N
        arr(i) = Int(Rnd * 100) - 50
    Next i
    'Выводим массив до упорядочивания.
    For i = 1 To N
        line_old = line
        line = line & arr(i) & Space(3)
        If Len(line) > 50 Then
            If Len(line_old) < 50 Then
                k = 50 - Len(line_old)
                line_old = Replace(line_old, Space(3), Space(4), , k)
            End If
            msg = msg & line_old & vbCrLf
            line = vbNullString
        End If
    Next i
    MsgBox msg, , "Перед упорядочиванием"
    msg = vbNullString
    '"Повторяем указанные действия n-1 раз"
    For i = 1 To N - 1
        'Просматриваем все n-1 последовательно расположенных пар элементов массива.
        For j = 1 To N - 1
            'Если найдена такая пара, что значение второго элемента в паре меньше,
            'чем значение первого, то меняем местами значения этих элементов.
            If arr(j) > arr(j + 1) Then: t = arr(j): arr(j) = arr(j + 1): arr(j + 1) = t
        Next j
    Next i
    'Выводим упорядоченный массив.
    For i = 1 To N
        line_old = line
        line = line & arr(i) & Space(3)
        If Len(line) > 50 Then
            If Len(line_old) < 50 Then
                k = 50 - Len(line_old)
                line_old = Replace(line_old, Space(3), Space(4), , k)
            End If
            msg = msg & line_old & vbCrLf
            line = vbNullString
        End If
    Next i
    MsgBox msg, , "После упорядочивания"
End Sub
Итак, рассмотрев всего лишь несколько задач, мы пришли к выводу, что использование массивов позволяет значительно облегчить решение многих важных проблем, таких, как:
  • нахождение общих характеристик некоторой совокупности (например, среднего арифметического);
  • поиск определенных значений в совокупности и подсчет их количества;
  • нахождение экстремальных значений совокупности (максимума и минимума);
  • упорядочивание элементов совокупности по определенному признаку.
Кроме того, как будет показано во второй части статьи, решение рассмотренных задач можно еще более упростить, используя методы библиотеки AksiArrays.
2
Аксима
5727 / 1177 / 185
Регистрация: 12.12.2012
Сообщений: 963
25.06.2014, 17:20 #68
Глава вторая: "Многомерные массивы"
Многомерные массивы - это массивы, количество измерений в которых (а следовательно, и количество индексов) больше одного. Формат их объявления:
Код
Dim <имя_массива>([<нижний_индекс> To ]<верхний_индекс>,[<нижний_индекс> To ]<верхний_индекс>[,...])[ As <тип>]
Примеры:
Visual Basic
1
2
3
Dim matr(0 To 3, 0 To 4) As Long
Dim matr(3, 4) As Long
Dim cube(0 To 2, 0 To 3, 0 To 4) As Long
В первом примере объявляется массив с двумя измерениями, который также часто называют матрицей. Первое измерение матрицы имеет нижнюю границу 0 и верхнюю границу 3, а второе измерение матрицы имеет нижнюю границу 0 и верхнюю границу 4. Следовательно, матрица имеет 3 - 0 + 1 = 4 строки и 4 - 0 + 1 = 5 столбцов. Всего матрица имеет 4 * 5 = 20 элементов (количество строк умножаем на количество столбцов, получаем колчество элементов матрицы).
Во втором примере приводится сокращенная запись объявления матрицы из первого примера (в предположении, что опция Option Base установлена равной 0 или не установлена).
В третьем примере объявляется массив с тремя измерениями: его можно называть кубом. При этом куб содержит 2 - 0 + 1 = 3 элемента вдоль своего первого измерения, 3 - 0 + 1 = 4 элемента вдоль второго измерения и 4 - 0 + 1 = 5 элементов вдоль третьего измерения. Всего получается 3 * 4 * 5 = 60 элементов.
На практике среди многомерных массивов чаще всего встречаются двухмерные (матрицы) - их мы рассмотрим более подробно. Также в статье мы кратко коснемся трехмерных массивов (кубов), а многомерные массивы, число измерений которых более трех, рассматривать не будем.
Итак, двухмерные массивы отличаются от одномерных тем, что обладают одним дополнительным измерением. Что это дает нам?
В-первых, мы можем анализировать данные сразу по двум параметрам. Например, в задаче №2 из предыдущей главы можно было бы организовать классный журнал в виде двумерного массива, где по строкам откладываются фамилии учащихся, а по столбцам - предметы. И тогда, проанализировав всего лишь один массив, мы можем подвести итоги не только по математике, но и, допустим, по русскому языку и литературе.
Ниже - пример программы, которая за один проход по матрице определяет как среднюю оценку учащихся по каждому предмету, так и средний балл каждого учащегося по всем предметам.
Задача №5
В классе 20 учащихся и 3 предмета (например, математика, русский язык и литература). Определить среднюю оценку каждого учащегося и среднюю оценку по каждому предмету.
Решение: объявим матрицу, количество строк которой равно количеству учащихся, а количество столбцов - количеству предметов. Далее объявим цикл обработки строк и внутри этого цикла будем обрабатывать элементы, находящиеся на пересечении исследуемой строки и каждого из столбцов матрицы. Обратите внимание, что цикл обработки столбцов матрицы вложен в цикл обработки ее строк. При обработке многомерных массивов использование вложенных циклов - обычное дело.
Код программы
Visual Basic
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
Sub PupilAndSubjectAverages()
    Const PUPILS_N = 20 'Количество учащихся в классе.
    Const SUBJECT_N = 3 'Количество изучаемых предметов.
    Dim i As Long, j As Long, grade(PUPILS_N, SUBJECT_N) As Long, msg As String
    Dim pupil_average(PUPILS_N) As Double, subject_average(SUBJECT_N) As Double
    'Заполняем массив данными.
    grade(1, 1) = 5: grade(1, 2) = 4: grade(1, 3) = 5
    grade(2, 1) = 4: grade(2, 2) = 5: grade(2, 3) = 4
    grade(3, 1) = 2: grade(3, 2) = 4: grade(3, 3) = 3
    grade(4, 1) = 3: grade(4, 2) = 3: grade(4, 3) = 2
    grade(5, 1) = 5: grade(5, 2) = 3: grade(5, 3) = 5
    grade(6, 1) = 2: grade(6, 2) = 2: grade(6, 3) = 3
    grade(7, 1) = 4: grade(7, 2) = 4: grade(7, 3) = 4
    grade(8, 1) = 3: grade(8, 2) = 3: grade(8, 3) = 3
    grade(9, 1) = 5: grade(9, 2) = 5: grade(9, 3) = 3
    grade(10, 1) = 5: grade(10, 2) = 5: grade(10, 3) = 5
    grade(11, 1) = 4: grade(11, 2) = 3: grade(11, 3) = 5
    grade(12, 1) = 2: grade(12, 2) = 4: grade(12, 3) = 3
    grade(13, 1) = 4: grade(13, 2) = 2: grade(13, 3) = 4
    grade(14, 1) = 5: grade(14, 2) = 4: grade(14, 3) = 4
    grade(15, 1) = 3: grade(15, 2) = 3: grade(15, 3) = 2
    grade(16, 1) = 5: grade(16, 2) = 3: grade(16, 3) = 4
    grade(17, 1) = 4: grade(17, 2) = 4: grade(17, 3) = 2
    grade(18, 1) = 4: grade(18, 2) = 2: grade(18, 3) = 4
    grade(19, 1) = 3: grade(19, 2) = 4: grade(19, 3) = 3
    grade(20, 1) = 4: grade(20, 2) = 5: grade(20, 3) = 5
    'Проходим по всем элементам матрицы и параллельно производим вычисления.
    For i = 1 To PUPILS_N
        For j = 1 To SUBJECT_N
            pupil_average(i) = pupil_average(i) + grade(i, j)
            subject_average(j) = subject_average(j) + grade(i, j)
        Next j
        pupil_average(i) = pupil_average(i) / SUBJECT_N
    Next i
    For j = 1 To SUBJECT_N: subject_average(j) = subject_average(j) / PUPILS_N: Next
    'Выводим результат.
    msg = "Средние оценки учащихся:" & vbCr
    For i = 1 To PUPILS_N
        msg = msg & "Учащийся №" & i & vbTab & Format(pupil_average(i), "0.00") & vbCr
    Next i
    msg = msg & vbCr & "Средние оценки по предметам:" & vbCr
    For i = 1 To SUBJECT_N
        msg = msg & "Предмет №" & i & vbTab & Format(subject_average(i), "0.00") & vbCr
    Next i
    MsgBox msg
End Sub
Во-вторых, наличие дополнительного измерения придает матрице форму. У нее появляется как бы своя "география". Например, можно говорить об обходе матрицы по строкам, обходе по столбцам и даже обходе по спирали. В случае квадратной матрицы очень часто говорят о следующих "географических объектах":
  1. Главная диагональ матрицы. Главная диагональ матрицы - элементы на линии, идущей из верхнего левого угла матрицы в ее правый нижний угол. У элементов главной диагонали матрицы индексы строки и столбца всегда совпадает.
  2. Побочная диагональ матрицы. Побочная диагональ матрицы - элементы на линии, идущей из верхнего правого угла матрицы в ее левый нижний угол. Индекс строки для элемента побочной диагонали равен разнице размера матрицы и индекса столбца этого элемента, увеличенной на единицу.
  3. Треугольники над/под главной/побочной диагональю - элементы матрицы, чьи индексы строки меньше (над) или больше (под) индекса строки элемента диагонали, лежащего в том же столбце, что и элемент треугольника.
Если нужно обработать подобный "географический объект", то можно пойти двумя путями. В-первых, можно перебрать все элементы матрицы и в ходе перебора проверять, удовлетворяют ли они определению обрабатываемого географического объекта. Если удовлетворяют - производим необходимую обработку. Достоинством такого пути является простота понимания и, соответственно, реализации. А недостатком - неэффективность (приходится перебирать все элементы матрицы помимо интересущих нас).
Во-вторых, можно построить цикл (циклы) таким образом, чтобы они проходили только по интересующим нас объектам. Этот путь более эффективен, но реализовать его для таких географических объектов, как треугольники матрицы, не так просто: нужно четко представлять себе, как определяются в каждом случае начальные и конечные значения переменных цикла. Начинающим трудно освоить такой путь.
Рассмотрим задачу, в которой стоит задача обработки "географических объектов" матрицы:
Задача №6
Выяснить, насколько максимальный элемент в треугольнике над главной диагональю больше минимального элемента в треугольнике под главной диагональю.
Решение: будем использовать первый подход из вышеизложенных - полный перебор с проверкой определения треугольника.
Код программы
Visual Basic
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
Option Explicit
Option Base 1
 
Sub TrianglesExtremesDifference()
    Const N = 6 'Размер квадратной матрицы.
    Dim i As Long, j As Long, iMain As Long, matr(N, N) As Long, msg As String
    Dim upperMax As Variant, lowerMin As Variant
    'Заполняем матрицу данными.
    For i = 1 To N
        For j = 1 To N
            matr(i, j) = Int(Rnd * 100) - 50
        Next j
    Next i
    'Выводим матрицу.
    msg = vbTab
    For i = 1 To N
        For j = 1 To N
            msg = msg & matr(i, j) & vbTab
            If i = j Or i = j + 1 Then msg = msg & vbTab
        Next j
        msg = msg & vbCr
    Next i
    MsgBox msg, , "Обрабатываемая матрица"
    'Обрабатываем матрицу.
    'Перебираем все элементы в двойном цикле.
    For i = 1 To N
        For j = 1 To N
            'Индекс строки элемента главной диагонали равен
            'индексу столбца, в котором он находится.
            iMain = j
            'Если индекс строки рассматриваемого элемента меньше
            'индекса строки элемента главной диагонали - это
            'элемент треугольника над главной диагональю.
            If i < iMain Then
                'Обработка.
                If IsEmpty(upperMax) Then upperMax = matr(i, j) Else If matr(i, j) > upperMax Then upperMax = matr(i, j)
            'Если индекс строки рассматриваемого элемента больше
            'индекса строки элемента главной диагонали - это
            'элемент треугольника под главной диагональю.
            ElseIf i > iMain Then
                'Обработка.
                If IsEmpty(lowerMin) Then lowerMin = matr(i, j) Else If matr(i, j) < lowerMin Then lowerMin = matr(i, j)
            End If
        Next j
    Next i
    'Выводим результат обработки.
    MsgBox "Разница между максимальным элементом над главной диагональю и минимальным элементом под главной диагональю равна: " & upperMax - lowerMin
End Sub
Подведем итог: матрицы, с одной стороны, значительно расширяют область применения массивов, а с другой - требуют большего объема программирования. К счастью, замечательные способности библиотеки AksiArrays по агрегированию данных и по ориентации в географии матрицы значительно облегчат вам задачу разработки приложений, обрабатывающих данные с использованием матриц.
Как обещалось, упомянем про трехмерные массивы. Они применяются в основном тогда, когда требуется обрабатывать объекты физической природы. Нахождение формы и положения тела в пространстве, расчет электромагнитных и гравитационных полей, определение энергии излучения или освещенности поверхности в той или иной точке - все эти задачи требуют применения трехмерных массивов. Без успешного решения проблем обработки трехмерных массивов были бы невозможны такие достижения современности, как разработка трехмерных графических редакторов (примеры: AutoCAD, 3D Max) или появление роботов, способных ориентироваться в пространстве (пример: робот-собака Aibo, которая способна следовать за хозяином по сложным трехмерным объектам наподобие лестницы в доме).


Спецглавы по массивам
Изложенная здесь информация с равным успехом может быть применена как к одномерным, так и к многомерным массивам. Было принято решение не относить ее к одной из предыдущих глав, а выделить в отдельную главу.
Динамические массивы
Основное преимущество статических массивов - то, что память под элементы этих массивов выделяется заранее. Таким образом, обеспечивается максимально быстрая скорость доступа к данным и их обработка. Но иногда возникают задачи, в которых мы не знаем заранее, сколько элементов надо выделять. В таком случае массив объявляется без размерности:
Код
Dim <имя_массива>()[ As <тип>]
В объявлении <имя_массива> - это имя, под которым мы будем обращаться к элементам массива, а <тип> - тип элементов массива.
Когда мы определились относительно количества элементов в массиве, нам нужно выделить необходимый для их хранения объем памяти с помощью оператора ReDim.
Код
ReDim [Preserve] <имя_массива>([<нижний_индекс> To ]<верхний_индекс>[,[<нижний_индекс> To ]<верхний_индекс>][,...])[ As <тип>]
Здесь ReDim - ключевое слово, дающее указание интерпретатору перераспределить память, выделенную под динамический массив (если память для него уже выделялась), либо выделить под него новый участок памяти (если память выделяется в первый раз).
Ключевое слово Preserve означает, что при перераспределении памяти, выделенной под динамический массив, значения, которые в нем хранятся, должны быть сохранены (перенесены в новый участок памяти). Если это ключевое слово не указать, то при перераспределении памяти вся информация, которая хранилась в динамическом массиве, будет утеряна, а сам массив будет проинициализирован значениями по умолчанию.
<имя_массива> - имя массива, для которого мы производим выделение/перераспределение памяти.
<нижний_индекс> - наименьшее значение, которое может принимать индекс массива.
<верхний_индекс> - наибольшее значение, которое может принимать индекс массива.
<тип> - тип элементов массива.
После выделения памяти динамический массив готов к употреблению. Освободить выделенную под него память можно с помощью ключевого слова Erase.
Код
Erase <имя_массива>
Память будет освобождена для массива с именем <имя_массива>.
В библотеке AksiArrays, построенной именно на динамических массивах, для аналогичной ключевому слову ReDim цели используются процедура Init.


Функция Array
Array - это удобная функция, которая выполняет сразу несколько задач:
  1. создает динамический массив типа Variant;
  2. инициализирует его значениями, переданными в качестве параметров функции;
  3. возвращает его в качестве своего результата.
Формат вызова функции Array:
Код
Array([<значение_1>][,<значение_2>][,...][,<значение_N>])
где <значение_1>, <значение_2> ... <значение_N> - список значений, которыми функция инициалирует массив.
Вызов функции без параметров, т.е. следующим образом:
Visual Basic
1
Array()
Эквивалентен объявлению динамического массива типа Variant:
Visual Basic
1
Dim retval() As Variant
Если же в функцию переданы параметры, то она, в-первых, выделяет в динамическом массиве объем памяти, необходимый для хранения всех значений, переданных в качестве параметров. А, во-вторых, присваивает эти значения элементам массива.
Таким образом, следующий вызов:
Visual Basic
1
2
Dim arr() As Variant
arr = Array(1, 2, 3)
Заменяет следющие строчки кода:
Visual Basic
1
2
3
4
5
6
7
Dim arr() As Variant
Dim retval() As Variant
ReDim retval(<Option_Base_Value> To <Option_Base_Value + 2>) As Variant
retval(<Option_Base_Value>) = 1
retval(<Option_Base_Value + 1>) = 2
retval(<Option_Base_Value + 2>) = 3
arr = retval
Как видите, экономия кода налицо. Отметим, что <Option_Base_Value> - это значение, заданное опцией Option Base (если опция не использована, то это значение равно нулю).
Что касается библиотеки AksiArrays, то в ней для быстрой и удобной инициализации массива используется ряд методов, начинающихся с префикса GetData_.


Определение границ массива: функции LBound и UBound
Функция LBound используется для определения минимального индекса, доступного в массиве (т.е. его нижней границы). Функция UBound используется для определения максимального индекса, доступного в массиве (верхней границы массива).
Функции имеют следующий синтаксис:
Код
LBound(<имя_массива>[, <размерность>])
Код
UBound(<имя_массива>[, <размерность>])
где <имя_массива> - имя массива, для которого требуется определить нижнюю (верхнюю) границу.
<размерность> - размерность многомерного массива, для которой требуется определить нижнюю (верхнюю) границу. По умолчанию нижняя и верхняя границы определяются для первой размерности.


Копирование значений из одного массива в другой
В старых версиях VBA для копирования значений из одного массива в другой приходилось писать цикл For...Next или For Each...Next. Версии VBA, начиная с версии 6.0, предлагают для этого более удобный способ, который выглядит точно так же, как присваивание одной переменной значения другой переменной. Но при этом налагаются следующие ограничения:
  1. Приемник должен быть динамическим массивом. Источник может быть как динамическим, так и статическим массивом.
  2. Типы элементов источника и приемника должны совпадать.
Пример использования данного способа копирования значений:
Visual Basic
1
2
3
4
5
6
7
Sub ArrayAssign()
    Dim i As Long, s As String, A(0 To 5) As Long, B() As Long
    For i = 0 To 5: A(i) = i: Next i 'Заполнение массива A значениями.
    B = A 'Копирование значений массива A в массив B.
    For i = 0 To 5: s = s & B(i) & Space(5): Next i
    MsgBox s 'Вывод значений массива B.
End Sub


Заключение
Мы начали со сравнения, отражающего предположение автора о том, что могло вдохновить людей на изобретение массивов, и затем изучили эти массивы во всей их красе и многообразии - и одномерные, и многомерные, и статические, и динамические. Был рассмотрен ряд примеров использования массивов, а также несколько полезных вспомогательных функций для работы с ними. По изложенному материалу можно видеть, насколько удобным и эффективным инструментом для решения большинства повседневных задач программирования являются массивы.
Библиотека AksiArrays, обсуждаемая в следующей части, призвана сделать этот инструмент еще более мощным и удобным.


Часть вторая: "Обзор библиотеки AksiArrays"


Вступление
Участвуя во многих темах и обсужениях раздела VBA, автору не раз приходилось замечать, что большинство из них так или иначе связаны с применением массивов. Кроме того, массивы являются популярной темой студенческих заданий. О чем говорить, если поиск слова "массив" только в одном разделе форума (в разделе VBA) выдает упирающееся в лимит количество результатов?
В ходе решения упомянутых задач часто приходится писать повторяющийся или почти повторяющийся код. Это натолкнуло на мысль создать библиотеку, которая позволила бы заменить написание такого кода вызовами подходящих функций/процедур. Однако написание такой библиотеки представлялось весьма трудоемкой и скучной задачей. И тут очень кстати в ходе самообразования автор изучил статью про пользовательские классы объектов. Идея библиотеки воедино с возможностью освоить пользовательские классы объектов на серьезном практическом материале оказались достаточным вызовом, чтобы взяться за работу.
Надо сказать, вызов оказался более чем достойным! На труд в перерывах между основной работой было потрачено полгода, и то этого оказалось недостаточно, чтобы реализовать все имевшиеся задумки. А что же тогда удалось реализовать, спросите вы? Об этом и пойдет разговор в следующих главах.
2
Аксима
5727 / 1177 / 185
Регистрация: 12.12.2012
Сообщений: 963
25.06.2014, 17:20 #69
О структуре библиотеки AksiArrays
Итак, библиотека AksiArrays, как вы уже, наверное догадались из вступления, основана на пользовательских классах объектов. Их довольно много, но каждый из них можно отнести к одной из трех основных групп:
  1. Базовые структуры массивов. Они отвечают за организацию данных и управление ими. По способу организации данных были выделены массивы с 1, 2 и 3 измерениями.
    • AksiVector (представляет собой одномерный массив)
    • AksiMatrix (-«»- двухмерный массив)
    • AksiCube (-«»- трехмерный массив)
  2. Базовые типы данных. Определяют набор типов данных, которые можно использовать в массивах. Набор предлагаемых базовых типов невелик, но достаточен для решения большинства задач, а случае необходимости может быть дополнен пользовательскими типами данных.
    • AksiInteger (целые числа)
    • AksiFloat (числа с плавающей точкой)
    • AksiChar (символы)
    • AksiString (строки)
    • AksiDate (даты)
  3. Интерфейсы доступа к данным. Они представляют собой оболочку, через которую базовые структуры массивов осуществляют обращение к своим элементам, и обеспечивают унифицированную обработку данных вне зависимости от их типа.
    • IFactory (фабрика объектов)
    • ISerializable (сериализация данных)
    • IComparer (инструмент сравнения объектов)
    • IComparable (встроенное в объект сравнение)
    • ICloneable (создание копии объекта)
    • IConvertible (преобразование типов)
    • IMath (математические вычисления)
Каждая из этих групп подробно рассматривается в следующих главах.
2
Аксима
5727 / 1177 / 185
Регистрация: 12.12.2012
Сообщений: 963
25.06.2014, 17:21 #70
Глава первая: "Обзор базовых структур массивов"
Как уже говорилось, базовые структуры массивов организуют данные в определенном порядке. Задача организации данных в виде одномерного массива возложена на класс AksiVector, в виде двухмерного массива - на класс AksiMatrix, и, наконец, задача организации трехмерного массива возложена на класс AksiCube. Листинги для этих классов приводится ниже:
Код класса AksiVector

Visual Basic
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
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
'________________________________________________________________
'______________________                    ______________________
'_____________________   Модуль AksiVector  _____________________
'____________________     Версия: 0.11.2     ____________________
'___________________       Автор: Aksima      ___________________
'___________________  Библиотека: AksiArrays  ___________________
'________________________________________________________________
'______                                                     _____
'______  Назначение: Реализует вектор - одномерный массив.  _____
'________________________________________________________________
 
Implements IFactory 'Поддерживает создание объектом класса других объектов этого же класса.
Implements ISerializable 'Поддерживает сериализацию данных.
Implements ICloneable
Enum AoSortMethod 'Перечисление методов сортировки.
    AO_BUBBLE 'Пузырковая сортировка.
    AO_SELECTION 'Сортировка путем выборки.
    AO_INSERTION 'Сортировка вставками.
End Enum
Enum AoSortOrder 'Возможные направления сортировки.
    AO_ASC = 1 'Сортировка в порядке возрастания.
    AO_DESC = -1 'Сортировка в порядке убывания.
End Enum
Dim a() As Object
Dim N As Long
'Создание объекта класса.
Private Function IFactory_NewOb() As Object
    Set IFactory_NewOb = New AksiVector
End Function
Private Function ISerializable_Serialize() As String 'Сериализация.
    Dim i As Long, s As String, z As New AksiString, src As ISerializable
    'Сериализация элемента.
    Set src = a(0)
    z = src.Serialize
    'Сериализация полученной строки.
    Set src = z
    s = src.Serialize
    For i = 1 To N - 1
        'Сериализация очередного элемента.
        Set src = a(i)
        z = src.Serialize
        'Сериализация полученной строки.
        Set src = z
        s = s & "," & src.Serialize
    Next i
    ISerializable_Serialize = s
End Function
Private Sub ISerializable_Unserialize(ByVal s As String) 'Десериализация.
    Dim i As Long, p As Long, q As Long, v As Variant, z As New AksiString
    Dim rec As ISerializable, es As Collection, ss As String, e() As String
    Set es = New Collection
    p = InStr(s, """") '(описание этой части процедуры есть в классе AksiMatrix).
    While p > 0
        ss = Trim(Left(s, p - 1))
        If Right(ss, 1) = "," Then ss = Trim(Left(ss, Len(ss) - 1))
        e = Split(ss, ",")
        For i = 0 To UBound(e)
            es.Add e(i)
        Next i
        q = InStr(p + 1, s, """")
        If q = 0 Then q = Len(s) + 1
        es.Add Mid(s, p + 1, q - p - 1)
        s = Trim(Mid(s, q + 1))
        If Left(s, 1) = "," Then s = Trim(Mid(s, 2))
        p = InStr(s, """")
    Wend
    e = Split(s, ",")
    For i = 0 To UBound(e)
        es.Add e(i)
    Next i
    For i = 0 To IIf(N < es.Count, N - 1, es.Count - 1)
        'Десериализация строки.
        Set rec = z
        rec.Unserialize es(i + 1)
        'Если в строке содержатся символы-разделители текстового файла, то
        'строка экранируется кавычками. При обратном преобразовании мы
        'проверяем наличие символов-разделителей: если они есть, то есть
        'и экранирующие кавычки. Обычно они удаляются драйвером текстового
        'файла, но здесь их необходимо удалить самостоятельно.
        If InStr(z, vbTab) + InStr(z, vbCr) + InStr(z, " ") + InStr(z, ",") > 0 _
        Then z = Mid(z, 2, Len(z.Value) - 2)
        'Десериализация элемента.
        Set rec = a(i)
        rec.Unserialize z
    Next i
End Sub
'Инициализация вектора c размерностью size и базовым объектом base.
'Базовый объект должен поддерживать интерфейс IFactory.
Public Sub Init(ByVal base As Object, ByVal size As Long)
    Dim i As Long, f As IFactory
    N = size
    Set f = base
    ReDim a(0 To N - 1) As Object
    For i = 0 To N - 1
        Set a(i) = f.NewOb
    Next i
End Sub
'Копирование содержимого вектора в новый вектор.
Private Function ICloneable_Copy() As Object
    Dim i As Long, c As ICloneable, v As New AksiVector
    v.Init a(0), N
    For i = 0 To N - 1
        Set c = a(i)
        Set v(i) = c.Copy
    Next i
    Set ICloneable_Copy = v
End Function
'Получение ссылки на элемент вектора по индексу.
Public Property Get Item(ByVal index As Long) As Object
    Set Item = a(index)
End Property
'Установка ссылки для элемента вектора с заданным индексом.
Public Property Set Item(ByVal index As Long, ByVal eNew As Object)
    If TypeName(a(index)) = TypeName(eNew) Then Set a(index) = eNew Else Err.Raise 13
End Property
'Получение количества элементов вектора.
Public Property Get Count() As Long
    Count = N
End Property
'Процедура для записи данных из вектора в текстовый файл с именем fileName.
'Базовый объект вектора должен поддерживать интерфейс ISerializable.
Public Sub PutData_TextFile(ByVal fileName As String)
    Dim i As Long, k As Long, s As String, src As ISerializable
    Dim c As AksiCatalog, f As New AksiFile
    f.Parse fileName
    If f.Path <> "\" Then
        Set src = a(0)
        s = src.Serialize
        For i = 1 To N - 1
            Set src = a(i)
            s = s & "," & src.Serialize 'Разделитель между элементами - запятая.
        Next i
        f.Catalog.MakeSureCatalogExists
        k = FreeFile
        Open fileName For Output As #k
        Print #k, s
        Close #k
    Else
        Set c = New AksiCatalog
        Set f = c.FileFind(f.Name)
        If f Is Nothing Then
            f.Name = fileName
            f.FullNameDialog "Файл " & f.Name & " не найден", "file " & f.Name & " not found"
        ElseIf f.FullName = "\" Then
            f.Name = fileName
            f.FullNameDialog "Файл " & f.Name & " не найден", "file " & f.Name & " not found"
        End If
        Set src = a(0)
        s = src.Serialize
        For i = 1 To N - 1
            Set src = a(i)
            s = s & "," & src.Serialize 'Разделитель между элементами - запятая.
        Next i
        k = FreeFile
        Open f.FullName For Output As #k
        Print #k, s
        Close #k
    End If
End Sub
'Процедура для чтения данных в вектор из текстового файла с именем fileName.
'Базовый объект вектора должен поддерживать интерфейс ISerializable.
Public Sub GetData_TextFile(ByVal fileName As String)
    Dim i As Long, k As Long, s As String
    Dim f As New AksiFile, c As AksiCatalog, rec As ISerializable
    f.Parse fileName
    If f.Path = "\" Then
        Set c = New AksiCatalog
        Set f = c.FileFind(fileName)
        If f Is Nothing Then
            f.Name = fileName
            f.FullNameDialog "Файл " & f.Name & " не найден", "file " & f.Name & " not found"
        ElseIf f.FullName = "\" Then
            f.Name = fileName
            f.FullNameDialog "Файл " & f.Name & " не найден", "file " & f.Name & " not found"
        End If
    End If
    k = FreeFile
    Open f.FullName For Input As #k
    Do Until EOF(k) 'Обрабатываем файл до конца.
        Input #k, s 'Считываем очередной элемент, разделенный запятой или знаком переноса.
        If s <> Chr(29) & Chr(30) Then 'Пропускаем разделитель слоев куба (см. класс AksiCube)
            Set rec = a(i)
            rec.Unserialize s
            i = i + 1
            If i > N - 1 Then Exit Do 'Если заполнили вектор - выходим досрочно.
        End If
    Loop
    Close #k
End Sub
'Процедура для вывода данных из вектора на диалоговое окно. Если базовый объект вектора не
'относится к одному из встроенных классов, то он должен поддерживать интерфейс ISerializable.
'Параметр title определяет заголовок диалогового окна, а floatPrecision - количество цифр,
'отображаемых в дробной части (параметр существенен только для векторов на основе AksiFloat).
Public Sub PutData_DialogBox(Optional ByVal title As String, Optional ByVal floatPrecision As Byte = 2)
    Dim i As Long, s As String, sFormat As String, src As ISerializable
    If N > 50 Then Err.Raise vbObjectError, , "Операция слишком велика (Operation too large)" & _
    vbCr & "Вы пытаетесь вывести в диалоговое окно вектор, размеры" & vbCr & _
    "которого больше допустимого лимита (50 элементов)." & vbCr & _
    "(You are trying to put into dialog box a vector with dimension" & vbCr & _
    "larger than allowed limit (maximum 50 elements)."
    Select Case TypeName(a(0))
        Case "AksiInteger"
            s = a(0)
            For i = 1 To N - 1
                s = s & Space(2) & a(i)
            Next i
        Case "AksiFloat"
            'Если в записи числа с плавающей точкой есть точка или ее аналог
            '(т.е. оно содержит дробную часть), то при выводе оно округляется
            'до точности floatPrecision во избежание громоздкости вывода.
            Select Case floatPrecision
                Case 0
                    sFormat = "0"
                Case Is <= 2
                    sFormat = "0." & String(floatPrecision, 48)
                Case Else
                    sFormat = "0.00" & String(floatPrecision - 2, 35)
            End Select
            If InStr(a(0), Format(0, ".")) Then
                If InStr(a(0), "E") Then
                    s = Format(a(0), sFormat & "E+")
                Else
                    s = Format(a(0), sFormat)
                End If
            Else
                s = a(0)
            End If
            For i = 1 To N - 1
                If InStr(a(i), Format(0, ".")) Then
                    If InStr(a(i), "E") Then
                        s = s & Space(4) & Format(a(i), sFormat & "E+")
                    Else
                        s = s & Space(4) & Format(a(i), sFormat)
                    End If
                Else
                    s = s & Space(4) & a(i)
                End If
            Next i
        Case "AksiChar"
            s = Chr(a(0))
            For i = 1 To N - 1
                s = s & Space(4) & Chr(a(i))
            Next i
        'Строки и сериализванные данные выводятся не подряд, а в столбик,
        'так как они занимают много места.
        Case "AksiString"
            s = a(0)
            For i = 1 To N - 1
                s = s & vbCr & a(i)
            Next i
        Case Else
            Set src = a(0)
            s = src.Serialize
            For i = 1 To N - 1
                Set src = a(i)
                s = s & vbCr & src.Serialize
            Next i
    End Select
    If title <> vbNullString Then MsgBox s, , title Else MsgBox s
End Sub
'Процедура для ввода данных в вектор через диалоговое окно. Если базовый объект вектора не
'относится к одному из встроенных классов, то он должен поддерживать интерфейс ISerializable.
'Параметр title определяет заголовок диалогового окна.
Public Sub GetData_DialogBox(Optional ByVal title As String)
    Dim i As Long, s As String, rec As ISerializable, v As Double, k As Long, b As Byte
    Dim f1 As Boolean, f2 As Boolean, f3 As Boolean
    Const pRU = "Пожалуйста, введите элемент № ", pEN = "(Input element number ", pE2 = ", please:"
    Const rRU = vbCr & "Пожалуйста, повторите ввод.", rEN = vbCr & "Try again, please.)"
    Const sErr = "Ошибка ввода (Invalid input)."
    If N > 50 Then Err.Raise vbObjectError, , "Операция слишком велика (Operation too large)" & _
    vbCr & "В целях сохранения здоровья оператора запрещен" & vbCr & _
    "ручной ввод векторов, размеры которых превышают" & vbCr & _
    "допустимый лимит (максимум 50 элементов)." & vbCr & _
    "(Caring of operator's health, system does not allow" & vbCr & _
    "to manually input vectors with more than 50 elements.)"
    Select Case TypeName(a(0))
        Case "AksiInteger"
            For i = 0 To N - 1
                s = pRU & i & vbCr & "- целое число." & vbCr _
                & pEN & i & pE2 & vbCr & "an integer value.)"
                If title <> vbNullString Then s = InputBox(s, title) Else s = InputBox(s)
                Do
                    f1 = False
                    f2 = False
                    f3 = False
                    'Отлов ошибки при выходе за пределы допустимого диапазона.
                    On Error Resume Next
                    v = Val(Replace(s, Format(0, "."), "."))
                    If Err Then f1 = True
                    On Error GoTo 0
                    If Not f1 Then
                        'Если функция Val вернула 0, то либо она не смогла распознать
                        'число, либо в функцию передана строка "0".
                        'Проверка ниже позволяет учесть эти факты.
                        If s = "0" Or v <> 0 Then
                            'Отлов ошибки при выходе за пределы допустимого диапазона для типа Long.
                            On Error Resume Next
                            k = CLng(v)
                            If Err Then f1 = True
                            On Error GoTo 0
                            If Not f1 Then
                                'Проверка на отсутствие дробной части.
                                If v - CDbl(k) = 0 Then
                                    a(i) = k
                                Else
                                    f2 = True
                                End If
                            End If
                        Else
                            f3 = True
                        End If
                    End If
                    If f1 Then s = "Число не должно выходить за пределы отрезка," & vbCr _
                    & "отводимого под целочисленные числа [-2^31..2^31-1]" & rRU _
                    & vbCr & "(Number must be in range between -2^31 and 2^31-1." & rEN
                    If f2 Then s = "Число должно быть целым." & rRU _
                    & vbCr & "(Number must be integer." & rEN
                    If f3 Then s = "Введенная вами строка не является" & vbCr _
                    & "корректной записью десятичного числа." & rRU _
                    & vbCr & "(System cannot recognize your input." & vbCr _
                    & "as a valid decimal number." & rEN
                    If f1 Or f2 Or f3 Then s = InputBox(s, sErr)
                Loop While f1 Or f2 Or f3
            Next i
        Case "AksiFloat"
            For i = 0 To N - 1
                s = pRU & i & vbCr & "- вещественное число." & vbCr _
                & pEN & i & pE2 & vbCr & "a real number.)"
                If title <> vbNullString Then s = InputBox(s, title) Else s = InputBox(s)
                Do
                    f1 = False
                    f2 = False
                    'Отлов ошибки при выходе за пределы допустимого диапазона.
                    On Error Resume Next
                    v = Val(Replace(s, Format(0, "."), "."))
                    If Err Then f1 = True
                    On Error GoTo 0
                    If Not f1 Then
                        'Если функция Val вернула 0, то либо она не смогла распознать
                        'число, либо в функцию передана строка "0".
                        If s = "0" Or v <> 0 Then
                            a(i) = v
                        Else
                            f2 = True
                        End If
                    End If
                    If f1 Then s = "Число не должно выходить за пределы допустимых диапазонов:" _
                    & vbCr & "-1,79E308...-5E-324; 0; 5E-324...1,79E308" & rRU _
                    & vbCr & "(Number must be in one of the following ranges:" & vbCr _
                    & "-1.79E+308...-5E-324, 0, 5E-324...1.79E+308" & rEN
                    If f2 Then s = "Введенная вами строка не является" & vbCr _
                    & "корректной записью десятичного числа." & rRU _
                    & vbCr & "(System cannot recognize your input." & vbCr _
                    & "as a valid decimal number." & rEN
                    If f1 Or f2 Then s = InputBox(s, sErr)
                Loop While f1 Or f2
            Next i
        Case "AksiChar"
            For i = 0 To N - 1
                s = pRU & i & vbCr & "- символ или его код." & vbCr _
                & pEN & i & pE2 & vbCr & "a symbol or its code.)"
                If title <> vbNullString Then s = InputBox(s, title) Else s = InputBox(s)
                Do
                    f1 = False
                    f2 = False
                    f3 = False
                    'Отлов ошибки при выходе за пределы допустимого диапазона.
                    On Error Resume Next
                    v = Val(Replace(s, Format(0, "."), "."))
                    If Err Then f1 = True
                    On Error GoTo 0
                    If Not f1 Then
                        'Проверка на успешность распознания строки в качестве числа.
                        If s = "0" Or v <> 0 Then
                            'Отлов ошибки при выходе за пределы допустимого диапазона для типа Byte.
                            On Error Resume Next
                            b = CByte(v)
                            If Err Then f1 = True
                            On Error GoTo 0
                            If Not f1 Then
                                'Проверка на отсутствие дробной части.
                                If v - CDbl(b) = 0 Then
                                    a(i) = v
                                Else
                                    f2 = True
                                End If
                            End If
                        'Если строка не была распознана как число,
                        'то проверяется ввод единственного символа.
                        ElseIf Len(s) = 1 Then
                            a(i) = Asc(s)
                        Else
                            f3 = True
                        End If
                    End If
                    If f1 Then s = "Код символа должен быть не меньше 0 и не больше 255." & rRU _
                    & vbCr & "(Code of symbol cannot be less than 0 or greater than 255." & rEN
                    If f2 Then s = "Код символа не может быть вещественным числом." & rRU _
                    & vbCr & "(Code of symbol cannot be a real number." & rEN
                    If f3 Then s = "Не допускается ввод больше одного символа." & rRU _
                    & vbCr & "(You shouldn't input more than one symbol." & rEN
                    If f1 Or f2 Or f3 Then s = InputBox(s, sErr)
                Loop While f1 Or f2 Or f3
            Next i
        Case "AksiString"
            For i = 0 To N - 1
                s = pRU & i & vbCr & "- строку." & vbCr _
                & pEN & i & pE2 & vbCr & "a string.)"
                If title <> vbNullString Then a(i) = InputBox(s, title) Else a(i) = InputBox(s)
            Next i
        Case Else
            For i = 0 To N - 1
                s = pRU & i & vbCr & "- элемент сложного типа." & vbCr _
                & pEN & i & pE2 & vbCr & "an element of non-basic data type.)"
                If title <> vbNullString Then s = InputBox(s, title) Else s = InputBox(s)
                Set rec = a(i)
                rec.Unserialize s
            Next i
    End Select
End Sub

2
Аксима
5727 / 1177 / 185
Регистрация: 12.12.2012
Сообщений: 963
25.06.2014, 17:21 #71
Глава первая: "Обзор базовых структур массивов" (продолжение)

Код класса AksiVector (продолжение)

Visual Basic
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
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
'Процедура для записи данных из вектора в файл Excel с именем fileName. При необходимости
'уточняются индекс листа sheetIndex и параметры выбора диапазона rangeParam либо заголовок header.
'Если имя fileName не указано, то через rangeParam передается ссылка на диапазон для записи данных.
'Базовый объект вектора должен поддерживать либо свойство по умолчанию Value, либо интерфейс ISerializable.
Public Sub PutData_ExcelFile(Optional ByVal rangeParam As Variant, Optional ByVal fileName As String, _
Optional ByVal sheetIndex As Variant, Optional ByVal header As String)
 
    Dim eApp As Object, eWbk As Object, eWst As Object, eRng As Object, eCell As Object
    Dim s As String, p As String, f0 As Boolean, f1 As Boolean, f2 As Boolean, arr As Variant
    Dim i As Long, j As Long, k As Long, rr As Long, cc As Long, shCount As Long
    Dim src As ISerializable, f As New AksiFile, search As Object, t As Variant
    
    If fileName <> vbNullString Then
        f.Parse fileName
        s = f.Extension
        If Not (s = "xls" Or s = "xlsx" Or s = "xlsb" Or s = "xlsm") Then Err.Raise 75
        s = f.Name
        p = f.Path
        
        On Error GoTo ErrAppNotOpenA
        Set eApp = GetObject(, "Excel.Application")
            
        On Error GoTo ErrWbkNotOpenA
        Set eWbk = eApp.Workbooks(s)
        If eWbk.Path & "\" <> p Then Err.Raise 9
        
LblSheetSearchA:
        On Error GoTo ErrSheetNotFoundA
        If IsMissing(sheetIndex) Or IsEmpty(sheetIndex) Then sheetIndex = 1
        Set eWst = eWbk.Worksheets(sheetIndex)
        
        On Error GoTo LblTerminationA
        If IsMissing(rangeParam) Or IsEmpty(rangeParam) Then
            'Если rangeParam опущен, то по умолчанию выкладываем данные
            'в первую свободную строку листа.
            Set eRng = eWst.Range("A1")
            If IsEmpty(eRng) Then
                Set eRng = eRng.Resize(, N)
            ElseIf IsEmpty(eRng.Offset(1)) Then
                Set eRng = eRng.Offset(1).Resize(, N)
            Else
                Set eRng = eRng.End(-4121).Resize(, N)
            End If
        Else
            'Если rangeParam - логическое значение, то оно указывает
            'на наличие или отсутствие заголовка.
            If TypeName(rangeParam) = "Boolean" Then
                'True - есть заголовок, данные выкладываем в столбец снизу заголовка.
                If rangeParam Then
                    If header <> vbNullString Then
                        On Error Resume Next
                        Set search = eWst.Cells.Find(What:=header, LookIn:=xlValues, LookAt:= _
                        xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                        MatchCase:=False, SearchFormat:=True)
                        On Error GoTo LblTerminationA
                        'Если заголовок не найден, то создаем новый столбец
                        If search Is Nothing Then 'с требуемым заголовком.
                            Set eRng = eWst.Range("A1")
                            If Not IsEmpty(eRng) Then
                                If IsEmpty(eRng.Offset(, 1)) Then
                                    Set eRng = eRng.Offset(, 1)
                                Else
                                    Set eRng = eRng.End(-4161).Offset(, 1)
                                End If
                            End If
                            eRng.Font.Bold = True
                            eRng = header
                            Set eRng = eRng.Offset(1).Resize(N)
                        Else 'Если нашли заголовок...
                            Set eRng = search.Offset(1)
                            'При необходимости очищаем его от старых данных.
                            If Not IsEmpty(eRng) Then
                                If IsEmpty(eRng.Offset(1)) Then
                                    eRng.ClearContents
                                Else
                                    eWst.Range(eRng, eRng.End(-4121)).ClearContents
                                End If
                            End If
                            Set eRng = eRng.Resize(N) 'И потом заносим новые.
                        End If
                    Else 'Если заголовое нужен, но его текст не задан...
                        'Находим подходящий столбец.
                        Set eRng = eWst.Range("A1")
                        If Not IsEmpty(eRng) Then
                            If IsEmpty(eRng.Offset(, 1)) Then
                                Set eRng = eRng.Offset(, 1)
                            Else
                                Set eRng = eRng.End(-4161).Offset(, 1)
                            End If
                        End If
                        eRng.Font.Bold = True
                        'Просматриваем все существующие заголовки и выбираем
                        'подходящее (неповторяющееся) название для нового столбца.
                        If eRng.Column > 1 Then
                            arr = eWst.Range(eWst.Range("A1"), eRng.Offset(, -1)).Value
                            k = UBound(arr, 2)
                            Do
                                j = 0
                                For i = 1 To k - 1
                                    If arr(1, i) > arr(1, i + 1) Then
                                        t = arr(1, i)
                                        arr(1, i) = arr(1, i + 1)
                                        arr(1, i + 1) = t
                                        j = j + 1
                                    End If
                                Next i
                            Loop While j > 0
                            s = "Column0"
                            j = 0
                            For i = 1 To k - 1
                                If arr(1, i) = s Then
                                    j = j + 1
                                    s = "Column" & j
                                End If
                            Next i
                            eRng = s
                        Else 'Если нет других заголовков, то "Column0" - заголовок по умолчанию.
                            eRng = "Column0"
                        End If
                        Set eRng = eRng.Offset(1).Resize(N)
                    End If
                'False - заголовка нет, данные выкладываем в первую свободную строку листа.
                Else
                    Set eRng = eWst.Range("A1")
                    If IsEmpty(eRng) Then
                        Set eRng = eRng.Resize(, N)
                    ElseIf IsEmpty(eRng.Offset(1)) Then
                        Set eRng = eRng.Offset(1).Resize(, N)
                    Else
                        Set eRng = eRng.End(-4121).Resize(, N)
                    End If
                End If
            'Если rangeParam - строка, то это должен быть адрес диапазона.
            ElseIf TypeName(rangeParam) = "String" Then
                Set eRng = eWst.Range(rangeParam)
            Else
                Err.Raise 5
            End If
        End If
    Else
        Set eRng = rangeParam
    End If
    
    On Error Resume Next 'Проверка на поддержку свойства Value.
    t = a(0).Value
    f2 = Err.Number = 438
    
    On Error GoTo LblTerminationA
    'Если искомый диапазон - непрерывный, то заполняем массив в памяти и выкладываем
    'его на лист одним движением, иначе поочередно заполняем ячейки диапазона.
    If eRng.Areas.Count = 1 Then
        i = 0
        k = 0
        rr = eRng.Rows.Count
        cc = eRng.Columns.Count
        If f2 Then 'Выбираем способ заполнения в зависимости от поддержки свойства Value.
            ReDim arrS(0 To rr - 1, 0 To cc - 1) As String
            Do While i <= rr - 1
                For j = 0 To cc - 1
                    k = i * cc + j
                    If k = N Then Exit Do
                    Set src = a(k)
                    arrS(i, j) = src.Serialize
                Next j
                i = i + 1
            Loop
            eRng = arrS
        Else
            ReDim arrV(0 To rr - 1, 0 To cc - 1) As Variant
            Do While i <= rr - 1
                For j = 0 To cc - 1
                    k = i * cc + j
                    If k = N Then Exit Do
                    arrV(i, j) = a(k)
                Next j
                i = i + 1
            Loop
            eRng = arrV
        End If
    Else
        If f2 Then 'Выбираем способ заполнения в зависимости от поддержки свойства Value.
            For Each eCell In eRng.Cells
                Set src = a(k)
                eCell = src.Serialize
                k = k + 1
            Next eCell
        Else
            For Each eCell In eRng.Cells
                eCell = a(k)
                k = k + 1
            Next eCell
        End If
    End If
    On Error GoTo 0
    If f1 Then eWbk.Close True
    If f0 Then eApp.Quit
    Exit Sub
 
ErrAppNotOpenA:
    If Err.Number = 429 Then 'Приложение Excel не открыто.
        f0 = True
        Set eApp = CreateObject("Excel.Application")
        Resume Next
    Else
        GoTo LblTerminationA
    End If
 
ErrWbkNotOpenA:
    If Err.Number = 9 Then 'Искомая книга не открыта в текущем приложении Excel.
        f1 = True
        Resume LblCreateWorkbookA
    Else
        GoTo LblTerminationA
    End If
 
LblCreateWorkbookA:
    On Error GoTo ErrWbkNotExistsA
    Set eWbk = eApp.Workbooks.Open(fileName)
    GoTo LblSheetSearchA
 
ErrWbkNotExistsA:
    If Err.Number = 1004 Then 'Искомая книга вообще не существует.
        Set eWbk = eApp.Workbooks.Add
        f.Catalog.MakeSureCatalogExists
        eWbk.SaveAs fileName
        Resume Next
    Else
        GoTo LblTerminationA
    End If
 
ErrSheetNotFoundA:
    If Err.Number = 9 Then 'Искомый лист не найден в книге.
        If TypeName(sheetIndex) = "Byte" Or TypeName(sheetIndex) = "Integer" Or TypeName(sheetIndex) = "Long" Then
            If sheetIndex > 0 And sheetIndex <= 100 Then
                shCount = eWbk.Sheets.Count
                eWbk.Sheets.Add After:=eWbk.Sheets(shCount), Count:=sheetIndex - shCount
                Resume
            Else
                Err.Raise 9
            End If
        ElseIf TypeName(sheetIndex) = "String" Then
            eWbk.Sheets.Add.Name = sheetIndex
            Resume
        Else
            Err.Raise 5
        End If
    Else
        GoTo LblTerminationA
    End If
    
LblTerminationA: 'Аварийное завершение программы с освобождением использованных ресурсов.
    If f1 Then
        eWbk.Close False
        Set eWbk = Nothing
    End If
    If f0 Then
        eApp.Quit
        Set eApp = Nothing
    End If
    Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub
'Процедура для чтения данных в вектор из файла Excel с именем fileName, листа sheetIndex и
'диапазона с адресом rangeParam или диапазона с заголовком header. Если имя fileName
'не указано, то через rangeParam передается ссылка на диапазон, из которого читаются данные.
'Базовый объект вектора должен поддерживать либо свойство по умолчанию Value, либо интерфейс ISerializable.
Public Sub GetData_ExcelFile(Optional ByVal rangeParam As Variant, Optional ByVal fileName As String, _
Optional ByVal sheetIndex As Variant, Optional ByVal header As String)
 
    Dim eApp As Object, eWbk As Object, eWst As Object, eRng As Object, eCell As Object
    Dim f0 As Boolean, f1 As Boolean, f2 As Boolean, t As Variant, arr As Variant
    Dim i As Long, j As Long, k As Long, rr As Long, cc As Long, f As New AksiFile
    Dim s As String, p As String, src As ISerializable, search As Object
    If fileName <> vbNullString Then
        f.Parse fileName
        s = f.Name
        p = f.Path
        
        On Error GoTo ErrAppNotOpenB
        Set eApp = GetObject(, "Excel.Application")
            
        On Error GoTo ErrWbkNotOpenB
        Set eWbk = eApp.Workbooks(s)
        If eWbk.Path & "\" <> p Then Err.Raise 9
        
        On Error GoTo LblTerminationB
        If IsMissing(sheetIndex) Or IsEmpty(sheetIndex) Then
            Set eWst = eWbk.Worksheets(1)
        Else
            Set eWst = eWbk.Worksheets(sheetIndex)
        End If
        If IsMissing(rangeParam) Or IsEmpty(rangeParam) Or (TypeName(rangeParam) = "Boolean" And rangeParam = True) Then
            If header <> vbNullString Then 'Если задан текст заголовка...
                On Error Resume Next 'То ищем заголовок.
                Set search = eWst.Cells.Find(What:=header, LookIn:=xlValues, LookAt:= _
                xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=True)
                On Error GoTo LblTerminationB
                If search Is Nothing Then 'Если заголовок не найден - перерываем работу.
                    Err.Raise 9
                Else 'Иначе находим и обрабатываем данные снизу заголока (если они есть).
                    Set eRng = search.Offset(1)
                    If IsEmpty(eRng) Then Exit Sub _
                    Else If Not IsEmpty(eRng.Offset(1)) _
                    Then Set eRng = eWst.Range(eRng, eRng.End(-4121))
                End If
            Else
                Err.Raise 5
            End If
        ElseIf TypeName(rangeParam) = "Boolean" And rangeParam = False Then
            Err.Raise 5
        Else
            Set eRng = eWst.Range(rangeParam)
        End If
    Else
        Set eRng = rangeParam
    End If
    
    On Error Resume Next 'Проверка на поддержку свойства Value.
    a(0).Value = t
    f2 = Err.Number = 438
    
    On Error GoTo LblTerminationB
    'Если искомый диапазон - непрерывный, то снимаем его с листа в массив
    'и обрабатываем данные в массиве, иначе поочередно обрабатываем ячейки диапазона.
    If eRng.Areas.Count = 1 Then
        arr = eRng
        rr = UBound(arr)
        cc = UBound(arr, 2)
        i = 1
        If f2 Then 'Выбираем способ заполнения в зависимости от поддержки свойства Value.
            Do While i <= rr
                For j = 1 To cc
                    k = (i - 1) * cc + j - 1
                    If k = N Then Exit Do
                    Set src = a(k)
                    src.Unserialize arr(i, j)
                Next j
                i = i + 1
            Loop
        Else
            Do While i <= rr
                For j = 1 To cc
                    k = (i - 1) * cc + j - 1
                    If k = N Then Exit Do
                    a(k) = arr(i, j)
                Next j
                i = i + 1
            Loop
        End If
    Else
        If f2 Then 'Выбираем способ заполнения в зависимости от поддержки свойства Value.
            For Each eCell In eRng.Cells
                Set src = a(k)
                src.Unserialize eCell.Value
                k = k + 1
            Next eCell
        Else
            For Each eCell In eRng.Cells
                a(k) = eCell.Value
                k = k + 1
            Next eCell
        End If
    End If
    On Error GoTo 0
    If f1 Then eWbk.Close False
    If f0 Then eApp.Quit
    Exit Sub
 
ErrAppNotOpenB:
    If Err.Number = 429 Then 'Приложение Excel не открыто.
        f0 = True
        Set eApp = CreateObject("Excel.Application")
        Resume Next
    Else
        GoTo LblTerminationB
    End If
 
ErrWbkNotOpenB:
    If Err.Number = 9 Then 'Искомая книга не открыта в текущем приложении Excel.
        f1 = True
        Set eWbk = eApp.Workbooks.Open(fileName)
        Resume Next
    Else
        GoTo LblTerminationB
    End If
    
LblTerminationB: 'Аварийное завершение программы с освобождением использованных ресурсов.
    If f1 Then
        eWbk.Close False
        Set eWbk = Nothing
    End If
    If f0 Then
        eApp.Quit
        Set eApp = Nothing
    End If
    Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub
'Преобразование времени в секундах в часы, минуты (от 0 до 59) и секунды (от 0 до 59).
Private Sub SecsToHMS(ByVal secs As Long, ByRef hms() As Integer)
    hms(2) = secs Mod 60
    secs = secs \ 60
    hms(1) = secs Mod 60
    hms(0) = secs \ 60
End Sub
'Функция, выполняющая корректное сложение дат, представленных в разных форматах.
Private Function SumDates(ByVal d1 As Date, ByVal d2 As Date) As Date
    Dim d1p(0 To 5) As Integer, d2p(0 To 5) As Integer
    Dim i As Long, k As Long, arr As Variant
    arr = Array("yyyy", "m", "d", "h", "n", "s")
    For i = 0 To 5
        d1p(i) = DatePart(arr(i), d1)
        d2p(i) = DatePart(arr(i), d2)
    Next i
    k = 4 * (CLng((d1p(0) = 1899) And (d1p(1) = 12) And (d1p(2) = 30)) + _
    2 * CLng((d1p(3) = 0) And (d1p(4) = 0) And (d1p(5) = 0))) + _
    CLng((d2p(0) = 1899) And (d2p(1) = 12) And (d2p(2) = 30)) + _
    2 * CLng((d2p(3) = 0) And (d2p(4) = 0) And (d2p(5) = 0))
    Select Case k
        Case 0
            For i = 0 To 5
                d1 = DateAdd(arr(i), d2p(i), d1)
            Next i
        Case -1, -9
            For i = 3 To 5
                d1 = DateAdd(arr(i), d2p(i), d1)
            Next i
        Case -2, -10
            For i = 0 To 2
                d1 = DateAdd(arr(i), d2p(i), d1)
            Next i
        Case -4, -5, -6
            For i = 3 To 5
                d2 = DateAdd(arr(i), d1p(i), d2)
            Next i
        Case -8, -10
            For i = 0 To 2
                d2 = DateAdd(arr(i), d1p(i), d2)
            Next i
    End Select
    Select Case k
        Case 0, -1, -2, -3, -7, -9, -10, -11
            SumDates = d1
        Case -4, -5, -6, -8, -12, -13, -14, -15
            SumDates = d2
    End Select
End Function

2
Аксима
5727 / 1177 / 185
Регистрация: 12.12.2012
Сообщений: 963
25.06.2014, 17:23 #72
Глава первая: "Обзор базовых структур массивов" (продолжение)

Код класса AksiVector (продолжение)

Visual Basic
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
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
'Процедура для заполения вектора данными, сгенерированными с помощью генератора случайных чисел.
'Данные генерируются в диапазоне от low_val (включительно) до high_val (включительно), либо в
'диапазоне, определенном по умолчанию. Параметр seed определяет число, используемое для
'генерации последовательности (псевдо)случайных чисел, а параметр floatPrecision - точность,
'до которой округляются вещественные числа (если параметр floatPrecision не задан, вещественные
'числа не округляются). В качестве данных генератор умеет генерировать числа, символы и даты.
Public Sub GetData_RandomGenerator(Optional ByVal low_val, Optional ByVal high_val, _
Optional ByVal seed, Optional ByVal floatPrecision)
    Dim i As Long, s As Long, d As Date, t As Date, multiplier As Long, arr As Variant
    Dim d1p(0 To 5) As Integer, d2p(0 To 5) As Integer, dp(0 To 2) As Integer
    Dim d1f As Long, d2f As Long, dif As Long, k As Long
    If IsMissing(seed) Then Randomize Else Randomize Val(seed) 'Инициализируем генератор.
    If IsMissing(low_val) Then 'Используем границы по умолчанию.
        If IsMissing(high_val) Then
            Select Case TypeName(a(0))
                Case "AksiInteger"
                    For i = 0 To N - 1
                        a(i) = Int(100 * Rnd)
                    Next i
                Case "AksiFloat"
                    If IsMissing(floatPrecision) Then
                        For i = 0 To N - 1
                            a(i) = 100 * Rnd - 50
                        Next i
                    Else
                        If IsNumeric(floatPrecision) Then
                            floatPrecision = CByte(Val(floatPrecision))
                            If floatPrecision = 0 Then
                                For i = 0 To N - 1
                                    a(i) = Int(101 * Rnd - 50)
                                Next i
                            Else
                                multiplier = 10 ^ floatPrecision
                                For i = 0 To N - 1
                                    a(i) = Int(2 * (Rnd - 0.5) * multiplier) / multiplier
                                Next i
                            End If
                        Else
                            Err.Raise 13
                        End If
                    End If
                Case "AksiChar"
                    For i = 0 To N - 1
                        a(i) = Int(256 * Rnd)
                    Next i
                Case "AksiDate"
                        high_val = Now
                        low_val = DateAdd("yyyy", -1, high_val)
                        arr = Array("yyyy", "m", "d", "h", "n", "s")
                        For i = 3 To 5
                            d1p(i) = DatePart(arr(i), low_val)
                        Next i
                        dif = DateDiff("d", low_val, high_val)
                        For i = 0 To N - 1
                            d = DateAdd("d", Int((dif + 1) * Rnd), low_val)
                            SecsToHMS Int(86400 * Rnd), dp
                            a(i) = SumDates(d, TimeSerial(dp(0), dp(1), dp(2)))
                        Next i
                Case Else
                    Err.Raise 5
            End Select
        Else
            Err.Raise 5
        End If
    Else 'Используем границы, заданные пользователем.
        If IsMissing(high_val) Then
            Err.Raise 5
        Else
            Select Case TypeName(a(0))
                Case "AksiInteger"
                    If IsNumeric(low_val) And IsNumeric(high_val) Then
                        low_val = Val(low_val)
                        high_val = Val(high_val)
                        If low_val - CLng(low_val) = 0 And high_val - CLng(high_val) = 0 Then
                            If low_val > high_val Then
                                Err.Raise 5, , "Неверные аргументы - нижняя граница больше верхней" & _
                                vbCr & "(Invalid argument(s) - low_val is greater than high_val)."
                            Else
                                For i = 0 To N - 1
                                    a(i) = Int((high_val - low_val + 1) * Rnd + low_val)
                                Next i
                            End If
                        Else
                            Err.Raise 5, , "Неверные аргументы - границы должны быть целыми" & _
                            vbCr & "(Invalid argument(s) - bounds must be integers)."
                        End If
                    Else
                        Err.Raise 13
                    End If
                Case "AksiFloat"
                    If IsNumeric(low_val) And IsNumeric(high_val) Then
                        low_val = Val(low_val)
                        high_val = Val(high_val)
                        If low_val > high_val Then
                            Err.Raise 5, , "Неверные аргументы - нижняя граница больше верхней" & _
                            vbCr & "(Invalid argument(s) - low_val is greater than high_val)."
                        Else
                            If IsMissing(floatPrecision) Then
                                For i = 0 To N - 1
                                    a(i) = (high_val - low_val) * Rnd + low_val
                                Next i
                            Else
                                If IsNumeric(floatPrecision) Then
                                    floatPrecision = CByte(Val(floatPrecision))
                                    multiplier = 10 ^ floatPrecision
                                    For i = 0 To N - 1
                                        a(i) = (Int((high_val - low_val) * Rnd + low_val) * multiplier) / multiplier
                                    Next i
                                Else
                                    Err.Raise 13
                                End If
                            End If
                        End If
                    Else
                        Err.Raise 13
                    End If
                Case "AksiChar"
                    If TypeName(low_val) = "String" And TypeName(high_val) = "String" Then
                        If Len(low_val) = 1 And Len(high_val) = 1 Then
                            low_val = Asc(low_val)
                            high_val = Asc(high_val)
                            If low_val > high_val Then
                                Err.Raise 5, , "Неверные аргументы - нижняя граница больше верхней" & _
                                vbCr & "(Invalid argument(s) - low_val is greater than high_val)."
                            Else
                                For i = 0 To N - 1
                                    a(i) = Int((high_val - low_val + 1) * Rnd + low_val)
                                Next i
                            End If
                        Else
                            Err.Raise 5, , "Неверные аргументы - границы представляются 1 символом." & _
                            vbCr & "(Invalid argument(s) - bounds must be 1-char symbols)."
                        End If
                    Else
                        low_val = CByte(Val(low_val))
                        high_val = CByte(Val(high_val))
                        If low_val > high_val Then
                            Err.Raise 5, , "Неверные аргументы - нижняя граница больше верхней" & _
                            vbCr & "(Invalid argument(s) - low_val is greater than high_val)."
                        Else
                            For i = 0 To N - 1
                                a(i) = Int((high_val - low_val + 1) * Rnd + low_val)
                            Next i
                        End If
                    End If
                Case "AksiDate"
                    If IsDate(low_val) And IsDate(high_val) Then
                        low_val = CDate(low_val)
                        high_val = CDate(high_val)
                        'Разбиваем обе даты на составляющие.
                        arr = Array("yyyy", "m", "d", "h", "n", "s")
                        For i = 0 To 5
                            d1p(i) = DatePart(arr(i), low_val)
                            d2p(i) = DatePart(arr(i), high_val)
                        Next i
                        'Получаем числа, характеризующие формат дат.
                        d1f = CLng((d1p(0) = 1899) And (d1p(1) = 12) And (d1p(2) = 30)) + _
                            2 * CLng((d1p(3) = 0) And (d1p(4) = 0) And (d1p(5) = 0))
                        d2f = CLng((d2p(0) = 1899) And (d2p(1) = 12) And (d2p(2) = 30)) + _
                            2 * CLng((d2p(3) = 0) And (d2p(4) = 0) And (d2p(5) = 0))
                        k = 4 * d1f + d2f
                        Select Case k 'Анализируем их формат.
                            Case 0, -2, -8 'Если одна из дат в полном формате, то...
                                If low_val > high_val Then
                                    Err.Raise 5, , "Неверные аргументы - нижняя граница больше верхней" & _
                                    vbCr & "(Invalid argument(s) - low_val is greater than high_val)."
                                Else
                                    '1) если они определяют один и тот же день, то генерируем только время.
                                    If d1p(0) = d2p(0) And d1p(1) = d2p(1) And d1p(2) = d2p(2) Then
                                        s = 3600& * d1p(3) + 60& * d1p(4) + d1p(5)
                                        dif = 3600& * d2p(3) + 60& * d2p(4) + d2p(5) - s
                                        For i = 0 To N - 1
                                            SecsToHMS Int((dif + 1) * Rnd + s), dp
                                            a(i) = SumDates(DateSerial(d1p(0), d1p(1), d1p(2)), _
                                            TimeSerial(dp(0), dp(1), dp(2)))
                                        Next i
                                    Else '2) если они определяют разные дни, генерируем сначала дату, потом время.
                                        dif = DateDiff("d", low_val, high_val)
                                        For i = 0 To N - 1
                                            d = DateAdd("d", Int((dif + 1) * Rnd), low_val)
                                            'Если сгенерированная дата приходится на тот же день,
                                            'что указан в нижней границе, то генерируем время, начиная от
                                            'указанного в нижней границе, и до 23:59:59.
                                            If d = DateSerial(d1p(0), d1p(1), d1p(2)) Then
                                                s = 3600& * d1p(3) + 60& * d1p(4) + d1p(5)
                                                SecsToHMS Int((86400 - s) * Rnd + s), dp
                                                a(i) = SumDates(d, TimeSerial(dp(0), dp(1), dp(2)))
                                            'Иначе, если сгенерированная дата приходится на тот же день,
                                            'что указан в верхней границе, то генерируем время, начиная от
                                            '0:00:00, и до указанного в верхней границе.
                                            ElseIf d = DateSerial(d2p(0), d2p(1), d2p(2)) Then
                                                s = 3600& * d2p(3) + 60& * d2p(4) + d2p(5)
                                                SecsToHMS Int((s + 1) * Rnd), dp
                                                a(i) = SumDates(d, TimeSerial(dp(0), dp(1), dp(2)))
                                            'В остальных случаях генерируем время от 0:00:00 до 23:59:59.
                                            Else
                                                SecsToHMS Int(86400 * Rnd), dp
                                                a(i) = SumDates(d, TimeSerial(dp(0), dp(1), dp(2)))
                                            End If
                                        Next i
                                    End If
                                End If
                            Case -1, -4, -5, -9, -12, -13 'Если одна из дат или обе в формате времени, то...
                                'Сверяем только время.
                                If TimeSerial(d1p(3), d1p(4), d1p(5)) > TimeSerial(d2p(3), d2p(4), d2p(5)) Then
                                    Err.Raise 5, , "Неверные аргументы - нижняя граница больше верхней" & _
                                    vbCr & "(Invalid argument(s) - low_val is greater than high_val)."
                                Else
                                    s = 3600& * d1p(3) + 60& * d1p(4) + d1p(5)
                                    dif = 3600& * d2p(3) + 60& * d2p(4) + d2p(5) - s
                                    Select Case k
                                        Case -1
                                            d = DateSerial(d1p(0), d1p(1), d1p(2))
                                        Case -4
                                            d = DateSerial(d2p(0), d2p(1), d2p(2))
                                        Case -5
                                            d = #12:00:00 AM#
                                        Case -9
                                            d = low_val
                                        Case -12
                                            d = DateSerial(d2p(0), d2p(1), d2p(2))
                                        Case -13
                                            d = #12:00:00 AM#
                                    End Select
                                    For i = 0 To N - 1
                                        SecsToHMS Int((dif + 1) * Rnd + s), dp
                                        t = TimeSerial(dp(0), dp(1), dp(2))
                                        a(i) = SumDates(d, TimeSerial(dp(0), dp(1), dp(2)))
                                    Next i
                                End If
                            Case -3, -6, -7, -11
                                Err.Raise 5, , "Неверные аргументы - нижняя граница больше верхней" & _
                                vbCr & "(Invalid argument(s) - low_val is greater than high_val)."
                            Case -10 'Если обе даты указаны в формате без времени.
                                If low_val > high_val Then
                                    Err.Raise 5, , "Неверные аргументы - нижняя граница больше верхней" & _
                                    vbCr & "(Invalid argument(s) - low_val is greater than high_val)."
                                Else
                                    dif = DateDiff("d", low_val, high_val)
                                    For i = 0 To N - 1
                                        a(i) = DateAdd("d", Int((dif + 1) * Rnd), low_val)
                                    Next i
                                End If
                            Case -14
                                For i = 0 To N - 1
                                    a(i) = high_val
                                Next i
                            Case -15
                                For i = 0 To N - 1
                                    a(i) = #12:00:00 AM#
                                Next i
                        End Select
                    Else
                        Err.Raise 13
                    End If
                Case Else
                    Err.Raise 5
            End Select
        End If
    End If
End Sub
'Процедура пузырковой сортировки. Параметр direction определяет
'порядок сортировки (восходящая или нисходящая). Параметр cmp -
'- объект, определяющий способ сравнения сортируемых объектов.
'При отсутствии объекта применяется интерфейс IComparable.
Private Sub BubbleSort(ByVal direction As AoSortOrder, Optional ByVal cmp As IComparer)
    Dim oneToCompare As IComparable
    Dim one As Object, another As Object
    Dim i As Long, j As Long, p As Long, t As Object
    If cmp Is Nothing Then
        For i = 1 To N - 1 'i определяет количество "всплывших" элементов.
            p = 0 'Счетчик перестановок.
            For j = 0 To N - i - 1 'Просматриваем все элементы, кроме "всплывших".
                Set oneToCompare = a(j)
                Set another = a(j + 1)
                'Если текущий элемент больше следующего (или меньше - в зависимости
                'от значения direction), то выполняем перестановку элементов.
                If oneToCompare.CompareTo(another) = direction Then
                    Set t = a(j)
                    Set a(j) = a(j + 1)
                    Set a(j + 1) = t
                    p = p + 1 'Увеличиваем счетчик перестановок.
                End If
            Next j
            If p = 0 Then Exit For 'Если не было произведено ни одной перестановки,
            'значит, последовательность уже отсортирована. Выходим из цикла.
        Next i
    Else 'То же, что и выше, но сравнение производится с помощью объекта cmp.
        For i = 1 To N - 1
            p = 0
            For j = 0 To N - i - 1
                Set one = a(j)
                Set another = a(j + 1)
                If cmp.Compare(one, another) = direction Then
                    Set t = a(j)
                    Set a(j) = a(j + 1)
                    Set a(j + 1) = t
                    p = p + 1
                End If
            Next j
            If p = 0 Then Exit For
        Next i
    End If
End Sub
'Процедура сортировки выборками. Параметр direction определяет
'порядок сортировки (восходящая или нисходящая). Параметр cmp -
'- объект, определяющий способ сравнения сортируемых объектов.
'При отсутствии объекта применяется интерфейс IComparable.
Private Sub SelectionSort(ByVal direction As AoSortOrder, Optional ByVal cmp As IComparer)
    Dim oneToCompare As IComparable
    Dim one As Object, another As Object
    Dim i As Long, j As Long, p As Long, t As Object
    If cmp Is Nothing Then
        For i = N - 1 To 1 Step -1 'i определяет индекс элемента для обмена.
            Set oneToCompare = a(0)
            p = 0
            For j = 1 To i 'Просматриваем все элементы вектора до обмениваемого.
                Set another = a(j)
                'Если текущий элемент больше выбранного (или меньше - в зависимости
                'от значения direction), то берем его как максимум (минимум).
                If oneToCompare.CompareTo(another) = direction Then
                    Set oneToCompare = another
                    p = j
                End If
            Next j
            If p <> i Then
                Set t = a(i)
                Set a(i) = a(p)
                Set a(p) = t
            End If
        Next i
    Else 'То же, что и выше, но сравнение производится с помощью объекта cmp.
        For i = N - 1 To 1
            Set oneToCompare = a(0)
            p = 0
            For j = 1 To i
                Set another = a(j)
                If cmp.Compare(one, another) = direction Then
                    Set oneToCompare = another
                    p = j
                End If
            Next j
            If p <> i Then
                Set t = a(i)
                Set a(i) = a(p)
                Set a(p) = t
            End If
        Next i
    End If
End Sub

2
Аксима
5727 / 1177 / 185
Регистрация: 12.12.2012
Сообщений: 963
25.06.2014, 17:24 #73
Глава первая: "Обзор базовых структур массивов" (продолжение)

Код класса AksiVector (продолжение)

Visual Basic
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
'Процедура сортировки вставками. Параметр direction определяет
'порядок сортировки (восходящая или нисходящая). Параметр cmp -
'- объект, определяющий способ сравнения сортируемых объектов.
'При отсутствии объекта применяется интерфейс IComparable.
Private Sub InsertionSort(ByVal direction As AoSortOrder, Optional ByVal cmp As IComparer)
    Dim oneToCompare As IComparable
    Dim one As Object, another As Object
    Dim i As Long, j As Long, f As Boolean, c As New Collection
    c.Add a(0)
    If cmp Is Nothing Then
        For i = 1 To N - 1 'i определяет индекс вставляемого элемента.
            Set another = a(i)
            f = True
            'Ищем элемент, перед которым следует производить вставку.
            For j = 1 To c.Count
                Set oneToCompare = c(j)
                If oneToCompare.CompareTo(another) = direction Then
                    c.Add Item:=a(i), Before:=j
                    f = False
                    Exit For
                End If
            Next j
            'Если не нашли элемента, перед которым следует производить вставку, то
            'просто добавляем элемент в конец коллекции.
            If f Then c.Add a(i)
        Next i
        For i = 0 To N - 1
            Set a(i) = c(i + 1)
        Next i
    Else 'То же, что и выше, но сравнение производится с помощью объекта cmp.
        For i = 1 To N - 1
            Set another = a(i)
            f = True
            For j = 1 To c.Count
                Set one = c(j)
                If cmp.Compare(one, another) = direction Then
                    c.Add Item:=a(i), Before:=j
                    f = False
                    Exit For
                End If
            Next j
            If f Then c.Add a(i)
        Next i
        For i = 0 To N - 1
            Set a(i) = c(i + 1)
        Next i
    End If
End Sub
'Процедура сортировки элементов вектора. Параметр method определяет алгоритм, применяемый
'при сортировке, параметр direction определяет порядок сортировки (восходящая или нисходящая).
'Параметр cmp - объект, определяющий способ сравнения сортируемых объектов. Если он
'не используется, то применяется способ сравения, встроенный в базовый элемент вектора
'(для этого базовый элемент должен поддерживать интерфейс IComparable).
Public Sub Sort(Optional ByVal method As AoSortMethod = AO_BUBBLE, _
Optional ByVal direction As AoSortOrder = AO_ASC, Optional ByVal cmp As IComparer)
    Select Case method
        Case AO_BUBBLE
            BubbleSort direction, cmp
        Case AO_SELECTION
            SelectionSort direction, cmp
        Case AO_INSERTION
            InsertionSort direction, cmp
        Case Else
            Err.Raise 5
    End Select
End Sub
'Процедура группировки и подсчета элементов вектора целых чисел.
Public Function CountUnique() As AksiMatrix
    Dim i As Long, k As Long, c As IComparable, v As AksiVector, m As AksiMatrix
    Select Case TypeName(a(0))
        Case "AksiInteger", "AksiChar", "AksiString"
            Set v = ICloneable_Copy
            v.Sort
            Set c = v(0)
            k = 1
            For i = 1 To N - 1
                If c.CompareTo(v(i)) Then
                    Set c = v(i)
                    k = k + 1
                End If
            Next i
            Set m = New AksiMatrix
            m.Init New AksiInteger, k, 2
            Set c = v(0)
            k = 0
            m(0, 0).Value = v(0).Value
            m(0, 1) = 1
            For i = 1 To N - 1
                If c.CompareTo(v(i)) Then
                    Set c = v(i)
                    k = k + 1
                    m(k, 0).Value = v(i).Value
                    m(k, 1) = 1
                Else
                    m(k, 1) = m(k, 1) + 1
                End If
            Next i
            Set CountUnique = m
        Case Else
            Err.Raise 5
    End Select
End Function
'Функция для получения максимального элемента вектора.
Public Function Max(Optional ByVal cmp As IComparer) As Object
    Dim i As Long, o As Object, c As IComparable
    Set o = a(0)
    If cmp Is Nothing Then
        Set c = a(0)
        For i = 1 To N - 1
            If c.CompareTo(a(i)) = -1 Then
                Set c = a(i)
                Set o = a(i)
            End If
        Next i
    Else
        For i = 1 To N - 1
            If cmp.Compare(o, a(i)) = -1 Then Set o = a(i)
        Next i
    End If
    Set Max = o
End Function
'Функция для получения минимального элемента вектора.
Public Function Min(Optional ByVal cmp As IComparer) As Object
    Dim i As Long, o As Object, c As IComparable
    Set o = a(0)
    If cmp Is Nothing Then
        Set c = a(0)
        For i = 1 To N - 1
            If c.CompareTo(a(i)) = 1 Then
                Set c = a(i)
                Set o = a(i)
            End If
        Next i
    Else
        For i = 1 To N - 1
            If cmp.Compare(o, a(i)) = 1 Then Set o = a(i)
        Next i
    End If
    Set Min = o
End Function
'Сумма элементов числового вектора.
Public Property Get Sum() As Object
    Dim i As Long, o As IMath
    Set o = a(0)
    Set Sum = a(0)
    For i = 1 To N - 1
        Set Sum = o.©(Sum, a(i))
    Next i
End Property
'Произведение элементов числового вектора.
Public Property Get Product() As Object
    Dim i As Long, o As IMath
    Set o = a(0)
    Set Product = a(0)
    For i = 1 To N - 1
        Set Product = o.·(Product, a(i))
    Next i
End Property
'Среднее арифметческое элементов числового вектора.
Public Property Get Average() As Object
    Dim i As Long, c As IConvertible, o As IMath
    If TypeOf a(0) Is AksiInteger Then Set o = New AksiFloat Else Set o = a(0)
    Set c = a(0)
    Set Average = o.®(Sum, c.Convert(N))
End Property
'Вызов функции для каждого элемента вектора.
Public Function GroupOperation(ByVal oper As String, opType As VbCallType, returnOb As Object) As AksiVector
    Dim i As Long, v As New AksiVector
    v.Init returnOb, N
    For i = 0 To N - 1
        v(i) = CallByName(a(i), oper, opType)
    Next i
    Set GroupOperation = v
End Function


Код класса AksiMatrix

Visual Basic
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
'________________________________________________________________
'______________________                    ______________________
'_____________________   Модуль AksiMatrix  _____________________
'____________________      Версия: 0.9.0     ____________________
'___________________       Автор: Aksima      ___________________
'___________________  Библиотека: AksiArrays  ___________________
'________________________________________________________________
'_____                                                      _____
'_____  Назначение: Реализует матрицу - двухмерный массив.  _____
'________________________________________________________________
 
Enum AoMatrixReadOrder 'Порядок чтения элементов матрицы.
    AO_BYROWS 'Матрица считывается по строкам.
    AO_BYCOLS 'Матрица считывается по столбцам.
End Enum
Enum AoMatrixParts 'Перечисление частей матрицы.
    AO_WHOLE        'Вся матрица.
    AO_ROWS         'Строки матрицы.
    AO_COLUMNS      'Столбцы матрицы.
    AO_MAIN_DIAG    'Главная диагональ матрицы.
    AO_SIDE_DIAG    'Побочная диагональ матрицы.
    AO_UP_MAIN_EXC      'Элементы выше главной диагонали.
    AO_DOWN_MAIN_EXC    'Элементы ниже главной диагонали.
    AO_UP_SIDE_EXC      'Элементы выше побочной диагонали.
    AO_DOWN_SIDE_EXC    'Элементы ниже побочной диагонали.
    AO_UP_MAIN_INC      'Главная диагональ и элементы выше ее.
    AO_DOWN_MAIN_INC    'Главная диагональ и элементы ниже ее.
    AO_UP_SIDE_INC      'Побочная диагональ и элементы выше ее.
    AO_DOWN_SIDE_INC    'Побочная диагональ и элементы ниже ее.
End Enum
Dim a() As Object
Dim r As Long, c As Long
'Инициализация матрицы с размерностями rowSize, colSize и базовым объектом base.
'Базовый объект должен поддерживать интерфейс IFactory.
Public Sub Init(ByVal base As Object, ByVal rowSize As Long, ByVal colSize As Long)
    Dim i As Long, j As Long, f As IFactory
    r = rowSize
    c = colSize
    Set f = base
    ReDim a(0 To r - 1, 0 To c - 1) As Object
    For i = 0 To r - 1
        For j = 0 To c - 1
            Set a(i, j) = f.NewOb
        Next j
    Next i
End Sub
'Получение ссылки на элемент матрицы по индексам.
Public Property Get Item(ByVal rowIndex As Long, ByVal colIndex As Long) As Object
    Set Item = a(rowIndex, colIndex)
End Property
'Установка ссылки для элемента матрицы с заданными индексами.
Public Property Set Item(ByVal rowIndex As Long, ByVal colIndex As Long, ByVal eNew As Object)
    If TypeName(a(rowIndex, colIndex)) = TypeName(eNew) Then Set a(rowIndex, colIndex) = eNew Else Err.Raise 13
End Property
'Получение общего количества элементов в матрице.
Public Property Get Count() As Long
    Count = r * c
End Property
'Получение количества строк матрицы.
Public Property Get CountRow() As Long
    CountRow = r
End Property
'Получение количества столбцов матрицы.
Public Property Get CountCol() As Long
    CountCol = c
End Property
'Процедура для записи данных из матрицы в текстовый файл с именем fileName.
'Базовый объект матрицы должен поддерживать интерфейс ISerializable.
Public Sub PutData_TextFile(ByVal fileName As String)
    Dim i As Long, j As Long, N As Long, s As String
    Dim t As AksiCatalog, f As New AksiFile, src As ISerializable
    f.Parse fileName
    If f.Path <> "\" Then
        Set src = a(0, 0)
        s = src.Serialize
        For j = 1 To c - 1
            Set src = a(0, j)
            s = s & "," & src.Serialize
        Next j
        For i = 1 To r - 1
            Set src = a(i, 0)
            s = s & vbCrLf & src.Serialize
            For j = 1 To c - 1
                Set src = a(i, j)
                s = s & "," & src.Serialize
            Next j
        Next i
        f.Catalog.MakeSureCatalogExists
        N = FreeFile
        Open fileName For Output As #N
        Print #N, s
        Close #N
    Else
        Set t = New AksiCatalog
        Set f = t.FileFind(f.Name)
        If f Is Nothing Then
            f.Name = fileName
            f.FullNameDialog "Файл " & f.Name & " не найден", "file " & f.Name & " not found"
        ElseIf f.FullName = "\" Then
            f.Name = fileName
            f.FullNameDialog "Файл " & f.Name & " не найден", "file " & f.Name & " not found"
        End If
        Set src = a(0, 0)
        s = src.Serialize
        For j = 1 To c - 1
            Set src = a(0, j)
            s = s & "," & src.Serialize
        Next j
        For i = 1 To r - 1
            Set src = a(i, 0)
            s = s & vbCrLf & src.Serialize
            For j = 1 To c - 1
                Set src = a(i, j)
                s = s & "," & src.Serialize
            Next j
        Next i
        N = FreeFile
        Open f.FullName For Output As #N
        Print #N, s
        Close #N
    End If
End Sub
'Процедура для чтения данных в матрицу из текстового файла с именем fileName.
'Базовый объект матрицы должен поддерживать интерфейс ISerializable.
Public Sub GetData_TextFile(ByVal fileName As String)
    Dim i As Long, j As Long, N As Long, p As Long, q As Long
    Dim s As String, ss As String, e() As String, es As Collection
    Dim f As New AksiFile, t As AksiCatalog, rec As ISerializable
    f.Parse fileName
    If f.Path = "\" Then
        Set t = New AksiCatalog
        Set f = t.FileFind(fileName)
        If f Is Nothing Then
            f.Name = fileName
            f.FullNameDialog "Файл " & f.Name & " не найден", "file " & f.Name & " not found"
        ElseIf f.FullName = "\" Then
            f.Name = fileName
            f.FullNameDialog "Файл " & f.Name & " не найден", "file " & f.Name & " not found"
        End If
    End If
    N = FreeFile
    Open f.FullName For Input As #N
    Set es = New Collection
    Do Until EOF(N) 'Обрабатываем файл до конца.
        Line Input #N, s 'Считываем строку из файла.
        If s <> Chr(29) & Chr(30) Then 'Пропускаем разделитель слоев куба (см. класс AksiCube)
            Set es = New Collection
            'Прежде чем разлагать строку по запятым, выделяем участки, ограниченные
            'парой кавычек, так как запятые внутри кавычек не должны учитываться.
            p = InStr(s, """")
            While p > 0 'Для каждого найденного участка...
                ss = Trim(Left(s, p - 1)) 'Получаем строку слева от первой кавычки.
                'Убираем из полученной строки смежную с первой кавычкой запятую.
                If Right(ss, 1) = "," Then ss = Trim(Left(ss, Len(ss) - 1))
                e = Split(ss, ",") 'Разлагаем строку по запятым.
                For j = 0 To UBound(e)
                    es.Add e(j)
                Next j
                q = InStr(p + 1, s, """") 'Ищем вторую кавычку.
                If q = 0 Then q = Len(s) + 1
                es.Add Mid(s, p + 1, q - p - 1)
                s = Trim(Mid(s, q + 1))
                'Убираем смежную со второй кавычкой запятую.
                If Left(s, 1) = "," Then s = Trim(Mid(s, 2))
                'Анализируем строку после второй кавычки.
                p = InStr(s, """")
            Wend
            e = Split(s, ",") 'Разлагаем всю остальную строку по запятым.
            For j = 0 To UBound(e)
                es.Add e(j)
            Next j
            For j = 0 To IIf(c < es.Count, c - 1, es.Count - 1)
                Set rec = a(i, j)
                rec.Unserialize es(j + 1)
            Next j
            i = i + 1
            If i > r - 1 Then Exit Do 'Если заполнили матрицу - выходим досрочно.
        End If
    Loop
    Close #N
End Sub
'Процедура для вывода целых чисел как есть, чисел в экспоненциальном формате -
'- без дробной части, а остальных - с двумя знаками после запятой.
Private Function CutAfterDecimal(ByVal x As Double) As String
    If InStr(x, Format(0, ".")) Then
        If InStr(x, "E") Then
            CutAfterDecimal = Format(x, "0E+")
        Else
            CutAfterDecimal = Format(x, "0.00")
        End If
    Else
        CutAfterDecimal = x
    End If
End Function
'Процедура для вывода данных из матрицы на диалоговое окно. Ввиду ограничений
'на размер диалогового окна, вывод поддерживается только для матриц на основе
'классов AksiInteger, AksiFloat или AksiChar, либо матриц, элементы которых
'выражаются строками длиной не более восьми элементов.
Public Sub PutData_DialogBox(Optional ByVal title As String)
    Dim i As Long, j As Long, s As String, t As String, src As ISerializable
    If r > 12 Or c > 8 Then Err.Raise vbObjectError, , "Операция слишком велика (Operation too large)" & _
    vbCr & "Вы пытаетесь вывести в диалоговое окно матрицу, количество" & vbCr & _
    "строк или столбцов которой больше допустимого лимита." & vbCr & _
    "Допускается вывод не более 12 строк и 8 столбцов." & vbCr & _
    "(You are trying to put into dialog box a matrix with dimensions" & vbCr & _
    "larger than allowed limit (maximum 12 rows and 8 columns)."
    Select Case TypeName(a(0, 0))
        Case "AksiInteger"
            s = a(0, 0)
            For j = 1 To c - 1
                s = s & vbTab & a(0, j)
            Next j
            For i = 1 To r - 1
                s = s & vbCrLf & a(i, 0)
                For j = 1 To c - 1
                    s = s & vbTab & a(i, j)
                Next j
            Next i
        Case "AksiFloat"
            s = CutAfterDecimal(a(0, 0))
            For j = 1 To c - 1
                s = s & vbTab & CutAfterDecimal(a(0, j))
            Next j
            For i = 1 To r - 1
                s = s & vbCrLf & CutAfterDecimal(a(i, 0))
                For j = 1 To c - 1
                    s = s & vbTab & CutAfterDecimal(a(i, j))
                Next j
            Next i
        Case "AksiChar"
            s = Chr(a(0, 0))
            For j = 1 To c - 1
                s = s & vbTab & Chr(a(0, j))
            Next j
            For i = 1 To r - 1
                s = s & vbCrLf & Chr(a(i, 0))
                For j = 1 To c - 1
                    s = s & vbTab & Chr(a(i, j))
                Next j
            Next i
        Case "AksiString"
            If Len(a(0, 0)) > 8 Then GoTo ErrTooLargeString Else s = a(0, 0)
            For j = 1 To c - 1
                If Len(a(0, j)) > 8 Then GoTo ErrTooLargeString Else s = s & vbTab & a(0, j)
            Next j
            For i = 1 To r - 1
                If Len(a(i, 0)) > 8 Then GoTo ErrTooLargeString Else s = s & vbCrLf & a(i, 0)
                For j = 1 To c - 1
                    If Len(a(i, j)) > 8 Then GoTo ErrTooLargeString Else s = s & vbTab & a(i, j)
                Next j
            Next i
        Case Else
            Set src = a(0, 0)
            t = src.Serialize
            If Len(t) > 8 Then GoTo ErrTooLargeString Else s = t
            For j = 1 To c - 1
                Set src = a(0, j)
                t = src.Serialize
                If Len(t) > 8 Then GoTo ErrTooLargeString Else s = s & vbTab & t
            Next j
            For i = 1 To r - 1
                Set src = a(i, 0)
                t = src.Serialize
                If Len(t) > 8 Then GoTo ErrTooLargeString Else s = s & vbCrLf & t
                For j = 1 To c - 1
                    Set src = a(i, j)
                    t = src.Serialize
                    If Len(t) > 8 Then GoTo ErrTooLargeString Else s = s & vbTab & t
                Next j
            Next i
    End Select
    If title <> vbNullString Then MsgBox s, , title Else MsgBox s
    Exit Sub
 
ErrTooLargeString:
    Err.Raise vbObjectError, , "Операция слишком велика (Operation too large)" & _
    vbCr & "Вы пытаетесь вывести в диалоговое окно матрицу, элементы" & vbCr & _
    "которой не помещаются в пространстве, выделенном для" & vbCr & _
    "диалогового окна." & vbCr & _
    "(You are trying to put into dialog box a matrix with elements" & vbCr & _
    "which cannot be displayed in dialog box reserved space."
End Sub

1
Аксима
5727 / 1177 / 185
Регистрация: 12.12.2012
Сообщений: 963
25.06.2014, 17:26 #74
Глава первая: "Обзор базовых структур массивов" (продолжение)

Код класса AksiMatrix (продолжение)

Visual Basic
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
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
'Процедура для ввода данных в матрицу через диалоговое окно. Если базовый объект матрицы не
'относится к одному из встроенных классов, то он должен поддерживать интерфейс ISerializable.
'Параметр title определяет заголовок диалогового окна, letter - букву для обозначения массива.
Public Sub GetData_DialogBox(Optional ByVal title As String, Optional ByVal letter As String = "m")
    Dim i As Long, j As Long, s As String, rec As ISerializable, v As Double, k As Long, b As Byte
    Dim f1 As Boolean, f2 As Boolean, f3 As Boolean, pRU As String, pEN As String
    Const pR2 = ") матрицы", pE2 = "), please:"
    Const rRU = vbCr & "Пожалуйста, повторите ввод.", rEN = vbCr & "Try again, please.)"
    Const sErr = "Ошибка ввода (Invalid input)."
    pRU = "Пожалуйста, введите элемент " & letter & "("
    pEN = "(Input matrix element " & letter & "("
    If r > 8 Or c > 8 Then Err.Raise vbObjectError, , "Операция слишком велика (Operation too large)" & _
    vbCr & "В целях сохранения здоровья оператора запрещен" & vbCr & _
    "ручной ввод матриц, размеры которых превышают" & vbCr & _
    "допустимый лимит (максимум 8 строк/столбцов)." & vbCr & _
    "(Caring of operator's health, system does not allow" & vbCr & _
    "to manually input matrices with more than 8 rows/columns.)"
    Select Case TypeName(a(0, 0))
        Case "AksiInteger"
            For i = 0 To r - 1
                For j = 0 To c - 1
                    s = pRU & i & "," & j & pR2 & vbCr & "- целое число." & vbCr _
                    & pEN & i & "," & j & pE2 & vbCr & "an integer value.)"
                    If title <> vbNullString Then s = InputBox(s, title) Else s = InputBox(s)
                    Do
                        f1 = False
                        f2 = False
                        f3 = False
                        On Error Resume Next
                        v = Val(Replace(s, Format(0, "."), "."))
                        If Err Then f1 = True
                        On Error GoTo 0
                        If Not f1 Then
                            If s = "0" Or v <> 0 Then
                                On Error Resume Next
                                k = CLng(v)
                                If Err Then f1 = True
                                On Error GoTo 0
                                If Not f1 Then
                                    If v - CDbl(k) = 0 Then
                                        a(i, j) = k
                                    Else
                                        f2 = True
                                    End If
                                End If
                            Else
                                f3 = True
                            End If
                        End If
                        If f1 Then s = "Число не должно выходить за пределы отрезка," & vbCr _
                        & "отводимого под целочисленные числа [-2^31..2^31-1]" & rRU _
                        & vbCr & "(Number must be in range between -2^31 and 2^31-1." & rEN
                        If f2 Then s = "Число должно быть целым." & rRU _
                        & vbCr & "(Number must be integer." & rEN
                        If f3 Then s = "Введенная вами строка не является" & vbCr _
                        & "корректной записью десятичного числа." & rRU _
                        & vbCr & "(System cannot recognize your input." & vbCr _
                        & "as a valid decimal number." & rEN
                        If f1 Or f2 Or f3 Then s = InputBox(s, sErr)
                    Loop While f1 Or f2 Or f3
                Next j
            Next i
        Case "AksiFloat"
            For i = 0 To r - 1
                For j = 0 To c - 1
                    s = pRU & i & "," & j & pR2 & vbCr & "- вещественное число." & vbCr _
                    & pEN & i & "," & j & pE2 & vbCr & "a real number.)"
                    If title <> vbNullString Then s = InputBox(s, title) Else s = InputBox(s)
                    Do
                        f1 = False
                        f2 = False
                        On Error Resume Next
                        v = Val(Replace(s, Format(0, "."), "."))
                        If Err Then f1 = True
                        On Error GoTo 0
                        If Not f1 Then
                            If s = "0" Or v <> 0 Then
                                a(i, j) = v
                            Else
                                f2 = True
                            End If
                        End If
                        If f1 Then s = "Число не должно выходить за пределы допустимых диапазонов:" _
                        & vbCr & "-1,79E308...-5E-324; 0; 5E-324...1,79E308" & rRU _
                        & vbCr & "(Number must be in one of the following ranges:" & vbCr _
                        & "-1.79E+308...-5E-324, 0, 5E-324...1.79E+308" & rEN
                        If f2 Then s = "Введенная вами строка не является" & vbCr _
                        & "корректной записью десятичного числа." & rRU _
                        & vbCr & "(System cannot recognize your input." & vbCr _
                        & "as a valid decimal number." & rEN
                        If f1 Or f2 Then s = InputBox(s, sErr)
                    Loop While f1 Or f2
                Next j
            Next i
        Case "AksiChar"
            For i = 0 To r - 1
                For j = 0 To c - 1
                    s = pRU & i & "," & j & pR2 & vbCr & "- символ или его код." & vbCr _
                    & pEN & i & "," & j & pE2 & vbCr & "a symbol or its code.)"
                    If title <> vbNullString Then s = InputBox(s, title) Else s = InputBox(s)
                    Do
                        f1 = False
                        f2 = False
                        f3 = False
                        On Error Resume Next
                        v = Val(Replace(s, Format(0, "."), "."))
                        If Err Then f1 = True
                        On Error GoTo 0
                        If Not f1 Then
                            If s = "0" Or v <> 0 Then
                                On Error Resume Next
                                b = CByte(v)
                                If Err Then f1 = True
                                On Error GoTo 0
                                If Not f1 Then
                                    If v - CDbl(b) = 0 Then
                                        a(i, j) = v
                                    Else
                                        f2 = True
                                    End If
                                End If
                            ElseIf Len(s) = 1 Then
                                a(i, j) = Asc(s)
                            Else
                                f3 = True
                            End If
                        End If
                        If f1 Then s = "Код символа должен быть не меньше 0 и не больше 255." & rRU _
                        & vbCr & "(Code of symbol cannot be less than 0 or greater than 255." & rEN
                        If f2 Then s = "Код символа не может быть вещественным числом." & rRU _
                        & vbCr & "(Code of symbol cannot be a real number." & rEN
                        If f3 Then s = "Не допускается ввод больше одного символа." & rRU _
                        & vbCr & "(You shouldn't input more than one symbol." & rEN
                        If f1 Or f2 Or f3 Then s = InputBox(s, sErr)
                    Loop While f1 Or f2 Or f3
                Next j
            Next i
        Case "AksiString"
            For i = 0 To r - 1
                For j = 0 To c - 1
                    s = pRU & i & "," & j & pR2 & vbCr & "- строку." & vbCr _
                    & pEN & i & "," & j & pE2 & vbCr & "a string.)"
                    If title <> vbNullString Then a(i, j) = InputBox(s, title) Else a(i, j) = InputBox(s)
                Next j
            Next i
        Case Else
            For i = 0 To r - 1
                For j = 0 To c - 1
                    s = pRU & i & vbCr & "- элемент сложного типа." & vbCr _
                    & pEN & i & pE2 & vbCr & "an element of non-basic data type.)"
                    If title <> vbNullString Then s = InputBox(s, title) Else s = InputBox(s)
                    Set rec = a(i, j)
                    rec.Unserialize s
                Next j
            Next i
    End Select
End Sub
'Процедура для записи данных из матрицы в файл Excel с именем fileName.
'При необходимости уточняется индекс листа sheetIndex и параметры выбора диапазона rangeParam.
'Если имя fileName не указано, то через rangeParam передается ссылка на диапазон для записи данных.
'Базовый объект матрицы должен поддерживать либо свойство по умолчанию Value, либо интерфейс ISerializable.
Public Sub PutData_ExcelFile(Optional ByVal rangeParam As Variant, Optional ByVal fileName As String, _
Optional ByVal sheetIndex As Variant)
 
    Dim eApp As Object, eWbk As Object, eWst As Object, eRng As Object
    Dim s As String, p As String, f0 As Boolean, f1 As Boolean, f2 As Boolean
    Dim i As Long, j As Long, rr As Long, cc As Long, shCount As Long
    Dim arr As Variant, t As Variant, src As ISerializable, f As New AksiFile
    
    If fileName <> vbNullString Then
        f.Parse fileName
        s = f.Extension
        If Not (s = "xls" Or s = "xlsx" Or s = "xlsb" Or s = "xlsm") Then Err.Raise 75
        s = f.Name
        p = f.Path
        
        On Error GoTo ErrAppNotOpenA
        Set eApp = GetObject(, "Excel.Application")
            
        On Error GoTo ErrWbkNotOpenA
        Set eWbk = eApp.Workbooks(s)
        If eWbk.Path & "\" <> p Then Err.Raise 9
        
LblSheetSearchA:
        On Error GoTo ErrSheetNotFoundA
        If IsMissing(sheetIndex) Or IsEmpty(sheetIndex) Then sheetIndex = 1
        Set eWst = eWbk.Worksheets(sheetIndex)
        
        On Error GoTo LblTerminationA
        If IsMissing(rangeParam) Or IsEmpty(rangeParam) Then
            'Если rangeParam опущен, то по умолчанию выкладываем данные
            'в прямоугольный диапазон, начинающийся с ячейки A1.
            Set eRng = eWst.Range("A1").Resize(r, c)
        Else
            'Если rangeParam - строка, то она указывает адрес диапазона.
            If TypeName(rangeParam) = "String" Then
                Set eRng = eWst.Range(rangeParam)
            Else
                Err.Raise 5
            End If
        End If
    Else
        Set eRng = rangeParam
    End If
    
    On Error Resume Next 'Проверка на поддержку свойства Value.
    t = a(0).Value
    f2 = Err.Number = 438
    
    On Error GoTo LblTerminationA
    Set eRng = eRng.Areas(1)
    rr = eRng.Rows.Count
    cc = eRng.Columns.Count
    If r < rr Then rr = r
    If c < cc Then cc = c
    If f2 Then 'Выбираем способ заполнения в зависимости от поддержки свойства Value.
        ReDim arrS(0 To rr - 1, 0 To cc - 1) As String
        For i = 0 To rr - 1
            For j = 0 To cc - 1
                Set src = a(i, j)
                arrS(i, j) = src.Serialize
            Next j
        Next i
        eRng = arrS
    Else
        ReDim arrV(0 To rr - 1, 0 To cc - 1) As Variant
        For i = 0 To rr - 1
            For j = 0 To cc - 1
                arrV(i, j) = a(i, j)
            Next j
        Next i
        eRng = arrV
    End If
    On Error GoTo 0
    If f1 Then eWbk.Close True
    If f0 Then eApp.Quit
    Exit Sub
 
ErrAppNotOpenA:
    If Err.Number = 429 Then 'Приложение Excel не открыто.
        f0 = True
        Set eApp = CreateObject("Excel.Application")
        Resume Next
    Else
        GoTo LblTerminationA
    End If
 
ErrWbkNotOpenA:
    If Err.Number = 9 Then 'Искомая книга не открыта в текущем приложении Excel.
        f1 = True
        Resume LblCreateWorkbookA
    Else
        GoTo LblTerminationA
    End If
 
LblCreateWorkbookA:
    On Error GoTo ErrWbkNotExistsA
    Set eWbk = eApp.Workbooks.Open(fileName)
    GoTo LblSheetSearchA
 
ErrWbkNotExistsA:
    If Err.Number = 1004 Then 'Искомая книга вообще не существует.
        Set eWbk = eApp.Workbooks.Add
        f.Catalog.MakeSureCatalogExists
        eWbk.SaveAs fileName
        Resume Next
    Else
        GoTo LblTerminationA
    End If
 
ErrSheetNotFoundA:
    If Err.Number = 9 Then 'Искомый лист не найден в книге.
        If TypeName(sheetIndex) = "Byte" Or TypeName(sheetIndex) = "Integer" Or TypeName(sheetIndex) = "Long" Then
            If sheetIndex > 0 And sheetIndex <= 100 Then
                shCount = eWbk.Sheets.Count
                eWbk.Sheets.Add After:=eWbk.Sheets(shCount), Count:=sheetIndex - shCount
                Resume
            Else
                Err.Raise 9
            End If
        ElseIf TypeName(sheetIndex) = "String" Then
            eWbk.Sheets.Add.Name = sheetIndex
            Resume
        Else
            Err.Raise 5
        End If
    Else
        GoTo LblTerminationA
    End If
    
LblTerminationA: 'Аварийное завершение программы с освобождением использованных ресурсов.
    If f1 Then
        eWbk.Close False
        Set eWbk = Nothing
    End If
    If f0 Then
        eApp.Quit
        Set eApp = Nothing
    End If
    Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub
'Процедура для чтения данных в матрицу из файла Excel с именем fileName, листа sheetIndex и
'диапазона с адресом rangeParam. Если имя fileName не указано, то через rangeParam передается
'ссылка на диапазон, из которого читаются данные. Базовый объект вектора должен поддерживать
'либо свойство по умолчанию Value, либо интерфейс ISerializable.
Public Sub GetData_ExcelFile(Optional ByVal rangeParam As Variant, Optional ByVal fileName As String, _
Optional ByVal sheetIndex As Variant)
 
    Dim eApp As Object, eWbk As Object, eWst As Object, eRng As Object, src As ISerializable
    Dim f0 As Boolean, f1 As Boolean, f2 As Boolean, arr As Variant, f As New AksiFile
    Dim i As Long, j As Long, rr As Long, cc As Long, s As String, p As String, t As Variant
 
    If fileName <> vbNullString Then
        f.Parse fileName
        s = f.Name
        p = f.Path
        
        On Error GoTo ErrAppNotOpenB
        Set eApp = GetObject(, "Excel.Application")
            
        On Error GoTo ErrWbkNotOpenB
        Set eWbk = eApp.Workbooks(s)
        If eWbk.Path & "\" <> p Then Err.Raise 9
        
        On Error GoTo LblTerminationB
        If IsMissing(sheetIndex) Or IsEmpty(sheetIndex) Then
            Set eWst = eWbk.Worksheets(1)
        Else
            Set eWst = eWbk.Worksheets(sheetIndex)
        End If
        If IsMissing(rangeParam) Or IsEmpty(rangeParam) Then
            'Если rangeParam опущен, то по умолчанию предполагается, что
            'данные находятся в прямоугольном диапазоне, начинающемся с ячейки A1.
            Set eRng = eWst.Range("A1")
            Set eRng = Application.Intersect(eRng.Resize(r, c), eRng.CurrentRegion)
        Else
            Set eRng = eWst.Range(rangeParam)
        End If
    Else
        Set eRng = rangeParam
    End If
    
    On Error Resume Next 'Проверка на поддержку свойства Value.
    a(0).Value = t
    f2 = Err.Number = 438
    
    On Error GoTo LblTerminationB
    Set eRng = eRng.Areas(1)
    arr = eRng
    rr = UBound(arr)
    cc = UBound(arr, 2)
    If r < rr Then rr = r
    If c < cc Then cc = c
    If f2 Then 'Выбираем способ заполнения в зависимости от поддержки свойства Value.
        For i = 1 To rr
            For j = 1 To cc
                Set src = a(i - 1, j - 1)
                src.Unserialize arr(i, j)
            Next j
        Next i
    Else
        For i = 1 To rr
            For j = 1 To cc
                a(i - 1, j - 1) = arr(i, j)
            Next j
        Next i
    End If
    On Error GoTo 0
    If f1 Then eWbk.Close False
    If f0 Then eApp.Quit
    Exit Sub
 
ErrAppNotOpenB:
    If Err.Number = 429 Then 'Приложение Excel не открыто.
        f0 = True
        Set eApp = CreateObject("Excel.Application")
        Resume Next
    Else
        GoTo LblTerminationB
    End If
 
ErrWbkNotOpenB:
    If Err.Number = 9 Then 'Искомая книга не открыта в текущем приложении Excel.
        f1 = True
        Set eWbk = eApp.Workbooks.Open(fileName)
        Resume Next
    Else
        GoTo LblTerminationB
    End If
    
LblTerminationB: 'Аварийное завершение программы с освобождением использованных ресурсов.
    If f1 Then
        eWbk.Close False
        Set eWbk = Nothing
    End If
    If f0 Then
        eApp.Quit
        Set eApp = Nothing
    End If
    Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub
'Преобразование времени в секундах в часы, минуты (от 0 до 59) и секунды (от 0 до 59).
Private Sub SecsToHMS(ByVal secs As Long, ByRef hms() As Integer)
    hms(2) = secs Mod 60
    secs = secs \ 60
    hms(1) = secs Mod 60
    hms(0) = secs \ 60
End Sub
'Функция, выполняющая корректное сложение дат, представленных в разных форматах.
Private Function SumDates(ByVal d1 As Date, ByVal d2 As Date) As Date
    Dim d1p(0 To 5) As Integer, d2p(0 To 5) As Integer
    Dim i As Long, k As Long, arr As Variant
    arr = Array("yyyy", "m", "d", "h", "n", "s")
    For i = 0 To 5
        d1p(i) = DatePart(arr(i), d1)
        d2p(i) = DatePart(arr(i), d2)
    Next i
    k = 4 * (CLng((d1p(0) = 1899) And (d1p(1) = 12) And (d1p(2) = 30)) + _
    2 * CLng((d1p(3) = 0) And (d1p(4) = 0) And (d1p(5) = 0))) + _
    CLng((d2p(0) = 1899) And (d2p(1) = 12) And (d2p(2) = 30)) + _
    2 * CLng((d2p(3) = 0) And (d2p(4) = 0) And (d2p(5) = 0))
    Select Case k
        Case 0
            For i = 0 To 5
                d1 = DateAdd(arr(i), d2p(i), d1)
            Next i
        Case -1, -9
            For i = 3 To 5
                d1 = DateAdd(arr(i), d2p(i), d1)
            Next i
        Case -2, -10
            For i = 0 To 2
                d1 = DateAdd(arr(i), d2p(i), d1)
            Next i
        Case -4, -5, -6
            For i = 3 To 5
                d2 = DateAdd(arr(i), d1p(i), d2)
            Next i
        Case -8, -10
            For i = 0 To 2
                d2 = DateAdd(arr(i), d1p(i), d2)
            Next i
    End Select
    Select Case k
        Case 0, -1, -2, -3, -7, -9, -10, -11
            SumDates = d1
        Case -4, -5, -6, -8, -12, -13, -14, -15
            SumDates = d2
    End Select
End Function

2
Аксима
5727 / 1177 / 185
Регистрация: 12.12.2012
Сообщений: 963
25.06.2014, 17:27 #75
Глава первая: "Обзор базовых структур массивов" (продолжение)

Код класса AksiMatrix (продолжение)

Visual Basic
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
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
'Процедура для заполения матрицы данными, сгенерированными с помощью генератора случайных чисел.
'Данные генерируются в диапазоне от low_val (включительно) до high_val (включительно), либо в
'диапазоне, определенном по умолчанию. Параметр seed определяет число, используемое для
'генерации последовательности (псевдо)случайных чисел, а параметр floatPrecision - точность,
'до которой округляются вещественные числа (если параметр floatPrecision не задан, вещественные
'числа не округляются). В качестве данных генератор умеет генерировать числа, символы и даты.
'Базовые принципы процесса генерации описаны в классе AksiVector.
Public Sub GetData_RandomGenerator(Optional ByVal low_val, Optional ByVal high_val, _
Optional ByVal seed, Optional ByVal floatPrecision)
    Dim i As Long, j As Long, s As Long, multiplier As Long, arr As Variant
    Dim d1p(0 To 5) As Integer, d2p(0 To 5) As Integer, dp(0 To 2) As Integer
    Dim d1f As Long, d2f As Long, dif As Long, k As Long, d As Date, t As Date
    If IsMissing(seed) Then Randomize Else Randomize Val(seed)
    If IsMissing(low_val) Then
        If IsMissing(high_val) Then
            Select Case TypeName(a(0, 0))
                Case "AksiInteger"
                    For i = 0 To r - 1
                        For j = 0 To c - 1
                            a(i, j) = Int(100 * Rnd)
                        Next j
                    Next i
                Case "AksiFloat"
                    If IsMissing(floatPrecision) Then
                        For i = 0 To r - 1
                            For j = 0 To c - 1
                                a(i, j) = 100 * Rnd - 50
                            Next j
                        Next i
                    Else
                        If IsNumeric(floatPrecision) Then
                            floatPrecision = CByte(Val(floatPrecision))
                            If floatPrecision = 0 Then
                                For i = 0 To r - 1
                                    For j = 0 To c - 1
                                        a(i, j) = Int(101 * Rnd - 50)
                                    Next j
                                Next i
                            Else
                                multiplier = 10 ^ floatPrecision
                                For i = 0 To r - 1
                                    For j = 0 To c - 1
                                        a(i, j) = Int(2 * (Rnd - 0.5) * multiplier) / multiplier
                                    Next j
                                Next i
                            End If
                        Else
                            Err.Raise 13
                        End If
                    End If
                Case "AksiChar"
                    For i = 0 To r - 1
                        For j = 0 To c - 1
                            a(i, j) = Int(256 * Rnd)
                        Next j
                    Next i
                Case "AksiDate"
                        high_val = Now
                        low_val = DateAdd("yyyy", -1, high_val)
                        arr = Array("yyyy", "m", "d", "h", "n", "s")
                        For i = 3 To 5
                            d1p(i) = DatePart(arr(i), low_val)
                        Next i
                        dif = DateDiff("d", low_val, high_val)
                        For i = 0 To r - 1
                            For j = 0 To c - 1
                                d = DateAdd("d", Int((dif + 1) * Rnd), low_val)
                                SecsToHMS Int(86400 * Rnd), dp
                                a(i, j) = SumDates(d, TimeSerial(dp(0), dp(1), dp(2)))
                            Next j
                        Next i
                Case Else
                    Err.Raise 5
            End Select
        Else
            Err.Raise 5
        End If
    Else
        If IsMissing(high_val) Then
            Err.Raise 5
        Else
            Select Case TypeName(a(0, 0))
                Case "AksiInteger"
                    If IsNumeric(low_val) And IsNumeric(high_val) Then
                        low_val = Val(low_val)
                        high_val = Val(high_val)
                        If low_val - CLng(low_val) = 0 And high_val - CLng(high_val) = 0 Then
                            If low_val > high_val Then
                                Err.Raise 5, , "Неверные аргументы - нижняя граница больше верхней" & _
                                vbCr & "(Invalid argument(s) - low_val is greater than high_val)."
                            Else
                                For i = 0 To r - 1
                                    For j = 0 To c - 1
                                        a(i, j) = Int((high_val - low_val + 1) * Rnd + low_val)
                                    Next j
                                Next i
                            End If
                        Else
                            Err.Raise 5, , "Неверные аргументы - границы должны быть целыми" & _
                            vbCr & "(Invalid argument(s) - bounds must be integers)."
                        End If
                    Else
                        Err.Raise 13
                    End If
                Case "AksiFloat"
                    If IsNumeric(low_val) And IsNumeric(high_val) Then
                        low_val = Val(low_val)
                        high_val = Val(high_val)
                        If low_val > high_val Then
                            Err.Raise 5, , "Неверные аргументы - нижняя граница больше верхней" & _
                            vbCr & "(Invalid argument(s) - low_val is greater than high_val)."
                        Else
                            If IsMissing(floatPrecision) Then
                                For i = 0 To r - 1
                                    For j = 0 To c - 1
                                        a(i, j) = (high_val - low_val) * Rnd + low_val
                                    Next j
                                Next i
                            Else
                                If IsNumeric(floatPrecision) Then
                                    floatPrecision = CByte(Val(floatPrecision))
                                    multiplier = 10 ^ floatPrecision
                                    For i = 0 To r - 1
                                        For j = 0 To c - 1
                                            a(i, j) = (Int((high_val - low_val) * Rnd + low_val) * multiplier) / multiplier
                                        Next j
                                    Next i
                                Else
                                    Err.Raise 13
                                End If
                            End If
                        End If
                    Else
                        Err.Raise 13
                    End If
                Case "AksiChar"
                    If TypeName(low_val) = "String" And TypeName(high_val) = "String" Then
                        If Len(low_val) = 1 And Len(high_val) = 1 Then
                            low_val = Asc(low_val)
                            high_val = Asc(high_val)
                            If low_val > high_val Then
                                Err.Raise 5, , "Неверные аргументы - нижняя граница больше верхней" & _
                                vbCr & "(Invalid argument(s) - low_val is greater than high_val)."
                            Else
                                For i = 0 To r - 1
                                    For j = 0 To c - 1
                                        a(i, j) = Int((high_val - low_val + 1) * Rnd + low_val)
                                    Next j
                                Next i
                            End If
                        Else
                            Err.Raise 5, , "Неверные аргументы - границы представляются 1 символом." & _
                            vbCr & "(Invalid argument(s) - bounds must be 1-char symbols)."
                        End If
                    Else
                        low_val = CByte(Val(low_val))
                        high_val = CByte(Val(high_val))
                        If low_val > high_val Then
                            Err.Raise 5, , "Неверные аргументы - нижняя граница больше верхней" & _
                            vbCr & "(Invalid argument(s) - low_val is greater than high_val)."
                        Else
                            For i = 0 To r - 1
                                For j = 0 To c - 1
                                    a(i, j) = Int((high_val - low_val + 1) * Rnd + low_val)
                                Next j
                            Next i
                        End If
                    End If
                Case "AksiDate"
                    If IsDate(low_val) And IsDate(high_val) Then
                        low_val = CDate(low_val)
                        high_val = CDate(high_val)
                        arr = Array("yyyy", "m", "d", "h", "n", "s")
                        For i = 0 To 5
                            d1p(i) = DatePart(arr(i), low_val)
                            d2p(i) = DatePart(arr(i), high_val)
                        Next i
                        d1f = CLng((d1p(0) = 1899) And (d1p(1) = 12) And (d1p(2) = 30)) + _
                            2 * CLng((d1p(3) = 0) And (d1p(4) = 0) And (d1p(5) = 0))
                        d2f = CLng((d2p(0) = 1899) And (d2p(1) = 12) And (d2p(2) = 30)) + _
                            2 * CLng((d2p(3) = 0) And (d2p(4) = 0) And (d2p(5) = 0))
                        k = 4 * d1f + d2f
                        Select Case k
                            Case 0, -2, -8
                                If low_val > high_val Then
                                    Err.Raise 5, , "Неверные аргументы - нижняя граница больше верхней" & _
                                    vbCr & "(Invalid argument(s) - low_val is greater than high_val)."
                                Else
                                    If d1p(0) = d2p(0) And d1p(1) = d2p(1) And d1p(2) = d2p(2) Then
                                        s = 3600& * d1p(3) + 60& * d1p(4) + d1p(5)
                                        dif = 3600& * d2p(3) + 60& * d2p(4) + d2p(5) - s
                                        For i = 0 To r - 1
                                            For j = 0 To c - 1
                                                SecsToHMS Int((dif + 1) * Rnd + s), dp
                                                a(i, j) = SumDates(DateSerial(d1p(0), d1p(1), d1p(2)), _
                                                TimeSerial(dp(0), dp(1), dp(2)))
                                            Next j
                                        Next i
                                    Else
                                        dif = DateDiff("d", low_val, high_val)
                                        For i = 0 To r - 1
                                            For j = 0 To c - 1
                                                d = DateAdd("d", Int((dif + 1) * Rnd), low_val)
                                                If d = DateSerial(d1p(0), d1p(1), d1p(2)) Then
                                                    s = 3600& * d1p(3) + 60& * d1p(4) + d1p(5)
                                                    SecsToHMS Int((86400 - s) * Rnd + s), dp
                                                    a(i, j) = SumDates(d, TimeSerial(dp(0), dp(1), dp(2)))
                                                ElseIf d = DateSerial(d2p(0), d2p(1), d2p(2)) Then
                                                    s = 3600& * d2p(3) + 60& * d2p(4) + d2p(5)
                                                    SecsToHMS Int((s + 1) * Rnd), dp
                                                    a(i, j) = SumDates(d, TimeSerial(dp(0), dp(1), dp(2)))
                                                Else
                                                    SecsToHMS Int(86400 * Rnd), dp
                                                    a(i, j) = SumDates(d, TimeSerial(dp(0), dp(1), dp(2)))
                                                End If
                                            Next j
                                        Next i
                                    End If
                                End If
                            Case -1, -4, -5, -9, -12, -13
                                If TimeSerial(d1p(3), d1p(4), d1p(5)) > TimeSerial(d2p(3), d2p(4), d2p(5)) Then
                                    Err.Raise 5, , "Неверные аргументы - нижняя граница больше верхней" & _
                                    vbCr & "(Invalid argument(s) - low_val is greater than high_val)."
                                Else
                                    s = 3600& * d1p(3) + 60& * d1p(4) + d1p(5)
                                    dif = 3600& * d2p(3) + 60& * d2p(4) + d2p(5) - s
                                    Select Case k
                                        Case -1
                                            d = DateSerial(d1p(0), d1p(1), d1p(2))
                                        Case -4
                                            d = DateSerial(d2p(0), d2p(1), d2p(2))
                                        Case -5
                                            d = #12:00:00 AM#
                                        Case -9
                                            d = low_val
                                        Case -12
                                            d = DateSerial(d2p(0), d2p(1), d2p(2))
                                        Case -13
                                            d = #12:00:00 AM#
                                    End Select
                                    For i = 0 To r - 1
                                        For j = 0 To c - 1
                                            SecsToHMS Int((dif + 1) * Rnd + s), dp
                                            t = TimeSerial(dp(0), dp(1), dp(2))
                                            a(i, j) = SumDates(d, TimeSerial(dp(0), dp(1), dp(2)))
                                        Next j
                                    Next i
                                End If
                            Case -3, -6, -7, -11
                                Err.Raise 5, , "Неверные аргументы - нижняя граница больше верхней" & _
                                vbCr & "(Invalid argument(s) - low_val is greater than high_val)."
                            Case -10
                                If low_val > high_val Then
                                    Err.Raise 5, , "Неверные аргументы - нижняя граница больше верхней" & _
                                    vbCr & "(Invalid argument(s) - low_val is greater than high_val)."
                                Else
                                    dif = DateDiff("d", low_val, high_val)
                                    For i = 0 To r - 1
                                        For j = 0 To c - 1
                                            a(i, j) = DateAdd("d", Int((dif + 1) * Rnd), low_val)
                                        Next j
                                    Next i
                                End If
                            Case -14
                                For i = 0 To r - 1
                                    For j = 0 To c - 1
                                        a(i, j) = high_val
                                    Next j
                                Next i
                            Case -15
                                For i = 0 To r - 1
                                    For j = 0 To c - 1
                                        a(i, j) = #12:00:00 AM#
                                    Next j
                                Next i
                        End Select
                    Else
                        Err.Raise 13
                    End If
                Case Else
                    Err.Raise 5
            End Select
        End If
    End If
End Sub
'Процедура для чтения данных в матрицу из заданного вектора. Параметр vec определяет
'ссылку на вектор, их которого считываются элементы матрицы, а параметр readorder
'задает порядок, в котором они считываются.
Public Sub GetData_Vector(ByVal vec As AksiVector, Optional ByVal readorder As AoMatrixReadOrder = AO_BYROWS)
    Dim i As Long, j As Long, N As Long
    Select Case readorder
        Case AO_BYROWS
            For i = 0 To r - 1
                For j = 0 To c - 1
                    N = i * c + j
                    If N > vec.Count - 1 Then Exit Sub
                    Set a(i, j) = vec(N)
                Next j
            Next i
        Case AO_BYCOLS
            For i = 0 To r - 1
                For j = 0 To c - 1
                    N = i + j * r
                    If N > vec.Count - 1 Then Exit Sub
                    Set a(i, j) = vec(N)
                Next j
            Next i
        Case Else
            Err.Raise 5
    End Select
End Sub
'Процедура для представления элементов матрицы в виде вектора. Параметр readorder
'задает порядок, в котором элементы матрицы считываются в вектор.
Public Function Elements(Optional ByVal readorder As AoMatrixReadOrder = AO_BYROWS) As AksiVector
    Dim i As Long, j As Long, v As AksiVector
    Select Case readorder
        Case AO_BYROWS
            Set v = New AksiVector
            v.Init a(0, 0), r * c
            For i = 0 To r - 1
                For j = 0 To c - 1
                    Set v(i * c + j) = a(i, j)
                Next j
            Next i
        Case AO_BYCOLS
            Set v = New AksiVector
            v.Init a(0, 0), r * c
            For i = 0 To r - 1
                For j = 0 To c - 1
                    Set v(i + j * r) = a(i, j)
                Next j
            Next i
        Case Else
            Err.Raise 5
    End Select
    Set Elements = v
End Function

2
25.06.2014, 17:27
MoreAnswers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
25.06.2014, 17:27
Привет! Вот еще темы с ответами:

Хранение картинок в теле надстройки - VBA
Добрый день! Возможно ли хранить картинку в самом файле (&quot;надстрока.xlsx&quot;) и вставлять ее на лист средствами VBA? к примеру:...

Добавление надстройки Excel в Ribbon - VBA
Здравствуйте. Написал я две надстройки на VBA для Excel, и захотелось мне поместить две кнопки для запуска этих надстроек на ленту в...

Вызов окна функции из надстройки - VBA
Добрый день. Сделал надстройку типа RIBBON. В меню перечислил свои пользовательские функции. Хочу, чтобы при щелчке по пункту меню,...

Назначение комбинации клавиш макроса у надстройки - VBA
Есть надстройка в ней полезные макросы.....для вызова которых есть комбинации клавиш.... и так возникла потребность написания....новых...


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
75
Ответ Создать тему
Опции темы

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2017, vBulletin Solutions, Inc.
Рейтинг@Mail.ru