copy an Array based on UDT

[Bombdrop]

Hi can some one please tell what i am doing wrong! i can copy an array no problem but when it comes to an array based on a UDT i can only copy one item within that array, any help would be great.

'============================================
'Title              :Module1 
'System             :proArray 
'=============================================
'Copyright          :© Oriel Software Limited 
'Date               :28/02/2002 
'Author             :Stephen Burrows 
'Technical Reviewer : 
'Purpose            :Bas module to store API and UDT need for the array 
'                   :practice form. 
'==============================================
Option Explicit 
'================================ 
'Api used to copy an Array! 
'================================ 
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _ 
Destination As Any, Source As Any, ByVal Length As Long) 
 
 
'================================= 
'Type used to assign to an arry 
'================================= 
Public Type People 
    Name As String 
    Age As Integer 
End Type 

'======================================================================= 
'Title              :frmArray 
'System             :proArray 
'======================================================================= 
'Copyright          :© Oriel Software Limited 
'Date               :28/02/2002 
'Author             :Stephen Burrows 
'Technical Reviewer : 
'Purpose            :Form to show how to use CopyMemory API in relation 
'                   :to arrays. 
'======================================================================= 
Option Explicit 
 
 
'======================================================================= 
'Procedure :cmdPartCopy_Click (Sub) 
'Date      :28/02/2002 
'Returns   : 
'Author    :Stephen Burrows 
'Purpose   :To show how an Array can have part of it contents coppied 
'======================================================================= 
Private Sub cmdPartCopy_Click() 
    Dim Array1(10) As Long 'Original array 
    Dim z As Long ' counter 
    Dim Array2() As Long ' Array that will have coppied infor in it 
    On Error GoTo cmdPartCopy_Click_Error 
 
    ReDim Array2(5) 
 
    For z = 0 To UBound(Array1) 
        Array1(z) = Rnd * z 
    Next 
 
    '================================================= 
    'Copy items 1-6 for Array1 to Array2 
    '================================================= 
    CopyMemory Array2(0), Array1(1), (5 - LBound(Array1) + 1) * Len(Array1(0)) 
 
    Debug.Print 
    Debug.Print "A partial Copy of an array" 
    Debug.Print "ORIGINAL" & vbTab & "COPY" 
 
    For z = 0 To UBound(Array2) 
        Debug.Print Array1(z) & vbTab & vbTab & Array2(z) 
    Next 
 
    '=============================== 
    'Use a bubble sort on the array 
    '=============================== 
    BubbleSort Array2 
 
    Debug.Print 
    Debug.Print "A bubble sort used on the Coppied array" 
    Debug.Print "ORIGINAL" & vbTab & "COPY" 
 
    For z = 0 To UBound(Array2) 
        Debug.Print Array1(z) & vbTab & vbTab & Array2(z) 
    Next 
 
 
    GoTo CleanExit: 
 
cmdPartCopy_Click_Error: 
 
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure cmdPartCopy_Click" & _ 
        " of Form frmArray" 
 
CleanExit: 
    On Error GoTo 0 
 
 
End Sub 
 
'======================================================================= 
'Procedure :cmdUDTCopy_Click (Sub) 
'Date      :28/02/2002 
'Returns   : 
'Author    :Stephen Burrows 
'Purpose   :To show how a Array based on a UDT can be coppied 
'======================================================================= 
Private Sub cmdUDTCopy_Click() 
 
    Dim udtOrig() As People 'The original Array 
    ReDim udtOrig(1) 
 
    Dim udtCopy() As People ' Array to coppy into 
    ReDim udtCopy(UBound(udtOrig)) 
    Dim x As Integer 'counter 
 
    On Error GoTo cmdUDTCopy_Click_Error 
 
    '================================ 
    'Populate the original Arry. 
    '================================ 
    udtOrig(0).Age = 25 
    udtOrig(0).Name = "Stephen" 
 
    udtOrig(1).Age = 26 
    udtOrig(1).Name = "Burrows" 
 
    '====================== 
    'Copy the UDTArray 
    '====================== 
 
    CopyMemory udtCopy(0), udtOrig(0), UBound(udtOrig) * Len(udtOrig(0)) 
 
    Debug.Print 
    Debug.Print "Shows a coppied UDTArray" 
 
    For x = 0 To UBound(udtCopy) 
        Debug.Print udtCopy(x).Age & vbTab & udtCopy(x).Name 
    Next 
 
    Debug.Print "this is were it goes wrong. It only coppies 1 item from the array" 
 
 
    GoTo CleanExit: 
 
cmdUDTCopy_Click_Error: 
 
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure cmdUDTCopy_Click" & _ 
        " of Form frmArray" 
 
CleanExit: 
    On Error GoTo 0 
 
End Sub 
 
'======================================================================= 
'Procedure :Form_Load (Sub) 
'Date      :28/02/2002 
'Returns   : 
'Author    :Stephen Burrows 
'Purpose   :This shows how to copy an array for one to another and 
'          :also how to insert in to an array at any point. 
'======================================================================= 
Private Sub Form_Load() 
 
    Randomize 
    Dim x(10) As Long 'Orginal Array 
    Dim C() As Long ' Array to copy to 
    ReDim C(UBound(x)) 
    Dim z As Long 'Counter 
 
    On Error GoTo Form_Load_Error 
 
    For z = 0 To UBound(x) 
        x(z) = z + 2 
    Next 
 
 
    CopyMemory C(0), x(0), (UBound(x) - LBound(x) + 1) * Len(x(0)) 
 
    Debug.Print "ORIGINAL" & vbTab & "COPY" 
    For z = 0 To UBound(C) 
        Debug.Print x(z) & vbTab & vbTab & C(z) 
    Next 
 
    '====================================== 
    'Insert a new item in the array 
    '====================================== 
    Dim Q As Long 
    Q = UBound(C) + 1 
    ReDim Preserve C(Q) 
 
    CopyMemory C(5 + 1), C(5), (UBound(C) - LBound(C) - 5) * Len(C(5)) 
    C(5) = 99 
    Debug.Print 
    Debug.Print "Shows an inserted value" 
    For z = 0 To UBound(C) 
        Debug.Print C(z) 
    Next 
 
    GoTo CleanExit: 
 
Form_Load_Error: 
 
    MsgBox "Error " & Err.Number & " (" & Err.Description & _ 
        ") in procedure Form_Load" & "of Form frmArray" 
 
CleanExit: 
    On Error GoTo 0 
 
 
End Sub 
 
 
 
'======================================================================= 
'Procedure :BubbleSort (Sub) 
'Date      :28/02/2002 
'Returns   : 
'Author    :Uknown 
'Purpose   :Basic method of sorting an array 
'======================================================================= 
Private Sub BubbleSort(ByRef arr() As Long, Optional numEls As Variant, _ 
    Optional ByVal descending As Boolean = False) 
 
 
    Dim value As Single 
    Dim index As Long 
    Dim firstItem As Long 
    Dim indexLimit As Long, lastSwap As Long 
    Dim inverseOrder As Boolean 
 
    ' account for optional arguments 
 
    On Error GoTo BubbleSort_Error 
 
    If IsMissing(numEls) Then numEls = UBound(arr) 
    inverseOrder = (descending <> False) 
 
    firstItem = LBound(arr) 
 
    lastSwap = numEls 
    Do 
        indexLimit = lastSwap - 1 
        lastSwap = 0 
        For index = firstItem To indexLimit 
            value = arr(index) 
            If (value > arr(index + 1)) Xor inverseOrder Then 
                ' if the items are not in order, swap them 
                arr(index) = arr(index + 1) 
                arr(index + 1) = value 
                lastSwap = index 
            End If 
        Next 
    Loop While lastSwap 
 
 
    GoTo CleanExit: 
 
BubbleSort_Error: 
 
    MsgBox "Error " & Err.Number & " (" & Err.Description & _ 
        ") in procedure BubbleSort" & " of Form frmArray" 
 
CleanExit: 
    On Error GoTo 0 
 
End Sub

Thanks

[Bombdrop]

Thanks that works just fine !!!!
Simple really thanks again any way ( i was going mad trying to solve it)

[darrenl]

Fan of League of Gentelmen by any chance?

"This is a local forum, we'll have no outsiders here!"

[Bombdrop]

your my forum now Dave