quarta-feira, 30 de setembro de 2009

Fazer instalação do dbe na máquina cliente

{Descompacte o arquivo DBeInst.zip, dentro da pasta de seu projeto.

Abra o delphi, crie uma nova aplicação.

Na seção INTERFACE, coloque a seguinte linha de comando:}

function DllRegisterServer: Integer; stdcall; external 'BdeInst.dll';

//Na seção IMPLEMENTATION

procedure TForm1.Button1Click(Sender: TObject);
begin
DllRegisterServer;
end;

{OBS: Caso você não encontre o arquivo zipado na sua máquina, esse arquivo encontra-se no CD de instalação do Delphi.}






p.821

Executando um programa externo (linux)

Var
rc: Integer;
begin
rc:= Libc.system('kcalc');
if rc = -1 then begin
showmessage('erro ao execultar kcalc');
end;
end;

Fazer programa funcionar fora do kylix

{Fazer um programa feito em Kylix3 funcionar fora do mesmo:
1. Edite a biblioteca "/etc/ld.so.conf" e inclua a seguinte linha no final:

/pasta/kylix3/bin

2.faça o linux reiniciar *ou* execute o "ldconfig" para forçar a
releitura dos arquivos de sistema

3.digite a seguinte instrução:
source /pasta/kylix3/bin}

Fazer o kylix3 funcionar no redhat 9

//Faça o seguinte script na pasta do /kylix/bin:

export LD_ASSUME_KERNEL=2.2.5
./startdelphi

chame o script...

Fazer programa funcionar fora do kylix

{Fazer um programa feito em Kylix3 funcionar fora do mesmo:
1. Edite a biblioteca "/etc/ld.so.conf" e inclua a seguinte linha no final:

/pasta/kylix3/bin

2.faça o linux reiniciar *ou* execute o "ldconfig" para forçar a
releitura dos arquivos de sistema

3.digite a seguinte instrução:
source /pasta/kylix3/bin}

Mostrar todas as unidades mapeadas na máquina.

//1: Coloque um TListBox, TButton no form;
//2: Crie a seguinte procedure;

procedure TForm1.MapeamentosDisponiveis;
var
I : Integer;
Caminho, Drive : String;
Tamanho : Cardinal;
begin
SetLength(Caminho,255);
Tamanho:=255;
For I:=0 to 25 do
begin
Drive := Chr(Ord('A')+I)+':';
if WNetGetConnection(PChar(Drive),PChar(Caminho),Tamanho) = NO_ERROR then
ListBox1.Items.Add(LowerCase(Drive + ' - '+Caminho));
end;
end;

//2: Digite o código seguindo no evento OnClick do TButton;

Validando cep

Function ValidarCEP(const CEP: string): string;
var
I: integer;
begin
Result := '';
for I := 1 to Length(CEP) do
if CEP[I] in ['0'..'9'] then
Result := Result + CEP[I];
if Length(Result) <> 8 then
raise Exception.Create('CEP inválido.')
else
Result := Copy(Result, 1, 2) + '.' + Copy(Result, 3, 3) + '-' + Copy(Result, 6, 3);
end;

Transforma a imagem em negativo de fotografia

Procedure ColorToNegative(ABmp: TBitmap);
//
// Transforma a imagem em negativo de fotografia
//
// Use-o assim:
//
var x: TBitmap;
begin

x := TBitmap.create;
x.LoadFromFile('c:MVC-267S.bmp');
ColorToNegative(x);
image1.Picture.Assign(x);
end;
//
//
const
_high = 255;
var
c: TCursor;
x, y: Integer;
ColorRGB: LongInt;
begin
c := Screen.Cursor;
Screen.Cursor := crHourGlass;
for y := 0 to (ABmp.Height - 1) do
for x := 0 to (ABmp.Width - 1) do
begin
ColorRGB := ColorToRGB(ABmp.Canvas.Pixels[x, y]);
ABmp.Canvas.Pixels[x, y] := PaletteRGB(_high - GetRValue(ColorRGB),_high - GetGValue(ColorRGB), _high - GetBValue(ColorRGB));
end;
Screen.Cursor := c;
end;

Coloração gradiente no form

Procedure TForm1.FormPaint(Sender: TObject);
var
altura, coluna: Word;
begin
altura := (ClientHeight + 255) div 256;
for coluna := 0 to 255 do
with Canvas do
begin
Brush.Color := RGB(coluna, 0, 0); { Modifique para obter cores diferentes }
FillRect(Rect(0, coluna * altura, ClientWidth, (coluna + 1) * altura)) ;
end;
end;

procedure TForm1.FormResize(Sender: TObject);
begin
Invalidate;
end;

Como gerar numeros randomicos para loterias

{Crie um form com os seguintes objetos:
- Listbox1 com a fonte "Courier New"
- Edit1 com Edit1.Text := 6 Numero de Dezenas
- Edit2 with Edit2.Text := 49 Valor Maximo
- Edit3 with Edit3.Text := 10 Numero de Jogos
- Button1 com onClick com o evento Button1Click abaixo

Isto criará 10 serie de jogos
com os numeros entre 1 e 49
Numeros não serão repetidos
vc poderá mudar os tres valores }

procedure TForm1.Button1Click(Sender: TObject);
var
MyList: TStringList;
Times, I, Number: Integer;
cInt, cLen: string;
begin
// make the button disabled to prevent multiple clicks
Self.enabled := False;
// convert the highest number
Number := StrToInt(Edit2.Text);
// this creates the correct format-argument for every
// max-numbers (e.g. 49 , 120, 9999 ....)
cLen := IntToStr(length(trim(Edit2.text)) + 1);
MyList := TStringList.Create;
try
// first clear the Listbox
Listbox1.clear;
// here we start a new serie
for Times := 1 to StrToInt(Edit3.Text) do
begin
// we go thru this while-loop until the max-numbers
// are created. Not every loop creates an entry
// to the list because double numbers are ignored.
while MyList.Count < StrToInt(Edit1.Text) do
begin
// get a new random number
I := Random(Number);
if (I 0) then
begin
// cLen has the number of chars from max-number plus one
// e.g.
// if max-number is 49 cLen is 3
// if max-number is 111 cLen is 4
// if max-number is 9999 cLen is 5
// this formatting is needed for the correct
// sorting of all List-Entries
cInt := Format('%' + cLen + '.1d', [I]);
// here we look at double entries and ignore it
if (MyList.IndexOf(cInt) < -1) then
continue;
// now we add a new randomnumber
MyList.Add(cInt);
end;
end;
cInt := '';
// max-numbers are created now we sort it
MyList.Sort;
// and put it all into Listbox
for I := 0 to MyList.Count - 1 do
cInt := cInt + MyList.Strings[I];
ListBox1.Items.Add(cInt);
// clear MyList for the next serie
MyList.clear;
end;
finally
MyList.Free;
end;
// make the button enable for the next click
Self.enabled := True;
end;



//Outra opção sem utilizar componentes visuais é:



type
{array of series of picks, used in Pick function}
TPick = array of array of integer;

function Pick (APicks, AMax, ASeries: integer): TPick;
var
I, J, Index: integer;
PickArray: array of integer;
begin
if (APicks = AMax) then
begin
raise Exception.Create ('Pick: Max available number should be larger than number of picks');
end; {if}
if (APicks < 1) then
begin
raise Exception.Create ('Pick: You should request at least one pick');
end; {if}
if (ASeries < 1) then
begin
raise Exception.Create ('Pick: You should request at least one series');
end; {if}

SetLength (Result, ASeries);
for I := Low (Result) to High (Result) do
begin
{populate AArray }
SetLength (PickArray, AMax);
for J := Low (PickArray) to High (PickArray) do
begin
PickArray [J] := J + 1;
end; {for}

SetLength (Result [I], APicks);
for J := Low (Result [I]) to High (Result [I]) do
begin
Result [I, J] := 0;
while (Result [I, J] = 0) do
begin
Index := Random (AMax);
Result [I, J] := PickArray [Index];
PickArray [Index] := 0;
end; {while}
end; {for J}
end; {for I}
end; {--Pick--}

//Exemplo de Uso

var
APick: TPick;
begin
APick := Pick (6, 49, 10); {we need 10 series of 6/49 numbers}
...

Como enviar mensagem para todos que estão conectados na rede winnt

Function NetSend(dest, source, msg: string): longint;
type
TNetMessageBufferSendFunction = function(servername, msgname, fromname:
PWideChar; buf: PWideChar; buflen: Cardinal): longint; stdcall;
var
NetMessageBufferSend: TNetMessageBufferSendFunction;
SourceWideChar: PWideChar;
DestWideChar: PWideChar;
MessagetextWideChar: PWideChar;
Handle: THandle;
begin

Handle := LoadLibrary('NETAPI32.DLL');
if Handle = 0 then
begin
Result := GetLastError;
exit;
end;

@NetMessageBufferSend := GetProcAddress(Handle, 'NetMessageBufferSend');
if @NetMessageBufferSend = nil then
begin
Result := GetLastError;
exit;
end;

MessagetextWideChar := nil;
SourceWideChar := nil;
DestWideChar := nil;

try
GetMem(MessagetextWideChar, Length(msg) * SizeOf(WideChar) + 1);
GetMem(DestWideChar, 20 * SizeOf(WideChar) + 1);
StringToWideChar(msg, MessagetextWideChar, Length(msg) *
SizeOf(WideChar) + 1);
StringToWideChar(Dest, DestWideChar, 20 * SizeOf(WideChar) + 1);
if source = '' then
result := NetMessageBufferSend(nil, DestWideChar, nil,
MessagetextWideChar, Length(msg) * SizeOf(WideChar) + 1)
else
begin
GetMem(SourceWideChar, 20 * SizeOf(WideChar) + 1);
StringToWideChar(source, SourceWideChar, 20 * SizeOf(WideChar) + 1);
result := NetMessageBufferSend(nil, DestWideChar, SourceWideChar,
MessagetextWideChar, Length(msg) * SizeOf(WideChar) + 1);
freemem(SourceWideChar);
end;
finally
FreeMem(MessagetextWideChar);
FreeLibrary(Handle);
end;
end;

Retorna o ip de sua máquina no momento em que você está conectado

Function GetIP:string;
//--> Declare a Winsock na clausula uses da unit
var
WSAData: TWSAData;
HostEnt: PHostEnt;
Name:string;
begin
WSAStartup(2, WSAData);
SetLength(Name, 255);
Gethostname(PChar(Name), 255);
SetLength(Name, StrLen(PChar(Name)));
HostEnt := gethostbyname(PChar(Name));
with HostEnt^ do
begin
Result := Format('%d.%d.%d.%d',
[Byte(h_addr^[0]),Byte(h_addr^[1]),
Byte(h_addr^[2]),Byte(h_addr^[3])]);
end;
WSACleanup;
end;

Autoocultar a barra de tarefas

//Ocultar.......

ShowWindow(FindWindow('Shell_TrayWnd', nil), SW_HIDE);

//Mostrar.....

ShowWindow(FindWindow('Shell_TrayWnd', nil), SW_SHOWNORMAL);

//Voltar como Estava.....

ShowWindow(FindWindow('Shell_TrayWnd', nil), SW_RESTORE);

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;

Alterando cor de linha de um dbgrid

{Coloque a propriedade defaultdrawdata do dbgrid em FALSE

No evento onDrawColumnCell do seu grid coloque o seguinte:}

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject;
const
Rect: TRect; DataCol: Integer; Column: TColumn;
State: TGridDrawState);
begin
If table1PRAZO.Value > DATE then // condição
Dbgrid1.Canvas.Font.Color:= clFuchsia; // coloque aqui a cor desejada
Dbgrid1.DefaultDrawDataCell(Rect, dbgrid1.columns[datacol].field, State);
end;

Como criar uma aplicação que mostre a velocidade da cpu

{Essa aplicação tem por objetivo exibir a velocidade da CPU.
Primeiro crie uma nova aplicação e insira um TButton e um TEdit. Crie a função GetCPUSpeed (ver código abaixo). Declare a constante ID_BIT na área de declarações da Unit.}

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;

//Agora faça a chamada à função no evento OnClick do botão.

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

//Execute a aplicação.

Obter status da memória do sistema

{Essa dica tem como objetivo mostrar o status da memória do sistema. Para isso, crie uma nova aplicação e adicione um TButton e um TMemo.

Copie o código a seguir no evento OnClick do Button1.}

procedure TForm1.Button1Click(Sender: TObject);
const
cBytesPorMb = 1024 * 1024;
var
M: TMemoryStatus;
begin
M.dwLength := SizeOf(M);
GlobalMemoryStatus(M);
Memo1.Clear;
with Memo1.Lines do begin
Add(Format('Memória em uso: %d%%', [M.dwMemoryLoad]));
Add(Format('Total de memória física: %f MB', [M.dwTotalPhys / cBytesPorMb]));
Add(Format('Memória física disponível: %f MB', [M.dwAvailPhys / cBytesPorMb]));
Add(Format('Tamanho máximo do arquivo de paginação: %f MB', [M.dwTotalPageFile / cBytesPorMb]));
Add(Format('Disponível no arquivo de paginação: %f MB', [M.dwAvailPageFile / cBytesPorMb]));
Add(Format('Total de memória virtual: %f MB', [M.dwTotalVirtual / cBytesPorMb]));
Add(Format('Memória virtual disponível: %f MB', [M.dwAvailVirtual / cBytesPorMb]));
end;
end;

Alterando a data e hora do sistema

{Alterando a data e hora do sistema


Na dica de hoje veremos como alterar a data e hora do sistema de forma bem simples. Primeiramente crie uma nova aplicação e adicione ao Form dois componentes TEdit e um TButton. Limpe a propriedade Text dos Edits.

Declare a procedure DataHora public da Unit }

public
{ Public declarations }
procedure DataHora(Data, Hora: TDateTime);

//Agora crie a procedure na área Implementation

procedure TForm1.DataHora(Data, Hora: TDateTime);
var
DataHora: TSystemTime;
Ano, Mes, Dia,
H, M, S, Mil: word;
begin
Data := StrToDate(Edit1.Text);
Hora := StrToTime(Edit2.Text);
DecodeDate(Data, Ano, Mes, Dia);
DecodeTime(Hora, H, M, S, Mil);
with DataHora do
begin
wYear := Ano;
wMonth := Mes;
wDay := Dia;
wHour := H;
wMinute := M;
wSecond := S;
wMilliseconds := Mil;
end;
SetLocalTime(DataHora);
end;

//Faça a chamada à procedure no evento OnClick do Button1

procedure TForm1.Button1Click(Sender: TObject);
begin
DataHora(StrToDateTime(Edit1.Text), StrToDateTime(Edit2.Text));
end;

//Pronto, agora é só executar o programa e ver seu funcionamento.

Trabalhando com listbox

{Nesta dica veremos como carregar um arquivo TXT em um ListBox, obter o total de linhas desse arquivo e exibir o conteúdo de suas linhas para um Panel.

Vamos começar criando uma nova aplicação e adicionando ao seu Form um TPanel, dois TButton, um TLabel e um TListBox.

Carregar o ListBox com um arquivo TXT é muito simples, para isso basta usar a função LoadFromFile do Delphi e passar como parâmetro o caminho completo do arquivo desejado. Adicione o código abaixo no evento OnClick do Button1 (botão Load):}

procedure TForm1.Button1Click(Sender: TObject);
begin
ListBox1.Items.LoadFromFile('C:discografiaelvis.txt');
end;

{O Button2 (botão Contador) tem como finalidade retornar na propriedade Caption do Label1 o total de linhas do arquivo carregado. Adicione o código abaixo no evento OnClick do Button2:}

procedure TForm1.Button2Click(Sender: TObject);
begin
Label1.Caption := 'Total de linhas do ListBox ' + IntToStr(ListBox1.Items.Count);
end;

{Abaixo veremos como carregar a propriedade Caption do Panel1 com o conteúdo de uma linha do ListBox. Adicione o código a seguir no evento OnClick do ListBox1:}

procedure TForm1.ListBox1Click(Sender: TObject);
var
arm:integer;
begin
arm := ListBox1.ItemIndex;
Panel1.Caption := ListBox1.Items[arm];
end;

Impressão direto pra porta (lpt, usb)

//declare o tipo e a classe abaixo
//caso alguem tenha alguma duvida entre em contato
//ntw@wmail.com.br

type
DOC_INFO_1 = Packed Record
pDocName: PChar;
pOutputFile: PChar;
pDataType: PChar;
End;

TDirectPrinterStream = Class(TStream)
private
FPrinter: TPrinter;
FHandle: THandle;
FTitle: String;
procedure CreateHandle;
procedure FreeHandle;
public
constructor Create(aPrinter: TPrinter; aTitle: String);
destructor Destroy; Override;
function Write(const Buffer; Count: LongInt): Longint; Override;
function Read(var Buffer; Count: Longint): Longint; override;
property Handle: THandle Read FHandle;
End;


//a implementação e a seguinte:

{********************** STREAM DE DADOS PARA A IMPRESSAO DIRETO PRA IMPRESSORA}

Constructor TDirectPrinterStream.Create(aPrinter: TPrinter; aTitle: String);
Begin
Inherited Create;
FPrinter := aPrinter;
FTitle := aTitle;
CreateHandle;
End;

procedure TDirectPrinterStream.CreateHandle;
var
DocInfo: DOC_INFO_1;
aDevice, aDriver, aPort: Array[0..255] Of Char;
aMode: Cardinal;
Begin
FreeHandle;
if FHandle = 0 then
begin
FPrinter.GetPrinter(aDevice, aDriver, aPort, aMode);
if OpenPrinter(aDevice, FHandle, Nil) then
begin
DocInfo.pOutputFile:=nil;
DocInfo.pDataType:='RAW';
DocInfo.pDocName := PChar(FTitle);
if StartDocPrinter(FHandle, 1, @DocInfo) = 0 then
begin
ClosePrinter(FHandle);
FHandle := 0;
end
else if not StartPagePrinter(FHandle) then
begin
EndDocPrinter(FHandle);
ClosePrinter(FHandle);
FHandle := 0;
end;
end;
end;
End;

destructor TDirectPrinterStream.Destroy;
begin
FreeHandle;
inherited;
end;

procedure TDirectPrinterStream.FreeHandle;
begin
if FHandle <> 0 then
begin
EndPagePrinter(FHandle);
EndDocPrinter(FHandle);
ClosePrinter(FHandle);
FHandle := 0;
end;
End;

function TDirectPrinterStream.Read(var Buffer; Count: Integer): Longint;
begin
inherited;
Result:=0;
end;

function TDirectPrinterStream.Write(const Buffer; Count: LongInt): Longint;
var Bytes: Cardinal;
begin
WritePrinter(Handle, @Buffer, Count, Bytes);
Result := Bytes;
End;


//exemplo de uso:

procedure PrintDoc(sNomDoc: String = ''; sNomeArq: String = '');
var Impressora: TDirectPrinterStream;
MemTxt: TMemoryStream;
begin
Impressora := TDirectPrinterStream.Create(Printer, sNomDoc);
try
MemTxt:=TMemoryStream.Create();//criacao dos streams para a copia dos dados
FStrTXT.SaveToStream(MemTxt);//descarrega os dados gravados em memoria no stream
try
Impressora.CopyFrom(MemTxt, 0);//inicia o processo de copia dos dados para a instancia aberta da impressora
finally
MemTxt.Free;
end;
finally
Impressora.Free;
FStrTXT.Free;
end;
end;

terça-feira, 29 de setembro de 2009

Como colocar imagens em um tstatusbar

{1) Insira um TStatusBar em seu projeto.
2) Faça os "Panels".
3) Vamos supor que queira que o "Panel 2" (Lembre-se que começa com 0 a contagem) receba a imagem, mude a propriedade Style do "Panel 2" para psOwnerDraw. Em seguida, no evento OnDrawPanel coloque:}

var
Imagem:TBitmap;
begin
if Panel = 2 then // Caso seja o "Panel 2"...
begin
Imagem:=TBitmap.Create;
Imagem.LoadFromFile('C:Imagem.Bmp'); // Estou carregando de um arquivo, mas há possibilidades de carregar de um resource também.
try
StatusBar1.Canvas.Draw(Rect.Left,Rect.Top,Imagem) // Tenta carregar.
finally
Imagem.Free;
end; // Depois de carregar, libera a imagem.
end;
end;

{4) Rode o projeto e veja que a imagem em C:Imagem.bmp carregou no Panel 2!}





p.801

Inverter botões do mouse

{Inverter os botões do mouse
Dica :}

{ Para inverter: }
SwapMouseButton(true);

{ Para voltar ao normal: }
SwapMouseButton(false);

Como colocar seus programas no painel de controle

{Abaixo segue o código para seu programa no Painel de Controle.
Para começar adicione a Unit Cpl ao seu projeto.}


Library Project1; {Muda de "programa" para "library"}
uses
Cpl, {use Cpl unit}
Windows,
Forms,
Unit1 in 'Unit1.pas' {Form1};

{$R *.RES}

procedure ExecuteApp;
begin
Application.Initialize;
Application.CreateForm(TForm1,Form1);
Application.Run;
end;

{A callback function to export at Control Panel}
function CPlApplet(hwndCPl: THandle; uMsg: DWORD;
lParam1, lParam2: LongInt):LongInt;stdcall;
var
NewCplInfo:PNewCplInfo;

begin
Result:=0;
case uMsg of
{Initialization.Return True.}
CPL_INIT : Result:=1;
{Number of Applet.}
CPL_GETCOUNT : Result:=1;
{Transporting informations of this Applet to the Control Panel.}
CPL_NEWINQUIRE :
begin
NewCplInfo:=PNewCplInfo(lParam2);
with NewCplInfo^ do
begin
dwSize:=SizeOf(TNewCplInfo);
dwFlags:=0;
dwHelpContext:=0;
lData:=0;
{An icon to display on Control Panel.}
hIcon:=LoadIcon(HInstance,'MAINICON');
{Applet name}
szName:='Project1';
{Description of this Applet.}
szInfo:='This is a test Applet.';
szHelpFile:='';
end;
end;
{Executing this Applet.}
CPL_DBLCLK : ExecuteApp;
else Result:=0;
end;
end;

{Exporting the function of CplApplet}
exports
CPlApplet;

begin

end.

Traduzindo mensagens

{Traduzindo mensagens

Um dos maiores problemas quando construimos um programa em Delphi são as mensagens de erro ou de alerta em inglês. Embora exista a possibilidade de fazer a verificação do código antes de a mensagem aparecer, como a que pergunta se o registro deseja ser deletado ou não, quando usamos o componente DBNAVIGATOR , e inserirmos a nossa própria BOX com o texto que quisermos, se estas mensagens já fosse todas traduzidas, gastaríamos menos tempo de programação e nosso programa ficaria mais rápido.

Recomendamos que antes de fazer quaisquer alterações nos arquivos descritos a seguir você efetue uma cópia de segurança dos mesmos.

Como exemplo, vamos citar as mensagens do Delphi que aparecem nos botões, caixas de avisos da função MessageDlg, etc. Para traduzir estas mensagens, basta traduzir o respectivo arquivos de recurso: *.RC.

Quando você efetua a instalação padrão do Delphi, estes arquivos estão no diretório "sourcevcl".

Procure o arquivo ".rc" e use o bloco de notas para abri-lo, faça a tradução das mensagem que você quiser traduzir (somente os textos que estão entre aspas), grave o arquivo e vá ao modo dos, entre no diretório "sourcevcl" e digite o seguinte "....binbrc32 -r {nome do arquivo rc}", isso irá gerar um arquivo res, copie-o para o diretório "lib" do delphi e pronto.

Obs: O diretório pode ser o bin e o brc e não brc32, dependendo da versão do Delphi.

No caso específico da MessageDlg, efetue as alterações ao lado.
Após gravar as alterações, vá ao modo DOS, entre no diretório "sourcevcl" e digite o seguinte "....binbrc32 -r consts.rc", isso irá gerar um arquivo consts.res, copie-o para o diretório lib do delphi, pronto, a messageDlg já estará traduzida.}

SMsgDlgWarning, "Atenção"
SMsgDlgError, "Erro"
SMsgDlgInformation, "Informação"
SMsgDlgConfirm, "Confirme"
SMsgDlgYes, "&Sim"
SMsgDlgNo, "&Não"
SMsgDlgOK, "OK"
SMsgDlgCancel, "Cancelar"
SMsgDlgHelp, "A&juda"
SMsgDlgHelpNone, "Ajuda não localizada"
SMsgDlgHelpHelp, "Ajuda"
SMsgDlgAbort, "&Abortar"
SMsgDlgRetry, "&Repetir"
SMsgDlgIgnore, "&Ignorar"
SMsgDlgAll, "&Todos"

Função para cálculo de fatorial

{Esta função usa chamada recursiva. Observe que há uma chamada à própria função no código.}

function Fatorial(Numero: integer): integer;
begin
if Numero = 0 then
result := 1
else
result := Numero * Fatorial(Numero - 1);
end;

Tipo de conexão com a internet

//Declare na uses WIninet,

var estado : Dword;
begin



if not InternetGetConnectedState(@estado, 0) then
ShowMessage('Você não está conectado à Internet.')
else
begin
if estado and INTERNET_CONNECTION_LAN <> 0 then
label1.Caption := (':: Connection :: Você está conectado à Internet através de LAN ::');
if estado and INTERNET_CONNECTION_MODEM <> 0 then
label1.Caption := (':: Connection :: Você está conectado à Internet através de MODEM ::');
if estado and INTERNET_CONNECTION_PROXY <> 0 then
label1.Caption := (':: Connection :: Você está conectado à Internet através de proxy ::');
end;

Procurando por um arquivo em todo o hd

Interface

type
PRecInfo=^TRecInfo;
Trecinfo=record
prev:PRecInfo;
fpathname:string;
srchrec:Tsearchrec;
end;


implememtation

function TForm1.RecurseDirectory(fname:string):tstringlist;
var
f1,f2:Tsearchrec;
p1,tmp:PRecInfo;
fwc:string;
fpath:string;
fbroke1,fbroke2:boolean;
begin
result:=tstringlist.create;
fpath:=extractfilepath(fname);
fwc:=extractfilename(fname);
new(p1);
p1.fpathname:=fpath;
p1.prev:=nil;
fbroke1:=false;
fbroke2:=false;
while(p1<>nil) do
begin
if (fbroke1=false) then
if (fbroke2=false) then
begin
if (findfirst(fpath+'*',faAnyfile,f1)<>0) then
break;
end
else if (findnext(f1)<>0) then
begin
repeat
findclose(f1);
if (p1=nil) then
break;
fpath:=p1.fpathname;
f1:=p1.srchrec;
tmp:=p1.prev;
dispose(p1);
p1:=tmp;
until (findnext(f1)=0);
if (p1=nil) then
break;
end;
if((f1.Name<>'.') and (f1.name<>'..') and ((f1.Attr and fadirectory)=fadirectory)) then
begin
fbroke1:=false;
new(tmp);
with tmp^ do
begin
fpathname:=fpath;
srchrec.Time:=f1.time;
srchrec.Size:=f1.size;
srchrec.Attr:=f1.attr;
srchrec.Name:=f1.name;
srchrec.ExcludeAttr:=f1.excludeattr;
srchrec.FindHandle:=f1.findhandle;
srchrec.FindData:=f1.FindData;
end;
tmp.prev:=p1;
p1:=tmp;
fpath:=p1.fpathname+f1.name+'';
if findfirst(fpath+fwc,faAnyfile,f2)=0 then
begin
result.add(fpath+f2.Name);
while(findnext(f2)=0) do
result.add(fpath+f2.Name);
findclose(f2);
end;
fbroke2:=false;
end
else
begin
if (findnext(f1)<>0) then
begin
findclose(f1);
fpath:=p1.fpathname;
f1:=p1.srchrec;
fbroke1:=false;
fbroke2:=true;
tmp:=p1.prev;
dispose(p1);
p1:=tmp;
end
else
begin
fbroke1:=true;
fbroke2:=false;
end;
end;
end;
fpath:=extractfilepath(fname);
if findfirst(fname,faAnyfile,f1)=0 then
begin
result.add(fpath+f2.Name);
while(findnext(f1)=0) do
result.add(fpath+f2.Name);
findclose(f1);
end;
end;

//Chame a funcao deste jeito:

procedure TForm1.Button1Click(Sender: TObject);
var
l1:Tstringlist;
begin
l1:=tstringlist.create;
listbox1.items.clear;
listbox1.Items.BeginUpdate;
l1:=recursedirectory1('C:*.exe');
listbox1.items.assign(l1);
freeandnil(l1);
listbox1.Items.endUpdate;
end;

Pegar o nome dos arquivos que estão em execução

{É comum e até relativamente fácil encontrarmos rotinas para listar todas as janelas abertas. Mas muitas vezes não é apenas o caption das janelas que queremos listar e sim o nome do arquivo executável.

Veja então uma rotina que cria uma lista de strings com esses nomes:}

uses TLHelp32; // não esqueça de incluir esta unit
procedure ListProcess(List: TStrings);
var
ProcEntry: TProcessEntry32;
Hnd: THandle;
Fnd: Boolean;
begin
List.Clear;
Hnd := CreateToolhelp32Snapshot(TH32CS_SNAPALL, 0);
if Hnd <> -1 then
begin
ProcEntry.dwSize := SizeOf(TProcessEntry32);
Fnd := Process32First(Hnd, ProcEntry);
while Fnd do
begin
List.Add(ProcEntry.szExeFile);
Fnd := Process32Next(Hnd, ProcEntry);
end;
CloseHandle(Hnd);
end;
end;

//E para utilizar esta rotina é muito simples, veja:

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

Rotina para apagar a senha do setup do micro

Procedure TForm1.Button1Click(Sender: TObject);
begin
asm
mov ax,2eh
out 70h,ax
mov ax,2fh
out 71h,ax
end;
end;

Verificar a velocidade da cpu

{Esta interessante função recupera a velocidade de processamento aproximada 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;

Função para recuperar o 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;

Capturar a data da bios do computador

{Insira um objeto do tipo Button com a propriedade name definica como Button1 e um objeto do tipo Label com a propriedade definida como Label1.}

procedure TForm1.Button1Click(Sender: TObject);
begin
Label1.Caption := 'Data da Bios: '+String(PChar(Ptr($FFFF5)));
end;

Download de arquivos da internet

{Esta dica tem por objetivo mostrar como é fácil fazer o download de arquivos na WEB.

Declare na cláusula uses: URLMon

Esta função é responsável pelo download do arquivo na WEB.}

function DownloadFile(Source, Dest: string): Boolean;
begin
try
Result := UrlDownloadToFile(nil, PChar(source), PChar(Dest), 0, nil) = 0;
except
Result := False;
end;
end;

//Insira no evento OnClick de um botão o seguinte código:

procedure TForm1.Button1Click(Sender: TObject);
begin
if DownloadFile ('http://www.meusite.com.br/default.asp', 'c:windowsdesktopdefault.asp') then
ShowMessage('Download Concluído!')
else
ShowMessage('Falha ao fazer o download!!')
end;

Checar o tipo de conexão com a internet

{Declare a uses: Wininet

Declare uma função com a seguinte instrução:}

function ConnectionKind: Boolean;
var
flags: DWORD;
begin
Result := InternetGetConnectedState(@flags, 0);
if Result then
begin
if (flags and INTERNET_CONNECTION_MODEM) = INTERNET_CONNECTION_MODEM
then
ShowMessage('Modem');
if (flags and INTERNET_CONNECTION_LAN) = INTERNET_CONNECTION_LAN then
ShowMessage('LAN');
if (flags and INTERNET_CONNECTION_PROXY) = INTERNET_CONNECTION_PROXY
then
ShowMessage('Proxy');
if (flags and INTERNET_CONNECTION_MODEM_BUSY) =
INTERNET_CONNECTION_MODEM_BUSY then
ShowMessage('Modem Busy');
end;
end;


Em um botão coloque o seguinte código:

procedure TForm1.Button1Click(Sender: TObject);
begin
ConnectionKind;
end;

Forçar a gravação de dados em tabela paradox

Procedure Commit(var Tabela:TTable);
begin
try
DBISaveChanges(Tabela.handle);
Tabela.Refresh;
except
Tabela.Abort;
end;

ou

Procedure Commit(var Tabela:TTable);
begin
try
Tabela.Startransaction;
DBISaveChanges(Tabela.handle);
Tabela.Commit;
Tabela.Refresh;
exept
Tabela.Rollback;
end;

Declare BDE em user

Cor de fundo do hint

//Veja as propriedades dp TApplication...
Application.HintColor := clAqua;
Application.HintPause := ...
Application.HintShortPause := ...

Validando campos em tabelas

//No evento OnValidate digite:

procedure TForm1.Table1CompanyValidate(Sender: TField);
begin
if Sender.AsString='' then
Raise EDatabaseError.Create('Preencha os campos Obrigatorios');
end;

Converte um arquivo jpeg em bmp

Function JpgToBmp(cImage: String): Boolean;
// Requer a Jpeg declarada na clausua uses da unit
var
MyJPEG : TJPEGImage;
MyBMP : TBitmap;
begin
Result := False;
if fileExists(cImage+'.Jpeg') then
begin
MyJPEG := TJPEGImage.Create;
with MyJPEG do
begin
try
LoadFromFile(cImage+'.Jpeg');
MyBMP := TBitmap.Create;
with MyBMP do
begin
Width := MyJPEG.Width;
Height := MyJPEG.Height;
Canvas.Draw(0,0,MyJPEG);
SaveToFile(cImage+'.Bmp');
Free;
Result := True;
end;
finally
Free;
end;
end;
end;
end;

Retorna o ultimo dia útil caso a data informada caia em um fim de semana

Function DiaUtilAnterior(dData : TDateTime) : TDateTime;
begin
if DayOfWeek(dData) = 7 then
begin
dData := dData - 1;
end
else if DayOfWeek(dData) = 1 then
begin
dData := dData - 2;
end;
Result := dData;
end;

Faz validação de campos impedindo a inserção de registros duplicados

Function ValidaCampo(Table: TTable; Text: Array of const;Indice:String):Boolean
// Esta função deve ser colocada no Evento on SetText do Campo que você deseja fazer a validação
var
Tabela : TTable;
begin
Tabela := TTable.Create(Application);
Tabela.DatabaseName := Table.DataBaseName;
Tabela.TableName := Table.TableName;
Tabela.Open;
Tabela.IndexFieldNames := Indice;
if Tabela.FindKey(Text) then
begin
Result := False;
Tabela.Free;
Abort;
end
else
begin
Result := True;
Tabela.Free;
end;
end;

Permite que seu db ignore os indices e recrie-os

Function CriaIndiceDB(TabName,Dataname,PIndice, PSIndice:string): Boolean;
Var
Tabela: TTable;
begin
Try
Tabela := TTable.Create(nil);
with Tabela do
begin
DatabaseName := TabName;
Exclusive := true;
TableName := Dataname;
IndexDefs.Clear;
try
AddIndex(PIndice,PIndice, [ixPrimary]);
if PSIndice <> ' ' then
begin
AddIndex(PSIndice,PSIndice,[ixCaseInsensitive]);
end;
except
on EDatabaseError do
MessageDlg('Esta Tabela está em uso!',mterror, [mbok],0);
end;
Close;
Exclusive := False;
end;
Result := True;
Except
Result := false;
end;
end;

Retorna o último acesso ao arquivo especificado

Function GetFileLastAccessTime(sFileName : string ) : TDateTime;
var
ffd : TWin32FindData;
dft : DWord;
lft : TFileTime;
h : THandle;
begin
// get file information
h := Windows.FindFirstFile(PChar(sFileName), ffd);
if(INVALID_HANDLE_VALUE <> h)then
begin
Windows.FindClose( h );
FileTimeToLocalFileTime(ffd.ftLastAccessTime, lft );
FileTimeToDosDateTime(lft,LongRec(dft).Hi, LongRec(dft).Lo);
Result := FileDateToDateTime(dft);
end;
end;

Testa se um diretorio existe ou nao

Function IsValidDir(S: string): Boolean;
var
SaveDir: string;
begin
SaveDir := GetCurrentDir;
if SetCurrentDir(S) then
begin
Result := True
end
else
begin
Result := False;
end;
SetCurrentDir(SaveDir);
end;

Habilita o auto-run do cd

Procedure SetCDAutoRun(AAutoRun:Boolean);
// Requer a Registry declarada na clausua uses da unit
const
DoAutoRun : array[Boolean] of Integer = (0,1);
var
Reg:TRegistry;
begin
try
Reg := TRegistry.Create;
Reg.RootKey := HKEY_LOCAL_MACHINE;
if Reg.KeyExists('SystemCurrentControlSetServicesClassCDROM') then
begin
if Reg.OpenKey('SystemCurrentControlSetServicesClassCDROM',FALSE) then
begin
Reg.WriteBinaryData('AutoRun',DoAutoRun[AAutoRun],1);
end;
end;
finally
Reg.Free;
end;
ShowMessage('Suas configurações terão efeito apos reiniciar o computador.');
end;

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;

Fecha um programa que esteje aberto

Function FechaPrograma(Nomeprograma,TituloPrograma:pchar; param: integer): boolean;
// param: determina que tipo de janela será fechada
// 1 - Janela Windows
// 2 - Janela Dos
var
Handle: HWnd;
begin
ShowMessage('Confirma o fechamento do(a) '+strpas(TituloPrograma)+'?');
Handle := FindWindow(nil,TituloPrograma);
if Handle <> 0 then
begin
case param of
1: SendMessage(Handle,WM_CLOSE,0,0); // Para janela windows
2: SendMessage(Handle,WM_QUIT,0,0); // Para janela DOS
end;
Result := true;
end
else
begin
showmessage('Este programa não está aberto');
Result := false;
end;
end;

Executa um programa e espera sua finalização

Function Executa(Arquivo : String; Estado : Integer) : Integer;
// Valores para Estdo: SW_SHOWNORMAL Janela em modo normal
// SW_MAXIMIZE Janela maximizada
// SW_MINIMIZE Janela minimizada
// SW_HIDE Janela Escondida
var
Programa : array [0..512] of char;
CurDir : array [0..255] of char;
WorkDir : String;
StartupInfo : TStartupInfo;
ProcessInfo : TProcessInformation;
begin
StrPCopy (Programa, Arquivo);
GetDir (0, WorkDir);
StrPCopy (CurDir, WorkDir);
FillChar (StartupInfo, Sizeof (StartupInfo), #0);
StartupInfo.cb := sizeof (StartupInfo);
StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
StartupInfo.wShowWindow := Estado;
if not CreateProcess (nil, Programa, nil, nil, false,
CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS,
nil, nil, StartupInfo, ProcessInfo) then
begin
Result := -1;
end
else
begin
WaitForSingleObject (ProcessInfo.hProcess, Infinite);
GetExitCodeProcess (ProcessInfo.hProcess, Result);
end;
end;

Gravando e lendo imagens em dll's

{Primeiramente crie um novo arquivo de resources (*.res) no Image editor do Delphi (menu tools | Image editor), nele que estará guardada a imagem. Crie um Bitmap e renomei-o para figura. salve o arquivo como imagem.res e feche o Image Editor. Crie uma Dll no Delphi, vá no menu (file | New | DLL). Salve a Dll no mesmo local do arquivo Res e mude o código fonte da Dll conforme o texto abaixo: }
library icones;

{$R imagem.res}

begin
end.
{Compile a Dll. Crie um novo projeto, no formulário coloque um objeto image e um button. No evento onclick do botão escreva o código abaixo: }
procedure TForm1.Button1Click(Sender: TObject);
var
fig:thandle;
begin
fig:=loadlibrary('figura.dll');
try
if fig <> 0 then
image1.Picture.Bitmap.LoadFromResourceName(fig,'figura')
else
showmessage('DLL não encontrada');
except
freelibrary(fig);
end;
end;

Abrir arquivo binarios

Function FileOpen(const FileName: string; Mode: LongWord): Integer;
const
AccessMode: array[0..2] of LongWord = (
GENERIC_READ, GENERIC_WRITE, GENERIC_READ or GENERIC_WRITE);
ShareMode: array[0..4] of LongWord = ( 0, 0, FILE_SHARE_READ, FILE_SHARE_WRITE,
FILE_SHARE_READ or FILE_SHARE_WRITE);
begin
Result := Integer(CreateFile(PChar(FileName), AccessMode[Mode and 3],
ShareMode[(Mode and $F0) shr 4], nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0));
end;

Função para buscar o número serial do hd

Function SerialNumHD(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;

Colocar uma progressbar numa statusbar

{- Coloque uma StatusBar no form.

- Adicione dois paineis na StatusBar (propriedade Panels).

- Ajuste as propriedades do primeiro painel conforme abaixo:}

Style = psOwnerDraw

Width = 150

{- Coloque uma ProgressBar no form e mude sua propriedade

Visible para false.

- No evento OnDrawPanel da StatusBar digite o código abaixo:}

procedure TForm1.StatusBar1DrawPanel(StatusBar: TStatusBar;
Panel: TStatusPanel; const Rect: TRect);
begin
{ Se for o primeiro painel... }
if Panel.Index = 0 then begin
{ Ajusta a tamanho da ProgressBar de acordo com
o tamanho do painel }
ProgressBar1.Width := Rect.Right - Rect.Left +1;
ProgressBar1.Height := Rect.Bottom - Rect.Top +1;
{ Pinta a ProgressBar no DC (device-context) da StatusBar }
ProgressBar1.PaintTo(StatusBar.Canvas.Handle, Rect.Left, Rect.Top);
end;
end;
{- Coloque um Button no form

- Digite no evento OnClick do Button o código abaixo:}

procedure TForm1.Button1Click(Sender: TObject);
var
I: integer;
begin
for I := ProgressBar1.Min to ProgressBar1.Max do begin
{ Atualiza a posição da ProgressBar }
ProgressBar1.Position := I;
{ Repinta a StatusBar para forçar a atualização visual }
StatusBar1.Repaint;
{ Aguarda 50 milisegundos }
Sleep(50);
end;

{ Aguarde 500 milisegundos }
Sleep(500);
{ Reseta (zera) a ProgressBar }
ProgressBar1.Position := ProgressBar1.Min;
{ Repinta a StatusBar para forçar a atualização visual }
StatusBar1.Repaint;
end;
{- Execute e clique no botão para ver o resultado.}

Colocando 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;
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(' Teste e divirta-se '); { Note os espacos }
end;

quinta-feira, 24 de setembro de 2009

Chama arquivos bmp de uma dll

//coloque as imagens em um arquivo Res e compile a bibioteca com a diretiva
{$R imagens.res}
//para chamar as imagens
var
Hicone: Thandle;
begin
Hicone:= LoadLibrary('Imagens.dll');
Componente.Glyph.Handle := LoadBitmap(Hicone,'B_CANCELAR');


p.765

Função para obter o número do registro atual

Function Recno(Dataset: TDataset): Longint;
var
CursorProps: CurProps;
RecordProps: RECProps;
begin
{ Return 0 if dataset is not Paradox or dBASE }
Result := 0;
with Dataset do
begin
if State = dsInactive then DBError(SDataSetClosed);
Check(DbiGetCursorProps(Handle, CursorProps));
UpdateCursorPos;
try
Check(DbiGetRecord(Handle, dbiNOLOCK, nil, @RecordProps));
case CursorProps.iSeqNums of
0: Result := RecordProps.iPhyRecNum; { dBASE }
1: Result := RecordProps.iSeqNum; { Paradox }
end;
except
on EDBEngineError do
Result := 0;
end;
end;
end;

Executa um aplicativo somente se ele não estiver aberto, caso contrário apenas chama-o

Procedure ExecutaApp(Nome,State,NomeExec,Path:Pchar;Estado:Integer);
// Valores para Estdo: SW_SHOWNORMAL Janela em modo normal
// SW_MAXIMIZE Janela maximizada
// SW_MINIMIZE Janela minimizada
// SW_HIDE Janela Escondida
// Exemplo:
// ExecutaApp('CALCULADORA','OPEN','CALC.EXE','C:WINDOWS',8);
// Onde 'CALCULADORA' é o nome da janela do aplicativo
var
TheWindows: HWND;
begin
theWindows := FindWindow(NIL,Nome);
if TheWindows <> 0 then
begin
SetForegroundWindow(TheWindows)
end
else
begin
if (Estado > 3) or (Estado < 1) then
begin
Estado := 1;
end;
ShellExecute(Application.Handle,State,NomeExec,NIL,Path,Estado);
end;
end;

Da um pack na tabela

Procedure TablePack( oTable : TTable );
var
iResult: DBIResult;
szErrMsg: DBIMSG;
pTblDesc: pCRTblDesc;
bExclusive: Boolean;
bActive: Boolean;
begin
with oTable do
begin
bExclusive := Exclusive;
bActive := Active;
DisableControls;
Close;
Exclusive := True;
end;
case oTable.TableType of
ttdBASE: begin
oTable.Open;
iResult := DbiPackTable( oTable.DBHandle, oTable.Handle, nil,nil, True );
if iResult <> DBIERR_NONE then
begin
DbiGetErrorString( iResult, szErrMsg );
MessageDlg( szErrMsg, mtError, [mbOk], 0 );
end;
end;
ttParadox: begin
GetMem( pTblDesc, SizeOf( CRTblDesc ));
FillChar( pTblDesc^, SizeOf( CRTblDesc ), 0 );
with pTblDesc^ do
begin
StrPCopy( szTblName, oTable.TableName );
StrPCopy( szTblType, szParadox );
bPack := True;
end;
iResult := DbiDoRestructure( oTable.DBHandle, 1, pTblDesc,nil, nil, nil, False );
if iResult <> DBIERR_NONE then
begin
DbiGetErrorString( iResult, szErrMsg );
ShowMessage( szErrMsg, mtError, [mbOk], 0 );
end;
FreeMem( pTblDesc, SizeOf( CRTblDesc ));
end;
else
ShowMessage( 'Impossível compactar uma tabela deste tipoe!');
end;
with oTable do
begin
Close;
Exclusive := bExclusive;
Active := bActive;
EnableControls;
end;
end;

Faz a tabela paradox ignorar o índice e recriá-lo

Procedure Geraindice(Tbl: TTable);
// Esta procedure requer o componente TTable no Form
var
NewIndex: IDXDesc;
begin
if Tbl.Exclusive = False then
begin
raise EDatabaseError.Create('Tabela deve estar em modo Exclusivo para ser indexada');
end;
NewIndex.iIndexId:= 0;
NewIndex.bPrimary:= TRUE;
NewIndex.bUnique:= TRUE;
NewIndex.bDescending:= FALSE;
NewIndex.bMaintained:= TRUE;
NewIndex.bSubset:= FALSE;
NewIndex.bExpIdx:= FALSE;
NewIndex.iFldsInKey:= 1;
NewIndex.aiKeyFld[0]:= 1;
NewIndex.bCaseInsensitive:= FALSE;
Tbl.Open;
Check(DbiAddIndex(Tbl.dbhandle, Tbl.handle, PChar(Tbl.TableName),szParadox, NewIndex, nil));
end;

Cria um alias em tempo de execução

Procedure ConfigAlias(AAlias, cDriver,APath: String);
var
Param: TStrings;
begin
Param := TStringList.Create;
try
// Obs. APath deve conter o nome do banco
// Ex. "C:Banco.gdb"
Param.Add(Format('SERVER NAME=', [APath]));
Session.AddAlias(AAlias, cDriver, Param);
finally
Param.Free;
end;
end;

Avisa se algum edit no formulário não foi preenchido

Function CheckForBlankText : Boolean
// deve ser usada assim:
// function TForm1.CheckForBlankText : Boolean;
// Declare-a na clausula Private do form
var
n : LongInt
begin
Result := false
for n := 0 to ( ComponentCount - 1 ) do
begin
if ( components[n].ClassType = TEdit ) then
begin
if TEdit (components[n]).text = '' then
begin
Result := true
Exit;
end;
end ;
end ;
End;

Retorna o path de onde o programa está sendo executado

Function ProgPath(filename:String):string;
var
st:string;
begin
st:= application.ExeName;
result:= extractfilepath(st)+filename;
end;

Gerando uma tabela no word

Procedure CreateTableWord(spath: string; printdoc : boolean);
//Coloque no uses: ComObj
var
Word: Variant;
begin
{ Abre o Word }
Word := CreateOleObject('Word.Application');
try
{ Novo documento }
Word.Documents.Add;
try
{ Adiciona tabela de 2 linhas e 3 colunas }
Word.ActiveDocument.Tables.Add(
Range := Word.Selection.Range,
NumRows := 2,
NumColumns := 3);
{ Escreve na primeira célula }
Word.Selection.TypeText(Text := 'Linha 1, Coluna 1');
{ Próxima célula }
Word.Selection.MoveRight(12);
{ Escreve }
Word.Selection.TypeText(Text := 'Linha 1, Coluna 2');
Word.Selection.MoveRight(12);
Word.Selection.TypeText(Text := 'Linha 1, Coluna 3');
Word.Selection.MoveRight(12);
Word.Selection.TypeText(Text := 'Linha 2, Coluna 1');
Word.Selection.MoveRight(12);
Word.Selection.TypeText(Text := 'Linha 2, Coluna 2');
Word.Selection.MoveRight(12);
Word.Selection.TypeText(Text := 'Linha 2, Coluna 3');
{ Auto-Formata }
Word.Selection.Tables.Item(1).Select; { Seleciona a 1º tabela }
Word.Selection.Cells.AutoFit; { auto-formata }
{ Imprime 1 cópia }
if printdoc then
begin
Word.ActiveDocument.PrintOut(Copies := 1);
ShowMessage('Aguarde o término da impressão...');
end;
{ Para salvar... }
Word.ActiveDocument.SaveAs(FileName := spath);
finally
{ Fecha documento }
Word.ActiveDocument.Close(SaveChanges := 0);
end;
finally
{ Fecha o Word }
Word.Quit;
end;
end;

Retorna o nome da impressora padrão do windows

Function GetDefaultPrinterName : string;
begin
if(Printer.PrinterIndex > 0)then
begin
Result := Printer.Printers[Printer.PrinterIndex];
end
else
begin
Result := 'Nenhuma impressora Padrão foi detectada';
end;
end;

Executa uma url com o browser padrão

Procedure ExploreWeb(page:PChar);
// Requer a ShellApi declarada na clausua uses da unit
var
Returnvalue : integer;
begin
ReturnValue := ShellExecute(0, 'open', page, nil, nil,SW_SHOWNORMAL);
if ReturnValue <= 32 then
begin
case Returnvalue of
0 : MessageBox(0,'Error: Out of memory','Error',0);
ERROR_FILE_NOT_FOUND: MessageBox(0,'Error: File not found','Error',0);
ERROR_PATH_NOT_FOUND: MessageBox(0,'Error: Directory not found','Error',0);
ERROR_BAD_FORMAT : MessageBox(0,'Error: Wrong format in EXE','Error',0);
else
MessageBox(0,PChar('Error Nr: '+IntToStr(Returnvalue)+' inShellExecute'),'Error',0)
end;
end;
end;

Executa um aplicativo, já abrindo um arquivo anexo

Function ExecFile(const FileName, Params, DefaultDir: string;ShowCmd: Integer): THandle;

// DefautDir: Diretorio onde ele irá trabalhar
// ShowCmd: 1 = Normal
// 2 = Minimizado
// 3 = Tela Cheia
var
zFileName, zParams, zDir: array[0..79] of Char;
begin
Result := ShellExecute(Application.MainForm.Handle,
nil,StrPCopy(zFileName, FileName), StrPCopy(zParams, Params),
StrPCopy(zDir, DefaultDir), ShowCmd);
end;

Checa cpf

Function ChecaCPF(CPF:String):Boolean;
var
TextCPF:String;
Laco, Soma, Digito1, Digito2:Integer;
begin
Result := False;
for Laco :=1 to Length(CPF) do
if not (CPF[Laco] in ['0'..'9', '-', '.',' ']) then
exit;
TextCPF:= '';
for Laco := 1 to Length(CPF) do
if CPF[Laco] in ['0'..'9'] then
TextCPF := TextCPF + CPF[Laco];
if TextCPF = '' then Result := True;
if Length(TextCPF) <> 11 then Exit;
Soma := 0;
for Laco := 1 to 9 do
Soma := Soma + (StrToInt(TextCPF[Laco])*Laco);
Digito1:= Soma mod 11;
if Digito1 = 10 then Digito1 := 0;
Soma := 0;
For Laco := 1 to 8 do
Soma := Soma + (StrToInt( TextCPF[Laco+1])*(Laco));
Soma := Soma + (Digito1*9);
Digito2 := Soma mod 11;
if Digito2 = 10 then Digito2 := 0;
if Digito1 = StrToInt(TextCPF[10]) then
if Digito2 = StrToInt(TextCPF[11]) then
Result := True;
end;

Utilização da dbgrid em rotina de alto custo

{Cuidado ao utilizar o componente da classe TDbGrid porque durante o processamento de cada registro o Grid poder estar sendo reatualizado, deixando o aplicativo excessivamente lento.

Para resolver isso, ao iniciar o processamente desative os controles visuais da tela/query, conforme exemplo abaixo:}

Query.DisableControls;
.
.
.
Query.EnableControls;

Convertendo de jpeg para bmp

Procedure JPEGtoBMP(const FileName: TFileName);
var
jpeg: TJPEGImage;
bmp: TBitmap;
begin
jpeg := TJPEGImage.Create;
try
jpeg.CompressionQuality := 100; {Default Value}
jpeg.LoadFromFile(FileName);
bmp := TBitmap.Create;
try
bmp.Assign(jpeg);
bmp.SaveTofile(ChangeFileExt(FileName, '.bmp'));
finally
bmp.Free
end;
finally
jpeg.Free
end;
end;

Gravando imagem blob no interbase

// Cria Variável
msFoto01: TMemoryStream;
msFoto02 := TMemoryStream.Create;

// Carrega Imagem para o Comp. Image
Image.Picture.Graphic.SaveToStream(msFoto02);
SQLInsert.ParamByName('pImagem').LoadFromStream(msFoto02,ftBlob);

Lendo tipo blob do interbase

// Cria Variáveis
msFoto01: TMemoryStream;
msJPeg01: TJPEGImage;

try
// Cria Variável
msFoto01 := TMemoryStream.Create;
msFoto01 := TSQLBlobStream.Create(CAMPOBLOB,bmRead);

// Carrega Imagem no Comp. Image (BMP)
Foto01.Picture.Bitmap.LoadFromStream(msFoto01);
except
// Testa sua existência
if CAMPOBLOB.AsString <> '' then
begin
// Cria Variável
msJpeg01 := TJPEGImage.Create;
msJPeg01.LoadFromStream(TSQLBlobStream.Create(CAMPOBLOB,bmRead));
// Carrega Imagem (JPEG)
Foto01.Picture.Graphic := msJpeg01;
Foto01.Update;
FreeAndNil(msJPeg01);
end;
end;

Abrir somente uma instância da aplicação

Var OldWindowProc: Pointer;
MyMsg: LongInt;

Function NewWindowProc(WH: hWnd;Msg,PW,PL:LongInt):LongInt stdcall;
Begin
If Msg=MyMsg Then
Begin
SendMessage(Application.Handle,WM_SYSCOMMAND,SC_RESTORE,0);
SetForegroundWindow(Application.Handle);
Result:=0;
exit;
End;
Result:=CallWindowProc(OldWindowProc,WH,Msg,PW,PL);
End;

No Evento OnCreate do form principal coloque:

MyMsg:=RegisterWindowMessage('X10APP');
OldWindowProc:=Pointer(SetWindowLong(Handle, GWL_WNDPROC, LongInt(@NewWindowProc)));

No Evento onDestroy do form principal coloque:

SetWindowLong(Handle,GWL_WNDPROC,LongInt(OldWindowProc));

No seu Arquivo *.dpr, coloque:

Cláusula Uses: Windows

e abaixo de {$R *.RES} coloque:

begin
//***************************************************
CreateMutex(NIL,False,'X10APP');
If GetLastError = ERROR_ALREADY_EXISTS Then
Begin
SendMessage(HWND_BROADCAST,
RegisterWindowMessage('X10APP'),0,0);
Halt(0);
End;
//***************************************************
{Coloque no seu projeto essa parte que esta acima}
Application.Initialize;
Application.CreateForm(TfrmPrincipal, frmPrincipal);
Application.Run;
end.

Saber se um form foi criado

//Simplemente:

If Form <> nil then
//form criado
else
//form não criado

Trocando a cor de uma célula num dbgrid

Procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect;
Field: TField; State: TGridDrawState);
begin
if Table1.FieldByName('Pagou').Value = True then
DBGrid1.Canvas.Brush.Color := clGreen
else
DBGrid1.Canvas.Brush.Color := clRed;
DBGrid1.Canvas.FillRect(Rect);
DBGrid1.DefaultDrawDataCell(Rect,Field,State);
end;

Usando locate com locaseinsensitive

if not qryalunos.locate('Aluno',edit1.text,[loCaseInsensitive,loPartialKey]) then
Showmessage ('Aluno não encontrado!!');

Verificar se a impressora está online

Function PrinterOnLine: Boolean
const
PrnStInt: Byte = $17;
StRq: Byte = $02;
PrnNum: Word = 0;
var
nResult: Byte;
begin
ASM
mov ah, StRq;
mov dx, PrnNum;
Int $17;
mov nResult, ah;
end;
end;

Verificar se o aplicativo já foi inicializado

{Para verificar se o aplicativo já foi inicializado, insira o código abaixo no .DPR(projeto).}

{$R *.RES}
begin
Application.Title := '';
Application.HelpFile := '';
if HPrevInst = 0 then
begin
F_Splash := TF_Splash.create(Application);
F_Splash.Show;
Application.CreateForm(TMenuPrincipal, MenuPrincipal);
Application.CreateForm(TCadastroDeSenhas, CadastroDeSenhas);
Application.CreateForm(TSenhaDeAcesso, SenhaDeAcesso);
Application.Run;
end
else
messagedlg('O sistema já foi inicializado!',mtinformation,[mbok],0);
end.

Verificando se o registro já existe

Procedure TF_Cliente.EditCodExit(Sender: TObject);
begin
qryPesq.Close;
qryPesq.SQL.Clear;
qryPesq.SQL.Add('Select Codigo from Clientes where Codigo = ' + EditCod.Text ) ;
qryPesq.Open;

if qryPesq.RecordCount <> 0 then
begin
MessageDlg('Código já Cadastrado!!!',mtWarning,[mbOK],0);
EditCod.SetFocus;
end;
end;

Zerando campo autoincremento em tabela paradox

Function ResetAutoInc(FileName: TFileName; Base: Longint): Boolean;
begin
with TFileStream.Create(FileName, fmOpenReadWrite) do
begin
Result := (Seek($49, soFromBeginning) = $49) and (Write(Base, 4) = 4);
Free;
end;
end;
{O parâmetro FileName é o nome da tabela, incluindo o caminho. E o parâmetro Base é o valor inicial para o contador do AutoIncremento.}

Validando entradas no edit

//No evento OnKeyPress do objeto Edit, digite:


if not ( Key In ['0'..'9','.'] ) then
Abort;

Testa se o registro está travado ou não

Function RLock(oTable : TTable): Boolean;
begin
result := false;
try
oTable.Edit;
except

Showmessage com quebra de linhas

Procedure TForm1.Button1Click(Sender: TObject);
var
MSG : String;
begin
MSG := 'Mensagem da Primeira Linha'+#13+'Mensagem da Segunda Linha'+#13+'Mensagem da Terceira Linha';
ShowMessage(MSG);
end;
ATENÇÃO. A quebra foi possível através do codigo #13.

Retorna o último acesso a um arquivo

Function GetFileLastAccessTime(sFileName : string ) : TDateTime;
var
ffd : TWin32FindData;
dft : DWord;
lft : TFileTime;
h : THandle;
begin
// get file information
h := Windows.FindFirstFile(PChar(sFileName), ffd);
if(INVALID_HANDLE_VALUE <> h)then
begin
Windows.FindClose( h );
FileTimeToLocalFileTime(ffd.ftLastAccessTime, lft );
FileTimeToDosDateTime(lft,LongRec(dft).Hi, LongRec(dft).Lo);
Result := FileDateToDateTime(dft);
end;
end;

Retorna o tamanho de um arquivo

Function fileSize(const FileName: String): LongInt;
var
SearchRec : TSearchRec;
begin { !Win32! -> GetFileSize }
if FindFirst(FileName,faAnyFile,SearchRec)=0
then Result:=SearchRec.Size
else Result:=0;
FindClose(SearchRec);
end;

Retorna o nome do usuario logado na rede

Function LogUser : String;
//Requer a unit Registry declarada na clausula Uses da Unit
var
Registro: TRegistry;
begin
Registro := TRegistry.Create;
Registro.RootKey := HKEY_LOCAL_MACHINE;
if Registro.OpenKey('NetworkLogon', false) then
begin
result := Registro.ReadString('username');
end;
Registro.Free;
end;

Retorna o mes, por extenso de uma data

Function NomedoMes(dData:TDatetime):string;
var
nAno,nMes,nDia:word;
cMes:array[1..12] of string;
begin
cMes[01] := 'Janeiro';
cMes[02] := 'Fevereiro';
cMes[03] := 'Março';
cMes[04] := 'Abril';
cMes[05] := 'Maio';
cMes[06] := 'Junho';
cMes[07] := 'Julho';
cMes[08] := 'Agosto';
cMes[09] := 'Setembro';
cMes[10] := 'Outubro';
cMes[11] := 'Novembro';
cMes[12] := 'Dezembro';
decodedate(dData,nAno,nMes,nDia);
if (nMes>=1) and (nMes<=13)then
begin
Result:=cMes[nMes];
end
else
begin
Result:='';
end;
end;

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;

Retorna a hora corrente

Function Time: TDateTime;
Retorna a hora corrente
procedure TForm1.Button1Click(Sender: TObject);
begin
Label1.Caption := 'The time is ' + TimeToStr(Time);
end;

Retorna a extensão de um arquivo

Function ExtractFileExt(const FileName: string): string;

Retorna a data de um arquivo

Function FileDateTime(const FileName: string): TDateTime;
begin
Result := FileDateToDateTime(FileAge(FileName));
end;

Retira o espaço em branco no inicio ou fim 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;

Relatorio quick report em html

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

quarta-feira, 23 de setembro de 2009

Adicionando dias a uma data

Var nDias:String;
vData:tDateTime;
Begin
vData:=Date;
if Inputquery('Adicionar dias','Quantos dias deseja adicionar?',nDias)
then begin
Try
vData:=vData+StrtoInt(nDias);
Except
ShowMessage('O valor de dias não parece um valor válido!!!');
Exit;
End;
ShowMessage('A Proxima dada é : '+FormatDateTime('DD/MM/YYYY',vData);
End;
End;

Abrindo configurações de video do painel de controle

WinExec('RunDLL32.exe Shell32.DLL,Control_RunDLL Desk.cpl', SW_Show)
{Os outros itens do Painel de Controle podem ser acessados mudando-se o nome do arquivo .cpl, exemplo:
- Modem.cpl
- Netcpl.cpl }

Abrindo a caixa localizar arquivo

CSIDL_DRIVES - My Computer
SIDL_CONTROLS - Control Panel
CSIDL_DESKTOP - Desctop
CSIDL_BITBUCKET - Recycle Bin


procedure TForm1.Button1Click(Sender: TObject); //
uses ShlObj, ShellAPI, ActiveX
var
pidl: PITEMIDLIST;
PMalloc: IMalloc;
sei : TShellExecuteInfo;
begin
try
SHGetMalloc(PMalloc);
ZeroMemory(@sei, sizeof(sei));
SHGetSpecialFolderLocation(0,CSIDL_DRIVES,pidl);
with sei do
begin
cbSize := SizeOf(sei);
// nShow := SW_SHOWNORMAL;
// lpFile := PChar('C:');
fMask := SEE_MASK_INVOKEIDLIST;
lpVerb := 'find';
lpIDList := pidl;
end;
ShellExecuteEx(@sei);
finally
pMalloc._Release;
pMalloc := nil;
end;
end;

Abrindo uma url

{1º Declare o procedure na seção PUBLIC da unit.
procedure JumpTo(const aAdress: String);

2º Coloque a cláusula ShellAPI na uses no início da unit. }

procedure TForm1.JumpTo(const aAdress: String);
var
buffer: String;
begin
buffer := 'http://' + aAdress;
ShellExecute(Application.Handle, nil, PChar(buffer), nil, nil, SW_SHOWNORMAL);
end;

procedure TForm1.Label1Click(Sender: TObject);
begin
JumpTo('www.geocities.com/SiliconValley/Way/1497');
end;

Obtendo a idade de uma pessoa a partir da data de nascimento

Function IdadeN(Nascimento:TDateTime) : String;
Type
Data = Record
Ano : Word;
Mes : Word;
Dia : Word;
End;
Const
Qdm:String = '312831303130313130313031'; // Qtde dia no mes
Var
Dth : Data; // Data de hoje
Dtn : Data; // Data de nascimento
anos, meses, dias, nrd : Shortint; // Usadas para calculo da idade
begin
DecodeDate(Date,Dth.Ano,Dth.Mes,Dth.Dia);
DecodeDate(Nascimento,Dtn.Ano,Dtn.Mes,Dtn.Dia);
anos := Dth.Ano - Dtn.Ano;
meses := Dth.Mes - Dtn.Mes;
if meses < 0 then
begin
Dec(anos);
meses := meses+12;
end;
dias := Dth.Dia - Dtn.Dia;
if dias < 0 then
begin
nrd := StrToInt(Copy(Qdm,(Dth.Mes-1)*2-1,2));
if ((Dth.Mes-1)=2) and ((Dth.Ano Div 4)=0) then
begin
Inc(nrd);
end;
dias := dias+nrd;
meses := meses-1;
end;
Result := IntToStr(anos)+' Anos '+IntToStr(meses)+' Meses '+IntToStr(dias)+' Dias';
end;

Função para adquir hora e data de um arquivo

Function GetFileDate(Arquivo: String): String;
var
FHandle: integer;
begin
FHandle := FileOpen(Arquivo, 0);
try
Result := DateTimeToStr(FileDateToDateTime(FileGetDate(FHandle)));
finally
FileClose(FHandle);
end;
end;

Arquivos *.ini

{É viável usar arquivos .ini para guardar informações. Um exemplo, Caso o programador tenha um componente, e toda hora o usuário acrescenta informação a ele, é possível gravar elas usando os arquivos ini.

Primeiro é necessário declarar a unit IniFile na uses }

var
ArquivoIni : TIniFile;
begin

ArquivoIni := TIniFile.Create('C:WindowsMeuArquivo.INI');
ArquivoIni.WriteString('Minha seção', 'Minha chave', Edit1.Text);
ArquivoIni.Free;

end;

Descobrindo a letra da unidade de cd-rom

Function TForm1.CDROMDrive: Char;
Var
drivemap, mask: DWORD;
i: Integer;
root: String;
Begin
Result := #0;
root := 'A:';
drivemap := GetLogicalDrives;
mask := 1;
For i:= 1 To 32 Do
Begin
If (mask and drivemap) <> 0 Then
If GetDriveType( PChar(root) ) = DRIVE_CDROM Then
Begin
Result := root[1];
Break;
End;
mask := mask shl 1;
Inc( root[1] );
End;
End;

Como apresentar o número da linha e coluna em um dbgrid

{Podemos derivar uma classe a partir de TDBGrid e para utilizar este recurso!}

implementation
{$R *.DFM}

type
TMostraProp = class (TDBGrid);
{evento OnColEnter do DBGrid}
procedure TForm1.DBGrid1ColEnter(Sender: TObject);
begin
Caption := Format(‘Coluna: %2d; Row: %2d’,
[TMostraProp(DbGrid1).Col, TMostraProp(DbGrid1).Row]);
end;

{ evento OnDataChange do DataSource }
procedure TForm1.DataSource1DataChange(Sender: TObject; Field: TField);
begin
DBGrid1ColEnter(Sender);
end;

Colocando seu programa no painel de controle

{Abaixo segue o código para seu programa no Painel de Controle.
Para começar adicione a Unit Cpl ao seu projeto.}

Library Project1; {Muda de "programa" para "library"}
uses
Cpl, {use Cpl unit}
Windows,
Forms,
Unit1 in 'Unit1.pas' {Form1};

{$R *.RES}

procedure ExecuteApp;
begin
Application.Initialize;
Application.CreateForm(TForm1,Form1);
Application.Run;
end;

{A callback function to export at Control Panel}
function CPlApplet(hwndCPl: THandle; uMsg: DWORD; lParam1, lParam2: LongInt):LongInt;stdcall;
var
NewCplInfo:PNewCplInfo;
begin
Result:=0;
case uMsg of
{Initialization.Return True.}
CPL_INIT : Result:=1;
{Number of Applet.}
CPL_GETCOUNT : Result:=1;
{Transporting informations of this Applet to the Control Panel.}
CPL_NEWINQUIRE :
begin
NewCplInfo:=PNewCplInfo(lParam2);
with NewCplInfo^ do
begin
dwSize:=SizeOf(TNewCplInfo);
dwFlags:=0;
dwHelpContext:=0;
lData:=0;
{An icon to display on Control Panel.}
hIcon:=LoadIcon(HInstance,'MAINICON');
{Applet name}
szName:='Project1';
{Description of this Applet.}
szInfo:='This is a test Applet.';
szHelpFile:='';
end;
end;
{Executing this Applet.}
CPL_DBLCLK : ExecuteApp;
else Result:=0;
end;
end;

{Exporting the function of CplApplet}
exports
CPlApplet;
begin

end.

Convertendo codigo asc para hexadecimal

Function CharToHex( MyChar: Char ): String;
var escala: string;
res, num: integer;
Begin
num:=ord(Mychar);
escala:='0123456789ABCDEF';
res:=(num div 16);
result:=escala[res+1];
res:=(num-(res*16));
result:=result+escala[res+1];
End;

Rotina para retornar a versão de um aplicativo

Function GetBuildInfo:string;
var
VerInfoSize: DWORD;
VerInfo: Pointer;
VerValueSize: DWORD;
VerValue: PVSFixedFileInfo;
Dummy: DWORD;
V1, V2, V3, V4: Word;
Prog : string;
begin
Prog := Application.Exename;
VerInfoSize := GetFileVersionInfoSize(PChar(prog), Dummy);
GetMem(VerInfo, VerInfoSize);
GetFileVersionInfo(PChar(prog), 0, VerInfoSize, VerInfo);
VerQueryValue(VerInfo, '', Pointer(VerValue), VerValueSize);
with VerValue^ do
begin
V1 := dwFileVersionMS shr 16;
V2 := dwFileVersionMS and $FFFF;
V3 := dwFileVersionLS shr 16;
V4 := dwFileVersionLS and $FFFF;
end;
FreeMem(VerInfo, VerInfoSize);
result := Copy (IntToStr (100 + v1), 3, 2) + '.' +
Copy (IntToStr (100 + v2), 3, 2) + '.' +
Copy (IntToStr (100 + v3), 3, 2) + '.' +
Copy (IntToStr (100 + v4), 3, 2);
end;

Verificar se um registro está travado

//Verificar se o registro está travado

//Inclua a unit DBITYPES na clausula uses do seu form.

function TForm1.IsRecordLocked(Table: TTable; ByAnyone: boolean): Boolean;

var
Locked: BOOL;
hCur: hDBICur;
rslt: DBIResult;
begin
Table.UpdateCursorPos;
// Is the record locked by the current session...
Check(DbiIsRecordLocked(Table.Handle, Locked));
Result := Locked;
// If the current session does not have a lock and the ByAnyone varable is
// set to check all sessions, continue check...
if (Result = False) and (ByAnyone = True) then
begin
// Get a new cursor to the same record...
Check(DbiCloneCursor(Table.Handle, False, False, hCur));
try
// Try and get the record with a write lock...
rslt := DbiGetRecord(hCur, dbiWRITELOCK, nil, nil);
if rslt <> DBIERR_NONE then
begin
// if an error occured and it is a lock error, return true...
if HiByte(rslt) = ERRCAT_LOCKCONFLICT then
Result := True
else
// If some other error happened, throw an exception...
Check(rslt);
end
else
// Release the lock in this session if the function was successful...
Check(DbiRelRecordLock(hCur, False));
finally
// Close the cloned cursor...
Check(DbiCloseCursor(hCur));
end;
end;
end;

//Utilize a função assim:


procedure TForm1.Button1Click(Sender: TObject);
begin
If IsRecordLocked(Table1,True) then
Showmessage('Registro Travado!');
end;

Reindexando tabelas

Uses
dbTables, DbiProcs;
begin
table1.exclusive := true;
table1.open;
dbiRegenIndexes(table.Handle);
end;

Alterar a data do sistema

Procedure TForm1.Button1Click(Sender: TObject);
begin
SetNewTime(1998,2,10,18,07);
end;

function SetNewTime(Ano, Mes, Dia, hour, minutes: word): Boolean;
var
st:TSYSTEMTIME;
begin
GetLocalTime(st);
st.wYear := Ano;
st.wMonth := Mes;
st.wDay := Dia;
st.wHour := hour;
st.wMinute := minutes;
if not SetLocalTime(st) then
Result := False
else
Result := True;
end;

Validar inscrição estadual

Validando Inscrição Estadual

{
Essa unit mostra como fazer a validação de uma inscrião estadual,
neste site (www.delphibr.com.br) existe um artigo onde mostra como
Fazer a validação Passo-a-passo.
}
Unit Inscricoes;

{ Create: 21/06/2001 - Update: 23/06/2001 - By Paulo Ed Casagrande }

{ Unit desenvolvida com base em informações contidas no site : www.sintegra.gov.br }

Interface uses

Sysutils;

Function Inscricao ( Inscricao, Tipo : String ) : Boolean;
Function Mascara_Inscricao( Inscricao, Estado : String ) : String;

Implementation

{ Inscrições __________________________________ }

Function Inscricao( Inscricao, Tipo : String ) : Boolean; Var

Contador : ShortInt;
Casos : ShortInt;
Digitos : ShortInt;

Tabela_1 : String;
Tabela_2 : String;
Tabela_3 : String;

Base_1 : String;
Base_2 : String;
Base_3 : String;

Valor_1 : ShortInt;

Soma_1 : Integer;
Soma_2 : Integer;

Erro_1 : ShortInt;
Erro_2 : ShortInt;
Erro_3 : ShortInt;

Posicao_1 : string;
Posicao_2 : String;

Tabela : String;
Rotina : String;
Modulo : ShortInt;
Peso : String;

Digito : ShortInt;

Resultado : String;
Retorno : Boolean;

Begin

Try

Tabela_1 := ' ';
Tabela_2 := ' ';
Tabela_3 := ' ';

{ } { }
{ Valores possiveis para os digitos (j) }
{ }
{ 0 a 9 = Somente o digito indicado. }
{ N = Numeros 0 1 2 3 4 5 6 7 8 ou 9 }
{ A = Numeros 1 2 3 4 5 6 7 8 ou 9 }
{ B = Numeros 0 3 5 7 ou 8 }
{ C = Numeros 4 ou 7 }
{ D = Numeros 3 ou 4 }
{ E = Numeros 0 ou 8 }
{ F = Numeros 0 1 ou 5 }
{ G = Numeros 1 7 8 ou 9 }
{ H = Numeros 0 1 2 ou 3 }
{ I = Numeros 0 1 2 3 ou 4 }
{ J = Numeros 0 ou 9 }
{ K = Numeros 1 2 3 ou 9 }
{ }
{ -------------------------------------------------------- }
{ }
{ Valores possiveis para as rotinas (d) e (g) }
{ }
{ A a E = Somente a Letra indicada. }
{ 0 = B e D }
{ 1 = C e E }
{ 2 = A e E }
{ }
{ -------------------------------------------------------- }
{ }
{ C T F R M P R M P }
{ A A A O O E O O E }
{ S M T T D S T D S }
{ }
{ a b c d e f g h i jjjjjjjjjjjjjj }
{ 0000000001111111111222222222233333333 }
{ 1234567890123456789012345678901234567 }

IF Tipo = 'AC' Then Tabela_1 := '1.09.0.E.11.01. . . . 01NNNNNNX.14.00';
IF Tipo = 'AC' Then Tabela_2 := '2.13.0.E.11.02.E.11.01. 01NNNNNNNNNXY.13.14';
IF Tipo = 'AL' Then Tabela_1 := '1.09.0.0.11.01. . . . 24BNNNNNX.14.00';
IF Tipo = 'AP' Then Tabela_1 := '1.09.0.1.11.01. . . . 03NNNNNNX.14.00';
IF Tipo = 'AP' Then Tabela_2 := '2.09.1.1.11.01. . . . 03NNNNNNX.14.00';
IF Tipo = 'AP' Then Tabela_3 := '3.09.0.E.11.01. . . . 03NNNNNNX.14.00';
IF Tipo = 'AM' Then Tabela_1 := '1.09.0.E.11.01. . . . 0CNNNNNNX.14.00';
IF Tipo = 'BA' Then Tabela_1 := '1.08.0.E.10.02.E.10.03. NNNNNNYX.14.13';
IF Tipo = 'BA' Then Tabela_2 := '2.08.0.E.11.02.E.11.03. NNNNNNYX.14.13';
IF Tipo = 'CE' Then Tabela_1 := '1.09.0.E.11.01. . . . 0NNNNNNNX.14.13';
IF Tipo = 'DF' Then Tabela_1 := '1.13.0.E.11.02.E.11.01. 07DNNNNNNNNXY.13.14';
IF Tipo = 'ES' Then Tabela_1 := '1.09.0.E.11.01. . . . 0ENNNNNNX.14.00';
IF Tipo = 'GO' Then Tabela_1 := '1.09.1.E.11.01. . . . 1FNNNNNNX.14.00';
IF Tipo = 'GO' Then Tabela_2 := '2.09.0.E.11.01. . . . 1FNNNNNNX.14.00';
IF Tipo = 'MA' Then Tabela_1 := '1.09.0.E.11.01. . . . 12NNNNNNX.14.00';
IF Tipo = 'MT' Then Tabela_1 := '1.11.0.E.11.01. . . . NNNNNNNNNNX.14.00';
IF Tipo = 'MS' Then Tabela_1 := '1.09.0.E.11.01. . . . 28NNNNNNX.14.00';
IF Tipo = 'MG' Then Tabela_1 := '1.13.0.2.10.10.E.11.11. NNNNNNNNNNNXY.13.14';
IF Tipo = 'PA' Then Tabela_1 := '1.09.0.E.11.01. . . . 15NNNNNNX.14.00';
IF Tipo = 'PB' Then Tabela_1 := '1.09.0.E.11.01. . . . 16NNNNNNX.14.00';
IF Tipo = 'PR' Then Tabela_1 := '1.10.0.E.11.09.E.11.08. NNNNNNNNXY.13.14';
IF Tipo = 'PE' Then Tabela_1 := '1.14.1.E.11.07. . . .18ANNNNNNNNNNX.14.00';
IF Tipo = 'PI' Then Tabela_1 := '1.09.0.E.11.01. . . . 19NNNNNNX.14.00';
IF Tipo = 'RJ' Then Tabela_1 := '1.08.0.E.11.08. . . . GNNNNNNX.14.00';
IF Tipo = 'RN' Then Tabela_1 := '1.09.0.0.11.01. . . . 20HNNNNNX.14.00';
IF Tipo = 'RS' Then Tabela_1 := '1.10.0.E.11.01. . . . INNNNNNNNX.14.00';
IF Tipo = 'RO' Then Tabela_1 := '1.09.1.E.11.04. . . . ANNNNNNNX.14.00';
IF Tipo = 'RO' Then Tabela_2 := '2.14.0.E.11.01. . . .NNNNNNNNNNNNNX.14.00';
IF Tipo = 'RR' Then Tabela_1 := '1.09.0.D.09.05. . . . 24NNNNNNX.14.00';
IF Tipo = 'SC' Then Tabela_1 := '1.09.0.E.11.01. . . . NNNNNNNNX.14.00';
IF Tipo = 'SP' Then Tabela_1 := '1.12.0.D.11.12.D.11.13. NNNNNNNNXNNY.11.14';
IF Tipo = 'SP' Then Tabela_2 := '2.12.0.D.11.12. . . . NNNNNNNNXNNN.11.00';
IF Tipo = 'SE' Then Tabela_1 := '1.09.0.E.11.01. . . . NNNNNNNNX.14.00';
IF Tipo = 'TO' Then Tabela_1 := '1.11.0.E.11.06. . . . 29JKNNNNNNX.14.00';

IF Tipo = 'CNPJ' Then Tabela_1 := '1.14.0.E.11.21.E.11.22.NNNNNNNNNNNNXY.13.14';
IF Tipo = 'CPF' Then Tabela_1 := '1.11.0.E.11.31.E.11.32. NNNNNNNNNXY.13.14';

{ Deixa somente os numeros }

Base_1 := '';

For Contador := 1 TO 30 Do IF Pos( Copy( Inscricao, Contador, 1 ), '0123456789' ) <> 0 Then Base_1 := Base_1 + Copy( Inscricao, Contador, 1 );

{ Repete 3x - 1 para cada caso possivel }

Casos := 0;

Erro_1 := 0;
Erro_2 := 0;
Erro_3 := 0;

While Casos < 3 Do Begin

Casos := Casos + 1;

IF Casos = 1 Then Tabela := Tabela_1;
IF Casos = 2 Then Erro_1 := Erro_3 ;
IF Casos = 2 Then Tabela := Tabela_2;
IF Casos = 3 Then Erro_2 := Erro_3 ;
IF Casos = 3 Then Tabela := Tabela_3;

Erro_3 := 0 ;

IF Copy( Tabela, 1, 1 ) <> ' ' Then Begin

{ Verifica o Tamanho }

IF Length( Trim( Base_1 ) ) <> ( StrToInt( Copy( Tabela, 3, 2 ) ) ) Then Erro_3 := 1;

IF Erro_3 = 0 Then Begin

{ Ajusta o Tamanho }

Base_2 := Copy( ' ' + Base_1, Length( ' ' + Base_1 ) - 13, 14 );

{ Compara com valores possivel para cada uma da 14 posições }

Contador := 0 ;

While ( Contador < 14 ) AND ( Erro_3 = 0 ) Do Begin

Contador := Contador + 1;

Posicao_1 := Copy( Copy( Tabela, 24, 14 ), Contador, 1 );
Posicao_2 := Copy( Base_2 , Contador, 1 );

IF ( Posicao_1 = ' ' ) AND ( Posicao_2 <> ' ' ) Then Erro_3 := 1;
IF ( Posicao_1 = 'N' ) AND ( Pos( Posicao_2, '0123456789' ) = 0 ) Then Erro_3 := 1;
IF ( Posicao_1 = 'A' ) AND ( Pos( Posicao_2, '123456789' ) = 0 ) Then Erro_3 := 1;
IF ( Posicao_1 = 'B' ) AND ( Pos( Posicao_2, '03578' ) = 0 ) Then Erro_3 := 1;
IF ( Posicao_1 = 'C' ) AND ( Pos( Posicao_2, '47' ) = 0 ) Then Erro_3 := 1;
IF ( Posicao_1 = 'D' ) AND ( Pos( Posicao_2, '34' ) = 0 ) Then Erro_3 := 1;
IF ( Posicao_1 = 'E' ) AND ( Pos( Posicao_2, '08' ) = 0 ) Then Erro_3 := 1;
IF ( Posicao_1 = 'F' ) AND ( Pos( Posicao_2, '015' ) = 0 ) Then Erro_3 := 1;
IF ( Posicao_1 = 'G' ) AND ( Pos( Posicao_2, '1789' ) = 0 ) Then Erro_3 := 1;
IF ( Posicao_1 = 'H' ) AND ( Pos( Posicao_2, '0123' ) = 0 ) Then Erro_3 := 1;
IF ( Posicao_1 = 'I' ) AND ( Pos( Posicao_2, '01234' ) = 0 ) Then Erro_3 := 1;
IF ( Posicao_1 = 'J' ) AND ( Pos( Posicao_2, '09' ) = 0 ) Then Erro_3 := 1;
IF ( Posicao_1 = 'K' ) AND ( Pos( Posicao_2, '1239' ) = 0 ) Then Erro_3 := 1;
IF ( Posicao_1 <> Posicao_2 ) AND ( Pos( Posicao_1, '0123456789' ) > 0 ) Then Erro_3 := 1;

End;

{ Calcula os Digitos }

Rotina := ' ';
Digitos := 000;
Digito := 000;

While ( Digitos < 2 ) AND ( Erro_3 = 0 ) Do Begin

Digitos := Digitos + 1;

{ Carrega peso }

Peso := Copy( Tabela, 5 + ( Digitos * 8 ), 2 );

IF Peso <> ' ' Then Begin

Rotina := Copy( Tabela, 0 + ( Digitos * 8 ), 1 ) ;
Modulo := StrToInt( Copy( Tabela, 2 + ( Digitos * 8 ), 2 ) );

IF Peso = '01' Then Peso := '06.05.04.03.02.09.08.07.06.05.04.03.02.00';
IF Peso = '02' Then Peso := '05.04.03.02.09.08.07.06.05.04.03.02.00.00';
IF Peso = '03' Then Peso := '06.05.04.03.02.09.08.07.06.05.04.03.00.02';
IF Peso = '04' Then Peso := '00.00.00.00.00.00.00.00.06.05.04.03.02.00';
IF Peso = '05' Then Peso := '00.00.00.00.00.01.02.03.04.05.06.07.08.00';
IF Peso = '06' Then Peso := '00.00.00.09.08.00.00.07.06.05.04.03.02.00';
IF Peso = '07' Then Peso := '05.04.03.02.01.09.08.07.06.05.04.03.02.00';
IF Peso = '08' Then Peso := '08.07.06.05.04.03.02.07.06.05.04.03.02.00';
IF Peso = '09' Then Peso := '07.06.05.04.03.02.07.06.05.04.03.02.00.00';
IF Peso = '10' Then Peso := '00.01.02.01.01.02.01.02.01.02.01.02.00.00';
IF Peso = '11' Then Peso := '00.03.02.11.10.09.08.07.06.05.04.03.02.00';
IF Peso = '12' Then Peso := '00.00.01.03.04.05.06.07.08.10.00.00.00.00';
IF Peso = '13' Then Peso := '00.00.03.02.10.09.08.07.06.05.04.03.02.00';
IF Peso = '21' Then Peso := '05.04.03.02.09.08.07.06.05.04.03.02.00.00';
IF Peso = '22' Then Peso := '06.05.04.03.02.09.08.07.06.05.04.03.02.00';
IF Peso = '31' Then Peso := '00.00.00.10.09.08.07.06.05.04.03.02.00.00';
IF Peso = '32' Then Peso := '00.00.00.11.10.09.08.07.06.05.04.03.02.00';

{ Multiplica }

Base_3 := Copy( ( '0000000000000000' + Trim( Base_2 ) ), Length( ( '0000000000000000' + Trim( Base_2 ) ) ) - 13, 14 );

Soma_1 := 0;
Soma_2 := 0;

For Contador := 1 To 14 Do Begin

Valor_1 := ( StrToInt( Copy( Base_3, Contador, 01 ) ) * StrToInt( Copy( Peso, Contador * 3 - 2, 2 ) ) );

Soma_1 := Soma_1 + Valor_1;

IF Valor_1 > 9 Then Valor_1 := Valor_1 - 9;

Soma_2 := Soma_2 + Valor_1;

End;

{ Ajusta valor da soma }

IF Pos( Rotina, 'A2' ) > 0 Then Soma_1 := Soma_2;
IF Pos( Rotina, 'B0' ) > 0 Then Soma_1 := Soma_1 * 10;
IF Pos( Rotina, 'C1' ) > 0 Then Soma_1 := Soma_1 + ( 5 + 4 * StrToInt( Copy( Tabela, 6, 1 ) ) );

{ Calcula o Digito }

IF Pos( Rotina, 'D0' ) > 0 Then Digito := Soma_1 Mod Modulo;
IF Pos( Rotina, 'E12' ) > 0 Then Digito := Modulo - ( Soma_1 Mod Modulo);

IF Digito < 10 Then Resultado := IntToStr( Digito );
IF Digito = 10 Then Resultado := '0';
IF Digito = 11 Then Resultado := Copy( Tabela, 6, 1 );

{ Verifica o Digito }

IF ( Copy( Base_2, StrToInt( Copy( Tabela, 36 + ( Digitos * 3 ), 2 ) ), 1 ) <> Resultado ) Then Erro_3 := 1;

End;

End;

End;

End;

End;

{ Retorna o resultado da Verificação }

Retorno := FALSE;

IF ( Trim( Tabela_1 ) <> '' ) AND ( ERRO_1 = 0 ) Then Retorno := TRUE;
IF ( Trim( Tabela_2 ) <> '' ) AND ( ERRO_2 = 0 ) Then Retorno := TRUE;
IF ( Trim( Tabela_3 ) <> '' ) AND ( ERRO_3 = 0 ) Then Retorno := TRUE;

IF Trim( Inscricao ) = 'ISENTO' Then Retorno := TRUE;

Result := Retorno;

Except

Result := False;

End;

End;

{ Mascara_Inscricao __________________________________}

Function Mascara_Inscricao( Inscricao, Estado : String ) : String; Var

Mascara : String;

Contador_1 : Integer;
Contador_2 : Integer;

Begin

IF Estado = 'AC' Then Mascara := '**.***.***/***-**' ;
IF Estado = 'AL' Then Mascara := '*********' ;
IF Estado = 'AP' Then Mascara := '*********' ;
IF Estado = 'AM' Then Mascara := '**.***.***-*' ;
IF Estado = 'BA' Then Mascara := '******-**' ;
IF Estado = 'CE' Then Mascara := '********-*' ;
IF Estado = 'DF' Then Mascara := '***********-**' ;
IF Estado = 'ES' Then Mascara := '*********' ;
IF Estado = 'GO' Then Mascara := '**.***.***-*' ;
IF Estado = 'MA' Then Mascara := '*********' ;
IF Estado = 'MT' Then Mascara := '**********-*' ;
IF Estado = 'MS' Then Mascara := '*********' ;
IF Estado = 'MG' Then Mascara := '***.***.***/****' ;
IF Estado = 'PA' Then Mascara := '**-******-*' ;
IF Estado = 'PB' Then Mascara := '********-*' ;
IF Estado = 'PR' Then Mascara := '********-**' ;
IF Estado = 'PE' Then Mascara := '**.*.***.*******-*';
IF Estado = 'PI' Then Mascara := '*********' ;
IF Estado = 'RJ' Then Mascara := '**.***.**-*' ;
IF Estado = 'RN' Then Mascara := '**.***.***-*' ;
IF Estado = 'RS' Then Mascara := '***/*******' ;
IF Estado = 'RO' Then Mascara := '***.*****-*' ;
IF Estado = 'RR' Then Mascara := '********-*' ;
IF Estado = 'SC' Then Mascara := '***.***.***' ;
IF Estado = 'SP' Then Mascara := '***.***.***.***' ;
IF Estado = 'SE' Then Mascara := '*********-*' ;
IF Estado = 'TO' Then Mascara := '***********' ;

Contador_2 := 1;

Result := '';

Mascara := Mascara + '****';

For Contador_1 := 1 To Length( Mascara ) Do Begin

IF Copy( Mascara, Contador_1, 1 ) = '*' Then Result := Result + Copy( Inscricao, Contador_2, 1 );
IF Copy( Mascara, Contador_1, 1 ) <> '*' Then Result := Result + Copy( Mascara , Contador_1, 1 );

IF Copy( Mascara, Contador_1, 1 ) = '*' Then Contador_2 := Contador_2 + 1;

End;

Result := Trim( Result );

End;

{ Fim __________________________________ }

End.

Compactando tabelas paradox

// 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;

Função para buscar data e hora do arquivo

Function GetFileDate(Arquivo: String): String;
var
FHandle: integer;
begin
FHandle := FileOpen(Arquivo, 0);
try
Result := DateTimeToStr(FileDateToDateTime(FileGetDate(FHandle)));
finally
FileClose(FHandle);
end;
end;

Verificar se existe placa de som instalada

{Para testar se há uma placa de som instalada no sistema, use a função abaixo (retorna True se há uma placa de som; False em outro caso):}

function TestaSom : Boolean;
begin
Result := (WaveOutGetNumDevs > 0);
end;

Enviar arquivo para lixeira

//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;

Escondendo a barra de tarefas

Var
H:hwnd;
begin
H:= findwindow(NIL,'Project1');
if (H <> 0) then
showWindow(H,sw_hide);
end;

Validar cnpj e cpf

Unit CPFeCGC;

interface
function cpf(num: string): boolean;
function cgc(num: string): boolean;

implementation

uses SysUtils;

function cpf(num: string): boolean;
var
n1,n2,n3,n4,n5,n6,n7,n8,n9: integer;
d1,d2: integer;
digitado, calculado: string;
begin
n1:=StrToInt(num[1]);
n2:=StrToInt(num[2]);
n3:=StrToInt(num[3]);
n4:=StrToInt(num[4]);
n5:=StrToInt(num[5]);
n6:=StrToInt(num[6]);
n7:=StrToInt(num[7]);
n8:=StrToInt(num[8]);
n9:=StrToInt(num[9]);
d1:=n9*2+n8*3+n7*4+n6*5+n5*6+n4*7+n3*8+n2*9+n1*10;
d1:=11-(d1 mod 11);
if d1>=10 then d1:=0;
d2:=d1*2+n9*3+n8*4+n7*5+n6*6+n5*7+n4*8+n3*9+n2*10+n1*11;
d2:=11-(d2 mod 11);
if d2>=10 then d2:=0;
calculado:=inttostr(d1)+inttostr(d2);
digitado:=num[10]+num[11];
if calculado=digitado then
cpf:=true
else
cpf:=false;
end;

function cgc(num: string): boolean;
var
n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,n11,n12: integer;
d1,d2: integer;
digitado, calculado: string;
begin
n1:=StrToInt(num[1]);
n2:=StrToInt(num[2]);
n3:=StrToInt(num[3]);
n4:=StrToInt(num[4]);
n5:=StrToInt(num[5]);
n6:=StrToInt(num[6]);
n7:=StrToInt(num[7]);
n8:=StrToInt(num[8]);
n9:=StrToInt(num[9]);
n10:=StrToInt(num[10]);
n11:=StrToInt(num[11]);
n12:=StrToInt(num[12]);
d1:=n12*2+n11*3+n10*4+n9*5+n8*6+n7*7+n6*8+n5*9+n4*2+n3*3+n2*4+n1*5;
d1:=11-(d1 mod 11);
if d1>=10 then d1:=0;
d2:=d1*2+n12*3+n11*4+n10*5+n9*6+n8*7+n7*8+n6*9+n5*2+n4*3+n3*4+n2*5+n1*6;
d2:=11-(d2 mod 11);
if d2>=10 then d2:=0;
calculado:=inttostr(d1)+inttostr(d2);
digitado:=num[13]+num[14];
if calculado=digitado then
cgc:=true
else
cgc:=false;
end;

end.

Apagar arquivos via ms-dos

WinExec('Command.com /c Del c: emp*.tmp', 0)

Alterando o nome de volume (label) de um disco

Inclua na seção uses: Windows

{ Da unidade C: }

SetVolumeLabel('c:', 'NovoLabel');

{ Da unidade atual: }

SetVolumeLabel(nil, 'NovoLabel');

Função para abreviar nomes

Function AbreviaNome(Nome: String): String;
var
Nomes: array[1..20] of string;
i, TotalNomes: Integer;
begin
Nome := Trim(Nome);
Result := Nome;
{Insere um espaço para garantir que todas as letras sejam testadas}
Nome := Nome + #32;
{Pega a posição do primeiro espaço}
i := Pos(#32, Nome);
if i > 0 then
begin
TotalNomes := 0;
{Separa todos os nomes}
while i > 0 do
begin
Inc(TotalNomes);
Nomes[TotalNomes] := Copy(Nome, 1, i - 1);
Delete(Nome, 1, i);
i := Pos(#32, Nome);
end;
if TotalNomes > 2 then
begin
{Abreviar a partir do segundo nome, exceto o último.}
for i := 2 to TotalNomes - 1 do
begin
{Contém mais de 3 letras? (ignorar de, da, das, do, dos, etc.)}
if Length(Nomes[i]) > 3 then
{Pega apenas a primeira letra do nome e coloca um ponto após.}
Nomes[i] := Nomes[i][1] + '.';
end;
Result := '';
for i := 1 to TotalNomes do
Result := Result + Trim(Nomes[i]) + #32;
Result := Trim(Result);
end;
end;
end;

Desligando e reiniciando o windows

{Nesta dica veremos como desligar e reiniciar o Windows. Os passos necessários para implementá-lo são os seguintes:

1) Inclua no seu formulário dois componentes do tipo Button;

2) Escreva o código a seguir, de forma que a sua Unit se pareça com o texto abaixo:}

unit Unit1;

interface

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

type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
Function DesligarMeuWindows(RebootParam: Longword): Boolean;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

{ TForm1 }

function TForm1.DesligarMeuWindows(RebootParam: Longword): Boolean;
var
TTokenHd: THandle;
TTokenPvg: TTokenPrivileges;
cbtpPrevious: DWORD;
rTTokenPvg: TTokenPrivileges;
pcbtpPreviousRequired: DWORD;
tpResult: Boolean;
const
SE_SHUTDOWN_NAME = 'SeShutdownPrivilege';
begin
if Win32Platform = VER_PLATFORM_WIN32_NT then
begin
tpResult := OpenProcessToken(GetCurrentProcess(),
TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY,
TTokenHd);
if tpResult then
begin
tpResult := LookupPrivilegeValue(nil, SE_SHUTDOWN_NAME, TTokenPvg.Privileges[0].Luid);
TTokenPvg.PrivilegeCount := 1;
TTokenPvg.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
cbtpPrevious := SizeOf(rTTokenPvg);
pcbtpPreviousRequired := 0;
if tpResult then
Windows.AdjustTokenPrivileges(TTokenHd, False, TTokenPvg, cbtpPrevious, rTTokenPvg, pcbtpPreviousRequired);
end;
end;
Result := ExitWindowsEx(RebootParam, 0);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
DesligarMeuWindows(EWX_POWEROFF or EWX_FORCE);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
DesligarMeuWindows(EWX_REBOOT or EWX_FORCE);
end;

end.