Error UDF realizada en Delphi

[morta71]

Hola a todos,

estoy escribiendo mi primera UDF en Delphi para calcular la edad de una persona y la muestre en una vista. La función tiene el siguiente código fuente:


uses
Windows, Messages, SysUtils, Controls;

type
{InterBase Date/Time Record}
ISC_QUAD = record
isc_quad_high : Integer ; // Date
isc_quad_low : Cardinal ; // Time
end;
PISC_QUAD = ^ISC_QUAD;

function CalculaEdad(var IBDate: PISC_QUAD): Integer; stdcall;

implementation

function CalculaEdad(var IBDate: PISC_QUAD): Integer;
var
iTemp,iTemp2,Nada:word;
Fecha: TDate;
begin
Fecha := IBDate^.isc_quad_high;

if Fecha = 0 then Result := 0
else
begin
DecodeDate(Date,itemp,Nada,Nada);
DecodeDate(Fecha,itemp2,Nada,Nada);
if FormatDateTime('mmdd',Date) <
FormatDateTime('mmdd',Fecha) then Result:=iTemp-iTemp2-1
else Result:=iTemp-iTemp2;
end;
end;

end.


Para importarla a FIREBIRD, utilizo el siguiente script:


DECLARE EXTERNAL FUNCTION GETEDAD
TIMESTAMP
RETURNS INTEGER BY VALUE
ENTRY_POINT 'CalculaEdad' MODULE_NAME 'MiUDF'


Y la Vista es algo como

SELECT GETEDAD(F_NACIMIENTO) AS EDAD FROM PERSONAS


El Caso es que, probandolo en el IBExpert, retorna siempre éste error:

Error Message:
----------------------------------------
Unsuccessful execution caused by a system error that precludes
successful execution of subsequent statements.
Error writing data to the connection.


Ya no sé que variaciones realizar, he intentado varias formas y no hay manera.

Os agradecería vuestras sugerencias al respecto, ¿qué hago mla? Gracias

[morta71]

Me respondo yo mismo, ya encontré la solución ... buf, aquí queda para quien le pueda servir.

Añadí la siguiente unidad con las definiciones que me hacian falta:


unit fb_tools;

interface

const
IBASE_DLL='FBCLIENT.DLL';

type
Int = LongInt; // 32 bit signed
DWord = Cardinal; // 32 bit unsigned
UInt = DWord; // 32 bit unsigned
Long = LongInt; // 32 bit signed
ULong = DWord; // 32 bit unsigned

TM = record
tm_sec : integer; // Seconds
tm_min : integer; // Minutes
tm_hour : integer; // Hour (0--23)
tm_mday : integer; // Day of month (1--31)
tm_mon : integer; // Month (0--11)
tm_year : integer; // Year (calendar year minus 1900)
tm_wday : integer; // Weekday (0--6) Sunday = 0)
tm_yday : integer; // Day of year (0--365)
tm_isdst : integer; // 0 if daylight savings time is not in effect)
end;
PTM = ^TM;

ISC_TIMESTAMP = record
timestamp_date : Integer;
timestamp_time : Cardinal;
end;
PISC_TIMESTAMP = ^ISC_TIMESTAMP;

procedure isc_encode_timestamp (tm_date : PTM;
ib_date : PISC_TIMESTAMP);
stdcall; external IBASE_DLL;
procedure isc_decode_timestamp (ib_date: PISC_TIMESTAMP;
tm_date: PTM);
stdcall; external IBASE_DLL;

procedure isc_decode_sql_date (var ib_date: Long;
tm_date: PTM);
stdcall; external IBASE_DLL;
procedure isc_encode_sql_date (tm_date: PTM;
var ib_date: Long);
stdcall; external IBASE_DLL;

procedure isc_decode_sql_time (var ib_date: ULong;
tm_date: PTM);
stdcall; external IBASE_DLL;
procedure isc_encode_sql_time (tm_date: PTM;
var ib_date: ULong);
stdcall; external IBASE_DLL;
implementation

end.


Así el código de la librería queda


library free_fbudf;

uses
SysUtils,
Classes,
Global in 'Global.pas',
fb_tools in 'fb_tools.pas';

{$R *.RES}

exports
CalculaEdad;

begin
isMultiThread := True;
end.



unit Global;

interface

uses
Windows, Messages, SysUtils, Controls, fb_tools;

function CalculaEdad(var ib_date: Long): Integer; stdcall;

implementation

function CalculaEdad(var ib_date: Long): Integer;
var
iTemp,iTemp2,Nada:word;
Fecha: TDate;
tm_date: TM;
begin
isc_decode_sql_date(ib_date, @tm_date);

Fecha := EncodeDate(tm_date.tm_year + 1900, tm_date.tm_mon + 1, tm_date.tm_mday);

if Fecha = 0 then Result := 0
else
begin
DecodeDate(Date,itemp,Nada,Nada);
DecodeDate(Fecha,itemp2,Nada,Nada);
if FormatDateTime('mmdd',Date) <
FormatDateTime('mmdd',Fecha) then Result:=iTemp-iTemp2-1
else Result:=iTemp-iTemp2;
end;
end;

end.



La declaración de la función en Firebird será la siguiente:


DECLARE EXTERNAL FUNCTION GETEDAD
DATE
RETURNS INTEGER BY VALUE
ENTRY_POINT 'CalculaEdad' MODULE_NAME 'free_fbudf'


Funciona correctamente, tan sólo queda contemplar aquellos casos en que la fecha de nacimeinto almacenada en la base de datos tenga un valor NULL.