varutils.pas

这是不可多得的源代码

    // try and free it then
    SafeArrayFreeMem(VarArray);
  except
    Result := VAR_UNEXPECTED;
  end;
end;

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

    // slick the data space
    Result := SafeArrayClearDataSpace(VarArray, False);

    // if all is swell and, if we are supposed to, free the data
    if (Result = VAR_OK) and
       ((VarArray^.Flags and ARR_FIXEDSIZE) = 0) then
    begin
      SafeArrayFreeMem(VarArray^.Data);
      VarArray^.Data := nil;
    end;
  except
    Result := VAR_UNEXPECTED;
  end;
end;

function SafeArrayRedim(VarArray: PVarArray; const NewBound: TVarArrayBound): HRESULT;
var
  LDim, LDelta: Integer;
  LTotal, LElement: Integer;
  LAddress: Pointer;
  LElementStyle: TElementStyle;
begin
  // check out the array
  Result := SafeArrayValidate(VarArray);
  if Result = VAR_OK then
  begin
    if (VarArray^.Flags and ARR_FIXEDSIZE) <> 0 then
      Result := VAR_INVALIDARG;

    // is still swell?
    if Result = VAR_OK then
    begin
      Result := SafeArrayLock(VarArray);
      if Result = VAR_OK then
      try
        try

          // calculate the delta
          LDelta := NewBound.ElementCount - VarArray^.Bounds[0].ElementCount;
          for LDim := 1 to VarArray^.DimCount - 1 do
            LDelta := LDelta * VarArray^.Bounds[LDim].ElementCount;

          // any change?
          if LDelta <> 0 then
          begin

            // how big are we currently?
            LTotal := SafeArrayElementTotal(VarArray);

            // make things shorter?
            if LDelta < 0 then
            begin

              // what type of stuff are we dealing with?
              LElementStyle := SafeArrayElementStyle(VarArray);

              // for each element
              for LElement := LTotal - 1 downto LTotal + LDelta do { Delta is negative }
              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;

            // failure?
            if Result <> VAR_OK then
              Exit;

            // regrab the memory
            SafeArrayReallocMem(VarArray^.Data,
                                LTotal * VarArray^.ElementSize,
                                (LTotal + LDelta) * VarArray^.ElementSize);
          end;

          // copy over the new bound info
          VarArray^.Bounds[0].ElementCount := NewBound.ElementCount;
          VarArray^.Bounds[0].LowBound := NewBound.LowBound;

        // oops!
        except

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

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

      // put away our toys
      finally
        if Result = VAR_OK then
          Result := SafeArrayUnlock(VarArray)
        else
          SafeArrayUnlock(VarArray);
      end;
    end;
  end;
end;

function SafeArrayCopy(SourceArray: PVarArray; out TargetArray: PVarArray): HRESULT;
var
  LDim: Integer;
begin
  // check out the source array
  Result := SafeArrayValidate(SourceArray);
  if Result = VAR_OK then
  begin
    Result := SafeArrayLock(SourceArray);
    if Result = VAR_OK then
    try //and
      try // again

        // make room for the descriptor
        Result := SafeArrayAllocDescriptor(SourceArray^.DimCount, TargetArray);
        if Result = VAR_OK then
        try

          // add our bits of information
          TargetArray^.DimCount := SourceArray^.DimCount;
          TargetArray^.Flags := SourceArray^.Flags;
          TargetArray^.ElementSize := SourceArray^.ElementSize;

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

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

          // now copy it!
          if Result = VAR_OK then
            Result := SafeArrayCopyDataSpace(SourceArray, TargetArray);

        // remember to clean up if needed
        finally
          if Result <> VAR_OK then
          begin
            SafeArrayDestroyDescriptor(TargetArray);
            TargetArray := nil;
          end;
        end;

      // oops!
      except

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

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

    // put away our toys
    finally
      if Result = VAR_OK then
        Result := SafeArrayUnlock(SourceArray)
      else
        SafeArrayUnlock(SourceArray);
    end;
  end;
end;

function SafeArrayCopyData(SourceArray, TargetArray: PVarArray): HRESULT;
var
  LDim: Integer;
begin
  // check out the source array
  Result := SafeArrayValidate(SourceArray);
  if Result = VAR_OK then
  begin
    Result := SafeArrayLock(SourceArray);
    if Result = VAR_OK then
    try

      // check out the target array
      Result := SafeArrayValidate(TargetArray);
      if Result = VAR_OK then
      begin
        Result := SafeArrayLock(TargetArray);
        if Result = VAR_OK then
        try

          // now make sure the two arrays are similar
          if (SourceArray^.DimCount <> TargetArray^.DimCount) or
             (SourceArray^.Flags <> TargetArray^.Flags) or
             (SourceArray^.ElementSize <> TargetArray^.ElementSize) then
            Result := VAR_INVALIDARG
          else
          begin

            // now make sure the bounds match
            for LDim := 0 to SourceArray^.DimCount - 1 do
              if (SourceArray^.Bounds[LDim].LowBound <> TargetArray^.Bounds[LDim].LowBound) or
                 (SourceArray^.Bounds[LDim].ElementCount <> TargetArray^.Bounds[LDim].ElementCount) then
              begin
                Result := VAR_INVALIDARG;
                Break;
              end;

            // if all is still well then lets copy the data
            if Result = VAR_OK then
            begin

              // clear the destination
              Result := SafeArrayClearDataSpace(TargetArray);

              // if all is still swell then copy the data space
              if Result = VAR_OK then
                Result := SafeArrayCopyDataSpace(SourceArray, TargetArray);
            end;
          end;

        // put away our toys
        finally
          if Result = VAR_OK then
            Result := SafeArrayUnlock(TargetArray)
          else
            SafeArrayUnlock(TargetArray);
        end;
      end;
    finally
      if Result = VAR_OK then
        Result := SafeArrayUnlock(SourceArray)
      else
        SafeArrayUnlock(SourceArray);
    end;
  end;
end;

function SafeArrayGetLBound(VarArray: PVarArray; Dim: Integer; out LBound: Integer): HRESULT;
begin
  Result := SafeArrayValidate(VarArray);
  if Result = VAR_OK then
    if (Dim < 1) or (Dim > VarArray^.DimCount) then
      Result := VAR_BADINDEX
    else
      LBound := VarArray^.Bounds[Dim - 1].LowBound;
end;

function SafeArrayGetUBound(VarArray: PVarArray; Dim: Integer; out UBound: Integer): HRESULT;
begin
  Result := SafeArrayValidate(VarArray);
  if Result = VAR_OK then
    if (Dim < 1) or (Dim > VarArray^.DimCount) then
      Result := VAR_BADINDEX
    else
      UBound := VarArray^.Bounds[Dim - 1].LowBound +
                VarArray^.Bounds[Dim - 1].ElementCount - 1;
end;

function SafeArrayGetDim(VarArray: PVarArray): Integer;
begin
  Result := 0;
  if SafeArrayValidate(VarArray) = VAR_OK then
    Result := VarArray^.DimCount;
end;

function SafeArrayAccessData(VarArray: PVarArray; out Data: Pointer): HRESULT;
begin
  Result := SafeArrayLock(VarArray);
  if Result = VAR_OK then
    Data := VarArray^.Data;
end;

function SafeArrayUnaccessData(VarArray: PVarArray): HRESULT;
begin
  Result := SafeArrayUnlock(VarArray);
end;

function SafeArrayLock(VarArray: PVarArray): HRESULT;
begin
  Result := SafeArrayValidate(VarArray);
  if Result = VAR_OK then
    Inc(VarArray^.LockCount);
end;

function SafeArrayUnlock(VarArray: PVarArray): HRESULT;
begin
  Result := SafeArrayValidate(VarArray);
  if (Result = VAR_OK) and
     (VarArray^.LockCount > 0) then
    Dec(VarArray^.LockCount);
end;

function SafeArrayGetElement(VarArray: PVarArray; Indices: PVarArrayCoorArray;
  Data: Pointer): HRESULT;
var
  LAddress: Pointer;
begin
  Result := SafeArrayValidateAndCalculateAddress(VarArray, Indices, LAddress, True);
  if Result = VAR_OK then
  try //and
    try // again

      // data type please
      case SafeArrayElementStyle(VarArray) of
        esNormal:
          Move(LAddress^, Data^, VarArray^.ElementSize);
        esReference:
          IUnknown(PUnknown(Data)^) := IUnknown(PUnknown(LAddress)^);
        esOleStr:
          WideString(PPointer(Data)^) := Copy(PPWideChar(LAddress)^, 1, MaxInt);
        esVariant:
          VariantCopy(PVarData(Data)^, PVarData(LAddress)^);
      end;

    // oops!
    except

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

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

  // clean up please
  finally
    if Result = VAR_OK then
      Result := SafeArrayUnlock(VarArray)
    else
      SafeArrayUnlock(VarArray);
  end;
end;

function SafeArrayPutElement(VarArray: PVarArray; Indices: PVarArrayCoorArray;
  const Data: Pointer): HRESULT;
var
  LAddress: Pointer;
begin
  Result := SafeArrayValidateAndCalculateAddress(VarArray, Indices, LAddress, True);
  if Result = VAR_OK then
  try // and
    try // again

      // data type please
      case SafeArrayElementStyle(VarArray) of
        esNormal:
          Move(Data^, LAddress^, VarArray^.ElementSize);
        esReference:
          IUnknown(PUnknown(LAddress)^) := IUnknown(PUnknown(Data)^);
        esOleStr:
          WideString(PPointer(LAddress)^) := Copy(PWideChar(Data), 1, MaxInt);
        esVariant:
          VariantCopy(PVarData(LAddress)^, PVarData(Data)^);
      end;

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

    // catch all el