Na postagem anterior sobre esse problema, eu recomendei renomear a unit Calendar e alterar todos os fontes que a utilizava.
Fazendo alguns testes para Windows Mobile, deu o mesmo problema com uma versão mais recente do lazarus.
Desta vez, ao invés de renomear a unit, eu fiz o seguinte:
Na unit Calendar.pp, exclui as seguintes linhas:
{
@abstract(Calendar component)
@author(Shane Miller)
@created(05 Dev 2001)
}
A partir dai, resolveu o problema de illegal unit name, mas deu outro erro:
"Search CalendarPopup, but found Calendar"
A unit Calendar.pp fica na pasta lazarus\lcl\ e a unit CalendarPopup na pasta -lazarus\lcl\forms
Então, alterei o arquivo fpc.cfg, acrescentei os path abaixo, na seção searchpath for units
-FuC:\lazarus\lcl
-FuC:\lazarus\lcl\forms
A partir dai, compilou normalmente.
Até a proxima.
Mostrando postagens com marcador programação. Mostrar todas as postagens
Mostrando postagens com marcador programação. Mostrar todas as postagens
domingo, 26 de dezembro de 2010
terça-feira, 20 de julho de 2010
Simulando um keybd_event
Nos meus programas em Delphi, algumas vezes, se fez necessário simular o pressionamento de uma tecla num TEdit que ainda não recebeu o foco.
Por exemplo:
procedure TFormPegaProdutos.DBGrid1KeyPress(Sender: TObject;
var Key: Char);
begin
//Testa se pressionou um tecla valida
if not (key in ['0'..'9','/',#13,#27,'A'..'z']) Then key:=#0;
if key=#27 then close;
//Testa se pressionou um letra
if (key in ['A'..'Z']) or (key in ['a'..'z']) Then
begin
//Abre um painel para digitacao do nome do item a pesquisar
. PanelPesquisa.Top:=80;
. PanelPesquisa.Left:=160;
. PanelPesquisa.visible:=True;
. Palavra1.setfocus;
. if (key in ['a'..'z']) Then Key:=chr(trunc(ord(Key))-32);
. keybd_event(trunc(Ord(Key)),0,0,0);
end;
if key in ['0'..'9'] Then
begin
. PanelVenda.Top:=80;
. PanelVenda.Left:=60;
. PanelVenda.visible:=True;
. ValorUni.Text:=FormatCurr('#0.00',ProTEMPP_VIS.AsCurrency);
. QTD.setfocus;
. keybd_event(trunc(Ord(Key)),0,0,0);
end;
...ou seja, na lista de itens (dbgrid1) o usuario pode abrir um painel de pesquisa de um novo item sem sair da lista, e ainda pode registrar uma venda do item, sem sair da lista, o que é, diga-se de passagem, muito prático.
Mas no lazarus não temos disponivel o keybd_event, então como resolver esse problema?
Criei uma simples procedure:
procedure keybd_event_on(EditControl:TEdit; var key: char);
begin
EditControl.Text:=key+' ';
EditControl.setfocus;
EditControl.SelStart:=1;
EditControl.SelLength:=1;
end;
Pronto!
Agora, posso continuar portando meus programas pro lazarus :-)
Não é por causa de um keybd_event que o projeto vai parar!
procedure TFormPegaProdutos.DBGrid1KeyPress(Sender: TObject;
var Key: Char);
begin
//Testa se pressionou um tecla valida
if not (key in ['0'..'9','/',#13,#27,'A'..'z']) Then key:=#0;
if key=#27 then close;
//Testa se pressionou um letra
if (key in ['A'..'Z']) or (key in ['a'..'z']) Then
begin
//Abre um painel para digitacao do nome do item a pesquisar
. PanelPesquisa.Top:=80;
. PanelPesquisa.Left:=160;
. PanelPesquisa.visible:=True;
. Palavra1.setfocus;
. if (key in ['a'..'z']) Then Key:=chr(trunc(ord(Key))-32);
. keybd_event(trunc(Ord(Key)),0,0,0);
. keybd_event_on(Palavra1,Key);
end;
if key in ['0'..'9'] Then
begin
. PanelVenda.Top:=80;
. PanelVenda.Left:=60;
. PanelVenda.visible:=True;
. ValorUni.Text:=FormatCurr('#0.00',ProTEMPP_VIS.AsCurrency);
. QTD.setfocus;
.//keybd_event(trunc(Ord(Key)),0,0,0);
. keybd_event_on(QTD,Key);
end;
O lazarus não é 100% compativel com o Delphi, mas ao depararmos com problemas como esse, não podemos desistir, sempre tem uma saida.
Seja livre!
Use lazarus/freepascal.
Por exemplo:
procedure TFormPegaProdutos.DBGrid1KeyPress(Sender: TObject;
var Key: Char);
begin
//Testa se pressionou um tecla valida
if not (key in ['0'..'9','/',#13,#27,'A'..'z']) Then key:=#0;
if key=#27 then close;
//Testa se pressionou um letra
if (key in ['A'..'Z']) or (key in ['a'..'z']) Then
begin
//Abre um painel para digitacao do nome do item a pesquisar
. PanelPesquisa.Top:=80;
. PanelPesquisa.Left:=160;
. PanelPesquisa.visible:=True;
. Palavra1.setfocus;
. if (key in ['a'..'z']) Then Key:=chr(trunc(ord(Key))-32);
. keybd_event(trunc(Ord(Key)),0,0,0);
end;
if key in ['0'..'9'] Then
begin
. PanelVenda.Top:=80;
. PanelVenda.Left:=60;
. PanelVenda.visible:=True;
. ValorUni.Text:=FormatCurr('#0.00',ProTEMPP_VIS.AsCurrency);
. QTD.setfocus;
. keybd_event(trunc(Ord(Key)),0,0,0);
end;
...ou seja, na lista de itens (dbgrid1) o usuario pode abrir um painel de pesquisa de um novo item sem sair da lista, e ainda pode registrar uma venda do item, sem sair da lista, o que é, diga-se de passagem, muito prático.
Mas no lazarus não temos disponivel o keybd_event, então como resolver esse problema?
Criei uma simples procedure:
procedure keybd_event_on(EditControl:TEdit; var key: char);
begin
EditControl.Text:=key+' ';
EditControl.setfocus;
EditControl.SelStart:=1;
EditControl.SelLength:=1;
end;
Pronto!
Agora, posso continuar portando meus programas pro lazarus :-)
Não é por causa de um keybd_event que o projeto vai parar!
procedure TFormPegaProdutos.DBGrid1KeyPress(Sender: TObject;
var Key: Char);
begin
//Testa se pressionou um tecla valida
if not (key in ['0'..'9','/',#13,#27,'A'..'z']) Then key:=#0;
if key=#27 then close;
//Testa se pressionou um letra
if (key in ['A'..'Z']) or (key in ['a'..'z']) Then
begin
//Abre um painel para digitacao do nome do item a pesquisar
. PanelPesquisa.Top:=80;
. PanelPesquisa.Left:=160;
. PanelPesquisa.visible:=True;
. Palavra1.setfocus;
. if (key in ['a'..'z']) Then Key:=chr(trunc(ord(Key))-32);
. keybd_event(trunc(Ord(Key)),0,0,0);
. keybd_event_on(Palavra1,Key);
end;
if key in ['0'..'9'] Then
begin
. PanelVenda.Top:=80;
. PanelVenda.Left:=60;
. PanelVenda.visible:=True;
. ValorUni.Text:=FormatCurr('#0.00',ProTEMPP_VIS.AsCurrency);
. QTD.setfocus;
.//keybd_event(trunc(Ord(Key)),0,0,0);
. keybd_event_on(QTD,Key);
end;
O lazarus não é 100% compativel com o Delphi, mas ao depararmos com problemas como esse, não podemos desistir, sempre tem uma saida.
Seja livre!
Use lazarus/freepascal.
segunda-feira, 19 de julho de 2010
GERAOBJCODE - Simples gerador de codigo OOP
Pra quem esta começando na programação OOP, e não dispõem de nenhuma ferramenta auxiliar para geração de codigos, venho aqui disponibilizar uma ferramenta de minha autoria.
É um programa simples, mas que tem sido muito util pra mim.
GERAOBJCODE
Muito simples de usar, basta informar o nome da classe ou objeto, colocar as variaveis da classe/objeto na caixa codigo fonte do objeto e clicar em gerar propriedades e metodos.
Imagine que será necessário criar propriedades e metodos para os items abaixo:
Nome da classe: TObjetoTeste
Itens que compoem a nossa classe:
Codigo gerado pelo nosso GERAOBJCODE:
Criticas, elogios, deixem a sua mensagem.
Link para download dos fontes:
GERAOBJCODE
Até a próxima.
É um programa simples, mas que tem sido muito util pra mim.
GERAOBJCODE
Muito simples de usar, basta informar o nome da classe ou objeto, colocar as variaveis da classe/objeto na caixa codigo fonte do objeto e clicar em gerar propriedades e metodos.
Imagine que será necessário criar propriedades e metodos para os items abaixo:
Nome da classe: TObjetoTeste
Itens que compoem a nossa classe:
Codigo gerado pelo nosso GERAOBJCODE:
Criticas, elogios, deixem a sua mensagem.
Link para download dos fontes:
GERAOBJCODE
Até a próxima.
sábado, 3 de julho de 2010
FortesReport4Lazarus323
Comunico a todos que foi criado um novo projeto no sourceforge para o gerador de relatorios FortesReport4Lazarus
Esse projeto baseia-se na versão 3.23 do Fortes Report, mas com algumas melhorias e correções de bugs que foram feitas na versão 3.24 do Fortes4Lazarus:
.Modo draftfilter ok
.Exporta para html,pdf,excel
.Gera os relatorios mais rapidamente que na versão 3.24
A versão do Fortes4lazarus baseado na 3.24 está com um bug, que ainda não sabemos se é no Fortes4Lazarus ou na LCL, por isso recomendo a todos que voltem sua atenção para a versão 3.23.
Em breve estarei disponibilizando um projeto baseado na 3.24, que não finaliza, terminando a aplicação abruptamente, que é nosso bug, para que todos testem e deem sugestões.
O bug só ocorreu no windows, sendo que no linux o mesmo relatório funcionou normalmente.
Ainda não subi os fontes, mas em breve estarão disponiveis para todos.
O projeto Fortes4Lazarus precisa de contribuições para acelerar o desenvolvimento.
Se você é programador e tem um tempo livre, ajude a manter esses projetos, e assim fortalecer mais o nosso querido lazarus/freepascal.
Link para download da versão 3.23 no sourceforge:
FortesReport4Lazarus323
Seja livre
Use Lazarus/freepascal
Esse projeto baseia-se na versão 3.23 do Fortes Report, mas com algumas melhorias e correções de bugs que foram feitas na versão 3.24 do Fortes4Lazarus:
.Modo draftfilter ok
.Exporta para html,pdf,excel
.Gera os relatorios mais rapidamente que na versão 3.24
A versão do Fortes4lazarus baseado na 3.24 está com um bug, que ainda não sabemos se é no Fortes4Lazarus ou na LCL, por isso recomendo a todos que voltem sua atenção para a versão 3.23.
Em breve estarei disponibilizando um projeto baseado na 3.24, que não finaliza, terminando a aplicação abruptamente, que é nosso bug, para que todos testem e deem sugestões.
O bug só ocorreu no windows, sendo que no linux o mesmo relatório funcionou normalmente.
Ainda não subi os fontes, mas em breve estarão disponiveis para todos.
O projeto Fortes4Lazarus precisa de contribuições para acelerar o desenvolvimento.
Se você é programador e tem um tempo livre, ajude a manter esses projetos, e assim fortalecer mais o nosso querido lazarus/freepascal.
Link para download da versão 3.23 no sourceforge:
FortesReport4Lazarus323
Seja livre
Use Lazarus/freepascal
quinta-feira, 24 de junho de 2010
TStringList - Uso da propriedade Values
Nesse post, vou apresentar um exemplo de uso da propriedade Values da classe TStringlist.
É muito comum precisarmos manter uma lista de variaveis totalizando campos numericos. O problema é que toda vez que precisamos de um novo totalizador, temos que criar uma nova variavel no programa.
Uma abordagem mais pratica dessa situação, é utilizar a classe TStringlist.
Nesse caso o TStringlist funcionará como um array, com a vantagem que seus elementos podem ser acessados pelo nome.
A propriedade Values
O TStringlist nos dá a opção de nomear elementos, associando seu respectivo valor, através do metodo Values.
Exemplo:
var
Lista1:TStringlist;
x:integer;
begin
Lista1:=TStringlist.Create;
for x:=1 to 5 do
begin
Lista1.Values['elemento'+inttostr(x)]:=inttostr(x*2);
end;
end;
Resultará em:
elemento1=2
elemento2=4
elemento3=6
elemento4=8
elemento5=10
Para acessar o valor de 'elemento3' basta executar:
Edit1.text:=Lista1.Values['elemento3'];
Que retornará a string '6'.
Pronto! Muito pratico não é mesmo?
Vamos então a um exemplo mais completo.
Para esse caso, criei duas funções:
function GetStringValue(svVar:string):Real;
procedure setStringValue(svVar:string;svValue:Real);
function GetStringValue(svVar:string):Real;
begin
Result:=StrtoFloat(CalcList.Values[svVar]);
end;
procedure setStringValue(svVar:string;svValue:Real);
begin
CalcList.Values[svVar]:=FloatToStr(svValue);
end;
A função GetStringValue retorna um valor convertido no tipo Real, de modo que podemos utilizar como totalizador, ou qualquer uso que desejar.
A função setStringValue cria/atribui um determinado valor a um elemento do Stringlist.
Exemplos:
setStringValue('total1',100); -> cria/atribui valor 100 a um elemento chamado total1
MinhaVariavelFloat:=GetStringValue('total1');-> atribui o 100 a MinhaVariavelFloat;
Agora incrementamos a variavel:
MinhaVariavelFloat:=MinhaVariavelFloat+20;
E atribuimos novamente ao elemento 'total1':
setStringValue('total1',MinhaVariavelFloat);
MinhaVariavelFloat:=GetStringValue('total1'); Resulta em 120
Espero que essas funções sirvam para você leitor, tanto quanto serviu pra mim.
Qualquer duvida, sugestão ou critica, fiquem a vontade para comentar.
Abaixo, o codigo fonte do nosso exemplo:
unit testa_strings_values0;
{$mode objfpc}{$H+}
interface
uses
LCLIntf, LCLType, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Buttons, StdCtrls, ComCtrls;
type
{ TForm1 }
TForm1 = class(TForm)
calcular: TButton;
box_varlist: TComboBox;
box_operation: TComboBox;
Criar_variavel: TButton;
Edit_calcval: TEdit;
Edit_valor1: TEdit;
Edit_var1: TEdit;
GroupBox1: TGroupBox;
GroupBox2: TGroupBox;
Label10: TLabel;
Label11: TLabel;
Label7: TLabel;
Label8: TLabel;
Label9: TLabel;
ListBox1: TListBox;
Memo1: TMemo;
PageControl1: TPageControl;
TabSheet1: TTabSheet;
procedure calcularClick(Sender: TObject);
procedure Criar_variavelClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
function GetStringValue(svVar:string):Real;
procedure setStringValue(svVar:string;svValue:Real);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
CalcList:TStringlist;
implementation
{$R *.lfm}
procedure TForm1.calcularClick(Sender: TObject);
var
V1,V2,V3:Real;
begin
Memo1.lines.add( 'Valor inicial...:'+CalcList.Values[box_varlist.Text]);
V1:=GetStringValue(box_varlist.Text);
V2:=StrToFloat(Edit_CalcVal.Text);
if box_operation.ItemIndex=0 then
begin
Memo1.lines.add('Valor a somar...:'+Edit_CalcVal.Text);
V3:=V1+V2;
end;
if box_operation.ItemIndex=1 then
begin
Memo1.lines.add('Valor a subtrair:'+Edit_CalcVal.Text);
V3:=V1-V2;
end;
setStringValue(box_varlist.Text,V3);
ListBox1.Items.Values[box_varlist.Text]:=FloatToStr(V3);
V1:=GetStringValue(box_varlist.Text);
Memo1.lines.add(' *-*-* Resultado='+FloatToStr(V1));
Memo1.lines.add(' ');
end;
function TForm1.GetStringValue(svVar:string):Real;
begin
Result:=StrtoFloat(CalcList.Values[svVar]);
end;
procedure TForm1.setStringValue(svVar:string;svValue:Real);
begin
CalcList.Values[svVar]:=FloatToStr(svValue);
end;
procedure TForm1.Criar_variavelClick(Sender: TObject);
begin
CalcList.Values[edit_var1.Text]:=edit_valor1.Text;
box_varlist.Items.Add(edit_var1.Text);
ListBox1.Items.Values[edit_var1.Text]:=edit_valor1.Text;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
CalcList:=TStringlist.Create;
Memo1.lines.Clear;
box_operation.ItemIndex:=-1;
box_varlist.ItemIndex:=-1;
end;
end.
A tela do nosso programinha, deve ficar assim:
Download dos Fontes:
Faça o download dos fontes aqui
Até a próxima.
É muito comum precisarmos manter uma lista de variaveis totalizando campos numericos. O problema é que toda vez que precisamos de um novo totalizador, temos que criar uma nova variavel no programa.
Uma abordagem mais pratica dessa situação, é utilizar a classe TStringlist.
Nesse caso o TStringlist funcionará como um array, com a vantagem que seus elementos podem ser acessados pelo nome.
A propriedade Values
O TStringlist nos dá a opção de nomear elementos, associando seu respectivo valor, através do metodo Values.
Exemplo:
var
Lista1:TStringlist;
x:integer;
begin
Lista1:=TStringlist.Create;
for x:=1 to 5 do
begin
Lista1.Values['elemento'+inttostr(x)]:=inttostr(x*2);
end;
end;
Resultará em:
elemento1=2
elemento2=4
elemento3=6
elemento4=8
elemento5=10
Para acessar o valor de 'elemento3' basta executar:
Edit1.text:=Lista1.Values['elemento3'];
Que retornará a string '6'.
Pronto! Muito pratico não é mesmo?
Vamos então a um exemplo mais completo.
Para esse caso, criei duas funções:
function GetStringValue(svVar:string):Real;
procedure setStringValue(svVar:string;svValue:Real);
function GetStringValue(svVar:string):Real;
begin
Result:=StrtoFloat(CalcList.Values[svVar]);
end;
procedure setStringValue(svVar:string;svValue:Real);
begin
CalcList.Values[svVar]:=FloatToStr(svValue);
end;
A função GetStringValue retorna um valor convertido no tipo Real, de modo que podemos utilizar como totalizador, ou qualquer uso que desejar.
A função setStringValue cria/atribui um determinado valor a um elemento do Stringlist.
Exemplos:
setStringValue('total1',100); -> cria/atribui valor 100 a um elemento chamado total1
MinhaVariavelFloat:=GetStringValue('total1');-> atribui o 100 a MinhaVariavelFloat;
Agora incrementamos a variavel:
MinhaVariavelFloat:=MinhaVariavelFloat+20;
E atribuimos novamente ao elemento 'total1':
setStringValue('total1',MinhaVariavelFloat);
MinhaVariavelFloat:=GetStringValue('total1'); Resulta em 120
Espero que essas funções sirvam para você leitor, tanto quanto serviu pra mim.
Qualquer duvida, sugestão ou critica, fiquem a vontade para comentar.
Abaixo, o codigo fonte do nosso exemplo:
unit testa_strings_values0;
{$mode objfpc}{$H+}
interface
uses
LCLIntf, LCLType, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Buttons, StdCtrls, ComCtrls;
type
{ TForm1 }
TForm1 = class(TForm)
calcular: TButton;
box_varlist: TComboBox;
box_operation: TComboBox;
Criar_variavel: TButton;
Edit_calcval: TEdit;
Edit_valor1: TEdit;
Edit_var1: TEdit;
GroupBox1: TGroupBox;
GroupBox2: TGroupBox;
Label10: TLabel;
Label11: TLabel;
Label7: TLabel;
Label8: TLabel;
Label9: TLabel;
ListBox1: TListBox;
Memo1: TMemo;
PageControl1: TPageControl;
TabSheet1: TTabSheet;
procedure calcularClick(Sender: TObject);
procedure Criar_variavelClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
function GetStringValue(svVar:string):Real;
procedure setStringValue(svVar:string;svValue:Real);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
CalcList:TStringlist;
implementation
{$R *.lfm}
procedure TForm1.calcularClick(Sender: TObject);
var
V1,V2,V3:Real;
begin
Memo1.lines.add( 'Valor inicial...:'+CalcList.Values[box_varlist.Text]);
V1:=GetStringValue(box_varlist.Text);
V2:=StrToFloat(Edit_CalcVal.Text);
if box_operation.ItemIndex=0 then
begin
Memo1.lines.add('Valor a somar...:'+Edit_CalcVal.Text);
V3:=V1+V2;
end;
if box_operation.ItemIndex=1 then
begin
Memo1.lines.add('Valor a subtrair:'+Edit_CalcVal.Text);
V3:=V1-V2;
end;
setStringValue(box_varlist.Text,V3);
ListBox1.Items.Values[box_varlist.Text]:=FloatToStr(V3);
V1:=GetStringValue(box_varlist.Text);
Memo1.lines.add(' *-*-* Resultado='+FloatToStr(V1));
Memo1.lines.add(' ');
end;
function TForm1.GetStringValue(svVar:string):Real;
begin
Result:=StrtoFloat(CalcList.Values[svVar]);
end;
procedure TForm1.setStringValue(svVar:string;svValue:Real);
begin
CalcList.Values[svVar]:=FloatToStr(svValue);
end;
procedure TForm1.Criar_variavelClick(Sender: TObject);
begin
CalcList.Values[edit_var1.Text]:=edit_valor1.Text;
box_varlist.Items.Add(edit_var1.Text);
ListBox1.Items.Values[edit_var1.Text]:=edit_valor1.Text;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
CalcList:=TStringlist.Create;
Memo1.lines.Clear;
box_operation.ItemIndex:=-1;
box_varlist.ItemIndex:=-1;
end;
end.
A tela do nosso programinha, deve ficar assim:
Download dos Fontes:
Faça o download dos fontes aqui
Até a próxima.
quinta-feira, 10 de junho de 2010
Convertendo aplicações delphi facilmente
Fonte: Parallel Pascal Worlds
Os forms do Lazarus(FPC) estão mais compativeis do que nunca com Delphi.
A nova versão do 2.4.0/2.5.1 do FPC, lazarus e FPC permitem salvar os forms no formato LFM sem a necesidade dos arquivos LRS.
Esta mudança permite migrar facilmente um form Delphi para Lazarus.
Pré requisitos:
Versão trunk do Lazarus.
Versão trunk do FPC. A versão 2.4.0 tambem funcionou
Siga os passos abaixo:
1) Ir a Opcões de Projeto, tab miscelaneos e selecionar recursos FPC (FPC resources).
2) Copiar o arquivo dfm para um com extensão lfm.
3) Abrir o arquivo extensão pas relacionado no lazarus.
4) Procurar a referencia a arquivos dfm e substituir pelo siguinte código:
{$IFDEF LCL}
{$R *.lfm}
{$ELSE}
{$R *.dfm}
{$ENDIF}
5) Procurar a instrução que inclui o arquivo *.lrs na sessão de inicializacão da unit e remove-la.
6) Tecle F12 (para ver o arquivo lfm).
7) É possivel ignorar as advertências sobre propiedades inexistentes, ou não presentes no lazarus. Ista é correto para a maioria dos casos. Como você é un programador sério, revisara cada mensagem para verificar a importancia ou não do mesmo, correto? ;)
Salvar.
8) Compile. (CTRL-F9)
Como sempre, não esqueça de informar as units necessarias na clausula uses. Me refiro a LclType, LResources,etc.
Seja livre.
Use lazarus!
English Version
Lazarus(FPC) forms even more compatible with delphi.
Starting with FPC version 2.5.1 lazarus and FPC allow to save forms in lfm format without the need of LRS files.
This change make even easy migrate code from Delphi to Lazarus.
Prereqs:
Lazarus trunk version.
FPC trunk version (tested with version 2.5.1, don't know which is the minimal version required).
(Edited: minimal version required is FPC Version 2.4.0. Thanks Paul!)
The steps are:
1) Go to project options, tab miscellaneous and select fpc resources.
2) Copy dfm file to lfm file.
3) Open pas file on lazarus.
4) search your dfm reference and replace it for
{$IFDEF LCL}
{$R *.lfm}
{$ELSE}
{$R *.dfm}
{$ENDIF}
5) Search the include for lrs file at inicialization section and remove it.
6) HIT F12 (to see the lfm file).
7) You can safely ignore warnings about properties non presents in lazarus. That is true for the most of cases, but like you are a serious programmer will always read the warning messages to evaluate importance of the message, right? ;)
Save
8) Build. Done!
As always, don't forget to add need uses clauses in header of units ( i mind LclType, LResources,etc).
Enjoy!
Conheça o Elevatedb, banco de dados para Windows Mobile
.
Os forms do Lazarus(FPC) estão mais compativeis do que nunca com Delphi.
A nova versão do 2.4.0/2.5.1 do FPC, lazarus e FPC permitem salvar os forms no formato LFM sem a necesidade dos arquivos LRS.
Esta mudança permite migrar facilmente um form Delphi para Lazarus.
Pré requisitos:
Versão trunk do Lazarus.
Versão trunk do FPC. A versão 2.4.0 tambem funcionou
Siga os passos abaixo:
1) Ir a Opcões de Projeto, tab miscelaneos e selecionar recursos FPC (FPC resources).
2) Copiar o arquivo dfm para um com extensão lfm.
3) Abrir o arquivo extensão pas relacionado no lazarus.
4) Procurar a referencia a arquivos dfm e substituir pelo siguinte código:
{$IFDEF LCL}
{$R *.lfm}
{$ELSE}
{$R *.dfm}
{$ENDIF}
5) Procurar a instrução que inclui o arquivo *.lrs na sessão de inicializacão da unit e remove-la.
6) Tecle F12 (para ver o arquivo lfm).
7) É possivel ignorar as advertências sobre propiedades inexistentes, ou não presentes no lazarus. Ista é correto para a maioria dos casos. Como você é un programador sério, revisara cada mensagem para verificar a importancia ou não do mesmo, correto? ;)
Salvar.
8) Compile. (CTRL-F9)
Como sempre, não esqueça de informar as units necessarias na clausula uses. Me refiro a LclType, LResources,etc.
Seja livre.
Use lazarus!
English Version
Lazarus(FPC) forms even more compatible with delphi.
Starting with FPC version 2.5.1 lazarus and FPC allow to save forms in lfm format without the need of LRS files.
This change make even easy migrate code from Delphi to Lazarus.
Prereqs:
Lazarus trunk version.
FPC trunk version (tested with version 2.5.1, don't know which is the minimal version required).
(Edited: minimal version required is FPC Version 2.4.0. Thanks Paul!)
The steps are:
1) Go to project options, tab miscellaneous and select fpc resources.
2) Copy dfm file to lfm file.
3) Open pas file on lazarus.
4) search your dfm reference and replace it for
{$IFDEF LCL}
{$R *.lfm}
{$ELSE}
{$R *.dfm}
{$ENDIF}
5) Search the include for lrs file at inicialization section and remove it.
6) HIT F12 (to see the lfm file).
7) You can safely ignore warnings about properties non presents in lazarus. That is true for the most of cases, but like you are a serious programmer will always read the warning messages to evaluate importance of the message, right? ;)
Save
8) Build. Done!
As always, don't forget to add need uses clauses in header of units ( i mind LclType, LResources,etc).
Enjoy!
Conheça o Elevatedb, banco de dados para Windows Mobile
.
quarta-feira, 2 de junho de 2010
Synapse - Exemplo com sockets
Os componentes de socket mais famosos sem duvida são o IdTcpServer e IdTcpClient, da paleta Indy.
Eu não sei quanto aos outros desenvolvedores, mas acho o Indy muito complexo, pesado, e no caso do lazarus, com varios bugs, pelo menos até a versão 0.9.27 do lazarus, quando eu portei um projeto em delphi/kylix3 pro lazarus.
Resolvi estudar outros componentes de socket para portar o meu projeto pro lazarus.
Os componentes que eu analisei foram:
.Synapse (Ararat Synapse)
.LNet (Lightweight networking library)
Aqui nesse post vou apresentar um projeto de teste do synapse composto de 3 modulos:
.Modulo Cliente
.Modulo Servidor
.Modulo Configura/Dispara Clientes
Como funciona
Modulo Servidor
Primeiro, carregue o modulo servidor (server_synapse1.exe).
Antes de ativar, marque a opção "Em caso de erro parar comunicação"
Clique em Ativar Servidor
Pronto, o nosso servidor está no ativo, esperando conexões.
Tela do servidor
Modulo Cliente
Agora, vamos carregar o(s) modulo(s) clientes do nosso projeto.
Execute o clientesynapse1.exe
Veja a tela do nosso cliente abaixo:
Observe que temos algumas configurações disponiveis pro nosso cliente, pra possibilitar a nossa maratona de testes.
Estas opções são:
Numero de sends
Numero de vezes que o cliente repetira o teste escolhido
Disparo por arquivo externo
Informa ao cliente que deve procurar pelo arquivo "disparo.dat" pra iniciar o teste
Finaliza automatico
Informa ao cliente pra auto-finalizar assim que o teste for executado
Parar em caso de erro
Em caso de problemas, para e mostra a mensagem de erro
Modulo Cliente Control
Esse modulo permite configurar o comportamento dos modulos clientes que serão carregados.
Tela do modulo control
Do lado esquerdo temos as configurações que serão carregadas pelos clientes.
Marque as opções desejadas e clique em "Gerar cconfig"
Do lado esquerdo temos 4 botões:
Engatilhar
Apos o primeiro "disparo", clique nesse botao pra colocar o modulo cliente em estado de espera pelo "disparo"
Disparar clientes
Ao clicar nesse botão, sera gerado o arquivo "disparo.dat" que será lido pelos clientes, e apos se iniciará o processamento desejado
Fechar clientes
Clicando nesse botão, será gerado o arquivo "closecli.dat" que fará com que todos os modulos clientes fechem automaticamente.
Reset
Ao receber o click, apaga os arquivos de controle (dispara.dat,closecli.dat)
Outros comandos
dispara10 e dispara100
Comandos para carregar 10 ou 100 modulos clientes de uma vez. Eu carreguei 100 modulos de uma vez no meu archlinux e funcionou beleza.
Download dos fontes aqui.
Boa diversão :-)
Modulo Servidor
unit server_synapse1_unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
StdCtrls, blcksock, synsock;
type
TTCPEchoDaemon = class(TThread)
private
Daemon_Memo1:TMemo;
SSocket:TTCPBlockSocket;
public
Constructor Create (hMemo:TMemo);
Destructor Destroy; override;
procedure Execute; override;
end;
TTCPEchoThrd = class(TThread)
private
Sock:TTCPBlockSocket;
loClientSock:TTCPBlockSocket;
EchoMemo:TMemo;
CSock: TSocket;
Memo1Text:string;
procedure UpdateMemo1;
public
Constructor Create (hsock:tSocket;hMemo:TMemo);
procedure Execute; override;
end;
{ TForm1 }
TForm1 = class(TForm)
servidor_modo_thread: TButton;
cancela_button: TButton;
box_error: TCheckBox;
modo_verbose: TCheckBox;
Memo1: TMemo;
procedure cancela_buttonClick(Sender: TObject);
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormCreate(Sender: TObject);
procedure servidor_modo_threadClick(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
SSocket: TTCPBlockSocket;
loClientSock: TTCPBlockSocket;
cancelar:Boolean;
implementation
{$R *.lfm}
Constructor TTCPEchoDaemon.Create(hMemo:TMemo);
begin
inherited create(false);
Daemon_Memo1:=hMemo;
Ssocket:=TTCPBlockSocket.create;
FreeOnTerminate:=true;
end;
Destructor TTCPEchoDaemon.Destroy;
begin
SSocket.free;
end;
procedure TTCPEchoDaemon.Execute;
var
echo1:TTCPEchoThrd;
ClientSock:TSocket;
begin
SSocket.CreateSocket;
SSocket.Bind('127.0.0.1','7000');
SSocket.Listen;
cancelar:=False;
if SSocket.LastError = 0 then
begin
while true do
begin
if terminated then break;
Application.ProcessMessages;
if SSocket.CanRead(10000)
then begin
ClientSock := SSocket.Accept;
if SSocket.LastError = 0
then begin
echo1:=TTCPEchoThrd.create(ClientSock,Daemon_memo1);
echo1.Resume;
end ;
end ;
end ;
end
else
begin
Daemon_memo1.Lines.add('Erro '+inttostr(loClientSock.LastError)+' '+loClientSock.GetErrorDescEx);
end;
Daemon_memo1.Lines.Add('Finalizou');
SSocket.CloseSocket;
SSocket.Purge;
end;
Constructor TTCPEchoThrd.Create(Hsock:TSocket;hMemo:TMemo);
begin
inherited create(true);
Csock := Hsock;
EchoMemo:=hMemo;
FreeOnTerminate:=true;
end;
procedure TTCPEchoThrd.UpdateMemo1;
begin
Form1.Memo1.Lines.Add(Memo1Text);
Application.ProcessMessages;
end;
procedure TTCPEchoThrd.Execute;
var
clienteID,s1:string;
r,r1,r2,x,x1:integer;
begin
loClientSock:=TTCPBlockSocket.create;
try
loClientSock.socket:=CSock;
s1:=loClientSock.RecvString(10000);
if s1='**teste1' then
begin
s1:=loClientSock.RecvString(10000);
clienteID:=s1;
loClientSock.SendString('** resp server '+clienteID+CRLF);
if loClientSock.LastError>0 then
begin
Memo1Text:='ID '+clienteID+' SendString Erro '+inttostr(loClientSock.LastError)+' '+loClientSock.GetErrorDescEx;
Synchronize(@UpdateMemo1);
end;
end;
if s1='**teste2' then
begin
s1:=loClientSock.RecvString(10000);
clienteID:=s1;
s1:=loClientSock.RecvString(10000);
x1:=strtoint(s1);
for x:=1 to x1 do
begin
s1:=loClientSock.RecvString(10000);
loClientSock.SendString('** resp server clienteID='+clienteID+CRLF);
if loClientSock.LastError>0 then
begin
Memo1Text:='ID '+clienteID+' SendString Erro '+inttostr(loClientSock.LastError)+' '+loClientSock.GetErrorDescEx;
Synchronize(@UpdateMemo1);
break;
end;
end;
end;
if s1='**teste3' then
begin
s1:=loClientSock.RecvString(10000);
clienteID:=s1;
s1:=loClientSock.RecvString(10000);
x1:=strtoint(s1);
for x:=1 to x1 do
begin
s1:=loClientSock.RecvString(10000);
if s1<>'**soma_inicio' then
begin
Memo1Text:='ID '+clienteID+' nao recebi **somainicio';
Synchronize(@UpdateMemo1);
if loClientSock.LastError>0 then
begin
Memo1Text:='ID '+clienteID+' RecvString - Erro '+inttostr(loClientSock.LastError)+' '+loClientSock.GetErrorDescEx;
Synchronize(@UpdateMemo1);
end;
break;
end;
s1:=loClientSock.RecvString(10000);
r:=strtoint(s1);
r2:=0;
for r1:=1 to r do
begin
s1:=loClientSock.RecvString(10000);
r2:=r2+strtoint(s1);
end;
loClientSock.SendString(inttostr(r2)+CRLF);
if loClientSock.LastError>0 then
begin
Memo1Text:='ID '+clienteID+' SendString - Erro '+inttostr(loClientSock.LastError)+' '+loClientSock.GetErrorDescEx;
Synchronize(@UpdateMemo1);
break;
end;
end;
end;
finally
loClientSock.CloseSocket ;
loClientSock.Free;
end;
end;
{ TForm1 }
procedure TForm1.cancela_buttonClick(Sender: TObject);
begin
cancelar:=True;
end;
procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
SSocket.CloseSocket;
SSocket.Destroy;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
SSocket := TTCPBlockSocket.Create;
end;
procedure TForm1.servidor_modo_threadClick(Sender: TObject);
var
loSock : TSocket;
clienteID,s1:string;
r,r1,r2,x,x1:integer;
Daemon1:TTCPEchoDaemon;
begin
Memo1.Lines.Add('Modo Thread Ativado');
Application.ProcessMessages;
cancelar:=False;
Daemon1:=TTCPEchoDaemon.Create(memo1);
Daemon1.Resume;
end;
end.
Modulo Cliente
unit clientesynapse1_unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
StdCtrls, ExtCtrls, blcksock, DateUtils;
type
{ TForm1 }
TForm1 = class(TForm)
box_error: TCheckBox;
envia3: TButton;
finalizaauto: TCheckBox;
disparo1: TCheckBox;
Edit2: TEdit;
envia2: TButton;
envia: TButton;
Edit1: TEdit;
Label1: TLabel;
Label2: TLabel;
Memo1: TMemo;
Timer1: TTimer;
Timer2: TTimer;
procedure envia3Click(Sender: TObject);
procedure enviamodo1;
procedure enviamodo2;
procedure enviamodo3;
procedure envia2Click(Sender: TObject);
procedure enviaClick(Sender: TObject);
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure Timer2Timer(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
SClient: TTCPBlockSocket;
formID:string;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.enviamodo1;
var
S1:string;
x,x1:integer;
begin
timer2.Enabled:=False;
while true do
begin
if not disparo1.Checked then break;
if SysUtils.FileExists('disparo.dat') then break;
Application.ProcessMessages;
sleep(500);
end;
while true do
begin
x:=DateUtils.SecondOfTheMinute(Time());
if x in [1,16,31,46] then break;
end;
memo1.Lines.Clear;
Application.ProcessMessages;
x1:=strtoint(edit2.Text);
for x:=1 to x1 do
begin
SClient.Connect('127.0.0.1','7000');
if SClient.LastError<>0 then
begin
memo1.Lines.Add('Conexao de teste '+inttostr(x));
memo1.Lines.add('Connect falhou - Erro '+inttostr(SClient.LastError)+' '+SClient.GetErrorDescEx);
showmessage('Ocorreu um problema');
timer2.Enabled:=True;
exit;
end;
if SClient.CanWrite(100) then
begin
SClient.SendString('**teste1'+CRLF);
SClient.SendString(FormID+CRLF);
SClient.SendString(Edit1.Text+' '+inttostr(x)+CRLF);
S1:=SClient.RecvString(10000);
memo1.Lines.Add(S1);
end;
SClient.CloseSocket;
end;
memo1.Lines.add('**teste1 finalizado');
if finalizaauto.Checked then close;
timer2.Enabled:=True;
end;
procedure TForm1.envia3Click(Sender: TObject);
begin
enviamodo3;
end;
procedure TForm1.enviamodo2;
var
S1:string;
x,x1:integer;
begin
timer2.Enabled:=False;
while true do
begin
if not disparo1.Checked then break;
if SysUtils.FileExists('disparo.dat') then break;
Application.ProcessMessages;
sleep(500);
end;
while true do
begin
x:=DateUtils.SecondOfTheMinute(Time());
if x in [1,16,31,46] then break;
end;
memo1.Lines.Clear;
Application.ProcessMessages;
SClient.Connect('127.0.0.1','7000');
if SClient.LastError<>0 then
begin
memo1.Lines.add('Connect falhou - Erro '+inttostr(SClient.LastError)+' '+SClient.GetErrorDescEx);
showmessage('Ocorreu um problema');
timer2.Enabled:=True;
exit;
end;
if SClient.CanWrite(1000) then
begin
SClient.SendString('**teste2'+CRLF);
SClient.SendString(FormID+CRLF);
SClient.SendString(edit2.text+CRLF);
x1:=strtoint(edit2.Text);
if SClient.LastError<>0 then
begin
memo1.Lines.add('SendString 1 Error '+inttostr(SClient.LastError)+' '+SClient.GetErrorDescEx);
end;
for x:=1 to x1 do
begin
SClient.SendString(Edit1.Text+' '+inttostr(x)+CRLF);
if SClient.LastError<>0 then
begin
memo1.Lines.add('SendString 2 Error '+inttostr(SClient.LastError)+' '+SClient.GetErrorDescEx);
if box_error.Checked then break;
end;
S1:=SClient.RecvString(10000);
if SClient.LastError<>0 then
begin
memo1.Lines.add('RecvString 1 Error '+inttostr(SClient.LastError)+' '+SClient.GetErrorDescEx);
if box_error.Checked then break;
end;
memo1.Lines.Add(S1);
end;
end;
memo1.Lines.add('**teste2 finalizado');
SClient.CloseSocket;
SClient.Purge;
if finalizaauto.Checked then close;
timer2.Enabled:=True;
end;
procedure TForm1.enviamodo3;
var
S1:string;
r,r1,r2,x,x1,x2:integer;
TS1:TStringlist;
begin
randomize;
TS1:=TStringlist.Create;
timer2.Enabled:=False;
while true do
begin
if not disparo1.Checked then break;
if SysUtils.FileExists('disparo.dat') then break;
Application.ProcessMessages;
sleep(500);
end;
while true do
begin
x:=DateUtils.SecondOfTheMinute(Time());
if x in [1,16,31,46] then break;
end;
memo1.Lines.Clear;
Application.ProcessMessages;
SClient.Connect('127.0.0.1','7000');
if SClient.LastError<>0 then
begin
memo1.Lines.add('Connect falhou - Erro '+inttostr(SClient.LastError)+' '+SClient.GetErrorDescEx);
showmessage('Ocorreu um problema');
timer2.Enabled:=True;
exit;
end;
if SClient.CanWrite(1000) then
begin
SClient.SendString('**teste3'+CRLF);
SClient.SendString(FormID+CRLF);
SClient.SendString(edit2.text+CRLF);
x1:=strtoint(edit2.Text);
if SClient.LastError<>0 then
begin
memo1.Lines.add('SendString 1 Error '+inttostr(SClient.LastError)+' '+SClient.GetErrorDescEx);
end;
for x:=1 to x1 do
begin
r:=10+trunc(random()*50);
TS1.Clear;
r2:=0;
for x2:=1 to r do
begin
r1:=trunc(random()*100);
r2:=r2+r1;
TS1.Add(inttostr(r1));
end;
SClient.SendString('**soma_inicio'+CRLF);
SClient.SendString(inttostr(TS1.Count)+CRLF);
for x2:=0 to TS1.Count-1 do
begin
SClient.SendString(TS1[x2]+CRLF);
end;
S1:=SClient.RecvString(10000);
if strtoint(S1)<>r2 then memo1.Lines.add('Erro de soma');
end;
memo1.Lines.add('**teste3 finalizado');
end;
SClient.CloseSocket;
SClient.Purge;
if finalizaauto.Checked then close;
timer2.Enabled:=True;
end;
procedure TForm1.enviaClick(Sender: TObject);
begin
enviamodo1;
end;
procedure TForm1.envia2Click(Sender: TObject);
begin
enviamodo2;
end;
procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
SClient.Destroy;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
s1:string;
begin
if fileexists('disparo.dat') then DeleteFile('disparo.dat');
if fileexists('closecli.dat') then DeleteFile('closecli.dat');
if fileexists('redisparo.dat') then DeleteFile('redisparo.dat');
SClient := TTCPBlockSocket.Create;
s1:=inttostr(DateUtils.MilliSecondOfTheHour(Time()));
formID:=s1;
end;
procedure TForm1.FormShow(Sender: TObject);
begin
label2.Caption:=formID;
timer1.Enabled:=True;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
ts1:TStringlist;
x:integer;
begin
timer1.Enabled:=False;
if fileexists('cconfig.dat') then
begin
ts1:=TStringlist.Create;
ts1.LoadFromFile('cconfig.dat');
for x:=0 to ts1.Count-1 do
begin
if ts1[x]='disparo' then
begin
disparo1.Checked:=True;
memo1.Lines.Clear;
memo1.Lines.Add('Aguardando disparo');
end;
if ts1[x]='boxerro' then box_error.Checked:=True;
if ts1[x]='finaliza' then finalizaauto.Checked:=True;
if copy(ts1[x],1,1)='0' then edit2.Text:=ts1[x];
end;
Application.ProcessMessages;
for x:=0 to ts1.Count-1 do
begin
if ts1[x]='envia1' then enviamodo1;
if ts1[x]='envia2' then enviamodo2;
if ts1[x]='envia3' then enviamodo3;
end;
end;
Application.ProcessMessages;
end;
procedure TForm1.Timer2Timer(Sender: TObject);
begin
if fileexists('closecli.dat') then close;
if fileexists('redisparo.dat') then
begin
memo1.Lines.Clear;
memo1.Lines.Add('Aguardando disparo');
Application.ProcessMessages;
timer1.Enabled:=True;
end;
end;
end.
Modulo Controle dos Clientes
unit clientesynapse_control1_unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
StdCtrls;
type
{ TForm1 }
TForm1 = class(TForm)
box_error: TCheckBox;
Engatilhar: TButton;
n_sends: TEdit;
Label2: TLabel;
nenhum_evento: TRadioButton;
reset1: TButton;
gravar: TButton;
disparo1: TCheckBox;
fechar_processos: TButton;
disparo: TButton;
finalizaauto: TCheckBox;
GroupBox1: TGroupBox;
Label1: TLabel;
modo1: TRadioButton;
modo2: TRadioButton;
modo3: TRadioButton;
procedure disparoClick(Sender: TObject);
procedure EngatilharClick(Sender: TObject);
procedure fechar_processosClick(Sender: TObject);
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormCreate(Sender: TObject);
procedure gravarClick(Sender: TObject);
procedure reset1Click(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
if fileexists('disparo.dat') then DeleteFile('disparo.dat');
if fileexists('closecli.dat') then DeleteFile('closecli.dat');
if fileexists('redisparo.dat') then DeleteFile('redisparo.dat');
end;
procedure TForm1.disparoClick(Sender: TObject);
var
s1:TStringlist;
begin
s1:=TStringlist.Create;
s1.add('start');
s1.SaveToFile('disparo.dat');
end;
procedure TForm1.EngatilharClick(Sender: TObject);
var
s1:TStringlist;
begin
if fileexists('disparo.dat') then DeleteFile('disparo.dat');
if fileexists('closecli.dat') then DeleteFile('closecli.dat');
s1:=TStringlist.Create;
s1.add('start');
s1.SaveToFile('redisparo.dat');
end;
procedure TForm1.fechar_processosClick(Sender: TObject);
var
s1:TStringlist;
x:integer;
begin
if fileexists('disparo.dat') then DeleteFile('disparo.dat');
if fileexists('redisparo.dat') then DeleteFile('redisparo.dat');
s1:=TStringlist.Create;
s1.add('close');
s1.SaveToFile('closecli.dat');
end;
procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
if fileexists('disparo.dat') then DeleteFile('disparo.dat');
if fileexists('closecli.dat') then DeleteFile('closecli.dat');
end;
procedure TForm1.gravarClick(Sender: TObject);
var
s1:TStringlist;
begin
s1:=TStringlist.Create;
if strtointdef(n_sends.Text,0)>0 then s1.Add('0'+n_sends.Text);
if disparo1.Checked then s1.Add('disparo');
if finalizaauto.Checked then s1.Add('finaliza');
if box_error.Checked then s1.Add('boxerro');
if modo1.Checked then s1.Add('envia1');
if modo2.Checked then s1.Add('envia2');
if modo3.Checked then s1.Add('envia3');
s1.SaveToFile('cconfig.dat');
end;
procedure TForm1.reset1Click(Sender: TObject);
begin
if fileexists('disparo.dat') then DeleteFile('disparo.dat');
if fileexists('redisparo.dat') then DeleteFile('redisparo.dat');
if fileexists('closecli.dat') then DeleteFile('closecli.dat');
end;
end.
Eu não sei quanto aos outros desenvolvedores, mas acho o Indy muito complexo, pesado, e no caso do lazarus, com varios bugs, pelo menos até a versão 0.9.27 do lazarus, quando eu portei um projeto em delphi/kylix3 pro lazarus.
Resolvi estudar outros componentes de socket para portar o meu projeto pro lazarus.
Os componentes que eu analisei foram:
.Synapse (Ararat Synapse)
.LNet (Lightweight networking library)
Aqui nesse post vou apresentar um projeto de teste do synapse composto de 3 modulos:
.Modulo Cliente
.Modulo Servidor
.Modulo Configura/Dispara Clientes
Como funciona
Modulo Servidor
Primeiro, carregue o modulo servidor (server_synapse1.exe).
Antes de ativar, marque a opção "Em caso de erro parar comunicação"
Clique em Ativar Servidor
Pronto, o nosso servidor está no ativo, esperando conexões.
Tela do servidorModulo Cliente
Agora, vamos carregar o(s) modulo(s) clientes do nosso projeto.
Execute o clientesynapse1.exe
Veja a tela do nosso cliente abaixo:
Observe que temos algumas configurações disponiveis pro nosso cliente, pra possibilitar a nossa maratona de testes.
Estas opções são:
Numero de sends
Numero de vezes que o cliente repetira o teste escolhido
Disparo por arquivo externo
Informa ao cliente que deve procurar pelo arquivo "disparo.dat" pra iniciar o teste
Finaliza automatico
Informa ao cliente pra auto-finalizar assim que o teste for executado
Parar em caso de erro
Em caso de problemas, para e mostra a mensagem de erro
Modulo Cliente Control
Esse modulo permite configurar o comportamento dos modulos clientes que serão carregados.
Tela do modulo controlDo lado esquerdo temos as configurações que serão carregadas pelos clientes.
Marque as opções desejadas e clique em "Gerar cconfig"
Do lado esquerdo temos 4 botões:
Engatilhar
Apos o primeiro "disparo", clique nesse botao pra colocar o modulo cliente em estado de espera pelo "disparo"
Disparar clientes
Ao clicar nesse botão, sera gerado o arquivo "disparo.dat" que será lido pelos clientes, e apos se iniciará o processamento desejado
Fechar clientes
Clicando nesse botão, será gerado o arquivo "closecli.dat" que fará com que todos os modulos clientes fechem automaticamente.
Reset
Ao receber o click, apaga os arquivos de controle (dispara.dat,closecli.dat)
Outros comandos
dispara10 e dispara100
Comandos para carregar 10 ou 100 modulos clientes de uma vez. Eu carreguei 100 modulos de uma vez no meu archlinux e funcionou beleza.
Download dos fontes aqui.
Boa diversão :-)
Modulo Servidor
unit server_synapse1_unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
StdCtrls, blcksock, synsock;
type
TTCPEchoDaemon = class(TThread)
private
Daemon_Memo1:TMemo;
SSocket:TTCPBlockSocket;
public
Constructor Create (hMemo:TMemo);
Destructor Destroy; override;
procedure Execute; override;
end;
TTCPEchoThrd = class(TThread)
private
Sock:TTCPBlockSocket;
loClientSock:TTCPBlockSocket;
EchoMemo:TMemo;
CSock: TSocket;
Memo1Text:string;
procedure UpdateMemo1;
public
Constructor Create (hsock:tSocket;hMemo:TMemo);
procedure Execute; override;
end;
{ TForm1 }
TForm1 = class(TForm)
servidor_modo_thread: TButton;
cancela_button: TButton;
box_error: TCheckBox;
modo_verbose: TCheckBox;
Memo1: TMemo;
procedure cancela_buttonClick(Sender: TObject);
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormCreate(Sender: TObject);
procedure servidor_modo_threadClick(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
SSocket: TTCPBlockSocket;
loClientSock: TTCPBlockSocket;
cancelar:Boolean;
implementation
{$R *.lfm}
Constructor TTCPEchoDaemon.Create(hMemo:TMemo);
begin
inherited create(false);
Daemon_Memo1:=hMemo;
Ssocket:=TTCPBlockSocket.create;
FreeOnTerminate:=true;
end;
Destructor TTCPEchoDaemon.Destroy;
begin
SSocket.free;
end;
procedure TTCPEchoDaemon.Execute;
var
echo1:TTCPEchoThrd;
ClientSock:TSocket;
begin
SSocket.CreateSocket;
SSocket.Bind('127.0.0.1','7000');
SSocket.Listen;
cancelar:=False;
if SSocket.LastError = 0 then
begin
while true do
begin
if terminated then break;
Application.ProcessMessages;
if SSocket.CanRead(10000)
then begin
ClientSock := SSocket.Accept;
if SSocket.LastError = 0
then begin
echo1:=TTCPEchoThrd.create(ClientSock,Daemon_memo1);
echo1.Resume;
end ;
end ;
end ;
end
else
begin
Daemon_memo1.Lines.add('Erro '+inttostr(loClientSock.LastError)+' '+loClientSock.GetErrorDescEx);
end;
Daemon_memo1.Lines.Add('Finalizou');
SSocket.CloseSocket;
SSocket.Purge;
end;
Constructor TTCPEchoThrd.Create(Hsock:TSocket;hMemo:TMemo);
begin
inherited create(true);
Csock := Hsock;
EchoMemo:=hMemo;
FreeOnTerminate:=true;
end;
procedure TTCPEchoThrd.UpdateMemo1;
begin
Form1.Memo1.Lines.Add(Memo1Text);
Application.ProcessMessages;
end;
procedure TTCPEchoThrd.Execute;
var
clienteID,s1:string;
r,r1,r2,x,x1:integer;
begin
loClientSock:=TTCPBlockSocket.create;
try
loClientSock.socket:=CSock;
s1:=loClientSock.RecvString(10000);
if s1='**teste1' then
begin
s1:=loClientSock.RecvString(10000);
clienteID:=s1;
loClientSock.SendString('** resp server '+clienteID+CRLF);
if loClientSock.LastError>0 then
begin
Memo1Text:='ID '+clienteID+' SendString Erro '+inttostr(loClientSock.LastError)+' '+loClientSock.GetErrorDescEx;
Synchronize(@UpdateMemo1);
end;
end;
if s1='**teste2' then
begin
s1:=loClientSock.RecvString(10000);
clienteID:=s1;
s1:=loClientSock.RecvString(10000);
x1:=strtoint(s1);
for x:=1 to x1 do
begin
s1:=loClientSock.RecvString(10000);
loClientSock.SendString('** resp server clienteID='+clienteID+CRLF);
if loClientSock.LastError>0 then
begin
Memo1Text:='ID '+clienteID+' SendString Erro '+inttostr(loClientSock.LastError)+' '+loClientSock.GetErrorDescEx;
Synchronize(@UpdateMemo1);
break;
end;
end;
end;
if s1='**teste3' then
begin
s1:=loClientSock.RecvString(10000);
clienteID:=s1;
s1:=loClientSock.RecvString(10000);
x1:=strtoint(s1);
for x:=1 to x1 do
begin
s1:=loClientSock.RecvString(10000);
if s1<>'**soma_inicio' then
begin
Memo1Text:='ID '+clienteID+' nao recebi **somainicio';
Synchronize(@UpdateMemo1);
if loClientSock.LastError>0 then
begin
Memo1Text:='ID '+clienteID+' RecvString - Erro '+inttostr(loClientSock.LastError)+' '+loClientSock.GetErrorDescEx;
Synchronize(@UpdateMemo1);
end;
break;
end;
s1:=loClientSock.RecvString(10000);
r:=strtoint(s1);
r2:=0;
for r1:=1 to r do
begin
s1:=loClientSock.RecvString(10000);
r2:=r2+strtoint(s1);
end;
loClientSock.SendString(inttostr(r2)+CRLF);
if loClientSock.LastError>0 then
begin
Memo1Text:='ID '+clienteID+' SendString - Erro '+inttostr(loClientSock.LastError)+' '+loClientSock.GetErrorDescEx;
Synchronize(@UpdateMemo1);
break;
end;
end;
end;
finally
loClientSock.CloseSocket ;
loClientSock.Free;
end;
end;
{ TForm1 }
procedure TForm1.cancela_buttonClick(Sender: TObject);
begin
cancelar:=True;
end;
procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
SSocket.CloseSocket;
SSocket.Destroy;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
SSocket := TTCPBlockSocket.Create;
end;
procedure TForm1.servidor_modo_threadClick(Sender: TObject);
var
loSock : TSocket;
clienteID,s1:string;
r,r1,r2,x,x1:integer;
Daemon1:TTCPEchoDaemon;
begin
Memo1.Lines.Add('Modo Thread Ativado');
Application.ProcessMessages;
cancelar:=False;
Daemon1:=TTCPEchoDaemon.Create(memo1);
Daemon1.Resume;
end;
end.
Modulo Cliente
unit clientesynapse1_unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
StdCtrls, ExtCtrls, blcksock, DateUtils;
type
{ TForm1 }
TForm1 = class(TForm)
box_error: TCheckBox;
envia3: TButton;
finalizaauto: TCheckBox;
disparo1: TCheckBox;
Edit2: TEdit;
envia2: TButton;
envia: TButton;
Edit1: TEdit;
Label1: TLabel;
Label2: TLabel;
Memo1: TMemo;
Timer1: TTimer;
Timer2: TTimer;
procedure envia3Click(Sender: TObject);
procedure enviamodo1;
procedure enviamodo2;
procedure enviamodo3;
procedure envia2Click(Sender: TObject);
procedure enviaClick(Sender: TObject);
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure Timer2Timer(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
SClient: TTCPBlockSocket;
formID:string;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.enviamodo1;
var
S1:string;
x,x1:integer;
begin
timer2.Enabled:=False;
while true do
begin
if not disparo1.Checked then break;
if SysUtils.FileExists('disparo.dat') then break;
Application.ProcessMessages;
sleep(500);
end;
while true do
begin
x:=DateUtils.SecondOfTheMinute(Time());
if x in [1,16,31,46] then break;
end;
memo1.Lines.Clear;
Application.ProcessMessages;
x1:=strtoint(edit2.Text);
for x:=1 to x1 do
begin
SClient.Connect('127.0.0.1','7000');
if SClient.LastError<>0 then
begin
memo1.Lines.Add('Conexao de teste '+inttostr(x));
memo1.Lines.add('Connect falhou - Erro '+inttostr(SClient.LastError)+' '+SClient.GetErrorDescEx);
showmessage('Ocorreu um problema');
timer2.Enabled:=True;
exit;
end;
if SClient.CanWrite(100) then
begin
SClient.SendString('**teste1'+CRLF);
SClient.SendString(FormID+CRLF);
SClient.SendString(Edit1.Text+' '+inttostr(x)+CRLF);
S1:=SClient.RecvString(10000);
memo1.Lines.Add(S1);
end;
SClient.CloseSocket;
end;
memo1.Lines.add('**teste1 finalizado');
if finalizaauto.Checked then close;
timer2.Enabled:=True;
end;
procedure TForm1.envia3Click(Sender: TObject);
begin
enviamodo3;
end;
procedure TForm1.enviamodo2;
var
S1:string;
x,x1:integer;
begin
timer2.Enabled:=False;
while true do
begin
if not disparo1.Checked then break;
if SysUtils.FileExists('disparo.dat') then break;
Application.ProcessMessages;
sleep(500);
end;
while true do
begin
x:=DateUtils.SecondOfTheMinute(Time());
if x in [1,16,31,46] then break;
end;
memo1.Lines.Clear;
Application.ProcessMessages;
SClient.Connect('127.0.0.1','7000');
if SClient.LastError<>0 then
begin
memo1.Lines.add('Connect falhou - Erro '+inttostr(SClient.LastError)+' '+SClient.GetErrorDescEx);
showmessage('Ocorreu um problema');
timer2.Enabled:=True;
exit;
end;
if SClient.CanWrite(1000) then
begin
SClient.SendString('**teste2'+CRLF);
SClient.SendString(FormID+CRLF);
SClient.SendString(edit2.text+CRLF);
x1:=strtoint(edit2.Text);
if SClient.LastError<>0 then
begin
memo1.Lines.add('SendString 1 Error '+inttostr(SClient.LastError)+' '+SClient.GetErrorDescEx);
end;
for x:=1 to x1 do
begin
SClient.SendString(Edit1.Text+' '+inttostr(x)+CRLF);
if SClient.LastError<>0 then
begin
memo1.Lines.add('SendString 2 Error '+inttostr(SClient.LastError)+' '+SClient.GetErrorDescEx);
if box_error.Checked then break;
end;
S1:=SClient.RecvString(10000);
if SClient.LastError<>0 then
begin
memo1.Lines.add('RecvString 1 Error '+inttostr(SClient.LastError)+' '+SClient.GetErrorDescEx);
if box_error.Checked then break;
end;
memo1.Lines.Add(S1);
end;
end;
memo1.Lines.add('**teste2 finalizado');
SClient.CloseSocket;
SClient.Purge;
if finalizaauto.Checked then close;
timer2.Enabled:=True;
end;
procedure TForm1.enviamodo3;
var
S1:string;
r,r1,r2,x,x1,x2:integer;
TS1:TStringlist;
begin
randomize;
TS1:=TStringlist.Create;
timer2.Enabled:=False;
while true do
begin
if not disparo1.Checked then break;
if SysUtils.FileExists('disparo.dat') then break;
Application.ProcessMessages;
sleep(500);
end;
while true do
begin
x:=DateUtils.SecondOfTheMinute(Time());
if x in [1,16,31,46] then break;
end;
memo1.Lines.Clear;
Application.ProcessMessages;
SClient.Connect('127.0.0.1','7000');
if SClient.LastError<>0 then
begin
memo1.Lines.add('Connect falhou - Erro '+inttostr(SClient.LastError)+' '+SClient.GetErrorDescEx);
showmessage('Ocorreu um problema');
timer2.Enabled:=True;
exit;
end;
if SClient.CanWrite(1000) then
begin
SClient.SendString('**teste3'+CRLF);
SClient.SendString(FormID+CRLF);
SClient.SendString(edit2.text+CRLF);
x1:=strtoint(edit2.Text);
if SClient.LastError<>0 then
begin
memo1.Lines.add('SendString 1 Error '+inttostr(SClient.LastError)+' '+SClient.GetErrorDescEx);
end;
for x:=1 to x1 do
begin
r:=10+trunc(random()*50);
TS1.Clear;
r2:=0;
for x2:=1 to r do
begin
r1:=trunc(random()*100);
r2:=r2+r1;
TS1.Add(inttostr(r1));
end;
SClient.SendString('**soma_inicio'+CRLF);
SClient.SendString(inttostr(TS1.Count)+CRLF);
for x2:=0 to TS1.Count-1 do
begin
SClient.SendString(TS1[x2]+CRLF);
end;
S1:=SClient.RecvString(10000);
if strtoint(S1)<>r2 then memo1.Lines.add('Erro de soma');
end;
memo1.Lines.add('**teste3 finalizado');
end;
SClient.CloseSocket;
SClient.Purge;
if finalizaauto.Checked then close;
timer2.Enabled:=True;
end;
procedure TForm1.enviaClick(Sender: TObject);
begin
enviamodo1;
end;
procedure TForm1.envia2Click(Sender: TObject);
begin
enviamodo2;
end;
procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
SClient.Destroy;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
s1:string;
begin
if fileexists('disparo.dat') then DeleteFile('disparo.dat');
if fileexists('closecli.dat') then DeleteFile('closecli.dat');
if fileexists('redisparo.dat') then DeleteFile('redisparo.dat');
SClient := TTCPBlockSocket.Create;
s1:=inttostr(DateUtils.MilliSecondOfTheHour(Time()));
formID:=s1;
end;
procedure TForm1.FormShow(Sender: TObject);
begin
label2.Caption:=formID;
timer1.Enabled:=True;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
ts1:TStringlist;
x:integer;
begin
timer1.Enabled:=False;
if fileexists('cconfig.dat') then
begin
ts1:=TStringlist.Create;
ts1.LoadFromFile('cconfig.dat');
for x:=0 to ts1.Count-1 do
begin
if ts1[x]='disparo' then
begin
disparo1.Checked:=True;
memo1.Lines.Clear;
memo1.Lines.Add('Aguardando disparo');
end;
if ts1[x]='boxerro' then box_error.Checked:=True;
if ts1[x]='finaliza' then finalizaauto.Checked:=True;
if copy(ts1[x],1,1)='0' then edit2.Text:=ts1[x];
end;
Application.ProcessMessages;
for x:=0 to ts1.Count-1 do
begin
if ts1[x]='envia1' then enviamodo1;
if ts1[x]='envia2' then enviamodo2;
if ts1[x]='envia3' then enviamodo3;
end;
end;
Application.ProcessMessages;
end;
procedure TForm1.Timer2Timer(Sender: TObject);
begin
if fileexists('closecli.dat') then close;
if fileexists('redisparo.dat') then
begin
memo1.Lines.Clear;
memo1.Lines.Add('Aguardando disparo');
Application.ProcessMessages;
timer1.Enabled:=True;
end;
end;
end.
Modulo Controle dos Clientes
unit clientesynapse_control1_unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
StdCtrls;
type
{ TForm1 }
TForm1 = class(TForm)
box_error: TCheckBox;
Engatilhar: TButton;
n_sends: TEdit;
Label2: TLabel;
nenhum_evento: TRadioButton;
reset1: TButton;
gravar: TButton;
disparo1: TCheckBox;
fechar_processos: TButton;
disparo: TButton;
finalizaauto: TCheckBox;
GroupBox1: TGroupBox;
Label1: TLabel;
modo1: TRadioButton;
modo2: TRadioButton;
modo3: TRadioButton;
procedure disparoClick(Sender: TObject);
procedure EngatilharClick(Sender: TObject);
procedure fechar_processosClick(Sender: TObject);
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormCreate(Sender: TObject);
procedure gravarClick(Sender: TObject);
procedure reset1Click(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
if fileexists('disparo.dat') then DeleteFile('disparo.dat');
if fileexists('closecli.dat') then DeleteFile('closecli.dat');
if fileexists('redisparo.dat') then DeleteFile('redisparo.dat');
end;
procedure TForm1.disparoClick(Sender: TObject);
var
s1:TStringlist;
begin
s1:=TStringlist.Create;
s1.add('start');
s1.SaveToFile('disparo.dat');
end;
procedure TForm1.EngatilharClick(Sender: TObject);
var
s1:TStringlist;
begin
if fileexists('disparo.dat') then DeleteFile('disparo.dat');
if fileexists('closecli.dat') then DeleteFile('closecli.dat');
s1:=TStringlist.Create;
s1.add('start');
s1.SaveToFile('redisparo.dat');
end;
procedure TForm1.fechar_processosClick(Sender: TObject);
var
s1:TStringlist;
x:integer;
begin
if fileexists('disparo.dat') then DeleteFile('disparo.dat');
if fileexists('redisparo.dat') then DeleteFile('redisparo.dat');
s1:=TStringlist.Create;
s1.add('close');
s1.SaveToFile('closecli.dat');
end;
procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
if fileexists('disparo.dat') then DeleteFile('disparo.dat');
if fileexists('closecli.dat') then DeleteFile('closecli.dat');
end;
procedure TForm1.gravarClick(Sender: TObject);
var
s1:TStringlist;
begin
s1:=TStringlist.Create;
if strtointdef(n_sends.Text,0)>0 then s1.Add('0'+n_sends.Text);
if disparo1.Checked then s1.Add('disparo');
if finalizaauto.Checked then s1.Add('finaliza');
if box_error.Checked then s1.Add('boxerro');
if modo1.Checked then s1.Add('envia1');
if modo2.Checked then s1.Add('envia2');
if modo3.Checked then s1.Add('envia3');
s1.SaveToFile('cconfig.dat');
end;
procedure TForm1.reset1Click(Sender: TObject);
begin
if fileexists('disparo.dat') then DeleteFile('disparo.dat');
if fileexists('redisparo.dat') then DeleteFile('redisparo.dat');
if fileexists('closecli.dat') then DeleteFile('closecli.dat');
end;
end.
terça-feira, 17 de novembro de 2009
Facilitando digitação de data
Em qualquer documento, geralmente temos que informar datas, de modo que se torna necessário agilizar a digitação.
Pra resolver esse problema, criei duas rotinas, que já uso ha uns 6 anos.
Pra quem é experiente, é algo banal, mas para os iniciantes, essa dica pode ser interessante.
Como funciona as rotinas
São duas rotinas:
Validakeydatas e Validakeydatas2.
Funciona validando a data quando o usuario tecla ENTER.
No meu caso tem sido muito útil, pois essas rotinas alem de validar as datas tem outras vantagens:
.Agiliza na digitação, pois ao digitar a data não precisa colocar o separador, no caso a barra '/', e adicionalmente, não precisa informar o ano da data, que a rotina completa automaticamente
.Pode ser usado em qualquer componente, como Edit, DBEdit, DBGrid.
Essas rotinas interceptam a digitação do usuario, retornando um caracter nulo no caso de digitar algo invalido.
A diferença de Validakeydatas e Validakeydatas2 é que na segunda função pode-se informar o ano para preenchimento automatico.
Por exemplo, pra informar '01/12/2009' você digita apenas '01122009' ou '0112' e tecla ENTER.
Como utilizar as rotinas
Basta configurar o evento OnKeyPress do componente, da seguinte forma:
Crie um form
Insira dois componentes TEdit no form
De um duplo clique no evento OnKeyPress do Edit1
Exemplo 1
Validakeydatas
procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: char);
begin
//Chama Validakeydatas, não aceita data em branco
Validakeydatas(Sender,Key,False);
if key=#13 then Edit2.setfocus;
if key=#27 then close;
end;
Exemplo 2
Validakeydatas
procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: char);
begin
//Chama Validakeydatas, aceitando data em branco
Validakeydatas(Sender,Key,True);
if key=#13 then Edit2.setfocus;
if key=#27 then close;
end;
Exemplo 3
Utilizando
Validakeydatas2
procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: char);
begin
//Chama Validakeydatas
//não aceita data em branco
//se não informar o ano, preenche com '2009'
Validakeydatas2(Sender,Key,False,'2009');
if key=#13 then Edit2.setfocus;
if key=#27 then close;
end;
Codigo fonte
Segue abaixo um exemplo de Unit que poderia ser usada pra armazenar as funcoes:
unit funcoes1;
interface
uses
LCLIntf, Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
EditBtn, ExtCtrls, StdCtrls;
Function IsDate(wData:String):Boolean;
Procedure ValidaKeyDatas(Const Sender:TObject; var key: char; Const AceitaNulo: Boolean);
Procedure ValidaKeyDatas2(Const Sender:TObject; var key: char; Const AceitaNulo: Boolean;Const zAno:String);
implementation
Function IsDate(wData:String):Boolean;
var
T:TDateTime;
Begin
Try
T:=StrToDateTime(wData);
Result:=True;
except
Result:=False;
end;
end;
Procedure ValidaKeyDatas(Const Sender:TObject; var key: char; Const AceitaNulo: Boolean);
var
D1:String;
L:integer;
begin
if not (key in ['0'..'9','/',#8,#13,#27]) Then key:=#0;
if Sender.ClassName='TEdit' Then
begin
D1:=TEdit(Sender).Text;
if (key=#13) and (D1='') then
if not (AceitaNulo) Then key:=#0;
if (key=#13) and (D1<>'') then
begin
L:=length(D1);
if (pos('/',TEdit(Sender).Text)=0) and ((L=6) or (L=8)) then
begin
if L=6 then
D1:=copy(D1,1,2)+'/'+copy(D1,3,2)+'/'+copy(D1,5,2)
else
D1:=copy(D1,1,2)+'/'+copy(D1,3,2)+'/'+copy(D1,5,4);
end;
if isdate(D1) Then TEdit(Sender).Text:=D1;
if not isdate(D1) Then
begin
key:=#0;
ShowMessage('Data Invalida');
TEdit(Sender).SetFocus;
end;
end;
end;
end;
Procedure ValidaKeyDatas2(Const Sender:TObject; var key: char; Const AceitaNulo: Boolean;Const zAno:String);
var
D1:String;
L:integer;
begin
if not (key in ['0'..'9','/',#8,#13,#27]) Then key:=#0;
if Sender.ClassName='TEdit' Then
begin
D1:=TEdit(Sender).Text;
if (key=#13) and (D1='') then
if not (AceitaNulo) Then key:=#0;
if (key=#13) and (D1<>'') then
begin
L:=length(D1);
if (pos('/',TEdit(Sender).Text)=0) and ((L=6) or (L=8)) then
begin
if L=6 then
D1:=copy(D1,1,2)+'/'+copy(D1,3,2)+'/'+copy(D1,5,2)
else
D1:=copy(D1,1,2)+'/'+copy(D1,3,2)+'/'+copy(D1,5,4);
end;
if (pos('/',TEdit(Sender).Text)=0) and (L=4) then
begin
D1:=D1+zAno;
L:=length(D1);
if L=6 then
D1:=copy(D1,1,2)+'/'+copy(D1,3,2)+'/'+copy(D1,5,2)
else
D1:=copy(D1,1,2)+'/'+copy(D1,3,2)+'/'+copy(D1,5,4);
end;
if isdate(D1) Then TEdit(Sender).Text:=D1;
if not isdate(D1) Then
begin
key:=#0;
ShowMessage('Data Invalida');
TEdit(Sender).SetFocus;
end;
end;
end;
end;
end.
Até a próxima.
.
Pra resolver esse problema, criei duas rotinas, que já uso ha uns 6 anos.
Pra quem é experiente, é algo banal, mas para os iniciantes, essa dica pode ser interessante.
Como funciona as rotinas
São duas rotinas:
Validakeydatas e Validakeydatas2.
Funciona validando a data quando o usuario tecla ENTER.
No meu caso tem sido muito útil, pois essas rotinas alem de validar as datas tem outras vantagens:
.Agiliza na digitação, pois ao digitar a data não precisa colocar o separador, no caso a barra '/', e adicionalmente, não precisa informar o ano da data, que a rotina completa automaticamente
.Pode ser usado em qualquer componente, como Edit, DBEdit, DBGrid.
Essas rotinas interceptam a digitação do usuario, retornando um caracter nulo no caso de digitar algo invalido.
A diferença de Validakeydatas e Validakeydatas2 é que na segunda função pode-se informar o ano para preenchimento automatico.
Por exemplo, pra informar '01/12/2009' você digita apenas '01122009' ou '0112' e tecla ENTER.
Como utilizar as rotinas
Basta configurar o evento OnKeyPress do componente, da seguinte forma:
Crie um form
Insira dois componentes TEdit no form
De um duplo clique no evento OnKeyPress do Edit1
Exemplo 1
Validakeydatas
procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: char);
begin
//Chama Validakeydatas, não aceita data em branco
Validakeydatas(Sender,Key,False);
if key=#13 then Edit2.setfocus;
if key=#27 then close;
end;
Exemplo 2
Validakeydatas
procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: char);
begin
//Chama Validakeydatas, aceitando data em branco
Validakeydatas(Sender,Key,True);
if key=#13 then Edit2.setfocus;
if key=#27 then close;
end;
Exemplo 3
Utilizando
Validakeydatas2
procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: char);
begin
//Chama Validakeydatas
//não aceita data em branco
//se não informar o ano, preenche com '2009'
Validakeydatas2(Sender,Key,False,'2009');
if key=#13 then Edit2.setfocus;
if key=#27 then close;
end;
Codigo fonte
Segue abaixo um exemplo de Unit que poderia ser usada pra armazenar as funcoes:
unit funcoes1;
interface
uses
LCLIntf, Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
EditBtn, ExtCtrls, StdCtrls;
Function IsDate(wData:String):Boolean;
Procedure ValidaKeyDatas(Const Sender:TObject; var key: char; Const AceitaNulo: Boolean);
Procedure ValidaKeyDatas2(Const Sender:TObject; var key: char; Const AceitaNulo: Boolean;Const zAno:String);
implementation
Function IsDate(wData:String):Boolean;
var
T:TDateTime;
Begin
Try
T:=StrToDateTime(wData);
Result:=True;
except
Result:=False;
end;
end;
Procedure ValidaKeyDatas(Const Sender:TObject; var key: char; Const AceitaNulo: Boolean);
var
D1:String;
L:integer;
begin
if not (key in ['0'..'9','/',#8,#13,#27]) Then key:=#0;
if Sender.ClassName='TEdit' Then
begin
D1:=TEdit(Sender).Text;
if (key=#13) and (D1='') then
if not (AceitaNulo) Then key:=#0;
if (key=#13) and (D1<>'') then
begin
L:=length(D1);
if (pos('/',TEdit(Sender).Text)=0) and ((L=6) or (L=8)) then
begin
if L=6 then
D1:=copy(D1,1,2)+'/'+copy(D1,3,2)+'/'+copy(D1,5,2)
else
D1:=copy(D1,1,2)+'/'+copy(D1,3,2)+'/'+copy(D1,5,4);
end;
if isdate(D1) Then TEdit(Sender).Text:=D1;
if not isdate(D1) Then
begin
key:=#0;
ShowMessage('Data Invalida');
TEdit(Sender).SetFocus;
end;
end;
end;
end;
Procedure ValidaKeyDatas2(Const Sender:TObject; var key: char; Const AceitaNulo: Boolean;Const zAno:String);
var
D1:String;
L:integer;
begin
if not (key in ['0'..'9','/',#8,#13,#27]) Then key:=#0;
if Sender.ClassName='TEdit' Then
begin
D1:=TEdit(Sender).Text;
if (key=#13) and (D1='') then
if not (AceitaNulo) Then key:=#0;
if (key=#13) and (D1<>'') then
begin
L:=length(D1);
if (pos('/',TEdit(Sender).Text)=0) and ((L=6) or (L=8)) then
begin
if L=6 then
D1:=copy(D1,1,2)+'/'+copy(D1,3,2)+'/'+copy(D1,5,2)
else
D1:=copy(D1,1,2)+'/'+copy(D1,3,2)+'/'+copy(D1,5,4);
end;
if (pos('/',TEdit(Sender).Text)=0) and (L=4) then
begin
D1:=D1+zAno;
L:=length(D1);
if L=6 then
D1:=copy(D1,1,2)+'/'+copy(D1,3,2)+'/'+copy(D1,5,2)
else
D1:=copy(D1,1,2)+'/'+copy(D1,3,2)+'/'+copy(D1,5,4);
end;
if isdate(D1) Then TEdit(Sender).Text:=D1;
if not isdate(D1) Then
begin
key:=#0;
ShowMessage('Data Invalida');
TEdit(Sender).SetFocus;
end;
end;
end;
end;
end.
Até a próxima.
.
quarta-feira, 26 de agosto de 2009
O componente LazGradient
Com esse componente os programas escritos em lazarus ficam com um visual bem atraente, mas cuidado pra não exagerar na dose.
Exemplo simples:
Exemplo mais complexo:
Propriedades principais:
BeginColor:TColor
EndColor:TColor
Orientation => foLeftToRight, fdTopToBottom
Rounded => Boolean
Na versão atual esse componente ao ser adicionado no form, automaticamente ocupa toda a tela.
Para corrigir, faça as alterações a seguir.
Abra o pacote lazgradient.lpk
Abra a unit gradient.pas e localize o codigo abaixo:
constructor TLazGradient.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
BeginColor:= clBlue;
EndColor:= clWhite;
Orientation:= foLeftToRight;
Align:= alClient;
Alignment := taCenter;
Rounded:= False;
end;
Mude
Align:= alClient;
para:
Align:= alNone;
Adicione as linhas abaixo:
Height:=35;
Width:=120;
Deve ficar assim:
constructor TLazGradient.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
BeginColor:= clBlue;
EndColor:= clWhite;
Orientation:= foLeftToRight;
Align:= alNone;
Alignment := taCenter;
Rounded:= False;
Height:=35;
Width:=120;
end;
Incremente seu sistema de automação comercial, pdv, etc.
Experimente o LazGradient !
Link para download do componente:
http://wile64.perso.neuf.fr/download/lazarus/lazgradient.zip
Até a proxima.
Exemplo simples:
Exemplo mais complexo:
Propriedades principais:
BeginColor:TColor
EndColor:TColor
Orientation => foLeftToRight, fdTopToBottom
Rounded => Boolean
Na versão atual esse componente ao ser adicionado no form, automaticamente ocupa toda a tela.
Para corrigir, faça as alterações a seguir.
Abra o pacote lazgradient.lpk
Abra a unit gradient.pas e localize o codigo abaixo:
constructor TLazGradient.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
BeginColor:= clBlue;
EndColor:= clWhite;
Orientation:= foLeftToRight;
Align:= alClient;
Alignment := taCenter;
Rounded:= False;
end;
Mude
Align:= alClient;
para:
Align:= alNone;
Adicione as linhas abaixo:
Height:=35;
Width:=120;
Deve ficar assim:
constructor TLazGradient.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
BeginColor:= clBlue;
EndColor:= clWhite;
Orientation:= foLeftToRight;
Align:= alNone;
Alignment := taCenter;
Rounded:= False;
Height:=35;
Width:=120;
end;
Incremente seu sistema de automação comercial, pdv, etc.
Experimente o LazGradient !
Link para download do componente:
http://wile64.perso.neuf.fr/download/lazarus/lazgradient.zip
Até a proxima.
Assinar:
Postagens (Atom)
