查看: 583  |  回复: 0
  VB6 在一维数组中移动一个元素
楼主
发表于 2023年5月6日 16:51

新建From1(窗体),新建Command1(按钮CommandButton),代码:

'Purpose   :    Removes an item from a 1d array.
'Inputs    :    avRemoveFrom            The array to remove the item from.
'               [lIndex]                The index of the item to remove.
'               [vItemToRemove]         The value of the item to remove.
'               [bPreserveOrder]        If True the order of the array is preserved (slightly slower)
'Outputs   :    Returns True if removed item from array.
'Notes     :    Specify EITHER the lIndex OR vItemToRemove.
'               If vItemToRemove is specified and the array contains more than one item with this value,
'               the first item in which matches this value will be removed. Will NOT work with fixed
'               arrays (eg. Dim myArray(1 to 5) as String). Arrays must be declared as dynamic (eg.
'               Dim myArray() as String).
Private Function Array1DRemove(ByRef avRemoveFrom As Variant, Optional lIndex As Long, Optional vItemToRemove As Variant, Optional bPreserveOrder As Boolean = False) As Boolean
    Dim lUbound As Long, vTempVal As Variant, lLBound As Long, bFoundItem As Boolean
    Dim lThisItem As Long
    On Error GoTo ErrFailed
    lUbound = UBound(avRemoveFrom)
    lLBound = LBound(avRemoveFrom)
    If IsMissing(vItemToRemove) Then
        If lUbound >= lIndex Then
            'Found item
            bFoundItem = True
        End If
    Else
        'Remove item by value, find the item in the array
        For lIndex = lLBound To lUbound
            If avRemoveFrom(lIndex) = vItemToRemove Then
                'Found item
                bFoundItem = True
                Exit For
            End If
        Next
    End If
    If bFoundItem Then
        'Found item
        If bPreserveOrder Then
            'Preserve the order of the array,
            'by copying the values up the order fo the array
            For lThisItem = lIndex To lUbound - 1
                avRemoveFrom(lThisItem) = avRemoveFrom(lThisItem + 1)
            Next
        Else
            'Copy last item into a temp variable
            vTempVal = avRemoveFrom(lUbound)
            'Overwrite item to delete
            avRemoveFrom(lIndex) = vTempVal
        End If
        'Resize the array
        ReDim Preserve avRemoveFrom(lLBound To lUbound - 1)
        Array1DRemove = True
    End If
    Exit Function
ErrFailed:
    Debug.Print Err.Description
    Array1DRemove = False
    On Error GoTo 0
End Function

Private Sub Command1_Click()
    Dim alValues() As Long, lThisItem As Long
    ReDim alValues(1 To 5)
    
    For lThisItem = 1 To 5
        alValues(lThisItem) = lThisItem * 2
    Next
    
    'Remove item with a value 4 (preserving the order of the array)
    Array1DRemove alValues, , 4, True
    'Remove item 1 (preserving the order of the array)
    Array1DRemove alValues, 1, True
End Sub


您需要登录后才可以回帖 登录 | 立即注册
【本版规则】请勿发表违反国家法律的内容,否则会被冻结账号和删贴。
用户名: 立即注册
密码:
2020-2024 MaNongKu.com