AW: Einbetten von Bytearray
23.02.2008 16:03:00
Bytearray
Halll Klaus,
mit über 190.000 Datensätzen in einem eindimensionales Array zu groß. Das muss aufgetweilt werden. Mal ein Vorschalg:
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Private vntTest1 As Variant, vntTest2 As Variant 'nur zum testen********************
Private Sub CommandButton1_Click()
Dim strFile As String
Dim vntReturn As Variant
Dim lngIndex As Long, lngCounter As Long
Dim lngIndex1 As Long, lngIndex2 As Long
Dim bytDataArray() As Byte
strFile = ActiveSheet.Cells(7, 7).Value
vntReturn = BinaryReadFile(strFile)
'********************nur zum testen********************
vntTest1 = vntReturn
'********************nur zum testen********************
For lngIndex = 256 To 0 Step -1
If (UBound(vntReturn) + 1) Mod lngIndex = 0 Then Exit For
Next
Redim bytDataArray(1 To (UBound(vntReturn) + 1) \ lngIndex, 1 To lngIndex)
For lngIndex1 = 1 To UBound(bytDataArray, 1)
For lngIndex2 = 1 To UBound(bytDataArray, 2)
bytDataArray(lngIndex1, lngIndex2) = vntReturn(lngCounter)
lngCounter = lngCounter + 1
Next
Next
Names.Add Name:="ByteArray", RefersTo:=bytDataArray, Visible:=False
End Sub
Private Function BinaryReadFile(ByRef i_strFilename As String) As Variant
On Error GoTo ErrHnd
Dim lLenFile As Long
Dim lFileNum As Long
Dim rgbyBin() As Byte
lFileNum = FreeFile
Open i_strFilename For Binary Access Read As #lFileNum
lLenFile = FileLen(i_strFilename)
Redim rgbyBin(lLenFile - 1)
Get #lFileNum, , rgbyBin
Close #lFileNum
BinaryReadFile = rgbyBin
Exit Function
ErrHnd:
Err.Raise Err.Number, Err.Source, Err.Description
End Function
Public Sub Rebuild_Array()
Dim vntReturn As Variant
Dim lngIndex1 As Long, lngIndex2 As Long, lngCounter As Long
Dim bytDataArray() As Byte
vntReturn = [ByteArray]
Redim bytDataArray(1 To UBound(vntReturn, 1) * UBound(vntReturn, 2))
For lngIndex1 = 1 To UBound(vntReturn, 1)
For lngIndex2 = 1 To UBound(vntReturn, 2)
lngCounter = lngCounter + 1
bytDataArray(lngCounter) = vntReturn(lngIndex1, lngIndex2)
Next
Next
'********************nur zum testen********************
vntTest2 = bytDataArray
'********************nur zum testen********************
End Sub
Public Sub test() 'Testarrays vergleichen ob identisch********************
Dim lngIndex As Long
For lngIndex = 0 To UBound(vntTest1)
If vntTest1(lngIndex) <> vntTest2(lngIndex + 1) Then Stop
Next
End Sub
Gruß
Nepumuk