varutils.pas

这是不可多得的源代码

    Result := VAR_OK;
  end;
end;

function BackupVarBStrFromBool(boolIn: WordBool; LCID: Integer; dwFlags: Longint;
  out bstrOut: WideString): HRESULT; stdcall;
begin
  if LCID <> VAR_LOCALE_USER_DEFAULT then
    Result := VAR_NOTIMPL
  else
  begin
    bstrOut := BoolToStr(boolIn);
    Result := VAR_OK;
  end;
end;

{******************************************************************************}
{ SafeArray Functions                                                          }
{******************************************************************************}

{$IF not GenericSafeArrays}
function SafeArrayCreate; external oleaut name 'SafeArrayCreate';
function SafeArrayAllocDescriptor; external oleaut name 'SafeArrayAllocDescriptor';
function SafeArrayAllocData; external oleaut name 'SafeArrayAllocData';
function SafeArrayDestroy; external oleaut name 'SafeArrayDestroy';
function SafeArrayDestroyDescriptor; external oleaut name 'SafeArrayDestroyDescriptor';
function SafeArrayDestroyData; external oleaut name 'SafeArrayDestroyData';
function SafeArrayRedim; external oleaut name 'SafeArrayRedim';
function SafeArrayCopy; external oleaut name 'SafeArrayCopy';
function SafeArrayCopyData; external oleaut name 'SafeArrayCopyData';
function SafeArrayGetLBound; external oleaut name 'SafeArrayGetLBound';
function SafeArrayGetUBound; external oleaut name 'SafeArrayGetUBound';
function SafeArrayGetDim; external oleaut name 'SafeArrayGetDim';
function SafeArrayAccessData; external oleaut name 'SafeArrayAccessData';
function SafeArrayUnaccessData; external oleaut name 'SafeArrayUnaccessData';
function SafeArrayLock; external oleaut name 'SafeArrayLock';
function SafeArrayUnlock; external oleaut name 'SafeArrayUnlock';
function SafeArrayGetElement; external oleaut name 'SafeArrayGetElement';
function SafeArrayPutElement; external oleaut name 'SafeArrayPutElement';
function SafeArrayPtrOfIndex; external oleaut name 'SafeArrayPtrOfIndex';
function SafeArrayGetElemSize; external oleaut name 'SafeArrayGetElemsize';

{$ELSE}
type
  TSafeArrayValidateCheck = (savLockCheck);
  TSafeArrayValidateChecks = set of TSafeArrayValidateCheck;
const
  cCheckAll: TSafeArrayValidateChecks = [savLockCheck];

function SafeArrayValidate(VarArray: PVarArray; AndCheck: TSafeArrayValidateChecks = []): HRESULT;
const
  cResults: array [Boolean] of HRESULT = (VAR_INVALIDARG, VAR_OK);
  cLockResult: array [Boolean] of HRESULT = (VAR_ARRAYISLOCKED, VAR_OK);
begin
  Result := cResults[VarArray <> nil];
  if (savLockCheck in AndCheck) and
     (Result = VAR_OK)  then
    Result := cLockResult[VarArray^.LockCount = 0];
end;

function SafeArrayCalculateElementAddress(VarArray: PVarArray; AElement: Integer): Pointer;
begin
  Result := Pointer(Integer(VarArray^.Data) + (AElement * VarArray^.ElementSize));
end;

function SafeArrayValidateAndCalculateAddress(VarArray: PVarArray;
  Indices: PVarArrayCoorArray; var Address: Pointer; Lockit: Boolean): HRESULT;
  function CountElements(LDim: Integer): Integer;
  begin
    Result := 1;
    if LDim < VarArray^.DimCount then
      Result := CountElements(LDim + 1) + VarArray^.Bounds[LDim - 1].ElementCount;
  end;
var
  LDim: Integer;
  LLow, LHigh: Integer;
  LElement: Integer;
begin
  // validate the array
  Result := SafeArrayValidate(VarArray);
  Address := nil;
  LElement := 0;

  // if all is swell so far
  if Result = VAR_OK then
  begin

    // validate the indices first
    for LDim := 1 to VarArray^.DimCount do
    begin
      LLow := VarArray^.Bounds[LDim - 1].LowBound;
      LHigh := LLow + VarArray^.Bounds[LDim - 1].ElementCount;
      if (LLow = LHigh) or
         ((Indices^[LDim - 1] < LLow) or
          (Indices^[LDim - 1] > LHigh)) then
      begin
        Result := VAR_BADINDEX;
        Break;
      end;

      // continue to calculate the element count
      Inc(LElement, (Indices^[LDim - 1] - LLow) * CountElements(LDim + 1));
    end;

    // all is swell?
    if Result = VAR_OK then
    begin
      Address := SafeArrayCalculateElementAddress(VarArray, LElement);

      // finally lets lock it we need to
      if LockIt then
        Result := SafeArrayLock(VarArray);
    end;
  end;
end;

function SafeArrayElementTotal(VarArray: PVarArray): Integer;
var
  LDim: Integer;
begin
  Result := 1;
  for LDim := 0 to VarArray^.DimCount - 1 do
    Result := Result * VarArray^.Bounds[LDim].ElementCount;
end;

type
  TElementStyle = (esNormal, esReference, esOleStr, esVariant);

function SafeArrayElementStyle(VarArray: PVarArray): TElementStyle;
begin
  // interface type thingy
  if ((VarArray^.Flags and ARR_DISPATCH) <> 0) or
     ((VarArray^.Flags and ARR_UNKNOWN) <> 0) then
    Result := esReference

  // string type thingy
  else if (VarArray^.Flags and ARR_OLESTR) <> 0 then
    Result := esOleStr

  // variant type thingy
  else if (VarArray^.Flags and ARR_VARIANT) <> 0 then
    Result := esVariant

  // otherwise is just a normal thingy
  else
    Result := esNormal;
end;

function SafeArrayClearDataSpace(VarArray: PVarArray; WipeBytes: Boolean = True): HRESULT;
var
  LElement: Integer;
  LAddress: Pointer;
  LElementStyle: TElementStyle;
begin
  Result := VAR_OK;

  // just in case
  try

    // what type of data do we have?
    LElementStyle := SafeArrayElementStyle(VarArray);
    case LElementStyle of

      // simple fill
      esNormal:
        if WipeBytes then
          FillChar(VarArray^.Data^, SafeArrayElementTotal(VarArray) *
                                    VarArray^.ElementSize, 0);

      // we have to go though each element
      esReference, esOleStr, esVariant:
        for LElement := 0 to SafeArrayElementTotal(VarArray) - 1 do
        begin
          LAddress := SafeArrayCalculateElementAddress(VarArray, LElement);

          // do the right thing
          case LElementStyle of
            esReference:
              IUnknown(PUnknown(LAddress)^) := nil;
            esOleStr:
              WideString(PPointer(LAddress)^) := '';
            esVariant:
              Result := VariantClear(PVarData(LAddress)^);
          else
            Result := VAR_EXCEPTION;
          end;
        end;
    end;

  // oops!
  except
    // something really really bad happened
    on EOutOfMemory do
      Result := VAR_OUTOFMEMORY;

  // catch all else
  else
    Result := VAR_EXCEPTION;
  end;
end;

function SafeArrayCopyDataSpace(SourceArray, TargetArray: PVarArray): HRESULT;
var
  LElement: Integer;
  LSource, LTarget: Pointer;
  LElementStyle: TElementStyle;
begin
  Result := VAR_OK;

  // just in case
  try

    // what type of data do we have?
    LElementStyle := SafeArrayElementStyle(SourceArray);
    case LElementStyle of

      // simple fill
      esNormal:
        Move(SourceArray^.Data^, TargetArray^.Data^, SafeArrayElementTotal(SourceArray) *
                                                     SourceArray^.ElementSize);

      // we have to go though each element
      esReference, esOleStr, esVariant:
        for LElement := 0 to SafeArrayElementTotal(SourceArray) - 1 do
        begin
          LSource := SafeArrayCalculateElementAddress(SourceArray, LElement);
          LTarget := SafeArrayCalculateElementAddress(TargetArray, LElement);

          // do the right thing
          case LElementStyle of
            esReference:
              IUnknown(PUnknown(LTarget)^) := IUnknown(PUnknown(LSource)^);
            esOleStr:
              WideString(PPointer(LTarget)^) := Copy(PPWideChar(LSource)^, 1, MaxInt);
            esVariant:
              Result := VariantCopy(PVarData(LTarget)^, PVarData(LSource)^);
          else
            Result := VAR_EXCEPTION;
          end;
        end;
    end;

  // oops!
  except
    // something really really bad happened
    on EOutOfMemory do
      Result := VAR_OUTOFMEMORY;

  // catch all else
  else
    Result := VAR_EXCEPTION;
  end;
end;

function SafeArrayAllocMem(const Size: LongWord): Pointer;
begin
  {$IF GenericSafeArrayUsesLibC}
  Result := Libc.calloc(1, Size);
  {$ELSE}
  Result := AllocMem(Size);
  {$IFEND}
end;

procedure SafeArrayFreeMem(const Address: Pointer);
begin
  {$IF GenericSafeArrayUsesLibC}
  Libc.free(Address);
  {$ELSE}
  FreeMem(Address);
  {$IFEND}
end;

procedure SafeArrayReallocMem(var Address: Pointer; const OldSize, NewSize: LongWord);
var
  Temp: Pointer;
begin
  if Address <> nil then
  begin
    if NewSize > 0 then
    begin
      Temp := SafeArrayAllocMem(NewSize);
      Move(Address^, Temp^, OldSize);
      SafeArrayFreeMem(Address);
      Address := Temp;
    end
    else
    begin
      SafeArrayFreeMem(Address);
      Address := nil;
    end;
  end else
    Address := SafeArrayAllocMem(NewSize);
end;

function SafeArrayCreate(VarType, DimCount: Integer; const Bounds: TVarArrayBoundArray): PVarArray;
var
  LResult: HRESULT;
  LDim: Integer;
begin
  Result := nil;

  // is this something we want to deal with?
  if (VarType in [CMinArrayVarType..CMaxArrayVarType]) and
     CVarTypeToElementInfo[VarType].ValidBase then
  begin

    // make room for the descriptor
    LResult := SafeArrayAllocDescriptor(DimCount, Result);
    if LResult = VAR_OK then
    begin

      // add our bits of information
      Result^.DimCount := DimCount;
      Result^.Flags := cVarTypeToElementInfo[VarType].Flags;
      Result^.ElementSize := cVarTypeToElementInfo[VarType].Size;

      // fill in the bounds info
      for LDim := 0 to Result^.DimCount - 1 do
      begin
        Result^.Bounds[LDim].ElementCount := Bounds[DimCount - LDim - 1].ElementCount;
        Result^.Bounds[LDim].LowBound := Bounds[DimCount - LDim - 1].LowBound;
      end;

      // try to allocate the data
      LResult := SafeArrayAllocData(Result);

      // if not then get rid of the descriptor
      if LResult <> VAR_OK then
      begin
        SafeArrayDestroyDescriptor(Result);
        Result := nil;
      end;
    end;
  end;
end;

function SafeArrayAllocDescriptor(DimCount: Integer; out VarArray: PVarArray): HRESULT;
begin
  Result := VAR_OK;

  // give it a shot
  try
    VarArray := SafeArrayAllocMem(SizeOf(TVarArray) + SizeOf(TVarArrayBound) * (DimCount - 1));
  except
    // something really really bad happened
    on EOutOfMemory do
      Result := VAR_OUTOFMEMORY;

  // catch all else
  else
    Result := VAR_UNEXPECTED;
  end;
end;

function SafeArrayAllocData(VarArray: PVarArray): HRESULT;
begin
  Result := VAR_OK;

  // give it a shot
  try
    VarArray^.Data := SafeArrayAllocMem(SafeArrayElementTotal(VarArray) *
                                        VarArray^.ElementSize);
  except
    // something really really bad happened
    on EOutOfMemory do
      Result := VAR_OUTOFMEMORY;

  // catch all else
  else
    Result := VAR_UNEXPECTED;
  end;
end;

function SafeArrayDestroy(VarArray: PVarArray): HRESULT;
begin
  // all is swell?
  Result := SafeArrayValidate(VarArray, cCheckAll);
  if Result = VAR_OK then
  begin

    // well then lets try to destroy the pieces parts
    Result := SafeArrayDestroyData(VarArray);
    if Result = VAR_OK then
      Result := SafeArrayDestroyDescriptor(VarArray);
  end;
end;

function SafeArrayDestroyDescriptor(VarArray: PVarArray): HRESULT;
begin
  // all is swell?
  Result := SafeArrayValidate(VarArray, cCheckAll);
  if Result = VAR_OK then
  try