Public Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" _
(Destination As Any, Source As Any, ByVal Length As Long)
Public Function UboundArray(ArrayName As Variant, Optional Dimension As Integer = 1) As Long
If Dimension < 1 Or Dimension > GetArrayDimensions(ArrayName) Then
UboundArray = -1
Else
UboundArray = UBound(ArrayName, Dimension)
End If
End Function
Public Function GetArrayDimensions(arr As Variant) As Integer
Dim a As Long
CopyMemory a, ByVal VarPtr(arr) + 8, 4
CopyMemory a, ByVal a, 4
If a Then CopyMemory GetArrayDimensions, ByVal a, 2
End Function
Rows = UBound(MyArray)+1
Redim Preserve MyArray(Rows)
MyArray(Rows) = ...
Function arr_AddItem_AZ( _
NewItem, _
TgtArr()) As Long
'Добавление уникального элемента в одномерный массив
'TgtArr и сортировка получившегося по алфавиту (A->Z)
'
'На входе:
'~~~~~~~~~
'NewItem - добавляемый элемента
'TgtArr - массив, в который производится добавление
'
'На выходе:
'~~~~~~~~~~
'
'-1 - такой элемент уже существует в массиве (добавление не произведено)
'>0 - каким номером в массиве стал добавляемый элемент
Dim TgtArrRows As Integer
On Error Resume Next
TgtArrRows = UBound(TgtArr)
If Err.Number <> 0 Then
ReDim TgtArr(1)
TgtArr(1) = NewItem
arr_AddItem_AZ = 1
Exit Function
End If
Err.Clear ' добавление первой записи
For CurRow = 1 To TgtArrRows
If TgtArr(CurRow) = NewItem Then
arr_AddItem_AZ = -1
Exit Function
End If
Next CurRow
TgtArrRows = TgtArrRows + 1
ReDim Preserve TgtArr(TgtArrRows)
If TgtArrRows > 1 Then
For CurRow = TgtArrRows - 1 To 1 Step -1
If TgtArr(CurRow) > NewItem Then
'копируем запись вниз, т.к. "поплавок" еще не всплыл
TgtArr(CurRow + 1) = TgtArr(CurRow)
Else 'TgtArr(CurRow) > NewItem
Exit For
End If 'TgtArr(CurRow) > NewItem
Next CurRow
Else 'TgtArrRows > 1
CurRow = TgtArrRows - 1
End If 'TgtArrRows > 1
CurRow = CurRow + 1
TgtArr(CurRow) = NewItem
arr_AddItem_AZ = CurRow
End Function
GSerg писал(а): И потом, прочитай внимательно то, что написано здесь.
Евгений Д. писал(а):Ну не нужна мне возможность MyArray(-5 to 25), меня устраивает MyArray(0 to n-1) или MyArray(1 to n).
Евгений Д. писал(а):По поводу того, нижний или верхний индекс: при первом ReDim они будут одинаковыми, но какими?
Евгений Д. писал(а):По кругу?
Dim TgtArrRows As Integer
On Error Resume Next
TgtArrRows = UBound(TgtArr)
If Err.Number <> 0 Then
ReDim TgtArr(?)
TgtArr(?) = NewItem
arr_AddItem_AZ = ?
Exit Function
End If
Function FirstBoundIndex() As Integer
Dim temp(1)
FirstBoundIndex = LBound(temp)
End Function
alibek писал(а):
- Код: Выделить всё
Function FirstBoundIndex() As Integer
Dim temp(1)
FirstBoundIndex = LBound(temp)
End Function
...
GSerg писал(а):На самом деле нужн переделать весь остальной код так, чтобы он не зависел от нижней границы.
Евгений Д. писал(а):А я и писал, что хочу переделать: убрать On Error, поставить, где надо LBound и т.д.
Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 19