Piscando um componente TLabel

// Coloque um componente Ttimer no form
// No evento Ontimer do Timer digite

Timer1.Interval := 500;
Label1.Visible := not Label1.visible;

Apresentando mensagem de confirmação para deleção de registro

//No evento BeforeDelete do componente TTable digite

if MessageDlg('Confirma a exclusão ?', mtConfirmation, [mbYes,mbNo], 0)<>mrYes then
Abort;

Executando o comando ARJ em um aplicativo Delphi

WinExec('command.com /c Arj a -vva -jm -p1 -r a:copia.arj + Arj C:\Meus Documentos\*.* A:/copia.arj', WS_MAXIMIZE); //(obs: para descompactar use Arj x -vva -jm -p1 -r)

Executando o comando ARJ em um aplicativo Delphi

WinExec('command.com /c Arj a -vva -jm -p1 -r a:copia.arj + Arj C:\Meus Documentos\*.* A:/copia.arj', WS_MAXIMIZE);

//(obs: para descompactar use Arj x -vva -jm -p1 -r)

Formatando disquetes 3½

Uses ShellApi;

WinExec(PChar('command.com /c format a: /v'),SW_SHOWNORMAL);

// SW_SHOWNORMAL - Exibe janela em estado normal.
// SW_SHOWMAXIMIZED - Exibe a janela em estado maximizado.
// SW_SHOWMINIMIZED - Exibe janela em estado minimizado.

Fechar um Form com ESC

No evento OnKeyDown do TForm digite:

if (Key=VK_ESCAPE) then
begin
close;
end;

Filtragem de dados sem as aspas em um componente TEdit com o comando SQL

Query1.Close;
Query1.Sql.Clear;
Query1.Sql.Add('Select * From Prova Where Nota Like '+''''+'%'+ Edit1.Text + '%'+'''');
Query1.Open;

Checkboxes em Grids

Conheceremos uma maneira muito fácil e simples para colocar um CheckBox em um StringGrid ou DBGrid.

Para fazer este exemplo vamos precisar de um StringGrid e um ImageList.

Bom antes que muito perguntem o porque do ImageList vou explicar: Podemos utilizar o canvas para desenhar um CheckBox no Grid, porém com o ImageList podemos variar a imagem do CheckBox como quisermos!

É bem simples. Faça o desenho do seu CheckBox como quiser (uma imagem do checkBox checado e a outra não), e coloque as duas no ImageList.

Vamos trabalhar em cima da propriedade OnDrawCell, que é a responsável por desenhar cada célula do grid.

Neste evento temos as variaveis ARow (Linha), Acol (Coluna) e Rect (área de cada célula identificada por ARow e Acol).

Neste exemplo eu coloquei o "index 0" do ImageList com a imagem checada e o "index 1" como não checada.

Veja o código abaixo: se a Coluna(ACol) for igual a 1 ,ou seja, a segunda coluna, e Linha (ARow) maior que "0" (não sendo o titulo), então ele testa se nesta célula tem o texto ' .' (que eu em particular escolhi, para representar o valor verdadeiro). Então ele desenha o CheckBox já "Checado", e caso esteja vazia a celula (''), desenha o checkBox não checado!.

As variáveis Rect.Left e Rect.Top representam o lugar onde o checkbox será desenhado dentro da celula.

procedure TForm1.GridDrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
var
R: TRect;
begin
if (Acol = 1) and (ARow > 0) then
if Grid.Cells[ACol,ARow] = ' .' then
ImageList1.Draw(Grid.Canvas, Rect.Left+4, Rect.Top+4, 0)
else
if Grid.Cells[ACol,ARow] = '' then
ImageList1.Draw(Grid.Canvas, Rect.Left+4, Rect.Top+4, 1);
end;

Arquivos ini no delphi

// uses inifiles;

var arqini: tinifile;

procedure TForm1.Button2Click(Sender: TObject); //Gravar ini
var
arqini: tinifile;
vNom: string;
begin
arqini:= tinifile.create('D:\Teste.ini');
vNom:= edit1.text;
try
arqini.writestring('String','Nome',vNom);
arqini.writebool('Boolean','Condicao',True);
arqini.WriteInteger('Integer','Vidas',5);
finally
arqini.free;
end;
end;

procedure TForm1.Button3Click(Sender: TObject); // ler ini
var
texto: string;
numero: integer;
vNom: string;
begin
arqini:= tinifile.create('D:\Teste.ini');
try
texto:= arqini.readstring('String','Nome',vNom);
arqini.readbool('Boolean','Condicao',True);
numero:= arqini.readInteger('Integer','Vidas',5);
finally
arqini.free;
end;
label1.Caption:= texto;
label2.caption:= inttostr(numero);

end;

Criar um campo autoincremento no Interbase

CREATE GENERATOR "GEN_CLI";
SET TERM ^:
CREATE TRIGGER "NEXCLI" for "DADOS"
ACTIVE BEFORE INSERT POSITION 0
AS
BEGIN
New.Codigo = GEN_ID(GEN_CLI,1);
END

Interbase em rede

Usando o IBX:

Para todos os exemplos abaixo usarei como o nome do servidor onde está instalado o INTERBASE "SERVER_IB" e o banco de dados estará instalado no path "C:\IB_DB\GUESTS.GDB" o caminho c:\ib_db\guests.gdb REFERE-SE A UNIDADE C: DO SERVIDOR E NÃO DAS ESTAÇÕES.
Arquivo Hosts.sam

Procure o arquivo HOSTS.SAM no diretório windows das máquinas clientes , este arquivo deverá ser configurado da seguinte maneira:
Caso o ip do servidor seja 192.198.25.4

então coloque em uma linha do arquivo hosts.sam

192.198.25.4 SERVIDOR

Agora abra o delphi, e no componente TIBDatabase na propriedade DatabaseName coloque a seguinte string de conexão:
SERVER_IB:C:\IB_DB\GUESTS.GDB
Informe na propriedade PARAMS do TIBDATABASE as seguintes strings:
user_name = SYSDBA
password=masterkey ( isto se você não mudou a senha do SYSDBA caso contrário coloque a nova senha.
atribua para FALSE a propriedade LOGIN PROMPT
Coloque um TIBTransaction e na propriedade DefaultTransaction do TIBDatabase atribua ao componente TIBTransaction.
clique no componente TIBTransaction e na propriedade DEFAULTDATABASE coloque o TIBDATABASE.
agora dê um clique duplo no componente TIBTransaction e sete o nível de transação para READ COMMITED e retire o parâmetro no wait ( para não acontecer o dead lock em caso de multiplas edições do registro )
Teste através da propriedade Connected do TIBDATABASE se está ok.

Usando o BDE

Abra o BDE ADMINISTRATOR
no menu OBJECT escolha NEW e escolha o drive INTRBASE. ( se não estiver presente instale novamente o BDE escolhendo uma instalação completa dos drives SQL LINKS )
Na propriedade SERVER NAME coloque SERVER_IB:C:\IB_DB\GUESTS.GDB
Abra o delphi coloque um TDatabase e escolha em ALIASNAME coloque o nome do alias que voce definiu no bde administrador em database name escolha um nome para o componente.
Os objetos ttable , tquery usarão o nome do TDatabase e não o alias name.


Usando o IB OBJECTS ( IBO )

Database=SERVER_IB:C:\IB_DB\GUESTS.GDB UserName=SYSDBA Password=masterkey
use o TIBODataBase para fazer a conexão.

Conectando a um servidor LINUX

A entrada no arquivo HOSTS.SAM é a mesma ex:

10.0.0.2 SERVER_LINUX #SERVIDOR LINUX

Apenas você terá que mudar o path do arquivo GDB. A string é case sensitive o Linux não usa letras de drives para conexão ex:

SERVER_LINUX:/var/ib_db/guests.gdb

Criar Banco de Dados no Interbase

CREATE DATABASE "c:\meus documentos\biblioteca.gdb"
USER "SYSDBA" PASSWORD "masterkey";

CONNECT "c:\meus documentos\biblioteca.gdb"
USER "SYSDBA" PASSWORD "masterkey";

CREATE DOMAIN DALUNO_ID INTEGER NOT NULL;
CREATE DOMAIN DLIVRO_ID INTEGER NOT NULL;
CREATE DOMAIN DEMPRESTIMO_ID INTEGER NOT NULL;
CREATE DOMAIN DITENS_ID INTEGER;

CREATE TABLE ALUNO
(ALUNO_ID DALUNO_ID,
NOME VARCHAR(20) NOT NULL,
ENDERECO VARCHAR(30) NOT NULL,
TELEFONE VARCHAR(15),
TURMA CHAR(3),
CONSTRAINT ALUNO_CHAVE_PRIM PRIMARY KEY (ALUNO_ID));

CREATE TABLE LIVRO
(LIVRO_ID DLIVRO_ID,
TITULO VARCHAR(20) NOT NULL,
ASSUNTO VARCHAR(10),
CONSTRAINT LIVRO_CHAVE_PRIM PRIMARY KEY (LIVRO_ID));

CREATE TABLE EMPRESTIMO
(EMPRESTIMO_ID DEMPRESTIMO_ID,
ALUNO_ID DALUNO_ID,
DATA_EMPRESTIMO DATE DEFAULT 'NOW' NOT NULL,
DATA_DEVOLUCAO DATE,
DEVOLVIDO CHAR(3) DEFAULT 'NAO',
CONSTRAINT EMPRESTIMO_CHAVE_PRIM PRIMARY KEY (EMPRESTIMO_ID),
CONSTRAINT EMPRESTIMO_CHAVE_EST FOREIGN KEY (ALUNO_ID) REFERENCES ALUNO);

CREATE TABLE ITENS
(LIVRO_ID DLIVRO_ID,
EMPRESTIMO_ID DEMPRESTIMO_ID,
ITENS_ID DITENS_ID,
CONSTRAINT ITENS_CHAVE_PRIM PRIMARY KEY (LIVRO_ID, EMPRESTIMO_ID));

EXIT;

Mudar a cor de dbgrid conforme o conteúdo

//muda a cor somente da célula
procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
if (Column.Field.FieldName = 'Pago') then
begin
if table1.FieldByName('pago').AsString = 'sim' then
begin
dbgrid1.Canvas.Font.Color := clBlue;
dbgrid1.Canvas.Font.Style :=[fsBold];
dbgrid1.Canvas.FillRect(Rect);
dbgrid1.DefaultDrawColumnCell(Rect, DataCol, Column, State);
end
else
begin
dbgrid1.Canvas.Font.Color:= clRed;
dbgrid1.Canvas.FillRect(Rect);
dbgrid1.DefaultDrawColumnCell(Rect, DataCol, Column, State);
end;
end;
end;

//muda a cor de toda a linha
procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect;
Field: TField; State: TGridDrawState);
begin
if table1.FieldByName('pago').AsString = 'sim' then
begin
dbgrid1.Canvas.Font.Color := clBlue;
dbgrid1.Canvas.Font.Style :=[fsBold];
dbgrid1.Canvas.FillRect(Rect);
dbgrid1.DefaultDrawDataCell(Rect,Field,State);
end
else
begin
dbgrid1.Canvas.Font.Color:= clRed;
dbgrid1.Canvas.FillRect(Rect);
dbgrid1.DefaultDrawDataCell(Rect,Field,State);
end;
end;

Impressão com o tprinter

Procedure TForm1.BitBtn1Click(Sender: TObject);
var
Linha:integer;
Tamanho:integer;
Coluna:integer;
begin
Printer.Orientation := poLandscape;
Printer.BeginDoc;
Printer.Canvas.Pen.Width := 5;
Printer.Canvas.Font.Name := 'Times New Roman';
Printer.Canvas.Font.Size := 10;
Linha := 20;
Coluna:= 20;
Tamanho := Printer.Canvas.TextWidth('a');
Table1.First;
while not Table1.Eof do
begin
if Linha = 20 then
begin
Coluna := 20;
Printer.Canvas.TextOut(0,Linha,'Relação de Clientes');
Linha := Linha - Printer.Canvas.Font.Height + 5 ;
Printer.Canvas.TextOut(Coluna,Linha,'Cod');
Coluna:= Coluna + (Tamanho * 5 );
Printer.Canvas.TextOut(Coluna,Linha,'Nome');
Coluna:= Coluna + (Tamanho * 30);
Printer.Canvas.TextOut(Coluna,Linha,'Endereço');
Coluna:= Coluna + (Tamanho * 30);
Linha := Linha - Printer.Canvas.Font.Height + 5 ;
end;
Coluna := 20 ;
Printer.Canvas.TextOut(Coluna,Linha,Table1. FieldByName('Codigo').AsString);
Coluna:= Coluna + (Tamanho * 5 );
Printer.Canvas.TextOut(Coluna,Linha,Table1. FieldByName('Nome').AsString);
Coluna:= Coluna + (Tamanho * 30);
Printer.Canvas.TextOut(Coluna,Linha,Table1. FieldByName('End').AsString);
Coluna:= Coluna + (Tamanho * 30);
Linha := Linha - Printer.Canvas.Font.Height + 5 ;
Table1.Next;
if Linha > Printer.PageHeight-20 then
Begin
Printer.NewPage;
Linha := 20;
end;
end;
Printer.EndDoc;
end;

Definindo o tamanho Mínimo e Máximo do Form

procedure TForm1.WMGetMinMaxInfo(var MSG: TMessage);
begin
inherited;
with PMinMaxInfo(MSG.lparam)^ do
begin
ptMinTRackSize.X := 300;
ptMinTRackSize.Y := 150;
ptMaxTRackSize.X := 350;
ptMaxTRackSize.Y := 250;
end;
end;

Carregando um cursor animado

procedure TForm1.Button2Click(Sender: TObject);
const cnCursorID = 1;
begin
Screen.Cursors[cnCursorID]:=LoadCursorFromFile( 'drive:\caminho\arquivo.ani' );
Cursor := cnCursorID;
end;

Alterar atributos de um arquivo

var Attrib: integer;
begin
Attrib:=FileGetAttr('C:\ARQUIVO.XYZ');
if Attrib<>-1 then
begin
Attrib:=Attrib and not faReadOnly;
if FileSetAttr('C:\ARQUIVO.XYZ', Attrib)=0 then
Alteração Efetuada
else Windows code error;
end;
end;

Converte um número binário para inteiro

function BinToInt(Value: String): LongInt;
var i,Size: Integer;
begin
Result := 0;
Size := Length(Value);
for i:=Size downto 0 do
if Copy(Value,i,1)='1' then
Result := Result+(1 shl i);
end;

Obtendo o número serial do HD

function SerialNumber(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;

Obtendo a letra do drive de CD-ROM

function FindFirstCDROMDrive: 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;

Testando se a impressora está OnLine

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;

Obtendo a Data e a Hora 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;

Abrindo e Fechando a bandeja do drive de CD-ROM

//Para Abrir:
mciSendString('Set cdaudio door open wait', nil, 0, handle);

//Para Fechar:
mciSendString('Set cdaudio door close wait', nil, 0, handle);

Fazendo uma janela filha de outra sem usar MDI

procedure TForm2.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);

with Params do
begin
Style := Style or WS_CHILD;
WndParent := Application.MainForm.Handle;
end;
end;

Função para formatar disquetes

{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'

// como usar:

procedure TForm1.button1Click(Sender: TObject);
var retCode: LongInt;
begin
retCode:= SHFormatDrive(Handle, 0, SHFMT_ID_DEFAULT, SHFMT_OPT_QUICKFORMAT);
if retCode < style="color: rgb(0, 0, 153);">then ShowMessage('Could not format drive');
end;

ZERAR o valor de um campo Auto-Incremento

function ResetAutoInc(FileName: TFileName; Base: Longint): Boolean;
//FileName é o nome da tabela, incluindo o caminho. Base é novo valor
begin
with TFileStream.Create(FileName, fmOpenReadWrite) do
Result:=(Seek($49,soFromBeginning)=$49)and(Write(Base,4)=4);
end;

Como deletar uma pasta com arquivos e subpastas dentro

procedure DeletaDir(const RootDir:string);
var
SearchRec: tSearchREC;
Erc:Integer;
Begin
try
{$I-}
ChDir(rootdir);
if IOResult <> 0 then
Exit;
FindFirst('*.*', faAnyFile, SearchRec);
Erc:=0;
while Erc=0 do
begin
if ((searchRec.Name <> '.') and (searchrec.Name<>'..')) then
if (SearchRec.Attr and faDirectory>0) then
DeletaDir(SearchRec.Name)
Else DeleteFile(Searchrec.Name);
Erc:=FindNext ( SearchRec);
Application.ProcessMessages;
end;
finally
If Length (RootDir)>3 then
Chdir('..');
end;
RmDir(rootDir);
{$I+}
End;

Linha e coluna do cursor em um MEMO

Procedure PosicaoMemo (M : TMemo; Var Linha, Coluna : Integer);
Begin
Linha := M.Perform (EM_LINEFROMCHAR, M.SelStart, 0);
Coluna := M.SelStart - M.Perform (EM_LINEINDEX, Linha, 0);
End;

Função para tornar o FORM Não-Retangular

procedure TForm1.FormResize;
var Region : HRGN;
begin
Region := CreateEllipticRgn(0,0,width,height);
SetWindowRgn(Handle, Region, True);
end;

Função ocultar o Botão Iniciar

procedure EscondeIniciar(Visible:Boolean);
Var taskbarhandle, buttonhandle : HWND;
begin
taskbarhandle := FindWindow('Shell_TrayWnd', nil);
buttonhandle := GetWindow(taskbarhandle, GW_CHILD);
if Visible then
ShowWindow(buttonhandle, SW_RESTORE)
else ShowWindow(buttonhandle, SW_HIDE);
end;

Função ocultar a Barra de Tarefas

procedure SetTaskBar(Visible: Boolean);
var
wndHandle : THandle;
wndClass : array[0..50] of Char;
begin
StrPCopy(@wndClass[0],'Shell_TrayWnd');
wndHandle := FindWindow(@wndClass[0], nil);
If Visible = True then
ShowWindow(wndHandle, SW_RESTORE)
else ShowWindow(wndHandle, SW_HIDE);
end;

Função de Criptografia de 32 Bits

//Para criptografar passe como paramêtros 3 valores inteiros quaisquer.
//Para reverter a criptografia utilize os mesmos valores

{$R-} {$Q-}
function EncryptSTR(const InString:string; StartKey,MultKey,AddKey:Integer): string;
var I : Byte;
begin
Result := '';
for I := 1 to Length(InString) do
begin
Result := Result + CHAR(Byte(InString[I]) xor (StartKey shr 8));
StartKey := (Byte(Result[I]) + StartKey) * MultKey + AddKey;
end;
end;

function DecryptSTR(const InString:string; StartKey,MultKey,AddKey:Integer): string;
var I : Byte;
begin
Result := '';
for I := 1 to Length(InString) do
begin
Result := Result + CHAR(Byte(InString[I]) xor (StartKey shr 8));
StartKey := (Byte(InString[I]) + StartKey) * MultKey + AddKey;
end;
end;
{$R+} {$Q+}

Saber qual a impressora padrão do Windows

//Declare a unit Printers na clausula uses

function CorrentPrinter :String;
var
Device : array[0..255] of char;
Driver : array[0..255] of char;
Port : array[0..255] of char;
hDMode : THandle;
begin
Printer.GetPrinter(Device, Driver, Port, hDMode);
Result := Device+' na porta '+Port;
end;

---

Capturar a tela em um TBitmap

function CaptureScreenRect(ARect: TRect): TBitmap;
var ScreenDC: HDC;
begin
Result := TBitmap.Create;
with Result, ARect do
begin
Width := Right - Left;
Height := Bottom - Top;
ScreenDC := GetDC(0);
try BitBlt(Canvas.Handle,0,0,Width,Height,ScreenDC,Left,Top,SRCCOPY);
finally
ReleaseDC(0,ScreenDC);
end;
end;
end;

//Como usar:
//Image1.picture.Assign(CaptureScreenRect(Rect(0,0,Width,Height)));

---

. Copiar um arquivo de um lugar para outro

Procedure CopyFile( Const sourcefilename, targetfilename: String );
Var S, T: TFileStream;
Begin
S := TFileStream.Create( sourcefilename, fmOpenRead );
try
T := TFileStream.Create(targetfilename,fmOpenWrite or fmCreate);
try
T.CopyFrom(S, S.Size ) ;
finally
T.Free;
end;
finally
S.Free;
end;
end;

Retorna o Nome do Usuário logado na rede

//Declare Registry na clausula uses da unit

function LogUser : String;
var Registro: TRegistry;
begin
Registro := TRegistry.Create;
Registro.RootKey := HKEY_LOCAL_MACHINE;
if Registro.OpenKey('Network\Logon', false) then
result := Registro.ReadString('username');
Registro.Free;
end;

Retorna o IP da Máquina

// Declare a Winsock na clausula uses da unit

function GetIP:string;
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
Result:=Format('%d.%d.%d.%d',[Byte(h_addr^[0]),
Byte(h_addr^[1]),Byte(h_addr^[2]),Byte(h_addr^[3])]);
WSACleanup;
end;

Desconectar uma unidade de rede mapeada

function DesconectaRede(Unidade:Pchar;ForcaCancel:boolean):String;
begin
WNetCancelConnection2(Unidade,0,ForcaCancel);
Case GetLastError() of
1205: Result := 'Não foi possível abrir o perfil';
1206: Result := 'Perfil do usuário não encontrado ou inválido';
1208: Result := 'Ocorreu um Erro específico na rede';
2138: Result := 'Rede não encontrada ou fora do ar';
2250: Result := 'Mapeamento inválido ou não encontrado';
2401: Result := 'Existem muitos arquivos abertos';
else Result := 'Unidade disconectada com sucesso';
end;
end;

Destravar as teclas: Alt+Tab, Ctrl+Esc, Ctrl+Alt+Del

var OldValue : LongBool;
begin
SystemParametersInfo(97, Word(False), @OldValue, 0);
end;

Travar as teclas: Alt+Tab, Ctrl+Esc, Ctrl+Alt+Del

var OldValue : LongBool;
begin
SystemParametersInfo(97, Word(True), @OldValue, 0);
end;

Executar Pack em Tabelas Paradox

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;

Esconder a aplicação da barra de tarefas

var H : HWnd;
begin
H := FindWindow(Nil,'Project1');
if H <> 0 then
ShowWindow(H,SW_HIDE);
end;

Trocar a resolução do vídeo

function TrocaResolucao(X, Y: word): Boolean;
var lpDevMode: TDeviceMode;
begin
if EnumDisplaySettings(nil, 0, lpDevMode) then
begin
lpDevMode.dmFields := DM_PELSWIDTH Or DM_PELSHEIGHT;
lpDevMode.dmPelsWidth := X;
lpDevMode.dmPelsHeight:= Y;
Result := ChangeDisplaySettings(lpDevMode, 0) = DISP_CHANGE_SUCCESSFUL;
end;
end;

Mostrar o nome do computador

function NomeComputador : String;
var
lpBuffer : PChar;
nSize : DWord;
const Buff_Size = MAX_COMPUTERNAME_LENGTH + 1;
begin
nSize := Buff_Size;
lpBuffer := StrAlloc(Buff_Size);
GetComputerName(lpBuffer,nSize);
Result := String(lpBuffer);
StrDispose(lpBuffer);
end;

Desabilitar o botão Fechar do Form

procedure TForm1.FormCreate(Sender: TObject);
var
hwndHandle : THANDLE;
hMenuHandle : HMenu;
begin
hwndHandle := Self.Handle;
if (hwndHandle <> 0) then
begin
hMenuHandle := GetSystemMenu(hwndHandle, FALSE);
if (hMenuHandle <> 0) then
DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND);
end;

end;

Limpar todos Edits do Form

var contador : integer;
begin
for contador := 0 to (Form1.ControlCount - 1) do
if Form1.Controls[contador].ClassName = 'TEdit' then
(Form1.Controls[contador] as TEdit).Text := '';
end;

Zerar Generator no Interbase

SET GENERATOR NOMEDESUAGENERATOR TO 0;

Instalar o Quick Report no Delphi 7

1. Abra o Delphi;
2. Menu: Component > Install Packages;
3. Clique no botão Add ou teclas ALT+A;
4. Localize a pasta bin dentro da pasta de instalação do Delphi, o
caminho se não foi alterado, geralmente é: C:\Arquivos de
programas\Borland\Delphi7\Bin;
5. Localize um pacote com o nome: "dclqrt70.bpl", selecione e clique
no botão abrir;
6. Pressione o botão ok

Validar CPF

//O CPF deve ser digitado no formato '000.000.000-00'

Function CPF(num: string): boolean;
var
n1,n2,n3,n5,n6,n7,n9,n10,n11: integer;
d1,d2: integer;
digitado, calculado: string;
begin
n1:=StrToInt(num[1]);
n2:=StrToInt(num[2]);
n3:=StrToInt(num[3]);
n5:=StrToInt(num[5]);
n6:=StrToInt(num[6]);
n7:=StrToInt(num[7]);
n9:=StrToInt(num[9]);
n10:=StrToInt(num[10]);
n11:=StrToInt(num[11]);
d1:=n11*2+n10*3+n9*4+n7*5+n6*6+n5*7+n3*8+n2*9+n1*10;
d1:=11-(d1 mod 11);
if d1>=10 then
d1:=0;
d2:=d1*2+n11*3+n10*4+n9*5+n7*6+n6*7+n5*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[13]+num[14];
if (calculado=digitado) then
cpf:=true
else
cpf:=false;
end;


//Como usar

procedure TForm1.Button1Click(Sender: TObject);
begin
If NOT cpf(edit1.text) then
Begin
messagebox(Application.Handle, Pchar ('O CPF ' +edit1.Text+ 'não é válido, deseja continuar assim mesmo?'), 'Atenção', MB_OK+MB_ICONWARNING+MB_DEFBUTTON1);
edit1.SetFocus;
end;
end;

Código de Barras 2x5i

//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';
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);
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(Edit1.text,Image1.Canvas);
end;

Função para calcular o IMC

Function CalculoIMC(Peso : real; Altura : Real) : string;
var
imc : real;
begin
try
altura := sqr(altura);
imc := peso/altura;
if (imc > 0) and (imc < 18.5)
then begin
result := 'Abaixo do Peso';
end else
if (imc >= 18.5) and (imc <= 24.9)
then begin
result := 'Peso Normal';
end else
if (imc >= 25) and (imc <= 29.9)
then begin
result := 'Sobrepeso';
end else
if (imc >= 30) and (imc <= 34.9)
then begin
result := 'Obesidade Grau I';
end else
if (imc >= 35) and (imc <= 39.9)
then begin
result := 'Obesidade Grau II';
end else
if (imc > 40)
then begin
result := 'Obesidade Grau III';
end;
except
result := 'Indefinido';
messagedlg('Ocorreu um erro durante o cálculo do IMC!' + #13 +
'Verifique se o peso e a altura da pessoa' + #13 +
'foram informados corretamente!' , MTERROR, [MBOK],0);
abort;
end;
end;
// para chamar a função

procedure TForm1.Button1Click(Sender: TObject);
begin
Label4.caption:= CalculoIMC(strtofloat(edit1.text),strtofloat(edit2.Text));
end;

Mudar a cor do progressbar

//Adicionar CommCtrl no uses.

SendMessage(ProgressBar1.Handle, PBM_SETBARCOLOR, 0, rgb(155,100,255));