Ayuda para crear eventos: Delphi snippet – RowObject

Como si me tratase del doctor Frankenstein perseguido por mi creación, decido abandonar mi retiro para afrontar a la bestia a la que un día aciago, jugando a ser programador, di vida: RowObject.pas

Sí, varias han sido las llamadas que hemos recibido últimamente de desarrolladores que se quejaban de fallos en un código que, en ciertos casos, hemos proporcionado como ejemplo de cómo manipular de manera fácil unas matrices de variants en delphi usadas en algunos eventos de a3ERP. Para evitar tener que aplicar la medicina de la escupidera de bronce a alguno (se evita leyendo algunos artículos de este blog), publicaré aquí la versión más reciente de dicha unidad.

Bien, el fragmento de código que publico a continuación contiene tres clases principalmente que nos evitarán tener que trabajar con las engorrosas matrices de matrices de variants (las matrices unidimensionales son muy fáciles de manipular, con un caramelo basta).

TDatasetObject

Esta clase encapsula lo que en el artículo en el que se describían los tipos usados en los eventos a3ERP denominé “Conjunto de datos”. Se encarga de, dado un variant que contiene un “Conjunto de datos”, o sea una lista de “Registros”, crear una lista de objetos (TRowObject) para cada uno de los registros. Permite, de esta manera, un acceso indexado a los registros. Adicionalmente permite devolver los cambios que se hayan producido en los registros al variant original.

TRowObject

Esta otra encapsula lo que en el enlace del punto anterior se denominó “Registro”. Su responsabilidad es mantener la lista de campos definidos en el registro encapsulado así como proveer de algunas facilidades para localizarlos, ya sea por índice o nombre. Además es capaz de devolver los cambios que se produjeran en los campos mantenidos al variant.

TFieldObject

La última de las tres clases simplemente permite algunas facilidades extra para manipular los valores de cada uno de los campos, al estilo de los TField, del tipo denominado “Registro”, ya encapsulado por la clase anterior.

El código: RowObject.pas

Que menos que decir que se entrega como está, con sus bugs y demás atrocidades que se puedan encontrar. La mayor versión de Delphi con la que se ha compilado es la 2006. La última vez que lo intenté, compiló. Con versiones superiores es muy posible que de problemas por el soporte UNICODE.

<br />
unit RowObject;</p>
<p>interface</p>
<p>uses<br />
  SysUtils, Classes, Contnrs;</p>
<p>type<br />
  ERowObjectException = class(Exception);<br />
  EInvalidFieldnameException = class(ERowObjectException);<br />
  EInvalidGetFieldsParameter = class(ERowObjectException);</p>
<p>  TDatasetObject = class;</p>
<p>  TRowObject = class;<br />
    TFieldObject = class<br />
  private<br />
    FIndex: Integer;<br />
    FValue,<br />
    FOldValue: Variant;<br />
    FRow: TRowObject;<br />
    FModified: Boolean;<br />
    FFieldname: string;</p>
<p>  protected<br />
    procedure SetAsBoolean(const AValue: Boolean);<br />
    procedure SetAsCurrency(const AValue: Currency);<br />
    procedure SetAsFloat(const AValue: Double);<br />
    procedure SetAsInteger(const AValue: Integer);<br />
    procedure SetAsString(const AValue: string);<br />
    function GetAsCurrency: Currency;<br />
    function GetAsInteger: Integer;<br />
    function GetAsString : string;<br />
    function GetAsBoolean: Boolean;<br />
    function GetAsFloat: Double;</p>
<p>    procedure SetValue(const Value: Variant);<br />
    procedure ApplyTo(var Line: Variant);<br />
  public<br />
    constructor Create(const AIndex: Integer; ARow: TRowObject);</p>
<p>    property AsCurrency: Currency read GetAsCurrency write SetAsCurrency;<br />
    property AsInteger: Integer read GetAsInteger write SetAsInteger;<br />
    property AsString : string read GetAsString write SetAsString;<br />
    property AsBoolean: Boolean read GetAsBoolean write SetAsBoolean;<br />
    property AsFloat: Double read GetAsFloat write SetAsFloat;</p>
<p>    property Modified: Boolean read FModified;<br />
    property Value: Variant read FValue write SetValue;<br />
    property OldValue: Variant read FOldValue;<br />
    function IsEmpty: Boolean; overload;<br />
    class function IsEmpty(AValue: Variant): Boolean; overload;<br />
    class function VarAreEqual(const Var1, Var2: Variant): Boolean;</p>
<p>    procedure CancelChange;<br />
    property Fieldname: string read FFieldname;<br />
    property Index: Integer read FIndex;<br />
    property Row: TRowObject read FRow;<br />
  end;</p>
<p>  TRowObject = class<br />
  private<br />
    FData: Variant;<br />
    FDataset: TDatasetObject;<br />
    FFields: TObjectList;<br />
    FFieldNameIndex: TStrings;<br />
  protected<br />
    function GetBufferFieldCount: Integer;<br />
    function GetBufferFieldName(const Index: Integer): string;<br />
    function GetBufferFieldValue(const Index: Integer): Variant;<br />
    procedure BuildFields;<br />
    procedure CheckIndex(const AIndex: Integer);</p>
<p>    function GetModified: Boolean;<br />
    function GetFields(const FieldNameOrIndex: Variant): TFieldObject;<br />
    function GetFieldCount: Integer;<br />
  public<br />
    constructor Create(const Line: Variant; ADatasetObject: TDatasetObject = nil); overload;<br />
    destructor Destroy; override;</p>
<p>    procedure ApplyTo(var Line: Variant);<br />
    procedure CancelChanges;<br />
    property Modified: Boolean read GetModified;</p>
<p>    function FindField(const AFieldname: string): TFieldObject;<br />
    function FieldByName(const AFieldname: string): TFieldObject;</p>
<p>    property Fields[const FieldNameOrIndex: Variant]: TFieldObject read GetFields; default;<br />
    property FieldCount: Integer read GetFieldCount;</p>
<p>    property Dataset: TDatasetObject read FDataset;<br />
  end;</p>
<p>  TDatasetObject = class<br />
  private<br />
    FRows: TObjectList;<br />
    function GetModified: Boolean;<br />
    protected<br />
    function GetCount: Integer;<br />
    function GetRows(const Index: Integer): TRowObject;<br />
  public<br />
    constructor Create; overload;<br />
    constructor Create(const Lines: Variant); overload;<br />
    destructor Destroy; override;</p>
<p>    procedure AddRow(ARow: TRowObject);<br />
    function RemoveRow(ARow: TRowObject): TRowObject;</p>
<p>    procedure ApplyTo(var Lines: Variant);<br />
    // todo: funciones de busqueda, modificado, etc...<br />
    procedure Sort(Compare: TListSortCompare);</p>
<p>    property Count: Integer read GetCount;<br />
    property Rows[const Index: Integer]: TRowObject read GetRows; default;<br />
    property Modified: Boolean read GetModified;<br />
  end;</p>
<p>implementation</p>
<p>uses<br />
  Variants;</p>
<p>{ TRowObject }</p>
<p>constructor TRowObject.Create(const Line: Variant; ADatasetObject: TDatasetObject = nil);<br />
begin<br />
  inherited Create;<br />
  FData := Line;<br />
  FFields := TObjectList.Create(True);<br />
  FFieldNameIndex := TStringList.Create;<br />
  TStringList(FFieldNameIndex).Sorted := True;<br />
  FDataset := ADatasetObject;</p>
<p>  BuildFields;<br />
end;</p>
<p>procedure TRowObject.BuildFields;<br />
var<br />
  Idx, Max: Integer;<br />
  Field: TFieldObject;<br />
begin<br />
  FFields.Clear;<br />
  FFieldNameIndex.Clear;<br />
  Max := GetBufferFieldCount - 1;<br />
  for Idx := 0 to Max do begin<br />
    Field := TFieldObject.Create(Idx, Self);<br />
    FFields.Add(Field);<br />
    FFieldNameIndex.AddObject(Field.Fieldname, Field);<br />
  end;<br />
end;</p>
<p>destructor TRowObject.Destroy;<br />
begin<br />
  FFieldNameIndex.Free;<br />
  FFields.Free;<br />
  inherited;<br />
end;</p>
<p>function TRowObject.GetBufferFieldCount: Integer;<br />
begin<br />
  Result := FData[0];<br />
end;</p>
<p>procedure TRowObject.CheckIndex(const AIndex: Integer);<br />
begin<br />
  if (AIndex &amp;gt; GetFieldCount) then<br />
    raise ERangeError.CreateFmt('Índice [%d] fuera de rango [%d, %d]', [AIndex, 0, GetFieldCount - 1]);<br />
end;</p>
<p>function TRowObject.GetBufferFieldValue(const Index: Integer): Variant;<br />
begin<br />
  CheckIndex(Index);<br />
  Result := FData[Index + 1][1];<br />
end;</p>
<p>function TRowObject.GetBufferFieldName(const Index: Integer): string;<br />
begin<br />
  CheckIndex(Index);<br />
  Result := FData[Index + 1][0];<br />
end;</p>
<p>procedure TRowObject.ApplyTo(var Line: Variant);<br />
var<br />
  Idx: Integer;<br />
begin<br />
  for Idx := 0 to FieldCount - 1 do<br />
    Fields[Idx].ApplyTo(Line);<br />
end;</p>
<p>procedure TRowObject.CancelChanges;<br />
var<br />
  Idx: Integer;<br />
begin<br />
  for Idx := 0 to FieldCount - 1 do<br />
    Fields[Idx].CancelChange;<br />
end;</p>
<p>function TRowObject.GetModified: Boolean;<br />
var<br />
  Idx: Integer;<br />
begin<br />
  for Idx := 0 to FieldCount - 1 do begin<br />
    Result := Fields[Idx].Modified;<br />
    if Result then Exit;<br />
  end;<br />
  Result := False;<br />
end;</p>
<p>function TRowObject.FieldByName(const AFieldname: string): TFieldObject;<br />
begin<br />
  Result := FindField(AFieldname);<br />
  if not Assigned(Result) then<br />
    raise EInvalidFieldnameException.CreateFmt('No se encontró campo [%s]', [AFieldname]);<br />
end;</p>
<p>function TRowObject.FindField(const AFieldname: string): TFieldObject;<br />
var<br />
  Idx: Integer;<br />
begin<br />
  Idx := FFieldNameIndex.IndexOf(UpperCase(AFieldname));<br />
  if Idx = -1 then<br />
    Result := nil<br />
  else<br />
    Result := TFieldObject(FFieldNameIndex.Objects[Idx]);<br />
end;</p>
<p>function TRowObject.GetFieldCount: Integer;<br />
begin<br />
  Result := FFields.Count;<br />
end;</p>
<p>function TRowObject.GetFields(const FieldNameOrIndex: Variant): TFieldObject;<br />
begin<br />
  if VarIsOrdinal(FieldNameOrIndex) then<br />
    Result := TFieldObject(FFields[FieldNameOrIndex])<br />
  else if VarIsStr(FieldNameOrIndex) then<br />
    Result := FieldByName(FieldNameOrIndex)<br />
  else<br />
    raise EInvalidGetFieldsParameter.Create('Parametro FieldNameOrIndex de tipo incorrecto');<br />
end;</p>
<p>{ TDatasetObject }</p>
<p>constructor TDatasetObject.Create(const Lines: Variant);<br />
var<br />
  Idx, Max: Integer;<br />
begin<br />
  Create;</p>
<p>  Max := Lines[0];<br />
  for Idx := 1 to Max do<br />
    AddRow(TRowObject.Create(Lines[Idx], Self));<br />
end;</p>
<p>constructor TDatasetObject.Create;<br />
begin<br />
  inherited Create;<br />
  FRows := TObjectList.Create;<br />
end;</p>
<p>destructor TDatasetObject.Destroy;<br />
begin<br />
  FreeAndNil(FRows);<br />
  inherited;<br />
end;</p>
<p>procedure TDatasetObject.AddRow(ARow: TRowObject);<br />
begin<br />
  FRows.Add(ARow);<br />
end;</p>
<p>procedure TDatasetObject.ApplyTo(var Lines: Variant);<br />
var<br />
  Idx: Integer;<br />
  Aux: Variant;<br />
begin<br />
  for Idx := 1 to Count do begin<br />
    Aux := Lines[Idx];<br />
    Rows[Idx - 1].ApplyTo(Aux);<br />
    VarArrayPut(Lines, Aux, [Idx]);<br />
  end;<br />
end;</p>
<p>function TDatasetObject.GetCount: Integer;<br />
begin<br />
Result := FRows.Count;<br />
end;</p>
<p>function TDatasetObject.GetModified: Boolean;<br />
var<br />
  Idx: Integer;<br />
begin<br />
  for Idx := 0 to Count - 1 do begin<br />
     Result := Rows[Idx].Modified;<br />
     if Result then Exit;<br />
  end;<br />
  Result := False;<br />
end;</p>
<p>function TDatasetObject.GetRows(const Index: Integer): TRowObject;<br />
begin<br />
  Result := TRowObject(FRows[Index]);<br />
end;</p>
<p>function TDatasetObject.RemoveRow(ARow: TRowObject): TRowObject;<br />
begin<br />
  FRows.Remove(ARow);<br />
  Result := ARow;<br />
end;</p>
<p>procedure TDatasetObject.Sort(Compare: TListSortCompare);<br />
begin<br />
  FRows.Sort(Compare);<br />
end;</p>
<p>{ TFieldObject }</p>
<p>procedure TFieldObject.CancelChange;<br />
begin<br />
  if not FModified then Exit;<br />
  FValue := FOldValue;<br />
end;</p>
<p>constructor TFieldObject.Create(const AIndex: Integer; ARow: TRowObject);<br />
begin<br />
  inherited Create;<br />
  FValue := ARow.GetBufferFieldValue(AIndex);<br />
  FFieldname := ARow.GetBufferFieldName(AIndex);</p>
<p>  FOldValue := FValue;;<br />
  FIndex := AIndex;<br />
  FRow := ARow;<br />
end;</p>
<p>procedure TFieldObject.ApplyTo(var Line: Variant);<br />
var<br />
  Aux: Variant;<br />
begin<br />
  Aux := Line[Index + 1];</p>
<p>  if VarAreEqual(Value, Aux[1]) then Exit;</p>
<p>  VarArrayPut(Aux, Value, [1]);<br />
  VarArrayPut(Line, Aux, [Index + 1]);</p>
<p>  FOldValue := FValue;<br />
end;</p>
<p>procedure TFieldObject.SetAsBoolean(const AValue: Boolean);<br />
begin<br />
  Value := AValue;<br />
end;</p>
<p>procedure TFieldObject.SetAsCurrency(const AValue: Currency);<br />
begin<br />
  Value := AValue;<br />
end;</p>
<p>procedure TFieldObject.SetAsFloat(const aValue: Double);<br />
begin<br />
  Value := AValue;<br />
end;</p>
<p>procedure TFieldObject.SetAsInteger(const AValue: Integer);<br />
begin<br />
  Value := AValue;<br />
end;</p>
<p>procedure TFieldObject.SetAsString(const AValue: string);<br />
begin<br />
  Value := AValue;<br />
end;</p>
<p>procedure TFieldObject.SetValue(const Value: Variant);<br />
begin<br />
  if (VarAreEqual(FValue, Value)) then Exit;</p>
<p>  FValue := Value;<br />
  FModified := not VarAreEqual(FValue, OldValue);<br />
end;</p>
<p>class function TFieldObject.VarAreEqual(const Var1, Var2: Variant): Boolean;<br />
begin<br />
  try<br />
    Result := VarSameValue(Var1, Var2);<br />
  except<br />
    Result := False;<br />
  end;<br />
end;</p>
<p>function TFieldObject.GetAsBoolean: Boolean;<br />
begin<br />
  if IsEmpty then<br />
    Result := False<br />
  else<br />
    Result := Value;<br />
end;</p>
<p>function TFieldObject.GetAsFloat: Double;<br />
begin<br />
if IsEmpty then<br />
     Result := 0<br />
else<br />
     Result := Value;<br />
end;</p>
<p>function TFieldObject.GetAsInteger: Integer;<br />
begin<br />
  if IsEmpty then<br />
    Result := 0<br />
  else<br />
    Result := Value;<br />
end;</p>
<p>function TFieldObject.GetAsString: string;<br />
begin<br />
  if IsEmpty then<br />
    Result := ''<br />
  else<br />
    Result := Value;<br />
end;</p>
<p>class function TFieldObject.IsEmpty(AValue: Variant): Boolean;<br />
begin<br />
  Result := VarIsNull(AValue) or (VarIsStr(AValue) and (AValue = ''));<br />
end;</p>
<p>function TFieldObject.IsEmpty: Boolean;<br />
begin<br />
  Result := TFieldObject.IsEmpty(Value);<br />
end;</p>
<p>function TFieldObject.GetAsCurrency: Currency;<br />
begin<br />
  if IsEmpty then<br />
    Result := 0<br />
  else<br />
    Result := Value;<br />
end;</p>
<p>end.<br />
&amp;lt;pre&amp;gt;

Uso

Antes de nada hay que conocer que es lo que contiene el Variant cuyo manejo queremos simplificar. Para ello os recomiendo que repaséis los siguientes artículos eventos y cambios de v7 a v8.

Directamente trabajaremos con dos clases, TDatasetObject y TRowObject. La tercera la usaremos en el momento en el que queramos consultar o alterar el valor de alguno de los campos de un registro.

TDatasetObject

Así si, por ejemplo, estuviésemos implementando un “AntesDeGuardarDocumento” en versión 8 o superior y necesitáramos modificar algún campo de la cabecera (en líneas a día de hoy no se puede desde este evento), haríamos algo tal que:

<br />
procedure ANTESDEGUARDARDOCUMENTO(Documento: string; IdDoc: Double; var Cabecera: Variant; var Lineas: Variant): boolean; stdcall;<br />
var<br />
  Dataset: TDatasetObject;<br />
begin<br />
  Dataset := TDatasetObject.Create(Cabecera);<br />
  try<br />
    Dataset.Rows[0].FieldByName('OBSERVACIONES').AsString := 'Documento con Id: ' + FormatFloat('0', IdDoc);<br />
    Dataset.ApplyTo(Cabecera);<br />
  finally<br />
    Dataset.Free;<br />
  end;<br />
end;<br />

Como podemos ver, explícitamente hemos creado un TDatasetObject pero manipulado un TRowObject y un TFieldObject.

TRowObject

En caso de que estuviéramos implementando algún evento de documentos en versión 7, o alguno de líneas de documento (por ejemplo), podemos simplificar el manipulado del registro que nos llega con esta clase de la siguiente manera:

<br />
procedure ANTESDEGUARDARLINEA(Documento: String; Cabecera: Variant; Linea: Variant): Variant; stdcall;<br />
var<br />
  Row: TRowObject;<br />
begin<br />
  Result := Null;<br />
  if Documento &amp;lt;&amp;gt; 'FV' then Exit; // Sólo en facturas de venta<br />
  Row := TRowObject.Create(Linea);<br />
  try<br />
    if Row.FieldByName('CODART').AsString = '0' then<br />
      SumarPuntosCliente(Row.FieldByName('UNIDADES').AsFloat);<br />
  finally<br />
    Row.Free;<br />
  end;<br />
end;<br />

Mejoras posibles

Hay muchas. Por ejemplo soportar versiones de Delphi UNICODE trabajando contra a3ERP con cadenas AnsiString, que no haga falta indicar el destino en los método ApplyTo (y por lo tanto queden como Apply sin más). Que el TRowObject permita construir registros al vuelo, sin necesidad de darle un variant origen, para así facilitar el devolver campos a modificar en los métodos “AntesDeGuardarLinea”, etc…

Os animo a que uséis este código y compartáis con nosotros las mejoras que introduzcáis. Para ello podéis enviarlas como comentarios a este artículo y así podremos discutirlas entre todos e incorporarlas. Hacedlo o no lo hagáis, pero sabed que una escupidera os vigila…