Para seguir con el módulo de usuarios y hacerlo bien antes he tenido que hacer el de capturas desde la webcam



A la izquierda del todo es un panel, los 5 speedbuton que veis y un timagen a la derecha. Este es el código

Código Delphi [-]
unit UCapturas;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Webcam, Buttons, ExtCtrls, jpeg, Clipbrd;      //Añadimos la unit WEBCAM y Jpeg

type
  TFCapturas = class(TForm)
    Panel1: TPanel;
    Panel2: TPanel;
    Image1: TImage;
    SpeedButton1: TSpeedButton;
    SpeedButton2: TSpeedButton;
    SpeedButton3: TSpeedButton;
    SpeedButton5: TSpeedButton;
    SpeedButton4: TSpeedButton;
    procedure SpeedButton5Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure SpeedButton3Click(Sender: TObject);
    procedure SpeedButton2Click(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
    procedure SpeedButton4Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    camera: TWebcam;  //Para la webcam
  end;

var
  FCapturas: TFCapturas;

implementation

{$R *.dfm}

USES UDM,UUsuarios;

procedure TFCapturas.FormCreate(Sender: TObject);
//------------------------------------------------------------------------------
//***********************************************************[ FormCreate ]*****
//------------------------------------------------------------------------------
begin
  camera := TWebcam.Create('WebCaptured', Panel1.Handle, 0, 0,1000, 1000);
end;

procedure TFCapturas.SpeedButton1Click(Sender: TObject);
//------------------------------------------------------------------------------
//****************************************************************[ Salir ]*****
// Cierra el formulario de capturas
//------------------------------------------------------------------------------
begin
   camera.Disconnect;
   (Sender as TSpeedButton).Caption:='Apagar camara';
   Close;
end;

procedure TFCapturas.SpeedButton2Click(Sender: TObject);
//------------------------------------------------------------------------------
//***********************************************************[ Pasar foto ]*****
// Pasa la imagen y cierra el formulario de capturas
//------------------------------------------------------------------------------
var JPGImage: TJPEGImage;
    Clip: TClipboard;
    AData: THandle;
    APalette: hPalette;
begin
   JPGImage:= TJPEGImage.Create;
   JPGImage.Assign(Image1.Picture.Bitmap);
   JPGImage.SaveToClipboardFormat(CF_PICTURE, AData,APalette);
   if VarSUnidad='UUSUARIOS' then FUsuarios.DBImage1.Picture.LoadFromClipboardFormat(CF_PICTURE, AData,APalette);
   JPGImage.Free;
   camera.Disconnect;
   SpeedButton5.Caption:='Apagar camara';
   Close;

end;

procedure TFCapturas.SpeedButton3Click(Sender: TObject);
//------------------------------------------------------------------------------
//**************************************************************[ Captura ]*****
//------------------------------------------------------------------------------
var
  PanelDC: HDC;
begin
if not Assigned(Image1.Picture.Bitmap) then Image1.Picture.Bitmap := TBitmap.Create
  else
  begin
    Image1.Picture.Bitmap.Free;
    Image1.picture.Bitmap := TBitmap.Create;
  end;
  Image1.Picture.Bitmap.Height := Panel1.Height;
  Image1.Picture.Bitmap.Width  := Panel1.Width;
  Image1.Stretch := True;
  PanelDC := GetDC(Panel1.Handle);
  try
    BitBlt(Image1.Picture.Bitmap.Canvas.Handle,0,0,Panel1.Width, Panel1.Height, PanelDC, 0,0, SRCCOPY);
  finally
    ReleaseDC(Handle, PanelDC);
  end;
end;

procedure TFCapturas.SpeedButton4Click(Sender: TObject);
//------------------------------------------------------------------------------
//*******************************************************[ Iniciar cámara ]*****
//------------------------------------------------------------------------------
begin
  camera.Connect;
  camera.Preview(true);
  Camera.PreviewRate(4);
  SpeedButton4.Enabled:=False;
  SpeedButton5.Enabled:=True;
  SpeedButton5.Caption:='Apagar camara';
end;

procedure TFCapturas.SpeedButton5Click(Sender: TObject);
//------------------------------------------------------------------------------
//***********************************************[ Encender/apagar cámara ]*****
//------------------------------------------------------------------------------
const //Gran parte de este código ha sido bajado de http://www.clubdelphi.com/foros/showthread.php?t=67582
  str_Connect = 'Encender la camara';
  str_Disconn = 'Apagar la camara';
begin
  if (Sender as TSpeedButton).Caption = str_Connect then  begin

    camera.Connect;
    camera.Preview(true);
    Camera.PreviewRate(4);
    (Sender as TSpeedButton).Caption:=str_Disconn;
  end
  else begin
    camera.Disconnect;
    (Sender as TSpeedButton).Caption:=str_Connect;
  end;
END;

end.

Podéis ver que llamamos a una unit webcam este es su código

Código Delphi [-]
unit Webcam;
interface
uses
  Windows, Messages;
type
  TWebcam = class
    constructor Create(
      const WindowName: String = '';
      ParentWnd: Hwnd = 0;
      Left: Integer = 0;
      Top: Integer = 0;
      Width: Integer = 0;
      height: Integer = 0;
      Style: Cardinal = WS_CHILD or WS_VISIBLE;
      WebcamID: Integer = 0);
    public
      const
        WM_Connect     = WM_USER + 10;
        WM_Disconnect  = WM_USER + 11;
        WM_GrabFrame   = WM_USER + 60;
        WM_SaveDIB     = WM_USER + 25;
        WM_Preview     = WM_USER + 50;
        WM_PreviewRate = WM_USER + 52;
        WM_Configure   = WM_USER + 41;
    public
      procedure Connect;
      procedure Disconnect;
      procedure GrabFrame;
      procedure SaveDIB(const FileName: String = 'webcam.bmp');
      procedure Preview(&on: Boolean = True);
      procedure PreviewRate(Rate: Integer = 42);
      procedure Configure;
    private
      CaptureWnd: HWnd;
  end;
implementation
function capCreateCaptureWindowA(
  WindowName: PChar;
  dwStyle: Cardinal;
  x,y,width,height: Integer;
  ParentWin: HWnd;
  WebcamID: Integer): Hwnd; stdcall external 'AVICAP32.dll';
{ TWebcam }
procedure TWebcam.Configure;
begin
  if CaptureWnd <> 0 then
    SendMessage(CaptureWnd, WM_Configure, 0, 0);
end;
procedure TWebcam.Connect;
begin
  if CaptureWnd <> 0 then
    SendMessage(CaptureWnd, WM_Connect, 0, 0);
end;
constructor TWebcam.Create(const WindowName: String; ParentWnd: Hwnd; Left, Top,
  Width, height: Integer; Style: Cardinal; WebcamID: Integer);
begin
  CaptureWnd := capCreateCaptureWindowA(PChar(WindowName), Style, Left, Top, Width, Height,
    ParentWnd, WebcamID);
end;
procedure TWebcam.Disconnect;
begin
  if CaptureWnd <> 0 then
    SendMessage(CaptureWnd, WM_Disconnect, 0, 0);
end;
procedure TWebcam.GrabFrame;
begin
  if CaptureWnd <> 0 then
    SendMessage(CaptureWnd, WM_GrabFrame, 0, 0);
end;
procedure TWebcam.Preview(&on: Boolean);
begin
  if CaptureWnd <> 0 then
    if &on then
      SendMessage(CaptureWnd, WM_Preview, 1, 0)
    else
      SendMessage(CaptureWnd, WM_Preview, 0, 0);
end;
procedure TWebcam.PreviewRate(Rate: Integer);
begin
  if CaptureWnd <> 0 then
    SendMessage(CaptureWnd, WM_PreviewRate, Rate, 0);
end;
procedure TWebcam.SaveDIB(const FileName: String);
begin
  if CaptureWnd <> 0 then
    SendMessage(CaptureWnd, WM_SaveDIB, 0, Cardinal(PChar(FileName)));
end;
end.

Comentar que en el DataModule (DM) esta la variable fija VarSUnidad, a la que le hemos asignado el valor de UUSUARIOS desde el módulo de usuarios, cuando estemos en clientes haremos los mismo pero dando el nombre de clientes, así el mismo módulo sirve para varios apartados, igual pasa con el editor aunque este trabajara con ciertas diferencias.

En el módulo Ueditor cambiamos el siguiente procedimiento para que sepamos a que unidad debemos devolver el dato

Código Delphi [-]
procedure TFeditor.SBOkClick(Sender: TObject);
//------------------------------------------------------------------------------
//*****************************************************************[ SBOk ]*****
// Graba los datos en la variable y salimos
//------------------------------------------------------------------------------
begin
   VarSMEMO:=Memo1.Lines.Text;
   if VarSUnidad='UUSUARIOS' then FUsuarios.MEmoNotas.Lines:=Memo1.Lines;
   Close;
end;

Bueno ya tengo terminado el módulo fuentes y algunas cosas más que ahora comentaré pero hoy no he terminado





Como ya dije esta es la única vez en colocare todo el código directamente así y lo comentaré salvo que entremos en cosas nuevas.

Código Delphi [-]
unit UUsuarios;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, DB, Buttons, DBCtrls, ComCtrls, ExtCtrls, StdCtrls, Grids, DBGrids,
  Mask, ExtDlgs;    //Añadimos la unit WEBCAM

type
  TFUsuarios = class(TForm)
    Botonera1: TPanel;
    Botonera2: TPanel;
    StatusBar1: TStatusBar;
    DBNavigator1: TDBNavigator;
    SBNuevo: TSpeedButton;
    SBEditar: TSpeedButton;
    SBBorrar: TSpeedButton;
    SBSalir: TSpeedButton;
    SBBuscar: TSpeedButton;
    DsPrincipal: TDataSource;
    Panelcontenedor: TPanel;
    PanelDatos: TPanel;
    Label1: TLabel;
    DBECodigo: TDBEdit;
    Label2: TLabel;
    DBENombre: TDBEdit;
    Label3: TLabel;
    DBEClave: TDBEdit;
    Label4: TLabel;
    DBETelefono: TDBEdit;
    Label5: TLabel;
    DBEMovil: TDBEdit;
    Label6: TLabel;
    DBEEmail: TDBEdit;
    Label7: TLabel;
    DBImage1: TDBImage;
    Notas: TLabel;
    MEmoNotas: TMemo;
    DBENivel: TDBEdit;
    SBMas: TSpeedButton;
    Label8: TLabel;
    SBMenos: TSpeedButton;
    PanelOculto: TPanel;
    SpeedButton8: TSpeedButton;
    SpeedButton9: TSpeedButton;
    SpeedButton10: TSpeedButton;
    SBEditMemo: TSpeedButton;
    SpeedButton12: TSpeedButton;
    SBWebCam: TSpeedButton;
    SBCargar: TSpeedButton;
    DBGrid1: TDBGrid;
    PanelMover: TPanel;
    sbSubir: TSpeedButton;
    SbBajar: TSpeedButton;
    Label9: TLabel;
    Edit1: TEdit;
    SpeedButton16: TSpeedButton;
    SpeedButton17: TSpeedButton;
    OpenPictureDialog1: TOpenPictureDialog;
    Label10: TLabel;
    procedure SBSalirClick(Sender: TObject);
    procedure sbSubirClick(Sender: TObject);
    procedure SbBajarClick(Sender: TObject);
    procedure SBNuevoClick(Sender: TObject);
    procedure SBEditarClick(Sender: TObject);
    procedure SBBorrarClick(Sender: TObject);
    procedure SBBuscarClick(Sender: TObject);
    procedure SBMasClick(Sender: TObject);
    procedure SBMenosClick(Sender: TObject);
    procedure FormKeyPress(Sender: TObject; var Key: Char);
    procedure SpeedButton8Click(Sender: TObject);
    procedure SpeedButton9Click(Sender: TObject);
    procedure SBCargarClick(Sender: TObject);
    procedure SBWebCamClick(Sender: TObject);
    procedure SBEditMemoClick(Sender: TObject);
    procedure SpeedButton17Click(Sender: TObject);
    procedure SpeedButton16Click(Sender: TObject);
    procedure DsPrincipalDataChange(Sender: TObject; Field: TField);
    procedure FormActivate(Sender: TObject);
    procedure comprobar;

  private
    { Private declarations }
  public
    { Public declarations }

  end;

var
  FUsuarios: TFUsuarios;

implementation

{$R *.dfm}

USES UDM,UEditor,funciones,UCapturas;

procedure TFUsuarios.comprobar;
//------------------------------------------------------------------------------
//************************************************************[ comprobar ]*****
//------------------------------------------------------------------------------
begin
      if FUsuarios.Active then
   begin
      if not (DsPrincipal.DataSet.State in [dsEdit,dsInsert]) then
      begin
         if not (DM.IBDUsuarios.IsEmpty) then
         begin
            if DBEClave.Text<>'' then Label10.Caption:=desencriptar(dbeclave.Field.Value,2112) else  Label10.Caption:='';
            if DsPrincipal.DataSet.FieldByName('NOTAS').Value<>'' then MEmoNotas.Lines.Text:=DsPrincipal.DataSet.FieldByName('NOTAS').AsString
                                                                  else MEmoNotas.Lines.Clear;
         end;
      end;
   end;
end;

procedure TFUsuarios.DsPrincipalDataChange(Sender: TObject; Field: TField);
//------------------------------------------------------------------------------
//******************************************************[ Cambia de datos ]*****
//------------------------------------------------------------------------------
begin
   comprobar;
end;

procedure TFUsuarios.FormActivate(Sender: TObject);
//------------------------------------------------------------------------------
//**********************************************************[ On Activate ]*****
//------------------------------------------------------------------------------
begin
   comprobar;
   if VarIModoApertura=1 then  SBNuevoClick(sender);

end;

procedure TFUsuarios.FormKeyPress(Sender: TObject; var Key: Char);
//------------------------------------------------------------------------------
//************************************************[  Al pulsar una tecla ]******
// Al pulsar la tecla salta al foco del siguiente componente, si esta admitido
//------------------------------------------------------------------------------
begin
    if (Key = #13) then {Si se ha pulsado enter }
    if (ActiveControl is TEdit)
    or (ActiveControl is TDBEdit)
    or (ActiveControl is TDBComboBox) then
    begin
      Key := #0; { anula la puulsación }
      Perform(WM_NEXTDLGCTL, 0, 0); { mueve al próximo control }
    end
end;

procedure TFUsuarios.SbBajarClick(Sender: TObject);
//------------------------------------------------------------------------------
//**************************************************************[ SBBajar ]*****
//------------------------------------------------------------------------------
begin
  DsPrincipal.DataSet.Prior;
end;

procedure TFUsuarios.SBBorrarClick(Sender: TObject);
//------------------------------------------------------------------------------
//*******************************************[ Borrar el Actual Registro ]******
//------------------------------------------------------------------------------
begin                                //Cambiar por el mensaje elegido
   if (MessageBox(0, '¿Esta seguro  de eliminar el registro actual?',   //Aqui no se porque me manda la última comilla simple y la coma a la linea de abajo, por favor subir al final de la linea anterior
   'Eliminar Registro', MB_ICONSTOP or MB_YESNO or MB_DEFBUTTON2) = ID_No) then abort
   else begin
      DSPrincipal.DataSet.Delete;
      DM.IBT.CommitRetaining;
      ShowMessage('El registro ha sido eliminado');
   end;
end;

procedure TFUsuarios.SBBuscarClick(Sender: TObject);
//------------------------------------------------------------------------------
//******************************************************[ Abrir Búsqueda ]******
//------------------------------------------------------------------------------
begin
   Botonera2.Visible:=True;
   Edit1.SetFocus;
end;

procedure TFUsuarios.SBCargarClick(Sender: TObject);
//------------------------------------------------------------------------------
//*********************************************************[ Cargar imagen ]****
//------------------------------------------------------------------------------
begin
  CargaIimagenADBImagen(OpenPictureDialog1,DBImage1);
end;

procedure TFUsuarios.SBEditarClick(Sender: TObject);
//------------------------------------------------------------------------------
//*******************************************[ Editar el actual registro ]******
//------------------------------------------------------------------------------
begin
   if DsPrincipal.DataSet.IsEmpty<>true then
   begin
      DSPrincipal.DataSet.Edit;
      PanelDatos.Enabled:=True;
      PanelOculto.Visible:=True;
      PanelMover.Enabled:=False;
      Botonera1.Enabled:=false;
      DBEClave.Field.Value:=desencriptar(dbeclave.Field.Value,2112);
      DBENombre.SetFocus;
   end else ShowMessage('No hay tregistros disponibles para editar')
end;

procedure TFUsuarios.SBEditMemoClick(Sender: TObject);
//------------------------------------------------------------------------------
//******************************************************[ Editor del memo ]*****
//------------------------------------------------------------------------------
begin
     VarSUnidad:='UUSUARIOS';
     VarSMEMO:=MEmoNotas.Lines.Text;
     Feditor.Memo1.Lines:=MEmoNotas.Lines;
     Feditor.Show;
end;

procedure TFUsuarios.SBNuevoClick(Sender: TObject);
//------------------------------------------------------------------------------
//**************************************************************[ SBnuevo ]*****
//------------------------------------------------------------------------------
var VarIRegistro:Integer;
begin
    DsPrincipal.DataSet.Insert;
    VarIRegistro:=DM.IBDConfiguracionNUMERADOR_USUARIOS.Value;
    VarIRegistro:=VarIRegistro+1;
    DBECodigo.Field.Value:=IntToStr(VarIRegistro);
    MEmoNotas.Lines.Clear;
    if VarIModoApertura=1 then
    begin
      SBMas.Enabled:=False;
      SBMenos.Enabled:=False;
      DBENivel.Field.Value:=8;

    end else DBENivel.Field.Value:=5;
    PanelDatos.Enabled:=True;
    PanelOculto.Visible:=True;
    PanelMover.Enabled:=False;
    Botonera1.Enabled:=false;
    VarIModoApertura:=0;
    DBENombre.SetFocus;
end;

procedure TFUsuarios.SBSalirClick(Sender: TObject);
//------------------------------------------------------------------------------
//**************************************************************[ SBSalir ]*****
//------------------------------------------------------------------------------
begin
  Close;
end;

procedure TFUsuarios.sbSubirClick(Sender: TObject);
//------------------------------------------------------------------------------
//**************************************************************[ SBSubir ]*****
//------------------------------------------------------------------------------
begin
  DsPrincipal.DataSet.Next;
end;

procedure TFUsuarios.SBWebCamClick(Sender: TObject);
//------------------------------------------------------------------------------
//***************************************************************[ Webcam ]*****
//------------------------------------------------------------------------------
begin
  VarSUnidad:='UUSUARIOS';
  FCapturas.show;
end;

procedure TFUsuarios.SpeedButton16Click(Sender: TObject);
//------------------------------------------------------------------------------
//****************************************************[ Salir de búsqueda ]*****
//------------------------------------------------------------------------------
begin
   Edit1.Text:='';
   Botonera2.Visible:=False;
end;

procedure TFUsuarios.SpeedButton17Click(Sender: TObject);
//------------------------------------------------------------------------------
//***********************************************[ ejecutamos la búsqueda ]*****
//------------------------------------------------------------------------------
begin
   DSPrincipal.DataSet.Locate('NOMBRE',Edit1.Text,[loCaseInsensitive,loPartialKey]);
end;

procedure TFUsuarios.SpeedButton8Click(Sender: TObject);
//------------------------------------------------------------------------------
//*****************************************************[ Cancelar Proceso]******
//------------------------------------------------------------------------------
begin
  if DsPrincipal.DataSet.State in [dsEdit,dsInsert] then DSPrincipal.DataSet.Cancel;
  DM.IBT.RollbackRetaining;   //Donde IBT es el nombre de su Ibtrasaction, con ruta
  PanelOculto.Visible:=False;
  Botonera1.Enabled:=True;
  PanelMover.Enabled:=True;
  PanelDatos.Enabled:=False;
end;

procedure TFUsuarios.SpeedButton9Click(Sender: TObject);
//------------------------------------------------------------------------------
//********************************************************[ Grabar datos ]******
//------------------------------------------------------------------------------
 var VarIFase:Integer;
begin
  try
    VarIFase:=1;
    DM.IBDUsuariosCLAVE.Value:=encriptar(DM.IBDUsuariosCLAVE.Value,2112);
    if DsPrincipal.DataSet.State in [dsInsert] then VarBGrabarNumerador:=True else VarBGrabarNumerador:=False;
    if DsPrincipal.DataSet.State in [dsEdit,dsInsert] then DSPrincipal.DataSet.Post;
    if VarBGrabarNumerador=true then
    begin
      VarIFase:=2;
      DM.IBDConfiguracion.Edit;
      DM.IBDConfiguracionNUMERADOR_USUARIOS.Value:=StrToInt(DBECodigo.Field.Value);
      DM.IBDConfiguracion.Post;
      VarBGrabarNumerador:=False;
    end;
    DM.IBT.CommitRetaining;    //Donde IBT es el nombre de su Ibtrasaction, con ruta
    if SBMas.Enabled=false then
    begin
      SBMas.Enabled:=True;
      SBMenos.Enabled:=True;
    end;
  except
    on E: Exception do
    begin
        MessageBeep(1000);
        ShowMessage('Se ha producido un error y el proceso no se ha podido terminar   Unidad:[ UUsuarios ]   Modulo:[ Grabar ]' + 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)
                  + 'El proceso ha quedado interrumpido');
        if DsPrincipal.DataSet.State in [dsEdit,dsInsert] then DSPrincipal.DataSet.Cancel;
        DM.IBT.RollbackRetaining;    //Donde IBT es el nombre de su Ibtrasaction, con ruta
    end;
  end;

  PanelOculto.Visible:=False;
  PanelDatos.Enabled:=False;
  Botonera1.Enabled:=True;
  PanelMover.Enabled:=True;
end;

procedure TFUsuarios.SBMasClick(Sender: TObject);
//------------------------------------------------------------------------------
//****************************************************************[ SBMas ]*****
// Aumenta en 1  el nivel del usuario
// No dejando que supere el 9
//------------------------------------------------------------------------------
begin
  if DBENivel.Field.Value<9 then DBENivel.Field.value:=DBENivel.Field.value+1;
end;

procedure TFUsuarios.SBMenosClick(Sender: TObject);
//------------------------------------------------------------------------------
//**************************************************************[ SBMenos ]*****
// Disminuye 1  el nivel del usuario
// No dejando que sea inferior a 1
//------------------------------------------------------------------------------
begin
  if DBENivel.Field.Value>1 then DBENivel.Field.value:=DBENivel.Field.value-1;
end;

en

Podemos ver como simplemente llamamos a los formularios de capturas

Código Delphi [-]
procedure TFUsuarios.SBWebCamClick(Sender: TObject);
//------------------------------------------------------------------------------
//***************************************************************[ Webcam ]*****
//------------------------------------------------------------------------------
begin
  VarSUnidad:='UUSUARIOS';
  FCapturas.show;
end;

O al editor

Código Delphi [-]
procedure TFUsuarios.SBEditMemoClick(Sender: TObject);
//------------------------------------------------------------------------------
//******************************************************[ Editor del memo ]*****
//------------------------------------------------------------------------------
begin
     VarSUnidad:='UUSUARIOS';
     VarSMEMO:=MEmoNotas.Lines.Text;
     Feditor.Memo1.Lines:=MEmoNotas.Lines;
     Feditor.Show;
end;

También tenemos la carga de una imagen mediante el siguiente código (al final pondré las funciones)

Código Delphi [-]
procedure TFUsuarios.SBEditarClick(Sender: TObject);
//------------------------------------------------------------------------------
//*******************************************[ Editar el actual registro ]******
//------------------------------------------------------------------------------
begin
   if DsPrincipal.DataSet.IsEmpty<>true then
   begin
      DSPrincipal.DataSet.Edit;
      PanelDatos.Enabled:=True;
      PanelOculto.Visible:=True;
      PanelMover.Enabled:=False;
      Botonera1.Enabled:=false;
      DBEClave.Field.Value:=desencriptar(dbeclave.Field.Value,2112);
      DBENombre.SetFocus;
   end else ShowMessage('No hay tregistros disponibles para editar')
end;

Pero en especial sería el botón nuevo, que no solo controla los paneles, además cargamos el numerador de configuración y controla si es el primer usuario marcándolo con el nivel de supervisor

En el caso de edición además hemos tenido en cuenta que la base no este vacía, evitando un error sin sentido muchas veces lo mismo que en el borrado

Confirmar hace varias cosas primero mira en que fase se puede producir el error, luego encripta la clave del usuario, para que no sea visible salvo desde el programa, luego añade el numerador el nuevo registro igualando el código y si no ha habido errores seguimos normalmente, cancelando todos los nuevos datos en caso contrario.


Creo que el resto es bastante sencillo.

Tened en cuenta que hay variables declarada en el DM y que no encontrareis en el formulario

Este es el módulo de funciones hasta este momento

Código Delphi [-]
unit Funciones;

interface

uses ExtDlgs,DBCtrls, Graphics,Clipbrd, SysUtils;



//------------------------------------------------------------------------------
//*************************************************[ CargaIimagenADBImagen ]****
//  Parte de la idea original de   ??? 09/06/2013
// bajada de http://www.planetadelphi.com.br/dica...-um-campo-blob
//------------------------------------------------------------------------------
// Pequeñas modificaciones y convertido a unción por mi permitiendo cargar varios
// tipos de imágenes diferentes
//------------------------------------------------------------------------------
//  [Dialog]  TOpenPictureDialog   Dialogo de cargad de la imagen
//  [Dbimage] TDBImage            El nº de cuenta de 10 digitos usar la funcion ceros
//------------------------------------------------------------------------------
//---EJEMPLO--------------------------------------------------------------------
//  CargaIimagenADBImagen:(OpenPictureDialog1,Dbimage1);
//------------------------------------------------------------------------------

function CargaIimagenADBImagen(Dialog:TOpenPictureDialog;Dbimage:TDBImage):Boolean;


 //------------------------------------------------------------------------------
//**********************************************************[ ENCRIPTAR ]*******
//  Encripta una cadena segun un valor integer
//  BAJADO DE AJPDSOFT
//------------------------------------------------------------------------------
function encriptar(aStr: String; aKey: Integer): String;



//------------------------------------------------------------------------------
//*******************************************************[ DESENCRIPTAR ]*******
//  Desencripta una cadena segun un valor integer (El mismo que para encriptarla
//  BAJADO DE AJPDSOFT
//------------------------------------------------------------------------------
function desencriptar(aStr: String; aKey: Integer): String;

implementation

//------------------------------------------------------------------------------
//*************************************************[ CargaIimagenADBImagen ]****
//  Parte de la idea original de   ??? 09/06/2013
// bajada de http://www.planetadelphi.com.br/dica...-um-campo-blob
//------------------------------------------------------------------------------
// Pequeñas modificaciones y convertido a unción por mi permitiendo cargar varios
// tipos de imágenes diferentes
//------------------------------------------------------------------------------
//  [Dialog]  TOpenPictureDialog   Dialogo de cargad de la imagen
//  [Dbimage] TDBImage            El nº de cuenta de 10 digitos usar la funcion ceros
//------------------------------------------------------------------------------
//---EJEMPLO--------------------------------------------------------------------
//  CargaIimagenADBImagen:(OpenPictureDialog1,Dbimage1);
//------------------------------------------------------------------------------

function CargaIimagenADBImagen(Dialog:TOpenPictureDialog;Dbimage:TDBImage):Boolean;
var imagem : TPicture;
begin
  if Dialog.Execute then
  begin
    try
      imagem:=TPicture.Create;
      imagem.LoadFromFile(Dialog.FileName);
      Clipboard.Assign(imagem);
      Dbimage.PasteFromClipboard;
      imagem.Free;
      Result:=True;
    except on E: Exception do
      Result:=False;
    end;
  end;
end;


//------------------------------------------------------------------------------
//**********************************************************[ ENCRIPTAR ]*******
//  Encripta una cadena segun un valor integer
//  BAJADO DE AJPDSOFT
//------------------------------------------------------------------------------
function encriptar(aStr: String; aKey: Integer): String;
begin
   Result:='';
   RandSeed:=aKey;
   for aKey:=1 to Length(aStr) do
       Result:=Result+Chr(Byte(aStr[aKey]) xor random(256));
end;


//------------------------------------------------------------------------------
//*******************************************************[ DESENCRIPTAR ]*******
//  Desencripta una cadena segun un valor integer (El mismo que para encriptarla
//  BAJADO DE AJPDSOFT
//------------------------------------------------------------------------------
function desencriptar(aStr: String; aKey: Integer): String;
begin
   Result:='';
   RandSeed:=aKey;
   for aKey:=1 to Length(aStr) do
       Result:=Result+Chr(Byte(aStr[aKey]) xor random(256));
end;

end.

Y estas las variables del módulo DM

Código Delphi [-]
var
  DM: TDM;
  VarSMEMO: string;
  Ventana: hwnd; //Handle de la ventana de captura
  VarSUnidad: string;
  VarBGrabarNumerador:Boolean;
  VarIModoApertura:Integer;
  VarSUsuario:string;
  VarINivelUSuario:Integer;

Se me olvido comentar en el módulo de usuarios el procedure comprobar al que llamamos desde el onactive y desde el OnDataChange desde nuestro datasource

Código Delphi [-]
//------------------------------------------------------------------------------
//************************************************************[ comprobar ]*****
//------------------------------------------------------------------------------
begin
      if FUsuarios.Active then
   begin
      if not (DsPrincipal.DataSet.State in [dsEdit,dsInsert]) then
      begin
         if not (DM.IBDUsuarios.IsEmpty) then
         begin
            if DBEClave.Text<>'' then Label10.Caption:=desencriptar(dbeclave.Field.Value,2112) else  Label10.Caption:='';
            if DsPrincipal.DataSet.FieldByName('NOTAS').Value<>'' then MEmoNotas.Lines.Text:=DsPrincipal.DataSet.FieldByName('NOTAS').AsString
                                                                  else MEmoNotas.Lines.Clear;
         end;
      end;
   end;
end;

Primero comprobamos que el formulario este activo
Luego que el datasoruce no este en edición o inserción en este momento
El siguiente paso es que la base de datos no este vacía
Y por último pasamos la traducción de la clave a un label y colocamos el texto que corresponde en nuestro memoNotas

Ya por último en esta semana pondré parte del Onactive del menú, ya que en el nos aseguramos de 2 cosas, primero que la tabla configuración tenga unos datos básicos y segundo de crear un primer usuario con nivel supervisor.

Código Delphi [-]
//------------------------------------------------------------------------------
//***********************************************************[ OnActivate ]*****
//------------------------------------------------------------------------------
 var VarSClaveIntroducida:String;
begin
   if FMENU.Active=True then
   begin
       if DM.IBDConfiguracion.IsEmpty then
       begin
         try
           DM.IBDConfiguracion.Insert;
           DM.IBDConfiguracionNUMERADOR_CLIENTE.Value:=0;
           DM.IBDConfiguracionNUMERADOR_UNIDAD.Value:=0;
           DM.IBDConfiguracionNUMERADOR_VALOR_ALQUILER.Value:=0;
           DM.IBDConfiguracionNUMERADOR_ALQUILER.Value:=0;
           DM.IBDConfiguracionNUMERADOR_CAJA.Value:=0;
           DM.IBDConfiguracionNUMERADOR_MOVIMIENTOS.Value:=0;
           DM.IBDConfiguracionNUMERADOR_FORMATO.Value:=0;
           DM.IBDConfiguracionNUMERADOR_FORMA_PAGO.Value:=0;
           DM.IBDConfiguracionNUMERADOR_CARGOS.Value:=0;
           DM.IBDConfiguracionNUMERADOR_GENERO.Value:=0;
           DM.IBDConfiguracionNUMERADOR_USUARIOS.Value:=0;
           DM.IBDConfiguracionSEGUNDOS_RETENIDOS.Value:=2;
           DM.IBDConfiguracionSALTO_REGISTROS.Value:=20;
           DM.IBDConfiguracionCOLOR_DISPONIBLE.Value:='clmoneygreen';
           DM.IBDConfiguracionCOLOR_NO_DISPONIBLE.Value:='clwhite';
           DM.IBDConfiguracionCOLOR_BLOQUEADA.Value:='clred';
           DM.IBDConfiguracion.Post;
           ShowMessage('Se ha creado los datos mínimos de la configuración, debe terminar de rellenar los datos' +
                       'de configuración'+ Chr(13) + Chr(13)+
                       '   --- Este proceso no se volvera a repetir ---');
         except
            on E: Exception do
            begin
                MessageBeep(1000);
                ShowMessage('Se ha producido un error y el proceso no se ha podido terminar   Unidad:[ UMEnu ]   Modulo:[ OnActive ]' + 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)
                          + 'El proceso ha quedado interrumpido');

                DM.IBT.RollbackRetaining;
            end;
         end;
       end;
       if DM.IBDUsuarios.IsEmpty then
       begin
         MessageBeep(1000);
         ShowMessage('SE va a crear el usuario supervisor. '+#13+#10+ #13+#10+
                     'Sin este no es posible crear nuevos usuarios'+#13+#10+ #13+#10+
                     'Recuerde los niveles son los siguientes:'+#13+#10+ #13+#10+
                     '[6] Usuario normal'+#13+#10+ #13+#10+
                     '[7] Usuario con privilegios (se le mostrará más información).'+#13+#10+ #13+#10+
                     '[8] Supervisor. Apartir de este nivel se crean los otros usuarios');
         VarIModoApertura:=1;
         FUsuarios.Show;
       end;

No pongo el resto para no liarla ya que tengo que corregir algunas cosas aun.


Ya sabéis como siempre espero vuestros comentarios, dudas, aportaciones y criticas. también me gustaría ver el diseño que le vais dando comentando que componente habéis usado.

Me despisto un poco, y la que lías, macho...:rolleyes:

¿Has puesto un esquema Entidad/Relación de la base de datos? Porque no me parece haberla visto. Es una herramienta muy útil a la hora de diseñar bases de datos, y también ayuda a definir la lógica puesto que de un vistazo (casi) puedes ver todas las dependencias.

Y no uses [quote][/quote] para poner el código fuente, que para eso están las etiquetas de código fuente [delphi][/delphi], leñes... :mad: (Si quieres, un moderador puede cambiarlas por ti).

Gracias Ñuño, pero el motivo de ponerlo en código Delphi es por que como lo pongo también en delphiAcces allí me da problema cuando lo pongo con las etiquetas y no así con las quote.


a:

No en este caso no utilizare tablas maestro detalle, si no me equivoco te refieres a esto

Y no te te preocupes a partir de ahora pondel el código dentro de sus etiquetas :D

Ahora se ve mejor. Más claro. ^\||/

Respecto al E/R, aunque no uses relaciones "maestro-detalle", estaría bien por lo menos para saber qué va con qué (o sea, clientes se relaciona con película a través de alquiler, por ejemplo...). La verdad es que no he leído el tutorial todavía porque tengo un cacao impresionante (entre el trabajo y el resto)... :(

Ñuño y que herramientas usas para los esquema Entidad/Relación, si puedes poner un ejemplo te lo agradecería ^\||/

Y ya me gustaría a mi tener un cacao impresionante (digo por lo del trabajo) :).

A mi es que me parece que aveces hago estas cosas para nada, ya que al no recibir comentarios, seán los que sean, no se si interesa, supongo que será la vena narcisista que necesita reconocimiento. Aúnque creo que no soy de esos pues no soy de los que se cuida mucho y prefiero pasar un poco desapercibido, como suelo decirle a mi hermano que es homosesual y muy metrosexual.

Yo de metrosexual, tengo lo mismo que el metro de una ferretería. :D:D:D

Pienso que sí interesa, en menos de una semana tiene ya más de 500 visitas :)

Si pero estoy seguro que buena parte de ellas son mias :rolleyes:

Punto A: Hay mucha gente que leemos el trabajo que haces.
Punto B: Tú no eres metrosexual porque eres KILOMETROSEXUAL :D.

Entre tú y yo abuelete, sigue con tu trabajo, que aunque en algunas cosas no coincido o lo haría de otra manera, es muy bueno.

Saludos

Sigue así, aunque no comentemos nada lo estamos leyendo y nos es de gran ayuda.Por mi parte no suelo comentar mucho puesto que estoy en la fase de principiante ya que no tengo muchos conocimientos,aunque programo cosas basíquisimas para mi, este tipo de tutoriales nos son de muy GRANDE AYUDAR,que son realizados con gente como tú.

Saludos y sigue así. Es un gran trabajo

respondo al punto B, ni hablar que mi mujer me mata :D:D:D
y es lógico que muchas cosas se hagan de manera bastante diferente, al final soy un novato avanzado y esto es para lo más novatos aún

Gracias Tuni, pero creo que es bueno oír los comentarios, tenía un profesor que decía algún comentario, nadie decía nada, a no pues entonces para que coño lo explico.

Eso es por que normalmente es imposible que lo entiendan todo a la primera y muchas veces es más el temor a preguntar que ha resolver la duda y te lo digo por experiencia.

Yo uso GNU/Dia. Está un poco parado, pero funciona muy bien. Además de para hacer diagramas E/R te permite hacer también diagramas de flujo, UML y multitud de cosas más.

Aquí tienes multitud de ejemplos de diagramas. Parecen complejos, pero es fácil de utilizar, y no hay que ser muy estricto para las cosas.

El que más me gusta es este:


Los mios son más simples, pero no encuentro ninguno en este ordenador. :(

Veamos Ñuño aun no controlo el programa y me ha quedado un poco grande, pero aquí lo pongo, espero que sea lo que me habías dicho

Vamos a prepararnos para que nuestra base de datos se ejecute siempre donde este el ejecutable, lo primero es declarar una variable en nuestro modulo Data module (DM)

Código Delphi [-]
VarBPrimeraConeccion:Boolean;

Tambien añadimos al uses de nuestro DM en el uses Forms, para poder usar application, añadiremos también Dialogs, para usar el Showmessage y con todo esto iremos a nuestro IBDatabase que hemos llamado (DB) y en seleccionamos el evento BeforeConnect donde añadiremos el siguiente código

Código Delphi [-]
procedure TDM.DBBeforeConnect(Sender: TObject);
//------------------------------------------------------------------------------
//*****************************************************[ Antes de conectar ]****
// Cogemos la ruta del Ejecutable
//------------------------------------------------------------------------------
var Ruta:string;
    VarBPaso:Boolean;
begin
    VarBPaso:=false;
    if VarBPrimeraConeccion=False then
    begin
      Ruta:=ExtractFilePath(Application.ExeName);    //Sacamos la ruta
      if FileExists(Ruta+ 'VIDEOCLUB.FDB') then
      begin
         DB.DatabaseName:=ruta + 'VIDEOCLUB.FDB';
         VarBPaso:=True;
      end else
      begin
         if FileExists(ruta+'bd\'+'VIDEOCLUB.FDB') then
         begin
           DB.DatabaseName:=Ruta+'bd\' + 'VIDEOCLUB.FDB';
           VarBPaso:=True;
         end else Showmessage('Lo sentimos pero no encontramos el archivo VIDEOCLUB.FDB, donde se encuentra el ejecutable, o en la capeta BD de la ubicación del Ejecutable'+
          #13+#10+'La Aplicación se cerrara');
      end;
      //ShowMessage(IBDatabase1.DatabaseName);
      VarBPrimeraConeccion:=True;
      if (VarBPaso) then
      begin
//         if ibdatabase.Connected=False then ShowMessage('No conectada') else ShowMessage('Conectada');
         if DB.Connected=False then
         begin
            DB.Connected:=True;  //La base de datos
         end;
        Conectar                 //si encontro la B.D. Activa el conjunto
      end
                  else Application.Terminate;   //Si no la encontro sale del programa
   end;
end;

Para que funciones nos queda crear el procedure conectar que tiene el siguiente código

Código Delphi [-]
procedure TDM.conectar;
//------------------------------------------------------------------------------
//**************************************************************[ Conectar ]****
//Nos permite conectar las tablas, querrys + IBDatabase + IBTransaction
//------------------------------------------------------------------------------
begin
   if DB.Connected=False then DB.Connected:=True;                        //La base de datos
   if IBT.Active=False then IBT.Active:=True;                            //Las Tansacciones
   if IBDUsuarios.Active=false then IBDUsuarios.Active:=True;            //La tabla Usuarios
   if IBDCONFIGURACION.Active=false then IBDCONFIGURACION.Active:=True;  //LA tabla configuración
end;

En el procedure anterior mirábamos si la base de datos se encontraba en donde estuviese ubicada la aplicación mediante la ruta, sacando la ubicación de la propia aplicación, como podemos ser un poco más organizados, comprobamos directamente en esta o si dentro de esta ruta esta en una carpeta llamada DB. Si lo encuentra pasa al procedure Conectar, en caso contrario nos muestra un mensaje diciendo que no se encuentra.

¿Por qué hacer esto? fácil para evitar que si cambiamos nuestro programa de ubicación no nos deje de trabajar, además si la aplicación no lleva más vínculos con el sistema, nos permite incluso trabajarla desde un pendrive.

El otro procedure CONECTAR, e s el encargado de volver a conectar tanto nuestra Base de datos (DB), como nuestras transiciones (IBT) y tablas o consultas que pongamos en este módulo, ya que en el resto pondremos simples consultas (IBQUERRYS) que deberemos controlar nosotros, así si tenemos por algún motivo desconectar la base de datos sólo tendremos que llamar al procedure CONECTAR para que todo el sistema vuelva a activarse y seguir trabajando sin tener que reiniciar la aplicación.

Para ello este procedure pregunta si esta activo o no para activarlo.

En el OnActive de nuestro menú debemos cambiar la linea

Código Delphi [-]
if (VarINivelUSuario<>Null and (not (DM.IBDUsuarios.IsEmpty))  then

por

Código Delphi [-]
if (VarINivelUSuario=0) and (not (DM.IBDUsuarios.IsEmpty))  then