Текущий архив: 2004.09.05;
Скачать: CL | DM;

Вниз

Маленькая развлекушка.   Найти похожие ветки 

← →
DiamondShark ©   (2004-08-13 18:39) [0]

Предыстория.
Человек пишет что-то на скриптах (то-ли сайт на ASP, то-ли в какой-то специализированной программе -- не важно) и столкнулся с такой особенностью, что параметры по ссылке как-то нехорошо передаются от скрипта объектам и обратно. Обратился с извечным вопросом: "Что делать?" Было посоветовано вместо кучи параметров по ссылке передавать один объект с кучей свойств. На вопрос "А это как?" оказалось быстрее написать код, чем объяснять.

unit prpcnt;

interface

uses
 Classes;

type
 TPropRec = record
   Name: String;
   DispId: Integer;
   Value: OleVariant;
 end;
 PPropRec = ^TPropRec;

type
 TPropertyContainer = class(TinterfacedObject, IDispatch)
 private
   FPropList: TList;
   FLastDispId: integer;
   function GetPropRec(Name: WideString): PPropRec; overload;
   function GetPropRec(DispId: integer): PPropRec; overload;
 protected // IDispatch implementation
   function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
   function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
   function GetIDsOfNames(const IID: TGUID; Names: Pointer;
     NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
   function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
     Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
 public
   constructor Create;
   destructor Destroy; override;
 end;

implementation

uses
 Windows, ActiveX, SysUtils;

{ TPropertyContainer }

constructor TPropertyContainer.Create;
begin
 inherited Create;
 FPropList := TList.Create;
end;

destructor TPropertyContainer.Destroy;
var
 i: integer;
begin
 if FPropList <> nil then
   for i := 0 to FPropList.Count - 1 do Dispose(PPropRec(FPropList[i]));
 inherited;
end;

function TPropertyContainer.GetIDsOfNames(const IID: TGUID; Names: Pointer;
 NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
type
 TPWCharArray = array[0..0] of PWideChar;
 TDispIdArray = array[0..0] of integer;
var
 NameArray: ^TPWCharArray absolute Names;
 DispIdArray: ^TDispIdArray absolute DispIDs;
 i: integer;
 pr: PPropRec;
begin
 if (NameCount < 1) or (Names = nil) or (DispIds = nil) then
   begin
     Result := E_INVALIDARG;
     Exit;
   end;
 for i := 0 to NameCount - 1 do DispIdArray[i] := DISPID_UNKNOWN;
 pr := GetPropRec(NameArray[0]);
 DispIdArray[0] := pr.DispId;
 if NameCount > 1 then Result := DISP_E_UNKNOWNNAME
 else Result := S_OK;
end;

function TPropertyContainer.GetPropRec(Name: WideString): PPropRec;
var
 i: integer;
 SName: string;
begin
 SName := AnsiUpperCase(Name);
 i := 0;
 while (i < FPropList.Count) and (AnsiUpperCase(PPropRec(FPropList[i]).Name) <> SName) do
   inc(i);
 if i < FPropList.Count then Result := PPropRec(FPropList[i])
 else
   begin
     i := FPropList.Add(New(PPropRec));
     Result := PPropRec(FPropList[i]);
     FillChar(Result^, sizeof(TPropRec), 0);
     Result.Name := SName;
     Result.DispId := FLastDispId + 1;
     inc(FLastDispId);
   end
end;

function TPropertyContainer.GetPropRec(DispId: integer): PPropRec;
var
 i: integer;
begin
 i := 0;
 while (i < FPropList.Count) and (PPropRec(FPropList[i]).DispId <> DispId) do
   inc(i);
 if i < FPropList.Count then Result := PPropRec(FPropList[i])
 else Result := nil;
end;

function TPropertyContainer.GetTypeInfo(Index, LocaleID: Integer;
 out TypeInfo): HResult;
begin
 Pointer(TypeInfo) := nil;
 Result := E_NOTIMPL;
end;

function TPropertyContainer.GetTypeInfoCount(out Count: Integer): HResult;
begin
 Count := 0;
 Result := S_OK;
end;

function TPropertyContainer.Invoke(DispID: Integer; const IID: TGUID;
 LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
 ArgErr: Pointer): HResult;
var
 pr: PPropRec;
begin
 pr := GetPropRec(DispId);
 if pr = nil then Result := DISP_E_MEMBERNOTFOUND
 else
   begin
     if Flags and (DISPATCH_METHOD or DISPATCH_PROPERTYGET) <> 0 then
       begin
         if VarResult = nil then Result := E_INVALIDARG
         else Result := VariantCopy(OleVariant(VarResult^), pr.Value)
       end
     else if Flags and DISPATCH_PROPERTYPUTREF <> 0 then
       Result := VariantCopyInd(pr.Value, OleVariant(TDispParams(Params).rgvarg[0]))
     else if Flags and DISPATCH_PROPERTYPUT <> 0 then
       begin
         if TDispParams(Params).rgvarg[0].vt = VT_DISPATCH then
           Result := VariantChangeType(pr.Value, OleVariant(TDispParams(Params).rgvarg[0]), 0, VT_VARIANT)
         else
           Result := VariantCopyInd(pr.Value, OleVariant(TDispParams(Params).rgvarg[0]))
       end
     else Result := E_INVALIDARG;
   end;
end;

end.

---

← →
VMcL ©   (2004-08-13 18:42) [1]

>>DiamondShark ©  (13.08.04 18:39)

Ну и?

---

← →
DiamondShark ©   (2004-08-13 18:44) [2]

Бяка.

destructor TPropertyContainer.Destroy;
var
 i: integer;
begin
 if FPropList <> nil then
   begin
     for i := 0 to FPropList.Count - 1 do Dispose(PPropRec(FPropList[i]));
     FPropList.Free;
   end;
 inherited;
end;

---

← →
DiamondShark ©   (2004-08-13 18:44) [3]

> VMcL ©   (13.08.04 18:42) [1]

А просто так ;)

---

← →
VMcL ©   (2004-08-13 18:50) [4]

>>DiamondShark ©  (13.08.04 18:44) [3]

"Флудеры" © м/ф про Масяню  ;-)

P.S. Анкету обнови.

---

← →
DiamondShark ©   (2004-08-13 18:58) [5]

Ничего не понимаю.
В посте анкета 1025205444.
Поиск по нику даёт анкету 1085218356.

Это как?

---

← →
DiamondShark ©   (2004-08-13 18:59) [6]

Ага. Надо было просто перелогиниться.

Хе ;) Интересная дырочка...

---

← →
TUser ©   (2004-08-13 21:21) [7]

Лучше бы ты объяснил, а не написал.

---

← →
Mim1 ©   (2004-08-14 14:39) [8]

> [7] TUser ©   (13.08.04 21:21)

Ага, так может получится что прийдется всю жизнь писать.
Таких работников нужно или учить или увольнять.

---

← →
DiamondShark ©   (2004-08-14 17:30) [9]

Это не работник ;)

---

Страницы: 1 вся ветка

Текущий архив: 2004.09.05;
Скачать: CL | DM;

Наверх

Память: 0.49 MB
Время: 0.026 c