Ошибка 7 'Out of memory'

[M_Block]

Привет, возникла проблемка.

На форме находится ListBox и Button "Удалить строку".
При загрузке формы массив заполняется данными из файла, затем все передается в ListBox.
Потом хочу удалить какую-нибудь строку из массива и обновить ListBox. Нашел где-то на сайте функцию ShrinkArray и вставил к себе в прогу. После 2-3 удалений возникает обозначенная ошибка. Если удалить 1 строку, программа просто зависает, а потом и закрывается.
Помогите пожалуйста, может че не так вставил.

Код: Выделить всё


Private Declare Sub CopyMemory _
Lib "KERNEL32" Alias "RtlMoveMemory" ( _
ByVal Destination As Long, _
ByVal Source As Long, _
ByVal Length As Long)

Private Declare Sub ZeroMemory _
Lib "KERNEL32" Alias "RtlZeroMemory" ( _
ByVal Destination As Long, _
ByVal numBytes As Long)

Private Sub Command6_Click()
Dim i As Integer
Dim mes

mes = ShrinkArray(String_array, List1.ListIndex)

List1.Clear

For i = 0 To UBound(String_array)
    List1.AddItem (String_array(i))
Next
End Sub

Private Function ShrinkArray(ByRef nArr() As String, ByVal nIndex As Long)
    If UBound(nArr) = nIndex Then
        ReDim Preserve nArr(nIndex - 1)
    Else
        If nIndex < LBound(nArr) Or nIndex > UBound(nArr) Then
            Err.Raise 10, , "Откуда такой индекс?"
        Else
            nArr(nIndex) = vbNullString
            CopyMemory VarPtr(nArr(nIndex)), VarPtr(nArr(nIndex + 1)), (UBound(nArr) - nIndex) * LenB(nArr(0))
            ZeroMemory VarPtr(nArr(UBound(nArr))), LenB(nArr(0))
            ReDim Preserve nArr(UBound(nArr) - 1)
        End If
    End If
End Function


[Viper]

надо указатели на строки копировать, а не сами строки, соответственно юзать StrPtr вместо VarPtr и не забывать, что размер указателя всегда 4 байта.

[ANDLL]

Знакомый код
Кстати, все там нормально, VarPtr должен быть. Вместо LenB(nArr(0)) просто 4 поставь(везде)

[Хакер]

Мои варианты:

Код: Выделить всё

Function ShrinkArray(ByRef sArr() As String, ByVal lIndex As Long)
Dim LB As Long
Dim UB As Long
Dim pFI As Long
    LB = LBound(sArr)
    UB = UBound(sArr)
    If lIndex < LB Or lIndex > UB Then
          Err.Raise 9 ' Почему в приведённом выше примере было 10?
    End If
    If lIndex < UB Then
        pFI = VarPtr(sArr(lIndex))
        CopyMemory pFI, pFI + 4, (UB - lIndex) * 4
    End If
    ReDim Preserve sArr(LB To UB - 1)
End Function

или

Код: Выделить всё

Function ShrinkArray(ByRef sArr() As String, ByVal lIndex As Long)
Dim LB As Long
Dim UB As Long
Dim pItem As Long
    LB = LBound(sArr)
    UB = UBound(sArr)
    If lIndex < LB Or lIndex > UB Then
          Err.Raise 9 ' Почему в приведённом выше примере было 10?
    End If
    If lIndex < UB Then
        pItem = VarPtr(sArr(lIndex))
        For pItem = pItem To VarPtr(sArr(UB - 1)) Step 4
            GetMem4 pItem + 4, pItem
        Next pItem
    End If
    ReDim Preserve sArr(LB To UB - 1)
End Function

[M_Block]

Ух ты, здорово, все заработало!

ANDLL, а почему тогда в твоей статье сразу не ставилась 4, как раз она менялась на LenB(nArr(0)) (= 48 )? Почему Хакер в своих вариантах не использует ZeroMemory и не очищает удаляемый элемент? В любом случае огромное спасибо!

Хакер, спасибо за помощь, теперь не знаю какой вариант использовать.

[M_Block]

Кстати, необходимо чуть-чуть доработать функцию, в части сравнения UBound(array) с 0, т.к. при попытке удалить последний элемент в массиве, получается ошибка при ReDim Preserve nArr(UBound(nArr) - 1).
Предлагаю следующее:

для варианта ANDLL

Код: Выделить всё

If UBound(nArr) = 0 Then ReDim nArr(0) Else ReDim Preserve nArr(UBound(nArr) - 1)


для варианта Хакер

Код: Выделить всё


If UB = 0 Then ReDim sArr(0) Else ReDim Preserve sArr(LB To UB - 1)


[Хакер]

Почему Хакер в своих вариантах не использует ZeroMemory и не очищает удаляемый элемент? В любом случае огромное спасибо!

Ну если ты жаден до памяти, которую занимает удалённая из массива строка, можешь и её удалить.

Вызовом SysFreeString или присвоением vbNullString-а. Первый вариант лично мне кажется лучшим.

А зачем использовать ZeroMemory? Она не освобождает память, она всего лишь заполняет её нулями. Кому надо будет, сам заполнит.

Кстати, необходимо чуть-чуть доработать функцию, в части сравнения UBound(array) с 0, т.к. при попытке удалить последний элемент в массиве, получается ошибка при ReDim Preserve nArr(UBound(nArr) - 1).

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

[tyomitch]

Штатными средствами VB нельзя сделать пустой массив. Всегда должен оставаться один элемент.

Ага!!

Код: Выделить всё

Dim s() As String
s = Split("")
Debug.Print UBound(s), LBound(s)


Dim v() As Variant
v = Array()
Debug.Print UBound(v), LBound(v)


[Хакер]

Имелся ввиду редим. Им никак нельзя.

Об этом:

Код: Выделить всё

Dim s() As String
s = Split("")
Debug.Print UBound(s), LBound(s)

не знал.

Второй вариант - не в тему.

[tyomitch]

Ну, и ещё для любителей нечистого VB всегда остаётся SafeArrayRedim...

[Хакер]

Это уже не штатные средства. О чём я и говорил, что я и имел ввиду.

[ANDLL]

А зачем использовать ZeroMemory?

Что бы программа работала

Код: Выделить всё

Private Sub Form_Load()
Dim A() As String, i As Long
ReDim A(10)
For i = 0 To 10
    A(i) = i
Next
ShrinkArray A, 2
msgbox a(9)
Stop
End
End Sub

Штатными средствами VB нельзя сделать пустой массив

Код: Выделить всё

Erase A

?

Почему Хакер в своих вариантах не использует ZeroMemory и не очищает удаляемый элемент?

Видимо потому что не читал статью, в которой написано зачем ZeroMemory и зачем писать =vbnullstring

[Хакер]

А зачем использовать ZeroMemory?

Что бы программа работала

Код: Выделить всё

Private Sub Form_Load()
Dim A() As String, i As Long
ReDim A(10)
For i = 0 To 10
    A(i) = i
Next
ShrinkArray A, 2
msgbox a(9)
Stop
End
End Sub

К чему этот код? Я сначала думал что это какой-то контр-пример, на котором моя функция не станет работать - проверил - всё прекрасно работает. В чём дело?

Штатными средствами VB нельзя сделать пустой массив

Код: Выделить всё

Erase A

?

Не то. Будет неинициализированный массив. А нужен пустой. Вариант Тёмыча со сплитом рулит.

Почему Хакер в своих вариантах не использует ZeroMemory и не очищает удаляемый элемент?

Первое я написал, второе, потому что "очистка памяти" термин видимо ему не дружественный

?

[ANDLL]

прекрасно работает

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

Код: Выделить всё

Option Explicit
Private Declare Sub CopyMemory _
Lib "KERNEL32" Alias "RtlMoveMemory" ( _
ByVal Destination As Long, _
ByVal Source As Long, _
ByVal Length As Long)

Private Sub Form_Load()
    Dim A() As String, i As Long
    ReDim A(10)
    For i = 0 To 10
        A(i) = String(10000, ".")
    Next
    ShrinkArray A, 2
    A(2) = String(10000, ",")
    MsgBox A(9)
End Sub

Function ShrinkArray(ByRef sArr() As String, ByVal lIndex As Long)
    Dim LB As Long
    Dim UB As Long
    Dim pFI As Long
    LB = LBound(sArr)
    UB = UBound(sArr)
    If lIndex < LB Or lIndex > UB Then
          Err.Raise 9 ' Ïî÷åìó â ïðèâåä¸ííîì âûøå ïðèìåðå áûëî 10?
    End If
    If lIndex < UB Then
        pFI = VarPtr(sArr(lIndex))
        CopyMemory pFI, pFI + 4, (UB - lIndex) * 4
    End If
    ReDim Preserve sArr(LB To UB - 1)
End Function

У меня показывает запятые, не знаю как у тебя

[Хакер]

ReDim виноват. Он при удалении последнего элемента вызывает SysFreeString, что, собственно говоря, - правильно, однако в данном случае не требуется. Получается что при вызове String(10000, ",") вызывается SysAllocString*, и выделается место, где до этого лежала 10-ая строка.

Т.е. StrPtr(String(10000, ",")) = StrPtr(A(9)).

Как вариант, - да, - перед ReDim-ом положить в A(10) ноль.

Согласен, придирка обоснована.

[M_Block]

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

А я и не пытался сделать массив пустым, мне нужно чтобы последний удаляемый элемент (строка) стала пустой, ReDim вполне сгодится.

В любом случае ReDim Preserve nArr(UBound(nArr) - 1) нельзя использовать, какая бы в дальнейшем цель не преследовалась.