上一篇
下一篇
TestStrArrays
作者:JiaJia 日期:2008-02-18
引用内容Attribute VB_Name = "mTestStrArrays"
Option Explicit
Private Declare Sub CopyMemByV Lib "kernel32" Alias "RtlMoveMemory" (ByVal lpDest As Long, ByVal lpSrc As Long, ByVal lByteLen As Long)
Private Declare Sub ZeroMemByV Lib "kernel32" Alias "RtlZeroMemory" (ByVal lpDest As Long, ByVal lLenB As Long)
Private sTestArray() As String
Private lAbuf() As Long
' +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'
' This is intended as a sort testing aid, and though it may be
' a handy technique to use elsewhere, care should be taken to
' ensure no memory violations occur.
'
' Distinctive usage:
'
' - This is intended to be used where the string items and
' the number of string items in the array are not changing.
'
' - This caches the string pointers only, not the strings,
' and is intended for use when re-ordering but not altering
' the string array, so care must be taken to reset the cached
' pointers whenever array items are added, removed, or modified.
'
' - When caching with CacheArrayPtrs the passed string array
' must contain at least one item or errors will occur.
'
' - When resetting with ResetArrayPtrs the passed string array
' size must match the cached size or errors will occur.
'
' - This uses RtlZeroMemory to nullify string pointers but only
' when calling ResetArrayPtrs with bNullify set to True; see
' SaveOriginal below. An un-confirmed mis-trust hangs over the
' use of RtlZeroMemory on some OS's?
'
' +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Public Sub ResetArrayPtrs(sArr() As String, Optional ByVal bNullify As Boolean)
Dim lpStr As Long, lpBuf As Long
Dim LBd As Long, UBd As Long
LBd = LBound(sArr)
UBd = UBound(sArr)
lpStr = VarPtr(sArr(LBd)) ' Cache string array pointer
If bNullify Then
If (UBd - LBd) Then
ZeroMemByV lpStr, ((UBd - LBd) + 1&) * 4&
End If
Else
lpBuf = VarPtr(lAbuf(LBd)) ' Cache buffer array pointer
If (UBd - LBd) Then
CopyMemByV lpStr, lpBuf, ((UBd - LBd) + 1&) * 4&
End If
End If
End Sub
Public Sub CacheArrayPtrs(sArr() As String)
Dim lpStr As Long, lpBuf As Long
Dim LBd As Long, UBd As Long
LBd = LBound(sArr)
UBd = UBound(sArr)
ReDim lAbuf(LBd To UBd) As Long
lpStr = VarPtr(sArr(LBd)) ' Cache string array pointer
lpBuf = VarPtr(lAbuf(LBd)) ' Cache buffer array pointer
If (UBd - LBd) Then
CopyMemByV lpBuf, lpStr, ((UBd - LBd) + 1&) * 4&
End If
End Sub
' +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' Demo code only follows:
Sub LoadArray()
' Code to load test strings into array
'...
' Whenever the array is re-loaded cache the
' pointers in their original order
CacheArrayPtrs sTestArray
End Sub
Sub SortTest()
' Reset the array items back to their original
' positions just before each new sorting test
ResetArrayPtrs sTestArray
' Do the sorting
strSort sTestArray
' I leave the array sorted to access the sorted data
' and don't reset until starting a new sort test
End Sub
Sub CommitChanges()
' I cache the array pointers when one of the following occurs:
' Load the array with new items
' Add item(s) to the array
' Delete item(s) from the array
' Modify item(s) the strings themselves in any way
' Alter the array order and wish to test or save the resulting order
CacheArrayPtrs sA
End Sub
Sub SaveOriginal()
' I use the temp array when I don't wish to alter
' the current sort state of the test array
Dim sTmp() As String
' This array must be erased or uninitialised
' (must contain only null string pointers)
ReDim sTmp(lb To ub) As String
' This makes an illegal copy
ResetArrayPtrs sTmp
' Code
'...
' Must nullify before going out of scope
ResetArrayPtrs sTmp, True
End Sub
' +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
文章来自: 
引用通告: 
Tags: 评论: 0 | 引用: 0 | 查看次数: -
发表评论