rm_dataset.pas

这是一个功能强大

{*****************************************}
{                                         }
{            Report Machine               }
{             Report dataset              }
{
{ 2004/12  PYZFL修改
{  对RMDataSet控件添加了两个属性
{    Visible，如果属性为false，则在设计器中不显示。
{    AliasName，别名，如果设计时写入，则在设计器中将会显示出来                                         }
{*****************************************}

unit RM_Dataset;

interface

{$I RM.INC}

uses
  SysUtils, Windows, Messages, Classes, Graphics, Stdctrls, DB, RM_Common
{$IFDEF COMPILER6_UP}, Variants{$ENDIF};

type
  TRMDataset = class;

  TRMRangeBegin = (rmrbFirst, rmrbCurrent, rmrbDefault);
  TRMRangeEnd = (rmreLast, rmreCurrent, rmreCount, rmreDefault);
  TRMCheckEOFEvent = procedure(Sender: TObject; var aEOF: Boolean) of object;
  TRMGetIsBlobFieldEvent = procedure(const aFieldName: string; var IsBlobField: Boolean) of object;
  TRMGetFieldIsNullEvent = procedure(const aFieldName: string; var IsBlobField: Boolean) of object;
  TRMUserDatasetOnGetFieldValue = procedure(Dataset: TRMDataset; const FieldName: string; var FieldValue: Variant) of object;
  TRMUserDatasetOnGetFieldDisplayText = procedure(Dataset: TRMDataset; const FieldName: string;
    var FieldValue: WideString) of object;
  TRMUserDatasetOnGetFieldsList = procedure(Dataset: TRMDataset; FieldNames: TStrings) of object;

  { TRMDataset }
  TRMDataset = class(TRMComponent)
  private
    FVisible: Boolean; //(2004-12-8 23:28 PYZFL)
    FAliasName: string; //(2004-12-9 0:00 PYZFL)
    FFieldAlias: TStringList;
    FOnGetFieldValue: TRMUserDatasetOnGetFieldValue;
    FOnGetFieldDisplayText: TRMUserDatasetOnGetFieldDisplayText;
    FOnGetFieldsList: TRMUserDatasetOnGetFieldsList;

    procedure SetFieldAlias(Value: TStringList);
  protected
    FDictionaryKey: string;
    FRangeBegin: TRMRangeBegin;
    FRangeEnd: TRMRangeEnd;
    FRangeEndCount: Integer;
    FOnInit, FOnFirst, FOnNext, FOnLast, FOnPrior: TNotifyEvent;
    FOnCheckEOF: TRMCheckEOFEvent;
    FRecordNo: Integer;
    FOnAfterFirst: TNotifyEvent;
    FOnGetIsBlobField: TRMGetIsBlobFieldEvent;
    FOnGetFieldIsNull: TRMGetFieldIsNullEvent;

    property OnGetFieldDisplayText: TRMUserDatasetOnGetFieldDisplayText read FOnGetFieldDisplayText write FOnGetFieldDisplayText;
    property OnGetFieldValue: TRMUserDatasetOnGetFieldValue read FOnGetFieldValue write FOnGetFieldValue;
    property OnGetFieldsList: TRMUserDatasetOnGetFieldsList read FOnGetFieldsList write FOnGetFieldsList;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    procedure Open; virtual;
    procedure Close; virtual;
    procedure Init; virtual;
    procedure Exit; virtual;
    procedure First; virtual;
    procedure Last; virtual;
    procedure Next; virtual;
    procedure Prior; virtual;
    function Eof: Boolean; virtual;
    function Active: boolean; virtual; abstract;
    function GetFieldValue(const aFieldName: string; aConvertNulls: Boolean): Variant; virtual; abstract;
    function GetFieldDisplayText(const aFieldName: string; aConvertNulls: Boolean): WideString; virtual; abstract;
    function GetFieldDisplayLabel(const aFieldName: string): string; virtual;
    function FieldIsNull(const aFieldName: string): Boolean; virtual;
    function FieldWidth(const aFieldName: string): Integer; virtual;
    procedure GetFieldsList(aFieldList: TStringList); virtual; abstract;
    function IsBlobField(const aFieldName: string): Boolean; virtual;
    procedure AssignBlobFieldTo(const aFieldName: string; aDest: TObject); virtual;

    function GetPropValue(aObject: TObject; aPropName: string; var aValue: Variant;
      Args: array of Variant): Boolean; override;
    function SetPropValue(aObject: TObject; aPropName: string;
      aValue: Variant): Boolean; override;

    property RecordNo: Integer read FRecordNo;
    property OnCheckEOF: TRMCheckEOFEvent read FOnCheckEOF write FOnCheckEOF;
    property OnInit: TNotifyEvent read FOnInit write FOnInit;
    property OnFirst: TNotifyEvent read FOnFirst write FOnFirst;
    property OnNext: TNotifyEvent read FOnNext write FOnNext;
    property OnPrior: TNotifyEvent read FOnPrior write FOnPrior;
    property OnGetIsBlobField: TRMGetIsBlobFieldEvent read FOnGetIsBlobField write FOnGetIsBlobField;
    property OnGetFieldIsNull: TRMGetFieldIsNullEvent read FOnGetFieldIsNull write FOnGetFieldIsNull;
  published
    property DictionaryKey: string read FDictionaryKey write FDictionaryKey;
    property RangeBegin: TRMRangeBegin read FRangeBegin write FRangeBegin default rmrbFirst;
    property RangeEnd: TRMRangeEnd read FRangeEnd write FRangeEnd default rmreLast;
    property RangeEndCount: Integer read FRangeEndCount write FRangeEndCount default 0;
    //(2004-12-8 23:28 PYZFL)
    property Visible: Boolean read FVisible write FVisible;
    property AliasName: string read FAliasName write FAliasName;
    property FieldAlias: TStringList read FFieldAlias write SetFieldAlias;
  end;

  { TRMUserDataset }
  TRMUserDataset = class(TRMDataset)
  private
  public
    function GetFieldValue(const aFieldName: string; aConvertNulls: Boolean): Variant; override;
    function GetFieldDisplayText(const aFieldName: string; aConvertNulls: Boolean): WideString; override;
    procedure GetFieldsList(aFieldList: TStringList); override;
    function Active: boolean; override;
    procedure AssignBlobFieldTo(const aFieldName: string; aDest: TObject); override;
  published
    property OnCheckEOF;
    property OnInit;
    property OnFirst;
    property OnNext;
    property OnPrior;
    property OnGetFieldDisplayText;
    property OnGetFieldValue;
    property OnGetFieldsList;
  end;

  { TRMStringsDataset}
  TRMStringSourceType = (rmssNone, rmssListBox, rmssComboBox, rmssMemo);

  TRMStringsDataset = class(TRMUserDataset)
  private
    FCurIndex: integer;
    FStrings: TStrings;
    FStringsSource: TComponent;
    FStringsSourceType: TRMStringSourceType;

    procedure SetStringsSource(Value: TComponent);
    function GetStrings: TStrings;
  protected
    procedure Notification(AComponent: TComponent; AOperation: TOperation); override;
  public
    constructor Create(AOwner: TComponent); override;

    function Active: boolean; override;
    function Eof: boolean; override;
    function GetFieldValue(const aFieldName: string; aConvertNulls: Boolean): Variant; override;
    function GetFieldDisplayText(const aFieldName: string; aConvertNulls: Boolean): WideString; override;

    procedure Init; override;
    procedure First; override;
    procedure Last; override;
    procedure Next; override;
    procedure Prior; override;
    procedure GetFieldsList(aFieldList: TStringList); override;

    property Strings: TStrings read GetStrings write FStrings;
  published
    property StringsSource: TComponent read FStringsSource write SetStringsSource;
  end;

  { TRMDBDataSet }
  TRMDBDataSet = class(TRMDataset)
  private
    FDataSet: TDataSet;
    FOpenDataSet, FCloseDataSet: Boolean;
    FOnOpen, FOnClose: TNotifyEvent;
    FBookmark: TBookmark;
    FEof: Boolean;
    procedure SetDataSet(Value: TDataSet);
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function Active: boolean; override;
    procedure Init; override;
    procedure Exit; override;
    procedure First; override;
    procedure Last; override;
    procedure Next; override;
    procedure Prior; override;
    procedure MoveBy(Distance: Integer);
    procedure Open; override;
    procedure Close; override;
    function Eof: Boolean; override;
    function GetDataSet: TDataSet;
    function FieldWidth(const aFieldName: string): Integer; override;
    function FieldIsNull(const aFieldName: string): Boolean; override;
    function GetFieldDisplayLabel(const aFieldName: string): string; override;
    function GetFieldValue(const aFieldName: string; aConvertNulls: Boolean): Variant; override;
    function GetFieldDisplayText(const aFieldName: string; aConvertNulls: Boolean): WideString; override;
    procedure GetFieldsList(aFieldList: TStringList); override;
    function IsBlobField(const aFieldName: string): Boolean; override;
    procedure AssignBlobFieldTo(const aFieldName: string; aDest: TObject); override;
  published
    property DataSet: TDataSet read FDataSet write SetDataSet;
    property CloseDataSet: Boolean read FCloseDataSet write FCloseDataSet default False;
    property OpenDataSet: Boolean read FOpenDataSet write FOpenDataSet default True;

    property OnCheckEOF;
    property OnClose: TNotifyEvent read FOnClose write FOnClose;
    property OnFirst;
    property OnNext;
    property OnPrior;
    property OnInit;
    property OnOpen: TNotifyEvent read FOnOpen write FOnOpen;
    property OnGetFieldValue;
  end;

function RMIsBlob(aField: TField): Boolean;
procedure RMAssignBlobTo(aBlobField: TField; aObj: TObject);
procedure RMDisableDBControls(aDataSet: TDataSet);
procedure RMEnableDBControls(aDataSet: TDataSet);

function RMStreamToVariant(aStream: TStream): OleVariant;
procedure RMVariantToStream(const aData: OleVariant; aOutStream: TStream);

implementation

type
  EDSError = class(Exception);

  TRMGraphicHeader = record
    Count: Word; // Fixed at 1
    HType: Word; // Fixed at $0100
    Size: Longint; // Size not including header
  end;

function RMStreamToVariant(aStream: TStream): OleVariant;
var
  p: Pointer;
begin
  Result := VarArrayCreate([0, aStream.Size - 1], varByte);
  p := VarArrayLock(Result);
  try
    aStream.Position := 0;
    aStream.Read(p^, aStream.Size);
  finally
    VarArrayUnlock(Result);
  end;
end;

procedure RMVariantToStream(const aData: OleVariant; aOutStream: TStream);
var
  P: Pointer;
begin
  P := VarArrayLock(aData);
  try
    aOutStream.write(P^, VarArrayHighBound(aData, 1) + 1);
    aOutStream.Position := 0;
  finally
    VarArrayUnlock(aData);
  end;
end;

{$IFDEF COMPILER6_UP}

procedure _AssignBlobToPicture(aBlobField: TBlobField; aObj: TPersistent);

  function _SupportsStreamPersist(const aPersistent: TPersistent;
    var aStreamPersist: IStreamPersist): Boolean;
  begin
    Result := (aPersistent is TInterfacedPersistent) and
      (TInterfacedPersistent(aPersistent).QueryInterface(IStreamPersist, aStreamPersist) = S_OK);
  end;

  procedure _SaveToStreamPersist(aStreamPersist: IStreamPersist);
  var
    lBlobStream: TStream;
    lSize: Longint;
    lHeader: TRMGraphicHeader;
  begin
    lBlobStream := aBlobField.DataSet.CreateBlobStream(aBlobField, bmRead);
    try
      lSize := lBlobStream.Size;
      if lSize >= SizeOf(TRMGraphicHeader) then
      begin
        lBlobStream.Read(lHeader, SizeOf(lHeader));
        if (lHeader.Count <> 1) or (lHeader.HType <> $0100) or
          (lHeader.Size <> lSize - SizeOf(lHeader)) then
          lBlobStream.Position := 0;
      end;

      aStreamPersist.LoadFromStream(lBlobStream);
    finally
      lBlobStream.Free;
    end;
  end;

var
  lStreamPersist: IStreamPersist;
begin
  if _SupportsStreamPersist(aObj, lStreamPersist) then
    _SaveToStreamPersist(lStreamPersist);
end;
{$ENDIF}

function RMIsBlob(aField: TField): Boolean;
begin
  Result := (aField <> nil) and (aField.DataType in [ftBlob..ftTypedBinary,
    ftOraBlob, ftOraClob]);
end;

procedure RMAssignBlobTo(aBlobField: TField; aObj: TObject);
begin
  if aObj is TPersistent then
  begin
    try
{$IFDEF COMPILER6_UP}
      if System.IsLibrary then
      begin
        _AssignBlobToPicture(TBlobField(aBlobField), TPersistent(aObj));
      end
      else
{$ENDIF}
        TPersistent(aObj).Assign(aBlobField);
    except
      on e: EConvertError do
      begin
{$IFDEF COMPILER6_UP}
      	if not System.IsLibrary then
        	_AssignBlobToPicture(TBlobField(aBlobField), TPersistent(aObj));
{$ENDIF}
      end;
    end;
  end
  else if aObj is TStream then
  begin
    TBlobField(aBlobField).SaveToStream(TStream(aObj));
    TStream(aObj).Position := 0;
  end;
end;

procedure RMDisableDBControls(aDataSet: TDataSet);
begin
  if aDataSet <> nil then
    aDataSet.DisableControls;
end;

procedure RMEnableDBControls(aDataSet: TDataSet);
begin
  if aDataSet <> nil then
    aDataSet.EnableControls;
end;

type
  IWideStringField = interface
    ['{679C5F1A-4356-4696-A8F3-9C7C6970A9F6}']
    function GetAsWideString: WideString;
    procedure SetAsWideString(const Value: WideString);
    function GetWideDisplayText: WideString;
    function GetWideEditText: WideString;
    procedure SetWideEditText(const Value: WideString);
    //--
    property AsWideString: WideString read GetAsWideString write SetAsWideString {inherited};
    property WideDisplayText: WideString read GetWideDisplayText;
    property WideText: WideString read GetWideEditText write SetWideEditText;
  end;

function _GetAsWideString(aField: TField): WideString;
var
  lWideField: IWideStringField;
begin
  if aField.GetInterface(IWideStringField, lWideField) then
    Result := lWideField.AsWideString
  else if (aField is TWideStringField) then
  begin
    if aField.IsNull then
      Result := ''
    else
      Result := TWideStringField(aField).Value
  end
  else
    Result := aField.AsString;
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{ TRMDataSet }

constructor TRMDataset.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  FOnAfterFirst := nil;
  RangeBegin := rmrbFirst;
  RangeEnd := rmreLast;
  //(2004-12-8 23:59 PYZFL)
  Visible := True;
  AliasName := '';
  FFieldAlias := TStringList.Create;

  RMDataSetList.Add(Self);
end;

destructor TRMDataset.Destroy;
begin
  RMDataSetList.Remove(Self);
  FFieldAlias.Free;

  inherited Destroy;
end;

function TRMDataset.IsBlobField(const aFieldName: string): Boolean;
var
  lIsBlob: Boolean;
begin
  Result := False;
  if Assigned(FOnGetIsBlobField) then
  begin
    lIsBlob := Result;
    FOnGetIsBlobField(aFieldName, lIsBlob);
    Result := lIsBlob;
  end;
end;

function TRMDataSet.FieldIsNull(const aFieldName: string): Boolean;
begin
  Result := False;
  if Assigned(FOnGetFieldIsNull) then
    FOnGetFieldIsNull(aFieldName, Result);
end;

function TRMDataSet.GetFieldDisplayLabel(const aFieldName: string): string;
begin
  Result := '';
end;

function TRMDataSet.FieldWidth(const aFieldName: string): Integer;
begin
  Result := 0;
end;

procedure TRMDataSet.AssignBlobFieldTo(const aFieldName: string; aDest: TObject);
begin
//
end;

procedure TRMDataset.Open;
begin
 //
end;

procedure TRMDataset.Close;
begin
  //
end;

procedure TRMDataset.Init;
begin
  if Assigned(FOnInit) then FOnInit(Self);
end;

procedure TRMDataset.Exit;
begin
  //
end;

procedure TRMDataset.First;
begin
  FRecordNo := 0;
  if Assigned(FOnFirst) then FOnFirst(Self);
end;

procedure TRMDataset.Last;
begin
  //
end;

procedure TRMDataset.Next;
begin
  Inc(FRecordNo);
  if not ((FRangeEnd = rmreCount) and (FRecordNo >= FRangeEndCount)) then
  begin
    if Assigned(FOnNext) then FOnNext(Self);
  end;
end;

procedure TRMDataSet.Prior;
begin
  Dec(FRecordNo);
  if Assigned(FOnPrior) then FOnPrior(Self);
end;

function TRMDataset.Eof: Boolean;
begin
  Result := False;
  if (FRangeEnd = rmreCount) and (FRecordNo >= FRangeEndCount) then Result := True;
  if Assigned(FOnCheckEOF) then FOnCheckEOF(Self, Result);
end;

function TRMDataSet.GetPropValue(aObject: TObject; aPropName: string; var aValue: Variant;
  Args: array of Variant): Boolean;
begin
  Result := inherited GetPropValue(aObject, aPropName, aValue, Args);
end;

function TRMDataSet.SetPropValue(aObject: TObject; aPropName: string;
  aValue: Variant): Boolean;
begin
  Result := inherited SetPropValue(aObject, aPropName, aValue);
end;

procedure TRMDataSet.SetFieldAlias(Value: TStringList);
begin
  FFieldAlias.Assign(Value);
end;