Club Delphi  
    FTP   CCD     Buscar   Trucos   Trabajo   Foros

Retroceder   Foros Club Delphi > Otros temas > Trucos
Registrarse FAQ Miembros Calendario Guía de estilo Buscar Temas de Hoy Marcar Foros Como Leídos

Los mejores trucos

Respuesta
 
Herramientas Buscar en Tema Desplegado
  #1  
Antiguo 02-04-2015
Avatar de nlsgarcia
[nlsgarcia] nlsgarcia is offline
Miembro Premium
 
Registrado: feb 2007
Ubicación: Caracas, Venezuela
Posts: 2.206
Poder: 14
nlsgarcia Tiene un aura espectacularnlsgarcia Tiene un aura espectacular
Garantizar de 1..N Instancias Activas en Memoria por Aplicación para Delphi y Lazarus

Club Delphi,

Revisen el siguiente código en Delphi:
Código Delphi [-]
unit SingleInstance;

interface

implementation

uses SysUtils, Forms, Dialogs, Windows;

const
   MutexName : String = 'Test_SingleInstance_Delphi';

var
   Mutex : THandle;

procedure CheckInstance;
begin

   if OpenMutex(MUTEX_MODIFY_STATE,false,PChar(MutexName)) = 0 then
   begin
      Mutex := CreateMutex(nil,False,PChar(MutexName));
      WaitForSingleObject(Mutex,INFINITE);
   end
   else
   begin
      MessageDlg('Existe una Instancia de la Aplicación Activa en Memoria',mtInformation,[mbOk],0);
      Application.Terminate;
   end;

end;

procedure FreeInstance;
begin
   if Mutex <> 0 then
   begin
      ReleaseMutex(Mutex);
      CloseHandle(Mutex);
   end
end;

initialization
  CheckInstance;

finalization
  FreeInstance;

end.
El código anterior en Delphi 7 Sobre Windows 7 Professional x32, permite tener una sola instancia activa en memoria de una aplicación.

Revisen el siguiente código en Lazarus:
Código Delphi [-]
unit SingleInstance;

{$mode objfpc}{$H+}

interface

implementation

uses SysUtils, Forms, Dialogs, Windows;

const
   MutexName : String = 'Test_SingleInstance_Lazarus';

var
   Mutex : THandle;

procedure CheckInstance;
begin

   if OpenMutex(MUTEX_MODIFY_STATE,false,PChar(MutexName)) = 0 then
   begin
      Mutex := CreateMutex(nil,False,PChar(MutexName));
      WaitForSingleObject(Mutex,INFINITE);
   end
   else
   begin
      MessageDlg('Existe una Instancia de la Aplicación Activa en Memoria',mtInformation,[mbOk],0);
      Halt;
   end;

end;

procedure FreeInstance;
begin
   if Mutex <> 0 then
   begin
      ReleaseMutex(Mutex);
      CloseHandle(Mutex);
   end
end;

initialization
  CheckInstance;

finalization
  FreeInstance;

end.
El código anterior en Lazarus Versión #:1.2.6 FPC Version 2.6.4 bajo Windows 7 Professional x32 , permite tener una sola instancia activa en memoria de una aplicación.

Nota:

1- Para tener una sola instancia de una aplicación tanto en Delphi como en Lazarus, solo debe agregarse la unidad SingleInstance al proyecto Delphi/Lazarus, la unidad ejecutara de forma automática el procedimiento CheckInstance al inicializarce y el procedimiento FreeMutex al finalizar.

2- Básicamente el código de Delphi y Lazarus es el mismo, solo varía en la forma de finalizar la aplicación.

3- MutexName, es el nombre de la aplicación para efectos de exclusión el cual debe ser único para las funciones de Mutex.

Revisen esta información:
Espero sea útil

Nelson.

Última edición por nlsgarcia fecha: 02-04-2015 a las 22:33:50.
Responder Con Cita
  #2  
Antiguo 03-04-2015
Avatar de Casimiro Notevi
Casimiro Notevi Casimiro Notevi is offline
Moderador
 
Registrado: sep 2004
Ubicación: En algún lugar.
Posts: 27.320
Poder: 10
Casimiro Notevi Tiene un aura espectacularCasimiro Notevi Tiene un aura espectacular
Responder Con Cita
  #3  
Antiguo 04-04-2015
Avatar de nlsgarcia
[nlsgarcia] nlsgarcia is offline
Miembro Premium
 
Registrado: feb 2007
Ubicación: Caracas, Venezuela
Posts: 2.206
Poder: 14
nlsgarcia Tiene un aura espectacularnlsgarcia Tiene un aura espectacular
Club Delphi,

Revisen este código:
Código Delphi [-]
unit SingleInstance;

interface

implementation

uses SysUtils, Forms, Windows, Dialogs;

const
  SemaphoreName : String = 'Semaphore_SingleInstance_Delphi/Lazarus';
  NumberInstance : Integer = 3;

var
  Semaphore: THandle;
  State : Boolean;
  MsgApp : String;

procedure CheckInstance;
begin

   Semaphore := CreateSemaphore(nil,NumberInstance,NumberInstance,PChar(SemaphoreName));
   if OpenSemaphore(EVENT_MODIFY_STATE,false,PChar(SemaphoreName)) <> 0 then
   begin
      if WaitForSingleObject(Semaphore,0) <> WAIT_OBJECT_0 then
      begin
         MsgApp := Format('El Número Máximo de Instancias de la Aplicación es %d',[NumberInstance]);
         MessageDlg(MsgApp,mtInformation,[mbOk],0);
         State := False;
         Halt;
      end
      else
         State := True;
   end;

end;

procedure FreeInstance;
begin
   if Semaphore <> 0 then
   begin
      if State then ReleaseSemaphore(Semaphore,1,nil);
      CloseHandle(Semaphore);
   end
end;

initialization
  CheckInstance;

finalization
  FreeInstance;

end.
El código anterior en Delphi XE7 Sobre Windows 7 Professional x32, permite por medio de un Semaphore definir el número de instancias activas en memoria de una aplicación en función de los requerimientos de la misma, según se muestra en la siguiente imagen con un máximo de 3 instancias permitidas en este caso:



Nota
:

1- Para controlar el número de instancias de una aplicación tanto en Delphi como en Lazarus, solo debe agregarse la unidad SingleInstance al proyecto Delphi/Lazarus, la unidad ejecutara de forma automática el procedimiento CheckInstance al inicializarce y el procedimiento FreeMutex al finalizar.

2- El código propuesto funciona correctamente en Delphi 7 y Lazarus Versión #:1.2.6 FPC Version 2.6.4 bajo Windows 7 Professional x32.

3- SemaphoreName, es el nombre de la aplicación para efectos de exclusión el cual debe ser único para las funciones de Semaphore.

4- NumberInstance, es el número de instancias máximas permitidas para una aplicación en función de sus requerimientos de performance y/o recursos.

5- Este código es una ampliación del código del Msg #1, ambos son equivalentes funcionalmente si el número de instancias (NumberInstance) es 1 .

Revisen esta información:
Espero sea útil

Nelson.
Responder Con Cita
  #4  
Antiguo 05-04-2015
Avatar de nlsgarcia
[nlsgarcia] nlsgarcia is offline
Miembro Premium
 
Registrado: feb 2007
Ubicación: Caracas, Venezuela
Posts: 2.206
Poder: 14
nlsgarcia Tiene un aura espectacularnlsgarcia Tiene un aura espectacular
Club Delphi,

Cita:
Empezado por nlsgarcia
...MutexName, es el nombre de la aplicación para efectos de exclusión el cual debe ser único para las funciones de Mutex...
...SemaphoreName, es el nombre de la aplicación para efectos de exclusión el cual debe ser único para las funciones de Semaphore...


Revisen este código:
Código Delphi [-]
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ClipBrd,  IdGlobal, IdHash, IdHashMessageDigest;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

function GetGUID : String;
var
   GUID : TGuid;
   Hash, IDHash : String;
   DateTimeID : String;

begin
   if CreateGuid(GUID) = S_OK then
   begin
      Clipboard.AsText := GuidToString(GUID);
      Result := Clipboard.AsText;
   end
   else
   begin
      with TIdHashMessageDigest5.Create do
      try
         DateTimeToString(DateTimeID, '{yyyy/mm/dd_hh:nn:ss.zzz}', Now);
         Hash := TIdHash128.AsHex(HashValue(DateTimeID));
         IDHash := '{' +
                   Copy(Hash,1,8) +
                   '-' +
                   Copy(Hash,9,4) +
                   '-' +
                   Copy(Hash,13,4) +
                   '-' +
                   Copy(Hash,17,4) +
                   '-' +
                   Copy(Hash,21,12) +
                   '}';
         Clipboard.AsText := IDHash;
         Result := Clipboard.AsText;
      finally
         Free;
      end;
   end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   MessageDlg(GetGUID,mtInformation,[mbOk],0);
end;

end.
El código anterior en Delphi 7 sobre Windows 7 Professional x32, permite crear un Globally unique identifier, que identifique de forma unívoca una aplicación para la creación de un Mutex o un Semaphore, como se muestra en la siguiente imagen:



Nota:

1- Este código es un complemento para el código de los Msg #1 y Msg #3.

2- El Globally unique identifier (GUID) generado, esta disponible por medio del Clipboard.

Espero sea útil

Nelson.

Última edición por nlsgarcia fecha: 05-04-2015 a las 04:35:50.
Responder Con Cita
  #5  
Antiguo 27-07-2015
Avatar de Ñuño Martínez
Ñuño Martínez Ñuño Martínez is offline
Moderador
 
Registrado: jul 2006
Ubicación: Ciudad Catedral, Españistán
Posts: 5.608
Poder: 18
Ñuño Martínez Va camino a la famaÑuño Martínez Va camino a la fama
Una preguntita. ¿Por qué para finalizar la aplicación se usa "Application.Terminate" en Delphi y "Halt" en Lazarus? Ya sé que la implementación de TApplication es diferente en VCL que en LCL, pero aun así, ¿no funcionaría el "Application.Terminate" en Lazarus?

Ya sé, podría hacer yo la prueba...
__________________
Proyectos actuales --> Burdjia Components|http://gesbit.sf.net/
Responder Con Cita
  #6  
Antiguo 28-07-2015
Avatar de nlsgarcia
[nlsgarcia] nlsgarcia is offline
Miembro Premium
 
Registrado: feb 2007
Ubicación: Caracas, Venezuela
Posts: 2.206
Poder: 14
nlsgarcia Tiene un aura espectacularnlsgarcia Tiene un aura espectacular
Guillermo,

Cita:
Empezado por Ñuño Martínez
...¿Por qué para finalizar la aplicación se usa "Application.Terminate" en Delphi y "Halt" en Lazarus?...


Revisa esta información:



Tomado de : TCustomApplication.Terminate

Según entiendo por las pruebas realizadas, en Lazarus no hay una verificación del método DoRun si Application.Terminate es ejecutado desde la sección de Initialization, por lo cual es necesario usar Halt en este caso.

Saludos,

Nelson.
Responder Con Cita
  #7  
Antiguo 11-08-2015
Avatar de Ñuño Martínez
Ñuño Martínez Ñuño Martínez is offline
Moderador
 
Registrado: jul 2006
Ubicación: Ciudad Catedral, Españistán
Posts: 5.608
Poder: 18
Ñuño Martínez Va camino a la famaÑuño Martínez Va camino a la fama
Gracias Nelson.
__________________
Proyectos actuales --> Burdjia Components|http://gesbit.sf.net/
Responder Con Cita
Respuesta


Herramientas Buscar en Tema
Buscar en Tema:

Búsqueda Avanzada
Desplegado

Normas de Publicación
no Puedes crear nuevos temas
no Puedes responder a temas
no Puedes adjuntar archivos
no Puedes editar tus mensajes

El código vB está habilitado
Las caritas están habilitado
Código [IMG] está habilitado
Código HTML está deshabilitado
Saltar a Foro

Temas Similares
Tema Autor Foro Respuestas Último mensaje
Evitar múltiples instancias en Lazarus Stereo100 Lazarus, FreePascal, Kylix, etc. 3 13-04-2015 08:40:18
Aplicación para Mac con Lazarus Jovalca Lazarus, FreePascal, Kylix, etc. 17 15-05-2014 20:32:28
FTP para subir archivos al servidor en DELPHI y me sirva para lazarus = koiji Delphi para la web 2 05-02-2013 15:52:06
Evitar abrir dos instancias en Lazarus pedrolazarus Lazarus, FreePascal, Kylix, etc. 7 17-11-2012 18:50:05
DCOM, instancias de una aplicación, Mensajes y Mapeo de ficheros en memoria Aldo OOP 0 15-09-2006 18:09:36


La franja horaria es GMT +2. Ahora son las 19:18:08.


Powered by vBulletin® Version 3.6.8
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.
Traducción al castellano por el equipo de moderadores del Club Delphi
Copyright 1996-2007 Club Delphi