Exclusividade para o programa

{Gostaria de saber como fazer para que, ao iniciar minha aplicação Delphi, eu " desabilite " o Shell do Windows (Explorer). Ou seja, o que eu preciso e' de uma forma de fazer com que apos a minha aplicação seja iniciada, o usuário não tenha como alternar entre programas, acessar outros ícones, etc No System.ini você tem uma configuração como esta :}

Shell=Explorer.exe

Basta trocar por

Shell=Myprog.exe

Ou usando delphi


procedure Tform1.ChangeShell(String programa);
var
ArquivoIni : Tinifile;
begin
try
ArquivoIni := Tinifile.Create('System.ini');
ArquivIni.WriteSection('Config','Shell','Myprog.exe');
fynally
ArquivoIni.Destroy;
end;
end;

Excluindo todos os registros de uma tabela

Procedure tbDBDeleteAll(const DataSet: TDataSet);
begin
with DataSet do
while RecordCount > 0 do
Delete;
end;

{ Chame-a como nos exemplos abaixo: }
tbDBDeleteAll(Table1);
ou
tbDBDeleteAll(Query1); Observações

{Se houver um filtro ou range ativo, somente os registros filtrados serão excluídos. Portanto é diferente de Table1.EmptyTable. Esta função poderá ser chamada no evento BeforeDelete do Table (ou Query) principal em um formulário mestre-detalhe para excluir os itens (da parte detalhe).}

Excluindo arquivos usando curingas (*.*)

{ - Coloque um Button no Form; - Altere o evento OnClick do Button conforme abaixo: }

procedure TForm1.Button2Click(Sender: TObject);
var
SR: TSearchRec;
I: integer;
begin
I := FindFirst('c:Teste*.*', faAnyFile, SR);
while I = 0 do begin
if (SR.Attr and faDirectory) <> faDirectory then
if not DeleteFile('c:Teste' + SR.Name) then
ShowMessage('Não consegui excluir c:Teste' + SR.Name);
I := FindNext(SR);
end;
end;

{No exemplo acima todos os arquivos do diretório c:Teste serão excluídos. CUIDADO! Arquivos excluídos desta forma não vão para a lixeira.}

Excluindo registros via sql

{Desejo excluir registro de uma tabela que dependem da existência de outros de outra(s) tabela(s), como fazer? }
DELETE FROM
WHERE (, ,)
IN
(SELECT , ,
FROM a, b
WHERE a. = b.
AND b. = 'AP' )

Evitando a proteção de tela durante a execução do programa

//Inclua na seção uses: Windows { Na seção "private" do Form principal acrescente: }


procedure AppMsg(var Msg: TMsg; var Handled: Boolean); { Na seção "implementation" acrescente (troque TForm1 para o nome do seu form principal): }

procedure TForm1.AppMsg(var Msg: TMsg; var Handled: Boolean);

begin

if (Msg.Message = wm_SysCommand) and

(Msg.wParam = sc_ScreenSave) then

Handled := true;

end;

{ No evento "OnCreate" do form principal, coloque: }

Application.OnMessage := AppMsg;

Evitando a perca dos dados

{Um dos problemas dos programadores Delphi é salvar as informações fisicamente no disco rígido. Quando estamos trabalhando com o programa as informações ficam retidas no buffer, o que, em caso de queda de energia ou até mesmo se o usuário fechar o Windows com a aplicação aberta resulta na perda dos dados, que foram processados na execução atual do sistema. Para resolver o problema, basta acrescentar no evento AfterPost de cada componente Table as linhas de código que estão abaixo.

Na lista de Uses acrescente a unit DBIProcs.

Dessa forma, você não precisa temer perder os seus dados por uma falha elétrica ou pela quebra do sistema (como um erro GPF, por exemplo), após atualizar o banco de dados.}

implementation

uses DBIProcs;

{$R *.DFM}
procedure TForm1.Table1AfterPost(DataSet: Dataset);
begin
DBISaveChanges(Table1.Handle);
end;
end;

Evitando o erro de key violation

{O código abaixo deve ser inserido no evento OnPostError do componente de banco de dados (Table ou Query). Toda vez que ocorrer um erro de gravação no banco de dados este evento será executado, sendo que na variável de parâmetro "E" deste procedimento é armazenado a mensagem que será apresentada na tela.

No caso de Key Violation a mensagem é exatamente esta: "Key violation.".

Para realizar um tratamento deste erro, testa-se se a mensagem ocorrida é "Key violation.', se for verdadeiro o processo de gravação é abortado (Action := daAbort).}


Procedure TForm1.Table1PostError(DataSet: TDataSet; E: EDatabaseError;var Action: TDataAction);
Var
ErroMens :String;
begin
ErroMens := E.Message;
if ErroMens = 'Key violation.' then begin ShowMessage('Chave Primária Inválida !');
action := daAbort;
end;
end;

Evitando caracteres com acento 2

Function TiraAcentos(s : string): string;
const
Acentos = 'ÁÍÓÚÉÄÏÖÜËÀÌÒÙÈÃÕÂÎÔÛÊáíóúéäïöüëàìòùèãõâîôûêÇç|#$%^&*()!~`"';
Letras = 'AIOUEAIOUEAIOUEAOAIOUEaioueaioueaioueaoaioueCc ';
var
i: Integer;
begin
for i := 1 to Length(Acentos) do
while Pos(acentos[i],s)>0 do
s[Pos(acentos[i],s)]:=Letras[i];
Result := S;
end;

Evitando caracteres com acento

{A função abaixo pega um string informada como parâmetro e retira todas as letras acentuadas substituindo-as por letras correspondentes sem acento. }
function AnsiToAscii ( str: String ): String;
var
i: Integer;
begin
for i := 1 to Length ( str ) do
case str[i] of
'á': str[i] := 'a';
'é': str[i] := 'e';
'í': str[i] := 'i';
'ó': str[i] := 'o';
'ú': str[i] := 'u';
'à': str[i] := 'a';
'è': str[i] := 'e';
'ì': str[i] := 'i';
'ò': str[i] := 'o';
'ù': str[i] := 'u';
'â': str[i] := 'a';
'ê': str[i] := 'e';
'î': str[i] := 'i';
'ô': str[i] := 'o';
'û': str[i] := 'u';
'ä': str[i] := 'a';
'ë': str[i] := 'e';
'ï': str[i] := 'i';
'ö': str[i] := 'o';
'ü': str[i] := 'u';
'ã': str[i] := 'a';
'õ': str[i] := 'o';
'ñ': str[i] := 'n';
'ç': str[i] := 'c';
'Á': str[i] := 'A';
'É': str[i] := 'E';
'Í': str[i] := 'I';
'Ó': str[i] := 'O';
'Ú': str[i] := 'U';
'À': str[i] := 'A';
'È': str[i] := 'E';
'Ì': str[i] := 'I';
'Ò': str[i] := 'O';
'Ù': str[i] := 'U';
'Â': str[i] := 'A';
'Ê': str[i] := 'E';
'Î': str[i] := 'I';
'Ô': str[i] := 'O';
'Û': str[i] := 'U';
'Ä': str[i] := 'A';
'Ë': str[i] := 'E';
'Ï': str[i] := 'I';
'Ö': str[i] := 'O';
'Ü': str[i] := 'U';
'Ã': str[i] := 'A';
'Õ': str[i] := 'O';
'Ñ': str[i] := 'N';
'Ç': str[i] := 'C';
end;
Result := str;
end;

Estado de uma tabela (ttable)

If Table1.State in [dsInsert, dsEdit] then
begin
//seus comandos
end;

Espaço maior no richedit

SendMessage(RichEdit1.Handle, EM_EXLIMITTEXT, 0, $FFFFFF);

//a depender da suar versão do delphi use

SendMessage(RichEdit1.Handle, EM_LIMITTEXT, 0, $FFFFFF);

Escrevendo um texto na diagonal usando o canvas

Procedure TForm1.Button1Click(Sender: TObject);
var
lf : TLogFont;
tf : TFont;
begin
with Form1.Canvas do
begin
Font.Name := 'Arial';
Font.Size := 24;
tf := TFont.Create;
tf.Assign(Font);
GetObject(tf.Handle, sizeof(lf), @lf);
lf.lfEscapement := 450;
lf.lfOrientation := 450;
tf.Handle := CreateFontIndirect(lf);
Font.Assign(tf);
tf.Free;
TextOut(20, Height div 2, 'Coloque o texto aqui!');
end;
end;

Escondendo o ícone da barra de tarefas

//Insira estas linhas no onShow do seu Aplicativo para que ele fique invisível
//na barra do menu Iniciar: var
H : HWnd;
begin
H := FindWindow(Nil,'Project1'); {troque project1 pelo nome do seu projeto)
if H <> 0 then ShowWindow(H,SW_HIDE);
end;

Escondendo/mostrando o botão iniciar

Procedure EscondeIniciar(Visible:Boolean);
Var taskbarhandle,
buttonhandle : HWND;
begin
taskbarhandle := FindWindow('Shell_TrayWnd', nil);
buttonhandle := GetWindow(taskbarhandle, GW_CHILD);
If Visible=True Then Begin
ShowWindow(buttonhandle, SW_RESTORE); {mostra o botão}
End Else Begin
ShowWindow(buttonhandle, SW_HIDE); {esconde o botão}
end;
end;

Escondendo ícones do desktop

ShowWindow(FindWindow(nil,'Program Manager'),SW_HIDE); //Para mostrar :

ShowWindow(FindWindow(nil,'Program Manager'),SW_SHOW);

Escondendo o programa de ctrl+alt+del

Unit Unit1;

interface

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

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

var
Form1: TForm1;

implementation

{$R *.DFM}
{Para ocultar um programa, deve-se registrar este como um serviço do Windows. Normalmente um serviço do Windows é ativado quando com a inicialização do sistema (Windows) e pemanece ativo até a finalização deste. Este processo esconde o programa da lista "Ctrl+Alt+Del"}
Const
Servico_Simples = 1;
Servico_Unregister = 1;

Function RegisterServiceProcess(DwProcessID, dwType: DWord): DWord; StdCall; External 'KERNEL32.dll';


procedure TForm1.FormCreate(Sender: TObject);
begin
RegisterServiceProcess(GetCurrentProcessID, Servico_Simples);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
RegisterServiceProcess(GetCurrentProcessID, Servico_Unregister);
end;
end.

Escondendo janelas filhas minimizadas

{Para esconder janelas filhas minimizadas, basta capturar a mensagem WM_Size, desta maneira: }
type
TForm1 = class(TForm)
public
procedure WMSize(var M : TWMSIZE);Message WM_Size;
end;
implementation
procedure TForm1.WMSize(var M:TWMSIZE);
begin
if M.SizeType=Size_Minimized then
ShowWindow(Handle,Sw_Hide);
end;

Esconde/mostra a barra de tarefas

Procedure EscondeTaskBar(Visible: Boolean);
var wndHandle : THandle;
wndClass : array[0..50] of Char;
begin
StrPCopy(@wndClass[0],'Shell_TrayWnd');
wndHandle := FindWindow(@wndClass[0], nil);
If Visible=True Then Begin
ShowWindow(wndHandle, SW_RESTORE); {Mostra a barra de tarefas}
End Else Begin
ShowWindow(wndHandle, SW_HIDE); {Esconde a barra de tarefas}
End;
end;

Enviando um email

Smtp.postmessage.toAddress := StringList (por ex uma listbox)';
smtp.postmessage.FromAdreess := ex: meu_email@123.pt';
smtp.userid := 'ex: user@123.pt'
smtp.host := 'ex: smtp@123.pt'
smtp.postmessage.subject := 'Assunto'
smtp.postmessage.body := 'Texto da mensagem (stringlist)'

smtp.connect;
smtp.sendmail;
smtp.disconnect; {Fazer um aplicativo completo para manipulação de e-mails é um tanto trabalhoso e não é o assunto desta dica. Muitas vezes, porém, queremos apenas dar ao nosso software a capacidade de enviar simples e-mails. Isto é fácil, especialmente porque o Delphi5/6 nos oferece o componente TNMSMTP (paleta FastNet) que faz praticamente todo o trabalho para nós. Precisamos apenas alterar algumas propriedades e chamar alguns métodos para que a mensagem seja enviada. Vamos para a prática:

1. Coloque um componente TNMSMTP no form.

2. Coloque um botão e no evento OnClick deste botão escreva:}


procedure TForm1.Button1Click(Sender: TObject);
begin

{ Seu servidor SMTP }
NMSMTP1.Host := 'smtp.servidor.com.br';

{ Porta SMTP, **NÃO MUDE ISTO** }
NMSMTP1.Port := 25;

{ Nome de login do usuário }
NMSMTP1.UserID := 'MeuLogin';

{ Conecta ao servidor }
NMSMTP1.Connect;

{ Se ocorrer algum erro durante a conexão com o servidor, avise! }
if not NMSMTP1.Connected then
raise Exception.Create('Erro de conexão');

with NMSMTP1.PostMessage do begin
{ Seu e-mail }
FromAddress := 'meuemail@meuserver.com.br';

{ Seu nome }
FromName := 'Meu Nome';

{ E-mail do destinatário }
ToAddress.Clear;
ToAddress.Add('destinatario@servidor.com.br');

{ Assunto da mensagem }
Subject := 'Assunto da mensagem';

{ Corpo da mensagem }
Body.Clear;
Body.Add('Primeira linha da mensagem');
Body.Add('Segunda linha da mensagem');
Body.Add(''); { Linha em branco }
Body.Add('Última linha da mensagem');

{ Anexar arquivos(Se não quiser anexar arquivos, apague as 3 linhas seguintes) }

Attachments.Clear;

{ Endereço do anexo }
Attachments.Add('c:diretorioarquivo.ext');

end;

{ Manda o e-mail }
NMSMTP1.SendMail;
{ Disconecta do servidor }
NMSMTP1.Disconnect;
end; { Para enviar o mesmo e-mail para vários destinatário de uma só vez basta adicionar os endereços de e-mails de todos os destinatários em NMSMTP1.PostMessage.ToAddress. }

Enviando relatório do quickreport para txt

Uses QRExport

{ Utilize o componente QRTextFilter }
procedure TForm1.Button4Click(Sender: TObject);
begin
{ Exemplo 1 }
QuickRep1.ExportToFilter(TQRAsciiExportFilter.Create('C:REPORT.TXT'));

{ Exemplo 2 }
QuickRep1.ExportToFilter(TQRHTMLDocumentFilter.Create('C:REPORT.htm'));
QuickRep1.ExportFilter.Free;
end;

Enviando comandos de rolagem vertical para um memo

//Inclua na seção uses: Windows

SendMessage(Memo1.Handle, WM_VSCROLL, SBPAGEDOWN, 0);

{Onde:

Memo1.Handle = manipulador da janela do Memo1.

WM_VSCROLL = Mensagem do Windows - rolagem vertical.

SB_PAGEDOWN = Comanndo de rolagem - página para baixo.

Outros exemplos:
}

{ Página para cima }
SendMessage(Memo1.Handle, WM_VSCROLL, SB_PAGEUP, 0);
{ Linha para baixo }
SendMessage(Memo1.Handle, WM_VSCROLL, SB_LINEDOWN, 0);
{ Linha para cima }
SendMessage(Memo1.Handle, WM_VSCROLL, SB_LINEUP, 0); {Além desta técnica existem API's do Windows que fazem um trabalho equivalente. }

Enviando um arquivo para a lixeira

Uses ShellAPI;

Function DeleteFileWithUndo(sFileName : string ) : boolean;
var
fos : TSHFileOpStruct;
Begin
FillChar( fos, SizeOf( fos ), 0 );
With fos do
begin
wFunc := FO_DELETE;
pFrom := PChar( sFileName );
fFlags := FOF_ALLOWUNDO
or FOF_NOCONFIRMATION
or FOF_SILENT;
end;
Result := ( 0 = ShFileOperation( fos ) );
end;

Enviando combinação de teclas para o buffer do teclado

// Exemplo : PostKeyEx32(Ord('A'), [ssCtrl], false);
// Envia Ctrl+A para o controle que tiver o foco.
// Key : virtual keycode da tecla a enviar. Para caracteres
// imprimíveis informe o código ANSI (Ord(CHARACTER)).
// Shift : estado das teclas modificadoras.
// Shift, Control, Alt, Mouse Buttons.
// SpecialKey: normalmente deve ser False. Informe True se
// a tecla desejada for, por exemplo, do teclado numérico. procedure PostKeyEx32(Key: Word; const Shift: TShiftState; SpecialKey: boolean);
type
TShiftKeyInfo = Record
shift: Byte;
vkey : Byte;
End;
byteset = Set of 0..7;
const
ShiftKeys: array [1..3] of TShiftKeyInfo =
((shift: Ord(ssCtrl); vkey: VK_CONTROL ),
(shift: Ord(ssShift); vkey: VK_SHIFT ),
(shift: Ord(ssAlt); vkey: VK_MENU ));
var
Flag: DWORD;
bShift: ByteSet absolute shift;
i: Integer;
begin
for i := 1 to 3 do begin
if shiftkeys[i].shift in bShift then
Keybd_Event(ShiftKeys[i].vkey,
MapVirtualKey(ShiftKeys[i].vkey, 0), 0, 0);
end; // for
if SpecialKey Then
Flag := KEYEVENTF_EXTENDEDKEY
else
Flag := 0;
Keybd_Event(Key, MapvirtualKey(Key, 0), Flag, 0);
Flag := Flag or KEYEVENTF_KEYUP;
Keybd_Event(Key, MapvirtualKey(Key, 0), Flag, 0);
for i := 3 DownTo 1 do
begin
if ShiftKeys[i].shift in bShift then
Keybd_Event(shiftkeys[i].vkey,
MapVirtualKey(ShiftKeys[i].vkey, 0),
KEYEVENTF_KEYUP, 0);
end; // for
end; // PostKeyEx32

Enviando caracteres para outra aplicação

Var
myHandle : THandle;
begin
myHandle:= FindWindow( 'MyAppClass', 'MyAppCaption');
if myHandle <> 0 then
PostMessage( myHandle, WM_KeyDown, myCharCode, 0 );
end;

Enter funcionando como tab em toda a aplicação

Uses
Grids
procedure TfrmPri.MudarComEnter(var Msg: TMsg; var Handled: Boolean);
begin
If not ((Screen.ActiveControl is TCustomMemo) or
(Screen.ActiveControl is TCustomGrid) or
(Screen.ActiveForm.ClassName = 'TMessageForm')) then
begin
If Msg.message = WM_KEYDOWN then
begin
Case Msg.wParam of
VK_RETURN,VK_DOWN : Screen.ActiveForm.Perform(WM_NextDlgCtl,0,0);
VK_UP : Screen.ActiveForm.Perform(WM_NextDlgCtl,1,0);
end;
end;
end;
end;
//No evento OnCreate o Form Principal digite a seguinte linha


Application.OnMessage := MudarComEnter;

Encriptando/desencriptando strings

{Esta função permite encriptar e desencriptar strings. O código de encriptação é bastante simples, por isso pode ser melhorado, sendo este apenas um exemplo de como fazê-lo em Delphi. }
function EnDecryptString(StrValue : String; Chave: Word) : String;
var
I: Integer;
OutValue : String;
begin
OutValue := '';
for I := 1 to Length(StrValue) do
OutValue := OutValue + char(Not(ord(StrValue[I])-Chave));
Result := OutValue;
end; Exemplo de utilização:

{Iniciar um novo projecto, copiar a função para uma unit, colocar três TEdit (Edit1, Edit2, Edit3) e dois TButton (Button1 e Button2) na form.

No evento OnClick do Button1 deve chamar a função, em que os parâmetros de entrada são o texto do Edit1 e uma chave de encriptação do tipo word.}

procedure TForm1.Button1Click(Sender: TObject);
begin
Edit2.text:=EnDecryptString(Edit1.text, 236);
end;

{No evento OnClick do Button2 deve chamar a função EnDecryptString, em que os parâmetros de entrada são o texto encriptado do Edit2 a chave de encriptação usada para encriptar a string.}

procedure TForm1.Button2Click(Sender: TObject);
begin
Edit3.text:=EnDecryptString(Edit2.text, 236);
end;

Encriptando/desencriptando arquivos

{Este procedimento permite encriptar e desencriptar arquivos de qualquer tipo. O código de encriptação é bastante simples, por isso pode ser melhorado, sendo este apenas um exemplo de como fazê-lo em Delphi. }
procedure EnDecryptFile(INFName, OutFName : String; Chave : Word);
var
InMS, OutMS : TMemoryStream;
I : Integer;
C : byte;
begin
InMS := TMemoryStream.Create;
OutMS := TMemoryStream.Create;
try
InMS.LoadFromFile(INFName);
InMS.Position := 0;
for I := 0 to InMS.Size - 1 do
begin
InMS.Read(C, 1);
C := (C xor not(ord(chave shr I)));
OutMS.Write(C,1);
end;
OutMS.SaveToFile(OutFName);
finally
InMS.Free;
OutMS.Free;
end;
end; Exemplo de utilização:

{Iniciar um novo projecto, copiar o procedimento EnDecryptFile para uma unit, colocar dois TButton (Button1 e Button2) na form.

No evento OnClick do Button1 deve chamar o procedimento, em que os parâmetros são o a path do arquivo a encriptar, a path para onde o arquivo deve ser encriptado e uma chave de encriptação.}


procedure TForm1.Button1Click(Sender: TObject);
begin
EnDecryptFile('c:arquivo.txt', 'c:arquivo1.txt', 12);
end; {No evento OnClick do Button2 deve chamar o procedimento, em que os parâmetros são o a path e o nome do arquivo encriptado, a path e o nome para onde o arquivo deve ser desencriptado e a chave de encriptação usada para encriptar o arquivo original.}


procedure TForm1.Button2Click(Sender: TObject);
begin
EnDecryptFile('c:ficheiro1.txt', 'c:ficheiro2.txt', 12);
end; {Agora verifique se o arquivo c:arquivo.txt é igual ao arquivo c:arquivo2.txt, se é então correu tudo bem! }

Emulando o pressionamento de uma tecla

Keybd_event(65,0,0,0); {Será enviado um 'A' para o componente que estiver em foco. }

Emitindo uma nota fiscal ou um boleto bancário

//Nota Fiscal

procedure TFmPedidos.btNotaClick(Sender: TObject);
var
Valorbase:DOUBLE;
valoricms:DOUBLE;
CONTADOR:Integer;
IMPRESSORA:TextFile;

begin
{POSICIONA O PONTEIRO DA TABELA DE CLIENTES,
EM RELAÇÃO À TABELA DE PEDIDOS}
DmDados.tbClientes.FindKey([DMDADOS.Tbpedidosped_Cliente.Value]);
{Relaciona a variável impressora com a
lpt1: - Poderia ser LPT, COM1,// Servidor/impressora}
AssignFile(IMPRESSORA,'LPT1:');
{abre a porta da impressão }
Rewrite(IMPRESSORA);
{envia caractere de controle para comprimir a impressão}
Write(IMPRESSORA);
{ Imprime o caractere "x" (marcando Nota de Saída) e salta para próxima linha}
Writeln(Impressora,Format('%80s',['x']));
{ salta duas linhas}
Writeln(impressora);
Writeln(Impressora);
{ Imprime a string "Vendas", alinhado à esquerda"-" dentro de uma área de quarenta caracteres}
Write(Impressora,Format('%-40s',['Vendas']));
{ Imprime a string "5.12", e salta para próxima linha}
WriteLn(Impressora,Format('%10s', ['5.12']));
{ Salta duas linhas}
Writeln(impressora);
Writeln(Impressora);
{ ---- Impressão dos Dados do Consumidor-----}
{ Imprime a Razão Social, alinhado à esquerda dentro de uma área de 90 caracteres}
Write (Impressora,Format('%-90s', [ dmdados.tbClientesCli_Razao.Value]));
{ Imprime a CGC, alinhado à esquerda dentro de umaárea de 30 caracteres}
Write(Impressora,Format('%-30s', [dmdados.tbClientesCli_CGC.Value]));
{ Imprime a Data de Emissão, baseada na data atual e salta para próxima linha}
Writeln(Impressora,DatetoStr(Date));
{ Salta uma linha}
Writeln(Impressora);
{ Imprime Endereço,alinhado à esquerda"-" dentro de uma área de 70 carcateres}
Write(Impressora,Format('%-70s',[dmdados.tbClientesCli_Endereco.Value]));
{Imprime Bairro, dentro de uma área de 35 carcateres}
Write(Impressora,Format('%-35s',[dmdados.tbClientesCli_Bairro.Value]));
{ Imprime CEP, dentro de uma área de 15 carcateres}
Write(Impressora,Format('%-15s', [dmdados.tbClientesCli_CEP.Value]));
{Imprime a Data de Saída, baseada na Hora Atual e Salta para próxima Linha}
Writeln(Impressora,DatetoStr(Date));
{ Salta uma linha}
Writeln(Impressora);
{ Imprime Munícipio, dentro de uma área de 60 caracteres}
Write(Impressora, Format('%-60s', [dmdados.tbClientesCli_Cidade.Value]));
{ Imprime DD+Telefone, dentro de uma área de 30 caracteres}
Write(Impressora,Format('%-30s',[dmdados.tbClientesCli_DDD.Value+' '+ dmdados.tbClientesCli_Fone1.Value]));
{ Imprime Estado (UF), dentro de uma área de 5 caracteres}
Write(Impressora,Format('%-5s',[dmdados.tbClientesCli_Estado.Value]));
{ Imprime Inscrição Estadual, dentro de uma área de 25 caracteres}
Write(Impressora,Format('%-25s',[dmdados.tbClientesCli_Inscricao.value]));
{ Imprime a Hora de Saída, baseada na Hora Atual e Salta para próxima Linha}
Writeln(Impressora,TimetoStr(time));
{ Salta três linhas}
Writeln(Impressora);
Writeln(Impressora);
Writeln(Impressora);
{----- Fase de Emissão dos Itens da Nota -----}
{ Zero variáveis}
Valorbase:=0;
valoricms:=0;
{ Move o ponteiro de registro da tabela de Itens para o primeiro}
Dmdados.TbItens.First;
{ Início do Laço}
While not (Dmdados.tbItens.Eof) do
Begin
{ Imprime Código produto}
Write(Impressora,Format('%-15s', [InttoStr(Dmdados.tbItensIT_Produto.Value)]));
{ Imprime Descrição do produto}
Write(Impressora,Format('%-68s', [dmdados.TbitensProdutos.value]));
{ Imprime Quantidade Comercializada}
Write(Impressora,Format('%12.2n',[Dmdados.tbItensIt_Quantidade.value]));
{ Imprime Preço Unitário produto}
Write(Impressora,Format('%15.2m',[dmdados.tbitensit_valor.value]));
{ Imprime o valor Total do Item e salta uma linha}
Writeln(Impressora,Format('&15.2f', [dmdados.tbItensValorItem.Value]));
{ Soma o valor Base de Cálculo do ICMS}
Valorbase:=ValorBase + dmdados.tbItensValorItem.Value;
{ Próximo Item}
Dmdados.Tbitens.next;
end;
{ laço de Itens}
{ Salta o núemro de linhas necessárias para completar o espaço restante de itens}
For Contador:= 1 to (20- dmdados.tbItens.recordCount)do
Writeln(Impressora);
{ Salta duas Linhas}
Writeln(Impressora);
Writeln(Impressora);
{ Imprime o valor total dos produtos e salta uma linha}
Writeln(Impressora,Format('%120.2f',[ValorBase]));
{ Salta duas linhas}
Writeln(Impressora);
Writeln(Impressora);
{ Cálculo do Imposto - baseada na Alíquota de 12%}
valoricms:=(Valorbase*0.12);
{ Imprime Valor base}

Write(Impressora,Format('%30.2f',[Valorbase]));
{ Imprime Valor ICMS e salta 'p/ próxima linha}
Write(Impressora, Format('%30.2f',[ ValorICMS]));
{ Salta uma linha}
Writeln(Impressora);
{ Imprime o valor total da Nota e salta uma linha}
Writeln(Impressora,Format('%120.2f',[Valorbase]));
{ Salta duas linhas}
Writeln(Impressora);
Writeln(Impressora);
{ Imprime informações transportador}
Writeln(Impressora,Format('%-30s', ['o mesmo']));
{ salta tr6es Linhas}
Writeln(Impressora);
Writeln(Impressora);
Writeln(Impressora);
{ Fecha a porta de impressão}
System.Close(Impressora);
end; { final da procedure}
Boleto bancário



procedure TFmGerRec.BtBoletaClick(Sender: TObject);
Var
Impressora:TextFile;

begin
AssignFile(Impressora,'LPT1:');
Rewrite(Impressora);
Writeln(impressora);
//Imprime Local de pagamento
Write(impressora,Format('%-50s',[' (PAGAVEL EM QUALQUER BANCO ATE O VENCIMENTO)']));
//Imprime Data Vencto e pula para próxima linha
Writeln (impressora,Format('%-20s',[''+DatetoStr(DmDados.TbcontasRecRec_DataVencto.Value)]));
//pula três linhas
Writeln(Impressora);
Writeln(impressora);
Writeln(impressora);

//Imprime Data de Emissão e Número Documento e salta duas linhas

Writeln(impressora,Format('%-50s',[''+DatetoStr(DmDados.TbcontasRecRec_DataEmissao.Value)]));
Writeln(impressora,Format('%-52s',[''+InttoStr(DmDados.TbcontasRecRec_Numero.Value)]));

Writeln(impressora);

//Imprime valor do Documento e pula p/ Próxima linha

Write(impressora, Format('%-55s',[ ' ']));
Writeln(impressora, Format('%-8.2m',[DmDados.TbContasRecRec_Valor.Value]));


//Pula duas linhas
Writeln(impressora);
Writeln(impressora);

//Imprime informações de Responsabilidade do Cedente

Writeln(impressora, Format('%-50s',[' Neste Espaco Voce pode imprimir o Texto']));
Writeln(impressora, Format('%-50s',[' De Responsabilidade do Cedente, comum em ']));
Writeln(impressora, Format('%-50s',[' Diversos Bancos,Ex: ']));
Writeln(impressora, Format('%-50s',[' -Cobrar Juros de 10%/Mes Apos Vencimento']));

// Pula duas Linhas

WriteLn(impressora);
Writeln(impressora);

//imprime informações do Sacado

Writeln(impressora, Format('%-50s',[''+DmDados.TbcontasRecRazao.Value+'-CGC/CPF'+Dmdados.TbContasRecCgc.Value]));
Writeln(impressora, Format('%-50s',[''+DmDados.TbContasRecEndereco.Value]));
Writeln(impressora, Format('%-50s',[' CEP'+DmDados.TbContasRecCEP.Value+''+Dmdados.TbContasRecCidade.Value+''+ Dmdados.TbContasRecEstado.Value]));

//Pula três linhas
Writeln(impressora);
Writeln(impressora);
Writeln(impressora);
CloseFile(impressora);
end;

Eliminando caracteres de strings

Function EliminaCaracteres (sTexto: String; sCaracteres:Set of Char):String;
{Elimina de sTexto todos os caracteres passados como parametro}
var
nPos, nTam: Integer;
begin
Result := '';
nPos := 1;
nTam := Lenght(sTexto);
while nPos <= nTam do
begin
if not (sTexto[nPos] in sCaracteres) then Result := Result +sTexto[nPos]
end;
end;

Eliminando os hints de uma treeview

Procedure TForm1.Button1Click(Sender: TObject);
begin
SetWindowLong(TreeView1.Handle, GWL_STYLE,
GetWindowLong(TreeView1.Handle,GWL_STYLE) or $80);
end; //para mostrar os hints novamente


SetWindowLong(TreeView1.Handle, GWL_STYLE,
GetWindowLong(TreeView1.Handle,GWL_STYLE) and not $80);

Efeito legal no caption do form 2

//declare as variaveis CAP e NCAR como gloobais.
var
cap : String;
ncar : Integer; // Inicialize as variáveis no evento Show do Form


cap := 'Digite aqui a Caption do Formulário';
ncar := 0; {- Coloque um objeto Timer no Form

- Modifique a Propriedade Interval do objeto Timer1 para 100

- No Evento OnTimer do objet Timer1 digite o seguinte}


IF ncar <= length(cap) then
begin
Form1.caption := copy(cap,1,ncar);
ncar := ncar +1;
end
else
begin
ncar := 0;
end;

Efeito legal no caption do form

Unit Unit1;

interface

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

type
TForm1 = class(TForm)
Timer1: TTimer;
procedure Timer1Timer(Sender: TObject);
procedure FormShow(Sender: TObject);
private
{ Private declarations }
WGiro : Integer;
WMesage : String;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Timer1Timer(Sender: TObject);
begin
Form1.Caption := WMesage;
Case WGiro of
1: begin
if Length(WMesage)<= 1 then
begin
WMesage := ' W';
WGiro := (WGiro + 1);
end;
WMesage := Copy(WMesage, 2,250);
end;

2: begin
if Length(WMesage)<= 2 then
begin
WMesage := ' I';
WGiro := (WGiro + 1);
end;
WMesage := Copy(WMesage, 3,250);
end;

3: begin
if Length(WMesage)<= 3 then
begin
WMesage := ' L ';
WGiro := (WGiro + 1);
end;
WMesage := 'W' + Copy(WMesage, 4,250);
end;

4: begin
if Length(WMesage)<= 4 then
begin
WGiro := (WGiro + 1);
end;
WMesage := 'WI' + Copy(WMesage, 5,250);
end;

5: begin
if Length(WMesage)<= 5 then
begin
WGiro := 1;
end;
WMesage := 'WIL' + Copy(WMesage, 6,250);
end;
end;
end;

procedure TForm1.FormShow(Sender: TObject);
begin
Timer1.Enabled := True;
WMesage := ' ';
WGiro := 1;
end;

end.

Drag e drop com o windows explorer

Interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, ComCtrls;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
PROCEDURE FileIsDropped ( VAR Msg : TMessage ) ; Message WM_DropFiles ;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation
uses
shellapi;
{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
DragAcceptFiles( Handle,True ) ;
end;

procedure TForm1.FileIsDropped ( VAR Msg : TMessage ) ;
var
hDrop : THandle ;
fName : ARRAY[0..254] OF CHAR ;
NumberOfFiles : INTEGER ;
fCounter : INTEGER ;
Names : STRING ;
begin
hDrop := Msg.WParam ;
NumberOfFiles := DragQueryFile(hDrop,-1,fName,254);
Names := '' ;
for fCounter := 1 TO NumberOfFiles DO BEGIN
DragQueryFile(hDrop,fCounter,fName,254);
// Aqui obtem-se o nome de todos os arquivos selecionados no Explorer
Names := Names + #13#10 + fName ;
end;

ShowMessage('Selecionados '+IntToStr(NumberOfFiles) + ' Nomes : ' + Names );
DragFinish ( hDrop);
end;

Diretórios windows ,system e temp

Function ExtractWindowsDir : String;
Var
Buffer : Array[0..144] of Char;
Begin
GetWindowsDirectory(Buffer,144);
Result := FormatPath(StrPas(Buffer));
End;

Function ExtractSystemDir : String;
Var
Buffer : Array[0..144] of Char;
Begin
GetSystemDirectory(Buffer,144);
Result := FormatPath(StrPas(Buffer));
End;

Function ExtractTempDir : String;
Var
Buffer : Array[0..144] of Char;
Begin
GetTempPath(144,Buffer);
Result := FormatPath(StrPas(Buffer));
End;

Diretório de instalação do windows

Function PegaSysDir: string;
var
MeuBuffer: Array [1..128] of Char;
retorno: Integer;
Begin
retorno:=GetSystemDirectory(@MeuBuffer,128);
if (retorno>128) OR (retorno=0) then
PegaSysDir:=''
else
PegaSysDir:=StrPas(@MeuBuffer);
End; {prc}

Digito verificador cpf

Você deve multiplicar individualmente todos os algarismos de um número requerido por uma seqüência numérica (9,8,7,..,2,9,8...) partindo do fim e repetindo a sequência caso seja necessário. Soma os resultados da multiplicação e divida tudo por onze. O resto dessa divisão deverá ser o DV, mas se esse resto for maior do que nove você deve subtrair esse resultado de onze. Existem várias tabelas utilizadas hoje no mercado, a mais usual é a 2..9 e depois a 2..7, sem contar outros tipos de módulos.

Segue um exemplo simples com cinco algarimos:

Matrícula: 00113-9

=> (0*5) + (0*6) + (1*7) + (1*8) + (3*9) = 0 + 0 + 7 + 8 + 27 = 42

=> 42 mod 11 => DV é 9}

//Calcula o digito verificador cpf
function DV11(Matr : string): string;
{Calculo pelo módulo 11 - tabela 2..9}
var
X, Cont, Soma, DV, NMatr : integer;
begin
Cont := 5; Soma := 0;
For X := 1 to 5 do
begin
NMatr := StrToInt(Copy(Matr,Cont-4,1));
Soma := Soma + (NMatr * Cont);
Inc(Cont);
end;
DV := Soma mod 11;
if DV > 9 then DV := 11 - DV;
Result := IntToStr(DV);
end;

Diferença entre duas horas

Function DifHora(Inicio,Fim : String):String;
{Retorna a diferença entre duas horas}
var
FIni,FFim : TDateTime;
begin
Fini := StrTotime(Inicio);
FFim := StrToTime(Fim);
If (Inicio > Fim) then
begin
Result := TimeToStr((StrTotime('23:59:59')-Fini)+FFim)
end
else
begin
Result := TimeToStr(FFim-Fini);
end;
end;

Dicas para quickreport

{O objetivo deste exemplo é fazer um relatório que apresente uma relação um para muitos entre duas tabelas. Por exemplo:

A tabela 1 (MasterTable) possui a descrição de todos os clientes da empresa e a tabela 2 (DetailTable) possui os dados de todas as compras realizadas por cada cliente. Temos neste caso uma relação 1:N. O objetivo deste exemplo é produzir um relatório com o formato abaixo descrito:

Nome: Paulo Ramos

Endereço: Rua N. S. Copacabana, 123

Telefone: 1111-0000

Itens comprados:

4 pares de Sapatos

3 calças

Nome: Marcel Waintraub

Endereço: Rua das Acácias 22, apto 1105

Telefone: 0000-0000

Itens comprados:

1 gravata

2 meias

A tabela MasterTable será a tabela com o nome dos clientes e a tabela DetailTable com as compras . Devemos então escolher no menu do Delphi, File/New/Forms e selecionar o formulário QuickReport Master/Detail. O formulário inicial é apresentado abaixo:

Este formulário é composto de 5 bandas, 2 componentes Table e 1 DataSource (MasterDS). Na banda Detail são colocados os componentes, por exemplo, QRDBText e QRLabel referentes a tabela MasterTable e na banda Subdetail os componentes referentes a tabela Detailtable.

É importante verificar se a propriedade DataSet do formulário foi inicializada corretamente para MasterTable . A propriedade DataSet da Banda SubDetail tem que ser alterada para DetailTable. Repare que o QuickReport inicializa erroneamente o valor desta propriedade para MasterTable.

Para cada tabela inicializa-se as propriedades DataBaseName com seu alias, a propriedade TableName com o nome das tabelas e a propriedade Active para true.

Para a tabela DetailTable estabelecemos a relação um para muitos. Para isto, devemos nos certificar que a propriedade MasterSource está atribuida com o Datasource MasterDS referente a tabela MasterTable.

Tendo feito isto é hora de se estabelecer de fato a ligação um para muitos entre as duas tabelas. Para isto, seleciona-se a tabela DetailTable e seleciona-se a propriedade MasterField (dá-se um click com o mouse no botão do lado direitro desta propriedade (...)).

Para se efetuar a ligação 1:N seleciona-se os campos de ligação entre as duas tabelas.

Depois, coloca-se os componentes em suas respctivas bandas. Por exemplo, colocamos dois componentes QRLabel na banda Detail e alteramos as suas propriedades Caption para Nome e Endereço do cliente. A seguir, coloca-se dois componentes QRDBText logo abaixo (ou do lado) dos componentes QRLabel. Para cada um deles a propriedade DataSet é inicializada com MasterTable e a propriedade DataField com os campos da tabela Nome e Endereco.

Na banda SubDetail são colocados os itens relacionados as compras dos clientes. Coloca-se componentes QRDBText com a propriedade DataSet sendo inicializada como DetailTable e a propriedade DataField com os campos da tabela DetailTable, campo Descrição.

Ao final temos aproximadamente :

Para vizualizar de imediato o resultado deste trabalho, damos um click com a outra tecla do mouse em cima do relatório. É apresentado um menu e escolhemos a opção Preview. Que resulta em.

Quando houver necessidade de um relatório mais sofisticado, por exemplo, com várias relações 1:N, podemos partir de um relatório MasterDetail, acrescentar bandas SubDetails com suas respectivas tabelas.

Como foi visto no exemplo anterior, os cabeçalhos do banda SubDetail foram postos na banda Detail. Mas como ficaria se colocassemos mais uma banda SubDetail?

O primeiro passo é colocar uma banda (terceiro componente do QuikReport), depois estabeleça que a propriedade HeaderBand da nova banda do SubDetail seja igual ao nome desta nova banda (QRBand1). Para finalizar coloque os componentes QRLabel na banda QRBand1 para servirem como cabeçalhos do nova relação um para muito.


------------------------------------------------------------------------------------------------------

1.Caso se queira que o relatório apresente cada cliente separadamente atribua a propriedade ForceNewPage da banda Detail para true;

2.Para o caso de só imprimir um cliente quando ele tiver efetuado uma compra, coloca-se o seguinte código no evento BeforePrint da banda Detail}


PrintBand:=DetailTable.RecordCount>0; { 3.Para ativar impressão do formulário a um evento OnClick, coloca-se a seguinte codificação:}


QRMDForm.Print; { 4.Para se inicializar campos antes da apresentaçãodo formulário, coloca-se a codificação no evento ONStartPage do Formulário, Por exemplo:}

procedure TDoseaciForm.DoseaciFormStartPage(Sender: TQuickRep);


5. begin
QRLabel4.Caption:=nome_serv;
MasterTable.filter:='Id='+InttoStr(id_serv);
MasterTable.filtered:=true;
QRLabel18.Caption:=Form23.Edit2.text;
QRLabel18.Left:=doseaciForm.width div 2- QRLabel18.width div 2;
try
QRMemo1.Lines.LoadFromFile('prelat.txt');
QRImage1.Picture.loadfromfile(simbolo);
finally
end;
end; { 6.Para ativar o formulário a um evento OnClick, coloca-se a seguinte codificação:}

QRMDForm.Preview;

Dicas para dbgrid

{Trocar o título dos campos

1 – Clique duas vezes sobre o dbgrid, isto fará aparecer uma janela, nesta janela clique com o botão direito do mouse e selecione add fields., todos os campos aparecerão.

2 – Para mudar o nome do titulo de cada campo, selecione o campo desejado e no object inspector vá na propriedade title, clique no sinal de mais que se encontra no lado esquerdo da propriedade, nas opções que aparecerem mude a propriedade caption, o que você escrever aqui, ficará no titulo.

Ordenando por título clicado

1 – No evento ontitleclick, criar uma variável chamada campo, campo então receberá a coluna clicada, para depois a query fazer o order by pelo campo escolhido.}


procedure Tconscli.gradeprocessosTitleClick(Column: TColumn);
var
campo:string;
begin
campo:=column.fieldname; // CAMPO RECEBE O NOME DA COLUNA CLICADA,
application.processmessages; // para considerar algo que aconteça no dbgrid durante a entrada nesta procedure
qrCLIENTES.sql.clear; // LIMPA A QUERY
qrCLIENTES.sql.add('select * from div1 order by '+campo); // ESCREVE O SELECT COM O ORDER BY
if not QRCLIENTES.Prepared then
QRCLIENTES.Prepare;
QRCLIENTES.Open; // ABRE A QUERY COM A ORDEM ESCOLHIDA.
End;
column.Font.color:=clblue; // COLOCAR A COLUNA NA COR DESEJADA {Busca recursiva

1 – Colocar o dbgrid em modo de leitura.

2 – Criar uma variável publica chamada letras no inicio do form;

3 – Clicar no evento onkeypress do dbgrid e fazer isto abaixo:}


letras:=letras+uppercase(key); // acumula as letras digitadas
QRclientes.LOCATE(CAMPO,LETRAS,[loPartialKey]); // Efetua a procura {4 – Para zerar a variável letras, basta escolher um evento de click ou de tecla pressionada e inserir:}


letras:=’’; {Minha dica fica para o evento onkeydown com isto:}


IF (KEY=38) or (key=40) then // avalio se é seta para cima ou para baixo;
letras:='';
end; {e no evento oncelclick colocar isto:}


letras:=’’; {Desta forma quando clicar na célula ou teclar seta para cima ou para baixo a variavel letras zerará.

Trocar o tab pelo enter

no evento onKeyDown do DBGrid:}

begin
case key of
13 : Key := 9;
end;
end;

Detectando o numero serial do hd

Function SerialNum(FDrive:String) :String;
Var
Serial:DWord;
DirLen,Flags: DWord;
DLabel : Array[0..11] of Char;
begin
Try GetVolumeInformation(PChar(FDrive+':'),dLabel,12,@Serial,DirLen,Flags,nil,0);
Result := IntToHex(Serial,8);
Except Result :='';
end;
end;

Dica para impressora matricial (pequena mas útil)

Primeiro utilize somente fontes courier, tamanho 10, no report especifique que a unidade invés de ser inches será caractere e adicione uma impressora fabricantes genérico somente texto. Na hora de imprimir selecione esta impressora e pronto ! Isso deve resolver quase todos os seus problemas.

Detectando e finalizando o screen saver

}{Primeiro verifique se o protetor de tela está em execução Function IsScreensaverRunning: Boolean;
var
old: Bool;
begin
SystemParametersInfo( SPI_SCREENSAVERRUNNING, 0, @old, 0 );
Result := old;
If old Then
Begin
SystemParametersInfo( SPI_SCREENSAVERRUNNING, 1, @old, 0 );
End; { If }
end;

{Se estiver em execução simule o pressionamento de uma tecla}

keybd_event( VK_SPACE, MapVirtualkey( VK_SPACE, 0 ), 0, 0);
keybd_event( VK_SPACE, MapVirtualkey( VK_SPACE, 0 ), KEYEVENTF_KEYUP, 0);

Detectando a finalização do windows

{Para detectar a finalização do Windows, deve-se capturar a mensagem WM_ENDSESSION. Estes passos devem ser tomados: Declarar uma rotina de manipulação de mensagens na sessao private de sua form:}

procedure WMEndSession(var Msg : TWMEndSession); message WM_ENDSESSION;

//Adicionar a procedure à seção implementation de sua unit:

procedure TForm1.WMEndSession(var Msg : TWMEndSession);
begin
if Msg.EndSession = TRUE then
ShowMessage('O Windows está finalizando ' + #13 + 'às ' +
FormatDateTime('c', Now));
inherited;
end;

Desligando/ligando o monitor

{Inclua na seção uses: Windows No Windows podemos desligar o monitor afim de economizar energia elétrica. Normalmente este recurso é controlado pelo próprio Windows. Porém sua aplicação Delphi também pode fazer isto. O exemplo abaixo desliga o monitor, aguarde 5 segundos e re-liga monitor.}

SendMessage(Application.Handle, WM_SYSCOMMAND,
SC_MONITORPOWER, 0);
Sleep(5000); { Aguarde 5 segundos }
SendMessage(Application.Handle, WM_SYSCOMMAND,
SC_MONITORPOWER, -1);

//PS: Este recurso pode não funcionar dependendo da configuração do sistema.

Desligando o windows

Function ExitWindowsEx(uFlags : integer; // shutdown operation dwReserved : word) : boolean; // reserved

external 'user32.dll' name 'ExitWindowsEx';

procedure Tchau;

const

EWX_LOGOFF = 0; // Dá "logoff" no usuário atual

EWX_SHUTDOWN = 1; // "Shutdown" padrão do sistema

EWX_REBOOT = 2; // Dá "reboot" no equipamento

EWX_FORCE = 4; // Força o término dos processos

EWX_POWEROFF = 8; // Desliga o equipamento

begin

ExitWindowsEx(EWX_FORCE, 0);

end;

Desenhando texto 3d no form com canvas

Type
TForm1 = class(TForm)
private
procedure TForm1.imgPaintCanvas(TheCanvas : TCanvas; TheString : String;
TheFontSize, UCorner, LCorner : Integer);
public
{ Public declarations }
end; var
Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.imgPaintCanvas(TheCanvas : TCanvas; TheString : String;
TheFontSize, UCorner, LCorner : Integer);
Begin
TheCanvas.Brush.Style := bsClear;
TheCanvas.Font.Style := [fsBold];
TheCanvas.Font.Name := 'MS Sans Serif';
TheCanvas.Font.Size := TheFontSize;
TheCanvas.Font.Color := clBlack;
TheCanvas.TextOut(UCorner, LCorner, TheString);
TheCanvas.Font.Color := clGray;
TheCanvas.TextOut(UCorner - 1, LCorner - 1, TheString);
TheCanvas.Font.Color := clSilver;
TheCanvas.TextOut(UCorner - 2, LCorner - 2, TheString);
TheCanvas.Font.Color := clBlack;
TheCanvas.TextOut(UCorner - 3, LCorner - 3, TheString);
End;

Usa-se:

procedure TForm1.Button1Click(Sender: TObject);
begin
imgPaintCanvas(Form1.Canvas, 'Escreva um texto aqui!', 10, 6, 4);
end;

Desenhando com tipos diferentes de linhas

{O Windows permite desenhar linhas onde cada pixel é outro tipo de primitiva ou desenho com a função LineDDA. Ela precisa de uma função "callback", que será chamada quando um pixel deve ser desenhado. Ali podem ser postas as rotinas de desenho. A rotina a seguir desenha um retângulo a cada 4 pixels:}

TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
public
DrawNow : Integer;
end;

var
Form1: TForm1;

procedure DrawPoint(x,y : Integer;lpData : LParam); stdcall;

implementation

{$R *.DFM}

procedure DrawPoint(x,y : Integer;lpData : LParam);
begin
with TObject(lpData) as TForm1 do begin
if DrawNow mod 4 = 0 then
Canvas.Rectangle(x-2,y-2,x+3,y+3);
Inc(DrawNow);
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
DrawNow := 0;
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
LineDDA(0,0,Width,Height,@DrawPoint,Integer(Self));
end;
end.

Descobrindo se uma data é fim do mês

//Inclua na seção uses: SysUtils

{ Esta função retorna true se a data passada como parâmetro é fim de mês. Retorna false caso contrário. }


function tbFimDoMes(const Data: TDateTime): boolean;
var
Ano, Mes, Dia: Word;
begin
DecodeDate(Data +1, Ano, Mes, Dia);
Result := Dia = 1;
end;

Descobrindo o código ascii de uma tecla

{ - Coloque um Label no form (Label1); - Mude a propriedade KeyPreview do form para true;

- Altere o evento OnKeyDown do form como abaixo: }


procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
Label1.Caption :=
Format('O código da tecla pressionada é: %d', [Key]);
end;

Descobrindo se um objeto tem uma determinada propriedade

Uses Typinfo
if GetPropInfo(DataSet, 'TableName') <> nil then
ShowMessage('Objeto TTable');

Descobrindo se um form já está criado 3

{Bem, saber se um form já esta ou não criado, melhor dizer instanciado, não é um problema muito crítico, abaixo pode-se ver uma unit padrão criada com um form vazio no Delphi, esta unit alem de declarar o nova classe TForm1 cria também uma variável Form1 do Isto é muito importante que seja observado, uma variável para um tipo "FORM" nada mais é que um ponteiro, ou seja ela apenas mostra em que local da memória está a instancia do seu form, enquanto o seu form não existir este ponteiro deve apontar para lugar nenhum. }
unit Unit1
interface
uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs;
type
TForm1 = class(TForm)
private
{ Private declarations }
public
{ Public declarations }
end;
var Form1: TForm1;
implementation
{$R *.DFM}
end. {Partindo deste princípio podemos verificar se um form foi ou não instanciado verificando o valor guardado em FORM1, se este valor for diferente de "NIL" significa que o Form já foi instanciado...

Normalmente quando um form é instanciado, ele deixa , mesmo depois de fechado um caminho para aquele endereço da memória, então este form sempre estará(para o sistema) instanciado. Para corrigir este problema basta limpar este caminho deixando o form como nil novamente:}


procedure TForm1.FormDestroy(Sender: TObject);
begin
Form1 := nil;
end; {Assim, quando o "FORM1" for destruído ele apaga o seu endereço junto.

Assim quando for criar (instanciar) um form utilize a seguinte verificação:}


if Form2 = nil then
Form2 := TForm2.Create(Self);
Form2.Show;... {Interessante que o Show quando um form já esta criado tem o efeito de umBringToFront.

Bem tudo isso resolve parte do problema, a outra parte tem de ser resolvida por você estruturando o seu programa de forma aos controles funcionem de acordo.

1 - Este controle não funciona para forms com múltiplas instancias, a não ser que você crie uma variável para cada instancia.

2 - Quando for criar um novo form não crie variáveis desnecessariamente, utilize a variável que já esta sendo criada na unit do Form.

Ex: Dados FORM1 e FORM2

Apenas FORM1 está no AUTO-CREATE. Quando no uses de FORM1 for referenciada a unit UNIT2 a variável FORM2 estará acessível, use-a.


FORM2 := TFORM2.CREATE(SELF); 3 - Quando um Form é mostrado com ShowModal este tipo de controle não se aplica já que será impossível mostrar qualquer outro form.}

Descobrindo se um form já está criado 2

{Quando um form ou outro objeto não existe, ou seja, ainda não foi criado, a variável usada para instanciar o objeto está "nil". Exemplo: }
form1 := Tform1.create(); //A variável form1 passa a ter um valor diferente de nil. Logo, faça o teste:

If form1 = nil then
{form não criado ainda ou já foi fechado}

//Lembre-se de fazer o form1, no seu evento close, receber nil.

form1 := nil;

//Assim ele estará fechado e não existirá mais. Teste este exemplo e verá.

Descobrindo se um form já está criado

{Bem saber se um form já esta ou não criado, melhor dizer instanciado, não é um problema muito crítico, abaixo pode-se ver uma unit padrão criada com um form vazio no Delphi, esta unit alem de declarar o nova classe TForm1 cria também uma variável Form1 do Isto é muito importante que seja observado, uma variável para um tipo "FORM" nada mais é que um ponteiro, ou seja ela apenas mostra em que local da memória está a instancia do seu form, enquanto o seu form não existir este ponteiro deve apontar para lugar }
unit Unit1
interface
uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs;
type
TForm1 = class(TForm)
private
{ Private declarations }
public
{ Public declarations }
end;
var Form1: TForm1;
implementation
{$R *.DFM}
end. {Partindo deste princípio podemos verificar se um form foi ou não instanciado verificando o valor guardado em FORM1, se este valor for diferente de "NIL" significa que o Form já foi instanciado...

Bem a coisa não é assim tão simples, imagine que um amigo mudou-se para São Paulo e lhe passou seu novo endereço, você recebe e anota em sua agenda,. depois de dois meses ele resolve que não quer mais morar em São Paulo e vai embora, ok o fato de seu amig

A forma mais limpa e automática para se contornar este problema nos obriga acodificar o seguinte no evento OnDestroy do Form :}


procedure TForm1.FormDestroy(Sender: TObject);
begin
Form1 := nil;
end; {Assim, quando o "FORM1" for destruído ele apaga o seu endereço junto.

Assim quando for instanciar um form utilize a seguinte verificação:}


if Form2 = nil then
Form2 := TForm2.Create(Self);
Form2.Show;... {Interessante que o Show quando um form já esta criado tem o efeito de umBringToFront.

Bem tudo isso resolve parte do problema, a outra parte tem de ser resolvida por você estruturando o seu programa de forma aos controles funcionem de acordo.

1 - Este controle não funciona para forms com múltiplas instancias, a não ser que você crie uma variável para cada instancia.

Pessoalmente eu nunca usei isso, se um form pode ter múltiplas instancias em MDI então controle por ActiveMDIChild e se for SDI então não sei porque ter mais de uma instancia.

2 - Quando for criar um novo form não crie variáveis desnecessariamente, utilize a variável que já esta sendo criada na unit do Form.

Ex: Dados FORM1 e FORM2

Apenas FORM1 está no AUTO-CREATE. Quando no uses de FORM1 for referenciada a unit UNIT2 a variável FORM2 estará acessível, use-a.}


FORM2 := TFORM2.CREATE(SELF); {3 - Quando um Form é mostrado com ShowModal este tipo de controle não se aplica já que será impossível mostrar qualquer outro form. }

Descobrindo se o aplicativo está minimizado

//Coloque no uses: Windows
if IsIconic(Application.Handle) then
{ Minimizado }
else
{ Não minimizado } Observações:

{Pode-se verificar qualquer janela (form). Só um lembrete:

Quando clicamos no botão de minimizar do form principal, na verdade ele é oculto e o Application é que é minizado. }

Descobrindo se há impressora instalada

Try
// Set printer so, for get information
JustTest := Printer.Orientation;
IsPrinterSetup := true;
except
on EPrinter do IsPrinterSetup := false;
end;
if not IsPrinterSetup then
begin
SayAboutIt;
ExitProgram;
End;

Desabilitando teclas ctrl+alt+del, alt+tab, ctrl+esc

//(Ctrl+Alt+Del),(Alt+Tab), (Ctrl+Esc)
var
OldValue : LongBool;
begin
{liga a trava}
SystemParametersInfo(97, Word(True), @OldValue, 0);
{desliga a trava}
SystemParametersInfo(97, Word(False), @OldValue, 0);
end;

Desabilitando o botão fechar de um form

Procedure TForm1.Button1Click(Sender: TObject);
var
hwndHandle : THANDLE;
hMenuHandle : HMENU;
begin
hwndHandle := FindWindow(nil, 'Sem título - Bloco de Notas');
if (hwndHandle <> 0) then
begin
hMenuHandle := GetSystemMenu(hwndHandle, FALSE);
if (hMenuHandle <> 0) then
DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND);
end;
end;

Desabilitando um radiobutton num radiogroup

TRadioButton(RadioGroup1.Controls[1]).
Enabled := False;

Desabilitando o splash screen do report smith

{1 - Localize o arquivo RS_RUN.INI (no diretório do Windows); 2 - Na seção [ReportSmith] inclua a linha seguinte:}

ShowAboutBox=0

{3 - Na seção [RS_RunTime] inclua a linha seguinte:}

ShowAboutBox=0

{4 - Não se esqueça de distribuir com o seu aplicativo o referido arquivo INI. }

Deletando um diretório inteiro de uma vez

{Problemas para deletar um diretório com subdiretórios? Utilize a função abaixo: }
Uses
Shellapi, filectrl, //declare estas das units!!!

function DeleteFolder(FolderName: String; LeaveFolder: Boolean): Boolean;
var
r: TshFileOpStruct;
begin
Result := False;
if not DirectoryExists(FolderName) then
Exit;
if LeaveFolder then
FolderName := FolderName + ' *.* '
else
if FolderName[Length(FolderName)] = ' ' then
Delete(FolderName,Length(FolderName), 1);
FillChar(r, SizeOf(r), 0);
r.wFunc := FO_DELETE;
r.pFrom := PChar(FolderName);
r.fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION;
Result := ((ShFileOperation(r) = 0) and (not r.fAnyOperationsAborted));
end;

//Usa-se Assim:

procedure TForm1.Button1Click(Sender: TObject);
begin
deleteFolder('c:temp',false);
end;

Deletando com query

QExclui.Close;
QExclui.Sql.Clear;
QExclui.SQL.Add('DELETE FROM TBEXEMPLO ' +
'WHERE (TBEXEMPLO.CodigoP = :EdCodigoP) AND ' +
'(TBEXEMPLO.CodigoS = :EdCodigoS) ');
QExclui.PARAMBYNAME('EdCodigo').AsInteger := 1;
QExclui.PARAMBYNAME('EdCodigoS').AsInteger := 5;
QExclui.ExecSQL;

Deletando um diretório

Procedure DelTree(const RootDir : String);
var
SearchRec : TSearchRec;
begin
Try
ChDir(RootDir); {Caminho Especificado}
FindFirst('*.*',faAnyFile,SearchRec);
Erc := 0;
while Erc = 0 do
begin
if ((SearchRec.Name <> '.' ) and (SearchRec.Name <> '..')) then
begin
if (SearchRec.Attr and faDirectory>0) then
begin
{Achou o diretório e ira apagar seus arquivos}
DelTree(SearchRec.Name);
end
else
begin
{Achou um arquivo. Apagar ou não}
end;
end;
Erc := FindNext (SearchRec);
{ Erc igual a zero se o FindNext obtiver sucesso, senão erro do DOS}
Application.ProcessMessages;
end;
finally
if Length(RootDir) > 3 then
ChDir('..');
end;
end;

Deletando um arquivo

If FileExists('C:MEUDIRMEUARQ.DAT') then
DeleteFile('C:MEUDIRMEUARQ.DAT');

Deixando o exe menor e mais rápido

{Para deixar o programa executável menor e mais rápido, abra a tela de Options/Project. Na página Compiler tire todos os "X" e deixe somente nas caixas: Force far Calls, Smart Callbacks e Extended Sintax.

Na página Linker marque um "X" em Optimize for size and load time.

Lembre-se fazendo isso o programa ficará menor e mais rápido, porém o Delphi levará mais tempo para compilá-lo }

Definindo o tamanho do papel em tprinter

{Esta procedure configura o tamanho do papel em Run-Time para ser utilizado com o objeto TPrinter; Esta procedure deve ser chamada antes de aplicar o método Printer.BeginDoc. }
procedure TForm1.SetPrinterPage(Width, Height : LongInt);
var
Device : array[0..255] of char;
Driver : array[0..255] of char;
Port : array[0..255] of char;
hDMode : THandle;
PDMode : PDEVMODE;
begin
Printer.GetPrinter(Device, Driver, Port, hDMode);
If hDMode <> 0 then
begin
pDMode := GlobalLock( hDMode );
If pDMode <> nil then
begin
pDMode^.dmPaperSize := DMPAPER_USER;
pDMode^.dmPaperWidth := Width;
pDMode^.dmPaperLength := Height;
pDMode^.dmFields := pDMode^.dmFields or DM_PAPERSIZE;
GlobalUnlock( hDMode );
end;
end;
end;

Definindo data/hora de um arquivo

//Inclua na seção uses: SysUtils
{ Esta função altera a data e hora de um arquivo. Se obter sucesso retorna true, caso contrário retorna false. }
function DefineDataHoraArq(NomeArq: string; DataHora: TDateTime): boolean;
var
F: integer;
begin
Result := false;
F := FileOpen(NomeArq, fmOpenWrite or fmShareDenyNone);
try
if F > 0 then
Result := FileSetDate(F, DateTimeToFileDate(DataHora)) = 0;
finally
FileClose(F);
end;
end; { Exemplo de uso 1: Usa a data atual do sistema (Now) }


if DefineDataHoraArq('c:testelogo.bmp', Now) then
ShowMessage('Data/Hora do arquivo definida com sucesso.')
else
ShowMessage('Não foi possível definir data/hora do arquivo.');

{ Exemplo de uso 2: Usa uma data fixa }
var
DataHora: TDateTime;
begin
{ Define a data para 5-Fev-1999 e a hora para 10:30 }
DataHora := EncodeDate(1999, 2, 5) + EncodeTime(10, 30, 0, 0);
if DefineDataHoraArq('c:testelogo.bmp', DataHora) then
ShowMessage('Data/Hora do arquivo definida com sucesso.')
else
ShowMessage('Não foi possível definir data/hora do arquivo.');
end;

Qtde de registros a ser impressa por pagina (qrep)

{1. A forma mais simples consiste em alterar a altura (Height) da banda Detail do nosso relatório de modo que a altura total da página seja inferior a duas vezes a altura da banda. Desta forma, cada registro será impresso em uma nova página, teoricamente por falta de espaço na página atual. 2. Uma outra forma mais sofisticada é usar o evento AfterPrint da banda Detail. Nele testamos se ainda não chegou no fim a tabela e, caso positivo, pedimos uma nova página:}

if not Table1.EOF then

QuickRep1.NewPage;

{Deve existir outras alternativas, mas as duas anteriores funcionaram bem nos testes realizados. }

Definindo atributo de um arquivo

Function FileSetAttr(const FileName: string; Attr: Integer): Integer;
Exemplo:
FileSetAttr ('C:logo.sys',0); {Onde Attr:Interger:

0=Sem Atributos;

1=Somente Leitura;

2=Oculto;

3=Somente Leitura e Oculto;

4=Sistema;

5=Somente Leitura e Sistema;

6=Sistema e Oculto;

7=Somente Leitura,Sistema e Oculto; }

Definido o tamanho mínimo e máximo de um formulário

Unit Unit1;

interface

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

type
TForm1 = class(TForm)
private
{ Private declarations }
procedure WMGetMinMaxInfo(var MSG: TMessage); message WM_GetMinMaxInfo;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMGetMinMaxInfo(var MSG: TMessage);
begin
inherited;
with PMinMaxInfo(MSG.lparam)^ do begin
ptMinTRackSize.X := 300;
ptMinTRackSize.Y := 150;
ptMaxTRackSize.X := 350;
ptMaxTRackSize.Y := 250;
end;
end;
end. //ou, altere a propriedade constraints( que exite apenas a partir da versão 4.0.

Dbgrid zebrado

{O exemplo abaixo mostra como deixar cada linha do componente DBGrid de uma cor diferente, dando assim um efeito zebrado. O controle é feito no evento OnDrawColumnCell. }
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Db, DBTables, Grids, DBGrids, StdCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
DBGrid1: TDBGrid;
Table1: TTable;
DataSource1: TDataSource;
procedure DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;

implementation
{$R *.DFM}

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
If odd(Table1.RecNo) then
begin
DBGrid1.Canvas.Font.Color:= clWhite;
DBGrid1.Canvas.Brush.Color:= clGreen;
end
else
begin
DBGrid1.Canvas.Font.Color:= clBlack;
DBGrid1.Canvas.Brush.Color:= clWhite;
end;
DBGrid1.Canvas.FillRect(Rect);
DBGrid1.Canvas.TextOut(Rect.Left+2,Rect.Top,Column.Field.AsString);
end;

Data por extenso no quickreport

Var
nrdia: Integer;
diasemana: array[1..7] of String;
meses: array[1..12] of String;
dia, mes, ano: Word;
begin
diasemana[1]:= 'Domingo';
diasemana[2]:= 'Segunda-feira';
diasemana[3]:= 'Terça-feira';
diasemana[4]:= 'Quarta-feira';
diasemana[5]:= 'Quinta-feira';
diasemana[6]:= 'Sexta-feira';
diasemana[7]:= 'Sábado';
meses[1]:= 'Janeiro';
meses[2]:= 'Fevereiro';
meses[3]:= 'Março';
meses[4]:= 'Abril';
meses[5]:= 'Maio';
meses[6]:= 'Junho';
meses[7]:= 'Julho';
meses[8]:= 'Agosto';
meses[9]:= 'Setembro';
meses[10]:= 'Outubro';
meses[11]:= 'Novembro';
meses[12]:= 'Dezembro';
DecodeDate(DATE,ano,mes,dia);
nrdia:= DayOfWeek(DATE);
QRLabel1.Caption:= diasemana[nrdia]+', '+INTTOSTR(dia)+' de '+meses[mes]+' de '+INTTOSTR(ano);
end;

Códigos usados pelas impressoras hp

{Veja abaixo alguns códigos usados pelas impressoras HP: RESET = 027/069

BOLD1 = 027/040/115/051/066

BOLD0 = 027/040/115/048/066

ITALIC1 = 027/040/115/049/083

ITALIC0 = 027/040/115/048/083

UNDERLINE1 = 027/038/100/049/068

UNDERLINE0 = 027/038/100/064

LPI6 = 027/038/108/054/068

LPI8 = 027/038/108/056/068

CPI5 = 027/040/115/053/072

CPI6 = 027/040/115/054/072

CPI8 = 027/040/115/056/072

CPI10 = 027/040/115/049/048/072

CPI12 = 027/040/115/049/050/072

CPI17 = 027/040/115/049/054/046/054/055/072

CPI20 = 027/040/115/050/048/072 }

Código seqüencial automático

{Você manda o caminho (Alias "C:Windows"), nome da tabela (tabela.db) e o campo primário (código por ex) e ele auto-incrementa, se quiser usar formatação é só colocar. }
Function AutoIncrementoManual(Const pAlias:String; pTabela:String; pCampo:String):Integer;
var
vQry : tQuery;
int : integer;
begin
vQry := tQuery.Create(Application);
with vQry do begin
DatabaseName := pAlias;
SQL.Add('Select Max(' + pCampo +') as Proximo');
SQL.Add('From '+ pTabela);
Open;
int:= FieldByName('Proximo').asInteger + 1;
Result := int;
free;
end; {with vQry}
end;

Código gerador de senha

Procedure TForm1.Button1Click(Sender: TObject);
var
i:integer;
const
str='1234567890ABCDEFGHIJKLMNOPQRSTUVWXYZ';
max=6;
begin
Edit1.Text:='';
for i:=1 to max do
Edit1.Text:=Edit1.Text+str[random(length(str))+1];
end;

Cursor customizado

{Criar um arquivo de recurso com o cursor (vamos chamá-lo de teste.res) Vamos chamar o recurso de CUR_1

Coloque {$R teste.res} na seção implementation.}

procedure InsereCursor(Num : Smallint);
begin
Screen.Cursors[Num]:= LoadCursor(hInstance, PChar('CUR_1'));
Screen.Cursor := Num;
end;

Cuidados ao se criar procedimentos e funções com parâmetros

{Quando criamos procedimentos e funções podemos introduzir parâmetros com valores default, devemos porém respeitar algumas regras: Esse parâmetros precisam ocorrer no final da lista;

precisam ser constantes

Não pode fazer por referência(var alguma coisa)

Respeitando essas regras o delphi permite criar sem problemas funções ou procedimentos do tipo:}


function Resizer(X: Real; Y: Real = 2.0): Real;
procedimento Multiplicar(var X:Real;X:Real=1;Resposta:Real=0); etc...

{Se você chamar "resizer" sem os parâmetros o delphi considera que você quer usar os valores default da função....

Tenha MUITA ATENÇÃO PORÉM com funções ou procedimentos que forma declarados em overload ou "sobrecarga" que permite que dois ou mais procedimentos ou funções tenham nomes iguais desde que tenham parâmetros diferentes.Isso criaria problemas na lógica do compilador. Pense, O que difere um procedimento do tipo:}

procedure teste(A:integer);overload

procedure teste(A:integer=0);overload;

{Se você chamar teste(x) o compilador não sabe se você está querendo chamar o procedimento 1 ou 2.}

Cuidados ao usar se usar o onexit

{É comum fazermos uso do evento OnExit quando queremos validar o conteúdo de um Edit. E essa pode ser uma boa prática quando necessitamos verificar o que foi digitado apenas quando o usuário terminar de fazer a entrada de dados, como, por exemplo, um Edit que vai receber o CPF ou CNPJ. Ao colocarmos um código qualquer no evento OnExit ele sempre será executado quando o usuário sair do Edit, o que acontece quando ele pressiona a tecla TAB, clica com o mouse em um outro Edit ou pressiona um botão OK, por exemplo.

No entanto, existem algumas situações especiais em que o evento OnExit não é gerado. Quer um exemplo? Você está no Edit e, ao invés de clicar no botão OK, você pressiona as teclas ALT + O (considerando que o botão OK tem a tecla O como atalho). É como se você tivesse pressionado o botão OK, porém, sem perder o foco que está no Edit. Só mais um exemplo: Os botões do tipo SpeedButton não recebem foco, então, mesmo que clique com o mouse sobre um SpeedButton, o foco continuará no Edit e, conseqüentemente, o evento OnExit não será gerado.

E a solução?

A solução para esse pequeno inconveniente é simples. Basta você colocar o seguinte código no evento OnClick do botão.}

procedure TForm1.Button1Click(Sender: TObject);
begin
ActiveControl := nil;
...
end;

{Com isso você força a saída de qualquer Edit ou outro componente que esteja com o foco, gerando assim o evento OnExit.

Suponhamos que você possua 2 Edits em um formulário. Supondo também que você queira dar alguma informação ao usuário da aplicação logo depois que ele sair do Edit1 você faz:}


procedure TForm1.Edit1Exit(Sender: TObject);
begin
MessageDlg('Mensagem...', mtInformation, [mbOk], 0);
end; {A princípio está tudo ok, ou melhor, parece estar tudo ok.

Se você altera o foco para o outro Edit através do pressionamento da tecla TAB, tudo bem. Mas experimente alterar o foco clicando com o mouse sobre o Edit2. Neste segundo caso a mensagem será exibida normalmente. Mas ao fechar o dialogo onde aparece a mensagem, o foco simplesmente se perde. Para setar o foco no Edit2 é necessário clicar novamente sobre ele.

Isso poderia não ser problema nenhum até que seu usuário experimente esta situação. Nada que ele digitar será acatado.

Mas existe uma maneira fácil de resolver o problema. Basta você cancelar o foco e forçar uma reentrada no componente Edit2. Como fazer isso? Veja o código:}


procedure TForm1.Edit1Exit(Sender: TObject);
begin
MessageDlg('Mensagem...', mtInformation, [mbOk], 0);
// cancela o foco e força novamente a entrada
ActiveControl := nil;
PostMessage(Edit2.Handle, WM_SETFOCUS, 0, 0);
Edit2.SetFocus;
end; {Porém, você nunca terá certeza se o usuário clicou no Edit2. Então temos que criar uma rotina genérica que leva o foco para qualquer outro controle:}


procedure TForm1.Edit1Exit(Sender: TObject);
var
Ctrl: TWinControl;
begin
MessageDlg('Mensagem...', mtInformation, [mbOk], 0);
// cancela o foco e força novamente a entrada
Ctrl := ActiveControl;
ActiveControl := nil;
PostMessage(TWinControl(Ctrl).Handle, WM_SETFOCUS, 0, 0);
TWinControl(Ctrl).SetFocus;
end; {Observe que antes de cancelar o foco com ActiveControl := nil, salvamos qual é o controle que detém o foco fazendo Ctrl := ActiveControl.

Depois enviamos uma mensagem ao controle que detinha o foco, forçando-o a receber o foco novamente.}

Cuidados ao gravar em arquivos binários

{Quando gravar em arquivos binários deve evitar o uso em seus records de longStrings pois, por default, uma longstring é uma string "sem fim" . Se você tentar gravar em um arquivo binário ele irá truncá-la(ou seja, vai cortar uma parte da string) e você poderá perder dados. Ao invés disso, use shorstrings para arquivos binários. }

Exe que seja executado através de outro exe

{Inclua na seção uses: Windows Antes da linha "Application.Initialize;" do programa a ser chamado, coloque o código abaixo:}


if ParamStr(1) <> 'MinhaSenha' then begin
{ Para usar ShowMessage, coloque Dialogs no uses }
ShowMessage('Execute este programa através de Prog2.EXE');
Halt; { Finaliza }
end;

{ No Form1programa que chama coloque um botão e escreva o OnClick deste botão como abaixo:}

procedure TForm1.Button1Click(Sender: TObject);
var
Erro: Word;
begin
Erro := WinExec('Pro2.exe MinhaSenha', SW_SHOW);
if Erro <= 31 then { Se ocorreu erro... }
ShowMessage('Erro ao executar o programa.');
end;

Criar um documento no word

Procedure TForm1.Button1Click(Sender: TObject);
var
MSWord: Variant;
begin
MSWord:= CreateOleObject ('Word.Basic');
MSWord.AppShow;//mostra o word
MSWord.FileNew;//inicia um novo documento
MSWord.insert('Contrato de Locação'); //Escreve algo
MSWord.insert(#13+'Contrato de Locação');//Pula uma linha e escreve
MSWord.FontSize(24);//muda o tamanho da fonte
MSWord.italic;//coloca italico
MSWord.bold;//coloca negrito
MSWord.underline;//sublina
MSWord.insert(#13+'Contrato de Locação');//pula a linha e escreve novamente
MSWord.FontSize(12);//muda o tamanho da fonte
MSWord.Font('Arial');//muda a fonte usada
MSWord.underline(false);//retira o sublinhado
MSWord.italic(false);//retira o italico
MSWord.bold(false);//retira o bold
MSWord.insert(#13 +'teste');
MSWord.insert(#13+#9 +'teste');//nova linha e um TAB
MSWord.insert(#13+Table1Razao_Social.Value);//insere algo de uma tabela
MSWord.LineUp(2, 1); //seleciona uma parte do texto
MSWord.TextToTable(ConvertFrom := 2, NumColumns := 1);// monta uma tabela com o texto selecionado
Word.FileSaveAs('c:temptest.txt', 3); //Salva o arquivo
end;

Criando um sub-diretório no diretório do exe

//Inclua na seção uses: FileCtrl, SysUtils ParamStr(Indice) {- Retorna valores passados na linha de comando quando executamos o programa. Se o valor de Indice for 0 (zero) será retornado o caminho+nome do EXE.}

ExtractFilePath(NomeArq) {- Retorna o caminho (path) do nome de arquivo informado.

Exemplo:}


S := 'C:NomeDirPrograma.exe';
ExtractFilePath(S); { retorna: 'C:NomeDir' } DirectoryExists(CaminhoDir) {- Retorna true se o diretório informado existe. False em caso contrário.}

CreateDir(CaminhoDir) {- Tenta criar o diretório informado.

Se conseguir, retorna true. Caso contrário retorna false.

Agora que sabemos como trabalham estas funções, vamos escrever uma função que precisamos para criar um sub-diretório conforme proposto.}


function CriaSubDir(const NomeSubDir: string): boolean;
var
Caminho: string;
begin
Caminho := ExtractFilePath(ParamStr(0)) + NomeSubDir;
if DirectoryExists(Caminho) then
Result := true
else
Result := CreateDir(Caminho);
end; {Exemplo de uso:

- Chame a função no evento OnCreate do form:}


procedure TForm1.FormCreate(Sender: TObject);
begin
if not CriaSubDir('MeuSubDir') then
ShowMessage('Não foi possível criar o sub-diretório MeuSubDir.');
end;

Criando labels em tempo de execução

Procedure TForm1.Button1Click(Sender: TObject);
Var
OLabel : TLabel;
begin
OLabel := TLabel.create(application);
OLabel.Parent := Form1;
OLabel.Name := 'LABEL1';
OLabel.Left := 10;
OLabel.Top := 10;
OLabel.font.Size := 20;
end;

Criando form sem título que possa ser arrastado

{- Crie um novo projeto;
- Mude as seguintes propriedades do Form1: }

BorderStyle = bsNone, FormStyle = fsStayOnTop,

{- Coloque um Label;
- Coloque um Timer;
- Altere o evento OnTimer do Timer1 conforme abaixo: }

procedure TForm1.Timer1Timer(Sender: TObject);
begin
Label1.Caption := TimeToStr(Time);
end; //- Altere o evento OnCreate do Form1 conforme abaixo:


procedure TForm1.FormCreate(Sender: TObject);
begin
Width := 80;
Height := 40;
Label1.Left := 10;
Label1.Top := 10;
end; //- Vá na seção private do Form1 e declare a procedure abaixo:


private
procedure WMNCHitTest(var Msg: TMessage);
message WM_NCHitTest;
public
{ Public declarations }
end; //- Vá na seção implementation e escreva a procedure abaixo:


implementation
{$R *.DFM}
procedure TForm1.WMNCHitTest(var Msg: TMessage);
begin
if GetAsyncKeyState(VK_LBUTTON) < 0 then
Msg.Result := HTCAPTION
else
Msg.Result := HTCLIENT;
end; {- Execute e experimente arrastar form com o mouse.

Para fechar este aplicativo pressione Alt+F4, ou inclua um botão. }

Criando dlls

{Esta é uma outra dúvida bastante freqüente que chega a nós. "Como posso usar uma DLL ?", "Como posso criar uma DLL ?", "Ei, pra quê serve uma DLL mesmo ?"

Pois bem, DLL ou Dynamic Link Libraries, permitem que um conjunto de funções desenvolvidas em uma linguagem possam ser utilizadas em programas desenvolvidos em outras linguagens.

Você pode, por exemplo, criar uma DLL em Delphi com um conjunto de funções e utilizá-la em aplicativos desenvolvidos em C++ ou Visual Basic, por exemplo. Agora, vamos começar criando uma DLL:

Selecione o item New do Menu File, para exibir a caixa de diálogo New Items. Agora, selecione o item DLL e clique em OK, para gerar o código principal da DLL, que se apresenta a seguir:}


library Project1;

{ Important note about DLL memory management: ShareMem must be the first unit in your library's USES clause AND your project's (select Project-View Source) USES clause if your DLL exports any procedures or functions that pass strings as parameters or function results. This applies to all strings passed to and from your DLL--even those that are nested in records and classes. ShareMem is the interface unit to the BORLNDMM.DLL shared memory manager, which must be deployed along with your DLL. To avoid using BORLNDMM.DLL, pass string information using PChar or ShortString parameters. }

uses
SysUtils, Classes;
begin
end. {Em muitas situações, inclusive esta, o arquivo DELPHIMM.DLL deve ser distribuído junto à sua aplicação. Uma outra observação muito importante, para que você possa escrever suas DLLs, você deve ter conhecimentos na Linguagem Object Pascal.

Vamos continuar criando nossa DLL, pois é ela que iremos usar mais para frente. Apenas como exemplificação, vamos criar uma função que receba como parâmetros dois números reais e retorne o maior deles.}


Function Max (a b : double ) : double ; Export ; stdcall ;
begin
If (a > b) then Result :=a else Result := b ;
end ;

{Export = indica que a função poderá ser chamada por outros aplicativos.

Stdcall = permite que aplicativos desenvolvidos em outras linguagens façam chamadas à função.

Após serem feitas estas alterações e salvar o projeto com o nome MAXDLL, nossa DLL ficará assim:}


library Project1;

{ Important note about DLL memory management: ShareMem must be the first unit in your library's USES clause AND your project's (select Project-View Source) USES clause if your DLL exports any procedures or functions that pass strings as parameters or function results. This applies to all strings passed to and from your DLL--even those that are nested in records and classes. ShareMem is the interface unit to the BORLNDMM.DLL shared memory manager, which must be deployed along with your DLL. To avoid using BORLNDMM.DLL, pass string information using PChar or ShortString parameters. }

uses
SysUtils,
Classes;
function Max(a, b : double):double:expert:stdcall:
begin
if (a > b) then result:= a else result := b;
end;

exports
Max index 1;
begin
end.

{Você pode compilar uma DLL, assim como a um projeto no Delphi, e distribuir livremente.

PS: Você não pode executar uma DLL pelo Delphi, através do RUN do Menu Run, pois não se trata de uma aplicação.

Mais à frente, você perceberá que uma DLL pode usar formulários e objetos definidos em outras unidades. Iremos, agora, chamar uma DLL, a partir de outra aplicação.

Neste exemplo que iremos montar, iremos usar: um formulário, duas caixas de texto (os quais o usuário irá digitar dois números reais), um botão de comando.}


unit usadll;

interface

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

type
TForm1 = class(TForm)
Label1: TLabel;
Label2: TLabel;
Button1: TButton;
Edit1: TEdit;
Edit2: TEdit;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
function Max(a, b : double):double;stdcall;

var
Form1: TForm1;

implementation

{$R *.DFM}

function Max(a, b : double):double;external 'MaxDLL';
procedure TForm1.Button1Click(Sender: TObject);
var
x, y, resultado : double;
begin
x := StrToFloat(Edit1.Text);
y := StrToFloat(Edit2.Text);
resultado := Max(x,y);
ShowMessage('Valor Máximo ' +FloatToStr(resultado));
end;

end. {PS: A função Max está declarada na seção interface e implementada na seção implementation, ou seja, a função está implementada em uma DLL.

Bem, mostramos como criar uma DLL simples e como fazer chamada de uma DLL. Agora, iremos melhorar nossa DLL, fazendo com que ela exiba um formulário qualquer em qualquer aplicação desenvolvida para Windows.}

Criando caixas de diálogo em tempo de execução

{Inclua na seção uses: Forms, StdCtrls, Buttons A função abaixo demonstra a criação de uma caixa de diálogo que permite entrada de dados.}

{ Esta função retorna true se for pressionado OK e false em caso contrário. Se for OK, o texto digitado pelo usuário será copiado para a variável Nome }
function ObterNome(var Nome: string): boolean;
var
Form: TForm; { Variável para o Form }
Edt: TEdit; { Variável para o Edit }
begin
Result := false; { Por padrão retorna false }
{ Cria o form }
Form := TForm.Create(Application);
try
{ Altera algumas propriedades do Form }
Form.BorderStyle := bsDialog;
Form.Caption := 'Atenção';
Form.Position := poScreenCenter;
Form.Width := 200;
Form.Height := 150;
{ Coloca um Label }
with TLabel.Create(Form) do begin
Parent := Form;
Caption := 'Digite seu nome:';
Left := 10;
Top := 10;
end;
{ Coloca o Edit }
Edt := TEdit.Create(Form);
with Edt do begin
Parent := Form;
Left := 10;
Top := 25;
{ Ajusta o comprimento do Edit de acordo com a largura do form }
Width := Form.ClientWidth - 20;
end;
{ Coloca o botão OK }
with TBitBtn.Create(Form) do begin
Parent := Form;
{ Posiciona de acordo com a largura do form }
Left := Form.ClientWidth - (Width * 2) - 20;
Top := 80;
Kind := bkOK; { Botão Ok }
end;
{ Coloca o botão Cancel }
with TBitBtn.Create(Form) do begin
Parent := Form;
Left := Form.ClientWidth - Width - 10;
Top := 80;
Kind := bkCancel; { Botão Cancel }
end;
{ Exibe o form e aguarda a ação do usuário. Se for OK... }
if Form.ShowModal = mrOK then begin
Nome := Edt.Text;
Result := true;
end;
finally
Form.Free;
end;
end;

//Para chamar esta função siga o exemplo abaixo:

procedure TForm1.Button1Click(Sender: TObject);
var
S: string;
begin
if ObterNome(S) then
Edit1.Text := S;
end;

{Os componentes Label, Edit (var Edt) e BitBtn's (botões) não são destruídos explicitamente (Componente.Free). Isto não é necessário, pois ao criá-los informei como proprietário o Form (ex: TLabel.Create(Form)). Neste caso, estes componentes são destruídos automaticamente ao destruir o Form (Form.Free).}

Criando um atalho no desktop

//Coloque essas units na seção implementation :
uses ShlObj, ActiveX,ComObj, Registry; //Por último, crie uma procedure que faça o trabalho:

procedure CreateShortcut (FileName, Parameters, InitialDir, ShortcutName, ShortcutFolder : String);
var
MyObject : IUnknown;
MySLink : IShellLink;
MyPFile : IPersistFile;
Directory : String;
WFileName : WideString;
MyReg : TRegIniFile;
begin
MyObject := CreateComObject(CLSID_ShellLink);
MySLink := MyObject as IShellLink;
MyPFile := MyObject as IPersistFile;
with MySLink do
begin
SetArguments(Parameters);
SetPath(PChar(FileName));
SetWorkingDirectory(PChar(InitialDir));
end;
MyReg := TRegIniFile.Create('SoftwareMicroSoftWindowsCurrentVersionExplorer');
Directory := MyReg.ReadString ('Shell Folders','Desktop','');
WFileName := Directory + '' + ShortcutName + '.lnk';
MyPFile.Save (PWChar (WFileName), False);
MyReg.Free;
end;

Criando uma rotina para pegar todos os erros do programa

Procedure MostraErro;
Begin
ShowMessage('Ocorreu algum erro!');
end;

TForm1.Create;
Begin
Application.OnException:=MostraErro;
end;

Criando uma base de dados ms access pelo delphi

{Aprenda como criar uma base de dados MS Access sem o MS Access. Cria a base, as tabelas, índices, enfim, tudo utilizando puro código Pascal. INTRODUÇÃO

Quando se cria um sistema para ambientes desktop sempre surge a dúvida de qual base de dados usar. Geralmente são usados bancos DBase, Paradox ou MS Access. Destes, a base mais robusta e confiável é, sem dúvida, MS Access. Mas existe um grande problema para se criar a base de dados MS Access, pois faz-se necessário o uso do ambiente MS Access.

Algumas pessoas não têm este aplicativo instalado em sua máquina e então torna-se inviável o uso desta base de dados, impedindo, desta forma, um crescimento tecnológico do programador que fica preso a ferramentas obsoletas.

Neste tutorial você irá aprender como criar uma base de dados MS Access a partir do nada, usando puro código Delphi e a Tecnologia ADO Extensions que é distribuída pela Microsoft.

ADOX, faz parte dos componentes ADO, quer dizer, é uma extensão do ADO. O ADOX fornece ferramentas de acesso a estrutura, segurança, definições de tabelas e muitos outros.

Como dito anteriormente, ADOX é uma library distribuída pela Microsoft, o arquivo chama-se "Msadox.dll", sua definição é "Microsoft ADO Ext. 2.x for DDL and Security" e é este arquivo que iremos importar para nossa IDE no Delphi.

INSTALANDO

Para usar este objetos no Delphi basta seguir os seguintes passos:

1- Selecione PROJECT > IMPORT TYPE LIBRARY

2- Procure pela descrição: "Microsoft ADO Ext. 2.x for DDL and Security (Version 2.x)"

2- Em CLASS NAMES, altere o nome dos objetos acrescentando ADOX após a letra T, exemplo: TTable mude para TADOXTable, TColumm mude para TADOXColumn. Repita este procedimento para todos objetos nesta lista.

3- Em PALETTE PAGE selecione ou digite um novo nome para a paleta onde os componentes ficarão, exemplo: ADOX.

4- Pressione INSTALL, logo depois pressione Ok confirmando o início da instalação.

5- Pressione YES confirmando que você quer instalar os componentes.

6- Pressione Ok na tela que indica os objetos instalados.

7- Selecione FILE > CLOSE ALL e pressione YES para salvar este package criado.

O motivo da troca do nome dos objetos é muito óbvio, estes nomes de classe como Ttable já existem, então iria gerar conflitos na compilação, por isso bastou trocar o nome da classe.

Pronto, os objetos estão instalados, agora sempre que você utilizar estes objetos será inserido na clausula USES a Unit ADOX_TLB pois este é o nome da unit criada a partir da importação da DLL.

Agora, mãos à obra.

DEFININDO A BASE DE DADOS E OBJETOS A SEREM USADOS

Vamos criar uma base onde serão armazenados informaçõe sobre animais de estimação (para sair um pouco da rotina de CLIENTES/PRODUTOS/PEDIDOS).

Para esta base serão criadas as seguintes tabelas:

> PROPRIETARIO

> PRO_ID

> PRO_NOME

>ANIMAL

> ANI_ID

> ANI_PROPRIETARIO

> ANI_NOME

> ANI_NASCIMENTO

Onde um proprietario pode ter mais de um animal formando assim um relacionamento UM PARA MUITOS.

No Delphi, crie uma nova aplicação. Será criado um novo Form, a este insira os seguintes componentes:

> 3 TButtons

Para lançar os procedimentos de criação da base de dados e das tabelas.

Altere as seguintes propriedades para cada TButtons respectivamente:

Caption: Criar base

Name: btnBase

Caption: Criar tabelas

Name: btnTabelas

Caption: Navegar

Name: btnNavegar

> 1 TEdit

Para armazenar o path da base de dados a ser criada.

Altere as seguintes propriedades:

Name: edtPath

Text: (deixe em branco)

> 1 TSaveDialog

Para navegar no disco e informar o path da base de dados.

Altere as seguintes propriedades:

Filter: Base MS Access|*.mdb

Title: Salvar como...

DefaultExt: .mdb

> 1 TADOConnection

Para fazer a conexão com a base criada.

Altere as seguintes propriedades:

Login prompt: False

> 1 TADOCommand

Para fazer a ligação e criação das tabelas.

Altere as seguintes propriedades:

Connection: Selecione o ADOConnection1

> 1 TADOXCatalog

Para criar a base de dados.

CRIANDO A BASE DE DADOS

Agora vamos ao código. Clique duas vezes no objeto btnNavegar e digite:}


procedure TForm1.btnNavegarClick(Sender: TObject);
begin
if SaveDialog1.Execute then
edtPath.Text := SaveDialog1.FileName;
end; Com isso informamos o nome que a base terá.

Clique duas vezes no objeto btnBase e digite o seguinte procedimento:


procedure TForm1.btnBaseClick(Sender: TObject);
var
Base: String;
begin
if edtPath.Text = '' then
begin
ShowMessage('Nome da base de dados não informada.');
exit;
end;
Base := 'Provider=Microsoft.Jet.OLEDB.4.0'+
';Data Source=' + edtPath.Text +
';Jet OLEDB:Engine Type=4';
ADOXCatalog1.Create1(Base);
end; {Primeiro verificamos se há algum texto no objeto TEdit, em seguida atribuímos a string de conexão à variável BASE informando vários parâmetros, mas atente para a seguinte linha: "...Engine Type=4...", isto quer dizer que iremos criar uma base Access 97, para Access 2000 informe 5.

Em seguida é efetivamente criado a base de dados através do método Create1 do objeto ADOXCatalog, passando para este a string da BASE. Observe que o método é Create1 e não simplesmente Create, pois o método Create já existe e é da classe.

Pronto, criamos uma base de dados vazia, não existe nada nela, mas já é um arquivo comum ao MS Access e pode ser aberto normalmente.

CRIANDO TABELAS

Vamos começar a criar as tabelas, seus índices e integridade referencial. Para isso clique duas vezes no objeto btnTabelas e digite:}


procedure TForm1.btnTabelasClick(Sender: TObject);
var
base, comando: string;
begin
{ definindo a base de dados }
base := 'Provider=Microsoft.Jet.OLEDB.4.0' +
';Data Source=' + edtPath.Text +
';Persist Security Info=False';
ADOConnection1.ConnectionString := base;
{ Criando as tabelas... }
{>>> PROPRIETARIO <<<}
comando := 'CREATE TABLE PROPRIETARIO (' +
'PRO_ID INT,' +
'PRO_NOME TEXT(50))';
ADOCommand1.CommandText := comando;
ADOCommand1.Execute;
{ ADICIONANDO INDICES }
comando := 'CREATE INDEX IDX_PRO_ID ' +
'ON PROPRIETARIO (PRO_ID) WITH PRIMARY';
ADOCommand1.CommandText := comando;
ADOCommand1.Execute;
{>>> ANIMAL <<<}
comando := 'CREATE TABLE ANIMAL (' +
'ANI_ID INT,' +
'ANI_PROPRIETARIO INT ' +
'CONSTRAINT IDX_PRO_ID ' +
'REFERENCES PROPRIETARIO (PRO_ID),' +
'ANI_NOME TEXT (50),' +
'ANI_NASCIMENTO DATETIME)';
ADOCommand1.CommandText := comando;
ADOCommand1.Execute;
end; {CONCLUÍNDO

Pronto, tudo muito fácil e simples. Agora rode o programa e faça os testes. Clique em navegar, selecione um diretório e digite o nome que sua base terá, então clique em CRIAR BASE e veja que o programa criará a base, logo após isto clique em CRIAR TABELAS então as tabelas serão criadas.

Agora ficou fácil criar sistemas desktops usando uma base mais robusta sem a necessidade de se ter o MS Access instalado em sua máquina. É possível criar e acessar todos os recursos de tabelas da base de dados MS Access usando os objetos ADOX, aqui foi mostrado como criar utilizando linguagem DDL, ou seja, escrevemos diretamente para que o comando fosse executado, mas é possível ter acesso à estes recursos diretamente com os componentes distribuídos por esta library, mas este assunto ficará para outra ocasião.

Se você tiver o MS Access instalado em sua máquina pode abri-lo e verificar nossa base de dados, caso contrário (como é o meu caso) crie uma simples aplicação com dois DBGrids para exibir os campos das tabelas, assim como inserir dados.}

Criando uma barra de status completa

{Para testar o exemplo abaixo inclua um componente StatusBar, um componente Timer. No componente StatusBar vá até a propriedade Panels e adicione 3 panels.

Na propriedade Interval do componente Timer informe o valor 500.}


unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ComCtrls, ExtCtrls;
type
TForm1 = class(TForm)
StatusBar1: TStatusBar;
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure FormKeyPress(Sender: TObject; var Key: Char);
procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
// Evento OnCreate do Form
procedure TForm1.FormCreate(Sender: TObject);
begin
Timer1Timer(Self);
end;
// Evento OnTimer do componente Timer
procedure TForm1.Timer1Timer(Sender: TObject);
begin
StatusBar1.Panels[0].Text := TimeToStr(Time);
if GetKeyState(VK_NUMLOCK) = 1 then
StatusBar1.Panels[1].Text := 'Num lock: ON'
else
StatusBar1.Panels[1].Text := 'Num lock: OFF';
if GetKeyState(VK_CAPITAL) = 1 then
StatusBar1.Panels[2].Text := 'Caps lock: ON'
else
StatusBar1.Panels[2].Text := 'Caps lock: OFF';
end;
// Evento OnKeyPress do Form
procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);
begin
Timer1Timer(Self);
end;
// Evento OnKeyDown do Form
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
Timer1Timer(Self);
end;

Criando uma barra de status

{Para criar uma barra de status realmente útil, primeiramente coloque um componente TStatusBar (que está na paleta Win32) no seu form. Clique com o botão direito no StatusBar1 e escolha Panels Editor. Clique Add e pronto (se quiser colocar mais divisões - para colocar um relógio, por exemplo, é só clicar Add mais vezes). Primeiramente altere a propriedade ShowHint para True. Depois digite o que vai aparecer no seguinte formato:

Texto que vai aparecer junto ao mouse|Texto que vai aparecer no StatusBar (onde | é Shift + ).

* No texto que aparecer junto ao mouse, coloque uma frase pequena (ex: Imprimir). No texto que vai aparecer no StatusBar, coloque um texto mais explicativo (ex: Imprimir o relatório de vendas do mês atual).

* Caso você queira que não apareça nenhum texto junto ao mouse (ou seja, só no StatusBar), cuide para que o primeiro caracter de Hint seja o caracter "|" (sem aspas).

No evento OnCreate do form, coloque o seguinte comando:}


Application.OnHint := ShowHint; {Crie uma procedure na seção private do form a procedure ShowHint. Na seção implementation, coloque:}


procedure TForm1.ShowHint(Sender: TObject);
begin
StatusBar1.Panels[0].Text := GetLongHint (Application.Hint);
end;

Criando um componente skin

{Aqui iremos tratar da criação de um componente SKIN como os do WINAMP. Para montar os SKINS devemos utilizar um Bitmap e deixar as bordas do formulários transparentes (ocultas). A solução é bem simples, utilizando o componente Timage, dê uma olhado no fonte:}


unit SkinImage;
interface

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

type
TSkinImage = class(TImage)
private

protected
{ Protected declarations }
function BitmapToRegion(bmp: TBitmap) : dword;
procedure OwnerShow(Sender : TObject);
public
constructor Create(AOwner : TComponent); override;
published
{ Published declarations }
end;

procedure Register;

var
Ready : Boolean;

implementation

procedure Register;
begin
RegisterComponents('CLINICA DELPHI', [TSkinImage]);
end;

{ TSkinImage }

constructor TSkinImage.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
if NOT (csDesigning in ComponentState) then
with TForm(AOwner) do
begin
BorderStyle := bsNone;
Self.Top := 0;
Self.Left := 0;
OnShow := OwnerShow;
end;
end;

function TSkinImage.BitmapToRegion(bmp: TBitmap) : dword;
var ix,iy : integer; // loop nas variáveis
tc : TColor; // transparentColor
b1 : boolean; // está olhando o "real"
pixels (no transparent pixels)
c1 : cardinal; // ajusta a variável na região
i1 : integer; // primeira posição real em pixel
begin
Result := 0;
i1 := 0;
// memória do transparent color
tc := bmp.transparentColor and $FFFFFF;
with bmp.canvas do
// enquadrilhe por todas as linhas
for iy := 0 to bmp.height - 1 do
begin
b1 := False;
// esquadrinhe por todo o pixels nesta linha
for ix:=0 to bmp.Width - 1 do
// feito nós acharmos o começo/final seguidos em pixel
if (pixels[ix, iy] and $FFFFFF <> tc) <> b1 then begin
// sim, e foi o último pixel,
// so nós podemos somar uma região de estilo de linha. . .
if b1 then begin
c1:=CreateRectRgn(i1,iy,ix,iy+1);
if result<>0 then
begin
// Esta não é a primeira região
CombineRgn(Result, Result, c1, RGN_OR);
DeleteObject(c1);
// Esta é a primeira região
end
else
Result := c1;
end else i1 := ix;
// mude o modo e procura o primeiro ou último pixel?
b1:=not b1;
end;
// o último pixel nesta fila era um pixel real?
if b1 then begin
c1:=CreateRectRgn(i1, iy, bmp.width-1, iy+1);
if (Result <> 0) then
begin
CombineRgn(Result, Result, c1, RGN_OR);
DeleteObject(c1);
end
else
Result := c1;
end;
end;
end;

procedure TSkinImage.OwnerShow(Sender: TObject);
var
Region : HRGN;
begin
if NOT Ready then
begin
Ready := True;
Region := BitmapToRegion(Picture.Bitmap);
SetWindowRgn(TForm(Owner).Handle, Region, True);
DeleteObject(Region);
end;
end;

initialization
Ready := False;
end. {" Digamos a primeira linha de nosso bitmap se parece:

000XXXXX00XXXXX000000XXXX000

0 -> Pixel Trasparente; X -> Pixel Colorido

Agora minha função passa por esta linha e cria uma região de janela para cada fila de pixels. No exemplo, nós adquiriríamos 3 regiões (4-8, 11-15, 22-25).

Nós fizemos o mesmo para todas as outras linhas no Bitmap, e todas essas regiões.}