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	(* *** 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.