AI muốn lập trình DLL cho Excel và các loại bằng Delphi thì xem video này nhé!

[Nguyễn Duy Tuân]

Đây là video hướng dẫn cách tạo DLL trên Delphi nhưng sử dụng trong VBA, Excel. Đây là phương pháp lập trình chuyên nghiệp nhưng không phải là khó. Giúp bạn bảo mật code của phần mềm tốt hơn.

Loạt video hướng dẫn lập trình Delphi cơ bản của mình tại đây:
https://www.giaiphapexcel.com/diend...-trình-delphi-cơ-bản-từ-bluesofts-net.138736/

 

[ThangCuAnh]

Version mới của VBArray32/64.dll
Source của hàm FastTransArrayDirect và optimize chút ở hàm FastTransArrayByCopy ở chổ dữ liệu là Variant.
Chắc chắn FastTransArrayDirect sẽ nhanh hơn FastTransArrayByCopy cỡ 1/3 - 1/4.
Bà con test tiếp giúp nhé. Dữ liệu càng lớn càng tốt.

Then and bé xì ga

// 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.

 

[Kiều Mạnh]

Version mới của VBArray32/64.dll
Source của hàm FastTransArrayDirect và optimize chút ở hàm FastTransArrayByCopy ở chổ dữ liệu là Variant.
Chắc chắn FastTransArrayDirect sẽ nhanh hơn FastTransArrayByCopy cỡ 1/3 - 1/4.
Bà con test tiếp giúp nhé. Dữ liệu càng lớn càng tốt.

Then and bé xì ga

// 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.

Chạy rất nhanh nhưng có 1 cái lỗi và 1 cái hỏi cách sử dụng

1/ Lỗi với hàm chuyển mảng là Array do ADODB lấy lên... code như sau + File Data ... Code Hàm chuyển Array sau Mạnh sử dụng tốt cho Mảng trên Sheet hay ADODB

Private Sub Transpose_Data()
    Dim tmpArray ''() As Variant
    Dim tmpArray2 ''() As Variant
    Dim Cnn As Object, Rs As Object
    Dim strCon As String
    Dim ExcelPath As String
    Dim srtQry As String
    Rem ========== Khai bao mo ket noi
    Set Cnn = CreateObject("ADODB.Connection")
    Set Rs = CreateObject("ADODB.Recordset")
    ExcelPath = ThisWorkbook.Path & "\Data.xlsb"
    strCon = ("Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ExcelPath _
            & ";Extended Properties=""Excel 12.0 Xml;HDR=Yes;"";")
    Rem ========== Tuy chon Lay du lieu SQL
    Rem srtQry = "Select *" & "From [" & Data_Nhap$ & "]"
    srtQry = "SELECT * FROM [Data_Nhap$]"
    Cnn.Open strCon
    Set Rs = Cnn.Execute(srtQry)
    tmpArray = Rs.GetRows
    Cnn.Close
    Rem ==========
    Dim t, d As Double
    t = Timer
    Call FastTransArrayByCopy(tmpArray, tmpArray2)
  
    With Range("A2")
        .Resize(UBound(tmpArray2, 1), UBound(tmpArray2, 2)).ClearContents
        .Resize(UBound(tmpArray2, 1), UBound(tmpArray2, 2)).Value = tmpArray2
    End With
    Debug.Print "FastTransArrayByCopy ... CuAnh", vbTab & (Timer - t), "Result=", d
    Rem ========== Thuc hien chuyen mang 2dArray len Sheet
'    Call Transpose_Array(tmpArray, tmpArray2)   ''Chuyen Mang tmpArray Sang tmpArray2
'    With Range("A2")
'        .Resize(UBound(tmpArray2, 1), UBound(tmpArray2, 2)).ClearContents
'        .Resize(UBound(tmpArray2, 1), UBound(tmpArray2, 2)).Value = tmpArray2
'    End With
End Sub

Private Sub Transpose_Array(ByRef InputArr() As Variant, ByRef ReturnArray() As Variant)
    Rem Khai bao Dim tmpArray(), tmpArray2() As Variant     ''Tang Toc 50%
    Rem Su Dung Call Transpose_Array (tmpArray, tmpArray2)  ''Chuyen Mang tmpArray Sang tmpArray2
    Dim RowNdx As Long, ColNdx As Long
    Dim LB1 As Long, LB2 As Long
    Dim UB1 As Long, UB2 As Long
    LB1 = LBound(InputArr, 1)
    LB2 = LBound(InputArr, 2)
    UB1 = UBound(InputArr, 1)
    UB2 = UBound(InputArr, 2)
    ReDim ReturnArray(LB2 To UB2, LB1 To UB1)

    For RowNdx = LB2 To UB2
    For ColNdx = LB1 To UB1
        ReturnArray(RowNdx, ColNdx) = InputArr(ColNdx, RowNdx)
    Next ColNdx, RowNdx ''Viet gon lai Bo Next
    Erase InputArr
End Sub

2/ Cho Mạnh hỏi cách sử dụng hàm sau và khai báo nó từ VBA

Và tại sao ko viết nó chỉ 1 đối số như hàm Sum trên VBA cho nó thuận tiện hơn

function FastSumArray(const vArr: Variant; var dblSum: Double): HRESULT; stdcall;

3/ Nếu được giải thích cho mạnh hiểu 1 chút về HRESULT ( kiểu trả về của hàm và cách sử dụng nó phù hợp )

4/ Hàm sau sử dụng rất tốt + chính xác cho các kiểu dữ liệu ( Arr trên Sheet + ADODB )

function FastTransArrayDirect(const vArrSrc: Variant; var vArrDst: Variant): HRESULT; stdcall;

.....
Code của tuân cũng bị chuyển cái Array do ADODB lấy lên là đơ Excel .....

 

[ThangCuAnh]

HRESULT chỉ là kiểu Long/LongInt thôi. Không có gì đặc biệt.
MS họ quy ước cho các hàm API COM/OLE phải trả về kiểu Long. Khi mọi thứ OK thì trả về 0 (S_OK) hay > 0. Còn âm thì là lỗi.
Delphi coder họ khai báo lại file source System.VarUtils.pas để dùng cho code Delphi và có comment:
// These equate to Window's constants but are renamed to less OS dependent
Các bạn download lại file đính kèm này, mình có kèm file Excel để test, 10 triệu cell.
Các bạn cứ bung ra 1 thư mục và test trên Excel của bạn, không cần phải quan tâm phải chép Dll nào vào chổ nào.
Trong code Aut__Open và Auto_Close mình đã làm sẵn cho các bạn việc đó, tự load đúng dll lên với Excel các bạn đang dùng.

Và các bạn chú ý. Khi hàm API đã khai báo là nhận biến Variant, tức là Variant đó trong ruột là array, nhưng các bạn lại cố truyền 1 array của Variant hay kiểu khác vào hàm API, thì VBA sẽ sinh ra 1 Variant tạm, có VarType là vtByRef or vtArray or vt của kiểu.

Kết quả test trên máy mình nhanh hơn code VBA khoảng 5-7 lần.
Thanks

 

[ThangCuAnh]

Kết quả test hàm FastSumArray mới giật mình, nhanh hơn cả hàm WorkSheetFunction.Sum của Excel tới 16 lần.

 

[Kiều Mạnh]

HRESULT chỉ là kiểu Long/LongInt thôi. Không có gì đặc biệt.
MS họ quy ước cho các hàm API COM/OLE phải trả về kiểu Long. Khi mọi thứ OK thì trả về 0 (S_OK) hay > 0. Còn âm thì là lỗi.
Delphi coder họ khai báo lại file source System.VarUtils.pas để dùng cho code Delphi và có comment:
// These equate to Window's constants but are renamed to less OS dependent
Các bạn download lại file đính kèm này, mình có kèm file Excel để test, 10 triệu cell.
Các bạn cứ bung ra 1 thư mục và test trên Excel của bạn, không cần phải quan tâm phải chép Dll nào vào chổ nào.
Trong code Aut__Open và Auto_Close mình đã làm sẵn cho các bạn việc đó, tự load đúng dll lên với Excel các bạn đang dùng.

Và các bạn chú ý. Khi hàm API đã khai báo là nhận biến Variant, tức là Variant đó trong ruột là array, nhưng các bạn lại cố truyền 1 array của Variant hay kiểu khác vào hàm API, thì VBA sẽ sinh ra 1 Variant tạm, có VarType là vtByRef or vtArray or vt của kiểu.

Kết quả test trên máy mình nhanh hơn code VBA khoảng 5-7 lần.
Thanks


View attachment 269473

Mạnh mới test nhanh lấy cái Array ADO lên được ... sau đó lỗi thoát Excel luôn ... mai Rảnh mới xem chi tiết

 

[ThangCuAnh]

Uhm, có thể chết ở IUnknown, IDispatch hay IRecordInfo. 3 case này mình chưa test, debug.
Thử đổi qua hàm ByCopy xem có chết kg ?

 

[Nguyễn Bảo Ninh]

Kiến thức các anh chia sẻ thật tuyệt, em có tải về chạy test khi em chạy file thì tốc độ thật tuyệt. Nhưng hiện em test tại máy ảo vì khi chạy ứng dụng này trên máy tính cài các phần mềm diệt virus như kaspersky thì nó xóa sạch khi tiến hành built file

Sự kiện: Đã xóa đối tượng
Người dùng: DESK6789\Admin
Kiểu người dùng: Người dùng hiện hoạt
Tên ứng dụng: WinRAR.exe
Đường dẫn ứng dụng: C:\Program Files\WinRAR
Thành phần: Chống virus cho tập tin
Mô tả kết quả: Đã xóa
Loại: Trojan
Tên: VHO:Trojan-Banker.Win32.Danabot.gen
Độ chính xác: Phân tích hành vi
Mức độ mối đe dọa: Cao
Loại đối tượng: Tập tin
Tên đối tượng: VBArray64.dll

 

[Kiều Mạnh]

Trên máy Mạnh check có 2 em virus thôi ... Fix lại code đó là hết à ... code đó Mạnh nhìn cũng xin thua còn Fix ít nhất sau 10 năm nữa quá

 

[ThangCuAnh]

Không liên quan gì tới fix hay không fix code hết. AV của KAS và thằng kia trên VirusTotal nhận dạng nhầm các pattern của Delphi RTL trùng với 1 con virus cũng viết bằng Delphi nào đó, Banker.Win32.Danabot.gen của tụi châu Mỹ.

FastTransArrayDirect chạy tốt với ADO của bạn Mạnh. Nhưng FastTransArrayByCopy làm văng Excel, khi free BSTR ở oleaut32.dll
Bug ngay chổ SizeOf(Variant) - copy raw value. Kiểu Variant nhưng có varByRef và Pointer nên bị free 2 lần.
Bài tập cho các bạn fix đó. Dùng VariantCopy, chấp nhận chậm thêm.

Mình đóng code này ở đây, quay lại làm tiếp các project của mình còn dang dỡ.

 

[Kiều Mạnh]

Không liên quan gì tới fix hay không fix code hết. AV của KAS và thằng kia trên VirusTotal nhận dạng nhầm các pattern của Delphi RTL trùng với 1 con virus cũng viết bằng Delphi nào đó, Banker.Win32.Danabot.gen của tụi châu Mỹ.

FastTransArrayDirect chạy tốt với ADO của bạn Mạnh. Nhưng FastTransArrayByCopy làm văng Excel, khi free BSTR ở oleaut32.dll
Bug ngay chổ SizeOf(Variant) - copy raw value. Kiểu Variant nhưng có varByRef và Pointer nên bị free 2 lần.
Bài tập cho các bạn fix đó. Dùng VariantCopy, chấp nhận chậm thêm.

Mình đóng code này ở đây, quay lại làm tiếp các project của mình còn dang dỡ.

Mạnh cảm ơn nhiều ... chắc dùng cái Hàm FastTransArrayDirect thôi
Còn cái kia lưu lại đó sau này trình code khá lên may ra sửa được ... còn giờ xin chịu thua 100/100
Ngay code VBA trên GPE này có code mạnh tải về xem tới lui mấy na9m sau mới hiểu ra đấy
Còn code đó đoán là ít nhất sau 10 na9m quá

Lưu vào Delphi luôn ... mỗi lần xem nó... nó nhắc nhở mình .... xem diết biết đâu sau này sẻ ngộ ra

 

[ThangCuAnh]

Uhm, để mình viết lại hàm rtcTypeName luôn, dùng pure Pointer to interface để tránh bug do các hàm internal về interface mà Delphi compiler tự động thêm vào.
Các hàm về string cho VBA, các bạn cần thêm hàm nào ?
Vừa xem lại hàm rtcInStr và rtcInStrRev của VB và VBA, đúng là chậm thiệt. MS coder check kỹ, chuyển kiểu, làm nhiều trường hợp quá.
Prototype của hàm rtcInStrRev:

function rctInStrRev(BSTR bstrSource; BSTR bstrSearch; nPos: Integer; vbCompMode: Integer): Integer; stdcall; external "vba7.dll"; delayed;

 

[Kiều Mạnh]

Ai biết cho Mạnh hỏi chút
1/ Khi viết 1 DLL = Delphi trong đó có trên 10 Unit + vô số code
2/ code trong đó ko thay đổi mọi cái y trang nhau ...
3/ Khi Buil DLL 32 bit và DLL 64 bit chỉ chuyển chế độ buil thôi
....
Vậy tại sao cái DLL 32 bít báo có vài Em virus ... còn cái DLL 64 bít thì ko có virus = tại sao = Cách xừ lý nó cho 32 bít
Xin cảm ơn

 

[ThangCuAnh]

Tiếp tục với 2 hàm xử lý string trong VBA, tốc độ nhanh hơn. Nhờ các bạn test giúp.

Hàm InStrA/W và InStrRevA/W. Đặc điểm của 4 hàm này là dùng các hàm API của Windows trong shlwapi.dll để thực hiện compare, search đúng string theo language, locale và support ignore case hay không.
Dĩ nhiên nó phải hy sinh chút về tốc độ chứ không như binary compare bình thường.

4 hàm này các bạn có thể dùng tham khảo như prototype cho các hàm xử lý string giữa VBA và Dll sau này theo nhu cầu của các bạn.

Về vấn đề giao tiếp giữa VBA string và Dll, các bạn xem kỹ khai báo hàm trong VBA và khai báo trong source Delphi của Dll. Và cả cách gọi hàm từ VBA, khi nào thì truyền là string, khi nào thì truyền = hàm VBA StrPtr. Cho nên các bạn thấy 1 hàm tại sao có 2 biến thể A và W: AnsiChar và WideChar.

Nói ra hết dài dòng nên mình hơi lười. Ai hỏi gì thì trả lời đấy thôi.
Quan trọng nhất 1 điều là khi truyền 1 string xuống 1 hàm API ở 1 Dll, dù ByVal hay ByRef aStr as String thì xuống tới Dll, ta luôn có 1 vùng nhớ là 1 kiểu BSTR, 4 byte trước vùng nhớ là tổng byte len của string, không tính 2 NULL char, và content của string là Ansi/MBCS, chứ không còn là Unicode nữa. Do VBA luôn convert string Unicode của ta trên VBA code thành kiểu BSTR ANSI trên trước khi truyền địa chỉ vùng nhớ đó xuống cho hàm Dll của ta.
Và ngay cả string ta trả về cho VBA, cũng phải trả về kiểu BSTR ANSI như trên, dù là qua var hay là return function Result. VBA tiếp tục convert ngược string ta trả về từ BSTR ANSI thành BSTR Unicode. Nên nếu ta trả về BSTR Unicode thì sẽ bị double Unicode, 1 ký tự thành 4 byte.
Ngược lại, nếu Dll của ta là COM, thì VBA và Office sẽ không thực hiện việc chuyển kiểu này, có Unicode sao thì truyền Unicode vậy.

Pointer, kiểu này kiểu kia gì thì cuối cùng chỉ là 1 con số trong memory thôi. Mình muốn suy diễn, ép kiểu, dùng kiểu nào, miễn compile ra được, sinh mã máy đúng thì được. Không quan trọng.
Mã máy nó không hề biết, không hề quan tâm tới PAnsiChar hay PWideChar, string hay WideString. Nó chỉ hiểu giá trị ABC trong ô nhớ XYZ.
Giờ mình code tiếp, code lại hàm rtcTypeName. Phát hiện ra mấy năm trước mình RE sai và thiếu ở kiểu SAFEARRAY và IRecordInfo.

Then en bé xì ga

function InStrA(nStart: Integer; const pacSource, pacSearch: PAnsiChar; bIgnoreCase: Boolean): Integer; stdcall;
var
  lenSource, lenSearch: Integer;
  pPos: PAnsiChar;
begin
  if (pacSource = nil) or (pacSearch = nil) or (nStart <= 0) then
    Exit(0);

  lenSource := SysStringByteLen(PWideChar(pacSource));
  if (lenSource = 0) or (nStart > lenSource) then
    Exit(0);

  lenSearch := SysStringByteLen(PWideChar(pacSearch));
  if (lenSearch = 0) then
    Exit(nStart);

  if bIgnoreCase then
    pPos := StrStrIA(@pacSource[nStart - 1], pacSearch)
  else
    pPos := StrStrA(@pacSource[nStart - 1], pacSearch);

  if pPos = nil then
    Result := 0
  else
    Result := pPos - pacSource + 1; // VB/VBA string index from 1
end;

function InStrW(nStart: Integer; const pwcSource, pwcSearch: PWideChar; bIgnoreCase: Boolean): Integer; stdcall;
var
  lenSource, lenSearch: Integer;
  pPos: PWideChar;
begin
  if (pwcSource = nil) or (pwcSearch = nil) or (nStart <= 0) then
    Exit(0);

  lenSource := SysStringLen(pwcSource);
  if (lenSource = 0) or (nStart > lenSource) then
    Exit(0);

  lenSearch := SysStringLen(pwcSearch);
  if (lenSearch = 0) then
    Exit(nStart);

  if bIgnoreCase then
    pPos := StrStrIW(@pwcSource[nStart - 1], pwcSearch)
  else
    pPos := StrStrW(@pwcSource[nStart - 1], pwcSearch);

  if pPos = nil then
    Result := 0
  else
    Result := pPos - pwcSource + 1;
end;

function InStrRevA(const pacSource, pacSearch: PAnsiChar; bIgnoreCase: Boolean): Integer; stdcall;
var
  lenSource, lenSearch: Integer;
  pPos: PAnsiChar;
begin
  if (pacSource = nil) or (pacSearch = nil) then
    Exit(0);

  lenSource := SysStringByteLen(PWideChar(pacSource));
  if (lenSource = 0) then
    Exit(0);

  lenSearch := SysStringByteLen(PWideChar(pacSearch));
  if (lenSearch = 0) or (lenSearch > lenSource) then
    Exit(0);

  if bIgnoreCase then
    pPos := StrRStrIA(pacSource, nil, pacSearch)
  else
  begin
    var ach := pacSearch^;
    pPos := @pacSource[lenSource - lenSearch];
    while (pPos >= pacSource) do
      if (pPos^ = ach) and (StrCmpNA(pPos, pacSearch, lenSearch) = 0) then
        Break
      else
        Dec(pPos);
  end;

  if (pPos = nil) or (pPos < pacSource) then
    Result := 0
  else
    Result := pPos - pacSource + 1;
end;

function InStrRevW(const pwcSource, pwcSearch: PWideChar; bIgnoreCase: Boolean): Integer; stdcall;
var
  lenSource, lenSearch: Integer;
  pPos: PWideChar;
begin
  if (pwcSource = nil) or (pwcSearch = nil) then
    Exit(0);

  lenSource := SysStringLen(pwcSource);
  if (lenSource = 0) then
    Exit(0);

  lenSearch := SysStringLen(pwcSearch);
  if (lenSearch = 0) or (lenSearch > lenSource) then
    Exit(0);

  if bIgnoreCase then
    pPos := StrRStrIW(pwcSource, nil, pwcSearch)
  else
  begin
    var awh := pwcSearch^;
    pPos := @pwcSource[lenSource - lenSearch];
    while (pPos >= pwcSource) do
      if (pPos^ = awh) and (StrCmpNW(pPos, pwcSearch, lenSearch) = 0) then
        Break
      else
        Dec(pPos);
  end;

  if (pPos = nil) or (pPos < pwcSource) then
    Result := 0
  else
    Result := pPos - pwcSource + 1;
end;

 

[ThangCuAnh]

Một mẹo để ta có thể vượt qua chuyển bị ép convert VBA string từ BSTR Unicode qua BSTR Ansi là ta truyền thẳng địa chỉ của biến VBA string xuống Dll API của ta. Dll API của chúng ta sẽ có tham số là var xxx: PWideChar. Trên VB và VBA, string luôn là kiểu BSTR (từ VB5 trở đi, VB4 là khác)
Dưới API của chúng ta, chúng ta nhớ phải gọi SysFreeString với biến string truyền xuống để free memory cũ mà biến string đó giữ. Và nhớ chỉ dùng các hàm BSTR API để thao tác, hay ép kiểu qua WideString để dùng các hàm WideString của Delphi. Kiểu WideString của Delphi cũng chỉ là wrapper cho BSTR.
Tất cả bộ nhớ cấp phát, giải phóng, cache string BSTR đều do Windows quản lý, thực hiện ở oleaut32.dll. Nên chúng ta không lo vấn đề cấp 1 nơi giải phóng 1 nẽo.
Dưới đây là code minh họa cho các bạn tham khảo:

VBA code:

Declare PtrSafe Function rtcTypeName Lib "VBArray64.dll" (ByRef var As Variant, ByVal strAddr As LongPtr) As Long
....
Sub TestRtcTypeName()
    Dim str As String
    Dim var As Variant
    Dim hr As Long

    str = "I am a Unicode string from VBA"
    Debug.Print str
 
    hr = rtcTypeName(var, VarPtr(str))
    Debug.Print str
End Sub

Delphi code:

function rtcTypeName(const AVar: Variant; var pwcTypeName: PWideChar): HRESULT; stdcall;
begin
  SysFreeString(pwcTypeName);
  pwcTypeName := SysAllocString('Delphi DLL return a string to VBA');
  Result := VAR_OK;
end;

Và kết quả

Bài đã được tự động gộp: 27/11/21

Nhấn mạnh thêm cho 2 post trên, nếu ta vẫn khăng khăng truyền VBA string xuống và muốn nhận về bằng cách ByRef thì chúng ta sẽ bị double Unicode, như hình.
VBA code đổi, code Delphi vẫn không đổi, vẫn chạy đúng. Nhưng khi return về VBA thì bị VBA chụp đầu ép đổi double tiếp

Declare PtrSafe Function rtcTypeName Lib "VBArray64.dll" (ByRef var As Variant, ByRef strAddr As String) As Long

Nếu chúng ta thấy khai báo kiểu ByRef str as String trên code VBA tiện hơn thì chúng ta phải đổi code ở Delphi lại. Thay vì dùng hàm SysAllocString để cấp phát và trả về 1 BSTR của kiểu Unicode thì chúng ta phải dùng hàm SysAllocStringByteLen để cấp phát và trả về 1 BSTR của kiểu ANSI.



VBA chụp đổi lại đúng cho ta.



Tùy các bạn. Nhưng nếu API trong Dll của chúng ta mà mang dùng cho các môi trường, ngôn ngữ khác thì phải cân nhắc là BSTR Unicode hay BSTR ANSI.

Then en bét xì ga.
Cuối tuần rồi, nghỉ sớm, nhậu

 

[Kiều Mạnh]

siêu thật ... chạy rất nhanh

 

[Kiều Mạnh]

To @ThangCuAnh
Cho Mạnh nhờ chút đồng thời cũng là cho các bạn khác có cơ hội học Delphi Với ... nếu vấn đề Mạnh nêu ra sau đây mà khó quá thì bỏ qua ... không sao cả

Mạnh đang tập viết COM trên Delphi
1/ Tạo 1 Class là COM Object
2/ Tạo 1 class là COM Auto
...
làm cái hàm sum để test
khi build DLL xong chưa đăng ký ActiveX COM với Window thì từ VBE (VBA hay VB6) check Refenrences tới DLL đó vào được OK ... thấy các Class + Hàm vv

Nhưng ko sử dụng được vì class đó chưa đăng ký với Windows .... Nếu đăng ký DLL đó với Windows thì sử dụng tốt thì vấn đề nêu trên hỏi sẻ thừa ko cần thiết

Vậy Mạnh muốn nhờ có cách nào đó mà khi check Refenrences tới DLL đó xong là nó tự đăng ký luôn DLL đó với Windows không (Auto Register Class )

Có tìm google rất nhiều thì nó có dẫn tới link sau ... xem diết mà ko biết họ nói gì và sử dụng nó như thế nào

Autoregister attribute for Delphi

Wouldnt it be nice if Delphi has an attribute that automatically registers your class for you? So rather than having to call Registerclass() manually to make a class known to Delphi’s persist…

jonlennartaasenden.wordpress.com

Hình sau là sau khi Build DLL check thì thấy hàm mà ko sử dụng được như mô tả phía trên


Nhìn thấy Class + Hàm



Code Mẫu đính kèm
Xin cảm ơn

 

[ThangCuAnh]

Bắt buộc phải đăng ký, hay tự viết 1 exe load dll nó lên, gọi hàm DllRegisterServer.
Link blog kia là nói về Attributes, không liên quan gì ở đây hết

 

[Kiều Mạnh]

Bắt buộc phải đăng ký, hay tự viết 1 exe load dll nó lên, gọi hàm DllRegisterServer.
Link blog kia là nói về Attributes, không liên quan gì ở đây hết

Thôi bài kia khó quá bỏ qua ... chỉ mạnh học code sau 1 chút

Chưa biết cách khai báo tương tác với Control bên ngoài Delphi sao cả mà đang loay hoay lúng túng
1/ Code sau sử dụng trên Delphi chạy rất tốt ... Lấy List File gán lên ListBox Delphi = ok

procedure ListFileDir(Path: string; FileList: TStrings);
var
  SR: TSearchRec;
begin
  if FindFirst(Path + '*.*', faAnyFile, SR) = 0 then
  begin
    repeat
      if (SR.Attr <> faDirectory) then
      begin
        FileList.Add(SR.Name);
      end;
    until FindNext(SR) <> 0;
    FindClose(SR);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ListFileDir('C:\WINDOWS\', ListBox1.Items);
end;

2/ Vậy Mạnh muốn hỏi với code đó xuất API thì khai báo truyền cái ListBox từ VBA vào làm sao cho Hàm trong Delphi nó nhận và gán dữ liệu ngược vào listBox trên VBA

3/ Như mục số 2 ... nếu xuất nó qua COM Delphi thì khai báo và sử dụng sao ???

rất mong trợ giúp ....

 

[ThangCuAnh]

Hàm cuối cùng của VBArray32/64.dll mà mình đã hứa, hàm rtcTypeName. Nhờ các bạn test giúp, đặc biệt là kiểu record, tức là kiểu User Define Type/End Type trong VBA đó. Mấy cái IUnknown, IDispatch OK hết rồi.
Bỏ VBA lâu quá nên khai báo hoài 1 cái Type không được

// Rewrite in Delphi code from RCE rtcTypeName function in VB/VBA: msvbvm60.dll and vbexxx.dll
//
function rtcTypeName(const AVar: TVarData; var pwcTypeName: PWideChar): HRESULT; stdcall;
const
  // Delphi until 10.4.2 only support vt to varUInt64 (VT_UI8)
  // Copy from VarTypeAsText function in System.Variants.pas, add VT_INT, VT_UINT and VT_RECORD
  CText: array [varEmpty..varRecord] of PWideChar = ('Empty', 'Null', 'Integer',
    'Long', 'Single', 'Double', 'Currency', 'Date', 'String', 'Object',
    'Error', 'Boolean', 'Variant', 'Unknown', 'Decimal', nil, 'ShortInt',
    'Byte', 'Word', 'Cardinal', 'Int64', 'UInt64', 'Signed Machine Int', 'Unsigned Machine Int',
    nil, nil, nil, nil, nil, nil, nil, nil, nil, nil, nil, nil, 'Record');
var
  hr: HRESULT;
  vt: TVarType;
  pwcRet: PWideChar;
  IsArray, IsByRef: Boolean;
  pRecInfo, pUnk, pDisp, pProvider, pTypeInfo: Pointer;
  pva: PVarArray;
begin
  // First, free old memory
  SysFreeString(pwcTypeName);
  pwcTypeName := nil;

  vt := AVar.VType and varTypeMask;
  IsArray := (AVar.VType and varArray) <> 0;
  IsByRef := (AVar.VType and varByRef) <> 0;

  // Validate vt
  if (vt > VT_UINT) and (vt < varRecord) or (vt = $0F) then
    Exit(VAR_BADVARTYPE);

  pwcRet := nil;
  if (vt = varRecord) then
  begin
    pRecInfo := nil;

    if not IsArray then
      pRecInfo := AVar.VRecord.RecInfo
    else
    begin
      if IsByRef then
        pva := PVarArray(AVar.VPointer^)
      else
        pva := AVar.VArray;

      if (pva <> nil) and (pva.Flags and FADF_RECORD <> 0) then
        pRecInfo := PPointer(PByte(pva) - SizeOf(Pointer))^;
    end;

    if (pRecInfo <> nil) then
      IRecordInfo(pRecInfo).GetName(pwcRet);
  end
  else if (vt = varUnknown) or (vt = varDispatch) then
  begin
    if IsArray then
      Exit(VAR_TYPEMISMATCH);

    if IsByRef then
      pUnk := PPointer(AVar.VUnknown)^
    else
      pUnk := AVar.VUnknown;

    if (pUnk = nil) then
    begin
      pwcRet := SysAllocString('Nothing');
      if (nil = pwcRet) then
        Exit(VAR_OUTOFMEMORY);
    end
    else
    begin
      pDisp := nil;
      pProvider := nil;
      pTypeInfo := nil;

      hr := IUnknown(pUnk).QueryInterface(IProvideClassInfo, pProvider);
      if Failed(hr) then
      begin
        hr := IUnknown(pUnk).QueryInterface(IDispatch, pDisp);
        if Succeeded(hr) then
          IDispatch(pDisp).GetTypeInfo(0, LOCALE_USER_DEFAULT, pTypeInfo);
      end
      else
        IProvideClassInfo(pProvider).GetClassInfo(ITypeInfo(pTypeInfo));

      if (pTypeInfo <> nil) then
      begin
        ITypeInfo(pTypeInfo).GetDocumentation(-1, PWideString(@pwcRet), nil, nil, nil);
        ITypeInfo(pTypeInfo)._Release;
        pTypeInfo := nil;
      end;

      // Release all interface pointers get by QueryInterface
      if (pProvider <> nil) then
      begin
        IProvideClassInfo(pProvider)._Release;
        pProvider := nil;
      end;

      if (pDisp <> nil) then
      begin
        IDispatch(pDisp)._Release;
        pDisp := nil;
      end;

      if (pwcRet <> nil) then
      begin
        if (pwcRet[0] = '_') then   // remove '_' char
        begin
          pwcTypeName := SysAllocStringLen(@pwcRet[1], SysStringLen(pwcRet) - 1);
          SysFreeString(pwcRet);
          if (nil = pwcTypeName) then
            Exit(VAR_OUTOFMEMORY);
        end
        else
          pwcTypeName := pwcRet;

        Exit(VAR_OK);
      end;
    end;
  end;

  // All above failed, get default, or vt not in [varRecord, varUnknown, varDispatch]
  if (pwcRet = nil) then
  begin
    pwcRet := SysAllocString(CText[vt]);
    if (nil = pwcRet) then
      Exit(VAR_OUTOFMEMORY);
  end;

  if IsArray then
  begin
    var oldLen := SysStringLen(pwcRet);
    pwcTypeName := SysAllocStringLen(pwcRet, oldLen + 2);
    if (pwcTypeName <> nil) then
    begin
      pwcTypeName[oldLen] := '(';
      pwcTypeName[oldLen + 1] := ')';
    end;
  end
  else
    pwcTypeName := SysAllocString(pwcRet);

  if (pwcRet <> nil) then
  begin
    SysFreeString(pwcRet);
    pwcRet := nil;
  end;

  if (nil <> pwcTypeName) then
    Result := VAR_OK
  else
    Result := VAR_OUTOFMEMORY;
end;

Nhờ admin xóa hết mấy cái file VBArray.zip ở các post trước trong chủ đề này.
Thanks

 

[Kiều Mạnh]

chạy nhanh... còn 1 hàm đơ Excel xong thoát