Source/TntAxCtrls.pas

   1
   2 {*****************************************************************************}
   3 {                                                                             }
   4 {    Tnt Delphi Unicode Controls                                              }
   5 {      http://www.tntware.com/delphicontrols/unicode/                         }
   6 {        Version: 2.3.0                                                       }
   7 {                                                                             }
   8 {    Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com)       }
   9 {                                                                             }
  10 {*****************************************************************************}
  11
  12 unit TntAxCtrls;
  13
  14 {$INCLUDE TntCompilers.inc}
  15
  16 interface
  17
  18 uses
  19   ComObj, StdVcl,
  20   {$IFNDEF COMPILER_10_UP}
  21   TntWideStrings,
  22   {$ELSE}
  23   WideStrings,
  24   {$ENDIF}
  25   TntClasses;
  26
  27 type
  28   TWideStringsAdapter = class(TAutoIntfObject, IStrings, IWideStringsAdapter)
  29   private
  30     FStrings: TWideStrings;
  31   protected
  32     { IWideStringsAdapter }
  33     procedure ReferenceStrings(S: TWideStrings);
  34     procedure ReleaseStrings;
  35     { IStrings }
  36     function Get_ControlDefault(Index: Integer): OleVariant; safecall;
  37     procedure Set_ControlDefault(Index: Integer; Value: OleVariant); safecall;
  38     function Count: Integer; safecall;
  39     function Get_Item(Index: Integer): OleVariant; safecall;
  40     procedure Set_Item(Index: Integer; Value: OleVariant); safecall;
  41     procedure Remove(Index: Integer); safecall;
  42     procedure Clear; safecall;
  43     function Add(Item: OleVariant): Integer; safecall;
  44     function _NewEnum: IUnknown; safecall;
  45   public
  46     constructor Create(Strings: TTntStrings);
  47   end;
  48
  49 implementation
  50
  51 uses
  52   Classes, ActiveX, Variants;
  53
  54 { TStringsEnumerator }
  55
  56 type
  57   TStringsEnumerator = class(TContainedObject, IEnumString)
  58   private
  59     FIndex: Integer;  // index of next unread string
  60     FStrings: IStrings;
  61   public
  62     constructor Create(const Strings: IStrings);
  63     function Next(celt: Longint; out elt;
  64       pceltFetched: PLongint): HResult; stdcall;
  65     function Skip(celt: Longint): HResult; stdcall;
  66     function Reset: HResult; stdcall;
  67     function Clone(out enm: IEnumString): HResult; stdcall;
  68   end;
  69
  70 constructor TStringsEnumerator.Create(const Strings: IStrings);
  71 begin
  72   inherited Create(Strings);
  73   FStrings := Strings;
  74 end;
  75
  76 function TStringsEnumerator.Next(celt: Longint; out elt; pceltFetched: PLongint): HResult;
  77 var
  78   I: Integer;
  79 begin
  80   I := 0;
  81   while (I < celt) and (FIndex < FStrings.Count) do
  82   begin
  83     TPointerList(elt)[I] := PWideChar(WideString(FStrings.Item[FIndex]));
  84     Inc(I);
  85     Inc(FIndex);
  86   end;
  87   if pceltFetched <> nil then pceltFetched^ := I;
  88   if I = celt then Result := S_OK else Result := S_FALSE;
  89 end;
  90
  91 function TStringsEnumerator.Skip(celt: Longint): HResult;
  92 begin
  93   if (FIndex + celt) <= FStrings.Count then
  94   begin
  95     Inc(FIndex, celt);
  96     Result := S_OK;
  97   end
  98   else
  99   begin
 100     FIndex := FStrings.Count;
 101     Result := S_FALSE;
 102   end;
 103 end;
 104
 105 function TStringsEnumerator.Reset: HResult;
 106 begin
 107   FIndex := 0;
 108   Result := S_OK;
 109 end;
 110
 111 function TStringsEnumerator.Clone(out enm: IEnumString): HResult;
 112 begin
 113   try
 114     enm := TStringsEnumerator.Create(FStrings);
 115     TStringsEnumerator(enm).FIndex := FIndex;
 116     Result := S_OK;
 117   except
 118     Result := E_UNEXPECTED;
 119   end;
 120 end;
 121
 122 { TWideStringsAdapter }
 123
 124 constructor TWideStringsAdapter.Create(Strings: TTntStrings);
 125 var
 126   StdVcl: ITypeLib;
 127 begin
 128   OleCheck(LoadRegTypeLib(LIBID_STDVCL, 4, 0, 0, StdVcl));
 129   inherited Create(StdVcl, IStrings);
 130   FStrings := Strings;
 131 end;
 132
 133 procedure TWideStringsAdapter.ReferenceStrings(S: TWideStrings);
 134 begin
 135   FStrings := S;
 136 end;
 137
 138 procedure TWideStringsAdapter.ReleaseStrings;
 139 begin
 140   FStrings := nil;
 141 end;
 142
 143 function TWideStringsAdapter.Get_ControlDefault(Index: Integer): OleVariant;
 144 begin
 145   Result := Get_Item(Index);
 146 end;
 147
 148 procedure TWideStringsAdapter.Set_ControlDefault(Index: Integer; Value: OleVariant);
 149 begin
 150   Set_Item(Index, Value);
 151 end;
 152
 153 function TWideStringsAdapter.Count: Integer;
 154 begin
 155   Result := 0;
 156   if FStrings <> nil then Result := FStrings.Count;
 157 end;
 158
 159 function TWideStringsAdapter.Get_Item(Index: Integer): OleVariant;
 160 begin
 161   Result := NULL;
 162   if (FStrings <> nil) then Result := WideString(FStrings[Index]);
 163 end;
 164
 165 procedure TWideStringsAdapter.Set_Item(Index: Integer; Value: OleVariant);
 166 begin
 167   if (FStrings <> nil) then FStrings[Index] := Value;
 168 end;
 169
 170 procedure TWideStringsAdapter.Remove(Index: Integer);
 171 begin
 172   if FStrings <> nil then FStrings.Delete(Index);
 173 end;
 174
 175 procedure TWideStringsAdapter.Clear;
 176 begin
 177   if FStrings <> nil then FStrings.Clear;
 178 end;
 179
 180 function TWideStringsAdapter.Add(Item: OleVariant): Integer;
 181 begin
 182   Result := -1;
 183   if FStrings <> nil then Result := FStrings.Add(Item);
 184 end;
 185
 186 function TWideStringsAdapter._NewEnum: IUnknown;
 187 begin
 188   Result := TStringsEnumerator.Create(Self);
 189 end;
 190
 191 end.