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

Blue Softs epl Liên hệ QC

Nguyễn Duy Tuân

Nghị Hách
Thành viên danh dự
Tham gia
13/6/06
Bài viết
4,500
Được thích
9,936
Giới tính
Nam
Nghề nghiệp
Giáo viên, CEO tại Bluesofts
Lần chỉnh sửa cuối:

Nguyễn Duy Tuân

Nghị Hách
Thành viên danh dự
Tham gia
13/6/06
Bài viết
4,500
Được thích
9,936
Giới tính
Nam
Nghề nghiệp
Giáo viên, CEO tại Bluesofts
Upvote 0

Kiều Mạnh

IIIIIIIIIIIIIIIII
Tham gia
9/6/12
Bài viết
4,583
Được thích
3,225
Giới tính
Nam
Tôi code DLL trong Delphi theo hướng giải quyết khác với anh "ThangCuAnh" và kết quả DLL tôi viết trong Delphi nhanh hơn VBA. Các bạn thử nghiệm trên máy tính của các bạn rồi cho kết quả nhé. Sự so sánh có thể khác nhau giữa các Office 32 hay 64-bit.

"tuanfastcode.dll" là thư viện lập trình bằng Delphi, xuất các hàm APIs gồm
1. CopyArray: Copy hai mảng 2D với nhau
2. TransArray: Đảo chiều mảng 2D
3. FastSumArray: Tổng trong mảng 2D

Để chạy các hàm này cần copy thư viện như sau:
+ Nếu Windows 64 bit
Copy x86\tuanfastcode.dll vào C:\Windows\SysWow64\
Copy x64\tuanfastcode.dll vào C:\Windows\System32\

+ Nếu Windows 32 bit
Copy x86\tuanfastcode.dll vào C:\Windows\System32\

So sánh hàm viết trong DLL này với cách viết tương tự trong VBA.
Chạy mở file "TestTuanFastCode.xlsm", vào VBA chạy code để so sánh.

Tôi đã test với Windows 64-bit, Office365 32-bit
Tốc độ các hàm tôi viết trong Delphi đều nhanh hơn VBA, trong đó hàm FastSumArray nhanh gấp 4 lần. Các bạn có thể test để xem kết quả ra sao.



Download
Máy Mạnh Office 365_x64 + Window10x64

1636020727406.png
 
Upvote 0

Kiều Mạnh

IIIIIIIIIIIIIIIII
Tham gia
9/6/12
Bài viết
4,583
Được thích
3,225
Giới tính
Nam
Tôi mới Test thử chạy code các kiểu ... API hay COM viết = Delphi tốc độc chạy như nhau cùng một cách viết

Có 1 điểm chung nữa là là lần đầu tiên chạy code thời gian gần gấp đôi những lần sau ( đoán là load API hay COM ) nên nó tăng cái thời gian xử lý khi load hàm lần đầu lên gần gấp đôi thời gian những lần chạy code sau đó

lần ở đây hiểu là khi mở Files lên chạy code tính là lần số 1
 
Upvote 0

ThangCuAnh

Mới rờ Ét xeo
Tham gia
1/12/17
Bài viết
875
Được thích
775
Giới tính
Nam
Nghề nghiệp
Coder nghỉ hưu, RCE dạo
Đúng là dữ liệu càng lớn thì mới thấy sự chênh lệch rõ về code VBA và Delphi.
Test trên máy mình với file của Tuân và Dll của Tuân và mình, hàm FastSumRange của mình giờ mới thấy nó chạy nhanh khiếp, có khi 0 ms luôn. Nhanh gấp 23 lần code VBA
Của Tuân vẫn bị chậm do Tuân call direct hàm API SafeArrayGetElement và SafeArrayPutElement trong vòng lặp.
Mỗi lần call vậy nó phải SafeArrayLock và Unlock trong hàm, check kiểu PSafeArray và các phần tử. (Rờ em oleaut32.dll 2 hàm này thấy khiếp. Nên né :D )
Tuy nhiên, cái gì cũng có cái giá của nó. Được này mất kia. Theo document của MS (MSDN) thì SafeArrayGet/PutElement sẽ copy đúng giá trị variant trong trường hợp phần tử variant là string, object....
1636258644041.png
1636259233056.png
 
Lần chỉnh sửa cuối:
Upvote 0

ThangCuAnh

Mới rờ Ét xeo
Tham gia
1/12/17
Bài viết
875
Được thích
775
Giới tính
Nam
Nghề nghiệp
Coder nghỉ hưu, RCE dạo
Hì hì, nhậu 3 ngày liên tục đù luôn.
Sẵn đây xin phép bạn Tuân cho mình post source decompiler ra C của hàm TransArray của Tuân để các bạn khác có thể đọc hiểu và viết lại bằng Delphi. Hàm CopyArray cũng tựa tựa vậy, chỉ khác thứ tự index I và J thôi. Tuân dùng trực tiếp các hàm API SafeArray, không dùng các hàm của Delphi RTL.
Vòng for của Delphi compiler nó sinh mã giống vòng do while của C/C++ thôi. Code Delphi là vòng for I := to for J := to đấy.
Cũng là bài tập thêm cho các bạn.
Kiểm tra phần tử VARIANT trong mãng, nếu nó là dạng số thuần thì dùng SafeArrayLock/Unlock để truy xuất trực tiếp tới memory của phần tử.
Nếu là kiểu string, object, IUnknown, IDispatch... thì dùng SafeArrayGet/PutElement.
Code sao cho nhanh nhất có thể.
1636260996746.png
 
Lần chỉnh sửa cuối:
Upvote 0

ThangCuAnh

Mới rờ Ét xeo
Tham gia
1/12/17
Bài viết
875
Được thích
775
Giới tính
Nam
Nghề nghiệp
Coder nghỉ hưu, RCE dạo
Các bạn mới code sẽ hay gặp 1 lỗi này, mình gợi ý các bạn tránh luôn. Lỗi này sẽ kéo tộc độ xuống gần 50%.
Vd:
Mã:
var
   flag: Boolean;
....
begin
....
  for I := A to B do
    for J := C to D do
      if flag then
        doA
      else
        doB
....
Không nên viết như vậy, CPU sẽ sinh mã nhảy, instruction cache misses rất nhiều trong vòng for. Nên đưa ra ngoài như sau:
Mã:
....
if flag then
  for I : = A to B do
    for J : = C to D do
       doA
else
  for I : = A to B do
    for J : = C to D do
       doB
....
Nhìn thì thấy dài hơn, compiler sinh code nhiều hơn nhưng tốc độ lại nhanh hơn. Lệnh CPU check flag chỉ có 1, sau đó là vào vòng for chạy 1 lèo luôn.
Chân chọng, bét xì ga.
 
Upvote 0

Nguyễn Duy Tuân

Nghị Hách
Thành viên danh dự
Tham gia
13/6/06
Bài viết
4,500
Được thích
9,936
Giới tính
Nam
Nghề nghiệp
Giáo viên, CEO tại Bluesofts
Hì hì, nhậu 3 ngày liên tục đù luôn.
Sẵn đây xin phép bạn Tuân cho mình post source decompiler ra C của hàm TransArray của Tuân để các bạn khác có thể đọc hiểu và viết lại bằng Delphi. Hàm CopyArray cũng tựa tựa vậy, chỉ khác thứ tự index I và J thôi. Tuân dùng trực tiếp các hàm API SafeArray, không dùng các hàm của Delphi RTL.
Vòng for của Delphi compiler nó sinh mã giống vòng do while của C/C++ thôi. Code Delphi là vòng for I := to for J := to đấy.
Cũng là bài tập thêm cho các bạn.
Kiểm tra phần tử VARIANT trong mãng, nếu nó là dạng số thuần thì dùng SafeArrayLock/Unlock để truy xuất trực tiếp tới memory của phần tử.
Nếu là kiểu string, object, IUnknown, IDispatch... thì dùng SafeArrayGet/PutElement.
Code sao cho nhanh nhất có thể.
View attachment 268869

Vâng. Bài trước em không để source để các bạn chịu tìm hiểu, nếu không làm được kiến thức đó thì em cũng share source chứ mấy cái này chỉ là tip cho cho học tập.
 
Upvote 0

Kiều Mạnh

IIIIIIIIIIIIIIIII
Tham gia
9/6/12
Bài viết
4,583
Được thích
3,225
Giới tính
Nam
Hì hì, nhậu 3 ngày liên tục đù luôn.
Sẵn đây xin phép bạn Tuân cho mình post source decompiler ra C của hàm TransArray của Tuân để các bạn khác có thể đọc hiểu và viết lại bằng Delphi. Hàm CopyArray cũng tựa tựa vậy, chỉ khác thứ tự index I và J thôi. Tuân dùng trực tiếp các hàm API SafeArray, không dùng các hàm của Delphi RTL.
Vòng for của Delphi compiler nó sinh mã giống vòng do while của C/C++ thôi. Code Delphi là vòng for I := to for J := to đấy.
Cũng là bài tập thêm cho các bạn.
Kiểm tra phần tử VARIANT trong mãng, nếu nó là dạng số thuần thì dùng SafeArrayLock/Unlock để truy xuất trực tiếp tới memory của phần tử.
Nếu là kiểu string, object, IUnknown, IDispatch... thì dùng SafeArrayGet/PutElement.
Code sao cho nhanh nhất có thể.
View attachment 268869
Úp code Delphi cho mạnh + các bạn khác iu thích Delphi học với .... nhìn vậy cứ như mộng du :p
 
Upvote 0

ThangCuAnh

Mới rờ Ét xeo
Tham gia
1/12/17
Bài viết
875
Được thích
775
Giới tính
Nam
Nghề nghiệp
Coder nghỉ hưu, RCE dạo
Mình chỉ biết nói dóc, lý thuyết thôi bạn Mạnh.
Code C đó, bạn port qua Delphi tương đương 1 - 1 à.
Mình kg code được, sorry.
Bạn Mạnh tự code đi, khi nào bị bug hay chạy chậm thì quăng code lên, mình fix và optimize cho.
Chứ còn nói mình tự code thì lười lắm :D
 
Lần chỉnh sửa cuối:
Upvote 0

ThangCuAnh

Mới rờ Ét xeo
Tham gia
1/12/17
Bài viết
875
Được thích
775
Giới tính
Nam
Nghề nghiệp
Coder nghỉ hưu, RCE dạo
Bữa giờ mình rờ em các hàm API về SafeArray của oleaut32.dll của MS.
Nên chưa vội viết các hàm CopyArray và TransArr bằng Delphi.
Code của Tuân là đúng, an toàn nhất. Nhưng bị memory leak/sai RefCount ở phần tử Variant cuối cùng trong array.
Chú ý field fFeatures trong struct SAFEARRAY.
Nếu nó là IUnknown, IDispatch, IRecordInfo, BSTR thì sụm bà chè hết.
SafeArray API, MS coder đã cung cấp sẵn hàm SafeArrayCopy, copy deep, nên dùng, kg nên phát minh lại bánh xe.
 
Upvote 0

Nguyễn Duy Tuân

Nghị Hách
Thành viên danh dự
Tham gia
13/6/06
Bài viết
4,500
Được thích
9,936
Giới tính
Nam
Nghề nghiệp
Giáo viên, CEO tại Bluesofts
Bữa giờ mình rờ em các hàm API về SafeArray của oleaut32.dll của MS.
Nên chưa vội viết các hàm CopyArray và TransArr bằng Delphi.
Code của Tuân là đúng, an toàn nhất. Nhưng bị memory leak/sai RefCount ở phần tử Variant cuối cùng trong array.
Chú ý field fFeatures trong struct SAFEARRAY.
Nếu nó là IUnknown, IDispatch, IRecordInfo, BSTR thì sụm bà chè hết.
SafeArray API, MS coder đã cung cấp sẵn hàm SafeArrayCopy, copy deep, nên dùng, kg nên phát minh lại bánh xe.

Hàm CopyArrray em cố tình viết vậy để so sánh tốc độ thực hiện với toán tử gán giá trị kiểu Vảiant giữa Delphi và VBA. Tại sao phần tử cuối cùng của mảng lại leak memory nhỉ? Điều này e thấy vô lý thật.
 
Upvote 0

ThangCuAnh

Mới rờ Ét xeo
Tham gia
1/12/17
Bài viết
875
Được thích
775
Giới tính
Nam
Nghề nghiệp
Coder nghỉ hưu, RCE dạo
Do hàm VariantCopy mà SafeArrayGet/PutElement gọi bên trong ruột nó em.
Em đọc lại help của hàm VariantCopy đi. Free dest, copy source qua dest.... Cứ vậy thì tới thằng cuối cùng kg ai free nó
 
Upvote 0

ThangCuAnh

Mới rờ Ét xeo
Tham gia
1/12/17
Bài viết
875
Được thích
775
Giới tính
Nam
Nghề nghiệp
Coder nghỉ hưu, RCE dạo
Sau 1 thời gian RE các hàm SAFEARRAY API trong oleaut32.dll, mình viết tặng các bạn các hàm Sum, Copy và Trans array. Dùng trực tiếp API và đã test, cải tiến tối đa tốc độ.
Các bạn có thể dùng cho thư viện riêng của mình. Beerware lái sần hết, không lo.
Các bạn test speed thử giúp mình nhé.
Hàm FastTransArrayByCopy thua tốc độ hàm FastTransArrayDirect 1 chút, nhưng dùng an toàn hơn. Nên mình không đưa code hàm FastTransArrayDirect vào, vì sau này, các Windows ver khác, ai biết MS có đổi internal struct của SAFEARRAY nữa hay không.
Cho nên chắc ăn nhất là cứ dùng các API có sẵn của họ.
Bạn nào cần code hàm FastTransArrayDirect thì contact mình.
Các hàm Sum, Copy và Trans array đều an toàn, không memory leak/object leak, chạy đúng với mọi kiểu dữ liệu của từng phần tử, mọi Variant , string (BSTR), các object IUnknown, IDispatch....

Mã:
// VBArray.dll: Library for some VB/VBA array functions
// Coded by: HTC (TQN/TCA)
// 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, 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

// 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 @vArrSrc = @vArrDst then
    Exit(VAR_OK); // copy itself

  if not VarIsArray(vArrSrc) then
    Exit(VAR_INVALIDARG);

  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 @vArrSrc = @vArrDst then
    Exit(VAR_OK); // trans itself

  if not VarIsArray(vArrSrc) then
    Exit(VAR_INVALIDARG);

  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;

  Assert(pSrc <> nil);

  try
    SafeArrayAccessData(pvaDst, pDst);  // pvaDst^.LockCount/cLocks = 0, don't need to check hr
    Assert(pDst <> nil);

    // 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;
    else
      // VARIANT, 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;

    SafeArrayUnaccessData(pvaDst);
  finally
    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;
begin
  Result := VAR_NOTIMPL;
end;

exports
  FastSumArray,
  FastCopyArray,
  FastTransArrayByCopy,
  FastTransArrayDirect;

{$IFDEF TEST}
var
  vArrSrc, vArrDst: Variant;
  I, J: Integer;
  hr: HRESULT;
begin
  vArrSrc := VarArrayCreate([0, 2, 0, 4], varVariant);
  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 := FastTransArrayByCopy(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.
 

File đính kèm

  • VBArray.zip
    182.9 KB · Đọc: 11
Lần chỉnh sửa cuối:
Upvote 0

Nguyễn Duy Tuân

Nghị Hách
Thành viên danh dự
Tham gia
13/6/06
Bài viết
4,500
Được thích
9,936
Giới tính
Nam
Nghề nghiệp
Giáo viên, CEO tại Bluesofts
Sau 1 thời gian RE các hàm SAFEARRAY API trong oleaut32.dll, mình viết tặng các bạn các hàm Sum, Copy và Trans array. Dùng trực tiếp API và đã test, cải tiến tối đa tốc độ.
Các bạn có thể dùng cho thư viện riêng của mình. Beerware lái sần hết, không lo.
Các bạn test speed thử giúp mình nhé.
Hàm FastTransArrayByCopy thua tốc độ hàm FastTransArrayDirect 1 chút, nhưng dùng an toàn hơn. Nên mình không đưa code hàm FastTransArrayDirect vào, vì sau này, các Windows ver khác, ai biết MS có đổi internal struct của SAFEARRAY nữa hay không.
Cho nên chắc ăn nhất là cứ dùng các API có sẵn của họ.
Bạn nào cần code hàm FastTransArrayDirect thì contact mình.
Các hàm Sum, Copy và Trans array đều an toàn, không memory leak/object leak, chạy đúng với mọi kiểu dữ liệu của từng phần tử, mọi Variant , string (BSTR), các object IUnknown, IDispatch....

Mã:
// VBArray.dll: Library for some VB/VBA array functions
// Coded by: HTC (TQN/TCA)
// 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, 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

// 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 @vArrSrc = @vArrDst then
    Exit(VAR_OK); // copy itself

  if not VarIsArray(vArrSrc) then
    Exit(VAR_INVALIDARG);

  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 @vArrSrc = @vArrDst then
    Exit(VAR_OK); // trans itself

  if not VarIsArray(vArrSrc) then
    Exit(VAR_INVALIDARG);

  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;

  Assert(pSrc <> nil);

  try
    SafeArrayAccessData(pvaDst, pDst);  // pvaDst^.LockCount/cLocks = 0, don't need to check hr
    Assert(pDst <> nil);

    // 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;
    else
      // VARIANT, 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;

    SafeArrayUnaccessData(pvaDst);
  finally
    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;
begin
  Result := VAR_NOTIMPL;
end;

exports
  FastSumArray,
  FastCopyArray,
  FastTransArrayByCopy,
  FastTransArrayDirect;

{$IFDEF TEST}
var
  vArrSrc, vArrDst: Variant;
  I, J: Integer;
  hr: HRESULT;
begin
  vArrSrc := VarArrayCreate([0, 2, 0, 4], varVariant);
  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 := FastTransArrayByCopy(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.

Em đã test. code anh làm chạy rất nhanh.
Về logic tính SUM, theo em với kiểu BOOLEAN mình không đưa vào tính tổng để việc ứng dụng sẽ thống nhất với các hàm Excel.
 
Upvote 0

Kiều Mạnh

IIIIIIIIIIIIIIIII
Tham gia
9/6/12
Bài viết
4,583
Được thích
3,225
Giới tính
Nam
Sau 1 thời gian RE các hàm SAFEARRAY API trong oleaut32.dll, mình viết tặng các bạn các hàm Sum, Copy và Trans array. Dùng trực tiếp API và đã test, cải tiến tối đa tốc độ.
Các bạn có thể dùng cho thư viện riêng của mình. Beerware lái sần hết, không lo.
Các bạn test speed thử giúp mình nhé.
Hàm FastTransArrayByCopy thua tốc độ hàm FastTransArrayDirect 1 chút, nhưng dùng an toàn hơn. Nên mình không đưa code hàm FastTransArrayDirect vào, vì sau này, các Windows ver khác, ai biết MS có đổi internal struct của SAFEARRAY nữa hay không.
Cho nên chắc ăn nhất là cứ dùng các API có sẵn của họ.
Bạn nào cần code hàm FastTransArrayDirect thì contact mình.
Các hàm Sum, Copy và Trans array đều an toàn, không memory leak/object leak, chạy đúng với mọi kiểu dữ liệu của từng phần tử, mọi Variant , string (BSTR), các object IUnknown, IDispatch....

Mã:
// VBArray.dll: Library for some VB/VBA array functions
// Coded by: HTC (TQN/TCA)
// 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, 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

// 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 @vArrSrc = @vArrDst then
    Exit(VAR_OK); // copy itself

  if not VarIsArray(vArrSrc) then
    Exit(VAR_INVALIDARG);

  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 @vArrSrc = @vArrDst then
    Exit(VAR_OK); // trans itself

  if not VarIsArray(vArrSrc) then
    Exit(VAR_INVALIDARG);

  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;

  Assert(pSrc <> nil);

  try
    SafeArrayAccessData(pvaDst, pDst);  // pvaDst^.LockCount/cLocks = 0, don't need to check hr
    Assert(pDst <> nil);

    // 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;
    else
      // VARIANT, 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;

    SafeArrayUnaccessData(pvaDst);
  finally
    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;
begin
  Result := VAR_NOTIMPL;
end;

exports
  FastSumArray,
  FastCopyArray,
  FastTransArrayByCopy,
  FastTransArrayDirect;

{$IFDEF TEST}
var
  vArrSrc, vArrDst: Variant;
  I, J: Integer;
  hr: HRESULT;
begin
  vArrSrc := VarArrayCreate([0, 2, 0, 4], varVariant);
  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 := FastTransArrayByCopy(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.
Cảm ơn nhiều ... qua tuần rảnh Mạnh test các kiểu xem sao có gì báo lại sau ... tin 100/100 là chạy vèo vèo
Cái dòng To màu đen cũng muốn lại mà ngại ....:p
 
Upvote 0

ThangCuAnh

Mới rờ Ét xeo
Tham gia
1/12/17
Bài viết
875
Được thích
775
Giới tính
Nam
Nghề nghiệp
Coder nghỉ hưu, RCE dạo
FastTransArrayByCopy sẽ chạy chậm nhất trong trường hợp các phần tử của array là kiểu VARIANT.
Do hàm SafeArrayCopy đã phải gọi hàm VariantCopy trong ruột nó, ở ngoài còn phải swap 2 raw value của 2 phần tử bằng CopyMemory.
Chờ chút mình fix lại chổ CopyMemory và đưa luôn source hàm FastTransArrayDirect
 
Upvote 0
Web KT
Top Bottom