Delphi - Tudo o que você queria saber: novembro 2009

quarta-feira, 25 de novembro de 2009

Para converter corretamente caracteres do dos para win

Function JOemToAnsiStr(const OemStr: string): string;
begin
SetLength(Result, Length(OemStr));
if Length(Result) > 0 then
{$IFDEF WIN32}
OemToCharBuff(PChar(OemStr), PChar(Result), Length(Result));
{$ELSE}
OemToAnsiBuff(@OemStr[1], @Result[1], Length(Result));
{$ENDIF}
end;

Exemplo
var
Variavel: String;
begin
//Pode pegar por exemplo de uma variável DOS q venha de um DBF e converter para o padrão Win
Variavel := JOemToAnsiStr('Texto em DOS');
...

P. 1140

Protegendo uma aplicação com uma senha armazenada na própria aplicaçati

// Evento OnCreate do Form
procedure TForm1.FormCreate(Sender: TObject);
var
Senha : String;
OK : Boolean;
Tentativa : integer;
begin
Tentativa := 0;
OK := False;
while (Tentativa < 3) do
begin
InputQuery(‘Digite a sua senha’, ‘Você tem ‘ + IntToStr(3 - Tentativa) + ‘ tentativas’, senha);
if (senha = ‘Senha’) then
begin
OK := True;
Break;
end;
Inc(Tentativa);
end;
if not OK then
begin
ShowMessage(‘Tentativas excedidas. Pressione OK para terminar.’);
Application.Terminate;
end;
end;

Uma boa forma de usar mdichild

{Quando uso este recurso nas minhas aplicações eu consigo reduzir em muito o tempo de carregamento do software, sendo assim, resolvi partilhar com todos.

É simples, baseada em uma função (FormExiste), que verifica se um form (MDIChild) já existe na memória. Se existir ele somente dá o foco ao mesmo, senão ele o cria e o deixa na tela pronto para funcionar...

Deixando de conversa, vamos ao código!}

//Função de reconhecimento de MDIChilds
function FormExiste(NomeJanela : TForm) : Boolean;
//Função declarada

//Implementando a função
function TForm1.FormExiste (NomeJanela : TForm) : Boolean;
var i : integer;
begin
formexiste := false;
for i := 0 to ComponentCount -1 do
if Components[i] is TForm then
if TForm(Components[i]) = NomeJanela then
FormExiste := true;
end;

{Para fazer uso correto da função você deve
seguir o exemplo do procedimento abaixo}
procedure TForm1.Button1Click(Sender: TObject);
begin
if FormExiste(frmAlunos) = false then
begin
Screen.Cursor := crhourGlass;
Form2 := TForm2.Create(Self);
Screen.Cursor := crDefault;
end
Else
if FormExiste(Form2 then
begin
Form2.WindowState := wsNormal;
Form2.BringToFront;
Form2.SetFocus;
end;
end;

{Certo?

Espero ter ajudado!

Evaldo Barbosa
evaldobarbosa@hotmail.com}

Criando formulários no formato de bola

{Para criar uma janela não retangular, você deve criar uma Região do Windows e usar a função da API SetWindowRgn, desta maneira (isto funciona apenas em D2/D3):}
var hR : THandle;

begin
// Cria uma Região elíptica
hR := CreateEllipticRgn(0,0,100,200);
SetWindowRgn(Handle,hR,True);
end;

Criando evento em tempo de execução

Memo.onchange := memo1Change;

procedure TForm1.Memo1Change(Sender: TObject);
begin
panel1.caption:='Conteúdo alterado';
end;

Criando e excluindo tfields em tempo de execução

{Objetos TField (e seus descendentes) podem ser criados em tempo de desenvolvimento através do Fields Editor.

O Fileds Editor é acionado quando damos um clique duplo no componente de acesso a dados, ou seja, TTable ou TQuery. Mas nós podemos fazer isto em tempo de execução também.

Descendentes do TField componente (como TStringField, TIntegerField, etc.) são criados para que possamos chamar o métodos Create para o tipo de campo desejado.

Após criar o componente, precisamos especificar algumas propriedades para que a conexão com os dados funcione e assim poderemos alterar dados das tabelas. São
eles:

FieldName: nome do campo na tabela.
Name: nome do componente, usado pelo Delphi.
Index: É um número de identificação para o campo. Este número nunca é repetido,
automaticamente é controlado pelo Delphi.}
DataSet: O componente TTable ou TQuery ao qual queremos associar o campo.

O Código abaixo mostra a criação de um campo String. Usaremos o Objeto Query1
para nos referenciarmos ao DataSet.

procedure TForm1.Button2Click(Sender: TObject);
var T: TStringField;

begin
Query1.Close;

T := TStringField.Create(Self);
T.FieldName := 'CO_NAME';
T.Name := Query1.Name + T.FieldName;
T.Index := Query1.FieldCount;
T.DataSet := Query1;

Query1.FieldDefs.UpDate;
Query1.Open;
end;

Note que é necessário fechar o DataSet(Query1) antes de adicionarmos o novo campo.

Usamos a propriedade "Fieldcount" para definir o número da chave do campo criado, usando esta propriedade obteremos o número de TFileds que o DataSet(Query1) possui no momento, assim sempre estaremos criando um campo novo, pois se o primeiro começa com 0

Excluir um campo é bem mais simples, para isto basta criar um instância do tipo TComponent, e usar a função FindComponent para referenciá-lo ao objeto, para isto basta sabermos o nome do Objeto. A exclusão é feita através do método Free.

procedure TForm1.Button1Click(Sender: TObject);
var TC: TComponent;

begin
TC := FindComponent('Query1CO_NAME');
if not (TC = nil) then
begin
Query1.Close;
TC.Free;
Query1.Open;
end;
end;

Copiando registros de uma tabela para outra incluindo valores

NULL
procedure TtableCopiaRegistro(Origem, Destino: Ttable);
begin
with TabelaOrig do
begin
for i := 0 to FieldCount -1 do
if not Fields[i].IsNull then TabelaDest.Fields[i].Assign(Fields[i]);
end;
end;

Convertendo valores

{No delphi podemos ler um campo armazenado numa tabela, alterando seu tipo, ou seja, podemos ler um campo numérico, por exemplo, como um campo string, e vice-versa. Este recurso é útil e prático, pois permite maior agilidade e menos programação.

Exemplo:

Se quisermos converter um campo numérico armazendo em Tabela1 para string, armazenando-o na variável S, podemos fazer o seguinte:}

S:=tabela1.camponumerico.asstring;

{Pode-se utilizar as seguintes conversões:

Asboolean - Converte para valores booleanos (lógicos)
AsDateTime - Converte para Data/Hora
AsFloat - Converte para valores numéricos de ponto flutuante
AsInteger - Converte para valors numéricos inteiros
AsString - Converte para strings de caracteres}

Convertendo valor hexadecimal para inteiro

Function HexToInt(const HexStr: string): longint;
var iNdx: integer;
cTmp: Char;

begin
Result := 0;
for iNdx := 1 to Length(HexStr) do
begin
cTmp := HexStr[iNdx];
case cTmp of
'0'..'9': Result := 16 * Result + (Ord(cTmp) - $30);
'A'..'F': Result := 16 * Result + (Ord(cTmp) - $37);
'a'..'f': Result := 16 * Result + (Ord(cTmp) - $57);
else
raise EConvertError.Create('Illegal character in hex string');
end;
end;
end;

Convertendo um número real para string com 2 casas

ValorReal : Real;
ValorString : String;
ValorReal := 5;
ValorString := floattostrf(ValorReal,ffFixed,18,2);

Convertendo pchar para string

Var sWinDir: AnsiString;
nTam: Integer;

begin
nTam := MAX_PATH;
SetLength(sWinDir,nTam);
GetWindowsDirectory( PChar( sWinDir ), nTam )
SetLength(sWinDir,nTam);
end;

Conectando uma unidade de rede

Var NRW: TNetResource;

begin
with NRW do
begin
dwType := RESOURCETYPE_ANY;
lpLocalName := 'G:';
lpRemoteName := '\servidorc';
lpProvider := '';
end;

WNetAddConnection2(NRW, 'MyPassword', 'MyUserName', CONNECT_UPDATE_PROFILE);
end;

obtendo o espaço livre em disco.

procedure TForm1.Button1Click(Sender: TObject);
var
FreeAvailable,TotalSpace,TotalFree : Int64;
begin
GetDiskFreeSpaceEx('c:',FreeAvailable,TotalSpace,@TotalFree);
ShowMessage('Espaço livre: '+FormatFloat('#,0',TotalFree)+#13+
'Espaço disponível: '+FormatFloat('#,0',FreeAvailable)+#13+
'Espaço total do disco: '+FormatFloat('#,0',TotalSpace));
end;

Usando mutex pra não deixar seu aplicativo ser executado mais de uma vez.

{1o. Coloque o código abaixo no seu projeto, clicando no menu Project/View Source.

2o. Adicione a Unit Windows no uses de seu projeto.

Esta dica serve para não deixar que seu aplicativo seja executado mais de uma vez, inclusive no Windows XP }

{$R *.res}
Var
MutexHandle: THandle;
hwind:HWND;
begin
MutexHandle := CreateMutex(nil, TRUE, 'MysampleAppMutex');
if MutexHandle <> 0 then
begin
if GetLastError = ERROR_ALREADY_EXISTS then
begin
MessageBox(0, 'Este programa já está em execução!','', mb_IconHand);
CloseHandle(MutexHandle);
hwind:=0;
repeat
hwind:=Windows.FindWindowEx(0,hwind,'TApplication','My sampleapp');
until (hwind<>Application.Handle);
if (hwind<>0) then
begin
Windows.ShowWindow(hwind,SW_SHOWNORMAL);
Windows.SetForegroundWindow(hwind);
end;
Halt;
end
end;
Application.Initialize;
Application.CreateForm(Tf_principal, f_principal);
Application.Run;
end.

Como criar uma variante de carregamento

{1º para que serve uma variante de carregamento?
Uma variante de carregamento serve para você indicar que o programa a ser usado está carregando, como se fosse uma especíe de downloads.
Ai Vai.}

procedure TForm1.Button1Click(Sender: TObject);
var
time1, time2:tdatetime;
n1, n2, total: variant;
begin
time1:= now;
n1:= 0;
n2:= 0;
progressbar1.position:= 0;
while n1 < 5000000 do
begin
n2:=n2 + n1;
inc (n1);
if (n1 mod 50000) = 0 then
begin
progressbar1.position:= n1 div 50000;
application.ProcessMessages;
end;
end;
// devemos usar o resultado
total:=n2;
time2:=now;
label1.caption:= formatdatetime('n:ss', time1-time2) + ' segundos';
end;

//obs: progressbar está em win32.

Como criar uma variante de carregamento

Como obter a data e hora de acesso, criação e alteração de um arquivo

//Usamos o objeto TSearchRec para retornar as datas e horas de um arquivo.

var
SearchFile: TSearchRec;
lpSystemTime: TSystemTime;
begin
{ arquivo }
FindFirst(‘c:ActiveDelphi.exe’,faAnyFile,SearchFile);
try
{ Criação }
FileTimeToSystemTime
(SearchFile.FindData.ftCreationTime,lpSystemTime);
Edit1.text:=DateTimeToStr(SystemTimeToDateTime(lpSystemTime));
{ Modificado }
FileTimeToSystemTime
(SearchFile.FindData.ftLastWriteTime,lpSystemTime);
Edit2.text:=DateTimeToStr
(SystemTimeToDateTime(lpSystemTime));
{ Acessado }
FileTimeToSystemTime
(SearchFile.FindData.ftLastAccessTime,lpSystemTime);
Edit3.text:=DateTimeToStr(SystemTimeToDateTime(lpSystemTime));
finally
FindClose(SearchFile);
end;
end;

Obter status da memória do sistema

//Adicione um TButton e um TMemo, no evento Onclick do TButton insira o código abaixo.

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;

como abrir um relatório criado no ms access pelo delphi

procedure TForm1.ImprimeClick(Sender: TObject);
var access : variant;
const
print = $00000000;
viewDesign = $00000001;
preview = $00000002;

begin
// Abre a aplicaçao Access
try
Access := GetActiveOleObject('Access.Application');
except
Access := CreateOleObject('Access.Application');
end;

Access.Visible := true;

// Abre o database
// Informe no primeiro parâmetro o local do arquivo.mdb
// No Segundo parâmetro especificar se o banco de dados do Access abrirá no modo exclusivo, não compartilhado.

Access.OpenCurrentDatabase('C:Mes documentostestearquivo.mdb', True);

{
Abre o relatório criado no Access; informar seu nome no primeiro parâmetro.
O valor do segundo parâmetro deve ser: preview, viewDesign(estrutura) ou print(o qual é default e imprime o relatório imediatamente).
O *terceiro parâmetro, é para uma expressão de sequência que seja o nome válido de uma consulta no banco de dados atual.
O *quarto parâmetro é para cláusula WHERE SQL válida, sem a palavra WHERE.
*não foi usado neste exemplo
}

Access.DoCmd.OpenReport('Relatorio_de_Clientes', preview,
EmptyParam, EmptyParam);

end;

procedure TForm1.FecharAccessClick(Sender: TObject);
var access : variant;
begin
// depois de imprimir, use esse código para fechar:
try
Access := GetActiveOleObject('Access.Application');
except
Access := CreateOleObject('Access.Application');
end;
Access.CloseCurrentDatabase;
Access.Quit;
end;

Exportando timage no formato wmf.

procedure ExportaBMPtoWMF(Imagem:TImage; Dest:Pchar);
var
Metafile : TMetafile;
MetafileCanvas : TMetafileCanvas;
DC : HDC;
ScreenLogPixels : Integer;
begin
Metafile := TMetafile.Create;
try
DC := GetDC(0);
ScreenLogPixels := GetDeviceCaps(DC, LOGPIXELSY);
Metafile.Inch := ScreenLogPixels;
Metafile.Width := Imagem.Picture.Bitmap.Width;
Metafile.Height := Imagem.Picture.Bitmap.Height;
MetafileCanvas := TMetafileCanvas.Create(Metafile, DC);
ReleaseDC(0, DC);
try
MetafileCanvas.Draw(0, 0, Imagem.Picture.Bitmap);
finally
MetafileCanvas.Free; end;
Metafile.Enhanced := FALSE;
Metafile.SaveToFile(Dest);
finally
Metafile.Destroy;
end;

end;

Exportando timage no formato wmf.

Administrando memória

// Declare ShareMem na seção USES.
// Esta procedure faz ocorrência com borlndmm.dll
procedure InitMemoryManager;
var
SharedMemoryManager: TMemoryManager;
MM: Integer;
begin
SharedMemoryManager.GetMem := SysGetMem;
MM := GetModuleHandle(DelphiMM);
SharedMemoryManager.GetMem := GetProcAddress(MM,'@Borlndmm@SysGetMem$qqri');
SharedMemoryManager.FreeMem := GetProcAddress(MM,'@Borlndmm@SysFreeMem$qqrpv');
SharedMemoryManager.ReallocMem := GetProcAddress(MM, '@Borlndmm@SysReallocMem$qqrpvi');
SetMemoryManager(SharedMemoryManager);
end;

Administrando memória

Como criar um about box igual ao do windows

{Esta dica mostra como usar o About box do windows na sua aplicação, sem a necessidade de criar um novo form.

Declare ShellApi no uses clause da unit.}

procedure TForm1.Button1Click(Sender: TObject);
begin
ShellAbout( Application.Handle, //Handle da sua aplicação
PChar( 'Nome da sua aplicação' ),
PChar( 'Comentários sobre a sua aplicação' ),
Application.Icon.Handle ); //icone que aparece na janela, neste caso o próprio da aplicação
end;

Abrindo o browser ou e-mail ao clicar num label ou timage

public
{ Public declarations }
procedure Executa(const aAdress: String);

//Declare a biblioteca ShellAPI na cláusula uses do Form

procedure TForm1.Executa(const aAdress: String);
var
buffer: String;
begin
buffer := aAdress;
ShellExecute(Application.Handle, nil, PChar(buffer), nil, nil, SW_SHOWNORMAL);
end;

//Adicione o código abaixo no evento OnClick do Label1 - aqui será aberto o Outlook para o envio de e-mails

procedure TForm1.Label1Click(Sender: TObject);
begin
Executa('mailto: miguelmm3@ibest.com.br ');
end;

//Adicione o código abaixo no evento OnClick do Image1

procedure TForm1.Image1Click(Sender: TObject);
begin
Executa('http://www.miguelmm3.kit.net');
end;

Mostrar a janela de diálogo de propriedades do windows

// Precisa declarar a shellapi no projeto

{ Aqui está um código que mostra a janela de diálogo de propriedades do Windows.
Usage:
ShowProperties(Application.Handle, 'c:autoexec.bat') }

function ShowProperties (hWndOwner: HWND; const FileName: string) : boolean;
var
Info: TShellExecuteInfo;
Handle : THandle;
begin
{ Fill in the SHELLEXECUTEINFO structure }
with Info do
begin
cbSize := SizeOf(Info);
fMask := SEE_MASK_NOCLOSEPROCESS or
SEE_MASK_INVOKEIDLIST or
SEE_MASK_FLAG_NO_UI;
wnd := hWndOwner;
lpVerb := 'properties';
lpFile := pChar(FileName);
lpParameters := nil;
lpDirectory := nil;
nShow := 0;
hInstApp := 0;
lpIDList := nil;
end;
{ Call Windows to display the properties dialog. }
Result := ShellExecuteEx(@Info);
end;

Criar um documento no word.

Uses ComObj

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

Obs:

MSWord.JustifyPara; // alinhamento justificado
MSWord.RightPara; // alinhamento a direita
MSWord.LeftPara; // alinhamento a esquerda
MSWord.InsertPageBreak; // quebrar página

como saber se a impressora atual possui determinada fonte

//Inclua na seção uses: Printers

{ Coloque este código no OnClick de um botão }
with Printer.Fonts do
if IndexOf('Draft 10cpi') >= 0 then
ShowMessage('A impressora possui a fonte.')
else
ShowMessage('A impressora NÃO possui a fonte.');

{ Observações
Isto pode ser útil quando queremos usar fonte da impressora quando for uma matricial ou fonte do Windows quando for uma Jato de Tinta ou Laser. }

Usando um for select dentro da storedprocedure no firebird/interbase

Create procedure SP_RETORNO(PCOD INTEGER)
returns (COD INTEGER, NOME VARCHAR(30),
VALOR NUMERIC(15,4))

as
begin
for select CODIGO, NOME from CLIENTES
where CODIGO = :PCOD
into :COD, :NOME do
begin
select VALOR from VALORES
where CODIGO = :COD
into :VALOR;
if ((VALOR IS NULL) or (VALOR = 0)) then
VALOR = 1;
suspend;
end
end;

{Para visualizar os registros retornados desta StoredProcedure podemos fazer um Select dentro da Query,
ficando a instrução da seguinte forma: }
select * from SP_RETORNO( 10 )

Criando drivers odbc através do delphi

Unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure CreateODBCDriver(Const cDSNName,cExclusive,cDescription,cDataBase,cDefaultPath,cConfigSql,cDriver: string);

type

TSQLConfigDataSource = function( hwndParent: HWND; fRequest: WORD; lpszDriver: LPCSTR; lpszAttributes: LPCSTR ): BOOL; stdcall;

const
ODBC_ADD_DSN = 1; // Adiciona uma fonte de dados (data source)
ODBC_CONFIG_DSN = 2; // Configura a fonte de dados (data source)
ODBC_REMOVE_DSN = 3; // Remove a fonte de dados (data source)
ODBC_ADD_SYS_DSN = 4; // Adiciona um DSN no sistema
ODBC_CONFIG_SYS_DSN = 5; // Configura o DSN do sistema
ODBC_REMOVE_SYS_DSN = 6; // Remove o DSN do sistema
var
pFn: TSQLConfigDataSource;
hLib: LongWord;
strDriver: string;
strHome: string;
strAttr: string;
strFile: string;
fResult: BOOL;
ModName: array[0..MAX_PATH] of Char;
srInfo : TSearchRec;
begin
Windows.GetModuleFileName( HInstance, ModName, SizeOf(ModName) );
strHome := ModName;
while ( strHome[length(strHome)] <> '' ) do
Delete( strHome, length(strHome), 1 );
strFile := strHome + cDatabase; // Teste com access (Axes = Access)
hLib := LoadLibrary( pChar(cDefaultPath) ); // carregando para o diretório padrão
if( hLib <> NULL ) then
begin
@pFn := GetProcAddress( hLib, pChar(cConfigSql) );
if( @pFn <> nil ) then
begin
strDriver := cDriver;
strAttr := Format( 'DSN=%s'+#0+ 'DBQ=%s'+#0+'Exclusive=%s'+#0+'Description=%s'+#0+#0,[cDSNName,strFile,cExclusive,cDescription] );
fResult := pFn( 0, ODBC_ADD_SYS_DSN, @strDriver[1], @strAttr[1] );
if( fResult = false ) then
ShowMessage( 'Falha ao tentar criar o DSN (Data source).' );
if( FindFirst( strFile, 0, srInfo ) <> 0 ) then
begin
strDriver := cDriver;
strAttr := Format( 'DSN=%s'+#0+'DBQ=%s'+#0+'Exclusive=%s'+#0+'Description= %s'+#0+#0+'CREATE_DB="%s"'#0+#0, [cDSNName,strFile,cExclusive,cDescription,strFile]);
fResult := pFn( 0, ODBC_ADD_SYS_DSN, @strDriver[1], @strAttr[1] );
if( fResult = false ) then
ShowMessage( 'Falha ao tentar criar o banco de dados' );
end;
FindClose( srInfo );
end;
FreeLibrary( hLib );
if fResult then
ShowMessage( 'Banco de dados criado.' );
end
else
begin
ShowMessage( 'o sistema não pode carregar a biblioteca ODBCCP32.DLL' );
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
CreateOdbcDriver('Cludelphi DSN','1','clubedelphi','clubedelphi.MDB','ODBCCP32','SQLConfigDataSource','Microsoft Access Driver (*.mdb)');
end;

end.

{ Concluções: Com esta dica você poderá criar drivers ODBC em tempo de execução, softwares de instalação, economizando tempo e deixando suas aplicações mais dinâmicas. }

Utilizando captions em componentes dbnavigator

Declare a seguinte classe:

type
TDBNewNavigator = class ( TDBNavigator );

uses Buttons;

procedure TForm1.FormCreate(Sender: TObject);
var
B: TNavigateBtn;
begin
for B := Low ( TNavigateBtn ) to High ( TNavigateBtn ) do
with TDBNewNavigator ( DBNavigator1 ).Buttons [ B ] do
begin
Case Index of
nbFirst : Caption := 'Primeiro';
nbPrior : Caption := 'Anterior';
nbNext : Caption := 'Próximo';
nbLast : Caption := 'Último';
nbInsert : Caption := 'Novo';
nbDelete : Caption := 'Excluir';
nbEdit : Caption := 'Editar';
nbPost : Caption := 'Salvar';
nbCancel : Caption := 'Cancelar';
nbRefresh : Caption := 'Atualizar';
End;
Layout := blGlyphTop;
Hint := Caption;
ShowHint := True;
end;
end;

Descobrindo url's visitadas

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

uses Registry;

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

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

Criando arrays ramdomicos

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

end;

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

Como clonar formulários em tempo de execução

procedure TForm1.Button1Click(Sender: TObject);
var
ms: TMemoryStream;
newform: TForm1;
begin
ms := TMemoryStream.Create;
try
ms.WriteComponent(Form1);
newform := TForm1.CreateNew(Application);
ms.Position := 0;
ms.ReadComponent(newform);
newform.Show;
finally
ms.Free
end;
end;

Criando um banco de dados ms-access via programação

//Isso é possível utilizando uma API chamada SQLConfigDataSource() que está disponível na ODBCCP32.DLL.

var
Form1: TForm1;
{ constante utilizada na API }
const
ODBC_ADD_DSN = 1;

{ declara a API fazendo referencia a DLL }

function SQLConfigDataSource( hwndParent: HWND; fRequest: WORD; lpszDriver: LPCSTR; lpszAttributes: LPCSTR): BOOL; stdcall; external ‘ODBCCP32.DLL’;

implementation

{$R *.DFM}

procedure CreateDatabase(DbName: String);
begin
SQLConfigDataSource(0, ODBC_ADD_DSN, ‘Microsoft Access Driver (*.mdb)’, PChar (‘CREATE_DB=’ + DbName + #0));
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if FileExists(‘c:Teste.mdb’) then
DeleteFile(‘c:Teste.mdb’);
try
CreateDatabase(‘c:Teste.mdb’);
ShowMessage(‘MDB criado com sucesso!’);
except
ShowMessage(‘Problemas ao criar o MDB!’);
end;
end;

end.

Como obter fatorial de um número

Ex: Fatorial(5) = 120.

function Fatorial(Valor: Integer):LongInt;
begin
{ Verifica se o valor é inválido }
if Valor < 1 then
raise Exception.Create(‘Valor inválido para ser fatorado!’);

if Valor = 1 then
Result := 1
else
{ Chamada recursiva }
Result := Valor * Fatorial(Valor - 1);
end;

procedure TForm1.BitBtn1Click(Sender: TObject);
begin
{ Teste o valor }
Edit1.Text := IntToStr(Fatorial(SpinEdit1.Value));
end;

Acessando uma propriedade, evento, função ou procedimento privado de um objeto ancestr

Type
TControlHack = class(TControl)
Public
Property OnMouseDown;
end;

procedure TDBXGrid.MouseDown(Button: TMouseButton;ShiftState:TShiftState; X,Y:Integer);
begin
if Assigned(TControlHack(Self).OnMouseDown) then
TControlHack(Self).OnMouseDown(Self, Button, FShiftState, X,Y);
end;

Type
TCustomGridHack = class(TCustomGrid)
Public
Property Options;
end;
procedure TDBXGrid.SetRowSizingAllowed(Value:Boolean);
begin
if Value<>FRowSizingAllowed Then
begin
FRowSizingAllowed:=Value;
if FRowSizingAllowed Then
TCustomGridHack(Self).Options:=TCustomGridHack(Self).Options+[goRowSizing]
else
TCustomGridHack(Self).Options:=TCustomGridHack(Self).Options-[goRowSizing];
end
end; // SetRowSizingAllowed

Executa o windows explorer a partir de uma pasta especificada

Function ExecExplorer(OpenAtPath: string; OpenWithExplorer, OpenAsRoot: Boolean): boolean;
// Requer a unit ShellApi
// ex: execExplorer('C:Temp', True,True);
var
s: string;
begin
if OpenWithExplorer then
begin
if OpenAsRoot then
s := ' /e,/root,"' + OpenAtPath + '"'
else
s := ' /e,"' + OpenAtPath + '"';
end
else
s := '"' + OpenAtPath + '"';
result := ShellExecute(Application.Handle,PChar('open'),PChar('explorer.exe'),PChar(s),nil,SW_NORMAL) > 32;
end;

Alinha um valor real, em um determinado espaço

function Alinhar(Pe_Num:Real; Pe_QtdPos:Byte; EDC :Char):string;
// EDC: C = Centralizado
// D = Direita
// E = Esquerda
//

var
I : integer;
S : string;
Num : string;
begin
if EDC = 'D' then
begin
Num := Format('%*.*n', [Pe_QtdPos, 2, Pe_Num]);
Alinhar := Num;
end;
if EDC = 'E' then
begin
Num := FormatFloat('###,###,###,##0.00',Pe_Num);
Alinhar := Num;
end;
if EDC = 'C' then
begin
Num := FormatFloat('###,###,###,##0.00',Pe_Num);
i := Pos(',',Num);
i := i + 2;
i := Pe_QtdPos - i;
i := Round( i / 2 );
i := Pe_QtdPos - i;
Num := Format('%*.*n', [i,2,Pe_Num]);
str(i,s);
Alinhar := Num ;
end;

end;

Pesquisando por parte de uma string

Procedure TForm1.BitBtn1Click(Sender: TObject);
begin
Query1.Close;
Query1.Sql.Clear;
Query1.Sql.Add(‘Select Teste1.Codigo,Teste1.Nome’);
Query1.Sql.Add(‘From Teste1 ‘);
Query1.Sql.Add(‘Where ‘);
Query1.Sql.Add(‘(Teste1.Codigo >= :Codigo1) and’);
Query1.Sql.Add(‘(Teste1.Codigo <= :Codigo2)’);
Query1.Params[0].AsString := Edit1.Text;
Query1.Params[1].AsString := Edit2.Text;
Query1.Open;
end;

Abreviar nomes

Function AbreviarNome(Nome: String): String;
var
Nomes: array[1..20] of string;
i, TotalNomes: Integer;
begin
Nome := Trim(Nome);
Result := Nome;
Nome := Nome + #32;
i := Pos(#32, Nome);
if i > 0 then

begin
TotalNomes := 0;
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 for i := 2 to TotalNomes - 1 do begin if Length(Nomes[i]) > 3 then
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;

Carregando imagem para o rave (run-time).

Procedure CarregaImagemRave(NomeProjeto: TRvProject; NomeRelatorio, NomeImagem, PathImagem: String);
var
MyPage : TRavePage;
MyPicture : TRaveBitmap;
begin
NomeProjeto.Open;
with NomeProjeto.ProjMan do
begin
MyPage := FindRaveComponent(NomeRelatorio,nil) as TRavePage;
MyPicture := FindRaveComponent(NomeImagem,MyPage) as TRaveBitmap;
MyPicture.Image.LoadFromFile(PathImagem);
end;
end;

Como mostrar as fontes truetype instaladas no window

{Inclua no seu form um componente Button, um componente ListBox e um componente Label.}

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

// Evento OnClick do componente ListBox
procedure TForm1.ListBox1Click(Sender: TObject);
begin
// A linha abaixo atribui a propriedade Caption do componente Label o nome da fonte selecionada no componente ListBox
Label1.Caption := ListBox1.Items[ListBox1.ItemIndex];
// A linha abaixo muda a fonte de letra de acordo com a fonte selecionada no componente Listbox
Label1.Font.Name := ListBox1.Items[ListBox1.ItemIndex];
end;

// Evento OnClick do componente Button
procedure TForm1.Button1Click(Sender: TObject);
begin
// Carrega as fontes instaladas no Windows para o componente ListBox
ListBox1.Items := Screen.Fonts;
end;

Extensões de arquivos paradox

{.DB - Tabela Paradox
.FAM - Lista de arquivos relacionados
.LCK - Arquivo de Lock
.MB - Campos Blobs
.PX - Indice Primário
.TV - Guarda as configurações da tabela (não usado pelo BDE)
.VAL - Valid checks e integridade referencial.
.Xnn - índice secundário de campo único
.Ynn - índice secundário de campo único.
.XGn - índice secundário composto
.YGn - índice secundário composto}

Verificando qual o idioma do windows

procedure TForm1.SpeedButton1Click(Sender: TObject);
var
TheWindow: HWND;
Lingua: array[0..255] of char;
begin
VerLanguageName(GetSystemDefaultLangID, Lingua, 255);
{ Verifica se o Windows é Português ou Brasileiro }
if Lingua <> ‘Português (Brasileiro)’ then
TheWindow:=FindWindow(nil,’Calculadora’)
else if Lingua <> ‘English (United States)’ then
TheWindow:=FindWindow(nil,’Calculator’)

{ Procura a janela da calculadora }
if TheWindow <> 0 then
begin
// Chama calculadora se já estiver carregada
SetForegroundWindow(TheWindow);
ShowWindow(TheWindow, SW_RESTORE);
end
else
// Carrega calculadora se estiver fechada
ShellExecute(Handle, ‘Open’, ‘Calc.exe’, nil, ‘c:windows’, sw_show);
end;

Como adicionar campos fisicamente em uma tabela paradox via programação

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Grids, DBGrids, Db, DBTables, BDE, DBCtrls, Menus, ComCtrls,
Buttons ;

type
TForm1 = class(TForm)
DataSource1: TDataSource;
DBGrid1: TDBGrid;
Button1: TButton;
Table1: TTable;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

type
ChangeRec = packed record
szName: DBINAME;
iType: Word;
iSubType: Word;
iLength: Word;
iPrecision: Byte;
end;

var
MyChangeRec: ChangeRec;

procedure AddField(Table: TTable; NewField: ChangeRec);

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
MyChangeRec.szName := ‘NovoCampo’;
MyChangeRec.iType := fldPDXCHAR;
MyChangeRec.iSubType:=0;
MyChangeRec.iLength := 45;
MyChangeRec.iPrecision := 0;

Table1.Close;
Table1.Exclusive := True;
Table1.Open;
AddField(Table1, MyChangeRec);
Table1.Close;
Table1.Exclusive := False;
Table1.Open;
end;

procedure AddField(Table: TTable; NewField: ChangeRec);
var
Props: CURProps;
hDb: hDBIDb;
TableDesc: CRTblDesc;
pFlds: pFLDDesc;
pOp: pCROpType;
B: byte;

begin
if Table.Active = False then
raise EDatabaseError.Create(‘A tabela precisa estar aberta’);
if Table.Exclusive = False then
raise EDatabaseError.Create(‘A tabela precisa estar aberta em modo Exclusivo’);
Check(DbiSetProp(hDBIObj(Table.Handle), curxltMODE, integer(xltNONE)));
Check(DbiGetCursorProps(Table.Handle, Props));
pFlds := AllocMem((Table.FieldCount + 1) * sizeof(FLDDesc));
FillChar(pFlds^, (Table.FieldCount + 1) * sizeof(FLDDesc), 0);
Check(DbiGetFieldDescs(Table.handle, pFlds));

for B := 1 to Table.FieldCount do begin
pFlds^.iFldNum := B;
Inc(pFlds, 1);
end;
try
StrCopy(pFlds^.szName, NewField.szName);
pFlds^.iFldType := NewField.iType;
pFlds^.iSubType := NewField.iSubType;
pFlds^.iUnits1 := NewField.iLength;
pFlds^.iUnits2 := NewField.iPrecision;
pFlds^.iFldNum := Table.FieldCount + 1;
finally
Dec(pFlds, Table.FieldCount);
end;
pOp := AllocMem((Table.FieldCount + 1) * sizeof(CROpType));
Inc(pOp, Table.FieldCount);
pOp^ := crADD;
Dec(pOp, Table.FieldCount);
// Blank out the structure...
FillChar(TableDesc, sizeof(TableDesc), 0);
// Get the database handle from the table’s cursor handle...
Check(DbiGetObjFromObj(hDBIObj(Table.Handle), objDATABASE, hDBIObj(hDb)));
// Put the table name in the table descriptor...
StrPCopy(TableDesc.szTblName, Table.TableName);
// Put the table type in the table descriptor...
StrPCopy(TableDesc.szTblType, Props.szTableType);
// Close the table so the restructure can complete...
TableDesc.iFldCount := Table.FieldCount + 1;
Tabledesc.pfldDesc := pFlds;
TableDesc.pecrFldOp := pOp;
Table.Close;
// Call DbiDoRestructure...
try
Check(DbiDoRestructure(hDb, 1, @TableDesc, nil, nil, nil, FALSE));
finally
FreeMem(pFlds);
FreeMem(pOp);
Table.Open;
end;
end;
{ ******* Tipos dos campos a ser declarado no iType, *********
******* Veja exemplo ... MyChangeRec.iType := fldPDXCHAR *********
Tipos fisicos do Paradox Tipos fisicos do dBase e FoxPro

fldPDXCHAR fldDBCHAR
fldPDXNUM fldDBNUM
fldPDXMONEY fldDBMEMO
fldPDXDATE fldDBBOOL
fldPDXSHORT fldDBDATE
fldPDXMEMO fldDBFLOAT
fldPDXBINARYBLOB fldDBLOCK (dBASE only)
fldPDXFMTMEMO fldDBBINARY (dBASE only)
fldPDXOLEBLOB fldDBOLEBLOB
fldPDXGRAPHIC fldDBBYTES
fldPDXBLOB fldDBLONG (dBASE 7.0 table format only)
fldPDXLONG fldDBDATETIME (dBASE 7.0 table format only)
fldPDXTIME fldDBDOUBLE (dBASE 7.0 table format only)
fldPDXDATETIME fldDBAUTINC (dBASE 7.0 table format only)
fldPDXBOOL
fldPDXAUTOINC
fldPDXBYTES
fldPDXBCD
}
end.

trabalhando com vários registros no dbgrid.

{Verificando quais os registros que estão selecionados no componente DBGrid. Primeiro altere a propriedade dgMultiSelect que faz parte da propriedade Options para True. }

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Buttons, Db, DBTables, Grids, DBGrids;

{ Coloque um componente TBitBtn e no evento Onclick do mesmo coloque o código abaixo: }

// Evento OnClick do componente BitBtn
procedure TForm1.BitBtn1Click(Sender: TObject);
begin
Table1.First;
While not Table1.Eof do
begin
if DBGrid1.SelectedRows.IndexOf(Table1.BookMark) >= 0 then
ShowMessage(‘Registro selecionado’);
Table1.Next;
end;
end;

Como verificar se uma porta serial está em uso.

//Usando APIs do Windows, veja abaixo:

var
portHandle: Integer;
begin
portHandle := 0;
portHandle := CreateFile(Pchar(ComboCOM.Text), GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
if portHandle > 0 then
ShowMessage(‘Porta em uso!’)
else
raise Exception.Create
(‘Não consegui abrir a porta!’);
end;

Como colorir um ttreeview

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

Rotina para retornar a hora, minutos, segundos e milisegundos.

Procedure TForm1.Button2Click(Sender: TObject);
var
Hora, Min, Sec, MSec : Word;
begin
DecodeTime(Now, Hora, Min, Sec, MSec);
Label1.Caption := FormatDateTime(‘hh:mm:ss’,Now)+ ’:’+FormatFloat(‘000’,MSec);
end;

Apagando um subdiretório

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

procedure DeleteDir( hHandle : THandle; Const sPath : String );
var
OpStruc: TSHFileOpStruct;
FromBuffer, ToBuffer: Array[0..128] of Char;
begin
fillChar( OpStruc, Sizeof(OpStruc), 0 );
FillChar( FromBuffer, Sizeof(FromBuffer), 0 );
FillChar( ToBuffer, Sizeof(ToBuffer), 0 );
StrPCopy( FromBuffer, sPath);
With OpStruc Do
Begin
Wnd:= hHandle;
wFunc:=FO_DELETE;
pFrom:= @FromBuffer;
pTo:= @ToBuffer;
fFlags:= FOF_NOCONFIRMATION;
fAnyOperationsAborted:=False;
hNameMappings:=nil;
End;
ShFileOperation(OpStruc);
end;

//Exemplo:

procedure TForm1.Button1Click(Sender: TObject);
begin
DeleteDir( Self.Handle,'C:TESTE');
end;

Pesquisando e substituindo de uma string

procedure TForm1.FindReplace(const Enc, subs: String; Var Texto:TMemo);
Var
i, Posicao: Integer;
Linha: string;
Begin
For i:= 0 to Texto.Lines.count - 1 do
begin
Linha := Texto. Lines[i];
Repeat
Posicao:=Pos(Enc,Linha);
If Posicao > 0 then
Begin
Delete(Linha,Posicao,Length(Enc));
Insert(Subs,Linha,Posicao);
Texto.Lines[i]:=Linha;
end;
until Posicao = 0;
end;
end;

Procedure TForm1.Button1Click (Sender: TObject);
Begin
FindReplace(Edit1.Text,Edit2.Text, Memo1);
end;

Basta digitar no Edit1 a string que substituirá a string do Edit2. Feito isso digite qualquer coisa no Memo1.

terça-feira, 24 de novembro de 2009

Converte um certo número de segundos em horas já formatado.

Function FormatSecsToHMS(Secs: LongInt): string;
var
Hrs, Min: Word;
begin
Hrs := Secs div 3600;
Secs := Secs mod 3600;
Min := Secs div 60;
Secs := Secs mod 60;
Result := Format('%d:%d:%d', [Hrs, Min, Secs]);
end;

p.1091

Alterar a cor do ítem selecionado do tradiogroup

procedure TForm1.RadioGroup1Click(Sender: TObject);
var
i : Integer;
begin
for i := 0 to RadioGroup1.Items.Count-1 do begin
TRadioButton(RadioGroup1.Controls[i]).Font.Color := clBlack;
TRadioButton(RadioGroup1.Controls[i]).Font.Style := [];
end;
TRadioButton(RadioGroup1.Controls [RadioGroup1.ItemIndex]).Font.Color := clRed;
TRadioButton(RadioGroup1.Controls [RadioGroup1.ItemIndex]).Font.Style := [fsBold];
end;

copiar arquivo para memoria

Function SaveClipboardTextDataToFile( sFileTo : string ) : boolean;
var
ps1, ps2 : PChar;
dwLen : DWord;
tf : TextFile;
hData : THandle;
begin
Result := False;
with Clipboard do
begin
try
Open;
if( HasFormat( CF_TEXT ) ) then
begin
hData := GetClipboardData( CF_TEXT );
ps1 := GlobalLock( hData );
dwLen := GlobalSize( hData );
ps2 := StrAlloc( 1 + dwLen );
StrLCopy( ps2, ps1, dwLen );
GlobalUnlock( hData );
AssignFile( tf, sFileTo );
ReWrite( tf );
Write( tf, ps2 );
CloseFile( tf );
StrDispose( ps2 );
Result := True;
end;
finally
Close;
end;
end;
end;

SaveClipboardTextDataToFile( 'c:temp.txt' );

Colocar margem em um memo

Procedure TForm1.Button1Click(Sender: TObject);
var
R : TRect;
MargenIzquierdo:integer;
MargenDerecho:integer;
begin
MargenIzquierdo:=20;
MargenDerecho:=10;

R := Memo1.ClientRect;
R.Left:=R.Left + MargenIzquierdo;
R.Top:=R.Top + 2;
R.Bottom:=R.Bottom - 2;
R.Right:=R.Right-MargenDerecho;
SendMessage(Memo1.Handle, EM_SETRECT, 0, Longint(@R));
end;

converter texto para gif.

Procedure TxtToGif (txt, FileName: String);
var
temp: TBitmap;
GIF : TGIFImage;
begin
temp:=TBitmap.Create;
try
temp.Height :=400;
temp.Width :=60;
temp.Transparent:=True;
temp.Canvas.Brush.Color:=colFondo.ColorValue;
temp.Canvas.Font.Name:=Fuente.FontName;
temp.Canvas.Font.Color:=colFuente.ColorValue;
temp.Canvas.TextOut (10,10,txt);
Imagen.Picture.Assign(nil);

GIF := TGIFImage.Create;
try
// Convert the bitmap to a GIF
GIF.Assign(Temp);
// Save the GIF
GIF.SaveToFile(FileName);
// Display the GIF
Imagen.Picture.Assign (GIF);
finally
GIF.Free;
end;

Finally
temp.Destroy;
end;
end;

Data do servidor interbase, capturando a

{*****
* Retorna a data do servidor INTERBASE
* (Válido somente para INTERBASE)
*
* Autor: Jociel Eloy de Almeida
*
*}
FUNCTION DateOfServer(DataBaseName: String): TDateTime;
var
QryTmp: TQuery;
begin
QryTmp := TQuery.Create(nil);
with QryTmp do begin
DatabaseName := DataBaseName;
SQL.Text := 'SELECT CURRENT_DATE FROM RDB$DATABASE';
try
Open;
Result := FieldByName('CURRENT_DATE').AsDateTime;
except
Result := Date;
end;
end;
end;

Como converter dbgrig em html

//Inicio do Código

function ColorToHtml(mColor: TColor): string;
begin
mColor := ColorToRGB(mColor);
Result := Format('#%.2x%.2x%.2x',
[GetRValue(mColor), GetGValue(mColor), GetBValue(mColor)]);
end; { ColorToHtml }

function StrToHtml(mStr: string; mFont: TFont = nil): string;
var
vLeft, vRight: string;
begin
Result := mStr;
Result := StringReplace(Result, '&', '&', [rfReplaceAll]);
Result := StringReplace(Result, '<', '<', [rfReplaceAll]);
Result := StringReplace(Result, '>', '>', [rfReplaceAll]);
if not Assigned(mFont) then Exit;
vLeft := Format('',
[mFont.Name, ColorToHtml(mFont.Color)]);
vRight := '';
if fsBold in mFont.Style then begin
vLeft := vLeft + '';
vRight := '' + vRight;
end;
if fsItalic in mFont.Style then begin
vLeft := vLeft + '';
vRight := '' + vRight;
end;
if fsUnderline in mFont.Style then begin
vLeft := vLeft + '';
vRight := '' + vRight;
end;
if fsStrikeOut in mFont.Style then begin
vLeft := vLeft + '';
vRight := '' + vRight;
end;
Result := vLeft + Result + vRight;
end; { StrToHtml }

function DBGridToHtmlTable(mDBGrid: TDBGrid; mStrings: TStrings;
mCaption: TCaption = ''): Boolean;
const
cAlignText: array[TAlignment] of string = ('LEFT', 'RIGHT', 'CENTER');
var
vColFormat: string;
vColText: string;
vAllWidth: Integer;
vWidths: array of Integer;
vBookmark: string;
I, J: Integer;
begin
Result := False;
if not Assigned(mStrings) then Exit;
if not Assigned(mDBGrid) then Exit;
if not Assigned(mDBGrid.DataSource) then Exit;
if not Assigned(mDBGrid.DataSource.DataSet) then Exit;
if not mDBGrid.DataSource.DataSet.Active then Exit;
vBookmark := mDBGrid.DataSource.DataSet.Bookmark;
mDBGrid.DataSource.DataSet.DisableControls;
try
J := 0;
vAllWidth := 0;
for I := 0 to mDBGrid.Columns.Count - 1 do
if mDBGrid.Columns[I].Visible then begin
Inc(J);
SetLength(vWidths, J);
vWidths[J - 1] := mDBGrid.Columns[I].Width;
Inc(vAllWidth, mDBGrid.Columns[I].Width);
end;
if J <= 0 then Exit;
mStrings.Clear;
mStrings.Add(Format('',
[ColorToHtml(mDBGrid.Color)]));
if mCaption <> '' then
mStrings.Add(Format('', [StrToHtml(mCaption)]));
vColFormat := '';
vColText := '';
vColFormat := vColFormat + ''#13#10;
vColText := vColText + ''#13#10;
J := 0;
for I := 0 to mDBGrid.Columns.Count - 1 do
if mDBGrid.Columns[I].Visible then begin
vColFormat := vColFormat + Format(
' '#13#10,
[ColorToHtml(mDBGrid.Columns[I].Color),
cAlignText[mDBGrid.Columns[I].Alignment],
Round(vWidths[J] / vAllWidth * 100), J]);
vColText := vColText + Format(
' '#13#10,
[ColorToHtml(mDBGrid.Columns[I].Title.Color),
cAlignText[mDBGrid.Columns[I].Alignment],
Round(vWidths[J] / vAllWidth * 100),
StrToHtml(mDBGrid.Columns[I].Title.Caption,
mDBGrid.Columns[I].Title.Font)]);
Inc(J);
end;
vColFormat := vColFormat + ''#13#10;
vColText := vColText + ''#13#10;
mStrings.Text := mStrings.Text + vColText;
mDBGrid.DataSource.DataSet.First;
while not mDBGrid.DataSource.DataSet.Eof do begin
J := 0;
vColText := vColFormat;
for I := 0 to mDBGrid.Columns.Count - 1 do
if mDBGrid.Columns[I].Visible then begin
vColText := StringReplace(vColText, Format('>DisplayText%d<', [J]),
Format('>%s<', [StrToHtml(mDBGrid.Columns[I].Field.DisplayText,
mDBGrid.Columns[I].Font)]),
[rfReplaceAll]);
Inc(J);
end;
mStrings.Text := mStrings.Text + vColText;
mDBGrid.DataSource.DataSet.Next;
end;
mStrings.Add('

%s
DisplayText%d	%s

');
finally
mDBGrid.DataSource.DataSet.Bookmark := vBookmark;
mDBGrid.DataSource.DataSet.EnableControls;
vWidths := nil;
end;
Result := True;
end; { DBGridToHtmlTable }

///////Fim do Código

Como desligar/ligar monitor

{Inclua na seção uses: Windows

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

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

{Este recurso pode não funcionar dependendo da configuração do sistema.}

Criar atalho na area de trabalho e no menu iniciar do windows

uses ShlObj, ActiveX,ComObj, Registry,FileCtrl;
procedure CriarAtalho (NomeDoPrograma,ParametrosdeExcecucao,DiretoriodeInicializacao, NomedoAtalho,IniciarEm,NomedoGrupo : String);
var
MeuObjeto : IUnknown;
MeuAtalho : IShellLink;
MeuArquivo : IPersistFile;
Diretorio : String;
CriarAtalho : WideString;
Var_Registro : TRegIniFile;
begin
MeuObjeto := CreateComObject(CLSID_ShellLink);
MeuAtalho := MeuObjeto as IShellLink;
MeuArquivo := MeuObjeto as IPersistFile;
with MeuAtalho do
begin
SetArguments(PChar(ParametrosdeExcecucao));
SetPath(PChar(NomeDoPrograma));
SetWorkingDirectory(PChar(DiretoriodeInicializacao));
end;
Var_Registro := TRegIniFile.Create('SoftwareMicrosoftWindowsCurrentVersionExplorer');
Diretorio := Var_Registro.ReadString ('Shell Folders','Programs','');
//Cria o Atalho No Menu Iniciar
if trim(NomedoGrupo)<>'' then
begin
Diretorio:=Diretorio+''+NomedoGrupo;
if not DirectoryExists(Diretorio) then
ForceDirectories(Diretorio);
end;
CriarAtalho := Diretorio + '' + NomedoAtalho + '.lnk';
MeuArquivo.Save (PWChar (CriarAtalho), False);
//Cria o Atal]ho na area de Trabalho
Diretorio := Var_Registro.ReadString ('Shell Folders','Desktop','');
CriarAtalho := Diretorio + '' + NomedoAtalho + '.lnk';

MeuArquivo.Save (PWChar (CriarAtalho), False);
Var_Registro.Free;
end;

procedure TForm1.CriarAtalhoClick(Sender: TObject);
begin
CriarAtalho('Arquivo.Exe','parametro pa abertura','Diretorio onde o Arquivo Esta','Nome do Atalho','onde o Arquivo Esta','Nome do Gupo');
end;
o nome do Grupo é uma pasta onde seu atalho vai Ficar
como por exemplo "acessorios"

Imprimir em impressora matricial em modo caracter

Procedure TForm1.Button1Click(Sender: TObject);
var Arquivo : TextFile;
begin
AssignFile(Arquivo,'LPT1');
Rewrite(Arquivo);
Writeln(Arquivo,'Teste de impressao - Linha 0');
Writeln(Arquivo,'Teste de impressao - Linha 1');
Writeln(Arquivo,#27#15+'Teste de Impressão - Linha 2');
Writeln(Arquivo,'Teste de impressao - Linha 3');
Writeln(Arquivo,#27#18+'Teste de Impressão - Linha 4');
Writeln(Arquivo,'Teste de impressao - Linha 5');
Writeln(Arquivo,#12); // Ejeta a página
CloseFile(Arquivo);
end;

Como imprimir um campo memo via canvas

//Coloque na clásula Uses a unit printers

procedure TForm1.Button1Click(Sender: TObject);
var
i, altura : Integer;
sMemo : String;
begin
With Printer do
begin
Title:= 'Imprimindo memo';
BeginDoc;
With Canvas do
begin
altura := TextHeight('A');
for i := 1 to Memo1.Lines.Count do
begin
sMemo := Memo1.Lines[I];
TextOut(1, (i - 1) * Altura, sMemo);
end;
end;
EndDoc;
end;
end;

Problemas delphi x impressora xerox

{Eu já ouvi falar que a própria Xerox já afirmou esta imcompatibilidade entre seu driver e o quickreport.

No meu caso, temos uma impressora Xerox N32PCL e para que não dê problema utilizo o driver da HP LaserJet 5MP. Utilizando este driver a impressão sai sem problemas na impressora Xerox.

Assim, tenho em meu computador instalado duas impressoras (que na realidade são as mesmas). Uma utilizando o driver da HP LaseJet 5MP (para ser utilizada com o Delfi quando a aplicação contém relatórios com o QuickReport) e outra utilizando o próprio drive da Xerox}

Como alterar o caption da janela de preview do quickreport

{Para mudar o título da barra de título da janela de Preview de seus relatórios, use o seguinte comando: }

QRPrinter.PreviewCaption := 'Visualização do Relatório';

Como criar um contador de página para um relatório desenvolvido no quickreport 2.0

{Como criar um contador de página para um relatório desenvolvido no QuickReport 2.0}

var
Form1: TForm1;
i : integer;
implementation
{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
i := 0 ;
QuickRep1.Prepare;
QrLabel2.Caption := IntToStr(i);
QuickRep1.Preview;
end;

procedure TForm1.QuickRep1StartPage(Sender: TQuickRep);
begin
i := i + 1;
Form2.Label1.caption := IntToStr(i);
end;

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

Como transformar 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;

Como mudar o texto de um edit no evento onchange

{Se o texto de um TEdit for mudado no seu evento OnChange, este even-to será chamado recursivamente até acabar com o espaço de pilha. Pa-ra fazer isso, deve-se setar o evento OnChange para NIL antes de mu-dar o texto, voltando ao original depois, desta maneira:}

procedure Edit1Change(Sender : TObject);
begin
Edit1.OnChange := NIL;
if Edit1.Text = 'Texto' then
Edit1.Text := 'Novo Texto';
Edit1.OnChange := Edit1Change;
end;
Isto também vale para evento OnValidate.

Como deixar o string grid colorido

Unit
Unit1;

interface

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

type
TForm1 = class(TForm)
StringGrid1: TStringGrid;
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure StringGrid1DrawCell(Sender: TObject; Col, Row: Longint;
Rect: TRect; State: TGridDrawState);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure StringGrid1DblClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
C, R: Integer;
Value: Integer;
begin
{Encher o String Grid de valores Inteiros e Ramdomicos}
Randomize;
for C := 1 to StringGrid1.ColCount-1 do
for R := 1 to StringGrid1.RowCount-1 do
begin
Value := Random(10) - 5;
StringGrid1.Cells[C,R] := IntToStr(Value);
StringGrid1.Objects[C,R] := Pointer(clBlack);
end;
end;

procedure TForm1.StringGrid1DrawCell(Sender: TObject; Col, Row: Longint;
Rect: TRect; State: TGridDrawState);
const
LM = 3; {each indiviual cell's left margin}
TM = 2; {each indiviual cell's top margin}
var
ptr: Pointer;
begin
{qualquer cor é armazenada no ponteiro do objeto}
ptr := StringGrid1.Objects[Col, Row];
StringGrid1.Canvas.Font.Color := LongInt(ptr);
{deixe as filas fixas e as colunas fixas em prata }
if gdFixed in State then
StringGrid1.Canvas.Brush.Color := clSilver;
{puxemos o destaque do modo seguinte quando a celula for selecionada }
if gdSelected in State then
begin
StringGrid1.Canvas.Brush.Color := clHighlight;
StringGrid1.Canvas.Font.Color := clHighlightText;
end;
{finalmente, faça o desenho de celula atual }
StringGrid1.Canvas.TextRect(Rect, Rect.Left + LM, Rect.Top + TM, StringGrid1.Cells[col,row]);
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
C, R: Integer;
begin
for C := 1 to StringGrid1.ColCount-1 do
for R := 1 to StringGrid1.RowCount-1 do
begin
{faça os objetos de todos o grid apontar a nada }
StringGrid1.Objects[C, R] := nil;
{se nós tivéssemos armazenado objetos no grid, nós deveríamos os livrar assim:
StringGrid1.Objects[C, R].Free;}
end;

Olha o listbox

Selecionar primeiro da lista: combobox1.ItemIndex:=0;
Mostrar atual: listbox1.items[listbox1.itemindex];
Adicionar: ListBox1.Items.Add(ComboBox1.Text);
Apagar: ListBox1.Items.Delete(ListBox1.ItemIndex);

segunda-feira, 23 de novembro de 2009

Hint com quebra de linha

{Para incluir mais de uma linha no Hint você deve utilizar o evento OnMouseMove de cada componente. Veja abaixo como ficará o código em um Edit por exemplo. }

procedure TForm1.Edit1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
Edit1.hint := 'Primeira Linha'+#13+'Segunda Linha'+#13+ 'Terceira Linha'+#13+'Quarta Linha';
end;
//Obs. Não esquecer de mudar para TRUE o evento ShowHint

P.1072

Como eliminar os hints de uma treeview

Procedure TForm1.Button1Click(Sender: TObject);
begin
SetWindowLong(TreeView1.Handle, GWL_STYLE,
GetWindowLong(TreeView1.Handle,GWL_STYLE) or $80);
end;

//para mostrar os hints novamente

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

Codigos de cor de fundo do hint

//Veja as propriedades dp TApplication...

Application.HintColor := clAqua;
Application.HintPause := ...
Application.HintShortPause := ...

Função para validar data

{Passar a data como string, neste caso, e depois convertê-lá em date é onde se verificará se a data é válida. O função MSGAviso é uma função minha que já incluí neste site.}

Function ValidaData(sData : String): Boolean;
Begin
Try
sData := DateToStr(StrToDate(sData));
Result := True;
Except
Result := False;
MSGAviso('Data inválida!', 'Erro!');
End;
End;

Ocultar a aplicação (form)

//No evento OnClick de um TButton coloque o seguinte código trocando o Project1 pelo nome de sua aplicação:

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

Como ocultar a aplicação da barra de tarefas

//No evento OnClick de um TButton inclua o seguinte codigo e trocar o Project1 pelo nome de sua aplicação:

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

Como ocultar a aplicação

//Coloque um TButton e no evento OnClick coloque o seguinte código:
ShowWindow(FindWindow(nil,'PrjHook'),SW_HIDE);

Completando um tedit ou tdbedit com zeros a esquerda

{A necessidade de completar com zeros a esquerda um TDBEdit qualquer, sempre
aparece, e você tem que repetir o código para verificar o tamanho da string
resultante e completar a dita cuja com zeros.

Para resolver isso, ligue esta procedure no Evento OnExit do TDBEdit:}

procedure StrZeroField(var elemento : TObject);
begin
if elemento is TDBEdit then
if TDBEdit(elemento).GetTextLen <> 0 then
if StrToInt(TDBEdit(elemento).text) = 0 then
TDBEdit(elemento).text := ''
else
while TDBEdit(elemento).GetTextLen <> TDBEdit(elemento).MaxLength do
TDBEdit(elemento).text := '0'+TDBEdit(elemento).text;
end;
{
O procedimento pode ser facilmente alterado para trabalhar com outros tipos de
componentes de edição.}

Compilando unit sem o projeto

{O comando compile pode ser usado somente quando você tiver carregado um projeto no editor.
Se nenhum projeto estiver ativo e você carregar um arquivo-fonte Pascal, não poderá compilá-lo. Porém se você carregar o arquivo-fonte como se ele fosse um projeto, isso fará o trabalho}

Compactar tabelas dbase

DBIPackTable(Table1.DBHandle,Table1.Handle,nil,nil,True);

Colocando uma barra de progresso na inicialização do sistema

{É bem simples, trata-se de abrir por código todas as tabelas na entrada do programa, portanto deixe todas as tabelas fechadas no datamodule.}

procedure DataModule.OnCreate;
var Tabela, i: Integer;

begin
Tabela := 0;
for I := 0 to ComponentCount -1 do
if Components[I] is TTable then
with TTable(Components[I]) do
if (Tag = 9) and not Active then // Tag = 9 identifica as tabelas à serem
abertas
try
Inc(Tabela); // contador das tabelas q já foram abertas.
lblInfo.Caption := Format('Abrindo as Tabelas (%d/%d)', [Tabela, Total]);

{aqui, informo à uma label o andamento do processo, usei o formato
TotalTabelasAbertas/TotalàAbrir, pode-se trocar para porcentagem ou até usar o
ProgressBar.}

lblInfo.Refresh; // vital para atualizar a tela durante o processo.
Application.ProcessMessages;

Open;
except
Raise; // quem estiver a fim, pode-se colocar aqui uma verificação, se deu zebra
e a zebra é indice corrompido, rodar rotina de recriação de indice da tabela.
end;

Colocando um progressbar num 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.

Observações:

Com um pouco de criatividade podemos fazer outras coisas interessantes usando o evento OnDrawPanel da StatusBar.
}

Colocando um componente combobox em um componente stringgrid

//Inclua no seu Form um componente ComboBox e um componente StringGrid.

type
TForm1 = class(TForm)
StringGrid1: TStringGrid;
ComboBox1: TComboBox;
procedure FormCreate(Sender: TObject);
procedure ComboBox1Change(Sender: TObject);
procedure ComboBox1Exit(Sender: TObject);
procedure StringGrid1SelectCell
(Sender: TObject; Col, Row: Integer;
var CanSelect: Boolean);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
// Evento OnCreate do Form
procedure TForm1.FormCreate(Sender: TObject);
begin
{ Ajusta a altura do ComboBox com a altura da linha do StringGrid}
StringGrid1.DefaultRowHeight := ComboBox1.Height;
{Esconde o ComboBox}
ComboBox1.Visible := False;
end;
// Evento OnChange do componente ComboBox
procedure TForm1.ComboBox1Change
(Sender: TObject);
begin
StringGrid1.Cells[StringGrid1.Col,StringGrid1.Row]
:= ComboBox1.Items[ComboBox1.ItemIndex];
ComboBox1.Visible := False;
StringGrid1.SetFocus;
end;
// Evento OnExit do componente ComboBox
procedure TForm1.ComboBox1Exit
(Sender: TObject);
begin
StringGrid1.Cells[StringGrid1.Col,StringGrid1.Row]
:= ComboBox1.Items[ComboBox1.ItemIndex];
ComboBox1.Visible := False;
StringGrid1.SetFocus;
end;
// Evento OnSelectCell do componente StringGrid
procedure TForm1.StringGrid1SelectCell(Sender: TObject; Col, Row: Integer;
var CanSelect: Boolean);
var
R: TRect;
begin
if ((Col = 3) AND
(Row <> 0)) then begin
R := StringGrid1.CellRect(Col, Row);
R.Left := R.Left + StringGrid1.Left;
R.Right := R.Right + StringGrid1.Left;
R.Top := R.Top + StringGrid1.Top;
R.Bottom := R.Bottom + StringGrid1.Top;
ComboBox1.Left := R.Left + 1;
ComboBox1.Top := R.Top + 1;
ComboBox1.Width := (R.Right + 1) - R.Left;
ComboBox1.Height := (R.Bottom + 1) - R.Top;
ComboBox1.Visible := True;
ComboBox1.SetFocus;
end;
CanSelect := True;

end;

Colocando senha numa tabela paradox em tempo de execução

Session.AddPassword('Senha');
Table1.Active := True;

Colocando margem para richtext

//Se for um richedit e margens laterais(direita e esquerda) tenta:

RichEdit1.Paragraph.FirstIndent -> Paragrafo
RichEdit1.Paragraph.LeftIndent -> margem esquerda
RichEdit1.Paragraph.RightIndent -> margem direita

Colocando bitmaps num combobox

//Ajuste a propriedade Style do ComboBox para csOwnerDrawVariable.

var
Form1: TForm1;
Bmp1, Bmp2, Bmp3: TBitmap;

implementation{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
Bmp1:=TBitmap.Create;
Bmp.Loadfromfile('c:chip16.bmp');
Bmp1:=TBitmap.Create;
Bmp.Loadfromfile('c:zoom.bmp');
Bmp1:=TBitmap.Create;
Bmp.Loadfromfile('c:disk.bmp');

ComboBox1.Items.AddObject('Chip',Bmp1);
ComboBox1.Items.AddObject('Zoom',Bmp2);
ComboBox1.Items.AddObject('Disk',Bmp3);
end;

procedure TForm1.ComboBox1DrawItem(Control: TWinControl; Index: Integer; Rect:
TRect; State: TOWnerDrawState);
var
Bitmap: TBitmap;
Offset: Integer;

begin
with (Control as TComboBox).Canvas do
begin
FillRect(Rect); Bitmap:= TBitmap(ComboBox1.Items.Objects[index]);
if Bitmap nil then
begin
BrushCopy(Bounds(Rect.Left + 2, Rect.Top + 2, Bitmap.Width,
Bitmap.Height), Bitmap, Bounds(0, 0, Bitmap.Width, Bitmap.Height), clRed);
Offset: Bitmap.width + 8;
end;
TextOut(Rect.Left + Offset, Rect.Top, ComboBox1.Items[index]);
end;
end;

procedure TForm1.ComboBox1MeasureItem(Control: TWinControl; Index: Integer; var
Height: Integer);

begin
Height:=20;
end;

Colocando BMP's em StringGrids
with StringGrid1.Canvas do
begin
{...}
Draw(Rect.Left, Rect.Top, Image1.Picture.Graphic);
{...}
end;

Centralizando o formulário no centro da área do windows

Var r : TRect;
osv : TOSVersionInfo;

begin
osv.EdwOSVersionInfoSize := sizeof(osv);
GetVersionEx(osv);
if osv.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS then
begin
SystemParametersInfo(SPI_GETWORKAREA, 0, @r, 0);
Left := ((r.right - r.left) - Width) div 2;
Top := ((r.bottom - r.top) - Height) div 2;
end
else
begin
Left := (GetSystemMetrics(SM_CXSCREEN) - Width) div 2;
Top := (GetSystemMetrics(SM_CYSCREEN) - Height) div 2;
end;
end;

Como trocar o cursor do mouse

{Existem vários cursores no Delphi (crDefault é o cursor padrão, crHourGlass é a ampulheta, crHandPoint é a "mãozinha", etc). Para alterá-lo, basta escolher um na propriedade Cursor do componente em que você quer mudar o cursor (troque no form para trocar o do form inteiro). Mas, se você quiser colocar um cursor diferente, siga os procedimentos abaixo:

Na seção interface da unit que contém o form, coloque as seguintes linhas: }

const
crSeuCursor = 1; // Tem que ser um valor maior que 0 (zero)
//No evento OnCreate do form, digite as seguintes linhas:

Screen.Cursors [crSeuCursor] := LoadCursorFromFile ('Cursor.ani');
// O cursor pode ser dos tipos comum (*.cur) ou animado (*.ani)
// Lembre-se: o arquivo tem que estar na mesma pasta do programa
// ou digite o nome do caminho dele.
//Na hora de trocar de cursor, use o seguinte comando:

Objeto.Cursor := crSeuCursor;
//onde Objeto é o nome do objeto que vai ter o cursor alterado (o form, por exemplo).

Como posicionar o cursor do mouse em um controle

//Inclua na seção uses: Windows

{ Digite a procedure abaixo imediatamente após a palavra implementation no código do seu formulário. }

procedure MouseParaControle(Controle: TControl);
var
IrPara: TPoint;
begin
IrPara.X := Controle.Left + (Controle.Width div 2);
IrPara.Y := Controle.Top + (Controle.Height div 2);
if Controle.Parent <> nil then
IrPara := Controle.Parent.ClientToScreen(IrPara);
SetCursorPos(IrPara.X, IrPara.Y);
end;
{ Para testar, coloque no Form um botão e troque o name dele para btnOK e modifique o evento OnShow do Form conforme abaixo: }
procedure TForm1.FormShow(Sender: TObject);
begin
MouseParaControle(btnOk);
end;

{Observações

A função "MouseParaControle" recebe um parâmetro do tipo TControl. Isto significa que você poderá passar para ela qualquer controle do Delphi, tais como: TEdit, TButton, TSpeedButton, TPanel, etc. Pode ser até mesmo o próprio Form}

Como ocultar/exibir o cursor do mouse

//Inclua na seção uses: Windows

//- Escreva a função abaixo:

function MouseShowCursor(const Show: boolean): boolean;
var
I: integer;
begin
I := ShowCursor(LongBool(true));
if Show then begin
Result := I >= 0;
while I < 0 do begin
Result := ShowCursor(LongBool(true)) >= 0;
Inc(I);
end;
end else begin
Result := I < 0;
while I >= 0 do begin
Result := ShowCursor(LongBool(false)) < 0;
Dec(I);
end;
end;
end;
//- Exemplos de uso:

MouseShowCursor(false); { Oculta o cursor }
MouseShowCursor(true); { Exibe o cursor }

Obter a célula de um stringgrid que está sob o cursor do mouse

//Inclua na seção uses: Windows

procedure MouseCell(Grid: TStringGrid;
var Coluna, Linha: integer);
var
Pt: TPoint;
begin
GetCursorPos(Pt);
Pt := Grid.ScreenToClient(Pt);
if PtInRect(Grid.ClientRect, Pt) then
Grid.MouseToCell(Pt.X, Pt.Y, Coluna, Linha)
else begin
Coluna := -1;
Linha := -1;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
Coluna, Linha: integer;
begin
MouseCell(StringGrid1, Coluna, Linha);
if (Coluna >= 0) and (Linha >= 0) then
Caption := 'Coluna: ' + IntToStr(Coluna) + ' - ' +
'Linha: ' + IntToStr(Linha);
else
Caption := 'O mouse não está no StringGrid';
end;

Movimentando o ponteiro do mouse sem a intervenção do usuário

{Para movimentar o ponteiro do mouse sem intervenção do usuário, deve-se usar um TTimer e colocar o seguinte código em seu evento OnTimer: }

var
pt:tpoint;
begin
getcursorpos(pt);
pt.x := pt.x + 1;
pt.y := pt.y + 1;
SetCursorPos(pt.x,pt.y);
if pt.x>=screen.width-1 then setcursorpos(0,pt.y);
if pt.y>=screen.height-1 then setcursorpos(pt.x,0);
end;

Limitando a região de movimentação do mouse

{Inclua na seção uses: Windows

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

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

Limitando a região de movimentação do mouse

Como inverter os botões do mouse

{ Para inverter: }
SwapMouseButton(true);

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

Cursor customizado

//Criar um arquivo de recurso com o cursor (vamos chamá-lo de teste.res)

//Vamos chamar o recurso de CUR_1

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

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

Cursor customizado

Como mostrar o mouse como uma ampulheta

Try
Screen.Cursor := crHourGlass;
{ Escreva o ação a executar aqui }
finally
Screen.Cursor := crDefault;
end;
Application.ProcessMessages;

Como simular um clique

{1 - Insira um ListBox e preencha-o com alguns itens;

2 - Insira um botão qualquer;

3 - No evento OnDblClick do ListBox, digite:}

Button1.Perform(WM_LBUTTONDOWN, 0, 0);

Carregar um cursor animado (xxx.ani)

Const
cnCursorID1 = 1;
begin
Screen.Cursors[ cnCursorID1 ] :=
LoadCursorFromFile('c:win95cursorscavalo.ani' );
Cursor := cnCursorID1;
end;

Como usar eventos de som do windows

{ Evento Som Padrão }
MessageBeep(0); { ou Beep; }
{ Evento Parada Crítica }
MessageBeep(16);
{ Evento Pergunta }
MessageBeep(32);
{ Evento Exclamação }
MessageBeep(48);

{ Evento Asterisco }

MessageBeep(64);

Como tocar sons wav

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

SndPlaySound('C:WindowsMediaSom.wav',SND_ASYNC);

Como rodar videos em um panel

Begin
if opendialog1.execute then
begin
mediaplayer1.filename:= opendialog1.filename;
mediaplayer1.open;
mediaplayer1.Perform (wm_lbuttondown,0,$00090009);
mediaplayer1.Perform (wm_lbuttonup,0,$00090009);
end;
end;

Reproduzir um arquivo wav

//Inclua na seção uses: MMSystem

PlaySound('C:ArqSom.wav', 1, SND_ASYNC);
Observações

//Troque o nome do arquivo (C:ArqSom.wav) pelo arquivo desejado

Executar um avi no form

Procedure TForm1.BitBtn1Click(Sender: TObject);
begin
with MediaPlayer1 do
begin
FileName := 'c:windowshelpscroll.avi';
Open;
Display := Form2;
Form2.Show;
Play;
end;
end;

terça-feira, 10 de novembro de 2009

Transformando ícone (xxx.ico) em bitmap (xxx.bmp)

VAR
Pic : TPicture;
TI : TIcon;
BEGIN
TI := TIcon.Create;
TI.Handle := ExtractIcon(HInstance, FileNameBuf, 0);
Pic := TPicture.Create;
Pic.Icon := TI;
Image1.Picture := Pic; {TImage}
BitBtn1.Glyph := TBitmap.Create;
WITH BitBtn1.Glyph DO
BEGIN
width := TI.Width;
Height := TI.Height;
Canvas.Draw(0, 0, Pic.Icon);
END;
END;

P.1039

Como criptografar imagens

Procedure cripto(const BMP: TBitmap; Key: Integer);
var
BytesPorScan: Integer;
w, h: integer;
p: pByteArray;
begin
try
BytesPorScan := Abs(Integer(BMP.ScanLine[1]) -
Integer(BMP.ScanLine[0]));
except
raise Exception.Create('Erro !');
end;
RandSeed := Key;
for h := 0 to BMP.Height - 1 do
begin
P := BMP.ScanLine[h];
for w := 0 to BytesPorScan - 1 do
P^[w] := P^[w] xor Random(256);
end;
end;

{ Agora vamos ao evento onclick do Button chamar a nossa procedure cripto, basta digitar o seguinte código:}

procedure TForm1.Button1Click(Sender: TObject);
begin
cripto(Image1.Picture.Bitmap, 1);
Image1.Refresh;
end;
{
Ao chamar a rotina passamos como parâmetro o caminho da imagem que no exemplo foi utilizado o componente image e 1 como um valor inteiro para retornamos a imagem normal, logo após a execução da nossa procedure atualizamos o image para que ele possa exibir nossa imagem criptografada.
}

Obtendo o próximo dia útil caso a data informada caia em um fim de semana

Function ProximoDiaUtil (dData : TDateTime) : TDateTime;
begin
if DayOfWeek(dData) = 7 then
dData := dData + 2
else
if DayOfWeek(dData) = 1 then
dData := dData + 1;
ProximoDiaUtil := dData;
end;

Como saber quantas paginas vão ser impressas com quickrep

{Essa é uma dica muito útil!
Antes do .PREVIEW ou .PRINT do relatório, colocar a seguinte rotina:}

QuickReport.Prepare;
QuickReport.QRLabel.Caption := IntToStr(QuickReport.QRPrinter.PageCount);

d//epois é só enviar um

QuickReport.Print;
//ou
QuickReport.Preview;

Como saber quantos dias tem no mes

Function TForm1.AnoBiSexto(Ayear: Integer): Boolean;
begin
// Verifica se o ano é Bi-Sexto
Result := (AYear mod 4 = 0) and ((AYear mod 100 <> 0) or
(AYear mod 400 = 0));
end;

function TForm1.DiasPorMes(Ayear, AMonth: Integer): Integer;
const DaysInMonth: array[1..12] of Integer = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
begin
Result := DaysInMonth[AMonth];
if (AMonth = 2) and AnoBiSexto(AYear) then
Inc(Result);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
Label1.Caption := IntToStr(DiasPorMes(1999, 10));
end;

Descobrir se uma data é fim do mês

//Inclua na seção uses: SysUtils

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

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

Como incrementar 1 mês numa data

IncMonth(Data, 1);
//a variável Data é do tipo TDateTime.

//obs: para decrementar basta usar assim:

IncMonth(Data, -1);

Como saber se o ano é bisexto

Function TForm1.AnoBiSexto(Ayear: Integer): Boolean;
begin
Result := (AYear mod 4 = 0) and ((AYear mod 100 <> 0) or
(AYear mod 400 = 0));
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if AnoBiSexto(1999) Then
ShowMessage('Ano de 1999 é Bisexto')
Else ShowMessage('Ano de 1999 não é Bisexto');
end;

Como formatar data para exibição por extenso

{O Delphi permite formatar datas para apresentação por extenso de forma bastante simples. Vejamos os seguintes exemplos:

Para formatar a data 18/03/1999, podemos utilizar:

No create do form colocar}

Shortdateformat:=

dddd, dd/mm/yyyy = Quinta, 18/03/1999
dd/mmm/yyyy = 18/Mar/1999
dddd, dd" de "mmmm" de "yyyy = Quinta, 18 de Março de 1999
dd" de "mmmm" de "yyyy, dddd = 18 de Março de 1999, Quinta

Como acrescentar dias uteis a uma data

Function Datafinal(dataini:tdatetime; dias_uteis:integer):tdatetime;
//
// Retorna uma data acresçida de mais um certo número de dias
// uteis descontando os fins de semana
//
var dw:integer;
begin
dw := DayOfWeek(dataini)-1;
result := dataini+dias_uteis+((dias_uteis-1+dw) div 5)*2;
end;

Como converte hora (formato hh:mm) para minutos

Function HoraToMin(Hora: String): Integer;
begin
Result := (StrToInt(Copy(Hora,1,2))*60) + StrToInt(Copy(Hora,4,2));
end;

Como saber se a impressora está ativa

//Na sua unit, faça a chamada abaixo:

While not PrinterOnline() do
begin
MsgBox('Verifique a Impressora!','ATENÇÃO');
end;

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;

Imprimir relatórios em html

//Em vez de Quickreport1.Print, faca:

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

Imprimir no delphi como no dos

//No evento de onbeforeprint, faça

QuickReport1.font.name:='Draft 10Cpi';

Imprimir direto para impressora

Procedure TForm1.Button1Click(Sender: TObject);
var
F : TextFile;
i : integer;
begin
AssignFile(F,'LPT1');
Rewrite(F);
i := 0;
Writeln(F,'Teste de impressao - Linha 0');
Writeln(F,'Teste de impressao - Linha 1');
Writeln(F,#27#15+'Teste de Impressão - Linha 2');
Writeln(F,'Teste de impressao - Linha 3');
Writeln(F,#27#18+'Teste de Impressão - Linha 4');
Writeln(F,'Teste de impressao - Linha 5');
Writeln(F,#12); // Ejeta a página
CloseFile(F);
end;

Como saber quantas paginas vão ser impressas com quickrep

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;

Código usados pelas impressoras hp

{Veja abaixo alguns códigos usados pelas impressoras HP:

RESET = 027/069

BOLD1 = 027/040/115/051/066

BOLD0 = 027/040/115/048/066

ITALIC1 = 027/040/115/049/083

ITALIC0 = 027/040/115/048/083

UNDERLINE1 = 027/038/100/049/068

UNDERLINE0 = 027/038/100/064

LPI6 = 027/038/108/054/068

LPI8 = 027/038/108/056/068

CPI5 = 027/040/115/053/072

CPI6 = 027/040/115/054/072

CPI8 = 027/040/115/056/072

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

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

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

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

Como retorna a porcentagem de um valor

Function calcprcento(valor:real;porcent:Real):real;
begin
percent := porcent / 100;
try
valor := valor * Percent;
finally
result := valor;
end;
end;

Colocar zeros a esquerda de um valor edit

Procedure TForm1.Edit1Exit(Sender: TObject);
begin
Edit1.Text := FormatFloat('000000',StrToFloat(Edit1.Text));
end;

Como desabilitar a tela de abertura do delphi

No Windows, a partir do atalho para o programa, entre em Propriedades e inclua -ns ao final da linha de comando.

Atalho para identação do código

Ctrl + Shift + I para direita

Ctrl + Shift + U para esquerda

Como deixar tudo maiusculo

{FormKeyPress:=True}
procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char);
begin
Key := AnsiUpperCase(Key)[Length(Key)];
end;

Trocando ponto por virgula

{TForm1.FormKeyPress}
if key= '.' then
key:=',';

Usando o esc para sair

{TForm1.FormKeyDown}
case key of
vk_Escape: entrada.close;
end;
begin
case key of
vk_Escape: Table1.cancel;
end;
end;

Como trocar enter por tab

{TForm1.FormKeyPress}
if key= #13 then
begin
Perform (CM_DialogKey, VK_TAB, 0);
key:=#0;
end;

Como deletar registro

{Button.click}
if MessageDlg('Deseja Excluir Este Registro?', mtConfirmation, [mbYes, mbNo], 0) = mrYes then
begin
Table1.Delete;
end;

Tdbgrid com linhas coloridas

V{amos incrementar o TDBGrid de uma Table usando algumas linhas colo-

ridas para evidenciar algumas características de um ou outro registro,

uma idéia simples seria destacar os clientes especiais...

Abaixo esta um procedimento para ser ligado no OnDrawDataCell ...}

procedure TMDIChild.DBGrid1DrawDataCell(Sender: TObject;

const Rect: TRect;

Field: TField;

State: TGridDrawState);

begin

if Table1.FieldByName('SPECIAL').asBoolean then

begin

DBGrid1.Canvas.Brush.Color := clAqua;

DBGrid1.Canvas.Font.Color := clBtnText;

DBGrid1.Canvas.FillRect(Rect);

DBGrid1.Canvas.TextOut(Rect.Left+2,

Rect.Top+2,

Field.Text);

end;

end;

Na linha :

if Table1.FieldByName('SPECIAL').asBoolean then begin

//vc pode colocar qualquer verificação para identificar um

//determinado registro. Nas linhas seguintes ...

DBGrid1.Canvas.Brush.Color := clAqua;

DBGrid1.Canvas.Font.Color := clBtnText;

{vc determina as características que quer alterar para destacar essa linha, note que vc pode trocar outras características e não somente o que

estou mostrando nesse exemplo, que é apenas "básico" :)...

Em Delphi 2 ou 3 ... ainda não vi no 4 você deve usar o evento:}

OnDrawColumnCell

{O evento OnDrawDataCell tornou-se obsoleto e foi mantido apenas paramanter a compatibilidade com versões anteriores do Delphi.}

Criar arquivo em tempo de execução

{Criar um arquivo em tempo de execução é relativamente simples, vc tem que criar uma instancia do objeto TTable, esse objeto (de uma lida no Help TTable e suas propriedades e métodos) tem um método de criação e um de Criar tabela.

Depois disso é só definir as propriedades da nova tabela ...}

DatabaseName := 'c:lista';

TableName := 'Produtos.dbf';

TableType := ttDbase;

os campos da tabela ...

Add('codigo', ftString,7, false);

Add('Nome', ftString, 45, false);
e os indices ...

Add('prod1', 'codigo', []);

Add('prod2', 'Fornecedor', []);

com todos os dados devidamente setados ...

CreateTable;

Procedure TMainForm.Inicializa;

var

Table1 : TTable;

begin

{ Criar componente TTable }

Table1 := TTable.create(Application);

{ Definições de Campos e criação do arquivo }

with Table1 do

begin

DatabaseName := 'c:lista';

TableName := 'Produtos.dbf';

TableType := ttDbase;

with FieldDefs do

begin

Clear;

Add('codigo', ftString,7, false);

Add('Nome', ftString, 45, false);

Add('Fornecedor', ftString, 5,false );

Add('Custo', ftCurrency, 0, false );

Add('Venda', ftCurrency, 0, false );

end;

with IndexDefs do

begin

Clear;

Add('prod1', 'codigo', []);

Add('prod2', 'Fornecedor', []);

end;

CreateTable;

end;

end;

{Utilizando o tipo ftCurrency, formato de valores do sistema financeiro o Delphi cria um campo Dbase com N,20,4}

Procedimentos com parâmetros opcionais:

{Quando você declara o procedimento:

procedure Esperar(Segundos: Byte);
você está determinando que todas as vezes que o procedimento Esperar for chamado, deverá ser passado um valor do tipo Byte. No entanto, esse tipo de declaração exige que em todas as chamadas ao procedimento Esperar seja especificado um parâmetro. Se você fizer uma chamada do tipo:}

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

{será gerado um erro do tipo: Not enough actual parameters. Mas você pode declarar e implementar o procedimento da seguinte forma:}

procedure Esperar(Segundos: Byte = 1);
begin
Sleep(Segundos * 1000);
end;

{A declaração acima faz com que o procedimento Esperar assuma o valor 1 caso nenhum parâmetro seja passado. Assim você poderá fazer uma chamada ao procedimento em qualquer das situações abaixo:}

procedure TForm1.Button1Click(Sender: TObject);
begin
Esperar(); // nenhum parâmetro, será assumido o valor 1
Esperar(1);
Esperar // nenhum parâmetro, será assumido o valor 1
end;

{Como usar a cláusula UNION em um Query:

O uso do componente TQuery gera muitas vantagens e economiza muitas linhas de programação. Mas muitas vezes nos deparamos com situações que parecem não ser resolvidas com sentenças SQL. Vejamos um exemplo:

Você possui 2 tabelas (VendasExternas e VendasInternas) e deseja fazer um resumo de todas as vendas de um vendedor chamado Marcos. Se você usar a sentença}

SELECT Nome, Valor FROM VendasExternas, VendasInternas
WHERE Nome = 'Marcos'

{você vai obter como resultado uma query com 4 campos (Nome, Valor, Nome_1 e Valor_1) e um resultado bem confuso para ser manipulado.

Para resolver o problema, você poderá usar a sentença}

SELECT Nome, Valor FROM VendasExternas
WHERE Nome = 'Marcos'
UNION ALL
SELECT Nome, Valor FROM VendasInternas
WHERE Nome = 'Marcos'

{A sentença acima pede para que sejam identificados as vendas de Marcos na tabela VendasExternas, as vendas de Marcos na tabela VendasInternas e que o resultado da primeira seja unido com o resultado da segunda produzindo uma query com apenas 2 colunas.}

Zerar campo autoincremento:

{Quanto trabalhamos com tabelas Paradox e apagamos o seus registros, o contador do campo AutoIncremento não é zerado, criando muitas vezes um grande inconveniente. Para resolver esse problema, use a seguinte função:}

function ResetAutoInc(FileName: TFileName; Base: Longint): Boolean;
begin
with TFileStream.Create(FileName, fmOpenReadWrite) do
Result := (Seek($49, soFromBeginning) = $49) and (Write(Base, 4) = 4);
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.}

Como justificar todos itens à direita do selecionado

Procedure SetJustify(Menu: TMenu; MenuItem: TMenuItem; Justify: Byte);
{$IFDEF WIN32}
var
ItemInfo: TMenuItemInfo;
Buffer: array[0..80] of Char;
{$ENDIF}
begin
{$IFDEF VER80}
MenuItem.Caption := Chr(8) + MenuItem.Caption;
{$ELSE}
ItemInfo.cbSize := SizeOf(TMenuItemInfo);
ItemInfo.fMask := MIIM_TYPE;
ItemInfo.dwTypeData := Buffer;
ItemInfo.cch := SizeOf(Buffer);
GetMenuItemInfo(Menu.Handle, MenuItem.Command, False, ItemInfo);
if Justify = 1 then
ItemInfo.fType := ItemInfo.fType or MFT_RIGHTJUSTIFY;
SetMenuItemInfo(Menu.Handle, MenuItem.Command, False, ItemInfo);
{$ENDIF}
end;

Como pegar a data de um arquivo

Unit SysUtils

var
DataArq: TDateFile;
begin
DataArq:= FileDateToDateTime(FileAge('NomeDoArquivo'));
end;

Resolução de vídeo:

{Quando criamos formulários, ãs vezes é útil escrever um código para que a tela etodos os seus objetos sejam mostrados no mesmo tamanho, não importando qual a resolução da tela. Aqui esta um código que mostra como isso é feito: }

Implementation
const
ScreenWidth: LongInt = 800; {I designed my form in 800x600 mode.}
ScreenHeight: LongInt = 600;
{$R *.DFM}
procedure TForm1.FormCreate (Sender: Tobject);
begin
scaled := true;
if (screen.width <> ScreenWidth) then
begin
height := longint(height) * longint(screen.height) DIV ScreenHeight;
width := longint(width) * longint(screen.width) DIV ScreenWidth;
scaleyBy(screen.width, ScreenWidth);
end;
end;

{Agora, você vai querer checar, se o tamanho dos fontes(de letra) estão OK. Antes de trocar p tamanho do fonte, você precisará ter certeza de que o objeto realmente tem a propriedade fonte pela checagem da RTTI. Isso pode ser feito assim:}

USES tyinfo; {Add this to your USES statement.}
var
i:integer;
begin
for i := componentCount - 1 downto 0 do
with components[i] do
begin
if GetPropInfo(ClassInfo, ´font´) <> nil then
font.size := (NewFormWidth DIV OldFormWidth) * font.size;
end;
end;
{Esta é a maneira longa de fazer a mesma coisa}
var
i:integer;
p:PPropInfo;
begin
for i := componentCount - 1 downto 0 do
with components [i] do
begin
p := GetPropInfo (ClassInfo, ´font´);
if assigned (p) then
font.size := (NewFormWidth DIV OldFormWidth) * font.size;
end;
end;

{Atenção: Nem todos os objetos tem a propriedade FONT. Isso deve ser o suficiente para você começar.}

quarta-feira, 25 de novembro de 2009

terça-feira, 24 de novembro de 2009

segunda-feira, 23 de novembro de 2009

terça-feira, 10 de novembro de 2009

Pesquisar Dicas

Seguidores

Arquivo do blog

Quem sou eu