sábado, 17 de outubro de 2009

Codigo de barras

//Criar Código de Barras 2x5i

Procedure CriaCodigo(Cod : String; Imagem : TCanvas);

Const
digitos : array['0'..'9'] of string[5]= ('00110',
'10001',
'01001',
'11000',
'00101',
'10100',
'01100',
'00011',
'10010',
'01010');
Var
Numero : String;
Cod1 : Array[1..1000] Of Char;
Cod2 : Array[1..1000] Of Char;
Codigo : Array[1..1000] Of Char;
Digito : String;
c1,c2 : Integer;
x,y,z,h : LongInt;
a,b,c,d : TPoint;
I : Boolean;
Begin
Numero := Cod;
For x := 1 to 1000 Do
Begin
Cod1 [x] := #0;
Cod2 [x] := #0;
Codigo[x] := #0;
End;
c1 := 1;
c2 := 1;
x := 1;
For y := 1 to Length(Numero) div 2 do
Begin
Digito := Digitos[Numero[x ]];
For z := 1 to 5 do
Begin
Cod1[c1] := Digito[z];
Inc(c1);
End;
Digito := Digitos[Numero[x+1]];
For z := 1 to 5 do
Begin
Cod2[c2] := Digito[z];
Inc(c2);
End;
Inc(x,2);
End;
y := 5;
Codigo[1] := '0';
Codigo[2] := '0';
Codigo[3] := '0';
Codigo[4] := '0'; { Inicio do Codigo }
For x := 1 to c1-1 do
begin
Codigo[y] := Cod1[x]; Inc(y);
Codigo[y] := Cod2[x]; Inc(y);
end;
Codigo[y] := '1'; Inc(y); { Final do Codigo }
Codigo[y] := '0'; Inc(y);
Codigo[y] := '0';
Imagem.Pen .Width := 1;
Imagem.Brush.Color := ClWhite;
Imagem.Pen .Color := ClWhite;
a.x := 1; a.y := 0;
b.x := 1; b.y := 79;
c.x := 2000; c.y := 79;
d.x := 2000; d.y := 0;
Imagem.Polygon([a,b,c,d]);
Imagem.Brush.Color := ClBlack;
Imagem.Pen .Color := ClBlack;
x := 0;
i := True;
for y:=1 to 1000 do
begin
If Codigo[y] <> #0 Then
Begin
If Codigo[y] = '0' then
h := 1
Else
h := 3;
a.x := x; a.y := 0;
b.x := x; b.y := 79;
c.x := x+h-1; c.y := 79;
d.x := x+h-1; d.y := 0;
If i Then
Imagem.Polygon([a,b,c,d]);
i := Not(i);
x := x + h;
End;
end;
end;

//Como Usar:

procedure TForm1.Button1Click(Sender: TObject);
begin
CriaCodigo('03213213241',Image1.Canvas);
end;



p.931

Criar um alias através do seu programa

//Criar um Alias através do seu programa

Inclua na seção uses: DB
{ se o alias não existir... }
if not Session.IsAlias('MeuAlias') then
begin
{ Adiciona o alias }
Session.AddStandardAlias('MeuAlias', 'C:DirProg', 'PARADOX');
{ Salva o arquivo de configuração do BDE }
Session.SaveConfigFile;
end;
{
Observações
Para criar um alias do dBase troque a string 'PARADOX' por 'DBASE'. No caso acima usei como path o caminho "C:DirProg", mas se você quiser poderá trocar este caminho por ExtractFilePath(ParamStr(0)) para que o alias seja direcionado para o local onde está seu .EXE. Neste último caso será necessário incluir na seção uses: SysUtils, System.Autor: Daniel P. Guimarães}

Utilizar messagebox com parametros

Var
Button: Integer;
Mensagem1 : Array[0..79] of Char;
Mensagem2 : Array[0..79] of Char;
begin
StrPCopy(Mensagem1, Edit1.Text + ' ' + Edit2.Text);
StrPCopy(Mensagem2, Edit3.Text + ' ' + Edit4.Text);
Button := Application.MessageBox (Mensagem2,Mensagem1, MB_YESNOCANCEL+
mb_DefButton1+MB_ICONQUESTION);
end;

Verificar que programas estã na memoria

Function EnumWindowsProc (Wnd: HWND; lb: TListbox): BOOL; stdcall;
// listbox1.clear;
// EnumWindows( @EnumWindowsProc, integer(listbox1));
var
caption: Array [0..128] of Char;
begin
Result := True;
if IsWindowVisible(Wnd) and ((GetWindowLong(Wnd, GWL_HWNDPARENT) = 0) or
(HWND(GetWindowLong(Wnd, GWL_HWNDPARENT)) = GetDesktopWindow)) and
((GetWindowLong(Wnd, GWL_EXSTYLE) and WS_EX_TOOLWINDOW) = 0) then
begin
SendMessage( Wnd, WM_GETTEXT, Sizeof( caption ),integer(@caption));
lb.Items.AddObject( caption, TObject( Wnd ));
end;
end;

Verificar que programas estã na memoria

Function EnumWindowsProc (Wnd: HWND; lb: TListbox): BOOL; stdcall;
// listbox1.clear;
// EnumWindows( @EnumWindowsProc, integer(listbox1));
var
caption: Array [0..128] of Char;
begin
Result := True;
if IsWindowVisible(Wnd) and ((GetWindowLong(Wnd, GWL_HWNDPARENT) = 0) or
(HWND(GetWindowLong(Wnd, GWL_HWNDPARENT)) = GetDesktopWindow)) and
((GetWindowLong(Wnd, GWL_EXSTYLE) and WS_EX_TOOLWINDOW) = 0) then
begin
SendMessage( Wnd, WM_GETTEXT, Sizeof( caption ),integer(@caption));
lb.Items.AddObject( caption, TObject( Wnd ));
end;
end;

Colocar os bitmaps na dll

Por vezes, quando iniciamos um projeto, temos uma preocupação: fazer uma aplicação pequena. Bem, a solução pode passar por colocar todos os bitmaps que vamos utilizar numa dll. Então vamos lá:

Deve usar o Image Editor, criar uma nova Resource File (.res), neste arquivo vamos colocar os bitmaps e icons (ambos funcionam da mesma forma) que queremos na nossa aplicação, clique com a tecla direita do mouse na nova resource file e crie um novo bitmap, depois desenhe ou cole do clipboard um bitmap, finalmente guarde o arquivo com o nome images.res. Depois disto estar feito vá ao IDE do Delphi e no File menu clique New... e escolha DLL depois cole o código abaixo, não se esqueça de adicionar uma unit vazia ao projeto. Guarde o projeto da dll no mesmo directório do arquivo image.res, finalmente faça o build da dll (não se esqueça, que não se pode correr (executar) uma dll!)

Código da Dll:

library ImageRes; {nome da dll}
uses DummyUnit; {DummyUnit é uma unit vazia, que é necessária}
{$R images.res} {nome da resource file, que deve estar no mesmo caminho da dll}
begin
end.
Código da DummyUnit:

unit DummyUnit;
interface
implementation
end.

Usar os bitmaps que estão na dll:
Estão aqui alguns exemplos como extrair os bitmaps da dll:

procedure TForm1.SpeedButton1Click(Sender:TObject);
var
MyHandle :THandle;
Bmp : TBitmap;
begin
{nome da dll construida acima}
MyHandle := LoadLibrary('ImageRes.DLL');
Bmp := TBitmap.Create;
{Bitmap1 é o nome do bitmap criado no ficheiro image.res}
Bmp.Handle := LoadBitmap(MyHandle, 'BITMAP1');
{Carrega o Bitmap1 para o glyph do SpeedButton1}
SpeedButton1.Glyph.Handle := LoadBitmap(MyHandle,'BITMAP1');
Canvas.Draw(0,0,Bmp); {Desenha o bitmap no canvas da form}
Image1.picture.bitmap:=Bmp; {Carrega o bitmap para o componente Timage}
Bmp.Free;
end;

Verificando impressora / impressao

{Verificar se a impressora esta OK, antes de iniciar
uma impressão é um bom procedimento, abaixo segue
uma função que retorna true se a impressora esta pronta
para imprimir.}


Function PrinterOnLine : Boolean;
Const
PrnStInt : Byte = $17;
StRq : Byte = $02;
PrnNum : Word = 0; { 0 para LPT1, 1 para LPT2, etc. }
Var
nResult : byte;
Begin (* PrinterOnLine*)
Asm
mov ah,StRq;
mov dx,PrnNum;
Int $17;
mov nResult,ah;
end;

PrinterOnLine := (nResult and $80) = $80;
End;


//Esta função foi Testada com Delphi 1, Delphi 2 e 3.
//Exemplo de utilização:

If not PrinterOnLine then ShowMessage('Atenção! Verifique a Impressora...');

Como obter o numero de serie do hd

Function TForm1.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;

Criando um form diferente

{Para alterar o formato do form, utilize a rotina abaixo
no evento OnClick do form (de preferência troque a
propriedade BorderStyle para bsNone, e deixe os
componentes mais ao centro do form): }

procedure TForm1.FormCreate(Sender: TObject);
var
hR : THandle;
begin
{cria uma form de formato elíptico}
hR := CreateEllipticRgn (0,0,Width,Height);
SetWindowRgn (Handle,hR,True);
end;

Limitndo o movimento do mouse

// Insira na seção uses a seguinte claúsula:
Windows

// Coloque um botão no form e altera o evento OnClick dele conforme abaixo:

procedure TForm1.Button1Click(Sender: TObject);
var
R: TRect;
begin
{ Pega o retângulo da área cliente do form }
R := GetClientRect;
{ Converte as coordenadas do form em coordenadas da tela }
R.TopLeft := ClientToScreen(R.TopLeft);
R.BottomRight := ClientToScreen(R.BottomRight);
{ Limita a região de movimentação do mouse }
ClipCursor(@R);
ShowMessage('Tente mover o mouse para fora da área cliente do Form');
{ Libera a movimentação }
ClipCursor(nil);
end;

{Funcionamento:
Ao clicar no form aparecerá a mensagem, tente movimentar o mouse para fora da área cliente do form aberto.Esta operação não será permitida até que o usuário clique em OK na caixa de dialogo aberta.}

Número de cópias para a impressão

Procedure AjustaPapel(Copias:Integer);
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.PrinterIndex := Printer.PrinterIndex;
Printer.GetPrinter(Device, Driver, Port, hDMode);
if hDMode <> 0 then
begin
pDMode := GlobalLock(hDMode);
if pDMode <> nil then
begin
pDMode^.dmFields := pDMode^.dmFields or DM_COPIES;
pDMode^.dmCopies := Copias;
GlobalUnlock(hDMode);
end;
GlobalFree(hDMode);
end;
Printer.PrinterIndex := Printer.PrinterIndex;
end;

Como criar um efeito degradê em um canvas

{Esta dica mostra como criar um efeito degradê em um Canvas qualquer.
Neste caso, estamos utilizando um componente TPaintBox e o evento OnPaint. Dependendo da utilização deste recurso, esta rotina pode ser adaptada para funcionar em um outro componente.}

procedure TForm1.PaintBox1Paint(Sender: TObject);
const
clStart: TColor = clRed;
clEnd: TColor = clBlack;
var
ACanvas: TCanvas;
ARect: TRect;
i : Integer;
rc, gc, bc, h: Integer;
begin

ACanvas := PaintBox1.Canvas;
ARect := PaintBox1.ClientRect;

h := ARect.Bottom - ARect.Top;

{ desenha o degradê }
for i := 0 to (ARect.Bottom - ARect.Top) do
begin
rc := GetRValue(clStart);
gc := GetGValue(clStart);
bc := GetBValue(clStart);
rc := rc + (((GetRValue(clEnd) - rc) * (ARect.Top + i)) div h);
gc := gc + (((GetGValue(clEnd) - gc) * (ARect.Top + i)) div h);
bc := bc + (((GetBValue(clEnd) - bc) * (ARect.Top + i)) div h);
ACanvas.Brush.Style := bsSolid;
ACanvas.Brush.Color := RGB(rc, gc, bc);
ACanvas.FillRect(Rect(ARect.Left, ARect.Top + i, ARect.Right, ARect.Top + i + 1));
end;

end;

Funcao para calculo de digito verificador de cpf

Function DVCPF (CPF : string) : boolean; stdcall; export;

const
SEQUEICIA1 : array[1..9] of byte = (10,9,8,7,6,5,4,3,2);
SEQUEICIA2 : array[1..9] of byte = (11,10,9,8,7,6,5,4,3);
var
SOMA1,SOMA2,N,I,DV1,DV2 : integer;
DVSOMADO1,DVSOMADO2,digcpf : string;

begin
Result := False;
SOMA1:=0; SOMA2:=0;
for I:=1 to 9 do
begin
N:= StrToInt(CPF[I]);
SOMA1:=SOMA1 + N*SEQUEICIA1[I];
SOMA2:=SOMA2 + N*SEQUEICIA2[I];
end;
if (SOMA1 MOD 11) <= 1 then DV1:=0 else DV1:= 11 - (SOMA1 MOD 11);
SOMA2:=SOMA2+DV1*2;
if (SOMA2 MOD 11) <= 1 then DV2:=0 else DV2:= 11 - (SOMA2 MOD 11);
str(DV1,DVSOMADO1); str(DV2,DVSOMADO2);
digcpf := DVSOMADO1+DVSOMADO2;
if copy(CPF,10,2) = digcpf THEN
result := true;



end;

Função de verificação de cpf e cnpf

// Essa função testa a validade tanto de CPFs quanto de CNPJs
// Para tanto basta informar o mesmo que a função identificará
// a verificação apropriada a ser feita
// A pontuação do CPF ou CNPJ não é necessária mas pode ser incluída a string sem maiores problemas

Function ValidaCPFCNPJ(CPFCNPJ: string): boolean;
var
count, tam, i, soma: integer;
num: array of integer;
begin
Result:=False;
tam:=0;
SetLength(num,tam);
for i:=1 to Length(CPFCNPJ) do
if CPFCNPJ[i] in ['0'..'9'] then
begin
inc(tam);
SetLength(num,tam);
Val(CPFCNPJ[i],num[tam-1],soma);
end;

if not(tam in [11,14]) then Exit;

count:=2;
soma:=0;
for i:=Length(num)-3 downto 0 do
begin
soma:=soma+(num[i]*count);
inc(count);
if (tam = 14) and (count > 9) then count:=2;
end;
soma:=11-(soma mod 11);
if soma > 9 then soma:=0;

if not(num[tam-2]=soma) then Exit;

soma:=soma*2;
count:=3;
for i:=Length(num)-3 downto 0 do
begin
soma:=soma+(num[i]*count);
inc(count);
if (tam = 14) and (count > 9) then count:=2;
end;
soma:=11-(soma mod 11);
if soma > 9 then soma:=0;

if not(num[tam-1]=soma) then Exit;

Result:=True;
end;

// Exemplo de utilização:
if ValidaCPFCNPJ('041.935.186-80') then
ShowMessage('CPF válido')
else
ShowMessage('CPF inválido');

if ValidaCPFCNPJ('11.222.333/0001-81') then
ShowMessage('CNPJ válido')
else
ShowMessage('CNPJ inválido');

// Revisado por Diego de Queiroz Macedo

Gravando uma string em um .exe

{Serão usados os objetos TStream do Delphi para gravar e ler uma string qualquer em um Executável.

Neste exemplo utilizamos 2 TButtons e um componente TMemo.}

implementation

{$R *.DFM}

{ Função que faz a gravação no executável }
function AttachToFile(const AFileName: String; MemoryStream: TMemoryStream): Boolean;
var
aStream: TFileStream;
iSize: Integer;
begin
Result := False;
if not FileExists(AFileName) then
Exit;
try
aStream := TFileStream.Create(AFileName, fmOpenWrite or fmShareDenyWrite);
MemoryStream.Seek(0, soFromBeginning);
// posiciona no final do arquivo.
aStream.Seek(0, soFromEnd);
// copia os dados para um Stream de memória.
aStream.CopyFrom(MemoryStream, 0);
// salva o “Stream-Size”
iSize := MemoryStream.Size + SizeOf(Integer);
aStream.Write(iSize, SizeOf(iSize));
finally
aStream.Free;
end;
Result := True;
end;

{ Lê a string do executável }
function LoadFromFile(const AFileName: String; MemoryStream: TMemoryStream): Boolean;
var
aStream: TFileStream;
iSize: Integer;
begin
Result := False;
if not FileExists(AFileName) then
Exit;
try
aStream := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite);
// posiciona para leitura da String recém gravada.
aStream.Seek( - SizeOf(Integer), soFromEnd);
aStream.Read(iSize, SizeOf(iSize));
if iSize > aStream.Size then
begin
aStream.Free;
Exit;
end;
// Carrega em um Stream de memória.
aStream.Seek( - iSize, soFromEnd);
MemoryStream.SetSize(iSize - SizeOf(Integer));
MemoryStream.CopyFrom(aStream, iSize - SizeOf(iSize));
MemoryStream.Seek(0, soFromBeginning);
finally
aStream.Free;
end;
Result := True;
end;

{ Salva a string no executável }
procedure TForm1.btnSalvaClick(Sender: TObject);
var
aStream: TMemoryStream;
begin
aStream := TMemoryStream.Create;
Memo1.Lines.SaveToStream(aStream);
AttachToFile(‘Test.exe’, aStream);
aStream.Free;
Memo1.Clear;
end;

{ Carrega a string gravada no executável }
procedure TForm1.btnLerClick(Sender: TObject);
var
aStream: TMemoryStream;
begin
aStream := TMemoryStream.Create;
LoadFromFile(‘Test.exe’, aStream);
Memo1.Lines.LoadFromStream(aStream);
aStream.Free;
end;

end.

Endereço de e-mail / url na aplicação.

{Estes examplos utilizam uma API do Windows muito popular, a shellexecute, por isso não se esqueça de colocar a ShellApi unit no uses clause da sua unit.
URL(endereço da internet)}
procedure TForm1.Label1Click(Sender: TObject);
begin
ShellExecute(Handle,'open','http://www.bytesul.com.br',nil,nil,SW_SHOW);
end;
// e-mail
procedure TForm1.Label2Click(Sender: TObject);
begin
ShellExecute(Handle,'open','mailto:melo@bytesul.com.br',nil,nil,SW_SHOW);
end;

Formatar disquete

{implementation section}
....
const SHFMT_ID_DEFAULT = $FFFF;
// Formating options
SHFMT_OPT_QUICKFORMAT = $0000;
SHFMT_OPT_FULL = $0001;
SHFMT_OPT_SYSONLY = $0002;
// Error codes
SHFMT_ERROR = $FFFFFFFF;
SHFMT_CANCEL = $FFFFFFFE;
SHFMT_NOFORMAT = $FFFFFFFD;
function SHFormatDrive(Handle: HWND; Drive, ID, Options: Word): LongInt; stdcall; external 'shell32.dll' name 'SHFormatDrive'
procedure TForm1.btnFormatDiskClick(Sender: TObject);
var
retCode: LongInt;
begin
retCode:= SHFormatDrive(Handle, 0, SHFMT_ID_DEFAULT, SHFMT_OPT_QUICKFORMAT);
if retCode < 0 then ShowMessage('Could not format drive');
end;

Imprimir o texto direto na porta da impressora

//Use o procedimento abaixo:

procedure Imprime;
varOutFile: TextFile;beginAssignFile(Outfile, 'LPT1'); // ou LPT2 ou LPT3
Rewrite(OutFile);
Writeln(OutFile, 'Esta é a primeira linha');
Writeln(OutFile, 'Esta é a segunda linha');
Closefile(OutFile);
end;

Verificar se um ano é bissexto

//Verifica se um ano é bissexto, retornando True em caso positivo.

function AnoBis(Data: TDateTime): Boolean;varDia,Mes,Ano : Word;beginDecodeDate(Data,Ano,Mes,Dia);if Ano mod 4 <> 0 thenbeginAnoBis:= False;endelse if Ano mod 100 <> 0 thenbeginAnoBis:= True;endelse if Ano mod 400 <> 0 thenbeginAnoBis:= False;endelsebeginAnoBis:= True;end;end;

Colocar icones no taskbar(ao lado do relógio)

{Acrescente a unit ShellApi à cláusula Uses. Declare TaskIcon:
TNotifyIconData; na seção var.· Adicionar o icone:}

Begin
with TaskIcon do beginWnd:= Form1.Handle;uID:= 1;uFlags:= NIF_ICON or NIF_TIP;hIcon:= Form1.Icon.Handle;szTip:= 'Form1.Caption';cbSize:= SizeOf(TaskIcon);end;Shell_NotifyIcon(NIM_ADD, @TaskIcon);end; · Modificar o Icone:BeginTaskIcon.hIcon:= Image1.Picture.Icon.Handle;Shell_NotifyIcon(NIM_MODIFY, @TaskIcon);end; · Remover o Icone do TaskBar:BeginShell_NotifyIcon(NIM_DELETE, @TaskIcon);
end;

Aquardar um determinado nº de segundos

Procedure Delay(Segundos: Word);

var x1: Double;

beginx1:= Now;repeat{Comando vazio}until ((Now-x1)*86400) > Segundos;

end;

Imprimindo com precisão milimétrica:

{O objeto Canvas que está na classe Printer é uma ferramenta que ajuda muito a imprimir qualquer tipo de dado, seja ele texto ou gráfico. O problema é que a largura e a altura são determinadas em pixels, e esses valores variam de acordo com a resolução da impressora. Para converter de milímetros para pixels, use as funções abaixo, sendo que MMtoPixelX é para a resolução horizontal e MMtoPixelY é para a resolução vertical(porque na impressora é possível uma resolução de 1440x720 dpi - 1440 dpi para a horizontal e 720 dpi para a vertical).}

function MMtoPixelX(MM: Integer): LongInt; //Resolução horizontal
var
mmPointX: Real;
PageSize, OffSetUL: TPoint;
begin
mmPointX:= Printer.PageWidth / GetDeviceCaps(Printer.Handle, HORZSIZE);
Escape(Printer.Handle, GETPRINTINGOFFSET, 0, nil, @OffSetUL);
Escape(Printer.Handle, GETPHYSPAGESIZE, 0, nil, @PageSize);
if MM > 0
then Result:= Round((MM * mmPointX) - OffSetUL.X);
else Result:= Round(MM * mmPointX);
end;

function MMtoPixelY(MM: Integer): LongInt; //Resolução vertical
var
mmPointY: Real;
PageSize, OffSetUL: TPoint;
begin
mmPointY:= Printer.PageHeight / GetDeviceCaps(Printer.Handle, VERTSIZE);
Escape(Printer.Handle, GETPRINTINGOFFSET, 0, nil, @OffSetUL);
Escape(Printer.Handle, GETPHYSPAGESIZE, 0, nil, @PageSize);
if MM > 0
then Result:= Round((MM * mmPointY) - OffSetUL.Y);
else Result:= Round(MM * mmPointY);
end;

Usando a classe tstream

{Usando a classe TStream:
A classe TStream é uma base para componentes que trabalham com dados acumulados em forma de bytes.
Como a classe TStream é uma base ela não pode ser utilizada diretamente, será necessário usar uma classe descendente como TFileStream ou TMemoryStream, existem outras mas nós vamos falar somente destas.
Como ler dados usando o TStream:
Para ter acesso aos dados de um TStream em primeiro lugar deve ser verificada a propriedade Size para saber se o stream não está vazio ou seja, maior que zero.
Outra coisa que deve ser verificada é a propriedade position para saber posição do stream. Por exemplo: Se o tamanho (Size) do stream é 5 bytes e a posição (position) é 3, só será possível ler os últimos 2 bytes.
Para ler os bytes use a função Read, esta função retorna o número de bytes que foram lidos. ?
}
var
MeuByte: byte;
begin
Stream1.Position:= 0;
if Stream1.Size > 0 then Stream1.Read(MeuByte,SizeOf(MeuByte));
end;
{Veja que neste exemplo foi declarado a variável MeuByte do tipo byte para servir de reservatório, a posição foi movida para zero e foi verificado o tamanho do stream e a função Read pegou 1 byte do stream copiou para a variável MeuByte alem disso a função Read também mudou a posição para 1 e retornou o numero 1 que indica que foi copiado 1 byte.
A variável MeuByte deve conter o valor do primeiro byte do stream que será um número entre 0 e 255.
Note que usamos a função SizeOf para saber o tamanho da variável MeuByte mas nós poderíamos ter colocado 1 no lugar de SizeOf porque variáveis do tipo byte tem o tamanho de 1 byte.
Como gravar dados no TStream:
Para gravar dados nós utilizamos a função Write, deve-se levar em consideração a propriedade Position para saber onde serão gravados os dados, se a posição for 0 a função Write vai sobrepor os dados do stream, se a posição for igual ao tamanho do stream (Position = Size) a função vai adicionar os novos dados aos já existentes e aumentar o tamanho do stream. }
var
MeuByte: byte;
begin
MeuByte:= 23;
Stream1.Write(MeuByte,SizeOf(MeuByte));
end;
{No exemplo acima nós mudamos o valor da variável MeuByte para 23 e a função Write gravou o número 23 no stream ocupando 1 byte de espaço na memória e também somou 1 a posição atual.
Copiando dados de um stream para outro:
A classe TStream tem uma função chamada CopyFrom que serve para copiar um determinado número de bytes de outro stream. }
begin
Stream2.Position:= 25;
Stream1.CopyFrom(Stream2,250);
end;
{A função CopyFrom pegou 250 bytes a partir da posição 25 do Stream2 e copiou para o Stream1.
Neste exemplo nós não verificamos se o Stream2 tem 275 bytes de tamanho para que fossem copiados os 250 bytes, se o Stream2 tiver menos de 275 byte a função CopyFrom vai copiar todos os bytes que puder e retornar o número de bytes que foram copiados, isto também vale para função Read.
Usando a função Seek:
Até agora nós usamos a propriedade Position para mudar a posição do stream mas também podemos utilizar a função Seek que tem algumas opções que facilitam nossa programação.
function Seek(Offset: Longint; Origin: Word): Longint;
A função Seek tem dois parâmetros:
Offset - Indica o número de bytes vamos mover a posição.
Origin - Especifica a partir de onde deve ser movido. Podem ser usadas uma das três opções abaixo:
soFromBeginning: indica que a posição deve ser movida a partir do inicio ou seja, da posição zero.
soFromCurrent:: indica que deve movido a partir da posição atual. (Position + Offset)
soFromEnd: indica que deve ser movido a partir do fim. Então o valor do Offset deverá ser negativo para não haver erro. }
begin
Stream1.Seek(-25,soFromEnd);
end;
{Neste exemplo nós voltamos 25 bytes na posição a partir do fim, se o tamanho do Stream1 for de 100 bytes a posição atual será 75.
Usando o TFileStream:
O TFileStream é o descendente do TStream usado para manipular arquivos.
O método Create é um pouco diferente dos outros.
constructor Create(const FileName: string; Mode: Word);
Para criar um TFileStream devemos informar o nome do arquivo desde a letra da unidade de disco incluindo pastas e sub-pastas até a extensão mesmo que este arquivo não exista.
O parâmetro Mode vai definir como será usado o arquivo, podemos usar as seguintes opções:
fmCreate: para criar um novo arquivo.
fmOpenRead: para abrir e apenas ler os dados do arquivo
fmOpenWrite: para abrir e apenas gravar dados no arquivo, isto faz com que os dados atuais do arquivo sejam completamente apagados.
fmOpenReadWrite: para abrir, ler e gravar dados no arquivo.
Exemplo geral para abrir e ler um arquivo: }
var
Arquivo: TFileStream;
Texto: array[0..19]of Char;
begin
Arquivo:= TFileStream.Create('c:Autoexec.bat',fmOpenRead);
Arquvo.Read(Texto, SizeOf(Texto));
Arquivo.Free;
end;
{Neste exemplo nós abrimos o Autoexec.bat e copiamos os 20 primeiros caracteres para a variável Texto.
O TMemoryStream:
O MemoryStream é usado para manipular dados na memória, a diferença mais importante é a alta velocidade no acesso aos dados e o MemoryStream também tem a capacidade de abrir e salvar arquivos através das funções LoadFromFile e SaveToFile.
Acho que já deu para ter uma idéia de como funciona um TStream, o que está aqui é só uma pequena parte, consulte a ajuda do Delphi e veja outros componentes descendentes do TStream tenho certeza que será de grande ajuda em seus futuros projetos.
Inserindo arquivos dentro do aplicativo:
Provavelmente você já deve conhecer os arquivos de recursos(.res) que são usados por seu aplicativo para acessar bitmaps, ícones e cursores e que podem ser criados pelo Image Editor do próprio Delphi.
Mas estes arquivos não servem apenas para isso você pode inserir outros arquivos como os de som Mp3, Wave, Midi e qualquer outro formato e também é possível por qualquer outro arquivo até mesmo outro Aplicativo.
Como inserir os arquivos?
1. Crie uma pasta no seu HD com um nome amigável. Por exemplo 'C:MP3 Res'.
2. Copie todos os arquivos que deseja inserir em seu arquivo de recursos.
3. Crie um arquivo de texto(.txt) nessa pasta. Exemplo 'Mp3Res.txt'.
4. Neste arquivo de texto digite um nome que será usado como referência para o arquivo, dê um espaço e digite a classificação de tipo do arquivo por exemplo(WAVFILE para Arquivos de som Wave), dê outro espaço e digite o nome real do arquivo com a exetensão, para outro arquivo digite na linha seguinte.
Exemplo geral( SOM_ROCK MP3FILE ROCK.MP3 ).
5. Compile o arquivo de texto usando o Brcc32.exe(no diretório DelphiBin) por linha de comando. Exemplo: Brcc32.exe C:MP3 ResMp3Res.txt.
6. O Brcc32 vai gerar um arquivo de recursos com o mesmo nome do arquivo de texto. Exemplo 'Mp3Res.RES'.
7. Copie este arquivo para a pasta onde está o projeto.
8. Agora no Delphi abra o projeto que você deseja inserir o arquivo de recursos, click no menu Projects | View Source e digite {$R Mp3Res.RES}
{9. Pronto agora é só Compilar o projeto e os arquivos vão estar dentro do aplicativo.
DICA: No tópico 5 você pode criar na pasta um atalho para o Brcc32, depois dê um clique com o botão esquerdo do mouse sobre o arquivo de atalho e clique em 'Propriedades', no campo objeto depois do "C:...DelphiBinbrcc32.exe" dê um espaço e digite entre aspas duplas o nome do arquivo de texto que você criou com o caminho completo. Exemplo: "C:MP3 ResMp3Res.txt".
Pronto para compilar o arquivo dê um clique duplo no atalho.
OBS.: Se for colocar muitos arquivos como em programas de instalação é recomendável compactar os arquivos antes de criar o arquivo de recursos.
Como usar os arquivos?
Abaixo está o procedimento que vamos usar para extrair o Rock.mp3 e grava-lo no disco.}
procedure ExtraiArq;
var
Arq: TResourceStream;
begin
Arq:= TResourceStream.Create(HInstance, 'SOM_ROCK', 'MP3FILE');
try
Arq.SaveToFile('Rock.mp3');
finally
Arq.Free;
end;
end;
{OBS.: Se os arquivos estiverem compactados inclua o algoritmo de descompactação antes de salvar o arquivo.}

Configuração de vídeo

{A aplicação abaixo permite que você modifique as configurações de vídeo:

inicie uma nova aplicação;
insira um componente TListBox;
insira dois componentes TButton;
insira o seguinte código no evento OnCreate do formulário: }

procedure TForm1.FormCreate(Sender: TObject);
Var
i : Integer;
Conf : TDevMode;
begin
i := 0;
While EnumDisplaySettings(Nil,i,Conf) Do
Begin
With Conf Do
ListBox1.Items.Add(Format('%dx%d %d Cores',[dmPelsWidth,dmPelsHeight,1 Shl dmBitsperPel]));
Inc(i);
End;
end;
insira o seguinte código no evento OnClick do componente TListBox:

procedure TForm1.ListBox1Click(Sender: TObject);
begin
Button1.Enabled := Listbox1.ItemIndex >= 0;
end;
insira o seguinte código no evento OnClick do botão Alterar:

procedure TForm1.Button1Click(Sender: TObject);
Var
Conf : TDevMode;
begin
If MessageDlg('Deseja realmente alterar as configurações ?', mtConfirmation, [mbYes, mbNo], 0) = mrYes Then
Begin
EnumDisplaySettings(Nil,Listbox1.ItemIndex,Conf);
ChangeDisplaySettings(Conf,0);
End;
end;
insira o seguinte código no evento OnClick do botão Fechar:
procedure TForm1.Button2Click(Sender: TObject);
begin
Application.Terminate;
end;
Código Completo
unit Unit1;

interface

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

type
TForm1 = class(TForm)
ListBox1: TListBox;
Button1: TButton;
Button2: TButton;
procedure FormCreate(Sender: TObject);
procedure ListBox1Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
Var
i : Integer;
Conf : TDevMode;
begin
i := 0;
While EnumDisplaySettings(Nil,i,Conf) Do
Begin
With Conf Do
ListBox1.Items.Add(Format('%dx%d %d Cores',[dmPelsWidth,dmPelsHeight,1 Shl dmBitsperPel]));
Inc(i);
End;
end;

procedure TForm1.Button1Click(Sender: TObject);
Var
Conf : TDevMode;
begin
If MessageDlg('Deseja realmente alterar as configurações ?', mtConfirmation, [mbYes, mbNo], 0) = mrYes Then
Begin
EnumDisplaySettings(Nil,Listbox1.ItemIndex,Conf);
ChangeDisplaySettings(Conf,0);
End;
end;

procedure TForm1.ListBox1Click(Sender: TObject);
begin
Button1.Enabled := Listbox1.ItemIndex >= 0;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
Application.Terminate;
end;

end.

Tirar um form da memória

{A melhor maneira de liberar um form da memoria

Quando você usa Form.Free ou Form.Destroy, você está imediatamento solicitando a
destruição do formulário. Com Form.Release, todas as mensagens pendentes no pool do
formulário são postadas - exemplo: redesenho do formulário, movimento do mouse, pressionamento de tecla,...

use assim:}


FormXX := TFormXX.create ( application );
try
FormXX.ShowModal
finally
FormXX.Release;
FormXX := nil;
end;

Recuperar a velocidade da cpu

Const
ID_BIT=$200000; // EFLAGS ID bit

function GetCPUSpeed: Double;
const
DelayTime = 500;
var
TimerHi, TimerLo: DWORD;
PriorityClass, Priority: Integer;
begin
try
PriorityClass := GetPriorityClass(GetCurrentProcess);
Priority := GetThreadPriority(GetCurrentThread);

SetPriorityClass(GetCurrentProcess, REALTIME_PRIORITY_CLASS);
SetThreadPriority(GetCurrentThread,THREAD_PRIORITY_TIME_CRITICAL);

Sleep(10);
asm
dw 310Fh // rdtsc
mov TimerLo, eax
mov TimerHi, edx
end;
Sleep(DelayTime);
asm
dw 310Fh // rdtsc
sub eax, TimerLo
sbb edx, TimerHi
mov TimerLo, eax
mov TimerHi, edx
end;

SetThreadPriority(GetCurrentThread, Priority);
SetPriorityClass(GetCurrentProcess, PriorityClass);

Result := TimerLo / (1000.0 * DelayTime);
except end;
end;
No evento OnClick, basta atribuir a saída da função a uma string:

procedure TForm1.Button1Click(Sender: TObject);
var cpuspeed:string;
begin
cpuspeed:=Format('%f MHz', [GetCPUSpeed]);
edit1.text := cpuspeed;
end;

Como retornar quantidade de dias meses e anos entre duas datas

Ola

Hoje de manhã procurei uma função no Delphi que fizesse o que eu queria e não achei nada , ai fui obrigado a fazer . Bom, pode ser util pra mais gente . Esta procedure retorna a diferença entre 2 datas em dias, meses e anos .


Procedure EntreDatas(DataFinal,DataInicial : TDate ; var Anos,Meses,Dias : Integer) ;
//
// Retorna a diferença em Dias,Meses e Anos entre 2 datas
//
Function Calcula(Periodo : Integer) : Integer ;
var
intCont : Integer ;
begin
intCont := 0 ;
Repeat
Inc(intCont) ;
DataFinal := IncMonth(DataFinal,Periodo * -1) ;
Until DataFinal < DataInicial ;
DataFinal := IncMonth(DataFinal,Periodo) ;
Inc(intCont,-1) ;
Result := intCont ;
End ;
begin
if DataFinal <= DataInicial then
begin
Anos := 0 ;
Meses := 0 ;
Dias := 0 ;
exit ;
end;
Anos := Calcula(12) ;
Meses := Calcula(1) ;
Dias := Round(DataFinal - DataInicial) ;
end;

Retorna o tamanho de um campo memo

Function GetMemoSize(TheMemo: TObject): integer;
var i: integer;
begin
result := 0;
with (TheMemo as TMemo).lines do
begin
for i := count - 1 downto 0 do
begin
result := result + length(strings[i]);
end;
end;
end;

//By Nativo_Gyn

Testa se uma linha de texto está vazia ou não

Function LineIsEmpty(Text:string):boolean;
// Testa se uma linha de texto está vazia ou não
var
i:byte;
begin
for i:=1 to length(Text) do
begin
if Text[i]<>' ' then
begin
result := False;
exit;
end;
end;
Result := True;
end;

//By Nativo_Gyn

Testa se é número

Function IsInteger(TestaString: String) : boolean;
begin
try
StrToInt(TestaString);
except
On EConvertError do
result := False;
else
result := True;
end;
end;

Adicionar o evento onclick do dbgrid

Private
procedure DBGridClick(Sender: TObject);
implementation
{$R *.DFM}
procedure TForm1.DBGridClick(Sender: TObject);
begin
ShowMessage('Clicou no DBGrid.');
end;
//Coloque as instruções abaixo no evento OnCreate do Form:
procedure TForm1.FormCreate(Sender: TObject);
begin
DBGrid1.ControlStyle :=
DBGrid1.ControlStyle + [csClickEvents];
TForm(DBGrid1).OnClick := DBGridClick;
end;
//Observações:
{O segredo principal desta dica está OnCreate do Form. A primeira instrução ativa o evento OnClick. A segunda instrução acessa o manipulador do evento OnClick. Para isto precisamos tratar o DBGrid como se fosse Form, pois o evento OnClick está declarado como protegido (protected) na classe TDBGrid.
}
//By Nativo_Gyn

Demonstração dos eventos ongeteditmask, ongetedittext e onsetedittext do tstringgrid

Demonstração dos eventos OnGetEditMask, OnGetEditText e OnSetEditText do TStringGrid


//Os eventos OnGetEditMask, OnGetEditText e OnSetEditText ocorrem quando entramos no modo de edição.
procedure TForm1.StringGrid1GetEditMask(Sender: TObject; ACol,
ARow: Integer; var Value: String);
begin
if (ARow = 1) and (ACol = 1) then
Value := '(999) 999-9999;1;_'; // Telefone
end;


procedure TForm1.StringGrid1GetEditText(Sender: TObject; ACol,
ARow: Integer; var Value: String);
begin
if (ARow = 1) and (ACol = 2) then begin
if StringGrid1.Cells[ACol, ARow] = 'Ótimo' then
Value := '1'
else if StringGrid1.Cells[ACol, ARow] = 'Regular' then
Value := '2'
else if StringGrid1.Cells[ACol, ARow] = 'Ruim' then
Value := '3';
end;
end;


procedure TForm1.StringGrid1SetEditText(Sender: TObject; ACol,
ARow: Integer; const Value: String);
begin
if (ARow = 1) and (ACol = 2) then begin
if Value = '1' then
StringGrid1.Cells[ACol, ARow] := 'Ótimo'
else if Value = '2' then
StringGrid1.Cells[ACol, ARow] := 'Regular'
else if Value = '3' then
StringGrid1.Cells[ACol, ARow] := 'Ruim'
end;
end;


//By Nativo_Gyn

Para esconder um formulário filho quando minimizar e depois restaurá-lo

//Para esconder o Form Filho o comando é
ShowWindow( FormFilho.Handle, Sw_Hide )
//e para voltar ao normal é
ShowWindow( FormFilho.Handle, Sw_Normal )

//By Nativo_Gyn

Tenta executar um aplicativo, em caso negativo retorna o código de erro correspondente

Function RodaPrograma(PathFileName: String): Integer;
// Exemplo:
// procedure TForm1.Button1Click(Sender: TObject);
// var
// Result: Word;
// begin
// //Result := RunProgram('c:windowswrite.exe');
// Result := RunProgram('c:windowsdesktopwordpad.exe');
// if Result <> 0 then
// begin
// raise Exception.Create('Error ' + IntToStr(Result) + ' executing program');
// end;
// end;
var
Rslt: LongBool;
StartupInfo: TStartupInfo;
ProcessInfo: TProcessInformation;
begin
FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
with StartupInfo do
begin
cb := SizeOf(TStartupInfo);
dwFlags := STARTF_USESHOWWINDOW or STARTF_FORCEONFEEDBACK;
wShowWindow := SW_SHOWNORMAL;
end;
Rslt := CreateProcess(PChar(PathFileName), nil,
nil, nil, False,NORMAL_PRIORITY_CLASS,
nil, nil, StartupInfo, ProcessInfo);
if Rslt then
begin
with ProcessInfo do
begin
WaitForInputIdle(hProcess, INFINITE);
CloseHandle(hThread);
CloseHandle(hProcess);
Result := 0;
end;
end
else
begin
Result := GetLastError;
end;
end;


//By Nativo_Gyn

Executa um módulo do painel de controle

Function RunControlPanel(sAppletFileName : string) : integer;
// Ex: RunControlPanelApplet('Access.cpl');
begin
Result := WinExec(PChar('rundll32.exe shell32.dll,'+
'Control_RunDLL '+ sAppletFileName),SW_SHOWNORMAL);
end

//By Nativo_Gyn

Retorna o tipo de unidade referente a letra especificado

Function TipodeDrive(Unidade: String):String;
Var
StrDrive : String;
StrDriveType : String;
intDriveType : Integer;
begin
StrDrive := Unidade;
If StrDrive[Length(StrDrive)] <> '' Then
begin
StrDrive := StrDrive + ':';
end;
intDriveType := GetDriveType(PChar(StrDrive));
Case intDriveType Of
0 : StrDriveType := 'Unidade inválida ou não encontrada.';
1 : StrDriveType := 'Unidade não encontrada ou inválida.';
DRIVE_REMOVABLE : StrDriveType := 'Floppy Drive ou Disco Removivel.';
DRIVE_FIXED : StrDriveType := 'Disco Rígido.';
DRIVE_REMOTE : StrDriveType := 'Unidade de rede mapeada.';
DRIVE_CDROM : StrDriveType := 'Drive CD-ROM ou similar.';
DRIVE_RAMDISK : StrDriveType := 'Disco de RAM ou similar.';
end;
Result := StrDriveType;
end;

//By Nativo_Gyn

quarta-feira, 7 de outubro de 2009

Testa se existe uma placa de som no seu computador

Procedure TestaPlaca(Value:integer);
begin
som := '';
if WaveOutGetNumDevs > 0 then
begin
result := True
end
else
begin
Result := False;
end;
end;


//By Nativo_Gyn








p.891

Compartilhar tabelas paradox em rede

Procedure SuaTabelaAfterPost(DataSet: TDataSet);
begin
DbCommit(SuaTabela);
end;
procedure DbCommit( tabela: TTable );
begin
tabela.UpdateCursorPos;
case DbiSaveChanges( tabela.Handle ) of
DBIERR_INVALIDHNDL: raise Exception.Create('Tabela inválida.');
DBIERR_NODISKSPACE: raise Exception.Create('Não há espaço em disco.');
DBIERR_NOTSUPPORTED: raise Exception.Create('Função não suportada.');
end;
tabela.CursorPosChanged;
end;
Não se esqueça de incluir DbiProcs, DbiTypes na cláusula Uses...


By Nativo_Gyn

Captura a tela de erro de uma aplicação e envia por e-mail

{As vezes em nosso sistema ocorrem erros de diversos tipos: erros de programação, erros do banco de dados, erro do windows, erros de hardware que não suporta o sistema, etc. Isso as vezes faz com que os dados fiquem inconsistentes. Portanto a idéia foi desenvolver um procedimento que capture a tela onde ocorreu o erro, capture a mensagem de erro e envie por e-mail.}

procedure EnviaErroaoSuporte(Para, CC, Mensagem: String);
var
OutlookApp,
Mapi, Msg : Variant;
BitMap : TBitMap;
begin
OutlookApp := CreateOleObject('Outlook.Application');
try
Mapi := OutlookApp.GetNameSpace('MAPI');
Msg := Mapi.Application.CreateItem(0);
Msg.Subject := 'Erro no aplicativo '+UpperCase(Application.Title);
Msg.To := Para;
Msg.CC := CC;
Msg.Body := 'Ocorreu um erro na máquina : '+GetNetStation(1)+#13+
'Esta máquina encontra-se no grupo : '+GetNetStation(2)+#13+
'A mensagem de erro é : '+#13+Mensagem+#13+#13+
'A tela que o usuário utilizava antes do erro segue em anexo.'+#13;

// Captura e salva a tela atual antes do erro para anexá-la e enviar ao suporte.
BitMap := TBitmap.Create;
BitMap := CaptureScreenRect(Bounds(0,0,Screen.Width,Screen.Height));
BitMap.SaveToFile(ExtractFilePath(Application.ExeName)+'erro.bmp');
BitMap.Free;
Msg.Attachments.Add(ExtractFilePath(Application.ExeName)+'erro.bmp');

// Envia o email.
Msg.Send;
finally
OutlookApp := Unassigned;
end;
end;

//Aqui vai um exemplo da utilização desse procedimento:

// Tenta executar um procedure no Banco SQL Server.
try
SPFechaNota.ExecProc;
except
on E: Exception do EnviaErroaoSuporte('nome@email.com.br', '', E.Message);
end;


{By
Nativo_Gyn
ufgnet@pop.com.br}

retorna a quantidade de dias uteis entre duas datas

Function DifDateUtil(dataini,datafin:string):integer;
var a,b,c:tdatetime;
ct,s:integer;
begin
if StrToDate(DataFin) < StrtoDate(DataIni) then
begin
Result := 0;
exit;
end;
ct := 0;
s := 1;
a := strtodate(dataFin);
b := strtodate(dataIni);
if a > b then
begin
c := a;
a := b;
b := c;
s := 1;
end;
a := a + 1;
while (dayofweek(a)<>2) and (a <= b) do
begin
if dayofweek(a) in [2..6] then
begin
inc(ct);
end;
a := a + 1;
end;
ct := ct + round((5*int((b-a)/7)));
a := a + (7*int((b-a)/7));
while a <= b do
begin
if dayofweek(a) in [2..6] then
begin
inc(ct);
end;
a := a + 1;
end;
if ct < 0 then
begin
ct := 0;
end;
result := s*ct;
end;

{By
Nativo_Gyn
ufgnet@pop.com.br}

Imprime o conteúdo de um trichedit

Procedure PrintRichEdit(const Caption: string;const RichEdt: TRichEdit);
// Requer a Printers e RichEdit declaradas na clausula uses da unit
var
Range: TFormatRange;
LastChar, MaxLen, LogX, LogY, OldMap: Integer;
begin
FillChar(Range, SizeOf(TFormatRange), 0);
with Printer, Range do
begin
BeginDoc;
hdc := Handle;
hdcTarget := hdc;
LogX := GetDeviceCaps(Handle, LOGPIXELSX);
LogY := GetDeviceCaps(Handle, LOGPIXELSY);
if IsRectEmpty(RichEdt.PageRect) then
begin
rc.right := PageWidth * 1440 div LogX;
rc.bottom := PageHeight * 1440 div LogY;
end
else
begin
rc.left := RichEdt.PageRect.Left * 1440 div LogX;
rc.top := RichEdt.PageRect.Top * 1440 div LogY;
rc.right := RichEdt.PageRect.Right * 1440 div LogX;
rc.bottom := RichEdt.PageRect.Bottom * 1440 div LogY;
end;
rcPage := rc;
Title := Caption;
LastChar := 0;
MaxLen := RichEdt.GetTextLen;
chrg.cpMax := -1;
OldMap := SetMapMode(hdc, MM_TEXT);
SendMessage(RichEdt.Handle, EM_FORMATRANGE, 0, 0);
try
repeat
chrg.cpMin := LastChar;
LastChar := SendMessage(RichEdt.Handle, EM_FORMATRANGE, 1,Longint(@Range));
if (LastChar < MaxLen) and (LastChar < -1) then
begin
NewPage;
end;
until (LastChar = MaxLen) or (LastChar = -1);
EndDoc;
finally
SendMessage(RichEdt.Handle, EM_FORMATRANGE, 0, 0);
SetMapMode(hdc, OldMap);
end;
end;
end;

By
Nativo_Gyn
ufgnet@pop.com.br

Envia o conteúdo de um listbox para a área de transferência

Procedure ListBoxToClipBoard(ListBox: TListBox; BufferSize : Integer; CopyAll : Boolean);
// Requer um listbox e a unit ClipBrd na clausula uses
// Use o Buffersize para mais de 30 (Recomendado)
//
var
Buffer : PChar;
Size : Integer;
Ptr : PChar;
I : Integer;
Line : String[255];
Count : Integer;
begin
if not Assigned(ListBox) then
Exit;
GetMem(Buffer, BufferSize);
Ptr := Buffer;
Count := 0;
for I := 0 to ListBox.Items.Count - 1 do
begin
Line := ListBox.Items.Strings[I];
if not CopyAll and ListBox.MultiSelect and (not ListBox.Selected[I]) then
Continue;
Count := Count + Length(Line) + 3;
if Count >= BufferSize then
Break;
Move(Line[1], Ptr^, Length(Line));
Ptr := Ptr + Length(Line);
Ptr[0] := #13;
Ptr[1] := #10;
Ptr := Ptr + 2;
end;
Ptr[0] := #0;
ClipBoard.SetTextBuf(Buffer);
FreeMem(Buffer, BufferSize);
end;

{By
Nativo_Gyn
ufgnet@pop.com.br`}

Verifica a existencia de um form

Function JaExiste(PForm: TForm): Boolean;
var
i : Integer;
begin
Result := False;
for i:= 0 to Screen.FormCount - 1 do
begin
if Screen.Forms[i] = PForm then
begin
Result := True;
Break;
end;
end;
end;

{By
Nativo_Gyn
ufgnet@pop.com.br}

Verifica a existencia de um form

Function JaExiste(PForm: TForm): Boolean;
var
i : Integer;
begin
Result := False;
for i:= 0 to Screen.FormCount - 1 do
begin
if Screen.Forms[i] = PForm then
begin
Result := True;
Break;
end;
end;
end;

{By
Nativo_Gyn
ufgnet@pop.com.br}

Um método bem simples de implementar uma ordenação de um listbox através

{Um método bem simples de implementar uma ordenação de um ListBox através de Drag-Drop, utilizando apenas os eventos oferecidos pelo próprio componente TListBox


Primeiro, certifique-se que a propriedade DragMode seja dmAutomatic.

No evento OnDragOver só devemos aceitar um item arrastado do próprio ListBox, ou seja, se o parâmetro Sender for igual ao Source. }

procedure TForm1.ListBox1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
Accept := (Sender = Source);
end;

{Já no evento OnDragDrop, utilizamos o método ItemAtPos para descobrir qual item está sob o cursor do mouse, e alteramos a ordem com o método Move. }

procedure TForm1.ListBox1DragDrop(Sender, Source: TObject; X, Y: Integer);
var
i: Integer;
begin
with TListBox(Sender) do
begin
if ItemIndex > -1 then
begin
i := ItemAtPos(Point(x,y),True);
Items.Move(ItemIndex, i);
ItemIndex := i;
end;
end;
end;

{By
Nativo_Gyn
ufgnet@pop.com.br}

Bloqueia uma tabela paradox

Procedure LockPDOXTable(TableName,Password : String);
// Requer a DBIProcs na clausula uses da unit
var
TblDesc: CRTblDesc;
LocDB : TDatabase;
begin
Check(DBIInit(nil));
Randomize;
LocDB := TDatabase.Create(nil);
with LocDB do begin
Params.Add('path=' + ExtractFilePath(TableName));
DatabaseName := 'PDOXEncryptDB' + IntToStr(Random(50));
DriverName := 'STANDARD';
Connected := True;
end;
FillChar(TblDesc, SizeOf(CRTblDesc), 0);
StrPCopy(TblDesc.szTblName, ExtractFileName(TableName));
with TblDesc do begin
bProtected := True;
StrPCopy(TblDesc.szPassword, Password);
end;
try
Check(DbiDoRestructure(LocDB.Handle, 1, @TblDesc,nil, nil, nil, False));
finally
LocDB.Free;
DBIExit;
end;
end;


{By
Nativo_Gyn
ufgnet@pop.com.br}

Recebe uma string de data, convertendo-a do formato origem para o formato destino

{Recebe uma string de data, convertendo-a do formato ORIGEM para o formato DESTINO}


function InverteStringData(sData, sFormatoOrigem, sFormatoDestino: String):String;
// Ex:
// InverteStringData(DateToStr(Date),'DD/MM/AAAA','AAAA/MM/DD')
var
sDia : String;
sMes : String;
sAno : String;
begin
if sFormatoOrigem = 'DD/MM/AAAA' then
begin
sDia := Copy(sData,1,2);
sMes := Copy(sData,4,2);
sAno := Copy(sData,7,4);
end
else
if sFormatoOrigem = 'MM/DD/AAAA' then
begin
sMes := Copy(sData,1,2);
sDia := Copy(sData,4,2);
sAno := Copy(sData,7,4);
end
else
if sFormatoOrigem = 'AAAA/MM/DD' then
begin
sAno := Copy(sData,1,4);
sMes := Copy(sData,6,2);
sDia := Copy(sData,9,2);
end
else
begin
MessageDlg('Formato original da data errado. A própria data do sistema foi retornada.',
mtError,[mbOk],0);
Result := DateToStr(Date);
Exit;
end;
if sFormatoDestino = 'DD/MM/AAAA' then
begin
Result := sDia + '/' + sMes + '/' + sAno;
end
else
if sFormatoDestino = 'MM/DD/AAAA' then
begin
Result := sMes + '/' + sDia + '/' + sAno;
end
else
if sFormatoDestino = 'AAAA/MM/DD' then
Result := sAno + '/' + sMes + '/' + sDia
else
begin
MessageDlg('Formato destino da data errado. A própria data do sistema foi retornada.',
mtError,[mbOk],0);
Result := DateToStr(Date);
Exit;
end;
end;


{By
Nativo_Gyn
ufgnet@pop.com.br}

Substitui, em uma cadeia de caracteres, todas as ocorrências de uma string por outra

//Substitui, em uma cadeia de caracteres, todas as ocorrências de uma string por outra

function Replace(aValue, aFind, aReplaceWith : String) : String;
// aValue: Cadeia de strings
// aFind: String a ser substituida
// aReplaceWith : String Substituta
var
LaFind,
X : Integer;
UaReplaceWith,
UaValue,
UaFind : String;
begin
UaValue := Uppercase(aValue);
UaFind := Uppercase(aFind);
UaReplaceWith := Uppercase(aReplaceWith);
LaFind := Length(aFind);
for X:= Length(aValue) downto 1 do
begin
if Copy(UaValue,X,LaFind) = UaFind then
begin
Delete(aValue,X,LaFind);
Insert(aReplaceWith,aValue,X);
Delete(UaValue,X,LaFind);
Insert(UaReplaceWith,UaValue,X);
end;
end;
Result := aValue;
end;


{By
Nativo_Gyn
ufgnet@pop.com.br}

Como uma aplicação pode enviar e mail

//Utiliza a função HLinkNavigateString que está declarada na Unit UrlMon, ex.:
HlinkNavigateString(nil,'mailto:alguem@algumlugar.com');

Como compactar e reparar um banco de dados utilizando delphi e dao

Como compactar e reparar um banco de dados utilizando Delphi e DAO


Seria muito interessante poder realizar estas rotinas automaticamente pelo seu próprio aplicativo. Veja um exemplo de como utilizar o DAO para compactar e reparar um arquivo MDB.

{******************************************}
// COMPACTANDO O BANCO DE DADOS
{******************************************}
var
dao: OLEVariant;
begin
dao := CreateOleObject('DAO.DBEngine.35');
dao.CompactDatabase('c:db1.mdb', 'c:dbnew.mdb');
end;

{******************************************}
// REPARANDO O BANCO DE DADOS
{******************************************}
var
dao: OLEVariant;
begin
dao := CreateOleObject('DAO.DBEngine.35');
dao.RepairDatabase('d:yourDatabaseName.mdb');
end;

Caso o seu banco de dados esteja protegido com senha, é preciso informar ao DAO a senha padrão.

dao.DefaultPassword := ....
dao.CompactDatabase(...)



By
Nativo_Gyn
ufgnet@pop.com.br

Como implementar a utilização das teclas ctrl-a para selecionar todo o texto de um com

Procedure TfrmShowPas.RichEdit1KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if (Shift = [ssCtrl]) then
case Key of
65: TRichEdit(Sender).SelectAll;
end;
end;


{By
Nativo_Gyn
ufgnet@pop.com.br}

Utilizando a função findwindow eremos remover o botão fechar da janela do bloco

{Utilizando a função FindWindow eremos remover o botão fechar da janela do Bloco de Notas }

procedure TForm1.Button1Click(Sender: TObject);
var
hwndHandle : THANDLE;
hMenuHandle : HMENU;
begin
hwndHandle := FindWindow(nil, 'Sem título - Bloco de notas');{Coloque aqui o caption da janela que vc quer retirar o botão}
if (hwndHandle <> 0) then begin
hMenuHandle := GetSystemMenu(hwndHandle, FALSE);
if (hMenuHandle <> 0) then
DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND);
end;
end;


{By
Nativo_Gyn
ufgnet@pop.com.br}



p.873

Após setar o comando post em tabelas paradox seus dados ainda estão vulneráveis

{Após setar o comando Post em tabelas Paradox seus dados ainda estão vulneráveis caso haja uma queda de energia ou falha no computador... eles serão perdidos!

Esta rotina resolve este problema!

Para que um registro seja inserido num banco de dados paradox basta chamar o comando:}

Table.post;

{Porém usuários mais experientes sabem que isso não é suficiente para q os dados sejam completamente gravados no banco de dados é necessário chamar o COMMIT que inclue uma rotina que funciona porém envolve muito trabalho.

Uma solução para este problema é usar a API dbiSaveChanges ou o dbiUseIdleTime da seguite maneira.:}

procedure TForm1.Table1AfterPost(DataSet: TDataSet);
begin
DbiSaveChanges(Table1.handle);
end;
Isto irá salvar os dados na table definitivamente ou usar o seguinte:
procedure TForm1.FormCreate(Sender: TObject);
begin
Application.onIdle := UseIdle;
end;
procedure Tform1.UseIdle(Sender: TObject; var Done: Boolean);
begin
DbiUseIdleTime;
end;
//Para que o todos os bancos sejam salvos no momento em que o aplicativo pare de processar mensagens!

{By
Nativo_Gyn
ufgnet@pop.com.br}

Rotinas úteis para calcular os feriados varíaveis de sábado de carnaval, sexta

{Rotinas úteis para calcular os feriados varíaveis de Sábado de Carnaval, Sexta Feira Santa, Páscoa e Corpus Christi


De acordo com a tabelinha abaixo podemos criar algumas funções úteis para cáculo de feriados
Sabado de Carnaval = Pascoa - 50 dias
Quarta de Cinzas = Pascoa - 46 dias
Sexta Feira Santa = Pascoa - 2 dias
Corpus Christi = Pascoa + 60 dias
Veja abaixo: }
type
TFeriados = (frPascoa, frCarnaval, frQuartaCinzas, frSextaSanta, frCorpusChristi);

{*******************************************}
// CALCULO DA PASCOA
{*******************************************}
function CalculaPascoa(AAno: Word): TDateTime;
var
R1, R2, R3, R4, R5 : Longint;
FPascoa : TDateTime;
VJ, VM, VD : Word;
begin
R1 := AAno mod 19;
R2 := AAno mod 4;
R3 := AAno mod 7;
R4 := (19 * R1 + 24) mod 30;
R5 := (6 * R4 + 4 * R3 + 2 * R2 + 5) mod 7;
FPascoa := EncodeDate(AAno, 3, 22);
FPascoa := FPascoa + R4 + R5;
DecodeDate(FPascoa, VJ, VM, VD);
case VD of
26 : FPascoa := EncodeDate(Aano, 4, 19);
25 : if R1 > 10 then
FPascoa := EncodeDate(AAno, 4, 18);
end;
Result:= FPascoa;
end;
{*******************************************}
// CALCULA FERIADO
{*******************************************}
function CalculaFeriado(AAno: Word; ATipo: TFeriados): TDateTime;
var
Aux: TDateTime;
begin
Aux := CalculaPascoa(AAno);
Case ATipo of
frCarnaval : Aux := Aux - 50;
frQuartaCinzas : Aux := Aux - 46;
frSextaSanta : Aux := Aux - 2;
frCorpusChristi: Aux := Aux + 60;
end;
Result := Aux;
end;

{By
Nativo_Gyn
ufgnet@pop.com.br}

Aceitar digitação de ponto em números, independente da conf. do windows

{Aceitar digitação de ponto em números, independente das configurações do Windows}


function StrToFloatF(e:String):Double;
var
p:Integer;
begin
while true do begin
p:=Pos(ThousandSeparator,e);
if p<=0 then
break
Else
Delete(e,p,1);
End;

result:=StrToFloat(e);
End;

aceitar digitação de ponto em números, independente das configurações

Aceitar digitação de ponto em números, independente das configurações do Windows


function StrToFloatF(e:String):Double;
var
p:Integer;
begin
while true do begin
p:=Pos(ThousandSeparator,e);
if p<=0 then
break
Else
Delete(e,p,1);
End;

result:=StrToFloat(e);
End;


By
Nativo_Gyn
ufgnet@pop.com.br

Dica para fazer a data e a hora aparecer da maneira escolhida independente das configuraçoti

Dica para fazer a data e a hora aparecer da maneira escolhida independente das configurações regionais


var
Ano,Mes,Dia:Word;
Hora,Min,Sec,MSec:Word;
begin

DecodeDate(Now,Ano,Mes,Dia);
DecodeTime(Now,Hora,Min,Sec,MSec);
ShortDateFormat := 'dd/mm/yyyy';
LongTimeFormat := 'hh:nn';
LongDayNames[1] := 'Domingo'; LongDayNames[2] := 'Segunda'; LongDayNames[3] := 'Terça';
LongDayNames[4] := 'Quarta'; LongDayNames[5] := 'Quinta'; LongDayNames[6] := 'Sexta';
LongDayNames[7] := 'Sábado';
Label1.Caption := FormatDateTime('"Hoje é" dddd, c',
StrToDateTime(IntToStr(Dia) + '/' + IntToStr(Mes) + '/' +
IntToStr(Ano) + ' ' + IntToStr(Hora) + ':' +
IntToStr(Min) + ':' + IntToStr(Sec)));
end;

Como configurar um banco de dados paradox em rede

Paradox em Rede

1) Todas as máquinas deverão ter o BDE instalado.

2) No servidor, configure o BDE da seguinte forma:

NET DIR - C: - Ou o drive onde o banco de dados está residindo. Este driver deverá ter
permissão para que todos possam escrevê-lo. Caso não tenha, coloque o NET DIR como C:BANCO_DE_DADOS
Onde BANCO_DE_DADOS é o diretório dos dados. Obviamente, este diretório será público para todos.

Obs: A propriedade Net Dir se encontra em Configuration, Drivers, Native, Paradox.

3) LOCAL SHARE - TRUE. A propriedade Local Share se encontra em Configuration, System, Init.

4) Nas máquinas clientes, configure o BDE da seguinte forma:

NET DIR - CAMINHO DO SERVIDOR, EQUIVALENTE AO NETDIR CONFIGURADO NO MESMO.

Ex: Se o Net Dir do servidor foi configurado como C:, o NET DIR da máquina cliente poderia ser
configurado como:

NOME_DO_SERVIDORC

Onde:

Nome_Do_Servidor - Nome da máquina servidor, na rede
C - Nome do compartilhamento para o drive C do servidor.

Se o Net Dir do servidor estivesse apontado para o diretório de banco de dados, o cliente poderia
estar configurado como:

NOME_DO_SERVIDORCDIRETORIO_DO_BANCO

Em Configuration, System, Init configure:

LOCAL SHARE - TRUE.

By
Alessandro Araujo
ufgnet@pop.com.br

Zerar campo auto incremento da tabela paradox

Function Zerar(Tabela: TFileName; num: Longint): Boolean;
begin
with TFileStream.Create(Tabela, fmOpenReadWrite) do
Result := (Seek($49, soFromBeginning) = $49) and (Write(num, 4) = 4);
end;


//Utilize a função assim:

if Zerar('c:diretoriotabela.db',0) then
Showmessage('campo autoincremento zerado')
else
Showmessage('nao foi possível zerar o campo autoincremento ')

Exponenciação em delphi

Function Exponenciacao(Base:double;Potencia:integer):double;
begin
Result := exp( ln(Base) * Potencia );
end;

Trabalhando com jpg em paradox

{Trabalhando com JPEG em paradox...

Declare uma procedure GRAVA assim:}

Procedure Grava(Tabela:TTable; Campo:TBlobField;Foto:TImage; Dialog:TOpenPictureDialog);
em uses digite JPG
Apos {$R *.DFM} digite

Procedure TFrmCadProdutos.Grava(Tabela:TTable; Campo:TBlobField;Foto:TImage; Dialog:TOpenPictureDialog);
var BS:TBlobStream;
MinhaImagem:TJPEGImage;
Begin
Dialog.InitialDir := 'c:JPGFotos_Jpeg';//pasta onde estão as fotos
Dialog.Execute;//componente opendialog
if Dialog.FileName <> '' Then
Begin
if not (Tabela.State in [dsEdit, dsInsert]) Then
Tabela.Edit;
BS := TBlobStream.Create((Campo as TBlobField), BMWRITE);
MinhaImagem := TJPEGImage.Create;
MinhaImagem.LoadFromFile(Dialog.FileName);
MinhaImagem.SaveToStream(BS);
Foto.Picture.Assign(MinhaImagem);
BS.Free;
MinhaImagem.Free;
Tabela.Post;
DBISaveChanges(Tabela.Handle);
End;
End;

//no evento onclick de um botão digite:
procedure TFrmCadProdutos.btImagemClick(Sender: TObject);
begin
Grava(tbProdutos,tbProdutosFoto,Image1,OpenDialog);
if not(tbProdutos.State in[dsEdit,dsInsert])then
begin
tbProdutos.edit;
tbProdutosCad.Value:='S';
tbProdutos.post;
end
else
begin
tbProdutosCad.Value:='S';
tbProdutos.post;
end;
end;

//meu e-mail: medeiros@pontenet.com.br

Nativo_ufgnet vunerabilidades no seu pc

{ Atualmente vários hacker usam falhas indiscretas, ou até mesmo fáceis de serem percebidas por usuários simples.
Tais ataques poderiam ser evitados, usando um Scaneador de Portas.
Como por exemplo o Programa "Languard Network Scanner" , com ele você poderá escanear seu próprio computador, ou seja, percebendo todas as falhas existente nele.
E tomar as atitudes certas para manter seu computador mais seguro.

By Nativo
Alessandro Araujo
Duvidas: ufgnet@pop.com.br}

Criando alias via programação

{Criando alias via programação

Se for para Paradox ...}

Session.AddStandardAlias('SeuAlias', edtPath.text, 'Paradox');
Session.SaveConfigFile;



//Desabilitar acesso a windows

Ai vai um codigo que peguei no site da Borland que trava as teclas
(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;

Verifica se o delphi esta aberto

{Verificando se o Delphi está aberto

Proteja aquele aplicativo ou objeto que vc desenvolveu com esta rotina que
identifica se o usuário está com o Delphi aberto (disponibiliza) ou fechado
(trava a execucao).
Bom proveito !}

Function TForm1.JanelaExiste(Classe,Janela:String) :Boolean;
var
PClasse,PJanela : array[0..79] of char;
begin
if Classe = '' then
PClasse[0] := #0
else
StrPCopy(PClasse,Classe);
if Janela = '' then
PJanela[0] := #0
else
StrPCopy(PJanela,Janela);
if FindWindow(PClasse,PJAnela) <> 0 then
result := true
else
Result := false;
end;

Function TForm1.DelphiCarregado : Boolean;
begin
Result := False;
if JanelaExiste('TPropertyInspector','Object Inspector') then
result := True
end;



procedure TForm1.FormCreate(Sender: TObject);
begin
if DelphiCarregado then
showmessage('Delphi está ativo, bom menino!')
else
begin
Showmessage('Vc não poderá utilizar esta aplicação! Mau garoto!');
application.terminate;
end;
end;

Protetor de tela com delphi

{Para fazer protetor de tela com o Delphi

Para o pessoal que queria saber...

A) No .Dpr ponha {$D SCRNSAVE } depois do uses

B) No Form principal nao ponha borda ou icone. No metodo Activate ponha left
e top como 0 e o Windowstate como wsMaximize.

C) no form.Create ponha application.OnMessage para um metodo que controle a
desativacao do screen saver. Ponha tb o application.OnIdle para "rodar" o
dito cujo...

D) Tb no Form.Create teste a linha de comando para /c ou /s. Estes
parametros dizem o que e' para fazer (/c configura)

E) Compile e renomeie o .exe p/ .scr, move para o diretorio do windows e...}

Criando arrays ramdomicos

Var
a: array[0..4] of integer;
i: Integer;
begin
for i:= 0 to 4 do
begin
a[i]:= random(99) + 1;
end;

end;

// obs: o 99 no random é o intervalo a ser sorteado .

Verificar se impressora esta conectada

{A dica abaixo apresenta o código para implementação de uma função para verificar se a impressora esta conectada.
Para implementar esta função é necessário que o código gerado manipule algumas interrupções da Bios (Sistema Básico de Entrada e Saída) responsáveis pelo controle da porta paralela (Interrupção $17).

A interrupção $17 utiliza dois registros ah e dx, o registrador ah indica neste caso o acesso a porta paralela e o registrador dx indica qual das portas será testada, 0 para LPT1 e 1 para LPT2.

Para saber se a porta esta ligada (impressora conectada) o resultado da operação de tratamento de interrupção deve ser $80. }

Function OnLine(Porta:Word):Boolean;
Const
Portas :Byte = $02;
Var
Res :Byte;
Begin
{ Código em Assembler }
Asm
mov ah,Portas; {Requisita o acesso as portas}
mov dx,Porta;{Define a porta de teste}
Int $17; {Chama a interrupção de Impressora}
mov Res,ah; {Guarda em Res o resultado da operação }
end;
Result := (Res and $80) = $80; {Testa o valor de saída}
End;

Colorindo um ttreeview

//Como alterar a cor dos ítens do componente TTreeview, através do evento onCustomDrawItem.

procedure TForm1.TVCustomDrawItem(Sender: TCustomTreeView; Node: TTreeNode; State: TCustomDrawState; var DefaultDraw: Boolean);
var
NodeRect: TRect;
begin
with TV.Canvas do
begin
NodeRect := Node.DisplayRect(True);
Font.Style := [fsBold];
Font.Color := clBlue;
Brush.Color := clAqua;
FillRect(NodeRect);
end;
end;

descobrindo url's visitadas

//Saiba todos os endereços da internet que você visitou:

uses Registry;

procedure ShowTypedUrls(Urls: TStrings);
var
Reg: TRegistry;
S: TStringList;
i: Integer;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CURRENT_USER;
if Reg.OpenKey('SoftwareMicrosoftInternet ExplorerTypedURLs', False) then
begin
S := TStringList.Create;
try
reg.GetValueNames(S);
for i := 0 to S.Count - 1 do
begin
Urls.Add(reg.ReadString(S.Strings[i]));
end;
finally
S.Free;
end;
Reg.CloseKey;
end;
finally
Reg.Free;
end;
end;


procedure TForm1.Button1Click(Sender: TObject);
begin
ShowTypedUrls(ListBox1.Items);
end;