setofsuitvariant.pas

这是用DELPHI做改变windows XP的主题的源代码

unit SetOfSuitVariant;
{
This unit provides the implementation for a TSetOfSuits variant data type.

Guy Smith-Ferrier, (c) 2001 Capella Software Ltd.
}
interface

type
  TSuits = (Hearts, Clubs, Diamonds, Spades);
  TSetOfSuits = set of TSuits;

  function VarSetOfSuitsCreate(SetOfSuits: TSetOfSuits): Variant; overload;
  function VarSetOfSuitsCreate: Variant; overload;

implementation

uses
  Classes, Variants, Windows, TypInfo, Math, Dialogs, SysUtils;

type
  TSetOfSuitsData = class(TPersistent)
  private
    FIncludeJokers: boolean;
  public
    SetOfSuits: TSetOfSuits;
    SaveAsXML: boolean;
    constructor Create(aSetOfSuits: TSetOfSuits);
  published
    property IncludeJokers: boolean read FIncludeJokers write FIncludeJokers;
  end;

type
  TSetOfSuitsVarData = packed record
    VType: TVarType;
    Reserved1, Reserved2, Reserved3: Word;
    VSet: TSetOfSuitsData;
    Reserved4: DWord;
  end;

type
  {$IFDEF PUBLISHABLE}
  TSetOfSuitsVariantType = class(TPublishableVariantType)
  {$ELSE}
  TSetOfSuitsVariantType = class(TInvokeableVariantType)
  {$ENDIF}
  public
    procedure Cast(var Dest: TVarData; const Source: TVarData); override;
    procedure CastTo(var Dest: TVarData; const Source: TVarData;
      const AVarType: TVarType); override;
    procedure Clear(var V: TVarData); override;
    function IsClear(const V: TVarData): Boolean; override;
    procedure Copy(var Dest: TVarData; const Source: TVarData;
      const Indirect: Boolean); override;
    function LeftPromotion(const V: TVarData; const Operator: TVarOp;
      out RequiredVarType: TVarType): Boolean; override;
    function RightPromotion(const V: TVarData; const Operator: TVarOp;
      out RequiredVarType: TVarType): Boolean; override;
    procedure BinaryOp(var Left: TVarData; const Right: TVarData;
      const Operator: TVarOp); override;
    procedure UnaryOp(var Right: TVarData; const Operator: TVarOp); override;

    {$IFDEF SUPPORTSORDER}
    procedure Compare(const Left, Right: TVarData; var Relationship: TVarCompareResult); override;
    {$ELSE}
    function CompareOp(const Left, Right: TVarData; const Operator: Integer): Boolean; override;
    {$ENDIF}

    function DoFunction(var Dest: TVarData; const V: TVarData; const Name: string; const Arguments: TVarDataArray): Boolean; override;

    {$IFDEF PUBLISHABLE}
    function GetInstance(const V: TVarData): TObject; override;
    {$ELSE}
    function GetProperty(var Dest: TVarData; const V: TVarData; const Name: String): Boolean; override;
    function SetProperty(const V: TVarData; const Name: string; const Value: TVarData): Boolean; override;
    {$ENDIF}
  end;

var
  SetOfSuitsVariantType: TSetOfSuitsVariantType;

function VarSetOfSuitsCreate(SetOfSuits: TSetOfSuits): Variant; overload;
begin
  VarClear(Result);
  TSetOfSuitsVarData(Result).VType := SetOfSuitsVariantType.VarType;
  TSetOfSuitsVarData(Result).VSet  := TSetOfSuitsData.Create(SetOfSuits);
end;

function VarSetOfSuitsCreate: Variant; overload;
begin
  VarClear(Result);
  Result.VType := SetOfSuitsVariantType.VarType;
  TSetOfSuitsVarData(Result).VSet  := TSetOfSuitsData.Create([]);
end;

{ TSetOfSuitsData }

constructor TSetOfSuitsData.Create(aSetOfSuits: TSetOfSuits);
begin
  SaveAsXML:=False;
  SetOfSuits:=aSetOfSuits;
end;

{ TSetOfSuitsVariantType }

procedure TSetOfSuitsVariantType.Clear(var V: TVarData);
begin
  V.VType := varEmpty;
  FreeAndNil(TSetOfSuitsVarData(V).VSet);
end;

procedure TSetOfSuitsVariantType.Copy(var Dest: TVarData;
  const Source: TVarData; const Indirect: Boolean);
begin
  if Indirect and VarDataIsByRef(Source) then
    VarDataCopyNoInd(Dest, Source)
  else
  begin
    TSetOfSuitsVarData(Dest).VType:=VarType;
    TSetOfSuitsVarData(Dest).VSet :=TSetOfSuitsData.Create(TSetOfSuitsVarData(Source).VSet.SetOfSuits);
  end;
end;

function GetToken(var strSource: string; var strToken: string): boolean;
var
  intCommaPos: integer;
  intSpacePos: integer;
  intPos     : integer;
begin
  if strSource = '' then
    Result:=False
  else
  begin
    Result:=True;
    intCommaPos:=Pos(',', strSource);
    intSpacePos:=Pos(' ', strSource);
    if (intCommaPos > 0) and (intSpacePos > 0) then
      intPos:=Min(intCommaPos, intSpacePos)
    else if intCommaPos > 0 then
      intPos:=intCommaPos
    else if intSpacePos > 0 then
      intPos:=intSpacePos
    else
      intPos:=Length(strSource) + 1;

    strToken:=Copy(strSource, 1, intPos - 1);
    strSource:=TrimLeft(Copy(strSource, intPos + 1, Length(strSource)));
  end;
end;

function StrToSetOfSuits(strSuits: string): TSetOfSuits;
var
  strToken: string;
  intSuit: integer;
begin
  Result:=[];
  while GetToken(strSuits, strToken) do
  begin
    intSuit:=GetENumValue(TypeInfo(TSuits), strToken);
    if intSuit >= Ord(Low(TSuits)) then
      Result:=Result+[TSuits(intSuit)];
  end;
end;

procedure TSetOfSuitsVariantType.Cast(var Dest: TVarData; const Source: TVarData);
var
  LSource, LTemp: TVarData;
begin
  VarDataInit(LSource);
  try
    VarDataCopyNoInd(LSource, Source);
    if VarDataIsStr(LSource) then
      TSetOfSuitsVarData(Dest).VSet := TSetOfSuitsData.Create(StrToSetOfSuits(VarDataToStr(LSource)))
    else
    begin
      VarDataInit(LTemp);
      try
        VarDataCastTo(LTemp, LSource, varOleStr);
        TSetOfSuitsVarData(Dest).VSet := TSetOfSuitsData.Create(StrToSetOfSuits(LTemp.VOleStr));
      finally
        VarDataClear(LTemp);
      end;
    end;
    Dest.VType := VarType;
  finally
    VarDataClear(LSource);
  end;
end;

function SetOfSuitsToStr(SetOfSuits: TSetOfSuits): string;
var
  Suit: TSuits;
begin
  Result:='';
  for Suit:=Low(TSuits) to High(TSuits) do
    if Suit in SetOfSuits then
      Result:=Result+GetENumName(TypeInfo(TSuits), Ord(Suit))+', ';

  if Result <> '' then
    Result:=Copy(Result, 1, Length(Result) - 2);
end;

function SetOfSuitsToInt(SetOfSuits: TSetOfSuits): integer;
// this function represents a set as an integer
// if the type is (Hearts, Clubs, Diamonds, Spades) then these have the
// respective ordinal values (0, 1, 2, 3) so a set of [Hearts, Diamonds] would
// contain the values 0 and 2. However, we cannot simply add these numbers together
// because [Clubs, Diamonds] has the same numeric value as [Spades]. So each
// number is converted to its power so the values become (1, 2, 4, 8) and an
// empty set is 0.
var
  Suit: TSuits;
begin
  Result:=0;
  for Suit:=Low(TSuits) to High(TSuits) do
    if Suit in SetOfSuits then
      Result:=Result+Trunc(Power(2, Ord(Suit)));
end;

function SetOfSuitsNegate(SetOfSuits: TSetOfSuits): TSetOfSuits;
var
  Suit: TSuits;
begin
  Result:=[];
  for Suit:=Low(TSuits) to High(TSuits) do
    if not (Suit in SetOfSuits) then
      Include(Result, Suit);
end;

procedure TSetOfSuitsVariantType.CastTo(var Dest: TVarData; const Source: TVarData;
  const AVarType: TVarType);
var
  LTemp: TVarData;
  strSuits: string;
begin
  if Source.VType = VarType then
    case AVarType of
    varOleStr:
      VarDataFromOleStr(Dest, SetOfSuitsToStr(TSetOfSuitsVarData(Source).VSet.SetOfSuits));
    varString:
      VarDataFromStr(Dest, SetOfSuitsToStr(TSetOfSuitsVarData(Source).VSet.SetOfSuits));
    varInteger:
      Dest.VInteger:=SetOfSuitsToInt(TSetOfSuitsVarData(Source).VSet.SetOfSuits);
    else
      VarDataInit(LTemp);
      try
        LTemp.VType := varOleStr;
        strSuits:=SetOfSuitsToStr(TSetOfSuitsVarData(Source).VSet.SetOfSuits);
        if strSuits  = '' then
          LTemp.VOleStr:=''
        else
          LTemp.VOleStr := PWideChar(strSuits[1]);
        VarDataCastTo(Dest, LTemp, AVarType);
      finally
        VarDataClear(LTemp);
      end;
    end
  else
    inherited;
end;

function TSetOfSuitsVariantType.LeftPromotion(const V: TVarData;
  const Operator: TVarOp; out RequiredVarType: TVarType): Boolean;
begin
  RequiredVarType := V.VType;
  // accept it if the left hand operation is an integer, string or another SetOfSuits
  Result:=(V.VType = varInteger) or (V.VType = varString) or (V.VType = VarType);
end;

function TSetOfSuitsVariantType.RightPromotion(const V: TVarData;
  const Operator: TVarOp; out RequiredVarType: TVarType): Boolean;
begin
  RequiredVarType := V.VType;
  // accept it if the right hand operation is an integer, string or another SetOfSuits
  Result:=(V.VType = varInteger) or (V.VType = varString) or (V.VType = VarType);
end;

procedure TSetOfSuitsVariantType.BinaryOp(var Left: TVarData; const Right: TVarData; const Operator: TVarOp);
begin
  case Operator of
  opAdd:
    if Left.VType = varString then
      // the left operand is a string and the right operand is a SetOfSuits variant
      String(Left.VString):=String(Left.VString) + SetOfSuitsToStr(TSetOfSuitsVarData(Right).VSet.SetOfSuits)
    else if (Left.VType = VarType) and (Right.VType = varString) then
      // the left operand is a SetOfSuits variant and the right operand is a string
      TSetOfSuitsVarData(Left).VSet.SetOfSuits := TSetOfSuitsVarData(Left).VSet.SetOfSuits +
      StrToSetOfSuits(String(Right.VString))
    else if (Left.VType = VarType) and (Right.VType = varInteger) then
      // the left operand is a SetOfSuits variant and the right operand is an integer
      TSetOfSuitsVarData(Left).VSet.SetOfSuits := TSetOfSuitsVarData(Left).VSet.SetOfSuits +
      [TSuits(Right.VInteger)]
    else if (Left.VType = VarType) and (Right.VType = VarType) then
      // the left operand is a SetOfSuits variant and the right operand is also a SetOfSuits variant
      TSetOfSuitsVarData(Left).VSet.SetOfSuits := TSetOfSuitsVarData(Left).VSet.SetOfSuits +
      TSetOfSuitsVarData(Right).VSet.SetOfSuits
    else
      RaiseInvalidOp;
  else
    RaiseInvalidOp;
  end;
end;


function TSetOfSuitsVariantType.IsClear(const V: TVarData): Boolean;
begin
  Result := (TSetOfSuitsVarData(V).VSet = nil) or
  (TSetOfSuitsVarData(V).VSet.SetOfSuits = []);
end;

procedure TSetOfSuitsVariantType.UnaryOp(var Right: TVarData;
  const Operator: TVarOp);
begin
  if Right.VType = VarType then
    TSetOfSuitsVarData(Right).VSet.SetOfSuits :=
    SetOfSuitsNegate(TSetOfSuitsVarData(Right).VSet.SetOfSuits)
  else
    RaiseInvalidOp;
end;

{$IFDEF SUPPORTSORDER}

procedure TSetOfSuitsVariantType.Compare(const Left, Right: TVarData;
  var Relationship: TVarCompareResult);
begin
  if (Left.VType = VarType) and (Right.VType = VarType) then
  begin
    if TSetOfSuitsVarData(Left ).VSet.SetOfSuits =
       TSetOfSuitsVarData(Right).VSet.SetOfSuits then
      Relationship:=crEqual
    else if SetOfSuitsToInt(TSetOfSuitsVarData(Left ).VSet.SetOfSuits) <
            SetOfSuitsToInt(TSetOfSuitsVarData(Right).VSet.SetOfSuits) then
      // this is a bit questionnable but then again the idea of a set
      // being less than another set is a questionnable idea in its own right
      Relationship:=crLessThan
    else
      Relationship:=crGreaterThan;
  end
  else
    RaiseInvalidOp;
end;

{$ELSE}

function TSetOfSuitsVariantType.CompareOp(const Left, Right: TVarData;
  const Operator: Integer): Boolean;
begin
  Result := False;
  if (Left.VType = VarType) and (Right.VType = VarType) then
    case Operator of
      opCmpEQ:
        Result := (
        TSetOfSuitsVarData(Left ).VSet.SetOfSuits =
        TSetOfSuitsVarData(Right).VSet.SetOfSuits);
      opCmpNE:
        Result := not (
        TSetOfSuitsVarData(Left ).VSet.SetOfSuits =
        TSetOfSuitsVarData(Right).VSet.SetOfSuits);
    else
      RaiseInvalidOp;
    end
  else
    RaiseInvalidOp;
end;

{$ENDIF}

function SetOfSuitsSaveToFile(SetOfSuits: TSetOfSuits; strFileName: string): boolean;
var
  stl: TStringList;
  Suit: TSuits;
begin
  stl:=TStringList.Create;
  try
    for Suit:=Low(TSuits) to High(TSuits) do
      if Suit in SetOfSuits then
        stl.Add(GetENumName(TypeInfo(TSuits), Ord(Suit)));

    stl.SaveToFile(strFileName);
    Result:=True;
  finally
    stl.Free;
  end;
end;

function TSetOfSuitsVariantType.DoFunction(var Dest: TVarData;
  const V: TVarData; const Name: string;
  const Arguments: TVarDataArray): Boolean;
var
  strFileName: string;
begin
  Result:=False;
  if Name = 'SAVETOFILE' then
  begin
    if Length(Arguments) > 0 then
      strFileName:=VarDataToStr(Arguments[0])
    else
      strFileName:='SetOfSuits.TXT';

    Result:=SetOfSuitsSaveToFile(TSetOfSuitsVarData(V).VSet.SetOfSuits, strFileName);
  end;
end;

{$IFDEF PUBLISHABLE}

function TSetOfSuitsVariantType.GetInstance(const V: TVarData): TObject;
begin
  Result := TSetOfSuitsVarData(V).VSet;
end;

{$ELSE}
function TSetOfSuitsVariantType.GetProperty(var Dest: TVarData; const V: TVarData; const Name: String): Boolean;
begin
  Result := True;
  if Name = 'SAVEASXML' then
    Variant(Dest) := TSetOfSuitsVarData(V).VSet.SaveAsXML
  else
    Result := False;
end;

function TSetOfSuitsVariantType.SetProperty(const V: TVarData;
  const Name: string; const Value: TVarData): Boolean;
begin
  Result := True;
  if Name = 'SAVEASXML' then
    TSetOfSuitsVarData(V).VSet.SaveAsXML := Variant(Value)
  else
    Result := False;
end;
{$ENDIF}

initialization
  SetOfSuitsVariantType := TSetOfSuitsVariantType.Create;

finalization
  SetOfSuitsVariantType.Free;

end.