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

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

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

Надстройка для VBE "IndenterVBA" - позволяет редактировать стиль оформления программного кода.

Аксима · 25.06.2014, 17:33

Глава вторая: "Обзор базовых типов данных"

Практически весь поток информации, обрабатываемый программами, можно представить в виде чисел, символов или их последовательностей (строк). Также заслуживает внимания работа с датами. Исходя из этого, несложно предположить, что в набор базовых типов данных должны войти классы для представления целых (AksiInteger) и вещественных (AksiFloat) чисел, а также классы символов (AksiChar), строк (AksiString) и, наконец, класс дат AksiDate. Листинги для этих классов приводится ниже:

Код класса AksiInteger

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
'________________________________________________________________
'_____________________                       ____________________
'____________________    Модуль AksiInteger   ___________________
'_____________________     Версия: 0.5.0     ____________________
'____________________      Автор: Aksima      ___________________
'___________________  Библиотека: AksiArrays  ___________________
'________________________________________________________________
'_____________                                      _____________
'_____________  Назначение: Обработка целых чисел.  _____________
'________________________________________________________________
 
Implements IFactory 'Поддерживает создание объектом класса других объектов этого же класса.
Implements ISerializable 'Поддерживает сериализацию данных.
Implements ICloneable 'Определяет функцию для создания полной копии объекта.
Implements IComparable 'Определяет встроенный способ сравнения элементов.
Implements IConvertible 'Определяет преобразование в объект своего класса.
Implements IMath 'Поддерживает математические операции над своими объектами.
Dim v As Long
'Свойство по умолчанию - получение.
Public Property Get Value() As Long
    Value = v
End Property
'Свойство по умолчанию - установка.
Public Property Let Value(ByVal vNew As Long)
    v = vNew
End Property
'Создание объекта класса.
Private Function IFactory_NewOb() As Object
    Set IFactory_NewOb = New AksiInteger
End Function
'Сериализация.
Private Function ISerializable_Serialize() As String
    ISerializable_Serialize = CStr(v)
End Function
'Десериализация.
Private Sub ISerializable_Unserialize(ByVal s As String)
    If s <> vbNullString Then v = Val(s)
End Sub
'Создание полной копии объекта.
Private Function ICloneable_Copy() As Object
    Set ICloneable_Copy = New AksiInteger
    ICloneable_Copy = v
End Function
'Преобразование входных данных в объекты данного класса.
Private Function IConvertible_Convert(ByVal x As Variant) As Object
    Select Case TypeName(x)
        Case "AksiInteger"
            Set IConvertible_Convert = x
        Case "Byte", "Integer", "Long"
            Set IConvertible_Convert = New AksiInteger
            IConvertible_Convert.Value = x
        Case "Single", "Double", "Currency", "AksiFloat"
            Set IConvertible_Convert = New AksiInteger
            IConvertible_Convert.Value = CLng(x)
        Case "String", "AksiString"
            Set IConvertible_Convert = New AksiInteger
            IConvertible_Convert.Value = CLng(Val(x))
        Case Else
            Err.Raise 13
    End Select
End Function
'Сложение.
Private Function IMath_©(ByVal a As Variant, ByVal b As Variant) As Object
    Dim c As IConvertible
    Set c = New AksiInteger
    Set IMath_© = New AksiInteger
    IMath_©.Value = c.Convert(a) + c.Convert(b)
End Function
'Вычитание.
Private Function IMath_*(ByVal a As Variant, ByVal b As Variant) As Object
    Dim c As IConvertible
    Set c = New AksiInteger
    Set IMath_* = New AksiInteger
    IMath_*.Value = c.Convert(a) - c.Convert(b)
End Function
'Умножение.
Private Function IMath_·(ByVal a As Variant, ByVal b As Variant) As Object
    Dim c As IConvertible
    Set c = New AksiInteger
    Set IMath_· = New AksiInteger
    IMath_·.Value = c.Convert(a) * c.Convert(b)
End Function
'Деление.
Private Function IMath_®(ByVal a As Variant, ByVal b As Variant) As Object
    Dim c As IConvertible
    Set c = New AksiInteger
    Set IMath_® = New AksiInteger
    IMath_®.Value = c.Convert(a) \ c.Convert(b)
End Function
'Функция сравнения элементов класса.
Private Function IComparable_CompareTo(ByVal another As Object) As Long
    If v < another Then
        IComparable_CompareTo = -1
    ElseIf v > another Then
        IComparable_CompareTo = 1
    End If
End Function

Код класса AksiFloat

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
'________________________________________________________________
'_______________________                   ______________________
'_____________________    Модуль AksiFloat  _____________________
'____________________      Версия: 0.5.0     ____________________
'___________________       Автор: Aksima      ___________________
'___________________  Библиотека: AksiArrays  ___________________
'________________________________________________________________
'__________                                             _________
'__________  Назначение: Обработка вещественных чисел.  _________
'________________________________________________________________
 
Implements IFactory 'Поддерживает создание объектом класса других объектов этого же класса.
Implements ISerializable 'Поддерживает сериализацию данных.
Implements ICloneable 'Определяет функцию для создания полной копии объекта.
Implements IComparable 'Определяет встроенный способ сравнения элементов.
Implements IConvertible 'Определяет преобразование в объект своего класса.
Implements IMath 'Поддерживает математические операции над своими объектами.
Dim v As Double
'Свойство по умолчанию - получение.
Public Property Get Value() As Double
    Value = v
End Property
'Свойство по умолчанию - установка.
Public Property Let Value(ByVal vNew As Double)
    v = vNew
End Property
'Создание объекта класса.
Private Function IFactory_NewOb() As Object
    Set IFactory_NewOb = New AksiFloat
End Function
'Сериализация.
Private Function ISerializable_Serialize() As String
    ISerializable_Serialize = Replace(CStr(v), Format(0, "."), ".")
End Function
'Десериализация.
Private Sub ISerializable_Unserialize(ByVal s As String)
    If s <> vbNullString Then v = Val(s)
End Sub
'Создание полной копии объекта.
Private Function ICloneable_Copy() As Object
    Set ICloneable_Copy = New AksiFloat
    ICloneable_Copy = v
End Function
'Преобразование входных данных в объекты данного класса.
Private Function IConvertible_Convert(ByVal x As Variant) As Object
    Select Case TypeName(x)
        Case "AksiFloat"
            Set IConvertible_Convert = x
        Case "Byte", "Integer", "Long", "Single", "Double", "Currency", "AksiInteger"
            Set IConvertible_Convert = New AksiFloat
            IConvertible_Convert.Value = x
        Case "String", "AksiString"
            Set IConvertible_Convert = New AksiFloat
            IConvertible_Convert.Value = Val(Replace(x, Format(0, "."), "."))
        Case Else
            Err.Raise 13
    End Select
End Function
'Сложение.
Private Function IMath_©(ByVal a As Variant, ByVal b As Variant) As Object
    Dim c As IConvertible
    Set c = New AksiFloat
    Set IMath_© = New AksiFloat
    IMath_©.Value = c.Convert(a) + c.Convert(b)
End Function
'Вычитание.
Private Function IMath_*(ByVal a As Variant, ByVal b As Variant) As Object
    Dim c As IConvertible
    Set c = New AksiFloat
    Set IMath_* = New AksiFloat
    IMath_*.Value = c.Convert(a) - c.Convert(b)
End Function
'Умножение.
Private Function IMath_·(ByVal a As Variant, ByVal b As Variant) As Object
    Dim c As IConvertible
    Set c = New AksiFloat
    Set IMath_· = New AksiFloat
    IMath_·.Value = c.Convert(a) * c.Convert(b)
End Function
'Деление.
Private Function IMath_®(ByVal a As Variant, ByVal b As Variant) As Object
    Dim c As IConvertible
    Set c = New AksiFloat
    Set IMath_® = New AksiFloat
    IMath_®.Value = c.Convert(a) / c.Convert(b)
End Function
'Функция сравнения элементов класса.
Private Function IComparable_CompareTo(ByVal another As Object) As Long
    If v < another Then
        IComparable_CompareTo = -1
    ElseIf v > another Then
        IComparable_CompareTo = 1
    End If
End Function

Код класса AksiChar

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
'________________________________________________________________
'_______________________                   ______________________
'_____________________    Модуль AksiChar   _____________________
'____________________      Версия: 0.5.0     ____________________
'___________________       Автор: Aksima      ___________________
'___________________  Библиотека: AksiArrays  ___________________
'________________________________________________________________
'__________                                            __________
'__________  Назначение: Обработка символьных данных.  __________
'________________________________________________________________
 
Implements IFactory 'Поддерживает создание объектом класса других объектов этого же класса.
Implements ISerializable 'Поддерживает сериализацию данных.
Implements ICloneable 'Определяет функцию для создания полной копии объекта.
Implements IComparable 'Определяет встроенный способ сравнения элементов.
Dim v As Byte
'Свойство по умолчанию - получение.
Public Property Get Value() As Byte
    Value = v
End Property
'Свойство по умолчанию - установка.
Public Property Let Value(ByVal vNew As Byte)
    v = vNew
End Property
'Создание объекта класса.
Private Function IFactory_NewOb() As Object
    Set IFactory_NewOb = New AksiChar
End Function
Private Function ISerializable_Serialize() As String 'Сериализация.
    Select Case v 'Маскируем символы со специальным значением.
        Case 0 'Нулевой символ - вместо него в файл записался бы пробел.
            ISerializable_Serialize = "@!%"
        Case 9, 13, 32, 44 'Разделители текстового файла.
            ISerializable_Serialize = """" & Chr(v) & """"
        Case 26 'Символ с кодом 26 - признак конца файла в системах DOS и Windows.
            ISerializable_Serialize = "$@#"
        Case 34 'Кавычки - ограничивают текст, воспринимаемый "как есть".
            ISerializable_Serialize = "#%$"
        Case Else
            ISerializable_Serialize = Chr(v)
    End Select
End Function
Private Sub ISerializable_Unserialize(ByVal s As String) 'Десериализация.
    Select Case s 'Демаскировка.
        Case "@!%"
            v = 0
        Case "$@#"
            v = 26
        Case "#%$"
            v = 34
        Case Else
            v = Asc(s)
    End Select
End Sub
'Создание полной копии объекта.
Private Function ICloneable_Copy() As Object
    Set ICloneable_Copy = New AksiChar
    ICloneable_Copy = v
End Function
'Функция сравнения элементов класса.
Private Function IComparable_CompareTo(ByVal another As Object) As Long
    If v < another Then
        IComparable_CompareTo = -1
    ElseIf v > another Then
        IComparable_CompareTo = 1
    End If
End Function

Код класса AksiString

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
'________________________________________________________________
'_______________________                   ______________________
'______________________  Модуль AksiString  _____________________
'_____________________     Версия: 0.5.0     ____________________
'____________________      Автор: Aksima      ___________________
'___________________   Библиотека: AksiArrays  __________________
'________________________________________________________________
'_________________                               ________________
'________________   Назначение: Обработка строк.  _______________
'________________________________________________________________
 
Implements IFactory 'Поддерживает создание объектом класса других объектов этого же класса.
Implements ISerializable 'Поддерживает сериализацию данных.
Implements ICloneable 'Определяет функцию для создания полной копии объекта.
Implements IComparable 'Определяет встроенный способ сравнения элементов.
Dim v As String
'Свойство по умолчанию - получение.
Public Property Get Value() As String
    Value = v
End Property
'Свойство по умолчанию - установка.
Public Property Let Value(ByVal vNew As String)
    v = vNew
End Property
'Создание объекта своего типа.
Private Function IFactory_NewOb() As Object
    Set IFactory_NewOb = New AksiString
End Function
Private Function ISerializable_Serialize() As String 'Сериализация.
    Dim s As String
    s = Replace(Replace(Replace(v, Chr(0), "@!%"), Chr(26), "$@#"), """", "#%$")
    If InStr(s, vbTab) + InStr(s, vbCr) + InStr(s, " ") + InStr(s, ",") > 0 Then s = """" & s & """"
    ISerializable_Serialize = s
End Function
Private Sub ISerializable_Unserialize(ByVal s As String) 'Десериализация.
    v = Replace(Replace(Replace(s, "#%$", """"), "$@#", Chr(26)), "@!%", Chr(0))
End Sub
'Создание полной копии объекта.
Private Function ICloneable_Copy() As Object
    Set ICloneable_Copy = New AksiString
    ICloneable_Copy = v
End Function
'Функция сравнения элементов класса.
Private Function IComparable_CompareTo(ByVal another As Object) As Long
    If v < another Then
        IComparable_CompareTo = -1
    ElseIf v > another Then
        IComparable_CompareTo = 1
    End If
End Function

Код класса AksiDate

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
'________________________________________________________________
'_______________________                   ______________________
'_____________________    Модуль AksiDate   _____________________
'____________________      Версия: 0.5.0     ____________________
'___________________       Автор: Aksima      ___________________
'___________________  Библиотека: AksiArrays  ___________________
'________________________________________________________________
'_________________                              _________________
'_________________  Назначение: Обработка дат.  _________________
'________________________________________________________________
 
Implements IFactory 'Поддерживает создание объектом класса других объектов этого же класса.
Implements ISerializable 'Поддерживает сериализацию данных.
Implements ICloneable 'Определяет функцию для создания полной копии объекта.
Implements IComparable 'Определяет встроенный способ сравнения элементов.
Dim v As Date
'Свойство по умолчанию - получение.
Public Property Get Value() As Date
    Value = v
End Property
'Свойство по умолчанию - установка.
Public Property Let Value(ByVal vNew As Date)
    v = vNew
End Property
'Создание объекта класса.
Private Function IFactory_NewOb() As Object
    Set IFactory_NewOb = New AksiDate
End Function
Private Function ISerializable_Serialize() As String 'Сериализация.
    Dim i As Long, p(0 To 5) As Integer, arr As Variant
    arr = Array("yyyy", "m", "d", "h", "n", "s")
    'Раскладываем дату на части.
    For i = 0 To 5
        p(i) = DatePart(arr(i), v)
    Next i
    'В зависимости от состава даты выбираем подходящее строковое представление.
    Select Case CLng((p(0) = 1899) And (p(1) = 12) And (p(2) = 30)) + _
        2 * CLng((p(3) = 0) And (p(4) = 0) And (p(5) = 0))
        Case 0
            ISerializable_Serialize = Format(v, "yyyy\/mm\/dd hh\:nn\:ss")
        Case -1
            ISerializable_Serialize = Format(v, "hh\:nn\:ss")
        Case -2
            ISerializable_Serialize = Format(v, "yyyy\/mm\/dd")
        Case -3
            ISerializable_Serialize = "00:00:00"
    End Select
End Function
Private Sub ISerializable_Unserialize(ByVal s As String) 'Десериализация.
    Dim i As Long, p(0 To 5) As Integer
    If s = "00:00:00" Then
        v = #12:00:00 AM#
    ElseIf s Like "????/??/?? ??:??:??" Then
        p(0) = Val(Left(s, 4))
        For i = 1 To 5
            p(i) = Val(Mid(s, 3 * i + 3, 2))
        Next i
        v = DateSerial(p(0), p(1), p(2)) + TimeSerial(p(3), p(4), p(5))
    ElseIf s Like "????/??/??" Then
        p(0) = Val(Left(s, 4))
        p(1) = Val(Mid(s, 6, 2))
        p(2) = Val(Right(s, 2))
        v = DateSerial(p(0), p(1), p(2))
    ElseIf s Like "??:??:??" Then
        For i = 0 To 2
            p(i) = Val(Mid(s, 3 * i + 1, 2))
        Next i
        v = TimeSerial(p(0), p(1), p(2))
    End If
End Sub
'Создание полной копии объекта.
Private Function ICloneable_Copy() As Object
    Set ICloneable_Copy = New AksiDate
    ICloneable_Copy = v
End Function
'Функция сравнения элементов класса.
Private Function IComparable_CompareTo(ByVal another As Object) As Long
    If v < another Then
        IComparable_CompareTo = -1
    ElseIf v > another Then
        IComparable_CompareTo = 1
    End If
End Function

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

Для получения доступа к значению этой переменной программист может использовать свойство Value:

Value() As Long/Double/Byte/String/Date <Property Get/Set> - возвращает или устанавливает значение переменной-члена класса. Тип этой переменной зависит от класса: Long для класса AksiInteger, Double для класса AksiFloat, Byte для класса AksiChar, String для класса AksiString и, наконец, Date для класса AksiDate.

Но, как правило, чаще к значению элемента базового типа обращаются не напрямую, а посредством различных методов, представляемых базовыми структурами массивов, и которые были рассмотрены в предыдущем разделе.

Аксима · 25.06.2014, 17:33

Глава третья: "Обзор интерфейсов"

Интерфейсы обеспечивают унифицированную обработку данных вне зависимости от их типа. Это очень важно, так как позволяет базовым структурам массивов работать с данными любого типа, не вдаваясь в тонкости реализации того или иного типа данных.

Список операций, которые могут поддерживаться базовыми или пользовательскими типами данных, довольно велик, но лишь одна из них нуждается в обязательной поддержке - операция создания объекта реализуемого базового или пользовательского типа (определенная в интерфейсе IFactory). Ее важность обуславливается тем, что без реализации данной операции базовые структуры не могут создать массив объектов данного типа, а значит, и работа с таким массивом в какой бы то ни было форме становится невозможной.

Что касается остальных операций, то решение о их поддержке принимается в зависимости от целей, которые ставятся над проектируемым типом данных. Если предолагается вывод информации в текстовые или иные файлы - реализуется интерфейс ISerializable. Если нужно сравнивать элементы между собой (в том числе в ходе сортировки) - в типе данных реализуется интерфейс IComparable или создается специальный класс с реализацией интерфейса IComparer. Если нужна возможность производить математические вычисления с использованием разработанного типа данных - реализуются интерфейсы IConvertible и IMath. И наконец, очень важным интерфейсом является интерфейс ICloneable, реализация которого позволяет структурам данных создавать точные копии элементов со всеми их значениями, вместо того, чтобы копировать только ссылки на элементы (что чревато потерей данных в ходе их модификации по одной из ссылок). Листинги всех интерфейсов приводятся ниже.

Код интерфейса IFactory

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
'________________________________________________________________
'_______________________                 ________________________
'______________________  Модуль IFactory  _______________________
'_____________________    Версия: 0.0.0    ______________________
'____________________     Автор: Aksima      ____________________
'___________________  Библиотека: AksiArrays  ___________________
'________________________________________________________________
'______________                                    ______________
'______________  Назначение: Определяет интерфейс  ______________
'______________  для создания классовых объектов.  ______________
'________________________________________________________________
 
Public Function NewOb() As Object
End Function

Код интерфейса ISerializable

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
'________________________________________________________________
'_____________________                      _____________________
'____________________  Модуль ISerializable  ____________________
'_____________________    Версия: 0.0.0    ______________________
'____________________     Автор: Aksima      ____________________
'___________________  Библиотека: AksiArrays  ___________________
'________________________________________________________________
'_______________                                   ______________
'______________  Назначение: Определяет интерфейс   _____________
'_________________  для сериализации объектов.  _________________
'________________________________________________________________
 
Public Function Serialize() As String
End Function
Public Sub Unserialize(ByVal s As String)
End Sub

Код интерфейса ICloneable

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
'________________________________________________________________
'______________________                   _______________________
'_____________________  Модуль ICloneable  ______________________
'____________________     Версия: 0.0.0     _____________________
'___________________      Автор: Aksima      ____________________
'__________________   Библиотека: AksiArrays  ___________________
'________________________________________________________________
'_______________                                  _______________
'______________  Назначение: Определяет интерфейс  ______________
'_____________  для создания точной копии объекта.  _____________
'________________________________________________________________
 
Public Function Copy() As Object
End Function

Код интерфейса IComparer

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
'________________________________________________________________
'_______________________                  _______________________
'______________________  Модуль IComparer  ______________________
'_____________________    Версия: 0.0.0     _____________________
'____________________     Автор: Aksima      ____________________
'___________________  Библиотека: AksiArrays  ___________________
'________________________________________________________________
'_______________                                   ______________
'______________  Назначение: Определяет интерфейс   _____________
'_________________  для объекта - "сравнителя".  ________________
'________________________________________________________________
 
Public Function Compare(ByVal one As Object, ByVal another As Object) As Long
End Function

Код интерфейса IComparable

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
'________________________________________________________________
'______________________                    ______________________
'_____________________  Модуль IComparable  _____________________
'_____________________    Версия: 0.0.0     _____________________
'____________________     Автор: Aksima      ____________________
'___________________  Библиотека: AksiArrays  ___________________
'________________________________________________________________
'_______________                                   ______________
'______________  Назначение: Определяет интерфейс   _____________
'_____________  для сравнения объектов между собой.  ____________
'________________________________________________________________
 
Public Function CompareTo(ByVal another As Object) As Long
End Function

Код интерфейса IConvertible

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
'________________________________________________________________
'____________________                       _____________________
'____________________  Модуль IConvertible  _____________________
'_____________________    Версия: 0.0.0    ______________________
'____________________     Автор: Aksima      ____________________
'___________________  Библиотека: AksiArrays  ___________________
'________________________________________________________________
'_____                                                       ____
'_____  Назначение: Определяет интерфейс для преобразования  ____
'______   объекта одного класса в объект другого класса.   ______
'________________________________________________________________
 
Public Function Convert(ByVal x As Variant) As Object
End Function

Код интерфейса IMath

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
'________________________________________________________________
'_______________________                _________________________
'______________________   Модуль IMath   ________________________
'_____________________    Версия: 0.0.0    ______________________
'____________________     Автор: Aksima      ____________________
'___________________  Библиотека: AksiArrays  ___________________
'________________________________________________________________
'______________                                    ______________
'____________    Назначение: Определяет интерфейс     ___________
'___________  для выполнения математических операций.  __________
'________________________________________________________________
 
'Функция 'C'ложить (сложения).
Public Function ©(ByVal a As Variant, ByVal b As Variant) As Object
End Function
'Функция "знак минус" (вычитания)
Public Function *(ByVal a As Variant, ByVal b As Variant) As Object
End Function
'Функция "знак умножения" (умножения)
Public Function ·(ByVal a As Variant, ByVal b As Variant) As Object
End Function
'Функция 'R'азделить (деления) или отношения (Ratio)
Public Function ®(ByVal a As Variant, ByVal b As Variant) As Object
End Function

Примеры решения задач с использованием методов библотеки AksiArrays

В этой главе приведены примеры решения задач из первой части статьи средствами библиотеки AksiArrays. Попробуйте сравнить объем кода в этих примерах с примерами программ из первой части.

Решение задачи №1

Пусть показания температуры находятся в файле "Geo.txt". Тогда решение задачи таково:

Visual Basic
1
2
3
4
5
6
Sub AverageTemperatureAksima()
    Dim v As New AksiVector
    v.Init New AksiFloat, 31
    v.GetData_TextFile "Geo.txt"
    MsgBox "Средняя температура января: " & Format(v.Average, "0.0") & " градуса."
End Sub

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

Решение задачи №2

Предположим, что оценки учащихся находятся в файле "Pupils.txt":

Visual Basic
1
2
3
4
5
6
7
Sub ControlWorkRatingsAksima()
    Dim v As New AksiVector
    v.Init New AksiInteger, 20
    v.GetData_TextFile "Pupils.txt"
    v.PutData_DialogBox "Содержимое классного журнала"
    v.CountUnique.PutData_DialogBox "Оценки и их количество"
End Sub

Здесь использована функция CountUnique, которая, как уже отмечалось, позволяет быстро и удобно определить уникальные элементы целочисленного массива и подсчитать их количество.

Решение задачи №3

Visual Basic
1
2
3
4
5
6
7
Sub FindMaxNumberAksima()
    Dim m As New AksiMatrix
    m.Init New AksiInteger, 10, 8
    m.GetData_RandomGenerator 50, 99
    m.PutData_DialogBox "Сгенерированный массив"
    MsgBox "Максимальный элемент массива: " & m.Max
End Sub

Иницализация массива случайными значениями, его вывод в диалоговое окно и поиск максимального значения массива - с новой библиотекой каждая операция требует только одной команды.

Решение задачи №4

Visual Basic
1
2
3
4
5
6
7
8
Sub SortNumbersAksima()
    Dim v As New AksiVector
    v.Init New AksiInteger, 50
    v.GetData_RandomGenerator 50, 99
    v.PutData_DialogBox "Перед упорядочиванием"
    v.Sort
    v.PutData_DialogBox "После упорядочивания"
End Sub

Выполнить сортировку данных в рассматриваемой задаче помогает библитечная функция Sort. По умолчанию она осуществляет сортировку данных по неубыванию методом пузырка. Но можно выбрать и другие параметры сортировки.

Решение задачи №5

Исходя из того, что оценки учащихся по всем предметам находятся в файле "PupSubjs.txt", можно написать следующий код:

Visual Basic
1
2
3
4
5
6
7
Sub PupilAndSubjectAveragesAksima()
    Dim m As New AksiMatrix
    m.Init New AksiInteger, 20, 3
    m.GetData_TextFile "PupSubjs.txt"
    m.Parts(AO_ROWS).GroupOperation("Average", VbGet, New AksiFloat).PutData_DialogBox "Средние оценки учащихся"
    m.Parts(AO_COLUMNS).GroupOperation("Average", VbGet, New AksiFloat).PutData_DialogBox "Средние оценки по каждому предмету"
End Sub

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

Решение задачи №6

Visual Basic
1
2
3
4
5
6
7
Sub TrianglesExtremesDifferenceAksima()
    Dim m As New AksiMatrix: Const N = 6
    m.Init New AksiInteger, N, N
    m.GetData_RandomGenerator 50, 99
    m.PutData_DialogBox "Обрабатываемая матрица"
    MsgBox "Разница между максимальным элементом над главной диагональю и минимальным элементом под главной диагональю равна: " & m.Parts(AO_UP_MAIN_EXC).Max - m.Parts(AO_DOWN_MAIN_EXC).Min
End Sub

Волшебная функция Parts умеет извлекать не только строки или столбцы, но и более сложные элементы матрицы, такие, например, как треугольник над большой диагональю матрицы.

Заключение

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

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

Аксима · 25.06.2014, 17:35

История проекта

Версия 0.0.0 - 24 декабря 2013 г.

Начата работа над базовыми структурами массивов.

Класс AksiVector	0.0.0
Класс AksiMatrix	0.0.0
Класс AksiCube	0.0.0

Версия 0.1.0 - 29 декабря 2013 г.

Созданы базовые типы данных.

Класс AksiInteger	0.0.0
Класс AksiFloat	0.0.0
Класс AksiChar	0.0.0
Класс AksiString	0.0.0
Класс AksiDate	0.0.0

Версия 0.2.0 - 11 января 2014 г.

Реализована идея интерфейса IFactory, позволяющего создавать объекты класса, не известного заранее.

Интерфейс IFactory

0.0.0

Версия 0.3.0 - 19 января 2014 г.

В базовые структуры массивов добавлены процедуры Init для инициализации их элементов с использованием интерфейса IFactory.

Класс AksiVector	0.1.0
Класс AksiMatrix	0.1.0
Класс AksiCube	0.1.0

Версия 0.4.0 - 26 января 2014 г.

Интерфейс IFactory реализован для всех базовых типов данных.

Класс AksiInteger	0.1.0
Класс AksiFloat	0.1.0
Класс AksiChar	0.1.0
Класс AksiString	0.1.0
Класс AksiDate	0.1.0

Версия 0.5.0 - 1 февраля 2014 г.

В базовые типы данных добавлено свойство по умолчанию Value.

Класс AksiInteger	0.2.0
Класс AksiFloat	0.2.0
Класс AksiChar	0.2.0
Класс AksiString	0.2.0
Класс AksiDate	0.2.0

Версия 0.6.0 - 9 февраля 2014 г.

В базовые структуры массивов добавлено свойство по умолчанию Item.

Класс AksiVector	0.2.0
Класс AksiMatrix	0.2.0
Класс AksiCube	0.2.0

Версия 0.7.0 - 15 февраля 2014 г.

Разработаны функции для получения общего количества элементов массива и количества элементов массива по тому или иному измерению.

Класс AksiVector	0.3.0
Класс AksiMatrix	0.3.0
Класс AksiCube	0.3.0

Версия 0.8.0 - 22 февраля 2014 г.

Реализована идея интерфейса ISerializable, позволяющего сериализовывать содержимое объекта в строковой переменной и проводить обратную операцию.

Интерфейс ISerializable

0.0.0

Версия 0.9.0 - 1 марта 2014 г.

В класс AksiVector добавлены процедуры для записи вектора в текстовый файл и чтения вектора из текстового файла с использованием интерфейса ISerializable.

Класс AksiVector

0.4.0

Версия 0.10.0 - 8 марта 2014 г.

Интерфейс ISerializable реализован для классов AksiInteger и AksiFloat.

Класс AksiInteger	0.3.0
Класс AksiFloat	0.3.0

Версия 0.11.0 - 9 марта 2014 г.

Интерфейс ISerializable реализован для классов AksiChar и AksiString. Особое внимание уделено проблеме отличения кавычек, используемых в качестве спецсимвола, от просто кавычек.

Класс AksiChar	0.3.0
Класс AksiString	0.3.0

Версия 0.12.0 - 15 марта 2014 г.

Интерфейс ISerializable реализован для класса AksiDate. Осуществлен анализ составляющих даты и ее приведение к стандарту, принятому для данного класса.

Класс AksiDate

0.3.0

Версия 0.12.1 - 22 марта 2014 г.

Реализация интерфейса ISerializable для классов AksiChar и AksiString изменена с учетом символов с кодами 0 и 26, а также символов - разделителей.

Класс AksiChar	0.3.1
Класс AksiString	0.3.1

Версия 0.12.2 - 23 марта 2014 г.

Реализация интерфейса ISerializable для класса AksiDate изменена с применением раздельной обработки данных в формате дата/время, данных в формате даты и данных в формате времени. Таким образом, достигнуто уменьшение размера сериализованного файла.

Класс AksiDate

0.3.1

Версия 0.13.0 - 30 марта 2014 г.

В класс AksiMatrix добавлена процедура для записи матрицы в текстовый файл с использованием интерфейса ISerializable.

Класс AksiMatrix

0.4.0

Версия 0.13.1 - 4 апреля 2014 г.

Процедура для записи матрицы в текстовый файл в классе AksiMatrix дополнена соответствующей процедурой для ее чтения из файла.

Класс AksiMatrix

0.4.1

Версия 0.14.0 - 5 апреля 2014 г.

В класс AksiCube добавлена процедура для записи куба в текстовый файл с использованием интерфейса ISerializable.

Класс AksiCube

0.4.0

Версия 0.14.1 - 12 апреля 2014 г.

Процедура для записи куба в текстовый файл в классе AksiCube дополнена соответствующей процедурой для его чтения из файла.

Класс AksiCube

0.4.1

Версия 0.14.2 - 19 апреля 2014 г.

Изменен способ записи слоев куба: теперь слои располагаются в текстовом файле не сплошным потоком по горизонтали, а раздельными прямоугольными участками по вертикали. Несмотря на то, что данный подход ухудшает скорость чтения и записи данных, он является куда более выигрышным с эстетической точки зрения.

Класс AksiCube

0.4.2

Версия 0.14.3 - 20 апреля 2014 г.

В связи с изменением способа записи слоев куба, в классах AksiVector и AksiMatrix были соответствующим образом изменен порядок следования разделителей, а также добавлен обработка специфического для куба разделителя.

Класс AksiVector	0.4.1
Класс AksiMatrix	0.4.2

Версия 0.15.0 - 26 апреля 2014 г

В класс AksiVector добавлена процедура для записи вектора в файл Excel. Было принято решение разделить ответственность за обработку данных, передаваемых в Excel и из него, между свойством Value и методами интерфейса ISerialzable. В соответствии с этим решением из реализации интерфейса ISerialzable классом AksiDate был убран функционал, предназначавшийся для особых случаев и фактически дублировавший функционал, предоставляемый свойством Value.

Класс AksiVector	0.5.0
Класс AksiDate	0.3.2

Версия 0.15.1 - 1 мая 2014 г.

Процедура для записи вектора в файл Excel в классе AksiVector дополнена соответствующей процедурой для его чтения из файла.

Класс AksiVector

0.5.1

Версия 0.15.2 - 2 мая 2014 г.

Добавлена возможность при записи векторов в файл Excel присваивать им заголовки. При чтении векторов из файла они позволяют нам указать, какой именно вектор нас интересует, без ручного вычисления адреса диапазона, содержащего искомый вектор.

Класс AksiVector

0.5.2

Версия 0.16.0 - 3 мая 2014 г.

В класс AksiMatrix добавлены процедуры для записи матрицы в файл Excel и ее чтения из файла Excel. Обнаружена и исправлена ошибка при записи текстовых файлов и файлов Excel в несуществующий каталог.

Класс AksiVector	0.5.3
Класс AksiMatrix	0.5.0

Версия 0.16.1 - 4 мая 2014 г.

Неоднократно повторяющийся процесс создания необходимых каталогов при их отсутствии вынесен в отдельную скрытую процедуру в каждом классе.

Класс AksiVector	0.5.4
Класс AksiMatrix	0.5.1

Версия 0.17.0 - 10 мая 2014 г.

В класс AksiCube добавлены процедуры для записи куба в файл Excel и его чтения из файла Excel.

Класс AksiCube

0.5.0

Версия 0.17.1 - 11 мая 2014 г.

Процедуры для записи куба в файл Excel и его чтения из файла Excel класса AksiCube теперь осуществляют "умный" поиск считываемых данных или места вставки новых данных.

Класс AksiCube

0.5.1

Версия 0.18.0 - 17 мая 2014 г.

В класс AksiVector добавлена процедура для вывода данных из вектора на диалоговое окно.

Класс AksiVector

0.6.0

Версия 0.18.1 - 18 мая 2014 г.

В класс AksiVector добавлена процедура для ввода данных в вектор через диалоговое окно.

Класс AksiVector

0.6.1

Версия 0.19.0 - 24 мая 2014 г.

В класс AksiMatrix добавлена процедура для вывода данных из матрицы на диалоговое окно.

Класс AksiMatrix

0.6.0

Версия 0.19.1 - 25 мая 2014 г.

В класс AksiMatrix добавлена процедура для ввода данных в матрицу через диалоговое окно.

Класс AksiMatrix

0.6.1

Версия 0.20.0 - 30 мая 2014 г.

В класс AksiCube добавлена процедура для вывода данных из слоев куба в диалоговые окна.

Класс AksiCube

0.6.0

Версия 0.20.1 - 31 мая 2014 г.

В класс AksiCube добавлена процедура для ввода данных в куб через диалоговое окно.

Класс AksiCube

0.6.1

Версия 0.21.0 - 1 июня 2014 г.

Интерфейсы IFactory и ISerializable реализованы для класса AksiVector, что открывает возможность создания и чтения/записи массивов с любым числом измерений.

Класс AksiVector

0.7.0

Версия 0.22.0 - 5 июня 2014 г.

Реализован подход к сортировке элементов массивов через интерфейсы IComparable и IComparer.

Интерфейс IComparable	0.0.0
Интерфейс IComparer	0.0.0

Версия 0.23.0 - 7 июня 2014 г.

Интерфейс IComparable реализован для всех базовых типов данных.

Класс AksiInteger	0.4.0
Класс AksiFloat	0.4.0
Класс AksiChar	0.4.0
Класс AksiString	0.4.0
Класс AksiDate	0.4.0

Версия 0.24.0 - 8 июня 2014 г.

Осуществлена базовая реализация процедуры сортировки элементов вектора.

Класс AksiVector

0.8.0

Версия 0.25.0 - 11 июня 2014 г.

В класс AksiMatrix добавлена процедура преобразования матрицы в вектор ее элементов, а также процедура заполнения матрицы элементами вектора.

Класс AksiMatrix

0.7.0

Версия 0.26.0 - 14 июня 2014 г.

В класс AksiCube добавлена процедура преобразования куба в вектор его элементов, а также процедура заполнения куба элементами вектора.

Класс AksiCube

0.7.0

Версия 0.27.0 - 15 июня 2014 г.

В класс AksiVector добавлена процедура, заполняющая вектор данными с помощью генератора случайных чисел.

Класс AksiVector

0.9.0

Версия 0.28.0 - 17 июня 2014 г.

В класс AksiMatrix добавлена процедура, заполняющая матрицу данными с помощью генератора случайных чисел.

Класс AksiMatrix

0.8.0

Версия 0.29.0 - 19 июня 2014 г.

В класс AksiCube добавлена процедура, заполняющая куб данными с помощью генератора случайных чисел.

Класс AksiCube

0.8.0

Версия 0.30.0 - 21 июня 2014 г.

Реализованы интерфейсы IConvertible и IMath, необходимые для произведения математических операций над числами и объектами, представляющими числа.

Интерфейс IConvertible	0.0.0
Интерфейс IMath	0.0.0

Интерфейсы IConvertible и IMath реализованы для классов, представляющих числа.

Класс AksiInteger	0.5.0
Класс AksiFloat	0.5.0

Версия 0.31.0 - 22 июня 2014 г.

Реализован подход к созданию полноценных копий ссылочных объектов через интерфейс ICloneable.

Интерфейс ICloneable

0.0.0

Интерфейс IComparable реализован для всех базовых типов данных.

Класс AksiInteger	0.6.0
Класс AksiFloat	0.6.0
Класс AksiChar	0.5.0
Класс AksiString	0.5.0
Класс AksiDate	0.5.0

Версия 0.32.0 - 23 июня 2014 г.

В класс AksiVector добавлены процедуры для получения суммы, произведения и средних значений элементов массива.
Кроме того, в класс AksiVector добавлена функция групповой обработки данных GroupOperation.

Класс AksiVector

0.11.0

Версия 1.0.0 - 24 июня 2014 г.

Процедура сортировки теперь определена также для классов AksiMatrix и AksiCube.

Класс AksiMatrix	0.9.0
Класс AksiCube	0.9.0

Кроме того, в класс AksiVector добавлены следующие методы сортировки: выборкой и вставками.

Класс AksiVector

0.11.2

Примечание: хотя не все связанные с проектом задумки были реализованы, но проект сильно затянулся, поэтому было принято решение, что пора уже показывать библиотеку сообществу.
Таким образом, последней версии библиотеки присвоен номер версии 1.0.0.

Версия 1.1.0 - 25 июня 2014 г.

В класс AksiVector добавлен очень полезная функция Filter, ряда возможностей которой нет даже у автофильтра Excel (например, эта функция позволяет отобрать элементы, дающие определенный остаток при делении на модуль X).
Также обновлен интерфейс IMath и классы AksiInteger и AksiFloat

Интерфейс IMath	0.1.0
Класс AksiInteger	0.7.0
Класс AksiFloat	0.7.0
Класс AksiVector	0.12.0

Версия 1.2.0 - 26 июня 2014 г.

Класс AksiVector обновился свойством, позволяющим задать значения всех элементов вектора одновременно, а также свойствами, позволяющими выделить элементы вектора с четными индексами и элементы с нечетными индексами.

Класс AksiVector

0.13.0

Последняя версия библиотеки - 1.2.0. Последнее обновление - 26 июня 2014 г.

О приложениях

В приложениях представлена библиотека AksiArrays в двух версиях:

архив модулей;
готовые файлы для приложений Word и Excel.

Если вы ведете разработку в приложении, отличном от Word или Excel - качайте архив модулей и импортируйте их в свой проект. Если разработка ведется в Word или Excel - вам достаточно скачать готовые файлы с уже импортированными модулями.

Кроме того, в приложении находится архив с текстовыми файлами, используемыми в примерах решения задач с использованием методов библотеки AksiArrays:

Geo.txt
Pupils.txt
PupSubjs.txt

@Антихакер32 · 13.07.2014, 16:01

Реализация калькулятора на VBA

Похожий код я уже выкладывал в разделе VB6, правда он там гдето затерялся
так вот теперь решил адаптировать под VBA
Сам код мне нужен был, только для того чтоб научиться другому ЯП
чтобы использовать основную логику этой программы
и решил, чтоб не пропадать добру, поделиться им здесь
Для того чтоб все заработало, нужно только скопировать этот код,
который представленн ниже, в модуль формы UserForm и запустить
уверен что там найдется множество полезных
решений для Вас

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
Option Explicit
'
'Калькулятор на VBA ... © Антихакер32™ ...2014
'
Const nX = 6, nY = 4, p = " ", Promt1 = "<Деление на 0>", Promt2 = "<Переполнение>"
Private Declare Function GetSystemMetrics32& Lib "User32" Alias "GetSystemMetrics" (ByVal nIndex&)
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Dim Matrix32(nX - 1, nY - 1) As CommandButton
Dim WithEvents cmm As CommandButton
Dim WithEvents cmb As ComboBox
Dim pos&, col As Collection, X&, Y&, Script As Object
 
Private Sub UserForm_Initialize()
    Dim sL&, sz&, st&, SM2&, o As Object
    SM2 = GetSystemMetrics32(2)
    sL = 100 / SM2: sz = 500 / SM2: st = sz + sL * 2
    Dim j$(), s$, i&, h&
    s = s & "7 8 9 = CE Sqr "
    s = s & "4 5 6 ( ) x^y "
    s = s & "1 2 3 + - Fix "
    s = s & "0 , % * / Mod "
    Set Script = CreateObject("MSScriptControl.ScriptControl"): Script.Language = "VBScript"
    Set col = New Collection: j = Split(s)
    For Y = 0 To nY - 1: For X = 0 To nX - 1
            Set Matrix32(X, Y) = Controls.Add("forms.CommandButton.1", "cmm_" & X & Y)
            With Matrix32(X, Y)
                Select Case X
                Case 3, 4: .Move sL * 2 + X * sz, st + Y * sz, sz, sz: .Visible = 1
                Case 5: .Move sL * 3 + X * sz, st + Y * sz, sz * 1.5, sz: .Visible = 1
                Case Else: .Move sL + X * sz, st + Y * sz, sz, sz
                End Select:  .FontSize = 10: .FontBold = 1: .Caption = j(i): i = i + 1: .Visible = 1
            End With
    Next: Next
    Set cmb = Controls.Add("forms.ComboBox.1", "cmb")
    With cmb
        .FontSize = 10: h = .Height
        .Move sL, Matrix32(0, 0).Top - h - sL, (Matrix32(nX - 1, 0).Left + Matrix32(nX - 1, 0).Width) - sL: .Visible = 1: .Text = 0
        Me.Width = .Width + sL * 3
    End With
    Set o = Controls("cmm_" & X - 1 & Y - 1)
    Me.Height = o.Top + o.Height + sz + sL
    Me.Caption = "Калькулятор VBA ... © Антихакер32™"
End Sub
 
Private Function Calc(ByVal Expression$)
    Dim s$, j$(), f&
    On Error GoTo EndFunction
    f = InStr(1, Expression, "<") 'Если в выражениях есть тег ошибки то выход
    If f Then Calc = Mid$(Expression, f): Calc = Left$(Calc, InStr(1, Calc, ">")): Exit Function
    Expression = Trim$(Split(Expression, "=")(0)) 'Отсееваем до знака равенства
    Expression = Replace(Expression, "%", "*0.01") 'Переименовать процент
    s = p & p: While InStr(1, Expression, s): Expression = Replace(Expression, s, p): Wend
    Expression = Replace(Expression, ",", ".") 'Переименовать разделитель для Eval
    Calc = Script.Eval(Expression) 'Вычисление !
    Exit Function
EndFunction:
    Calc = "<" & Err.Description & ">"
End Function
Private Sub cmm_Click()
    Dim s$: Static Result$, f&, b(2) As Boolean
    cmb.SetFocus: b(0) = 0 'Сброс оператора
    If Len(Result) Then 'Сброс если после прежнего результата, пойдет ввод цифр
        If IsNumeric(cmm.Caption) Then cmb.Text = ""
        Select Case cmm.Caption
        Case "Sqr", "Fix": cmb.Text = ""
        End Select
    End If: b(2) = b(1) Or cmb.Text = "0" Or cmb.Text = ""
    Select Case cmm.Caption 'Действия по вводу зависимо от активного названия кнопки
    Case "="
        f = InStr(1, cmb, "="): If f Then cmb.Text = Left$(cmb, f - 1)
        Result = Calc(cmb): cmb.Text = Trim$(Replace(cmb, p & p, p))
        s = cmb & " = " & Result: cmb.Text = Result
        On Error Resume Next: col.Add 0, s 'Попытаться добавить в коллекцию
        If Err.Number = 0 Then cmb.AddItem s Else Err.Clear
        cmb.Text = Result: pos = Len(cmb): cmb.SelStart = pos: Erase b: GoTo EndSub
    Case "CE": cmb.Text = 0: pos = 1: cmb.SelStart = pos: Erase b: GoTo EndSub
    Case "x^y": s = p & "^" & p: b(0) = 1
    Case "-" 'Проверка на второй минус
        For f = Len(cmb) To 1 Step -1
            s = Mid$(cmb, f, 1): If IsNumeric(s) Then Exit For
            If s = "-" Then GoTo EndSub
        Next: s = p & cmm.Caption & p: b(1) = 0: b(0) = 1
    Case "+", "*", "/", "Mod": s = p & cmm.Caption & p: b(0) = 1
    Case "," 'Проверка на повтор разделителя
        For f = Len(cmb) To 1 Step -1: s = Mid$(cmb, f, 1)
            If s = "," Then
                GoTo EndSub
            ElseIf Not IsNumeric(s) Then Exit For
            End If
        Next: s = cmm.Caption
    Case "Fix", "Sqr":  If b(2) Then s = cmm.Caption & "(": b(1) = 0: b(0) = 1
    Case "(": If b(2) Then s = cmm.Caption: b(1) = 0: b(0) = 1
    Case ")": If Not b(1) Then s = cmm.Caption Else GoTo EndSub
    Case "%": If Right$(cmb, 1) <> "%" Then s = cmm.Caption
    Case Else: s = cmm.Caption
    End Select
    If b(1) And b(0) Then GoTo EndSub Else b(1) = b(0)
    If Left$(cmb, 1) = "0" Then cmb.Text = Mid$(cmb, 2)
    cmb.SelStart = pos: cmb.SelText = s: pos = pos + Len(s): Result = ""
    Exit Sub
EndSub: cmb.SelStart = pos
End Sub
Private Sub UserForm_Activate()
    Do: DoEvents: Sleep 50: tmr_Timer: Loop
End Sub
Private Sub tmr_Timer()
    Static OldName$
    If OldName <> ActiveControl.Name And ActiveControl.Name Like "cmm_##" Then
        Set cmm = ActiveControl
    End If: OldName = ActiveControl.Name
End Sub
Private Sub cmb_Validate(Cancel As Boolean): pos = cmb.SelStart: End Sub
Private Sub UserForm_Terminate(): End: End Sub

Так-же выкладываю независимое скомпилированное приложение
с реализацией стиля Windows

PS. Лично я уже пользуюсь вместо стандартного встроенного

@Антихакер32 · 24.07.2014, 07:40

Программа для регистрации библиотек, без запроса админских прав.

Мне удалось это зделать !

В режиме регистрации
Программа записывает ключи и GUID-ы для каждого класса DLL или OCX
в реестр, в режиме отмены, удаляется все безследно.
идея принадлежит пользователю под ником "Аналитика" (CyberForum.ru)

Так-же можно ввести относительный путь, тоесть только файловое имя DLL-ки
например: wsh.Run "RegLib Min.dll", 0, 1
wsh.Run "RegLib Min.dl /s", 0, 1 'При ошибке сообщения не будет

Команды /S и /U можно вводить в любой очередности
но первый параметр должен быть путь к DLL

Могу продемонстрировать часть кода из RegLib, остальное военная тайна

Кликните здесь для просмотра всего текста

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
Option Explicit: Option Compare Text
'
'Программа, для регистрации библиотек, без запроса админских прав
'© Антихакер32™ // Матерьялы взяты здесь: [url]https://www.cyberforum.ru/visual-basic/thread649325.html[/url]
'
Const k = "\", r = "/"
Const Promt1 = "Файл не найден", Promt2 = "Файл не является библиотекой Dll // Ocx"
'=================
Const sPATH_BASE As String = "HKEY_CURRENT_USER\Software\Classes\"
Const sCOMPONENTCATEGORIESGUID = "{40FC6ED5-2438-11CF-A3DB-080036F12502}"
Const sPSOAINTERFACE = "{00020424-0000-0000-C000-000000000046}"
Dim mWShell As Object, mTLI As Object, mFSO As Object
Dim j$(), f&
 
Sub Main()
    Dim result&, b(1) As Boolean, Promt$, Ext$, hMod&
    On Error Resume Next:  DeleteSetting App.EXEName: Err.Clear
    j = Split(Command$, r)
    For f = 0 To UBound(b): b(f) = 1: Next
    For f = 0 To UBound(j): j(f) = Trim(j(f))
        If f Then
            Select Case UCase(j(f))
            Case "S": b(0) = False 'Разрешение показывать сообщения
            Case "U": b(1) = False 'Отмена регистрации
            End Select
    End If: Next
    j(0) = getFSO.GetAbsolutePathName(j(0))
    If Not getFSO.FileExists(j(0)) Then Promt = Promt1: GoTo 101
    Ext = getFSO.GetExtensionName(j(0))
    If Not (Ext Like "dll" Or Ext Like "ocx") Then Promt = Promt2: GoTo 101
    result = Register(j(0), b(1))
    If Err Then
        Promt = "Error " & Err.Number & vbCrLf & Err.Description
        If b(1) Then Call Register(j(0), 0) 'Удалить созданные ключи
    End If
    SaveSetting App.EXEName, 0, 0, result
101
    If Len(Promt) And b(0) Then MsgBox Promt, vbCritical
    SaveSetting App.EXEName, 0, 0, result 'Сохранить в реестр
End Sub

Как пользоваться?!, версия для макроса VBA:
в архиве есть сама прога (RegLib.exe) и тестовая DLL (min.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
Option Explicit
'
'Программа, для регистрации библиотек, без запроса админских прав
'Первый параметр вызова должен быть путь,
'можно относительный после него, в любой последовательности идут ключи
'/s /u ...где /s - это тихий режим, /u - отмена регистрации
'© Антихакер32™ // Матерьялы взяты здесь: [url]https://www.cyberforum.ru/visual-basic/thread649325.html[/url]
'
Dim wsh As Object
 
Private Sub Test_Reg()
    'Тест регистрации
    '
    Dim o As Object, path$
    Set wsh = CreateObject("WScript.Shell")
    ChDir ThisWorkbook.path
    wsh.Run "RegLib Min.dll", 0, 1
    If GetSetting("RegLib", 0, 0) Then
        Set o = CreateObject("Project1.Class1")
        o.out "Hello Word!"
    End If
    wsh.Run "RegLib Min.dll /u/s", 0, 1 'Отменить регистрацию по тихому :)
End Sub

должно будет появится сообщение "Привет мир!"

Кликните здесь для просмотра всего текста

Версия тэста, для VB6
Архив с файлом проекта, необходимыми компонентами, и одной формы,
ниже код этой формы:

Кликните здесь для просмотра всего текста

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
Option Explicit
'
'Регистрация и динамическое подключение тест
'// © Антихакер32™
'
Const cn = "dlg_" 'Component Name
Dim WithEvents dlg As VBControlExtender
'
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function DispCallFunc Lib "oleaut32" (ByVal PPV As Long, ByVal oVft As Long, ByVal cc As Long, ByVal rtTYP As VbVarType, ByVal paCNT As Long, paTypes As Any, paValues As Any, ByRef fuReturn As Variant) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryW" (ByVal lpLibFileName As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Dim wsh As Object
 
Private Sub dlg_LostFocus()
    If Left$(ActiveControl.Name, Len(cn) + 1) Like cn & "#" Then
        Set dlg = ActiveControl
    End If
End Sub
 
Private Sub dlg_ObjectEvent(Info As EventInfo)
    'Пример реакции на события этого компонента
    Debug.Print Info.Name
    Select Case Info.Name
    Case "Help" 'Вызов подсказок
        Info.EventParameters(1) = "Кнопка " & Info.EventParameters(1)
        Info.EventParameters(2) = "Пример вызова подсказки по правой кнопке"
        Info.EventParameters(3) = 7 '1,2,3 ,7
    Case "SelectPath" 'Выбран путь
        MsgBox "Выбран путь" & vbCrLf & dlg.object.Text
    End Select
End Sub
 
Private Sub Form_Load()
    'Динамически регестрируем и создаем этот компонент
    Dim f&, o As Object
    Set wsh = CreateObject("WScript.Shell")
    ChDir App.Path 'Устанавливаем папку по умолчанию
    wsh.Run "RegLib Dialogs.ocx", 0, 1
    If GetSetting("RegLib", 0, 0) Then
        Call Controls.Add("Dialogs.dlgBrawser", cn & Controls.Count)
        Call Controls.Add("Dialogs.dlgColor", cn & Controls.Count)
        Controls(cn & Controls.Count - 1).object.Color = vbButtonFace
        Call Controls.Add("Dialogs.dlgOpenSave", cn & Controls.Count)
        For f = 0 To Controls.Count - 1
            With Controls(cn & f): .Move 100, f * 800, 3000
                .object.Caption = Choose(f + 1, "Браузер", "Выбор цвета", "Открыть-сохранить")
                .Visible = 1
            End With
        Next: Set dlg = Controls(cn & 0)
    End If
    DeleteSetting "RegLib"
End Sub
 
Private Sub Form_Terminate()
    'Можно отменить зарегестрированный компонент
    wsh.Run "RegLib Dialogs.ocx /s /u", 0, 1
    DeleteSetting "RegLib"
End Sub

И тоже, появится следущая картинка:

Кликните здесь для просмотра всего текста

обсуждение можно продолжить здесь и здесь

@Апострофф · 24.07.2014, 08:36

Не по теме:

Привет слово!

Dragokas · 24.07.2014, 11:44

Не по теме:

Плагиат с Hello World-ом нипадецки.

@ikki · 27.07.2014, 11:56

возможно, кому-то пригодится: xlCompiler

xlCompiler converts Excel workbook into stand-alone application file. This application doesn't require Microsoft Excel to be installed on the PC. It is completely independent from Excel and other libraries. You are getting application where all formulas and macros are comletely hidden and converted into the binary code.

немного смущает это:

At this moment xlCompiler supports basic features available in the Spreadsheet Applications (like Microsoft Excel)

впрочем, как я понимаю, проект развивается.

пс. сам не пробовал.

@Антихакер32 · 28.07.2014, 19:53

Нестандартная форма на VBA

Простой пример, как получить описатель пользовательского окна (hWnd)
и что можно, после этого вытворять с формой

Для демонстрации примера, необходимо запустить файл .xls
в той-же папке, где будет находиться картинка amsn_8001.gif

вот эти файлы:
https://www.cyberforum.ru/blog... 1406562083

Код модуля UserForm:

Кликните здесь для просмотра всего текста

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
Option Explicit
'
'нестандартная форма
'© Антихакер32™
'
'-----------------------------------------[Константы]
Private Const GWL_EXSTYLE = (-20)
Private Const WS_EX_LAYERED As Long = &H80000
Private Const LWA_COLORKEY = &H1
'-----------------------------------------[Api функции]
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "User32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Declare Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Sub InitCommonControls Lib "comctl32.dll" ()
Private Declare Function GetSystemMetrics32& Lib "User32" Alias "GetSystemMetrics" (ByVal nIndex&)
Dim hwnd&, SMX&, SMY&
 
Private Sub UserForm_Activate()
    Me.Move -SMX, -SMY, SMX * 2.5, SMY * 2.5
End Sub
 
Private Sub UserForm_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    End 'По двойному клику выход из программы
End Sub
 
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, _
ByVal Y As Single)
    '
    'Перемещение, по правой кнопке прога остановится
    '
    Static x1 As Single, y1 As Single
    If Button = 1 Then
        Me.Left = Me.Left - x1 + X
        Me.Top = Me.Top - y1 + Y
    Else
        x1 = X: y1 = Y
    End If
    
End Sub
 
Private Sub UserForm_Initialize()
    Const KeyColor = &HFF00DC 'Фиолетовый цвет ключ прозрачности
    Dim Style As Long, PicFile$
    'Получаем описатель окна
    hwnd = FindWindow(vbNullString, Me.Caption)
    PicFile = ThisWorkbook.Path
    ChDir PicFile 'Устанавливаем папку этой книги
    PicFile = PicFile & "\amsn_8001.gif"
    SMX = GetSystemMetrics32(0)
    SMY = GetSystemMetrics32(1)
    Me.BackColor = KeyColor
    Style = GetWindowLong(hwnd, GWL_EXSTYLE) Or WS_EX_LAYERED
    SetWindowLong hwnd, GWL_EXSTYLE, Style
    SetLayeredWindowAttributes hwnd, KeyColor, 0, LWA_COLORKEY
    Me.Picture = LoadPicture(PicFile)
End Sub

Должна получиться следующая картина:

Кликните здесь для просмотра всего текста

Добавлено через 5 минут
Здесь, тоже-самое, я реализовал на VB6

Dragokas · 07.08.2014, 12:24

Microsoft Photo Editor

Этот маленький редактор идет вместе с офисом (если не ошибаюсь 2000 версии).
С сайта M$ его скачивание уже не доступно (видимо посчитали, что устарел).
А везде в интернете какие-то очень кривые установщики (несмотря на наличие цифровой подписи M$).

Как то он мне полюбился. И я приберег нормальные файлы редактора из своего офиса. Решил поделиться.
Будет работать только при наличии установленного MS Office (по идее).

@Антихакер32 · 19.08.2014, 17:23

Настоящий браузер на VBA..

недавно столкнулся с такой проблемой, что мне понадобились статистические
сведения о запросах в яндексе и гугле..
так вот, собрал свой браузер для этих целей
если кому пригодится, пользуйтесь

Код модуля формы UserForm

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
Option Explicit
 
Private Type rect
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As rect) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As rect) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Public WithEvents cmm1 As CommandButton
Public WithEvents cmm2 As CommandButton
Public WithEvents cmm3 As CommandButton
Public WithEvents cmm4 As CommandButton
Public WithEvents cmm5 As CommandButton
Dim WithEvents cmb As ComboBox
Dim Brows As Object
Dim wx&, wy&, ww&, wh&, hWnd&, home$, f&, s$
 
Private Sub cmb_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    With Brows.Object
        If KeyCode = 13 Then
            Debug.Print KeyCode
            If InStr(1, cmb.Text, "http", 1) = 0 Then
                .Navigate "https://www.google.ru/search?as_q=" & cmb.Text
            Else
                'Если текст поменялся, то запомнить новый адрес
                For f = 0 To cmb.ListCount - 1
                    If StrComp(cmb.Text, cmb.List(f), 1) = 0 Then Exit For
                Next
                If f = cmb.ListCount Then cmb.AddItem cmb.Text
                .Navigate cmb.Text
            End If
            KeyCode = 0
        End If
    End With
End Sub
 
Private Sub cmm5_Click()
    On Error Resume Next
    Brows.Object.stop
End Sub
 
Private Sub cmm4_Click()
    On Error Resume Next
    Brows.Object.Refresh
End Sub
 
Private Sub cmm3_Click()
    On Error Resume Next
    Brows.Object.GoForvard
End Sub
 
Private Sub cmm2_Click()
    On Error Resume Next
    Brows.Object.GoBack
End Sub
 
Private Sub cmm1_Click()
    On Error Resume Next
    Brows.Object.GoHome
End Sub
 
Private Sub ScrollBar1_Change()
 
End Sub
 
Private Sub UserForm_Initialize()
    Dim Left&, rect(1) As rect
    Application.DisplayAlerts = False
    wx = GetSystemMetrics(0): wy = GetSystemMetrics(1)
    Me.Move 0, 0, wx / 1.5, wy / 1.5
    Me.Caption = "Вэб-браузер на VBA ... © Антихакер32™"
    hWnd = FindWindow(vbNullString, Me.Caption)
    Call GetWindowRect(hWnd, rect(0))
    Call GetClientRect(hWnd, rect(1))
    ww = (rect(0).Right - rect(1).Right) / 2: ww = Me.Width - ww
    wh = (rect(0).Bottom - rect(1).Bottom): wh = Me.Height - wh
    Dim cmm As Object
    For f = 1 To 5
        s = "cmm" & f
        Call CallByName(Me, s, VbSet, Controls.Add("forms.CommandButton.1", s))
        With Me.Controls(s)
            .AutoSize = 1
            .Caption = Choose(f, "Домой", "Назад", "Вперед", "Обновить", "Стоп")
            .Left = Left: Left = Left + .Width
        End With
    Next
    Set cmb = Controls.Add("forms.ComboBox.1", "cmb")
    With cmb
        .Left = Left
        .Width = ww - Left
        .AddItem "http://yandex.ru/"
        .AddItem "http://google.ru/"
        .ListIndex = 0
    End With
 
    Set Brows = Controls.Add("Shell.Explorer.2", "Brows")
    With Brows
        .Move 0, cmm1.Height, ww, wh - cmm1.Top - cmb.Height
        .Object.Navigate cmb.Text
    End With
 
End Sub

Добавлено через 27 минут

Не по теме:

PS
Запускать желательно на 2003 офисе, но можно и на 2007-м, только надо выключить
все параметры безопасности, а вообще, если приложить фантазию
то теперь можно все что угодно делать с интернетом, например программно посылать
любые команды в окно браузера, скачивать и копипастить страницы..
ну всякое...

внес изменения теперь стартовая страница, Яндекс! :)
добавил кнопку остановки и убрал таймеры

@Антихакер32 · 29.08.2014, 18:18

Эмуляция Print

Жаль что на VBA невозможно произвести на форме
обычную рапечатку, и я решил хоть как-то это исправить

так-же учитывается новая строка в тексте VbCrLf

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
Option Explicit
'
'Эмуляция Print // Cls на VBA
' © Антихакер32 (CyberForum.ru)
'
#Const Demo = 1 'Если демонстрация не нужна, то эту строку можно закоментировать
 
Dim WithEvents LsBx As MSForms.ListBox
#If Demo Then
    Public WithEvents cm1 As MSForms.CommandButton
    Public WithEvents cm2 As MSForms.CommandButton
    Private Sub cm1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
        EmPrint "Случайное число =", Rnd
    End Sub
    Private Sub cm2_Click(): EmCls: End Sub
#End If
 
Sub EmCls(): LsBx.Clear: End Sub
Sub EmPrint(ParamArray Vars())
    Dim s$, v
    For Each v In Vars: s = s & v & vbTab: Next
    For Each v In Split(s, vbCrLf): LsBx.AddItem v: Next
End Sub
 
Private Sub UserForm_Initialize()
    Dim f&, s$, L&, t&
    #If Demo Then
        For f = 1 To 2: s = "cm" & f
            CallByName Me, s, VbSet, Controls.Add("forms.CommandButton.1", s)
            With Controls(s): .AutoSize = 1
                .Caption = Choose(f, "Эмуляция *Print*", "Эмуляция *CLS*")
                .Move L, 0: L = L + .Width
            End With
        Next: Randomize Timer: t = cm1.Height
    #End If
    Set LsBx = Controls.Add("Forms.ListBox.1", "LsBx", 1)
    With LsBx
        .Move 0, t, Me.Width, Me.Height
        .BackColor = Me.BackColor:  .Font = Me.Font
        .Enabled = 0: .ZOrder 1
    End With
End Sub

Пример использования:

Visual Basic
1
EmPrint "Размеры:", 10, 20, 30

@Антихакер32 · 30.08.2014, 23:01

Эмуляция таймера на VBA, через сабкласинг

Решил выложить нормальный пример, для демонстрации таймера,
как отдельного потока, тоесть можно одновременно работать с листом
и выполняемым макросом

Код модуля

Кликните здесь для просмотра всего текста

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
Option Explicit
'Эмуляция таймера на листе, с добавлением спец-кнопки, чтоб его остановить
'© Антихакер32
Public Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
Dim iTmr&, sh As Worksheet, btn2 As Button
 
Sub StartTimer()
    Set sh = ActiveSheet
    With sh.Cells(1, 2) '$B$1 'Создание кнопки, чтоб можно было остановить таймер !
        Set btn2 = sh.Buttons.Add(.Left, .Top, .Width * 3, .Height)
    End With
    btn2.Caption = "Нажмите для остановки"
'    btn2.AutoSize = 1 'Авторазмер кнопки !
    btn2.OnAction = "EndTimer"
    sh.Cells(2, 1).NumberFormat = "[h]:mm:ss;@" 'Форматируем одну ячейку для показа времени
    iTmr = SetTimer(0, 0, 100, AddressOf TimerProg)
End Sub
 
Sub TimerProg(ByVal hWnd As Long, ByVal msg As Long, ByVal idEvent As Long, ByVal TimeSys As Long)
    On Error Resume Next 'Обязательно включить обработчик ошибок, чтоб не вылетала среда !
    '
    'Далее любое действие
    sh.Cells(1, 1).Value = sh.Cells(1, 1).Value + 1
    'Например показываем время !
    sh.Cells(2, 1).Value = Format(Time, "h:m:s")
End Sub
 
Sub EndTimer()
    KillTimer 0, iTmr
    sh.Buttons(btn2.Name).Delete 'Удаление кнопки
End Sub

Картинка

Кликните здесь для просмотра всего текста

Видео:
clip0002.rar (19.1 Кб)

Dragokas · 31.08.2014, 11:34

Антихакер32
в VBA именно это уже реализовано во встроенной функции Application.OnTime.

@The trick · 31.08.2014, 11:46

Сообщение от Антихакер32

Эмуляция таймера на VBA, через сабкласинг

Какой сабклассинг? Где тут сабклассинг? Ты посмотри сначала что такое сабклассинг и не дезинформируй людей.

Сообщение от Антихакер32

как отдельного потока

да развесилил конечно. Покажи функцию которая создает поток хотя-бы. Твой код выполняется последовательно.

@Антихакер32 · 03.09.2014, 01:22

Вот, я выложил свои продвинутые версии
где таймеры можно использовать многократно
Золотая коллекция классов
непоместилось в один пост, вот Вторая часть

и картинка,

PS
Критиковать, всегда легче, чем реально чтото делать

Добавлено через 6 минут
Монтировал на VB6, но текст, что я выложил легко подойдет к VBA-макросам
там никаких отдельных OCX-..ов

@Антихакер32 · 09.09.2014, 23:29

Библиотека UGVB6

Представляю вашему вниманию релиз нативной библиотеки
которая была писанна на VB6, и частично мною была протестированна
в 2007-м офисе

Подробнее здесь: https://www.cyberforum.ru/post6591449.html

@101 · 15.12.2014, 07:02

Красивая кнопка

В последнее время мне часто приходиться делать проекты с одной-двумя кнопками
нажал, и все пересчиталось скопировалось и отчиталось

и я решил потратить пару дней на создание кнопки с подсветкой и подсказкой
но столкнулся с непреодалимой преградой...
во первых, объекты Shape, из которых я и хотел сделать её, не реагируют на мышку
во вторых, для таких объектов не предусмотренно отображение подсказок
в том виде, в котором мы привыкли их видеть

Тема была начата здесь

Наконец, пользователь KoGG (спасибо ему) натолкнул меня на мысль, что можно
использовать прозрачный ActiveX-объект, от которого можно получить нужные события

и я решил сделать слоенный пирог:
в неактивном состоянии, на переднем плане выступает объект Image,
а как только произошла реакция, тут-же передвинуть вперед нашу кнопку ))

и включить API-шный таймер, который бы проверял, не вышел ли курсор за границу активной кнопки
и если вышел, то опять вернуть прежнюю позицию и прежний цвет
проверил, все работает, отлично. Но с подсказкой пришлось помучиться
все перебрал, пробовал сделать отдельный лейбл который бы появлялся в нужное время
но такое вмешательство подтормаживает программу

затем обратил внимание на гиперссылку, и на то что к гиперссылке можно привязать
помимо адресса и подсказку тоже ))
и опять но! Возникла трудность с реализацией макроса
Обычно на автофигуру можно назначить либо макрос, либо гиперссылку с подсказкой, но не одновременно.

пришлось и это как-то обойти
Я сделал гиперссылку на ячейку активного листа, а уже в событии листа
на изменение активной ячейки

Visual Basic
1
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

можно перенаправить выполнение программы

там я откоментировал в своём модуле ))

Visual Basic
1
2
3
4
5
6
7
        'Хитрый трюк с гиперссылкой
        If Len(TText) Then
            addr = .Cells(y, x).Address
            .Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:= _
            "", SubAddress:=.Name & "!" & addr, ScreenTip:=TText
            Butt.AlternativeText = addr
        End If

Получилось так, и API-шный таймер не особо перегружает процессы
и мгновенная реакция на уход курсора куда-либо
и настоящие подсказки имеются )) все по взрослому ))

Теперь эту кнопку не отличить от той, которая отображается у меня в системе
причем все дополнительно настраиваеться, вот константы:

Visual Basic
1
2
3
4
Private Const Passive_Color = 49 'Неактивный цвет
Private Const Active_Color = 44 'Подсветка
Private Const PassiveLine_Color = 21
Private Const ActiveLine_Color = 12

теперь это не какой-то унылый, серый квадрат,
теперь у этой кнопки есть душа ))

Проект состоит из основного модуля BeautifulButton
и событий на рабочем листе, я их постарался реализовать как можно удобнее
для копирования

Visual Basic
1
2
3
4
5
6
7
8
9
Private Sub BeautifulButtonImage1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    BB_MMoove x, y, 1
End Sub
Private Sub BeautifulButtonImage2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    BB_MMoove x, y, 2
End Sub
Private Sub BeautifulButtonImage3_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    BB_MMoove x, y, 3
End Sub

Ниже прилагаю готовый проект, надеюсь теперь я буду чаще видеть приятные глазу кнопки
и как я уже говорил, кнопок много не бывает ))

Аксима · 27.01.2015, 17:18

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

Отличительной особенностью этого класса является полная поддержка всех встроенных в VBA числовых типов данных. Поддерживается перевод в указанные системы счисления чисел, хранящися в переменных типа Byte, Integer, Long, Single, Double или Currency.

Перевод осуществляется следующим образом:

Создается объект класса AksiNumberConverter.
Вызывается процедура ParseNumber, в которую в качестве параметра передается число, которое необходимо перевести в другую систему счисления.
С помощью свойств BinaryValue, OctalValue, HexadecimalValue вы получаете строковое представление числа в нужной системе счисления.

Код класса AksiNumberConverter

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
Const BITS_IN_BYTE = 8  'Количество бит в байте.
Const BYTE_CNT = 256    'Количество значений, хранимых в Byte-переменной.
'Перечисление доступных видов точности вещественного числа.
Private Enum Precisions
    SINGLE_PREC
    DOUBLE_PREC
End Enum
'Перечисление доступных характеристик вещественного числа.
Private Enum Fields
    BYT_SZ
    BIT_SZ
    SGN_POS
    SGN_CNT
    EXP_POS
    EXP_CNT
    EXP_OFS
    MNS_POS
    MNS_CNT
End Enum
Private Type SingleV
    x As Single
End Type
Private Type SingleB
    x(0 To 3) As Byte
End Type
Private Type DoubleV
    x As Double
End Type
Private Type DoubleB
    x(0 To 7) As Byte
End Type
Dim neg As Boolean 'Флаг отрицательного числа.
Dim n As Long, m As Long 'Размеры целой и дробной части числа.
Dim b() As Byte, f() As Byte 'Целая и дробная части числа.
Dim sep As String 'Разделитель целой и дробной части числа.
Dim d(0 To 7) As Byte 'Массив степеней двойки от 0 до 7.
Dim s(0 To BYTE_CNT - 1) As String * BITS_IN_BYTE 'Массив двоичных представлений чисел.
'Массив характеристик чисел с плавающей точкой встроенного типа.
Dim p(SINGLE_PREC To DOUBLE_PREC, BYT_SZ To MNS_CNT) As Long
'Вспомогательная функция, выделяющая из массива bits отрезок, начинающийся с позиции position,
'и состоящий из count элементов.
Private Function SelectBits(ByRef bits() As Long, ByVal position As Long, ByVal count As Long) _
    As Long()
    Dim i As Long, sb() As Long
    ReDim sb(0 To count - 1) As Long
    For i = 0 To count - 1
        sb(i) = bits(i + position)
    Next i
    SelectBits = sb
End Function
'Вспомогательная функция, возвращающая величину числа, выраженого массивом бит.
Private Function BitsToNumber(ByRef bits() As Long) As Long
    Dim i As Long, u As Long
    u = UBound(bits)
    BitsToNumber = bits(u)
    For i = u - 1 To 0 Step -1
        BitsToNumber = 2 * BitsToNumber + bits(i)
    Next i
End Function
'Процедура, анализирующая вещественное число.
Private Sub ParseRealNumber(ByRef bytes() As Byte, ByVal pcn As Precisions)
    Dim i As Long, j As Long, k As Long, nzPos As Long, nLen As Long, iLen As Long, fLen As Long
    Dim bits() As Long, exponenta As Long, mantissa() As Long, iPart() As Long, fPart() As Long
    'Копируем информацию из байт числа в битовый массив.
    ReDim bits(0 To p(pcn, BIT_SZ) - 1) As Long
    For i = 0 To p(pcn, BYT_SZ) - 1
        For j = 0 To BITS_IN_BYTE - 1
            If bytes(i) And d(j) Then bits(BITS_IN_BYTE * i + j) = 1
        Next j
    Next i
    'Определяем знак числа.
    neg = SelectBits(bits, p(pcn, SGN_POS), p(pcn, SGN_CNT))(0)
    'Вычисляем экспоненту.
    exponenta = BitsToNumber(SelectBits(bits, p(pcn, EXP_POS), p(pcn, EXP_CNT))) - p(pcn, EXP_OFS)
    'Получаем мантиссу.
    mantissa = SelectBits(bits, p(pcn, MNS_POS), p(pcn, MNS_CNT))
    'Определяем позицию первого значащего бита, начиная с начала мантиссы.
    nLen = UBound(mantissa) + 1
    For nzPos = 0 To nLen - 1
        If mantissa(nzPos) = 1 Then Exit For
    Next nzPos
    nLen = nLen - nzPos
    'В зависимости от значения экспоненты определяем целую и дробную части мантиссы.
    If exponenta < 0 Then 'Если экспонента меньше нуля, то число состоит только из дробной части.
        iLen = 0
        fLen = nLen - exponenta
        ReDim fPart(0 To fLen - 1)
        For i = 0 To nLen - 1 'Заполняем биты дробной части, начиная с начала, битами мантиссы,
            fPart(i) = mantissa(nzPos + i) 'начиная с первого значащего бита.
        Next i
        fPart(nLen) = 1
    ElseIf exponenta >= nLen Then 'Если экспонента больше или равна длине мантиссы - число целое.
        iLen = exponenta + 1
        fLen = 0
        ReDim iPart(0 To iLen - 1)
        iPart(iLen - 1) = 1
        For i = 0 To nLen - 1 'Заполняем биты целой части, начиная с конца, битами мантиссы,
            iPart(iLen - i - 2) = mantissa(nzPos + nLen - i - 1) 'начиная с ее конца.
        Next i
        iPart(iLen - 1) = 1
    Else 'В противном случае мантисса содержит как целую, так и дробную части.
        iLen = exponenta + 1
        fLen = nLen - exponenta
        ReDim iPart(0 To iLen - 1)
        ReDim fPart(0 To fLen - 1)
        For i = 0 To fLen - 1
            fPart(i) = mantissa(nzPos + i)
        Next i
        For i = 0 To iLen - 2
            iPart(iLen - i - 2) = mantissa(nzPos + nLen - i - 1)
        Next i
        iPart(iLen - 1) = 1
    End If
    'Если число содержит целую часть, то заполняем байты целой части.
    If iLen Then
        n = iLen \ BITS_IN_BYTE
        'Кратно ли число бит количеству бит в байте?
        k = iLen Mod BITS_IN_BYTE
        If k Then 'Если не кратно, то...
            '...к количеству байт целой части добавляем еще один для хранения "хвостика".
            n = n + 1
            ReDim b(0 To n - 1) As Byte
            '...и записываем в добавленный байт k бит хвостика.
            b(n - 1) = BitsToNumber(SelectBits(iPart, iLen - k, k))
            'Заполняем остальные байты.
            For i = 0 To n - 2
                b(i) = BitsToNumber(SelectBits(iPart, i * BITS_IN_BYTE, BITS_IN_BYTE))
            Next i
        Else 'Если число бит кратно количеству бит в байте...
            ReDim b(0 To n - 1) As Byte
            For i = 0 To n - 1
                b(i) = BitsToNumber(SelectBits(iPart, i * BITS_IN_BYTE, BITS_IN_BYTE))
            Next i
        End If
    Else 'Если число не содержит целой части, то считается, что она равна нулю.
        n = 1
        ReDim b(0 To 0) As Byte
        b(0) = 0
    End If
    'Если число содержит дробную часть, то заполняем байты дробной части.
    If fLen Then
        m = fLen \ BITS_IN_BYTE
        'Кратно ли число бит количеству бит в байте?
        k = fLen Mod BITS_IN_BYTE
        If k Then 'Если не кратно, то...
            '...к количеству байт дробной части добавляем еще один для хранения "хвостика".
            m = m + 1
            ReDim f(0 To m - 1) As Byte
            '...и записываем в добавленный байт k бит хвостика, дополнив их в начале нулями.
            f(0) = BitsToNumber(SelectBits(fPart, 0, k)) * d(BITS_IN_BYTE - k)
            'Заполняем остальные байты.
            For i = 1 To m - 1
                f(i) = BitsToNumber(SelectBits(fPart, (i - 1) * BITS_IN_BYTE + k, BITS_IN_BYTE))
            Next i
        Else 'Если число бит кратно количеству бит в байте...
            ReDim f(0 To m - 1) As Byte
            For i = 0 To m - 1
                f(i) = BitsToNumber(SelectBits(fPart, i * BITS_IN_BYTE, BITS_IN_BYTE))
            Next i
        End If
    Else 'Если число не содержит дробной части, то удаляем дробную часть.
        m = 0
        Erase f
    End If
End Sub
'Процедура, проводящая анализ числа num и инициализацию полей класса на основании данных,
'полученных при анализе числа num.
Public Sub ParseNumber(ByVal num As Variant)
    Dim i As Long, j As Long, sv As SingleV, sb As SingleB, dv As DoubleV, db As DoubleB
    Dim с As String, сs() As String, mTmp As Long, fTmp() As Byte
    Select Case TypeName(num) 'Смотрим, какой тип имеет переменная num...
        Case "Byte" 'Переменная типа Byte занимает строго один байт целой части и не имеет знака.
            neg = False
            n = 1
            ReDim b(0 To 0) As Byte
            b(0) = num
            m = 0
            Erase f
        Case "Integer" 'Переменная типа Integer занимает от 1 до 2 байт целой части.
            If num < 0 Then
                neg = True
                num = -num
            Else
                neg = False
            End If
            If num >= 0 And num < BYTE_CNT Then
                n = 1
                ReDim b(0 To 0) As Byte
                b(0) = num
            Else
                n = 2
                ReDim b(0 To 1) As Byte
                b(0) = num Mod BYTE_CNT
                b(1) = num \ BYTE_CNT
            End If
            m = 0
            Erase f
        Case "Long" 'Переменная типа Long занимает от 1 до 4 байт целой части.
            If num < 0 Then
                neg = True
                num = -num
            Else
                neg = False
            End If
            j = 1
            For i = 1 To 4
                j = BYTE_CNT * j
                If num < j Then
                    n = i
                    ReDim b(0 To n - 1) As Byte
                    b(0) = num Mod BYTE_CNT
                    For j = 1 To n - 1
                        num = num \ BYTE_CNT
                        b(j) = num Mod BYTE_CNT
                    Next j
                    Exit For
                End If
            Next i
            m = 0
            Erase f
        Case "Single" 'Вещественные переменные переводим в массив байт и анализируем.
            sv.x = num
            LSet sb = sv
            ParseRealNumber sb.x, SINGLE_PREC
        Case "Double"
            dv.x = num
            LSet db = dv
            ParseRealNumber db.x, DOUBLE_PREC
        Case "Currency"
            с = CStr(num)
            'Если суммарное количество цифр целой и дробной части переменной типа Currency
            'меньше или равно 15, то число может быть точно представлено типом Double.
            If Len(Replace(Replace(с, "-", vbNullString), sep, vbNullString)) <= 15 Then
                ParseNumber CDbl(num)
            Else 'Иначе разбиваем число на целую и дробную части и анализируем их отдельно.
                сs = Split(с, sep)
                ParseNumber CDbl("0" & sep & сs(1))
                mTmp = m
                fTmp = f
                ParseNumber CDbl(сs(0))
                m = mTmp
                f = fTmp
            End If
        Case Else
            Err.Raise 13
    End Select
End Sub
'Двоичное представление числа.
Property Get BinaryValue() As String
    Dim i As Long
    If m Then
        For i = 0 To m - 1
            BinaryValue = s(f(i)) & BinaryValue
        Next i
        BinaryValue = sep & Replace(RTrim(Replace(BinaryValue, "0", " ")), " ", "0")
    End If
    For i = 0 To n - 1
        BinaryValue = s(b(i)) & BinaryValue
    Next i
    BinaryValue = Replace(LTrim(Replace(BinaryValue, "0", " ")), " ", "0")
    If BinaryValue = vbNullString Then BinaryValue = "0"
    If InStr(BinaryValue, sep) = 1 Then BinaryValue = "0" & BinaryValue
    If neg Then BinaryValue = "-" & BinaryValue
End Property
'Восьмеричное представление числа.
Property Get OctalValue() As String
    Dim i As Long, j As Long, k As Long
    If m Then
        k = m Mod 3
        Select Case k
            Case 1
                OctalValue = Oct(f(0) * d(1)) & OctalValue
            Case 2
                OctalValue = Oct((BYTE_CNT * f(1) + f(0)) * d(2)) & OctalValue
        End Select
        For i = k To m - 1 Step 3
            OctalValue = Oct(BYTE_CNT * (BYTE_CNT * f(i + 2) + f(i + 1)) + f(i)) & OctalValue
        Next i
        OctalValue = sep & Replace(RTrim(Replace(OctalValue, "0", " ")), " ", "0")
    End If
    k = n Mod 3
    For i = 0 To n - k - 1 Step 3
        OctalValue = Oct(BYTE_CNT * (BYTE_CNT * b(i + 2) + b(i + 1)) + b(i)) & OctalValue
    Next i
    Select Case k
        Case 1
            OctalValue = Oct(b(n - 1)) & OctalValue
        Case 2
            OctalValue = Oct(BYTE_CNT * b(n - 1) + b(n - 2)) & OctalValue
    End Select
    OctalValue = Replace(LTrim(Replace(OctalValue, "0", " ")), " ", "0")
    If OctalValue = vbNullString Then OctalValue = "0"
    If InStr(OctalValue, sep) = 1 Then OctalValue = "0" & OctalValue
    If neg Then OctalValue = "-" & OctalValue
End Property
'Шестнадцатеричное представление числа.
Property Get HexadecimalValue() As String
    Dim i As Long
    If m Then
        For i = 0 To m - 1
            If f(i) < 16 Then
                HexadecimalValue = "0" & Hex(f(i)) & HexadecimalValue
            Else
                HexadecimalValue = Hex(f(i)) & HexadecimalValue
            End If
        Next i
        HexadecimalValue = sep & Replace(RTrim(Replace(HexadecimalValue, "0", " ")), " ", "0")
    End If
    For i = 0 To n - 1
        If b(i) < 16 Then
            HexadecimalValue = "0" & Hex(b(i)) & HexadecimalValue
        Else
            HexadecimalValue = Hex(b(i)) & HexadecimalValue
        End If
    Next i
    HexadecimalValue = Replace(LTrim(Replace(HexadecimalValue, "0", " ")), " ", "0")
    If HexadecimalValue = vbNullString Then HexadecimalValue = "0"
    If InStr(HexadecimalValue, sep) = 1 Then HexadecimalValue = "0" & HexadecimalValue
    If neg Then HexadecimalValue = "-" & HexadecimalValue
End Property
'При инициализации класса определяем разделитель и заполняем вспомогательные массивы.
Private Sub Class_Initialize()
    Dim i As Long, j As Long, k As Long
    sep = Format(0, ".")
    d(0) = 1
    For i = 1 To 7
        d(i) = 2 * d(i - 1)
    Next i
    For i = 1 To BITS_IN_BYTE
        Mid(s(0), i, 1) = "0"
    Next i
    For i = 1 To BYTE_CNT - 1
        k = Mid(s(i - 1), BITS_IN_BYTE, 1)
        Mid(s(i), BITS_IN_BYTE, 1) = 1 - k
        For j = BITS_IN_BYTE - 1 To 1 Step -1
            If k Then
                k = Mid(s(i - 1), j, 1)
                Mid(s(i), j, 1) = 1 - k
            Else
                Mid(s(i), j, 1) = Mid(s(i - 1), j, 1)
            End If
        Next j
    Next i
    p(SINGLE_PREC, BYT_SZ) = 4
    p(SINGLE_PREC, BIT_SZ) = 32
    p(SINGLE_PREC, SGN_POS) = 31
    p(SINGLE_PREC, SGN_CNT) = 1
    p(SINGLE_PREC, EXP_POS) = 23
    p(SINGLE_PREC, EXP_CNT) = 8
    p(SINGLE_PREC, EXP_OFS) = 127
    p(SINGLE_PREC, MNS_POS) = 0
    p(SINGLE_PREC, MNS_CNT) = 23
    p(DOUBLE_PREC, BYT_SZ) = 8
    p(DOUBLE_PREC, BIT_SZ) = 64
    p(DOUBLE_PREC, SGN_POS) = 63
    p(DOUBLE_PREC, SGN_CNT) = 1
    p(DOUBLE_PREC, EXP_POS) = 52
    p(DOUBLE_PREC, EXP_CNT) = 11
    p(DOUBLE_PREC, EXP_OFS) = 1023
    p(DOUBLE_PREC, MNS_POS) = 0
    p(DOUBLE_PREC, MNS_CNT) = 52
End Sub

С уважением,

Аксима

@Night Ranger · 28.01.2015, 06:54

Сообщение от Аксима

С уважением,Аксима

Вы просто молодец, добавлю Вас в друзья ! если не против..

Новые блоги и статьи Все статьи Все блоги /
Калькулятор для расчета родства russiannick 07.08.2026 1. Задача: Создать калькулятор для расчета родства. Родственных связей существует 8 ступеней, такие как: p - отец P - мать q - муж Q - жена b - брат B - сестра s - сын S - дочь	Мир по моей воле kumehtar 07.08.2026 Когда-то кажется, что всё просто. Ты весь такой светлый. Причиняешь добро. Борешься за справедливость в этом тёмном мире. Потом начинаешь замечать одну неприятную вещь. Почти каждый хороший. . .	Кредитный калькулятор Maks 05.08.2026 Решение задачи по прикладной информатике средствами 1С. Задача: Напишите приложение-калькулятор, которое помогает рассчитывать параметры кредита для аннуитетного и дифференцированного видов. . .	У нас сейчас поговорку "Опять 25" нужно переделать на "Опять +35". kumehtar 04.08.2026 С ностальгией вспоминаю времена моего детства, когда у нас и правда +25 - была максимальная температура летом. Раньше +25 °C реально казались вершиной жары, когда можно было весь день пропадать на. . .
Как ИИ начал спорить и врать (возможно почуяв опасность для себя от индустрии - уход от электроники). Hrethgir 04.08.2026 Недельный диалог, на фоне событий с НПЗ. Да, из спирта можно получать бензин, и это не сложно. Но потом в схеме я решил избавиться от насоса, при этом полностью сделав контроль подачи спирта в. . .	Термопринтер QR701 Argus19 03.08.2026 Термопринтер QR701 Купил два термопринтера QR701. На сэлф-тесте написано: Language: PC936 (GB18030). Что означает, что принтеры могут печатать только латиницу и китайские иероглифы. Так же. . .	Создание формы заимствованного документа Maks 03.08.2026 Задача: Необходимо создать собственную форму заимствованного документа. На форме должен быть реквизит "Покупатель", а также табличная часть со следующими реквизитами: - Расчетный счет покупателя. . .	Задача предоставления скидок покупателям Maks 03.08.2026 Задача: В документе "Продажи" необходимо реализовать функционал предоставления скидок покупателям. Скидка должна автоматически рассчитываться и подставляться в соответствующее поле при выборе. . .

@Апострофф
	24.07.2014, 08:36
	Не по теме: Привет слово! Миниатюры 0

Dragokas
	24.07.2014, 11:44
	Не по теме: Плагиат с Hello World-ом нипадецки. 0

Dragokas 18035 / 7738 / 892 Регистрация: 25.12.2011 Сообщений: 11,502 Записей в блоге: 16
	31.08.2014, 11:34
	Антихакер32 в VBA именно это уже реализовано во встроенной функции Application.OnTime. 0

@Антихакер32 1201 / 473 / 46 Регистрация: 06.01.2014 Сообщений: 1,797 Записей в блоге: 19
	03.09.2014, 01:22
	Вот, я выложил свои продвинутые версии где таймеры можно использовать многократно Золотая коллекция классов непоместилось в один пост, вот Вторая часть и картинка, PS Критиковать, всегда легче, чем реально чтото делать Добавлено через 6 минут Монтировал на VB6, но текст, что я выложил легко подойдет к VBA-макросам там никаких отдельных OCX-..ов 0

@Антихакер32 1201 / 473 / 46 Регистрация: 06.01.2014 Сообщений: 1,797 Записей в блоге: 19
	09.09.2014, 23:29
	Библиотека UGVB6 Представляю вашему вниманию релиз нативной библиотеки которая была писанна на VB6, и частично мною была протестированна в 2007-м офисе Подробнее здесь: https://www.cyberforum.ru/post6591449.html 0