Форум: "Потрепаться";
Текущий архив: 2004.09.05;
Скачать: [xml.tar.bz2];
Вниз
Маленькая развлекушка. Найти похожие ветки
← →
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;
Скачать: [xml.tar.bz2];
Память: 0.47 MB
Время: 0.032 c