copy an Array based on UDT
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.
Code:
'============================================
'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
