[原创]快速拷贝数组程序
这几天刚到新公司上班，还没安排任务下来，无聊就写了这个程序主要是为了在VB中提高效率，程序运行一次没问题，但是郁闷的是运行第二次会出问题，由于上班时间没得多的调试时间。大家可以一起研究改善一下。我目前发现的问题是第二次调用的时候会自动更改了原数组的内容问题就出在这里。
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32 " Alias "RtlMoveMemory " (Destination As Any, Source As Any, ByVal Length As Long)
Private byteSave() As Byte
Private byteView() As Byte
Private strSave() As String
Private strView() As String
Private Sub cmdCancel_Click()
Unload Me
End Sub
Private Sub cmdSave_Click()
If textBytes1.Text <> " " Then
' cmdSave.Enabled = False
' byteSave = StrConv(textBytes1.Text, vbFromUnicode)
' MsgBox "保存完毕！！现在可以拷贝了！！ "
' cmdSave.Enabled = True
'字符串数组
cmdSave.Enabled = False
strSave = Split(textBytes1.Text, ", ")
' MsgBox "保存完毕！！现在可以拷贝了！！ "
cmdSave.Enabled = True
End If
' Dim hFile As Integer
' hFile = FreeFile
' Open "c:\1.xls " For Binary As #hFile
' ReDim byteSave(FileLen( "c:\1.xls ") - 1)
' Get #hFile, , byteSave
' Close #hFile
End Sub
Private Function IsByteArrayIsInitialize(bytes() As Byte) As Boolean
Dim i As Long
On Error GoTo errLine
i = UBound(bytes)
IsByteArrayIsInitialize = True
Exit Function
errLine:
IsByteArrayIsInitialize = False
End Function
Private Function IsStringArrayIsInitialize(strArray() As String) As Boolean
Dim i As Long
On Error GoTo errLine
i = UBound(strArray)
IsStringArrayIsInitialize = True
Exit Function
errLine:
IsStringArrayIsInitialize = False
End Function
Private Sub cmdView_Click()
' CopyByteArray byteSave, byteView
' textBytes2.Text = StrConv(byteView, vbUnicode)
'拷贝字符串数组
Dim strTmp As String, i As Integer
Erase strView
CopyStringArray strSave, strView
For i = 0 To UBound(strView)
strTmp = strTmp & strView(i) & ", "
Next
textBytes2.Text = Left(strTmp, Len(strTmp) - 1)
' Dim hFile As Integer
' hFile = FreeFile
' Open "c:\2.xls " For Binary As #hFile
' ReDim byteView(FileLen( "c:\1.xls ") - 1)
' Put #hFile, , byteSave
' Close #hFile
End Sub
'这几个注释的方法都是可以的
'Private Sub CopyByteArray(byteSource() As Byte, byteDest() As Byte)
' Dim lng1 As Long, lng2 As Long
' If IsByteArrayIsInitialize(byteSource) Then
' lng1 = StrPtr(byteSource)
' CopyMemory lng2, lng1, 4
' ReDim byteView(UBound(byteSource))
' CopyMemory ByVal VarPtr(byteDest(0)), ByVal lng2, LenB(byteSource(0)) * (UBound(byteSource) + 1)
' End If
'End Sub
'Private Sub CopyByteArray(byteSource() As Byte, byteDest() As Byte)
' Dim lng1 As Long, lng2 As Long
' If IsByteArrayIsInitialize(byteSource) Then
' lng1 = StrPtr(byteSource)
' CopyMemory lng2, lng1, 4
' ReDim byteView(UBound(byteSource))
' CopyMemory byteDest(0), ByVal lng2, LenB(byteSource(0)) * (UBound(byteSource) + 1)
' End If
'End Sub
Private Sub CopyByteArray(byteSource() As Byte, byteDest() As Byte)
Dim lng1 As Long, lng2 As Long
If IsByteArrayIsInitialize(byteSource) Then
lng1 = VarPtr(byteSource(0))
CopyMemory lng2, lng1, 4
ReDim byteView(UBound(byteSource))
CopyMemory ByVal VarPtr(byteDest(0)), ByVal lng2, LenB(byteSource(0)) * (UBound(byteSource) + 1)
End If
End Sub
'Private Sub CopyByteArray(byteSource() As Byte, byteDest() As Byte)
' Dim lng1 As Long, lng2 As Long
' If IsByteArrayIsInitialize(byteSource) Then
' lng1 = VarPtr(byteSource(0))
' CopyMemory lng2, lng1, 4
' ReDim byteView(UBound(byteSource))
' CopyMemory byteDest(0), ByVal lng2, LenB(byteSource(0)) * (UBound(byteSource) + 1)
' End If
'End Sub
'这个注释的也可以和下面是一样的
'Private Sub CopyStringArray(strSourceArray() As String, strDestArray() As String)
' Dim lng1 As Long, lng2 As Long
' If IsStringArrayIsInitialize(strSourceArray) Then
' Debug.Print strSourceArray(0)
' lng1 = VarPtr(strSourceArray(0))
' CopyMemory lng2, lng1, 4
' ReDim strDestArray(UBound(strSourceArray))
' CopyMemory ByVal VarPtr(strDestArray(0)), ByVal lng2, LenB(strSourceArray(0)) * (UBound(strSourceArray) + 1)
' End If
'End Sub
Private Sub CopyStringArray(strSourceArray() As String, strDestArray() As String)
Dim lng1 As Long, lng2 As Long
If IsStringArrayIsInitialize(strSourceArray) Then
'问题出在这里第二次执行时会把strSourceArray(0)的值更改这是导致程序错误的所在
lng1 = VarPtr(strSourceArray(0))
CopyMemory lng2, lng1, 4
ReDim strDestArray(UBound(strSourceArray))
'这里最好用4*(UBound(strSourceArray) + 1) 因为可能第一个元素为空上面的也修改即可
CopyMemory ByVal VarPtr(strDestArray(0)), ByVal lng2, 4 * (UBound(strSourceArray) + 1) 'LenB(strSourceArray(0)) * (UBound(strSourceArray) + 1)
End If
End Sub
Private Sub Form_Load()
End Sub
Private Sub Form_Unload(Cancel As Integer)
Erase strSave
Erase strView
End Sub
[解决办法]
只能对一维数组有效的，多维数组在VB中是按列存储的。
[解决办法]
up
[解决办法]
呵呵
其实一维数组的快速拷贝不就一条语句不就可以了
Private Declare Sub CopyMemory Lib "kernel32 " Alias "RtlMoveMemory " (Destination As Any, Source As Any, ByVal Length As Long)
Private Sub CopyByteArray(byteSource() As Byte, byteDest() As Byte)
CopyMemory ByVal VarPtr(byteDest(0)), ByVal VarPtr(byteSource(0)), LenB(byteSource(0)) * (UBound(byteSource) + 1)
End Sub
Private Sub Command1_Click()
Dim a(10) As Byte
For i = 0 To 10
a(i) = i ^ 2
Next
Dim b(10) As Byte
CopyByteArray a, b
End Sub
