propfilereh.pas

最新的 DBGRIDEH4.0

        if ReadValue = vaNil then
          VarClear(Result) else
          Result := NULL;
      end;
      vaInt8: TVarData(Result).VByte := Byte(ReadInteger);
      vaInt16: TVarData(Result).VSmallint := Smallint(ReadInteger);
      vaInt32: TVarData(Result).VInteger := ReadInteger;
      vaExtended: TVarData(Result).VDouble := ReadFloat;
      vaSingle: TVarData(Result).VSingle := ReadSingle;
      vaCurrency: TVarData(Result).VCurrency := ReadCurrency;
      vaDate: TVarData(Result).VDate := ReadDate;
      vaString, vaLString: Result := ReadString;
      vaWString: Result := ReadWideString;
      vaFalse, vaTrue: TVarData(Result).VBoolean := ReadValue = vaTrue;
    else
      raise EReadError.Create(SReadError);
    end;
    TVarData(Result).VType := ValTtoVarT[ValType];
  end;

{$ENDIF}

  // This is isolated into a local to help reduce transient VarClears
  procedure SetVariantReference;
  begin
    SetVariantProp(Instance, PropInfo, ReadVariant);
  end;

{$IFDEF EH_LIB_6}

  procedure SetInterfaceReference;
  var
    Intf: IInterface;
  begin
    if NextValue = vaNil then
    begin
      ReadValue;
      Intf := nil;
      SetInterfaceProp(Instance, PropInfo, Intf);
    end
    else
      //FFixups.Add(TPropIntfFixup.Create(Instance, Root, PropInfo, '', ReadIdent));
  end;

{$ENDIF}

begin
  if not CanWrite(PropInfo) then
{$IFDEF EH_LIB_6}
    if not ((PropType_getKind(PropInfo_getPropType(PropInfo)) = tkClass) and
       (GetObjectProp(Instance, PropInfo) is TComponent) and
       (csSubComponent in TComponent(GetObjectProp(Instance, PropInfo)).ComponentStyle)) then
{$ENDIF}
      ReadError(SReadOnlyProperty);
  PropType := PropInfo_getPropType(PropInfo);
  case PropType_getKind(PropType) of
    tkInteger:
      if NextValue = vaIdent then
        SetIntIdent(Instance, PropInfo, ReadIdent)
      else
        SetOrdProp(Instance, PropInfo, ReadInteger);
    tkChar:
      SetOrdProp(Instance, PropInfo, Ord(ReadChar));
    tkEnumeration:
      SetOrdProp(Instance, PropInfo, GetEnumValue(PropType, ReadIdent));
    tkFloat:
      SetFloatProp(Instance, PropInfo, ReadFloat);
    tkString, tkLString:
      SetStrProp(Instance, PropInfo, ReadString);
    tkWString:
{$IFDEF EH_LIB_6}
      SetWideStrProp(Instance, PropInfo, ReadWideString);
{$ELSE}
      SetStrProp(Instance, PropInfo, ReadWideString);
{$ENDIF}
    tkSet:
      SetOrdProp(Instance, PropInfo, ReadSet(PropType));
    tkClass:
      case NextValue of
        vaNil:
          begin
            ReadValue;
            SetOrdProp(Instance, PropInfo, 0);
          end;
        vaCollection:
          begin
            ReadValue;
            ReadCollection(TCollection(GetObjectProp(Instance, PropInfo)));
          end
      else
        SetObjectIdent(Instance, PropInfo, ReadIdent);
      end;
    tkMethod:
      raise Exception.Create('Unexpected Kind of Method: "tkMethod"');
{      if NextValue = vaNil then
      begin
        ReadValue;
        SetMethodProp(Instance, PropInfo, NilMethod);
      end
      else
      begin
        Method.Code :=  FindMethod(Root, ReadIdent);
        Method.Data := Root;
        if Method.Code <> nil then SetMethodProp(Instance, PropInfo, Method);
      end;}
    tkVariant:
      SetVariantReference;
{$IFDEF EH_LIB_5}
    tkInt64:
      SetInt64Prop(Instance, PropInfo, ReadInt64);
{$ENDIF}
{$IFDEF EH_LIB_6}
    tkInterface:
      SetInterfaceReference;
{$ENDIF}
  end;
end;

procedure TPropReaderEh.DefineProperty(const Name: string;
  ReadData: TReaderProc; WriteData: TWriterProc; HasData: Boolean);
begin
  if SameText(Name, FPropName) and Assigned(ReadData) then
  begin
    ReadData(Self);
    FPropName := '';
  end;
end;

procedure TPropReaderEh.DefineBinaryProperty(const Name: string;
  ReadData, WriteData: TStreamProc; HasData: Boolean);
var
  Stream: TMemoryStream;
  Count: Longint;
{$IFDEF CIL}
  ABuffer: array of Byte;
{$ENDIF}
begin
  if SameText(Name, FPropName) and Assigned(ReadData) then
  begin
    if  ReadValue <> vaBinary then
    begin
//      Dec(FBufPos);
//      SkipValue;
      FCanHandleExcepts := True;
      PropValueError;
    end;
    Stream := TMemoryStream.Create;
    try
      Read(Count, SizeOf(Count));
      Stream.SetSize(Count);
{$IFDEF CIL}
{ DONE : Read(Stream.Memory, 0, Count); does not work}
      ABuffer := Stream.Memory;
      Read(ABuffer, 0, Count);
{$ELSE}
      Read(Stream.Memory^, Count);
{$ENDIF}
      FCanHandleExcepts := True;
      ReadData(Stream);
    finally
      Stream.Free;
    end;
    FPropName := '';
  end;
end;

procedure TPropReaderEh.ReadOwnerProperties(Component: TComponent);
begin
  ReadSignature;
  Root := Component;
  Owner := Root;
  ReadComponent(Component);
end;

function EnumValue(EnumType: PTypeInfo; const EnumName: string): Integer;
begin
  Result := GetEnumValue(EnumType, EnumName);
  if Result = -1 then PropValueError;
end;

function TPropReaderEh.ReadSet(SetType: PTypeInfo): Integer;
{$IFDEF CIL}
begin
  Result := inherited ReadSet(SetType);
end;
{$ELSE}
var
  EnumType: PTypeInfo;
  EnumName: string;
begin
  try
    if ReadValue <> vaSet then PropValueError;
    EnumType := GetTypeData(SetType)^.CompType^;
    Result := 0;
    while True do
    begin
      EnumName := ReadStr;
      if EnumName = '' then Break;
      Include(TIntegerSet(Result), EnumValue(EnumType, EnumName));
    end;
  except
    SkipSetBody;
    raise;
  end;
end;
{$ENDIF}

procedure TPropReaderEh.SkipSetBody;
begin
  while ReadStr <> '' do begin end;
end;

{$IFNDEF EH_LIB_5}

procedure TPropReaderEh.PropertyError;
begin
  SkipValue;
  PropertyNotFound;
end;

procedure TPropReaderEh.SkipValue;

  procedure SkipList;
  begin
    while not EndOfList do SkipValue;
    ReadListEnd;
  end;

  procedure SkipBytes(Count: Longint);
  var
    Bytes: array[0..255] of Char;
  begin
    while Count > 0 do
      if Count > SizeOf(Bytes) then
      begin
        Read(Bytes, SizeOf(Bytes));
        Dec(Count, SizeOf(Bytes));
      end
      else
      begin
        Read(Bytes, Count);
        Count := 0;
      end;
  end;

  procedure SkipBinary;
  var
    Count: Longint;
  begin
    Read(Count, SizeOf(Count));
    SkipBytes(Count);
  end;

  procedure SkipCollection;
  begin
    while not EndOfList do
    begin
      if NextValue in [vaInt8, vaInt16, vaInt32] then SkipValue;
      SkipBytes(1);
      while not EndOfList do SkipProperty;
      ReadListEnd;
    end;
    ReadListEnd;
  end;

begin
  case ReadValue of
    vaNull: begin end;
    vaList: SkipList;
    vaInt8: SkipBytes(1);
    vaInt16: SkipBytes(2);
    vaInt32: SkipBytes(4);
    vaExtended: SkipBytes(SizeOf(Extended));
    vaString, vaIdent: ReadStr;
    vaFalse, vaTrue: begin end;
    vaBinary: SkipBinary;
    vaSet: SkipSetBody;
    vaCollection: SkipCollection;
  end;
end;

procedure TPropReaderEh.SkipProperty;
begin
  ReadStr; { Skips property name }
  SkipValue;
end;

{$ENDIF}

{ TStoragePropertyInterceptor }

constructor TStoragePropertyInterceptor.Create(ATarget: TObject);
begin
  inherited Create;
  FTarget := ATarget;
end;

function TStoragePropertyInterceptor.NeedIntercept: Boolean;
begin
  Result := True;
end;

procedure TStoragePropertyInterceptor.Readed;
begin

end;

function GetFormNormalPlacement(Form: TCustomForm): TRect;
{$IFNDEF EH_LIB_CLX}
var
  Placement: TWindowPlacement;
{$ENDIF}
begin
{$IFNDEF EH_LIB_CLX}
  if (Form.WindowState <> wsNormal) and Form.HandleAllocated then
  begin
    Placement.length := SizeOf(TWindowPlacement);
{$IFDEF CIL}
    GetWindowPlacement(Form.Handle, Placement);
{$ELSE}
    GetWindowPlacement(Form.Handle, @Placement);
{$ENDIF}
    Result := Placement.rcNormalPosition;
  end else
{$ENDIF}
    Result := Rect(Form.Left, Form.Top, Form.Left + Form.Width, Form.Top + Form.Height);
end;

{ TFormStoragePropertyInterceptor }

constructor TFormStoragePropertyInterceptor.Create(ATarget: TObject);
var
  PlacementRect: TRect;
begin
  inherited Create(ATarget);
  if (Target <> nil) and (Target is TCustomForm) then
  begin
    PlacementRect := GetFormNormalPlacement(TCustomForm(Target));
    FTop := PlacementRect.Top;
    FLeft := PlacementRect.Left;
    FHeight := PlacementRect.Bottom - PlacementRect.Top;
    FWidth := PlacementRect.Right - PlacementRect.Left;
  end;
  FPixelsPerInch := TForm(Target).PixelsPerInch;
  FWindowState := TForm(Target).WindowState;
  FActiveControl := TForm(Target).ActiveControl;
end;

function TFormStoragePropertyInterceptor.GetTop: Integer;
begin
  Result := 0;
  if (Target <> nil) and (Target is TCustomForm) then
    Result := GetFormNormalPlacement(TCustomForm(Target)).Top
end;

function TFormStoragePropertyInterceptor.GetLeft: Integer;
begin
  Result := 0;
  if (Target <> nil) and (Target is TCustomForm) then
    Result := GetFormNormalPlacement(TCustomForm(Target)).Left;
end;

function TFormStoragePropertyInterceptor.GetHeight: Integer;
var
  PlacementRect: TRect;
begin
  Result := 0;
  if (Target <> nil) and (Target is TCustomForm) then
  begin
    PlacementRect := GetFormNormalPlacement(TCustomForm(Target));
    Result := PlacementRect.Bottom - PlacementRect.Top;
  end;
end;

function TFormStoragePropertyInterceptor.GetWidth: Integer;
var
  PlacementRect: TRect;
begin
  Result := 0;
  if (Target <> nil) and (Target is TCustomForm) then
  begin
    PlacementRect := GetFormNormalPlacement(TCustomForm(Target));
    Result := PlacementRect.Right - PlacementRect.Left;
  end;
end;

function TFormStoragePropertyInterceptor.GetNotmalFormPlacement: TRect;
begin
end;

{$HINTS OFF}

type
{$IFDEF EH_LIB_CLX}
  TNastyForm = class(TScrollingWidget)
  private
{$IFDEF EH_LIB_7}
    FActivated: Boolean;
    FDeactivated: Boolean;
    FBorderIcons: TBorderIcons;
    FActive: Boolean;
    FKeyPreview: Boolean;
    FDropTarget: Boolean;
    FShown: Boolean;
    FSizeGrip: Boolean;
    FModalResult: TModalResult;
    FBorderStyle: TFormBorderStyle;
{$ENDIF}
    FActiveControl: TWidgetControl;
  end;
{$ELSE}
  TNastyForm = class(TScrollingWinControl)
  private
    FActiveControl: TWinControl;
    FFocusedControl: TWinControl;
    FBorderIcons: TBorderIcons;
    FBorderStyle: TFormBorderStyle;
    FSizeChanging: Boolean;
    FWindowState: TWindowState;
    FShowAction: TShowAction;
    FKeyPreview: Boolean;
    FActive: Boolean;
    FFormStyle: TFormStyle;
    FPosition: TPosition;
  end;
{$ENDIF}

{$HINTS ON}

procedure TFormStoragePropertyInterceptor.Readed;
{$IFNDEF EH_LIB_CLX}
var
  Placement: TWindowPlacement;
{$ENDIF}
begin
  inherited Readed;
  FHeight := MulDiv(FHeight, Screen.PixelsPerInch, FPixelsPerInch);
  FLeft := MulDiv(FLeft, Screen.PixelsPerInch, FPixelsPerInch);
  FTop := MulDiv(FTop, Screen.PixelsPerInch, FPixelsPerInch);
  FWidth := MulDiv(FWidth, Screen.PixelsPerInch, FPixelsPerInch);
  if (Target <> nil) then
  begin
    TCustomForm(Target).WindowState := FWindowState;
{$IFDEF CIL}
    TCustomForm(Target).ActiveControl := FActiveControl;
{$ELSE}
    TNastyForm(Target).FActiveControl := FActiveControl;
{$ENDIF}

{$IFDEF EH_LIB_VCL}
    if TCustomForm(Target).WindowState <> wsNormal then
    begin
{$IFDEF CIL}
      GetWindowPlacement(TCustomForm(Target).Handle, Placement);
{$ELSE}
      GetWindowPlacement(TCustomForm(Target).Handle, @Placement);
{$ENDIF}
      Placement.rcNormalPosition.Left := FLeft;
      Placement.rcNormalPosition.Top := FTop;
      Placement.rcNormalPosition.Right := FLeft + FWidth;
      Placement.rcNormalPosition.Bottom := FTop + FHeight;
{$IFDEF CIL}
      SetWindowPlacement(TCustomForm(Target).Handle, Placement);
{$ELSE}
      SetWindowPlacement(TCustomForm(Target).Handle, @Placement);
{$ENDIF}
    end else
      TCustomForm(Target).SetBounds(FLeft, FTop, FWidth, FHeight);
    if (TForm(Target).Position in [poScreenCenter, poDesktopCenter]) and
      not (csDesigning in TCustomForm(Target).ComponentState) and FPosPresent
    then
{$IFDEF CIL}
{ TODO : Realize Position }
//      TCustomForm(Target).Position := poDesigned;
{$ELSE}
      TNastyForm(Target).FPosition := poDesigned;
{$ENDIF}

{$ELSE}
    TCustomForm(Target).SetBounds(FLeft, FTop, FWidth, FHeight);
{$ENDIF}
  end;
end;

procedure TFormStoragePropertyInterceptor.SetLeft(const Value: Integer);
begin
  FPosPresent := True;
  FLeft := Value;
end;

procedure TFormStoragePropertyInterceptor.SetTop(const Value: Integer);
begin
  FPosPresent := True;
  FTop := Value;
end;

initialization
  RegisterReadPropertyInterceptor(TCustomForm, TFormStoragePropertyInterceptor);
finalization
  FreeAndNil(InterceptorList);
  FreeAndNil(TargetList);
  FreeAndNil(ForChildListObj);
end.