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.

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.

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

.

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.

Problemas com SVN

A alguns dias tentei baixar a ultima versão do fortes4lazarus com o svn e não consegui, pois deu erro.

Executei o comando abaixo:

$svn co https://fortes4lazarus.svn.sourceforge.net/svnroot/fortes4lazarus/trunk fortes4lazarus

Deu o seguinte erro:

SSL negotiation failed: SSL disabled due to library version mismatch

Como eu ainda sou inexperiente com svn, achei que estava fazendo alguma coisa errada.

Mas não era. Na verdade era o pacote neon que estava desatualizado.

No meu caso,uso archlinux, executei:


#pacman -S openssl, neon

Pra usuarios do Ubuntu, digite:

#apt-get install openssl, neon

E pronto. Feito isso, o svn funcionou normalmente.

Espero ter colaborado.

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.
.

Dica de instalacao de componentes em ambiente linux

Alguns desenvolvedores, acostumados com o windows, tem certo receio de migrar seus aplicativos para linux, vista como uma plataforma dificil.
Isso não é verdade.
Eu só programo utilizando ambiente linux.

O proposito desse artigo é demonstrar como instalar componentes no ambiente de desenvolvimento lazarus, no caso o pacote/componente FortesReport4lazarus.

Após instalar o lazarus, versão 0.9.29 no meu Archlinux, fui instalar o componente FortesReport4lazarus.

Ao tentar instalar, tive alguns problemas.Vou descrever aqui como resolver esses problemas e instalar corretamente o pacote fortes4lazarus.
Não sei se esse erro acontece em todas as distribuições, mas comigo ja aconteceu no Archlinux e no slackware.

Vamos começar.

Fui em Package->Open package file(.lpk);
Abri o pacote fortes324forlaz.lpk;
Compilei, tudo certo;
Cliquei em Install, deu um erro com a seguinte mensagem:

Unable to find "componenttreeview.pas"




Esse arquivo encontra-se na pasta /usr/lib/lazarus/ideintf/ basta executar um find para encontra-lo, assim:
find /usr/lib/lazarus -name "componenttreeview.pas"

Agora, pra sanar o problema, vamos abrir o arquivo /etc/fpc.cfg

Procure pelo titulo:
# searchpath for units and other system dependent things

Acrescente a linha como descrita abaixo:
-Fu/usr/lib/lazarus/ideintf/

E salve o arquivo.


No pacote fortes324forlaz, clique novamente em install.
Agora dá outra mensagem:

Ambiguous unit found




Clique em Ignore All

Deu outra mensagem de erro:
Unable to find "rlreg.pas"




Essa unit faz parte do pacote fortes4lazarus.
No /etc/fpc.cfg procure a secao:
# searchpath for units and other system dependent things

Então acrescente a seguinte linha

-Fu/home/user/mycomponentes/laz/fortes324forlazarus

E salve.

Volte ao pacote fortes324forlaz e clique em install novamente.

Pronto! O pacote fortes324forlaz foi instalado corretamente.

Postem suas duvidas, criticas ou sugestões.

Até a proxima.

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.

Executando o lazarus no wine

Essa dica ficou obsoleta, pois a partir da versão 0.9.29 o lazarus funcionou perfeitamente no wine.

Para aqueles que desenvolvem pra linux e windows e o uso de uma maquina virtual não é uma alternativa muito pratica, e tem tempo pra encarar o wine, então essa dica pode ser interessante.

Realmente, rodar uma aplicação no wine pode não ser a opção mais confiavel, mas em muitos casos resolve o problema de ter que trabalhar com dois OS simultaneamente, o que implica o uso de maquinas virtuais, que consomem muito processamento da maquina, mas cada um tem uma opinião e depende de cada caso.

Rodando o lazarus

Varias vezes quando eu instalava o lazarus no wine, não era possivel trabalhar, pois não conseguia abrir os projetos.

Exemplo:

projeto g:\diversos\laztestewin32\linux\rlreportteste.lpi

Ao tentar abrir, o lazarus retorna que o projeto não existe:



E assim ocorre pra qualquer arquivo que tentar abrir.

A primeira solução que me veio a mente foi criar um link simbolico apontando pra pasta requerida, assim:
Considerando G:=/home/teste

cd /home/teste/diversos/laztestewin32/
ln -s linux/ linu

...e pronto, tava resolvido.

O problema é que ao abrir o mesmo arquivo, o lazarus suprimia a ultima letra outra vez, e assim sucessivamente, e tinha que criar um novo link.

Resolvi por a mão na massa e estudar o codigo.

Então criei as seguintes funções:

unit mainwine;

{$mode objfpc}{$H+}

interface

uses
Classes, SysUtils;

function WineValidFile(filename1:string):string;
function WineValidSaveFile(filename1:string):string;

implementation

function WineValidFile(filename1:string):string;
var
wineFile,wineFile2,winePath,winePath2:string;
wineListChar:TStringlist;
pathLen,charCount:integer;
begin
wineListChar:=TStringlist.Create;
Result:=filename1;
if not SysUtils.FileExists(filename1) then
begin
WinePath:=SysUtils.ExtractFilePath(filename1);
PathLen:=length(WinePath);
WinePath:=copy(WinePath,1,PathLen-1);
wineFile:=SysUtils.ExtractFileName(filename1);
for charCount:=32 to 127 do begin
wineFile2:=WinePath+chr(charCount)+'\'+wineFile;
if fileexists(wineFile2) then begin
Result:=wineFile2;
break;
end;
end;
end;

end;

function WineValidSaveFile(filename1:string):string;
var
wineFile,wineFile2,winePath,winePath2:string;
wineListChar:TStringlist;
pathLen,charCount:integer;
begin
wineListChar:=TStringlist.Create;
Result:=filename1;
if not SysUtils.FileExists(filename1) then
begin
WinePath:=SysUtils.ExtractFilePath(filename1);
PathLen:=length(WinePath);
WinePath:=copy(WinePath,1,PathLen-1);
wineFile:=SysUtils.ExtractFileName(filename1);
for charCount:=32 to 127 do begin
wineFile2:=WinePath+chr(charCount)+'\'+wineFile;
if DirectoryExists(WinePath+chr(charCount)+'\') then
begin
Result:=wineFile2;
break;
end;
end;
end;

end;

end.

Observei que o problema acontece sempre que se usa a classe TOpenDialog e TSaveDialog.

A unit que esta o codigo pra salvar os projetos, packages, etc é a main.pp.
Então, é só incluir essa unit (mainwine) na clausula uses da unit main.pp e chamar essas funções antes de abrir e salvar seus arquivos na ide.

crie uma diretiva USEWINE:
{$DEFINE USEWINE}

Agora implemente nos casos abaixo:

procedure TMainIDE.mnuOpenClicked(Sender: TObject);

...
For I := 0 to OpenDialog.Files.Count-1 do
Begin
AFilename:=CleanAndExpandFilename(OpenDialog.Files.Strings[i]);
{$IFDEF USEWINE}
AFilename:=mainwine.WineValidFile(AFilename);
{$ENDIF}
...

function TMainIDE.DoShowSaveFileAsDialog(AnUnitInfo: TUnitInfo;
var ResourceCode: TCodeBuffer): TModalResult;
...
NewFilename:=ExpandFileNameUTF8(SaveDialog.Filename);
{$IFDEF USEWINE}
NewFilename:=WineValidSaveFile(NewFilename);
{$ENDIF}
...

if ExtractFileExt(NewFilename)='' then begin
NewFilename:=NewFilename+SaveAsFileExt;
{$IFDEF USEWINE}
NewFilename:=WineValidSaveFile(NewFilename);
{$ENDIF}
end;
...
{$IFDEF USEWINE}
NewFilename:=WineValidSaveFile(NewFilename);
{$ENDIF}
NewFilePath:=ExtractFilePath(NewFilename);
...

function TMainIDE.DoShowSaveProjectAsDialog: TModalResult;

...
NewFilename:=ExpandFileNameUTF8(SaveDialog.Filename);
{$IFDEF USEWINE}
NewFilename:=WineValidSaveFile(NewFilename);
{$ENDIF}
if not FilenameIsAbsolute(NewFilename) then
RaiseException('TMainIDE.DoShowSaveProjectAsDialog: buggy ExpandFileNameUTF8');
NewProgramName:=ExtractFileNameOnly(NewFilename);
...

Eu não testei todos os casos, pois para mim desse jeito resolveu grande parte do problema, e o codigo da IDE é muito complexo, e extenso.

Mas fica registrada uma solução para o problema, e aqueles desenvolvedores que colaboram com o projeto e tem mais afinidade com o codigo da unit main.pp e outras units que compoem a IDE, podem apreciar e se for o caso, implementar definitivamente, e assim oferecer mais uma alternativa pro usuario.

Até a proxima.


English version:

Running lazarus under wine

For that they develop for linux and windows and the use of one virtual machine is not an alternative practises, and it has time to try wine, then this tip can be interesting.

Really run an application in wine can not be the option most trustworthy, but in many cases decided the problem to have that to work simultaneously with two OS, what implies the use of virtual machines, that they consume much processing of cpu, but each one has an opinion and depends on each case.

Make lazarus run on wine

Many times when I installed lazarus in wine, he was not possible to work, therefore he did not obtain to open the projects.
Example:

project g:\diversos\laztestewin32\linux\rlreportteste.lpi

When trying to open, lazarus returns that the project does not exist:



E thus occurs pra any archive that to try to open.
The first solution that came me the mind was to create one link symbolic pointing pra required folder, thus:
Considering:
G: =/home/teste
cd /home/teste/diversos/laztestewin32/
ln - s linux/linu

… and ready, it decided.
The problem is that when opening the same archive, lazarus suppressed finishes it letter another time, and thus successively, and had that to create new link.
I decided for the hand in the mass and to study the code.

Then I created following the functions:

Please, sees the unit mainwine.pas above listed

I observed that the problem happens whenever the class TOpenDialog and TSaveDialog is used.
Unit that this the code to save the projects, packages, etc is main.pp.
Then, is alone to include this unit (mainwine) in the uses clause of unit main.pp and to call these functions before opening and saving its archives in IDE.

It creates a directive USEWINE:
{$DEFINE USEWINE}

Now it implements in the cases below:


procedure TMainIDE.mnuOpenClicked(Sender: TObject);

...
For I := 0 to OpenDialog.Files.Count-1 do
Begin
AFilename:=CleanAndExpandFilename(OpenDialog.Files.Strings[i]);
{$IFDEF USEWINE}
AFilename:=mainwine.WineValidFile(AFilename);
{$ENDIF}
...

function TMainIDE.DoShowSaveFileAsDialog(AnUnitInfo: TUnitInfo;
var ResourceCode: TCodeBuffer): TModalResult;
...
NewFilename:=ExpandFileNameUTF8(SaveDialog.Filename);
{$IFDEF USEWINE}
NewFilename:=WineValidSaveFile(NewFilename);
{$ENDIF}
...

if ExtractFileExt(NewFilename)='' then begin
NewFilename:=NewFilename+SaveAsFileExt;
{$IFDEF USEWINE}
NewFilename:=WineValidSaveFile(NewFilename);
{$ENDIF}
end;
...
{$IFDEF USEWINE}
NewFilename:=WineValidSaveFile(NewFilename);
{$ENDIF}
NewFilePath:=ExtractFilePath(NewFilename);
...

function TMainIDE.DoShowSaveProjectAsDialog: TModalResult;

...
NewFilename:=ExpandFileNameUTF8(SaveDialog.Filename);
{$IFDEF USEWINE}
NewFilename:=WineValidSaveFile(NewFilename);
{$ENDIF}
if not FilenameIsAbsolute(NewFilename) then
RaiseException('TMainIDE.DoShowSaveProjectAsDialog: buggy ExpandFileNameUTF8');
NewProgramName:=ExtractFileNameOnly(NewFilename);
...

I did not test all the cases, therefore for me of this skill he decided great part of the problem, and the code of IDE is very complex, and extensive.
But a solution for the problem, and those developers is registered that collaborate with the project and have more affinity with the code of unit main.pp and others units that they make the IDE, can appreciate and it will be the case, to implement definitively, and thus to offer to end user a new alternative.

Until the next one.

Configurando fonte de tela multiplataforma

Quem desenvolve aplicações multiplataforma, muitas vezes tem o problema de visual gerado pela fonte de tela, que sempre acaba irritando.

Eu resolvia esse problema definindo manualmente a fonte que seria usada no linux, e outra fonte no windows, assim:
{$IFDEF LINUX}
self.font.name:='Helvetica';
{$ENDIF}

Assim, no linux usava a font 'Helvetica' e no windows a font 'Ms Sans Serif'.
Naturalmente não ficava perfeito, pois os tamanhos são diferentes.

Isso quando eu usava o kylix3.

Mas agora, com lazarus e a widget QT, consegui resolver esse problema de forma satisfatória.

Das varias fonts que eu testei, descobri que o font Verdana tem exatamente o mesmo resultado visual, tanto no windows como no linux, assim não preciso me preocupar em ficar redimensionando os labels, pra caber o texto em ambos os sistemas operacionais.

Portanto, antes de desenhar qualquer componente visual no form, mudei o font pra Verdana e pronto.

Não é o font mais bonito, mas não dava pra continuar do jeito que estava, pois configurar um font pra windows e outro pra linux é complicado.

Tambem é possivel configurar o font padrão das aplicações QT no QTConfig, mas eu não aconselho fazer isso.

Esse procedimento foi testado apenas no linux (não uso widget QT no windows)

Se alguem ja resolveu esse problema de outra maneira, aceito criticas e sugestões ok.

No proximo post, mostrarei como resolvi o problema de executar o lazarus dentro do wine, corrigindo aquele bug do diretório, que impede de abrir os projetos no wine.

Até a próxima.


English Version

Configuring screen font multiplatform

Who develops applications multiplatforms, many times has the problem of appearance generated for the screen font, that always finishes annoying. I decided this problem manually defining the font that would be used in linux, and another font in windows, thus:
{$IFDEF LINUX}
self.font.name: =' Helvetica' ;
{$ENDIF}
Thus, in linux ' used font; Helvetica' e in windows font ' Ms Sans Serif'. Of course he was not perfect, therefore the sizes are different.
This when I used kylix3.
But now, with lazarus and widget QT, I obtained the solution this problem of satisfactory form. Of them you vary fonts that I tested, I discovered that font Verdana has accurately the same resulted visual, as much in windows as in linux, to worry thus not necessary me in being change labels width, to fit the text in both the operational systems.
Therefore, before drawing any visual component in form, I changed font to Verdana. He is not font prettier, but it did not give to continue of the skill that was, therefore to configure one font for windows and another one for linux is complicated.

Also standard of applications QT in the QTConfig is possible to configure font, but I do not advise to make this.
This procedure was tested only in linux (not use widget QT in windows)
If somebody already decided this problem in another way, accepted you criticize and suggestions. In next post, I will show as I decided the problem to inside execute lazarus under wine, correcting that one bug of the directory, that it hinders to open the projects under wine.
Until the next one.

Usando o lazarus com QT widget

(English Version at the end of page)

Esta dica esta obsoleta. A partir da versão 0.9.28 a Qt vem configurada perfeitamente.

Apos varias tentativas, descobri com fazer funcionar perfeitamente(ou quase) o lazarus com a maravilhosa biblioteca Qt (versao 4.5.1)

Screenshot:




Pra quem não sabe, a QT foi disponibilizada sob a licença LGPL, tornando-se assim uma das melhores opções de trabalho no linux, senão a melhor.

Esse procedimento foi realizado no ARCHLINUX

.Baixar o arquivo
bin-qt4pas-V1.70_Qt4.5.0.tar.gz ou
bin64-qt4pas-V1.70_Qt4.5.0.tar.gz
..dependendo da arquitetura da maquina

descompactar:
tar -zxvf bin-qt4pas-V1.70_Qt4.5.0.tar.gz

dois arquivos serão descompactados:
libqt4intf.so
qt4.pas

Após descompactar, o arquivo libqt4intf.so deve ser copiado nas seguintes pastas:
/usr/lib
/usr/lib/lazarus/lcl/interfaces/qt

Copiados esses arquivos, entre na pasta /usr/lib/lazarus/lcl/interfaces/qt

#cd /usr/lib/lazarus/lcl/interfaces/qt

Duas tarefas a fazer nessa pasta:
.renomear o arquivo qt4.pas ja existente
mv qt4.pas qt4.pas.old

.alterar o arquivo qtdefines.inc
acrescentar a linha:
{$define USE_QT_44}

Em seguida entre na pasta /usr/lib/lazarus/lcl/units/i386/ e crie uma pasta qt

#cd /usr/lib/lazarus/lcl/units/i386/
mkdir qt
chmod 0777 qt

Na minha maquina, não era possivel compilar a ide, sempre dava erro de unit não encontrada

Alterando o arquivo /etc/fpc.cfg, inclui a seguinte linha na seção
# searchpath for units and other system dependent things
-Fu/usr/lib/lazarus/ideintf/

A LCL Qt tem um bug no linux, não aparece o botão fechar do form, de qualquer form até mesmo da ide, o que traz um grande desconforto pro desenvolvedor.
No meu caso, resolvi esse problema da seguinte forma:

Localize a unit qtwsforms.pp

Abra a unit e localize: TQtWSCustomForm.CreateHandle

Apartir da linha 153, deve aparecer o seguinte codigo:

if not (csDesigning in TCustomForm(AWinControl).ComponentState) then
begin
UpdateWindowFlags(QtMainWindow, TCustomForm(AWinControl).BorderStyle,
TCustomForm(AWinControl).BorderIcons, TCustomForm(AWinControl).FormStyle);
end;

altere para:

{$IFDEF LINUX}
UpdateWindowFlags(QtMainWindow, TCustomForm(AWinControl).BorderStyle,
[biSystemMenu,biHelp], TCustomForm(AWinControl).FormStyle);
{$ELSE}
UpdateWindowFlags(QtMainWindow, TCustomForm(AWinControl).BorderStyle,
TCustomForm(AWinControl).BorderIcons, TCustomForm(AWinControl).FormStyle);
{$ENDIF}

.Salve as modificações

Pra recompilar o lazarus, entre em Tools->Configure Build Lazarus
Marque Build All
Selecione o widget qt (beta)
Clique em Build

Após concluir a compilação
marque Build IDE with Packages
Clique em Build

Se tudo tiver certinho, deve recompilar o lazarus com o widget QT, que apesar de ter alguns bugs, dá um resultado final muito mais bonito.
Em breve estarei postando aqui os bugs que eu encontrar

Até a próxima

English Version

Using lazarus with QT widget

After many attempts, I discovered with making to perfectly function (or almost) lazarus with the wonderful Qt library (version 4.5.1)
To who does not know, the QT was under license LGPL, becoming thus one of the best options of work in linux, or best.

This procedure was carried through in the ARCHLINUX

Download the archive bin-qt4pas-V1.70_Qt4.5.0.tar.gz or bin64-qt4pas-V1.70_Qt4.5.0.tar.gz .like your architecture of your pc.

to unpack:
tar - zxvf bin-qt4pas-V1.70_Qt4.5.0.tar.gz
two archives will be unpacked:
libqt4intf.so
qt4.pas

After to unpack, the archive libqt4intf.so must be copied in the following folders:
/usr/lib
/usr/lib/lazarus/lcl/interfaces/qt

Copied these archives, it enters in the /usr/lib/lazarus/lcl/interfaces/qt folder

#cd /usr/lib/lazarus/lcl/interfaces/qt

Two tasks to make in this folder:
to.rename the existing archive qt4.pas already
mv qt4.pas qt4.pas.old

to change the archive qtdefines.inc
to add the line:
{$define USE_QT_44}

After that it enters in the
/usr/lib/lazarus/lcl/units/i386/ folder and it creates a folder qt
#cd /usr/lib/lazarus/lcl/units/i386/
#mkdir qt
#chmod 0777 qt
In my case, it was not possible to compile IDE, always gave not joined error of unit
Modifying the /etc/fpc.cfg archive, it includes the following line in the section
# searchpath will be units and to other system dependent things
- Fu/usr/lib/lazarus/ideintf/

The LCL Qt has one bug in linux, does not appear the close button of form, of any form even though of IDE, what it brings a great developer discomfort.
In my case that, I decided this problem of the following mode:
.locate unit Qtwsforms.pp
.Open unit and it locates: TQtWSCustomForm.CreateHandle
Near the line 153, must appear the following code:

if not (csDesigning in TCustomForm(AWinControl).ComponentState) then
begin
UpdateWindowFlags(QtMainWindow, TCustomForm(AWinControl).BorderStyle,
TCustomForm(AWinControl).BorderIcons, TCustomForm(AWinControl).FormStyle);
end;

change to:

{$IFDEF LINUX}
UpdateWindowFlags(QtMainWindow, TCustomForm(AWinControl).BorderStyle,
[biSystemMenu,biHelp], TCustomForm(AWinControl).FormStyle);
{$ELSE}
UpdateWindowFlags(QtMainWindow, TCustomForm(AWinControl).BorderStyle,
TCustomForm(AWinControl).BorderIcons, TCustomForm(AWinControl).FormStyle);
{$ENDIF}


It saves the modifications
To compile lazarus, enters in Tools-> Build Lazarus configures


.Selects widget QT(beta)
.It marks Build All
.Click in Build
.After to conclude the compilation marks "Build IDE with Packages"
.Click in Build

If everything will right, must re-compile lazarus with widget QT, that although to have some bugs, of the much more pretty final resulted one. Soon I will be post here bugs that to find.

Best regards