Super Dicas Delphi parte II

Como posso rolar um form usando pgUP and pgDn.
Tocando Sons WAV
Colocar Funções em uma DLL
Compactando tabelas
Gera número por extenso
Preenche com zeros o lado esquerdo de uma string
Ponto Decimal
FindNearest numa Query
Relatórios em HTML
Desligando Windows via programação
Como saber se o CD está no drive
Tradução de Mensagens
Função que devolve tempo decorrido em uma string
Criando uma rotina para pegar todos os erros do programa.
Capturando conteúdo do desktop

Como posso rolar um form usando pgUP and pgDn.

Versão: Todas
Plataforma: Windows/Win32

Q. Como posso fazer funções de rolagem num componente TForm usando comandos
de teclado? Por exemplo, rolar pra cima e pra baixo quando pressionar PgUp
ou PgDown. Existe algum método simples de fazer isso???

R. O rolamento do form é completo fazendo-se uma modificação na posição das
propriedades VertScrollbar ou HorzScrollbar do form. Como mostrado no código a
seguir:

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
const
PageDelta = 10;
begin
With VertScrollbar do
if Key = VK_NEXT then
Position := Position + PageDelta
else if Key = VK_PRIOR then
Position := Position - PageDelta;
end;

Tocando Sons WAV

Para reproduzir sons no formato WAV em um programa em Delphi é simples, o usuário deverá colocar na clásula
Uses o MMSystem. E no corpo do programa o comando:

SndPlaySound('C:\Windows\Media\Som.wav',SND_ASYNC);

Colocar Funções em uma DLL

Edite diretamente no DPR, e depois salve como Funcoes.dpr:

Library Funcoes;

Uses SysUtils,WinTypes,WinProcs;

{ Uma função que tira os espaços no início e no final de uma string }
Function Trim(J:String):String; Export;
Begin
While J[Length(J)]=#32 do Dec(J[0]);
If Length(J)>1 then
While (J[1]=' ') do
Begin
Delete(J,1,1);
If Length(J)<=1 then J:='';
end;
Result:=J;
end;
Exports { Torna visivel para os programas }
Trim;
Begin
End.

Para usar num programa:

Unit Unit1;
Interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, Buttons;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
Var
Form1: TForm1;
Implementation
{ Declara a funcao }
Function Trim(J:String):String; External 'funcoes.dll';
{$R *.DFM}
Procedure TForm1.FormClick(Sender: TObject);
begin
Caption:=Trim(' Visite sempre o Delphi Club '); { Note os espacos }
end;

As vantagens de colocar as funções em DLL são:
1. O programa exigirá menos memória
2. Você poderá reaproveitar as funções
3. Em alguns casos pode-se atualizar apenas as dll para um upgrade

Compactando tabelas

Para compactar (remover fisicamente todos registros apagados) de uma tabela Paradox deve-se utilizar o seguinte código

procedure ParadoxPack(Table : TTable);
var
TBDesc : CRTblDesc;
hDb: hDbiDb;
TablePath: array[0..dbiMaxPathLen] of char;
begin
FillChar(TBDesc,Sizeof(TBDesc),0);
with TBDesc do begin
StrPCopy(szTblName,Table.TableName);
StrPCopy(szTblType,szParadox);
bPack := True;
end;
hDb := nil;
Check(DbiGetDirectory(Table.DBHandle, True, TablePath));
Table.Close;
Check(DbiOpenDatabase(nil, 'STANDARD', dbiReadWrite,
dbiOpenExcl,nil,0, nil, nil, hDb));
Check(DbiSetDirectory(hDb, TablePath));
Check(DBIDoRestructure(hDb,1,@TBDesc,nil,nil,nil,False));
Table.Open;
end;

Gera número por extenso

unit Ext;

interface
function extenso (valor: real): string;

implementation

uses
SysUtils, Dialogs;

function extenso (valor: real): string;
var
Centavos, Centena, Milhar, Milhao, Texto, msg: string;
const
Unidades: array[1..9] of string = ('Um', 'Dois', 'Tres', 'Quatro', 'Cinco',
'Seis', 'Sete', 'Oito', 'Nove');
Dez: array[1..9] of string = ('Onze', 'Doze', 'Treze', 'Quatorze', 'Quinze',
'Dezesseis', 'Dezessete', 'Dezoito', 'Dezenove');
Dezenas: array[1..9] of string = ('Dez', 'Vinte', 'Trinta', 'Quarenta',
'Cinquenta', 'Sessenta', 'Setenta',
'Oitenta', 'Noventa');
Centenas: array[1..9] of string = ('Cento', 'Duzentos', 'Trezentos',
'Quatrocentos', 'Quinhentos', 'Seiscentos',
'Setecentos', 'Oitocentos', 'Novecentos');

function ifs(Expressao: Boolean; CasoVerdadeiro, CasoFalso: String): String;
begin
if Expressao
then Result:=CasoVerdadeiro
else Result:=CasoFalso;
end;

function MiniExtenso (trio: string): string;
var
Unidade, Dezena, Centena: string;
begin
Unidade:='';
Dezena:='';
Centena:='';
if (trio[2]='1') and (trio[3]<>'0') then
begin
Unidade:=Dez[strtoint(trio[3])];
Dezena:='';
end
else
begin
if trio[2]<>'0' then Dezena:=Dezenas[strtoint(trio[2])];
if trio[3]<>'0' then Unidade:=Unidades[strtoint(trio[3])];
end;
if (trio[1]='1') and (Unidade='') and (Dezena='')
then Centena:='cem'
else
if trio[1]<>'0'
then Centena:=Centenas[strtoint(trio[1])]
else Centena:='';
Result:= Centena + ifs((Centena<>'') and ((Dezena<>'') or (Unidade<>'')), ' e ', '')
+ Dezena + ifs((Dezena<>'') and (Unidade<>''),' e ', '') + Unidade;
end;

begin
if (valor>999999.99) or (valor<0) then
begin
msg:='O valor está fora do intervalo permitido.';
msg:=msg+'O número deve ser maior ou igual a zero e menor que 999.999,99.';
msg:=msg+' Se não for corrigido o número não será escrito por extenso.';
showmessage(msg);
Result:='';
exit;
end;
if valor=0 then
begin
Result:='';
Exit;
end;
Texto:=formatfloat('000000.00',valor);
Milhar:=MiniExtenso(Copy(Texto,1,3));
Centena:=MiniExtenso(Copy(Texto,4,3));
Centavos:=MiniExtenso('0'+Copy(Texto,8,2));
Result:=Milhar;
if Milhar<>'' then
if copy(texto,4,3)='000' then
Result:=Result+' Mil Reais'
else
Result:=Result+' Mil, ';
if (((copy(texto,4,2)='00') and (Milhar<>'')
and (copy(texto,6,1)<>'0')) or (centavos=''))
and (Centena<>'') then Result:=Result+' e ';
if (Milhar+Centena <>'') then Result:=Result+Centena;
if (Milhar='') and (copy(texto,4,3)='001') then
Result:=Result+' Real'
else
if (copy(texto,4,3)<>'000') then Result:=Result+' Reais';
if Centavos='' then
begin
Result:=Result+'.';
Exit;
end
else
begin
if Milhar+Centena='' then
Result:=Centavos
else
Result:=Result+', e '+Centavos;
if (copy(texto,8,2)='01') and (Centavos<>'') then
Result:=Result+' Centavo.'
else
Result:=Result+' Centavos.';
end;
end;

end.

Preenche com zeros o lado esquerdo de uma string

unit Zero;

interface
function RetZero(ZEROS:string;QUANT:integer):String;

implementation

function RetZero(ZEROS:string;QUANT:integer):String;
var
I,Tamanho:integer;
aux: string;
begin
aux:=zeros;
Tamanho:=length(ZEROS);
ZEROS:='';
for I:=1 to quant-tamanho do
ZEROS:=ZEROS+'0';
aux:=zeros+aux;
RetZero:=aux;
end;
end.

Ponto Decimal

if Key in [',','.'] then Key := DecimalSeparator;

Coloque no evento OnKeyPress dos seus TEdits numéricos

FindNearest numa Query

Query.Locate('campo onde ira porcurar',Texto a buscar,[loPartialKey])

Relatórios em HTML

Em vez de Quickreport1.Print faca :

QuickRep1.ExportToFilter(TQRHtmlExportFilter.Create('teste.html'));

Desligando Windows via programação

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;

Como saber se o CD está no drive

Function MidiaPresente(MediaPlayer: TMediaPlayer): Boolean;
var
Params: MCI_STATUS_PARMS;
S: array [0.255] of char;
r: Integer;
begin
//verifica se existe um cd inserido
Params.dwItem:= MCI_STATUS_MEDIA_PRESENT;
r:= MCISendCommand(MediaPlayer.DeviceID, MCI_STATUS,

MCI_STATUS_ITEM, Integer(Addr(Params)));
if r <> 0 then
begin
MCIGetErrorString(r, S, SizeOf(S));
ShowMessage('Erro: ' + StrPas(S));
end
else
Result:= Params.dwReturn = 1;
end;

Tradução de Mensagens

Depois de algum tempo pesquisando uma forma de fazer aparecer as mensagens
em português, consegui uma solução muito fácil de implementar no ambiente
de programação do Delphi 3.

CHEGA DE YES/NO !!!

messagedlg('Confirma ? mtConfirmation, [mbYes, mbNo], 0);

Aí vai:

1 - No diretório DELPHI3\LIB, copie o arquivo consts.dcu para consts.old;
2 - Inicie o Delphi e crie um nova Unit;
3 - Insira nesta, o arquivo consts.int do diretório DELPHI3\DOC E faça as
devidas alterações nas mensagens que desejares alterar e nas
partes duplicadas da Unit como "implement" e etc, também deixe o
cabeçalho como Unit Consts.
4 - Salve esta nova Unit no diretório DELPHI\LIB e pronto todas as
mensagens alteradas por você estarão aplicadas nos seus
próximos programas sem uma linha de programa e da
forma que você quiser.

Função que devolve tempo decorrido em uma string

Function NumDiasExtenso(NumDias:integer):string;
var
Anos, Meses, Dias : integer;
sAnos, sMeses, sDias : string;
begin
{ --- Calcula o número de anos --- }
Anos := 0;
while NumDias >= 365 do
begin
Anos := Anos + 1;
NumDias := NumDias - 365;
end;
if Anos > 1 then
sAnos := ' anos,'
else
sAnos := ' ano,';

{ --- Calcula o número de meses --- }
Meses := 0;
while NumDias >= 30 do
begin
Meses := Meses + 1;
NumDias := NumDias - 30;
end;
if Meses > 1 then
sMeses := ' meses e '
else
sAnos := ' mês e ';

{ --- O Número de dias é a sobra --- }
Dias := NumDias;
if sDias > 1 then
sDias := 'dias'
else
sDias := 'dia';

Return := Inttostr(Anos)+sAnos+inttostr(Meses)+sMeses+inttostr(Dias)+sDias;
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;

Capturando conteúdo do desktop

procedure TForm1.FormResize(Sender: TObject);
var
R : TRect;
DC : HDc;
Canv : TCanvas;
begin
R := Rect( 0, 0, Screen.Width, Screen.Height );
DC := GetWindowDC( GetDeskTopWindow );
Canv := TCanvas.Create;
Canv.Handle := DC;
Canvas.CopyRect( R, Canv, R );
ReleaseDC( GetDeskTopWindow, DC );
end;