source/COM/_StUtil.pas

(* ***** BEGIN LICENSE BLOCK *****
 * Version: MPL 1.1
 *
 * The contents of this file are subject to the Mozilla Public License Version
 * 1.1 (the "License"); you may not use this file except in compliance with
 * the License. You may obtain a copy of the License at
 * http://www.mozilla.org/MPL/
 *
 * Software distributed under the License is distributed on an "AS IS" basis,
 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
 * for the specific language governing rights and limitations under the
 * License.
 *
 * The Original Code is TurboPower SysTools
 *
 * The Initial Developer of the Original Code is
 * TurboPower Software
 *
 * Portions created by the Initial Developer are Copyright (C) 1996-2002
 * the Initial Developer. All Rights Reserved.
 *
 * Contributor(s):
 *
 * ***** END LICENSE BLOCK ***** *)

{*********************************************************}
{*                   _STUTIL.PAS 3.00                    *}
{*********************************************************}

{$I STDEFINE.INC}
{$I STCOMDEF.INC}
unit _StUtil;

interface

uses
  Windows, ComObj, ActiveX, AxCtrls, Classes, SysTools_TLB, StdVcl;

type
  IEnumVariant = interface(IUnknown)
    ['{00020404-0000-0000-C000-000000000046}']
    function Next(celt: Longint; out elt; pceltFetched: PLongint): HResult; stdcall;
    function Skip(celt: Longint): HResult; stdcall;
    function Reset: HResult; stdcall;
    function Clone(out Enum: IEnumVariant): HResult; stdcall;
  end;

  TStStringList = class(TAutoObject, IConnectionPointContainer, IEnumVariant, IStStringList)
   private   { Private declarations }
    FConnectionPoints: TConnectionPoints;
    FConnectionPoint : TConnectionPoint;
    FSinkList        : TList;
    FEvents          : IStStringListEvents;

    FStringList      : Classes.TStringList;
    FExternalList    : Boolean;
    FEnumPos         : Integer;
    FIsLicensed      : Boolean;

    function GetStringList: TStringList;
    procedure SetStringList(Value: TStringList);

    procedure _OnChange(Sender: TObject);
    procedure _OnChanging(Sender: TObject);
   public    { Public declarations }
    constructor Create(AList: TStringList); reintroduce; overload;
    procedure Initialize; override;
    destructor Destroy; override;

    property StringList : TStringList read GetStringList write SetStringList;
   protected { Protected declarations }
    { IConnectionPointContainer }
    property ConnectionPoints: TConnectionPoints read FConnectionPoints
      implements IConnectionPointContainer;
    procedure EventSinkChanged(const EventSink: IUnknown); override;

    { IEnumVariant }
    function Next(celt: Longint; out elt; pceltFetched: PLongint): HResult; stdcall;
    function Skip(celt: Longint): HResult; stdcall;
    function Reset: HResult; stdcall;
    function Clone(out Enum: IEnumVariant): HResult; stdcall;

    { IStStringList - Properties }
    function Get__NewEnum: IUnknown; safecall;
    function Get_CommaText: WideString; safecall;
    function Get_Count: Integer; safecall;
    function Get_Duplicates: Integer; safecall;
    function Get_Item(Index: Integer): WideString; safecall;
    function Get_Names(Index: Integer): WideString; safecall;
    function Get_Sorted: WordBool; safecall;
    function Get_Stream: OleVariant; safecall;
    function Get_Strings(Index: Integer): WideString; safecall;
    function Get_Text: WideString; safecall;
    function Get_Values(const Name: WideString): WideString; safecall;

    procedure Set_CommaText(const Value: WideString); safecall;
    procedure Set_Duplicates(Value: Integer); safecall;
    procedure Set_Item(Index: Integer; const Value: WideString); safecall;
    procedure Set_Sorted(Value: WordBool); safecall;
    procedure Set_Stream(Value: OleVariant); safecall;
    procedure Set_Strings(Index: Integer; const Value: WideString); safecall;
    procedure Set_Text(const Value: WideString); safecall;
    procedure Set_Values(const Name, Value: WideString); safecall;

    { IStStringList - Methods }
    function Add(const S: WideString): Integer; safecall;
    procedure Append(const S: WideString); safecall;
    procedure Clear; safecall;
    procedure Delete(Index: Integer); safecall;
    function Equals(const Strings: IStStringList): WordBool; safecall;
    procedure Exchange(Index1, Index2: Integer); safecall;
    function Find(const S: WideString; var Index: Integer): WordBool; safecall;
    function IndexOf(const S: WideString): Integer; safecall;
    function IndexOfName(const Name: WideString): Integer; safecall;
    procedure Insert(Index: Integer; const S: WideString); safecall;
    procedure LoadFromFile(const FileName: WideString); safecall;
    procedure Move(CurIndex, NewIndex: Integer); safecall;
    procedure SaveToFile(const FileName: WideString); safecall;
    procedure Sort; safecall;
    function License(const Key: WideString): WordBool; safecall;
  end;

  function StStreamToOleVariant(Value: TStream): OleVariant;
  function StOleVariantToStream(Value: OleVariant; NewStream: Boolean): TStream;

  function StTextToOleVariant(Value: string): OleVariant;
  function StOleVariantToText(Value: OleVariant): string;


implementation

uses ComServ {$IFDEF LICENSE}, StComLic {$ENDIF};

{ Converts a TStream class to an OleVariant [array of byte] }
function StStreamToOleVariant(Value: TStream): OleVariant;
var
  Info : array of Byte;
begin
  Value.Position := 0;
  SetLength(Info, Value.Size);
  Value.Read(Info[0], Value.Size);
  Result := Info;
end;

{$WARNINGS OFF}
{ Converts an OleVariant [array of byte] to a TStream class }
function StOleVariantToStream(Value: OleVariant; NewStream: Boolean): TStream;
var
  Info : array of Byte;
begin
  if NewStream then
    Result := TMemoryStream.Create;
  Info := Value;
  Result.Write(Info[0], Length(Info));
  Result.Position := 0;
end;
{$WARNINGS ON}

{ Converts a text string to an OleVariant [array of byte] }
function StTextToOleVariant(Value: string): OleVariant;
var
  SL   : TStringList;
  MS   : TStream;
begin
  SL := nil;
  MS := nil;
  try
    SL := TStringList.Create;
    MS := TMemoryStream.Create;

    SL.Text := Value;
    SL.SaveToStream(MS);

    Result := StStreamToOleVariant(MS);
  finally
    MS.Free;
    SL.Free;
  end;
end;

{ Converts an OleVariant [array of byte] to a text string }
function StOleVariantToText(Value: OleVariant): string;
var
  SL : TStringList;
  MS : TStream;
begin
  SL := nil;
  MS := nil;
  try
    SL := TStringList.Create;
    MS := StOleVariantToStream(Value, True);

    SL.LoadFromStream(MS);
    Result := SL.Text;
  finally
    MS.Free;
    SL.Free;
  end;
end;

{ ******** TStStringList Interface - IConnectionPointContainer Methods ******** }
procedure TStStringList.EventSinkChanged(const EventSink: IUnknown);
begin
  FEvents := EventSink as IStStringListEvents;
  if FConnectionPoint <> nil then
     FSinkList := FConnectionPoint.SinkList;
end;

{ ******** TStStringList Interface - IEnumVariant Methods ******** }
function TStStringList.Next(celt: Longint; out elt; pceltFetched: PLongint): HResult;
var
  V : OleVariant;
  I : Integer;
begin
  Result := S_FALSE;
  try
    if pceltFetched <> nil then
      pceltFetched^ := 0;
    for I := 0 to celt - 1 do begin
      if FEnumPos >= FStringList.Count then begin
        FEnumPos := 0;
        Exit;
      end;
      V := Get_Item(FEnumPos);
      TVariantArgList(elt)[I] := TVariantArg(V);

      // Prevent COM garbage collection
      TVarData(V).VType := varEmpty;
      TVarData(V).VInteger := 0;

      Inc(FEnumPos);
      if pceltFetched <> nil then
        Inc(pceltFetched^);
    end;
  except
  end;
  if (pceltFetched = nil) or ((pceltFetched <> nil) and (pceltFetched^ = celt)) then
   Result := S_OK;
end;

function TStStringList.Skip(celt: Longint): HResult;
begin
  Inc(FEnumPos, celt);
  Result := S_OK;
end;

function TStStringList.Reset: HResult;
begin
  FEnumPos := 0;
  Result := S_OK;
end;

function TStStringList.Clone(out Enum: IEnumVariant): HResult;
begin
  Enum := nil;
  Result := S_OK;
  try
    Enum := Self.Create;
    TStStringList(Enum).FStringList.Assign(FStringList);
  except
    Result := E_OUTOFMEMORY;
  end;
end;

{ ********** TStStringList Interface ***************************************************}
constructor TStStringList.Create(AList: TStringList);
begin
  FExternalList := True;
  FStringList   := AList;
  inherited Create;
end;

procedure TStStringList.Initialize;
begin
  inherited Initialize;
  FConnectionPoints := TConnectionPoints.Create(Self);
  if AutoFactory.EventTypeInfo <> nil then
    FConnectionPoint := FConnectionPoints.CreateConnectionPoint(
      AutoFactory.EventIID, ckSingle, EventConnect)
  else FConnectionPoint := nil;

  {$IFDEF LICENSE}
  FIsLicensed := False;
  {$ELSE}
  FIsLicensed := True;
  {$ENDIF}

  if not FExternalList then
    FStringList := TStringList.Create;

  FEnumPos    := 0;

  FStringList.OnChange := _OnChange;
  FStringList.OnChanging := _OnChanging;
end;

destructor TStStringList.Destroy;
begin
  if (FStringList <> nil) and (not FExternalList) then
    FStringList.Free;

  inherited Destroy;
end;

function TStStringList.GetStringList: TStringList;
begin
  Result := FStringList;
end;

procedure TStStringList.SetStringList(Value: TStringList);
begin
  FStringList.Assign(Value);
end;

{ ********** TStStringList Events *********************************************************}
procedure TStStringList._OnChange(Sender: TObject);
begin
  if Assigned(FEvents) then
    FEvents.OnChange;
end;

procedure TStStringList._OnChanging(Sender: TObject);
begin
  if Assigned(FEvents) then
    FEvents.OnChanging;
end;

{ ********** TStStringList Properties *** (Get) *******************************************}
function TStStringList.Get__NewEnum: IUnknown;
begin
  Result := Self;
end;

function TStStringList.Get_Item(Index: Integer): WideString;
begin
  {$IFDEF LICENSE}
   if (not FIsLicensed) or (not COMHasBeenLicensed) then
     OleError(CLASS_E_NOTLICENSED);
  {$ENDIF}
  Result := FStringList.Strings[Index];
end;

function TStStringList.Get_CommaText: WideString;
begin
  {$IFDEF LICENSE}
   if (not FIsLicensed) or (not COMHasBeenLicensed) then
     OleError(CLASS_E_NOTLICENSED);
  {$ENDIF}
  Result := FStringList.CommaText;
end;

function TStStringList.Get_Count: Integer;
begin
  {$IFDEF LICENSE}
   if (not FIsLicensed) or (not COMHasBeenLicensed) then
     OleError(CLASS_E_NOTLICENSED);
  {$ENDIF}
  Result := FStringList.Count;
end;

function TStStringList.Get_Duplicates: Integer;
begin
  {$IFDEF LICENSE}
   if (not FIsLicensed) or (not COMHasBeenLicensed) then
     OleError(CLASS_E_NOTLICENSED);
  {$ENDIF}
  Result := Ord(FStringList.Duplicates);
end;

function TStStringList.Get_Names(Index: Integer): WideString;
begin
  {$IFDEF LICENSE}
   if (not FIsLicensed) or (not COMHasBeenLicensed) then
     OleError(CLASS_E_NOTLICENSED);
  {$ENDIF}
  Result := FStringList.Names[Index];
end;

function TStStringList.Get_Sorted: WordBool;
begin
  {$IFDEF LICENSE}
   if (not FIsLicensed) or (not COMHasBeenLicensed) then
     OleError(CLASS_E_NOTLICENSED);
  {$ENDIF}
  Result := FStringList.Sorted;
end;

function TStStringList.Get_Stream: OleVariant;
begin
  {$IFDEF LICENSE}
   if (not FIsLicensed) or (not COMHasBeenLicensed) then
     OleError(CLASS_E_NOTLICENSED);
  {$ENDIF}
  Result := StTextToOleVariant(FStringList.Text);
end;

function TStStringList.Get_Strings(Index: Integer): WideString;
begin
  {$IFDEF LICENSE}
   if (not FIsLicensed) or (not COMHasBeenLicensed) then
     OleError(CLASS_E_NOTLICENSED);
  {$ENDIF}
  Result := FStringList.Strings[Index];
end;

function TStStringList.Get_Text: WideString;
begin
  {$IFDEF LICENSE}
   if (not FIsLicensed) or (not COMHasBeenLicensed) then
     OleError(CLASS_E_NOTLICENSED);
  {$ENDIF}
  Result := FStringList.Text;
end;

function TStStringList.Get_Values(const Name: WideString): WideString;
begin
  {$IFDEF LICENSE}
   if (not FIsLicensed) or (not COMHasBeenLicensed) then
     OleError(CLASS_E_NOTLICENSED);
  {$ENDIF}
  Result := FStringList.Values[Name];
end;

{ ********** TStStringList Properties *** (Set) *******************************************}
procedure TStStringList.Set_CommaText(const Value: WideString);
begin
  {$IFDEF LICENSE}
   if (not FIsLicensed) or (not COMHasBeenLicensed) then
     OleError(CLASS_E_NOTLICENSED);
  {$ENDIF}
  FStringList.CommaText := Value;
end;

procedure TStStringList.Set_Duplicates(Value: Integer);
begin
  {$IFDEF LICENSE}
   if (not FIsLicensed) or (not COMHasBeenLicensed) then
     OleError(CLASS_E_NOTLICENSED);
  {$ENDIF}
  FStringList.Duplicates := Classes.TDuplicates(Value);
end;

procedure TStStringList.Set_Item(Index: Integer; const Value: WideString);
begin
  {$IFDEF LICENSE}
   if (not FIsLicensed) or (not COMHasBeenLicensed) then
     OleError(CLASS_E_NOTLICENSED);
  {$ENDIF}
  FStringList.Strings[Index] := Value;
end;

procedure TStStringList.Set_Sorted(Value: WordBool);
begin
  {$IFDEF LICENSE}
   if (not FIsLicensed) or (not COMHasBeenLicensed) then
     OleError(CLASS_E_NOTLICENSED);
  {$ENDIF}
  FStringList.Sorted := Value;
end;

procedure TStStringList.Set_Stream(Value: OleVariant);
begin
  {$IFDEF LICENSE}
   if (not FIsLicensed) or (not COMHasBeenLicensed) then
     OleError(CLASS_E_NOTLICENSED);
  {$ENDIF}
  FStringList.Text := StOleVariantToText(Value);
end;

procedure TStStringList.Set_Strings(Index: Integer;
  const Value: WideString);
begin
  {$IFDEF LICENSE}
   if (not FIsLicensed) or (not COMHasBeenLicensed) then
     OleError(CLASS_E_NOTLICENSED);
  {$ENDIF}
  FStringList.Strings[Index] := Value;
end;

procedure TStStringList.Set_Text(const Value: WideString);
begin
  {$IFDEF LICENSE}
   if (not FIsLicensed) or (not COMHasBeenLicensed) then
     OleError(CLASS_E_NOTLICENSED);
  {$ENDIF}
  FStringList.Text := Value;
end;

procedure TStStringList.Set_Values(const Name, Value: WideString);
begin
  {$IFDEF LICENSE}
   if (not FIsLicensed) or (not COMHasBeenLicensed) then
     OleError(CLASS_E_NOTLICENSED);
  {$ENDIF}
  FStringList.Values[Name] := Value;
end;

{ ********** TStStringList Methods *****************************************************}
function TStStringList.Add(const S: WideString): Integer;
begin
  {$IFDEF LICENSE}
   if (not FIsLicensed) or (not COMHasBeenLicensed) then
     OleError(CLASS_E_NOTLICENSED);
  {$ENDIF}
  FStringList.Add(S);
end;

procedure TStStringList.Append(const S: WideString);
begin
  {$IFDEF LICENSE}
   if (not FIsLicensed) or (not COMHasBeenLicensed) then
     OleError(CLASS_E_NOTLICENSED);
  {$ENDIF}
  FStringList.Append(S);
end;

procedure TStStringList.Clear;
begin
  {$IFDEF LICENSE}
   if (not FIsLicensed) or (not COMHasBeenLicensed) then
     OleError(CLASS_E_NOTLICENSED);
  {$ENDIF}
  FStringList.Clear;
end;

procedure TStStringList.Delete(Index: Integer);
begin
  {$IFDEF LICENSE}
   if (not FIsLicensed) or (not COMHasBeenLicensed) then
     OleError(CLASS_E_NOTLICENSED);
  {$ENDIF}
  FStringList.Delete(Index);
end;

function TStStringList.Equals(const Strings: IStStringList): WordBool;
begin
  {$IFDEF LICENSE}
   if (not FIsLicensed) or (not COMHasBeenLicensed) then
     OleError(CLASS_E_NOTLICENSED);
  {$ENDIF}
  Result := FStringList.Equals(TStStringList(Strings).FStringList);
end;

procedure TStStringList.Exchange(Index1, Index2: Integer);
begin
  {$IFDEF LICENSE}
   if (not FIsLicensed) or (not COMHasBeenLicensed) then
     OleError(CLASS_E_NOTLICENSED);
  {$ENDIF}
  FStringList.Exchange(Index1, Index2);
end;

function TStStringList.Find(const S: WideString;
  var Index: Integer): WordBool;
begin
  {$IFDEF LICENSE}
   if (not FIsLicensed) or (not COMHasBeenLicensed) then
     OleError(CLASS_E_NOTLICENSED);
  {$ENDIF}
  Result := FStringList.Find(S, Index);
end;

function TStStringList.IndexOf(const S: WideString): Integer;
begin
  {$IFDEF LICENSE}
   if (not FIsLicensed) or (not COMHasBeenLicensed) then
     OleError(CLASS_E_NOTLICENSED);
  {$ENDIF}
  Result := FStringList.IndexOf(S);
end;

function TStStringList.IndexOfName(const Name: WideString): Integer;
begin
  {$IFDEF LICENSE}
   if (not FIsLicensed) or (not COMHasBeenLicensed) then
     OleError(CLASS_E_NOTLICENSED);
  {$ENDIF}
  Result := FStringList.IndexOfName(Name);
end;

procedure TStStringList.Insert(Index: Integer; const S: WideString);
begin
  {$IFDEF LICENSE}
   if (not FIsLicensed) or (not COMHasBeenLicensed) then
     OleError(CLASS_E_NOTLICENSED);
  {$ENDIF}
  FStringList.Insert(Index, S);
end;

procedure TStStringList.LoadFromFile(const FileName: WideString);
begin
  {$IFDEF LICENSE}
   if (not FIsLicensed) or (not COMHasBeenLicensed) then
     OleError(CLASS_E_NOTLICENSED);
  {$ENDIF}
  FStringList.LoadFromFile(FileName);
end;

procedure TStStringList.Move(CurIndex, NewIndex: Integer);
begin
  {$IFDEF LICENSE}
   if (not FIsLicensed) or (not COMHasBeenLicensed) then
     OleError(CLASS_E_NOTLICENSED);
  {$ENDIF}
  FStringList.Move(CurIndex, NewIndex);
end;

procedure TStStringList.SaveToFile(const FileName: WideString);
begin
  {$IFDEF LICENSE}
   if (not FIsLicensed) or (not COMHasBeenLicensed) then
     OleError(CLASS_E_NOTLICENSED);
  {$ENDIF}
  FStringList.SaveToFile(FileName);
end;

procedure TStStringList.Sort;
begin
  {$IFDEF LICENSE}
   if (not FIsLicensed) or (not COMHasBeenLicensed) then
     OleError(CLASS_E_NOTLICENSED);
  {$ENDIF}
  FStringList.Sort;
end;


function TStStringList.License(const Key: WideString): WordBool;
begin
  {$IFDEF LICENSE}
  Result := COMIsValidKey(Key);
  {$ELSE}
  Result := True;
  {$ENDIF}
  FIsLicensed := Result;
end;

initialization
  TAutoObjectFactory.Create(ComServer, TStStringList, Class_StStringList, ciMultiInstance, tmBoth);
end.
1	torben	2671	(* *** BEGIN LICENSE BLOCK ***
2			* Version: MPL 1.1
3			*
4			* The contents of this file are subject to the Mozilla Public License Version
5			* 1.1 (the "License"); you may not use this file except in compliance with
6			* the License. You may obtain a copy of the License at
7			* http://www.mozilla.org/MPL/
8			*
9			* Software distributed under the License is distributed on an "AS IS" basis,
10			* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
11			* for the specific language governing rights and limitations under the
12			* License.
13			*
14			* The Original Code is TurboPower SysTools
15			*
16			* The Initial Developer of the Original Code is
17			* TurboPower Software
18			*
19			* Portions created by the Initial Developer are Copyright (C) 1996-2002
20			* the Initial Developer. All Rights Reserved.
21			*
22			* Contributor(s):
23			*
24			* *** END LICENSE BLOCK *** *)
25
26			{*********************************************************}
27			{* _STUTIL.PAS 3.00 *}
28			{*********************************************************}
29
30			{$I STDEFINE.INC}
31			{$I STCOMDEF.INC}
32			unit _StUtil;
33
34			interface
35
36			uses
37			Windows, ComObj, ActiveX, AxCtrls, Classes, SysTools_TLB, StdVcl;
38
39			type
40			IEnumVariant = interface(IUnknown)
41			['{00020404-0000-0000-C000-000000000046}']
42			function Next(celt: Longint; out elt; pceltFetched: PLongint): HResult; stdcall;
43			function Skip(celt: Longint): HResult; stdcall;
44			function Reset: HResult; stdcall;
45			function Clone(out Enum: IEnumVariant): HResult; stdcall;
46			end;
47
48			TStStringList = class(TAutoObject, IConnectionPointContainer, IEnumVariant, IStStringList)
49			private { Private declarations }
50			FConnectionPoints: TConnectionPoints;
51			FConnectionPoint : TConnectionPoint;
52			FSinkList : TList;
53			FEvents : IStStringListEvents;
54
55			FStringList : Classes.TStringList;
56			FExternalList : Boolean;
57			FEnumPos : Integer;
58			FIsLicensed : Boolean;
59
60			function GetStringList: TStringList;
61			procedure SetStringList(Value: TStringList);
62
63			procedure _OnChange(Sender: TObject);
64			procedure _OnChanging(Sender: TObject);
65			public { Public declarations }
66			constructor Create(AList: TStringList); reintroduce; overload;
67			procedure Initialize; override;
68			destructor Destroy; override;
69
70			property StringList : TStringList read GetStringList write SetStringList;
71			protected { Protected declarations }
72			{ IConnectionPointContainer }
73			property ConnectionPoints: TConnectionPoints read FConnectionPoints
74			implements IConnectionPointContainer;
75			procedure EventSinkChanged(const EventSink: IUnknown); override;
76
77			{ IEnumVariant }
78			function Next(celt: Longint; out elt; pceltFetched: PLongint): HResult; stdcall;
79			function Skip(celt: Longint): HResult; stdcall;
80			function Reset: HResult; stdcall;
81			function Clone(out Enum: IEnumVariant): HResult; stdcall;
82
83			{ IStStringList - Properties }
84			function Get__NewEnum: IUnknown; safecall;
85			function Get_CommaText: WideString; safecall;
86			function Get_Count: Integer; safecall;
87			function Get_Duplicates: Integer; safecall;
88			function Get_Item(Index: Integer): WideString; safecall;
89			function Get_Names(Index: Integer): WideString; safecall;
90			function Get_Sorted: WordBool; safecall;
91			function Get_Stream: OleVariant; safecall;
92			function Get_Strings(Index: Integer): WideString; safecall;
93			function Get_Text: WideString; safecall;
94			function Get_Values(const Name: WideString): WideString; safecall;
95
96			procedure Set_CommaText(const Value: WideString); safecall;
97			procedure Set_Duplicates(Value: Integer); safecall;
98			procedure Set_Item(Index: Integer; const Value: WideString); safecall;
99			procedure Set_Sorted(Value: WordBool); safecall;
100			procedure Set_Stream(Value: OleVariant); safecall;
101			procedure Set_Strings(Index: Integer; const Value: WideString); safecall;
102			procedure Set_Text(const Value: WideString); safecall;
103			procedure Set_Values(const Name, Value: WideString); safecall;
104
105			{ IStStringList - Methods }
106			function Add(const S: WideString): Integer; safecall;
107			procedure Append(const S: WideString); safecall;
108			procedure Clear; safecall;
109			procedure Delete(Index: Integer); safecall;
110			function Equals(const Strings: IStStringList): WordBool; safecall;
111			procedure Exchange(Index1, Index2: Integer); safecall;
112			function Find(const S: WideString; var Index: Integer): WordBool; safecall;
113			function IndexOf(const S: WideString): Integer; safecall;
114			function IndexOfName(const Name: WideString): Integer; safecall;
115			procedure Insert(Index: Integer; const S: WideString); safecall;
116			procedure LoadFromFile(const FileName: WideString); safecall;
117			procedure Move(CurIndex, NewIndex: Integer); safecall;
118			procedure SaveToFile(const FileName: WideString); safecall;
119			procedure Sort; safecall;
120			function License(const Key: WideString): WordBool; safecall;
121			end;
122
123			function StStreamToOleVariant(Value: TStream): OleVariant;
124			function StOleVariantToStream(Value: OleVariant; NewStream: Boolean): TStream;
125
126			function StTextToOleVariant(Value: string): OleVariant;
127			function StOleVariantToText(Value: OleVariant): string;
128
129
130			implementation
131
132			uses ComServ {$IFDEF LICENSE}, StComLic {$ENDIF};
133
134			{ Converts a TStream class to an OleVariant [array of byte] }
135			function StStreamToOleVariant(Value: TStream): OleVariant;
136			var
137			Info : array of Byte;
138			begin
139			Value.Position := 0;
140			SetLength(Info, Value.Size);
141			Value.Read(Info[0], Value.Size);
142			Result := Info;
143			end;
144
145			{$WARNINGS OFF}
146			{ Converts an OleVariant [array of byte] to a TStream class }
147			function StOleVariantToStream(Value: OleVariant; NewStream: Boolean): TStream;
148			var
149			Info : array of Byte;
150			begin
151			if NewStream then
152			Result := TMemoryStream.Create;
153			Info := Value;
154			Result.Write(Info[0], Length(Info));
155			Result.Position := 0;
156			end;
157			{$WARNINGS ON}
158
159			{ Converts a text string to an OleVariant [array of byte] }
160			function StTextToOleVariant(Value: string): OleVariant;
161			var
162			SL : TStringList;
163			MS : TStream;
164			begin
165			SL := nil;
166			MS := nil;
167			try
168			SL := TStringList.Create;
169			MS := TMemoryStream.Create;
170
171			SL.Text := Value;
172			SL.SaveToStream(MS);
173
174			Result := StStreamToOleVariant(MS);
175			finally
176			MS.Free;
177			SL.Free;
178			end;
179			end;
180
181			{ Converts an OleVariant [array of byte] to a text string }
182			function StOleVariantToText(Value: OleVariant): string;
183			var
184			SL : TStringList;
185			MS : TStream;
186			begin
187			SL := nil;
188			MS := nil;
189			try
190			SL := TStringList.Create;
191			MS := StOleVariantToStream(Value, True);
192
193			SL.LoadFromStream(MS);
194			Result := SL.Text;
195			finally
196			MS.Free;
197			SL.Free;
198			end;
199			end;
200
201			{ ****** TStStringList Interface - IConnectionPointContainer Methods ****** }
202			procedure TStStringList.EventSinkChanged(const EventSink: IUnknown);
203			begin
204			FEvents := EventSink as IStStringListEvents;
205			if FConnectionPoint <> nil then
206			FSinkList := FConnectionPoint.SinkList;
207			end;
208
209			{ ****** TStStringList Interface - IEnumVariant Methods ****** }
210			function TStStringList.Next(celt: Longint; out elt; pceltFetched: PLongint): HResult;
211			var
212			V : OleVariant;
213			I : Integer;
214			begin
215			Result := S_FALSE;
216			try
217			if pceltFetched <> nil then
218			pceltFetched^ := 0;
219			for I := 0 to celt - 1 do begin
220			if FEnumPos >= FStringList.Count then begin
221			FEnumPos := 0;
222			Exit;
223			end;
224			V := Get_Item(FEnumPos);
225			TVariantArgList(elt)[I] := TVariantArg(V);
226
227			// Prevent COM garbage collection
228			TVarData(V).VType := varEmpty;
229			TVarData(V).VInteger := 0;
230
231			Inc(FEnumPos);
232			if pceltFetched <> nil then
233			Inc(pceltFetched^);
234			end;
235			except
236			end;
237			if (pceltFetched = nil) or ((pceltFetched <> nil) and (pceltFetched^ = celt)) then
238			Result := S_OK;
239			end;
240
241			function TStStringList.Skip(celt: Longint): HResult;
242			begin
243			Inc(FEnumPos, celt);
244			Result := S_OK;
245			end;
246
247			function TStStringList.Reset: HResult;
248			begin
249			FEnumPos := 0;
250			Result := S_OK;
251			end;
252
253			function TStStringList.Clone(out Enum: IEnumVariant): HResult;
254			begin
255			Enum := nil;
256			Result := S_OK;
257			try
258			Enum := Self.Create;
259			TStStringList(Enum).FStringList.Assign(FStringList);
260			except
261			Result := E_OUTOFMEMORY;
262			end;
263			end;
264
265			{ ******** TStStringList Interface *************************************************}
266			constructor TStStringList.Create(AList: TStringList);
267			begin
268			FExternalList := True;
269			FStringList := AList;
270			inherited Create;
271			end;
272
273			procedure TStStringList.Initialize;
274			begin
275			inherited Initialize;
276			FConnectionPoints := TConnectionPoints.Create(Self);
277			if AutoFactory.EventTypeInfo <> nil then
278			FConnectionPoint := FConnectionPoints.CreateConnectionPoint(
279			AutoFactory.EventIID, ckSingle, EventConnect)
280			else FConnectionPoint := nil;
281
282			{$IFDEF LICENSE}
283			FIsLicensed := False;
284			{$ELSE}
285			FIsLicensed := True;
286			{$ENDIF}
287
288			if not FExternalList then
289			FStringList := TStringList.Create;
290
291			FEnumPos := 0;
292
293			FStringList.OnChange := _OnChange;
294			FStringList.OnChanging := _OnChanging;
295			end;
296
297			destructor TStStringList.Destroy;
298			begin
299			if (FStringList <> nil) and (not FExternalList) then
300			FStringList.Free;
301
302			inherited Destroy;
303			end;
304
305			function TStStringList.GetStringList: TStringList;
306			begin
307			Result := FStringList;
308			end;
309
310			procedure TStStringList.SetStringList(Value: TStringList);
311			begin
312			FStringList.Assign(Value);
313			end;
314
315			{ ******** TStStringList Events *******************************************************}
316			procedure TStStringList._OnChange(Sender: TObject);
317			begin
318			if Assigned(FEvents) then
319			FEvents.OnChange;
320			end;
321
322			procedure TStStringList._OnChanging(Sender: TObject);
323			begin
324			if Assigned(FEvents) then
325			FEvents.OnChanging;
326			end;
327
328			{ ******** TStStringList Properties * (Get) *******************************************}
329			function TStStringList.Get__NewEnum: IUnknown;
330			begin
331			Result := Self;
332			end;
333
334			function TStStringList.Get_Item(Index: Integer): WideString;
335			begin
336			{$IFDEF LICENSE}
337			if (not FIsLicensed) or (not COMHasBeenLicensed) then
338			OleError(CLASS_E_NOTLICENSED);
339			{$ENDIF}
340			Result := FStringList.Strings[Index];
341			end;
342
343			function TStStringList.Get_CommaText: WideString;
344			begin
345			{$IFDEF LICENSE}
346			if (not FIsLicensed) or (not COMHasBeenLicensed) then
347			OleError(CLASS_E_NOTLICENSED);
348			{$ENDIF}
349			Result := FStringList.CommaText;
350			end;
351
352			function TStStringList.Get_Count: Integer;
353			begin
354			{$IFDEF LICENSE}
355			if (not FIsLicensed) or (not COMHasBeenLicensed) then
356			OleError(CLASS_E_NOTLICENSED);
357			{$ENDIF}
358			Result := FStringList.Count;
359			end;
360
361			function TStStringList.Get_Duplicates: Integer;
362			begin
363			{$IFDEF LICENSE}
364			if (not FIsLicensed) or (not COMHasBeenLicensed) then
365			OleError(CLASS_E_NOTLICENSED);
366			{$ENDIF}
367			Result := Ord(FStringList.Duplicates);
368			end;
369
370			function TStStringList.Get_Names(Index: Integer): WideString;
371			begin
372			{$IFDEF LICENSE}
373			if (not FIsLicensed) or (not COMHasBeenLicensed) then
374			OleError(CLASS_E_NOTLICENSED);
375			{$ENDIF}
376			Result := FStringList.Names[Index];
377			end;
378
379			function TStStringList.Get_Sorted: WordBool;
380			begin
381			{$IFDEF LICENSE}
382			if (not FIsLicensed) or (not COMHasBeenLicensed) then
383			OleError(CLASS_E_NOTLICENSED);
384			{$ENDIF}
385			Result := FStringList.Sorted;
386			end;
387
388			function TStStringList.Get_Stream: OleVariant;
389			begin
390			{$IFDEF LICENSE}
391			if (not FIsLicensed) or (not COMHasBeenLicensed) then
392			OleError(CLASS_E_NOTLICENSED);
393			{$ENDIF}
394			Result := StTextToOleVariant(FStringList.Text);
395			end;
396
397			function TStStringList.Get_Strings(Index: Integer): WideString;
398			begin
399			{$IFDEF LICENSE}
400			if (not FIsLicensed) or (not COMHasBeenLicensed) then
401			OleError(CLASS_E_NOTLICENSED);
402			{$ENDIF}
403			Result := FStringList.Strings[Index];
404			end;
405
406			function TStStringList.Get_Text: WideString;
407			begin
408			{$IFDEF LICENSE}
409			if (not FIsLicensed) or (not COMHasBeenLicensed) then
410			OleError(CLASS_E_NOTLICENSED);
411			{$ENDIF}
412			Result := FStringList.Text;
413			end;
414
415			function TStStringList.Get_Values(const Name: WideString): WideString;
416			begin
417			{$IFDEF LICENSE}
418			if (not FIsLicensed) or (not COMHasBeenLicensed) then
419			OleError(CLASS_E_NOTLICENSED);
420			{$ENDIF}
421			Result := FStringList.Values[Name];
422			end;
423
424			{ ******** TStStringList Properties * (Set) *******************************************}
425			procedure TStStringList.Set_CommaText(const Value: WideString);
426			begin
427			{$IFDEF LICENSE}
428			if (not FIsLicensed) or (not COMHasBeenLicensed) then
429			OleError(CLASS_E_NOTLICENSED);
430			{$ENDIF}
431			FStringList.CommaText := Value;
432			end;
433
434			procedure TStStringList.Set_Duplicates(Value: Integer);
435			begin
436			{$IFDEF LICENSE}
437			if (not FIsLicensed) or (not COMHasBeenLicensed) then
438			OleError(CLASS_E_NOTLICENSED);
439			{$ENDIF}
440			FStringList.Duplicates := Classes.TDuplicates(Value);
441			end;
442
443			procedure TStStringList.Set_Item(Index: Integer; const Value: WideString);
444			begin
445			{$IFDEF LICENSE}
446			if (not FIsLicensed) or (not COMHasBeenLicensed) then
447			OleError(CLASS_E_NOTLICENSED);
448			{$ENDIF}
449			FStringList.Strings[Index] := Value;
450			end;
451
452			procedure TStStringList.Set_Sorted(Value: WordBool);
453			begin
454			{$IFDEF LICENSE}
455			if (not FIsLicensed) or (not COMHasBeenLicensed) then
456			OleError(CLASS_E_NOTLICENSED);
457			{$ENDIF}
458			FStringList.Sorted := Value;
459			end;
460
461			procedure TStStringList.Set_Stream(Value: OleVariant);
462			begin
463			{$IFDEF LICENSE}
464			if (not FIsLicensed) or (not COMHasBeenLicensed) then
465			OleError(CLASS_E_NOTLICENSED);
466			{$ENDIF}
467			FStringList.Text := StOleVariantToText(Value);
468			end;
469
470			procedure TStStringList.Set_Strings(Index: Integer;
471			const Value: WideString);
472			begin
473			{$IFDEF LICENSE}
474			if (not FIsLicensed) or (not COMHasBeenLicensed) then
475			OleError(CLASS_E_NOTLICENSED);
476			{$ENDIF}
477			FStringList.Strings[Index] := Value;
478			end;
479
480			procedure TStStringList.Set_Text(const Value: WideString);
481			begin
482			{$IFDEF LICENSE}
483			if (not FIsLicensed) or (not COMHasBeenLicensed) then
484			OleError(CLASS_E_NOTLICENSED);
485			{$ENDIF}
486			FStringList.Text := Value;
487			end;
488
489			procedure TStStringList.Set_Values(const Name, Value: WideString);
490			begin
491			{$IFDEF LICENSE}
492			if (not FIsLicensed) or (not COMHasBeenLicensed) then
493			OleError(CLASS_E_NOTLICENSED);
494			{$ENDIF}
495			FStringList.Values[Name] := Value;
496			end;
497
498			{ ******** TStStringList Methods ***************************************************}
499			function TStStringList.Add(const S: WideString): Integer;
500			begin
501			{$IFDEF LICENSE}
502			if (not FIsLicensed) or (not COMHasBeenLicensed) then
503			OleError(CLASS_E_NOTLICENSED);
504			{$ENDIF}
505			FStringList.Add(S);
506			end;
507
508			procedure TStStringList.Append(const S: WideString);
509			begin
510			{$IFDEF LICENSE}
511			if (not FIsLicensed) or (not COMHasBeenLicensed) then
512			OleError(CLASS_E_NOTLICENSED);
513			{$ENDIF}
514			FStringList.Append(S);
515			end;
516
517			procedure TStStringList.Clear;
518			begin
519			{$IFDEF LICENSE}
520			if (not FIsLicensed) or (not COMHasBeenLicensed) then
521			OleError(CLASS_E_NOTLICENSED);
522			{$ENDIF}
523			FStringList.Clear;
524			end;
525
526			procedure TStStringList.Delete(Index: Integer);
527			begin
528			{$IFDEF LICENSE}
529			if (not FIsLicensed) or (not COMHasBeenLicensed) then
530			OleError(CLASS_E_NOTLICENSED);
531			{$ENDIF}
532			FStringList.Delete(Index);
533			end;
534
535			function TStStringList.Equals(const Strings: IStStringList): WordBool;
536			begin
537			{$IFDEF LICENSE}
538			if (not FIsLicensed) or (not COMHasBeenLicensed) then
539			OleError(CLASS_E_NOTLICENSED);
540			{$ENDIF}
541			Result := FStringList.Equals(TStStringList(Strings).FStringList);
542			end;
543
544			procedure TStStringList.Exchange(Index1, Index2: Integer);
545			begin
546			{$IFDEF LICENSE}
547			if (not FIsLicensed) or (not COMHasBeenLicensed) then
548			OleError(CLASS_E_NOTLICENSED);
549			{$ENDIF}
550			FStringList.Exchange(Index1, Index2);
551			end;
552
553			function TStStringList.Find(const S: WideString;
554			var Index: Integer): WordBool;
555			begin
556			{$IFDEF LICENSE}
557			if (not FIsLicensed) or (not COMHasBeenLicensed) then
558			OleError(CLASS_E_NOTLICENSED);
559			{$ENDIF}
560			Result := FStringList.Find(S, Index);
561			end;
562
563			function TStStringList.IndexOf(const S: WideString): Integer;
564			begin
565			{$IFDEF LICENSE}
566			if (not FIsLicensed) or (not COMHasBeenLicensed) then
567			OleError(CLASS_E_NOTLICENSED);
568			{$ENDIF}
569			Result := FStringList.IndexOf(S);
570			end;
571
572			function TStStringList.IndexOfName(const Name: WideString): Integer;
573			begin
574			{$IFDEF LICENSE}
575			if (not FIsLicensed) or (not COMHasBeenLicensed) then
576			OleError(CLASS_E_NOTLICENSED);
577			{$ENDIF}
578			Result := FStringList.IndexOfName(Name);
579			end;
580
581			procedure TStStringList.Insert(Index: Integer; const S: WideString);
582			begin
583			{$IFDEF LICENSE}
584			if (not FIsLicensed) or (not COMHasBeenLicensed) then
585			OleError(CLASS_E_NOTLICENSED);
586			{$ENDIF}
587			FStringList.Insert(Index, S);
588			end;
589
590			procedure TStStringList.LoadFromFile(const FileName: WideString);
591			begin
592			{$IFDEF LICENSE}
593			if (not FIsLicensed) or (not COMHasBeenLicensed) then
594			OleError(CLASS_E_NOTLICENSED);
595			{$ENDIF}
596			FStringList.LoadFromFile(FileName);
597			end;
598
599			procedure TStStringList.Move(CurIndex, NewIndex: Integer);
600			begin
601			{$IFDEF LICENSE}
602			if (not FIsLicensed) or (not COMHasBeenLicensed) then
603			OleError(CLASS_E_NOTLICENSED);
604			{$ENDIF}
605			FStringList.Move(CurIndex, NewIndex);
606			end;
607
608			procedure TStStringList.SaveToFile(const FileName: WideString);
609			begin
610			{$IFDEF LICENSE}
611			if (not FIsLicensed) or (not COMHasBeenLicensed) then
612			OleError(CLASS_E_NOTLICENSED);
613			{$ENDIF}
614			FStringList.SaveToFile(FileName);
615			end;
616
617			procedure TStStringList.Sort;
618			begin
619			{$IFDEF LICENSE}
620			if (not FIsLicensed) or (not COMHasBeenLicensed) then
621			OleError(CLASS_E_NOTLICENSED);
622			{$ENDIF}
623			FStringList.Sort;
624			end;
625
626
627			function TStStringList.License(const Key: WideString): WordBool;
628			begin
629			{$IFDEF LICENSE}
630			Result := COMIsValidKey(Key);
631			{$ELSE}
632			Result := True;
633			{$ENDIF}
634			FIsLicensed := Result;
635			end;
636
637			initialization
638			TAutoObjectFactory.Create(ComServer, TStStringList, Class_StStringList, ciMultiInstance, tmBoth);
639			end.