Programa de gestión desde 0

[[José Luis Garcí]]

Ahora voy a poner las funciones usadas

Archivo: FUN_DBGRID

La siguiente función no tiene descripción, pero lo que hace es colocar el grid con dos colores, ver en el código de los módulos para que quede más claro

Código Delphi [-]
function Zebrado(DST:TDataSource; GridsDb:TDBGrid; Rect:TRect; Column:TColumn; State:TGridDrawState; ColorA:TColor=clWhite; Colorb:TColor=clMoneyGreen; ColorSelect:TColor=clAqua):Boolean;
begin
   if not odd(DST.dataSet.RecNo) then GridsDb.Canvas.Brush.Color := Colorb
                                else GridsDb.Canvas.Brush.Color := Colora;
    TDbGrid(GridsDb).Canvas.font.Color:= clBlack;
    if gdSelected in State then
    with (GridsDb as TDBGrid).Canvas do
    begin
        Brush.Color := ColorSelect;
        FillRect(Rect);
        Font.Style := [fsbold]
    end;
     TDbGrid(GridsDb).DefaultDrawDataCell(Rect,TDbGrid(GridsDb).columns[Column.ID].field, State);
     Result:=True;
End;

Ahora pongo el módulo completo Fun_Errores:

Código Delphi [-]
unit Fun_Errores;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms;

function ErrorDetail(Error:string):string;

function ErrorX(ID:string='';
               Unidad:string='';
               Modulo:STring='';
               Mensaje:string='';
               Clase_Error:string='';
               Mensaje_Error:string='';
               B_Salir:Boolean=False;
               Color:TColor=clBtnFace;
               FontColor:TColor=clMaroon;
               Delay:Integer=500):string;

implementation
 uses UErrores;   //Modulo para mostrar el Error

//------------------------------------------------------------------------------
//***********************************************[ ErrorX ]*******
// 18/10/2011 JLGT basada en la idea del Compañero enecumene
//  Expuesta en http://www.delphiaccess.com/forum/(d...ersonalizadas/
//  Nos muestra una pantalla para los errores, que dados unos parámetros, mostrara
//  más o menos información, Devuelve como hemos cerrado
//---[Parámetros]---------------------------------------------------------------
//  Parámetro       Tipo         Por defecto    Explicación
//  --------------  -----------  -------------  --------------------------------
//  ID              string       ''             Identificador del error, nos permite encontrar a los programadores
//                                              con mayor facilidad, donde se ha producido el error si es '' no se muestra
//  Unidad          string       ''             Form si es '' no se muestra
//  Modulo          STring       ''             Donde esta el control de la Excepción (Grabar, borrar, etc) si es '' no se muestra
//  Mensaje         string       ''             Mensaje que queremos mostrar, no es eliminable
//  Clase_Error     string       ''             Clase del error (E.ClassName) si es '' no se muestra
//  Mensaje_Error   string       ''             Muestra una breve nota del por que del error, si esta dentro de la
//                                              lista de ErrorDetail, será en Español, en caso contrario muestra el mensaje originas,
//                                              si es '' no se muestra
//  B_Salir         Boolean     False           Muestra el botón salir, aparte del botón continuar(fijo),
//                                              dándonos opciones en el result diferente, por si queremos cerrar el programa después
//                                              del Error, si es false no se muestra
//  Color           TColor      clBtnFace       Color de los paneles
//  FontColor       TColor      clMaroon        Color en el que nos mostrara los textos
//  Delay           Integer     500             Parpadeo del icono de error y el mensaje de error (se alternan)
//--EJEMPLOS--------------------------------------------------------------------
//  procedure TForm1.BitBtn1Click(Sender: TObject);
//  var i : integer;
//      VarSdev:string;
//  begin
//    num:=10;
//    try
//    i := StrToInt(Edit1.Text);
//      Label1.caption := format('El cuadrado es: %d', [ i * i ]);
//    except
//         on E: Exception do
//         begin
//            VarSdev:=Errorx('125','Form1','Buton1','Error adrede',E.ClassName,E.Message,False,clTeal,clNavy,500);
//            Memo1.Lines.Add(DateToStr(now)+' - '+varsdev);
//            VarSdev:=Errorx('125','Form1','Buton1','Error adrede','','',False,clMoneyGreen,clRed,500);
//            Memo1.Lines.Add(DateToStr(now)+' - '+varsdev);
//            VarSdev:=Errorx('125','','Buton1','Error adrede',E.ClassName,E.Message,True,clMoneyGreen,clBlue,250);
//            Memo1.Lines.Add(DateToStr(now)+' - '+varsdev);
//            VarSdev:=Errorx('125','Form1','Buton1','Error adrede',E.ClassName,E.Message,False,clTeal,clPurple,500);
//            Memo1.Lines.Add(DateToStr(now)+' - '+varsdev);
//            VarSdev:=Errorx('125','Form1','Buton1','Error adrede',E.ClassName,E.Message,False,$000066FF,clAqua,50);
//            Memo1.Lines.Add(DateToStr(now)+' - '+varsdev);
//         end;
//    end;
//  end;
//------------------------------------------------------------------------------
function ErrorX(ID:string='';
               Unidad:string='';
               Modulo:STring='';
               Mensaje:string='';
               Clase_Error:string='';
               Mensaje_Error:string='';
               B_Salir:Boolean=False;
               Color:TColor=clBtnFace;
               FontColor:TColor=clMaroon;
               Delay:Integer=500):string;
begin
   try // Bajado del Club delphi   // FEnvases =form
      if not Assigned(FError) then  Ferror := TFerror.Create(nil);
      begin
          FError.LabeledEdit1.Font.Color:=FontColor;
          FError.LabeledEdit2.Font.Color:=FontColor;
          FError.LabeledEdit3.Font.Color:=FontColor;
          FError.LabeledEdit4.Font.Color:=FontColor;
          FError.Memo1.Font.Color:=FontColor;
          FError.Memo2.Font.Color:=FontColor;
          if (ID='')  then Ferror.LabeledEdit1.visible:=False
                                 else
                                 begin
                                      FError.LabeledEdit1.visible:=True;
                                      FError.LabeledEdit1.text:=ID;
                                 end;
          if (Unidad='')  then FError.LabeledEdit2.visible:=False
                                 else
                                 begin
                                      FError.LabeledEdit2.visible:=True;
                                      FError.LabeledEdit2.text:=Unidad;
                                 end;
          if (Modulo='') then FError.LabeledEdit3.visible:=False
                                 else
                                 begin
                                      FError.LabeledEdit3.visible:=True;
                                      FError.LabeledEdit3.text:=Modulo;
                                 end;
          if (Clase_Error='') then FError.LabeledEdit4.visible:=False
                                 else
                                 begin
                                      FError.LabeledEdit4.visible:=True;
                                      FError.LabeledEdit4.text:=Clase_Error;
                                 end;
          FError.Memo1.lines.Clear;
          FError.Memo1.lines.Add(Mensaje);
          if (Mensaje_Error='') then
          begin
             FError.Memo1.Height:=265;
             FError.Memo2.Visible:=False;
          end
          else
          begin
             FError.Memo1.Height:=105;
             FError.Memo2.Visible:=True;
             FError.memo2.lines.Clear;
             if errorDetail(Clase_Error)<>Clase_Error then FError.Memo2.lines.Add(errorDetail(Clase_Error)+#13#10+'---Mensaje Original---------------------------------------'+#13#10+Mensaje_Error)
                                                      else FError.Memo2.lines.Add(Mensaje_Error);
          end;
          if (B_Salir=False) then  FError.SpeedButton1.visible:=false
                               else  FError.SpeedButton1.visible:=True;
          FError.Panel1.Color:=Color;
          FError.Panel2.Color:=Color;
          FError.Timer1.interval:=Delay;
          FError.ShowModal;
      end
   finally
    Result:=FError.VarSFErrorResult;
   end;
end;


//------------------------------------------------------------------------------
//********************************************[ ErroDetail ]*******
// 18/10/2011 JLGT Si damos la Clase del error nos da un texto mas Descriptivo
//--Ejemplo---------------------------------------------------------------------
// var MenError
// ...
//  Showmessage(ErrorDetail(E.ClassName));
//------------------------------------------------------------------------------
function ErrorDetail(Error:string):string;
begin
   Result:=Error;
   if Trim(UpperCase(Error))=Trim(UpperCase('EAbort')) then Result:='Finaliza la secuencia de eventos sin mostrar el mensaje de error.';
   if Trim(UpperCase(Error))=Trim(UpperCase('EAccessViolation')) then Result:='Comprueba errores de acceso a memoria inválidos.';
   if Trim(UpperCase(Error))=Trim(UpperCase('EBitsError')) then Result:='Previene intentos para acceder a arrays de elementos booleanos. ';
   if Trim(UpperCase(Error))=Trim(UpperCase('EComponentError')) then Result:='Nos informa de un intento inválido de registrar o renombrar un componente. ';
   if Trim(UpperCase(Error))=Trim(UpperCase('EConvertError')) then Result:='Muestra un error al convertir objetos o cadenas de texto string. ';
   if Trim(UpperCase(Error))=Trim(UpperCase('EDatabaseError')) then Result:='Especifica un error de acceso a bases de datos. ';
   if Trim(UpperCase(Error))=Trim(UpperCase('EDBEditError')) then Result:='Error al introducir datos incompatibles con una máscara de texto. ';
   if Trim(UpperCase(Error))=Trim(UpperCase('EDivByZero')) then Result:='Errores de división por cero. ';
   if Trim(UpperCase(Error))=Trim(UpperCase('EExternalException')) then Result:='Significa que no reconoce el tipo de excepción (viene de fuera). ';
   if Trim(UpperCase(Error))=Trim(UpperCase('EIntOutError')) then Result:='Representa un error de entrada/salida a archivos. ';
   if Trim(UpperCase(Error))=Trim(UpperCase('EIntOverflow')) then Result:='Especifica que se ha provocado un desbordamiento de un tipo de dato. ';
   if Trim(UpperCase(Error))=Trim(UpperCase('EInvalidCast')) then Result:='Comprueba un error de conversión de tipos ';
   if Trim(UpperCase(Error))=Trim(UpperCase('EInvalidGraphic')) then Result:='Indica un intento de trabajar con gráficos que tienen un formato desconocido. ';
   if Trim(UpperCase(Error))=Trim(UpperCase('EInvalidOperation')) then Result:='Ocurre cuando se ha intentado realizar una operación inválida sobre un componente.';
   if Trim(UpperCase(Error))=Trim(UpperCase('EInvalidPointer')) then Result:='Se produce en operaciones con punteros inválidos.';
   if Trim(UpperCase(Error))=Trim(UpperCase('EMenuError')) then Result:='Controla todos los errores relacionados con componentes de menú.';
   if Trim(UpperCase(Error))=Trim(UpperCase('EOleCtrlError')) then Result:='Detecta problemas con controles ActiveX.';
   if Trim(UpperCase(Error))=Trim(UpperCase('EOleError')) then Result:='Especifica errores de automatización de objetos OLE.';
   if Trim(UpperCase(Error))=Trim(UpperCase('EPrinterError')) then Result:='Errores al imprimir.';
   if Trim(UpperCase(Error))=Trim(UpperCase('EPropertyError')) then Result:=' Ocurre cuando se intenta asignar un valor erroneo a una propiedad del componente.';
   if Trim(UpperCase(Error))=Trim(UpperCase('ERangeError')) then Result:='Indica si se intenta asignar un número entero demasiado grande a una propiedad. ';
   if Trim(UpperCase(Error))=Trim(UpperCase('ERegistryExcepcion')) then Result:='Controla los errores en el registro. ';
   if Trim(UpperCase(Error))=Trim(UpperCase('EZeroDivide')) then Result:='Controla los errores de división para valores reales. ';
   if Trim(UpperCase(Error))=Trim(UpperCase('ArgumentException')) then Result:='Pasado argumento no válido (base de excepciones de argumentos) ';
   if Trim(UpperCase(Error))=Trim(UpperCase('ArgumentNullException')) then Result:='Pasado argumento nulo';
   if Trim(UpperCase(Error))=Trim(UpperCase('ArgumentOutOfRangeException')) then Result:='Pasado argumento fuera de rango ';
   if Trim(UpperCase(Error))=Trim(UpperCase('ArrayTypeMistmatchException')) then Result:='Asignación a tabla de elemento que no es de su tipo';
   if Trim(UpperCase(Error))=Trim(UpperCase('COMException')) then Result:='Excepción de objeto COM ';
   if Trim(UpperCase(Error))=Trim(UpperCase('DivideByZeroException')) then Result:='División por cero ';
   if Trim(UpperCase(Error))=Trim(UpperCase('IndexOutOfRangeException')) then Result:='Índice de acceso a elemento de tabla fuera del rango válido (menor que cero o mayor que el tamaño de la tabla) ';
   if Trim(UpperCase(Error))=Trim(UpperCase('InvalidCastException')) then Result:='Conversión explícita entre tipos no válida ';
   if Trim(UpperCase(Error))=Trim(UpperCase('InvalidOperationException')) then Result:='Operación inválida en estado actual del objeto ';
   if Trim(UpperCase(Error))=Trim(UpperCase('InteropException')) then Result:='Base de excepciones producidas en comunicación con código inseguro ';
   if Trim(UpperCase(Error))=Trim(UpperCase('NullReferenceException')) then Result:='Acceso a miembro de objeto que vale null ';
   if Trim(UpperCase(Error))=Trim(UpperCase('OverflowException')) then Result:='Desbordamiento dentro de contexto donde se ha de comprobar los desbordamientos (expresión constante, instrucción checked, operación checked u opción del compilador /checked)';
   if Trim(UpperCase(Error))=Trim(UpperCase('OutOfMemoryException')) then Result:='Falta de memoria para crear un objeto con new ';
   if Trim(UpperCase(Error))=Trim(UpperCase('SEHException')) then Result:='Excepción SHE del API Win32 ';
   if Trim(UpperCase(Error))=Trim(UpperCase('StackOverflowException')) then Result:='Desbordamiento de la pila, generalmente debido a un excesivo número de llamadas recurrentes. ';
   if Trim(UpperCase(Error))=Trim(UpperCase('EConvertError')) then Result:='No se puede convertir esa cadena';
   if Trim(UpperCase(Error))=Trim(UpperCase('TypeInizializationException')) then Result:='Ha ocurrido alguna excepción al inicializar los campos estáticos o el constructor estático de un tipo. En InnerException se indica cuál es.';
end;

end.

[[José Luis Garcí]]

Aquí la imagen del modulo necesario para la función ErrorX



y el código del módulo

Código Delphi [-]
unit UErrores;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Buttons, StdCtrls, ExtCtrls;

type
  TFError = class(TForm)
    Panel1: TPanel;
    Image1: TImage;
    Label1: TLabel;
    LabeledEdit1: TLabeledEdit;
    LabeledEdit2: TLabeledEdit;
    LabeledEdit3: TLabeledEdit;
    Label2: TLabel;
    Timer1: TTimer;
    Memo1: TMemo;
    LabeledEdit4: TLabeledEdit;
    Label3: TLabel;
    Memo2: TMemo;
    Panel2: TPanel;
    SpeedButton1: TSpeedButton;
    SpeedButton2: TSpeedButton;
    procedure Timer1Timer(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure SpeedButton2Click(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    var VarSFErrorResult:string;
  end;

var
  FError: TFError;

implementation

{$R *.dfm}

procedure TFError.FormActivate(Sender: TObject);
//------------------------------------------------------------------------------
//******************************************[ Al Activarse ]*******
//------------------------------------------------------------------------------
begin
  if Timer1.Enabled=false then Timer1.Enabled:=True;
end;

procedure TFError.FormClose(Sender: TObject; var Action: TCloseAction);
//------------------------------------------------------------------------------
//*******************************************[ Al Cerrarse ]*******
//------------------------------------------------------------------------------
begin
  if VarSFErrorResult='' then VarSFErrorResult:='Omisión';
  if Timer1.Enabled=true then Timer1.Enabled:=False;
  if Image1.Visible=false then Image1.Visible:=True;
  if Label1.Visible=False then Label1.Visible:=True;
end;

procedure TFError.SpeedButton1Click(Sender: TObject);
//------------------------------------------------------------------------------
//************************************************[ Salir ]*******
//------------------------------------------------------------------------------
begin
  VarSFErrorResult:='Salir';
  Close;
end;

procedure TFError.SpeedButton2Click(Sender: TObject);
//------------------------------------------------------------------------------
//********************************************[ Continuar ]*******
//------------------------------------------------------------------------------
begin
 VarSFErrorResult:='Continuar';
 Close;
end;

procedure TFError.Timer1Timer(Sender: TObject);
//------------------------------------------------------------------------------
//***********************************************[ Timer ]*******
//------------------------------------------------------------------------------
begin
    if Image1.Visible=true then
    begin
          Image1.Visible:=False;
          Label1.Visible:=True;
    end else
    begin
          Image1.Visible:=True;
          Label1.Visible:=False
    end;
end;

end.

[[José Luis Garcí]]

Seguimos con las funciones

De mi archivo Fun.pas

Código Delphi [-]
//-----------------------------------------------------------------------------
//**********************************************************[ ActQuerry ]******
//  20/11/2010  JLGT  Para modificar la sentencia de un querry
//-----------------------------------------------------------------------------
//  Estudiando como poder hacer mi código mas corto se me ocurrio esta función
//  para usar un los IBQerry, para mi base de datos Firebird.
//  El tema es que cada vez que utilizo un querry y lo modifico tengo que
//  escribir unas 20 lineas y mediante este sistema, logro reducirlo a una sola
//  ya que es un, código repetitivo y soló varia el nombre del query y la
//  sentencia Sql, cree esta función
//-----------------------------------------------------------------------------
// [QRY]              Tibquery a actualizar
// [TxtSql]           Cadena de texto con sentencia SQL
// [MostrarMEnsaje]   Si muestra el mensaje de la Exception
// [RetornarMEnsaje]  Si retorna la cadena Sql que da el Error
// [RetornarQuerry]   Si retorna El querry a la cadena sql de antes del error
//-----------------------------------------------------------------------------
//  Base de datos a usar CLIENTES
//   if ActQuerry(IBQuerry1,'Select * form Clientex')=true then
//                   showmessage('Existe la base de datos')
//   else showmessage('No existe la base de datos');
//-----------------------------------------------------------------------------
Function ActQuery(QRY:TIBQuery; TxtSql:string; MostrarMensaje:boolean=VMiLogico;Retornarmensaje:boolean=VMiLogico; RetornarQuerry:boolean=VMiLogico): Boolean;
var AntSql:string;
begin
    try
      try
        AntSql:=QRY.SQL.Text;
        QRY.Active:=false;
        QRY.SQL.Clear;
        QRY.SQL.Text:=TxtSql;
        QRY.Active:=true;
        Result:=true;
      except
        on E: Exception do
        begin
           if MostrarMensaje=true then
           begin
             ShowMessage('Se ha producido un error: ' + Chr(13) + Chr(13)
                       + 'Clase de error: ' + E.ClassName + Chr(13) + Chr(13)
                       + 'Mensaje del error: ' + E.Message+ Chr(13) + Chr(13)
                       +'  '+ Chr(13) + Chr(13)
                       +'Se volvera al estado anterior');
           end;
        Result:=false;
        end;
      end;
    finally
      if Result=false then
      begin
         if Retornarmensaje=true then  ShowMessage('Sentencia Sql que ha dado Error' + Chr(13) + Chr(13)+ QRY.SQL.Text);
         if RetornarQuerry=true then
         begin
            QRY.Active:=false;
            QRY.SQL.Clear;
            QRY.SQL.Text:=AntSql;
            QRY.Active:=true;
         end;
      end;
    end;
end;

//-----------------------------------------------------------------------------
//******************************************[ ActIBDataset ]******
//  15/02/2011  JLGT  Para modificar la sentencia de un TIbdataset
//-----------------------------------------------------------------------------
//  Estudiando como poder hacer mi código mas corto se me ocurrió esta función
//  para usar un los Tibdataset basada en mi otra función ActQuerry, para mi base
//  de datos Firebird.
//  El tema es que cada vez que utilizo un Ibdtatset y lo modifico tengo que
//  escribir unas 4 lineas y mediante este sistema, logro reducirlo a una sola
//  ya que es un, código repetitivo y soló varia el nombre del Ibdtaset y la
//  sentencia Sql, cree esta función
//-----------------------------------------------------------------------------
//  Base de datos a usar CLIENTES //El error podría ser otro pero es un ejemplo
//   if ActIbdataset(IBDataset,'Select * form Clientex')=true then  showmessage('Existe la base de datos')
//                                                                              else showmessage('No existe la base de datos');
//-----------------------------------------------------------------------------
function ActIbdataset(ibdata: TIBDataSet; SQL:string):Boolean;
var VPorsiacaso:string;
begin
  VPorsiacaso:=ibdata.SelectSQL.Text;  //Por si falla
  try
    try
      ibdata.Active:=False;
      ibdata.SelectSQL.Clear;
      ibdata.SelectSQL.Add(SQL);
      ibdata.Active:=True;
      Result:=true
    except
      on E: Exception do
      begin
           ShowMessage('Se ha producido un error: ' + Chr(13) + Chr(13)
                     + 'Clase de error: ' + E.ClassName + Chr(13) + Chr(13)
                     + 'Mensaje del error: ' + E.Message+ Chr(13) + Chr(13)
                     +'  '+ Chr(13) + Chr(13)
                     +'Se volvera al estado anterior');
        Result:=false;
      end;
    end;
  finally
     if Result=false then
     begin
        ibdata.Active:=false;
        ibdata.SelectSQL.Clear;
        ibdata.SelectSQL.Add(VPorsiacaso);
        ibdata.Active:=true;
     end;
  end;
end;

//-----------------------------------------------------------------------------
//********************************************[ QuerryOC ]******
//  07/10/2011  JLGT  Para comprobar y cerrar o abrir un querry
//-----------------------------------------------------------------------------
//  Para evitar tener que repetir el mismo código una y otra vez, abreviando lo
//  considerablemente
//-----------------------------------------------------------------------------
// [QRY]              Tibquery a actualizar
// [OpenClose]        Valor Bolean True, comprueba si no esta activo y lo activa
//                                 False, hace todo lo Contrario, por defecto False
//-----------------------------------------------------------------------------
//  Querry a usar CLIENTES
//  QuerryOC(Clientes);  //Es igual que if Cliente.active=true then Clientes.active=false;
//  y QuerryOC(Clientes,True); // igual que Cliente.active=False then Clientes.active=True;
//-----------------------------------------------------------------------------
Function QuerryOC(QRY:TIBQuery; OpenClose:boolean=False): Boolean;
begin
  if OpenClose=true then
  begin
    if QRY.Active=false then QRY.Active:=true;
    Result:=True;
  end else
  begin
    if QRY.Active=true then  QRY.Active:=False;
    Result:=False;
  end;
end;


//------------------------------------------------------------------------------
//*********************************************[ SoloInteger ]****
// 14/07/2012 JLGT nos devuelve un número entero, aunque la cadena tenga letras
// en caso de no tener ninguno devuelve 0
// Nace con la idea de usarlo para las numeraciones de Documentos, así aunque tenga
// letras, nos da un numero al que podemos incrementar o usar en el método deseado
//------------------------------------------------------------------------------
// [Cadena]     String     Cadena a pasar
//------------------------------------------------------------------------------
//---Ejemplo--------------------------------------------------------------------
//  SoloInteger('A1fa120 eco89');  //=112089
//------------------------------------------------------------------------------
function SoloInteger(cadena:string):Integer;
var VarSCadena,VarSCaracter:String;
    VarIContadorFor:Integer;
begin
    VarSCadena:='';
    for VarIContadorFor := 1 to Length(cadena) do
    begin
      VarSCaracter:=Copy(cadena,VarIContadorFor,1);
      if VarSCaracter='0' then VarSCadena:=VarSCadena+'0';
      if VarSCaracter='1' then VarSCadena:=VarSCadena+'1';
      if VarSCaracter='2' then VarSCadena:=VarSCadena+'2';
      if VarSCaracter='3' then VarSCadena:=VarSCadena+'3';
      if VarSCaracter='4' then VarSCadena:=VarSCadena+'4';
      if VarSCaracter='5' then VarSCadena:=VarSCadena+'5';
      if VarSCaracter='6' then VarSCadena:=VarSCadena+'6';
      if VarSCaracter='7' then VarSCadena:=VarSCadena+'7';
      if VarSCaracter='8' then VarSCadena:=VarSCadena+'8';
      if VarSCaracter='9' then VarSCadena:=VarSCadena+'9';
    end;
    if VarSCadena='' then VarSCadena:='0';
    Result:=StrToInt(VarSCadena);
end;

Si veis que se me ha pasado poner alguna función por favor decidme lo.

[[José Luis Garcí]]

Empezamos con el módulo clientes
Aquí os pongo la imagen



Por cierto me he dado cuenta al poner la imagen en la pestaña otros datos el botón que pone siguiente debe poner anterior

y aquí como me aconsejo mamcx os pongo el enlace para que veáis el código https://gist.github.com/anonymous/5692959

[[José Luis Garcí]]

Ahora el modulo que reúne las direcciones


Aquí la imagen




Aquí el código https://gist.github.com/anonymous/5693046

[Casimiro Notevi]

Este hilo se merece estar siempre arriba, así que ahí está, como tema importante.

[[José Luis Garcí]]

Aquí el módulo que reúne los contactos y que más adelante sus datos lo usaremos en la agenda

aquí la imagen


Aquí una imagen espesificando este detalle



y aquí el código

https://gist.github.com/anonymous/5693067

existe un pequeño error en el código el correcto es

Código Delphi [-]
procedure TFContactos.FormClose(Sender: TObject; var Action: TCloseAction);
//------------------------------------------------------------------------------
//*************************************************[ Al Cerrarse El Form ]******
// Cerramos todos los procesos para que no consuman memoria y posibles errores
//------------------------------------------------------------------------------
begin
   if Timer1.Enabled=true then  Timer1.Enabled:=False;
   ActIbdataset(DM.IBDContacto,'select * from  CONTACTOS');
   //Retornos al modulo de llamada
   if VarSNomMod='CLIENTES' then FClientes.SpeedButtonBC7Click(sender); //antes ponía  FClientes.SpeedButtonBC4Click(sender);
   //Según se van creando los módulos de llamada ir añadiendo, ejmplo Proveedores, Agentes, Personal, etc
end;

[[José Luis Garcí]]

Aquí el módulo que reúne las personas de contacto

Aquí la imagen


Aquí un detalle de datos de familia


Aquí el código
https://gist.github.com/anonymous/5693094

y por último las nuevas funciones usadas de mi fichero Fun.pas

Código Delphi [-]
//------------------------------------------------------------------------------
//****************************************************[ ImputFamiliaaMemo ]****
//  Parte de la idea original de   Felipe Monteiro  del 25/05/2006
// bajada de http://www.planetadelphi.com.br/dica...tbox-com-combo)
//------------------------------------------------------------------------------
// J.L.G.T. 01/05/2013 Basando me en el código de Felipe Monteiro , lo adapte a
// mis necesidades, creando un imput de doble entrada en mi caso para insertar
// dos edit y grabarlo a a un memo
//------------------------------------------------------------------------------
//  [Memo]          TMemo      Donde grabaremos los datos
//  [Acaption]       String     Texto en la barra del caption
//  [Aprompt]        String     Texto aclaratorio para el mensaje o petición
//------------------------------------------------------------------------------
//---EJEMPLO--------------------------------------------------------------------
//  procedure TForm1.Button1Click(Sender: TObject);
//  begin
//     Label1.Caption:=ImputFamiliaaMemo(MEmo1,'Datos de familia','Nombre de la Esposa');
//  end;
//------------------------------------------------------------------------------
function ImputFamiliaaMemo(Memo:TMemo;const ACaption, APrompt: string): string;
  function GetCharSize(Canvas: TCanvas): TPoint;
  var
    I: Integer;
    Buffer: array[0..51] of Char;
  begin
    for I := 0 to 25 do Buffer[i] := Chr(I + Ord('A'));
    for I := 0 to 25 do Buffer[I + 26] := Chr(I + Ord('a'));
    GetTextExtentPoint(Canvas.Handle, Buffer, 52, TSize(Result));
    Result.X := Result.X div 52;
  end;

var
  Form: TForm;
  Prompt: TLabel;
  Combo: TSpinEdit;
  Ed:  TEdit;
  NomH:TEdit;
  Labelfec2: TLabel;
  labelnh:Tlabel;
  DialogUnits: TPoint;
  ButtonTop, ButtonWidth, ButtonHeight: Integer;
  R: TRect;
begin
  Result := '';
  Form   := TForm.Create(Application);
  with Form do
    try
      Canvas.Font     := Font;
      DialogUnits     := GetCharSize(Canvas);
      BorderStyle     := bsDialog;
      FormStyle        :=fsStayOnTop;
      Caption         := ACaption;
      ClientWidth     := MulDiv(195, DialogUnits.X, 4);
      Position        := poScreenCenter;
      Prompt          := TLabel.Create(Form);
      with Prompt do
      begin
        Parent   := Form;
        Caption  := APrompt;
        Left     := MulDiv(8, DialogUnits.X, 4);
        Top      := MulDiv(8, DialogUnits.Y, 8);
        Constraints.MaxWidth := MulDiv(180, DialogUnits.X, 4);
        WordWrap := True;
      end;
      Ed:=TEdit.Create(Form);
      with Ed do
      begin
        Parent     := Form;
        Left      := Prompt.Left;
        Top       := Prompt.top+Prompt.Height+5;
        Width     := MulDiv(180, DialogUnits.X, 4);
        Text      :='';
      end;
      Labelfec2   := TLabel.Create(Form);
      with Labelfec2 do
      begin
        Parent   := Form;
        Caption  := 'Número de hijos';
        Left     := Prompt.Left;
        Top      := ED.top+ED.Height+5;
        WordWrap := True;
      end;
      Combo := TSpinEdit.Create(Form);
      with Combo do
      begin
        Parent     := Form;
        Left      := Prompt.Left;
        Value      :=0;
        Top       := Labelfec2.top+Labelfec2.Height+5;
        Width     := MulDiv(178, DialogUnits.X, 4);
      end;
      labelnh   := TLabel.Create(Form);
      with labelnh do
      begin
        Parent   := Form;
        Caption  := 'Nombre de los hijos';
        Left     := Prompt.Left;
        Top      := Combo.top+Combo.Height+5;
        WordWrap := True;
      end;
      NomH := TEdit.Create(Form);
      with NomH do
      begin
        Parent     := Form;
        Left      := Prompt.Left;
        Top       := labelnh.top+labelnh.Height+5;
        Width     := MulDiv(180, DialogUnits.X, 4);
        Text      :='';
      end;
      ButtonTop    := NomH.top+NomH.Height+10;;
      ButtonWidth  := MulDiv(50, DialogUnits.X, 4);
      ButtonHeight := MulDiv(14, DialogUnits.Y, 8);
      with TButton.Create(Form) do
      begin
        Parent      := Form;
        Caption     := 'OK';
        ModalResult := mrOk;
        default     := True;
        SetBounds(MulDiv(Prompt.Left-2, DialogUnits.X, 4), ButtonTop, ButtonWidth,
          ButtonHeight);
      end;
      with TButton.Create(Form) do
      begin
        Parent      := Form;
        Caption     := 'Cancelar';
        ModalResult := mrCancel;
        Cancel      := True;
        SetBounds(MulDiv(137, DialogUnits.X, 4), ButtonTop,ButtonWidth, ButtonHeight);
        Form.ClientHeight :=ButtonTop+ButtonHeight+5;     //Altura
      end;
      if ShowModal = mrOk then
      begin
         if Ed.Text<>'' then  Memo.Lines.Add('Esposa:[ '+ed.Text+' ]');
         if Combo.Value<>0 then
         begin
           Memo.Lines.Add('Nº de hijos:[ '+IntToStr(Combo.Value)+' ]');
           if NomH.Text<>'' then Memo.Lines.Add('Nombre de los hijos:[ '+NomH.Text+' ]');
         end;
      end;
    finally
      Form.Free;
    end;
end;

//------------------------------------------------------------------------------
//**********************************[ FECHA_DBEDIT_ENTER ]*******
// Nueva 24/11/2010  Se encarga de Asignar una fecha si el edit esta vació
// se pone en el evento OnEnter del Dbedit
//-----------Ejemplo-------------
//   FECHA_DBEDIT(dbedit1,Fecha);
//------------------------------------------------------------------------------
//******************[ AÑADIR AL PRINCIPIO DEL unit de la función  ]*******
//    const
//   VMiAutoFECHA='';
//-----------------------------------------------------------------------------
function FECHA_DBEDIT_ENTER(dbedit:tdbedit;Fecha:String=VMiautoFecha):Tdate;
begin
    try
      try
          if dbedit.Text<>'' then dbedit.Text:=Fecha
                           else begin
                                  Fecha:=DateToStr(now);
                                  dbedit.Text:=fecha;
                                end;

       StrToDate(fecha);  //Para que se produzca una excepción si no es una fecha
      except
         on E: Exception do
         begin
              ShowMessage('Se ha producido un error: ' + Chr(13) + Chr(13)
                  + 'Clase de error: ' + E.ClassName + Chr(13) + Chr(13)
                  + 'Mensaje del error: ' + E.Message+Chr(13) + Chr(13)
                  + '    '+Chr(13) + Chr(13)
                  + 'Se anula la Fecha introducida y se asigna la del sistema');
             dbedit.Text:=DateToStr(Now);
             Fecha:=DateToStr(now);
         end;
      end;
    finally
        Result:=StrToDate(Fecha);
    end;
end;

//------------------------------------------------------------------------------
//*******************************************************[ FECHA_DBEDIT ]*******
// Nueva 23/11/2010  Se encarga de que con las teclas Arriba/abajo aumentar
//reducir un día, se pone en el evento OnKeyDown del Dbedit
//-----------Ejemplo-------------
//   FECHA_DBEDIT(dbedit1,Key);
//------------------------------------------------------------------------------
function FECHA_DBEDIT(dbedit:tdbedit; Tecla:Word):Boolean;
begin
  if (Tecla=VK_UP) then DBEdit.text:=DateToStr(StrToDate(DBEdit.Text)+1);  //Añadimos un día
  if (Tecla=VK_DOWN) then DBEdit.Text:=DateToStr(StrToDate(DBEdit.Text)-1);//Disminuimos un día
end;

[[José Luis Garcí]]

Gracias Casimiro, estaba tan metido en subir los datos que no me había fijado en que contestaste. Muchas gracias por considerarlo interesante