// VBArray.dll: Library for some VB/VBA array functions
// Coded by: HTC (TQN/TCA)
// Version: 1.0
// Compile:
// Release: dcc32.exe/dcc64.exe -B -$C- VBArray.dpr
// Debug: dcc32.exe/dcc64.exe -B -V VBArray.dpr
// Beeware licenses ;)
//
//{$DEFINE TEST}
{$IFDEF TEST}
program VBArray;
{$APPTYPE CONSOLE}
{$ELSE}
library VBArray;
{$IFDEF WIN64}
{$LIBSUFFIX '64'}
{$ELSE}
{$LIBSUFFIX '32'}
{$ENDIF}
{$ENDIF}
uses
Winapi.Windows, Winapi.ActiveX, System.Variants, System.VarUtils;
const
// Not declared in Delphi until Sydney 10.4.2 verion, declared in wtypes.h
FADF_RECORD = $20;
FADF_HAVEIID = $40;
FADF_HAVEVARTYPE = $80;
VT_INT = 22; // signed machine int
VT_UINT = 23; // unsigned machine int
function SafeArrayGetVartype(pva: PVarArray; var vt: TVarType): HRESULT; stdcall; external 'oleaut32.dll';
// We can not sum array of IUnknown, IDispatch, IRecordInfo
// Only support sum array of Variant, BSTR (OleStr), numeric elements...
//
function FastSumArray(const vArr: Variant; var dblSum: Double): HRESULT; stdcall;
var
hr: HRESULT;
vt: TVarType;
pData: Pointer;
pva: PVarArray; // TVarArray in Delphi = SAFEARRAY in C/C++ Windows SDK
dblOut: Double;
varSum: TVarData;
I, LTotalElement: NativeUInt;
begin
dblSum := 0;
if not VarIsArray(vArr) then
Exit(VAR_INVALIDARG);
pva := VarArrayAsPSafeArray(vArr);
Assert(pva <> nil);
if (pva.Flags and FADF_RECORD <> 0) or (pva.Flags and FADF_HAVEIID <> 0) then
Exit(VAR_NOTIMPL);
if (pva.DimCount < 1) or (pva.Flags and FADF_HAVEVARTYPE = 0) then
Exit(VAR_TYPEMISMATCH);
vt := PWord(PByte(pva) - 4)^; // vt stored at offset -4
if ((pva.Flags and ARR_OLESTR <> 0) and (varOleStr <> vt)) or
((pva.Flags and ARR_VARIANT <> 0) and (varVariant <> vt)) then
begin
Assert(False, 'Bad VarType');
Exit(VAR_UNEXPECTED);
end;
// we not support VT_DECIMAL (16 byte)
if not vt in [varSmallInt, varInteger, varSingle, varDouble, varCurrency, varDate, varOleStr,
varBoolean, varVariant, varShortInt, varByte, varWord, varUInt32, varInt64,
varUInt64, VT_INT, VT_UINT] then
Exit(VAR_BADVARTYPE);
LTotalElement := 1;
for I := 0 to pva.DimCount - 1 do
LTotalElement := LTotalElement * pva.Bounds[I].ElementCount;
hr := SafeArrayAccessData(pva, pData);
if Failed(hr) then
Exit(hr);
try
// Unroll the case inside the loop. Avoid excute many cmp/jnz ASM instructions inside the loop
// Delphi compiler not create swich/jump table as other C/C++ compilers
// Avoid access pva.ElementSize in the loop: Inc(PByte(pData), pva.ElementSize), uses constant direct
//
case vt of
varSmallInt, varBoolean: // 2 bytes, signed, VARIANT_BOOL = WordBool, -1 = TRUE, 0 = FALSE
for I := 1 to LTotalElement do
begin
dblSum := dblSum + PSmallInt(pData)^;
Inc(PByte(pData), 2);
end;
varInteger, VT_INT: // 4 bytes, signed
for I := 1 to LTotalElement do
begin
dblSum := dblSum + PInteger(pData)^;
Inc(PByte(pData), 4);
end;
varSingle: // 4 bytes, float
for I := 1 to LTotalElement do
begin
dblSum := dblSum + PSingle(pData)^;
Inc(PByte(pData), 4);
end;
varDouble, varDate: // 8 bytes, DATETIME = Double
for I := 1 to LTotalElement do
begin
dblSum := dblSum + PDouble(pData)^;
Inc(PByte(pData), 8);
end;
varCurrency: // 8 bytes
for I := 1 to LTotalElement do
begin
dblSum := dblSum + PCurrency(pData)^;
Inc(PByte(pData), 8);
end;
varOleStr: // SizeOf(Pointer)
for I := 1 to LTotalElement do
begin
hr := VarR8FromStr(PWideChar(pData^), VAR_LOCALE_USER_DEFAULT, 0, dblOut);
Inc(PByte(pData), SizeOf(Pointer));
if Succeeded(hr) then
dblSum := dblSum + dblOut;
end;
varVariant: // SizeOf(Variant)
begin
VariantInit(varSum);
varSum.VType := varDouble;
varSum.VDouble := 0;
for I := 1 to LTotalElement do
begin
VarAdd(varSum, PVarData(pData)^, varSum); // ignore HRESULT return and failed elements
Inc(PByte(pData), SizeOf(Variant));
end;
if varSum.VType <> varDouble then
VariantChangeType(varSum, varSum, 0, varDouble); // ignore HRESULT return
if varSum.VType = varDouble then
dblSum := varSum.VDouble;
VariantClear(varSum);
end;
varShortInt: // 1 byte, signed
for I := 1 to LTotalElement do
begin
dblSum := dblSum + PShortInt(pData)^;
Inc(PByte(pData), 1);
end;
varByte: // 1 byte, unsigned
for I := 1 to LTotalElement do
begin
dblSum := dblSum + PByte(pData)^;
Inc(PByte(pData), 1);
end;
varWord: // 2 bytes, unsigned
for I := 1 to LTotalElement do
begin
dblSum := dblSum + PWord(pData)^;
Inc(PByte(pData), 2);
end;
varUInt32, VT_UINT: // 4 byte, unsigned
for I := 1 to LTotalElement do
begin
dblSum := dblSum + PUInt32(pData)^;
Inc(PByte(pData), 4);
end;
varInt64: // 8 byte, signed
for I := 1 to LTotalElement do
begin
dblSum := dblSum + PInt64(pData)^;
Inc(PByte(pData), 8);
end;
varUInt64: // 8 byte, unsigned
for I := 1 to LTotalElement do
begin
dblSum := dblSum + PUInt64(pData)^;
Inc(PByte(pData), 8);
end;
else
Assert(False, 'Invalid VarType');
end;
finally
SafeArrayUnaccessData(pva);
end;
Result := VAR_OK; // = S_OK
end;
function FastCopyArray(const vArrSrc: Variant; var vArrDst: Variant): HRESULT; stdcall;
var
hr: HRESULT;
pvaSrc, pvaDst: PVarArray;
begin
if not VarIsArray(vArrSrc) then
Exit(VAR_INVALIDARG);
if @vArrSrc = @vArrDst then
Exit(VAR_OK); // copy itself
pvaSrc := VarArrayAsPSafeArray(vArrSrc);
Assert(pvaSrc <> nil);
pvaDst := nil;
hr := SafeArrayCopy(pvaSrc, pvaDst);
if Failed(hr) then
Exit(hr);
Assert(pvaDst <> nil);
// Copy ok, clear old variant
VariantClear(TVarData(vArrDst));
// Change vArrDst to variant of array, ignore varByRef
TVarData(vArrDst).VType := varArray or (TVarData(vArrSrc).VType and varTypeMask);
TVarData(vArrDst).VArray := pvaDst;
Result := VAR_OK;
end;
function FastTransArrayByCopy(const vArrSrc: Variant; var vArrDst: Variant): HRESULT; stdcall;
var
hr: HRESULT;
pSrc, pDst: Pointer;
pvaSrc, pvaDst: PVarArray;
I, J, LOldCols, LOldRows: NativeUInt;
begin
if not VarIsArray(vArrSrc) then
Exit(VAR_INVALIDARG);
if @vArrSrc = @vArrDst then
Exit(VAR_OK); // trans itself
pvaSrc := VarArrayAsPSafeArray(vArrSrc);
Assert(pvaSrc <> nil);
if (pvaSrc.DimCount <> 2) then
Exit(VAR_TYPEMISMATCH); // we only support transfer array have two dimensions
// SafeArrayCopy calls the string or variant manipulation functions if the array to copy contains
// either of these data types. If the array being copied contains object references, the reference
// counts for the objects are incremented.
hr := SafeArrayCopy(pvaSrc, pvaDst);
if Failed(hr) then
Exit(hr);
Assert((pvaDst <> nil) and (pvaSrc.DimCount = pvaDst.DimCount) and (pvaSrc.ElementSize = pvaDst.ElementSize));
// Swap two dimensions, bounds array stored reverse in memory of a SAFEARRAY
I := 1;
LOldCols := pvaSrc.Bounds[0].ElementCount;
LOldRows := pvaSrc.Bounds[I].ElementCount;
pvaDst.Bounds[0] := pvaSrc.Bounds[I];
pvaDst.Bounds[I] := pvaSrc.Bounds[0];
hr := SafeArrayAccessData(pvaSrc, pSrc);
if Failed(hr) then
begin
SafeArrayDestroy(pvaDst);
Exit(hr);
end;
SafeArrayAccessData(pvaDst, pDst); // pvaDst^.LockCount/cLocks = 0, don't need to check hr
Assert((pSrc <> nil) and (pDst <> nil));
try
// Transpose array by swapping raw data position of each element
// Elements in SAFEARRAY stored as [col, row], so we need only swap to [row, col]
// Unroll the case inside the loop, use constant
case pvaDst.ElementSize of
1:
for I := 0 to LOldRows - 1 do
for J := 0 to LOldCols - 1 do
begin
PByte(pDst)^ := PByte(PByte(pSrc) + J * LOldRows + I)^;
Inc(PByte(pDst), 1);
end;
2:
for I := 0 to LOldRows - 1 do
for J := 0 to LOldCols - 1 do
begin
PWord(pDst)^ := PWord(PByte(pSrc) + (J * LOldRows + I) * 2)^;
Inc(PByte(pDst), 2);
end;
4:
for I := 0 to LOldRows - 1 do
for J := 0 to LOldCols - 1 do
begin
PUInt(pDst)^ := PUInt(PByte(pSrc) + (J * LOldRows + I) * 4)^;
Inc(PByte(pDst), 4);
end;
8:
for I := 0 to LOldRows - 1 do
for J := 0 to LOldCols - 1 do
begin
PUInt64(pDst)^ := PUInt64(PByte(pSrc) + (J * LOldRows + I) * 8)^;
Inc(PByte(pDst), 8);
end;
SizeOf(Variant):
for I := 0 to LOldRows - 1 do
for J := 0 to LOldCols - 1 do
begin
PVarData(pDst)^ := PVarData(PByte(pSrc) + (J * LOldRows + I) * SizeOf(Variant))^;
Inc(PByte(pDst), SizeOf(Variant));
end;
else
// DECIMAL or another types
for I := 0 to LOldRows - 1 do
for J := 0 to LOldCols - 1 do
begin
CopyMemory(pDst, Pointer(PByte(pSrc) + (J * LOldRows + I) * pvaDst.ElementSize), pvaDst.ElementSize);
Inc(PByte(pDst), pvaDst.ElementSize);
end;
end;
finally
SafeArrayUnaccessData(pvaDst);
SafeArrayUnaccessData(pvaSrc);
end;
// Trans data OK, clear old variant
VariantClear(TVarData(vArrDst));
// Change vArrDst to Variant of array, ignore varByRef
TVarData(vArrDst).VType := varArray or (TVarData(vArrSrc).VType and varTypeMask);
TVarData(vArrDst).VArray := pvaDst;
Result := VAR_OK;
end;
// Code from RE SafeArrayCreate and SafeArrayCopy in oleaut32.dll
// Unsafe to uses.
function FastTransArrayDirect(const vArrSrc: Variant; var vArrDst: Variant): HRESULT; stdcall;
var
hr: HRESULT;
vt: TVarType;
pSrc, pDst: Pointer;
pvaSrc, pvaDst: PVarArray;
I, J, LOldCols, LOldRows: NativeUInt;
pInfTmp, pRecInfo, pszTmp: PNativeUInt;
begin
if not VarIsArray(vArrSrc) then
Exit(VAR_INVALIDARG);
if @vArrSrc = @vArrDst then
Exit(VAR_OK); // trans itself
pvaSrc := VarArrayAsPSafeArray(vArrSrc);
Assert(pvaSrc <> nil);
if (pvaSrc.DimCount <> 2) then
Exit(VAR_TYPEMISMATCH);
hr := SafeArrayGetVarType(pvaSrc, vt);
if Failed(hr) then
Exit(hr);
pvaDst := SafeArrayCreate(vt, 2, @pvaSrc.Bounds);
if pvaDst = nil then
Exit(VAR_OUTOFMEMORY);
if (varUnknown = vt) or (varDispatch = vt) then
PGUID(PByte(pvaDst) - SizeOf(TGUID))^ := PGUID(PByte(pvaSrc) - SizeOf(TGUID))^
else if (varRecord = vt) then
begin
NativeUInt(pRecInfo) := PNativeUInt(PByte(pvaSrc) - SizeOf(Pointer))^;
PNativeUInt(PByte(pvaDst) - SizeOf(Pointer))^ := NativeUInt(pRecInfo);
IRecordInfo(pRecInfo)._AddRef();
end;
// Copy and trans data
I := 1;
LOldCols := pvaSrc.Bounds[0].ElementCount;
LOldRows := pvaSrc.Bounds[I].ElementCount;
hr := SafeArrayAccessData(pvaSrc, pSrc);
if Failed(hr) then
begin
SafeArrayDestroy(pvaDst);
Exit(hr);
end;
SafeArrayAccessData(pvaDst, pDst);
Assert((pSrc <> nil) and (pDst <> nil));
try
case vt of
varUnknown, varDispatch:
for I := 0 to LOldRows - 1 do
for J := 0 to LOldCols - 1 do
begin
NativeUInt(pInfTmp) := PNativeUInt(PByte(pSrc) + (J * LOldRows + I) * SizeOf(Pointer))^;
IUnknown(pInfTmp)._AddRef();
PNativeUInt(pDst)^ := NativeUInt(pInfTmp);
Inc(PByte(pDst), SizeOf(Pointer));
end;
varRecord: // SizeOf(Record) = pvaDst/pvaSrc.ElementSize
for I := 0 to LOldRows - 1 do
for J := 0 to LOldCols - 1 do
begin
IRecordInfo(pRecInfo).RecordCopy(PByte(pSrc) + (J * LOldRows + I) * pvaSrc.ElementSize, pDst);
Inc(PByte(pDst), pvaDst.ElementSize);
end;
varOleStr:
for I := 0 to LOldRows - 1 do
for J := 0 to LOldCols - 1 do
begin
NativeUInt(pszTmp) := PNativeUInt(PByte(pSrc) + (J * LOldRows + I) * SizeOf(Pointer))^;
PPOleStr(pDst)^ := SysAllocStringByteLen(PAnsiChar(pszTmp), SysStringByteLen(PWideChar(pszTmp)));
Inc(PByte(pDst), SizeOf(Pointer));
end;
varVariant:
for I := 0 to LOldRows - 1 do
for J := 0 to LOldCols - 1 do
begin
VariantCopy(PVarData(pDst)^, PVarData(PByte(pSrc) + (J * LOldRows + I) * SizeOf(Variant))^);
Inc(PByte(pDst), SizeOf(Variant));
end;
else
case pvaDst.ElementSize of
1:
for I := 0 to LOldRows - 1 do
for J := 0 to LOldCols - 1 do
begin
PByte(pDst)^ := PByte(PByte(pSrc) + J * LOldRows + I)^;
Inc(PByte(pDst), 1);
end;
2:
for I := 0 to LOldRows - 1 do
for J := 0 to LOldCols - 1 do
begin
PWord(pDst)^ := PWord(PByte(pSrc) + (J * LOldRows + I) * 2)^;
Inc(PByte(pDst), 2);
end;
4:
for I := 0 to LOldRows - 1 do
for J := 0 to LOldCols - 1 do
begin
PUInt(pDst)^ := PUInt(PByte(pSrc) + (J * LOldRows + I) * 4)^;
Inc(PByte(pDst), 4);
end;
8:
for I := 0 to LOldRows - 1 do
for J := 0 to LOldCols - 1 do
begin
PUInt64(pDst)^ := PUInt64(PByte(pSrc) + (J * LOldRows + I) * 8)^;
Inc(PByte(pDst), 8);
end;
else
// DECIMAL or another types
for I := 0 to LOldRows - 1 do
for J := 0 to LOldCols - 1 do
begin
CopyMemory(pDst, Pointer(PByte(pSrc) + (J * LOldRows + I) * pvaDst.ElementSize), pvaDst.ElementSize);
Inc(PByte(pDst), pvaDst.ElementSize);
end;
end;
end;
finally
SafeArrayUnaccessData(pvaDst);
SafeArrayUnaccessData(pvaSrc);
end;
VariantClear(TVarData(vArrDst));
TVarData(vArrDst).VType := varArray or vt;
TVarData(vArrDst).VArray := pvaDst;
Result := VAR_OK;
end;
exports
FastSumArray,
FastCopyArray,
FastTransArrayByCopy,
FastTransArrayDirect;
{$IFDEF TEST}
var
vArrSrc, vArrDst: Variant;
I, J: Integer;
hr: HRESULT;
begin
vArrSrc := VarArrayCreate([0, 2, 0, 4], varOleStr);
for I := 0 to 2 do
for J := 0 to 4 do
vArrSrc[I, J] := I * 10 + J + 1;
vArrSrc[2, 4] := 'Text';
for I := 0 to 2 do
begin
for J := 0 to 4 do
Write(vArrSrc[I, J]:8, ' ');
WriteLn;
end;
hr := FastTransArrayDirect(vArrSrc, vArrDst);
if Succeeded(hr) then
begin
WriteLn('Bound 1: ', VarArrayLowBound(vArrDst, 1), ' - ', VarArrayHighBound(vArrDst, 1));
WriteLn('Bound 2: ', VarArrayLowBound(vArrDst, 2), ' - ', VarArrayHighBound(vArrDst, 2));
for I := 0 to 4 do
begin
for J := 0 to 2 do
Write(vArrDst[I, J]:8);
WriteLn;
end;
end;
ReadLn;
{$ENDIF}
end.
