Dicas de Delphi

Você precisa estar logado para dar um feedback. Clique aqui para efetuar o login
Para efetuar o download você precisa estar logado. Clique aqui para efetuar o login
Confirmar voto
0
 (0)  (0)

Veja nesse artigo algumas dicas de Delphi e aumente ainda mais o seu conhecimento da linguagem Delphi.

Olá pessoal, tudo bom? No artigo de hoje iremos aprender diversas dicas na linguagem Delphi. Muitas delas são muito simples mas que muita gente não conhece e que vai ajudar bastante os desenvolvedores.

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;

Colocar os bitmaps na DLL

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

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

Código da DLL:

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

Usar os bitmaps que estão na DLL

Estão aqui alguns exemplos como extrair os bitmaps da DLL:

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

Colocar uma ProgressBar numa StatusBar

Coloque uma StatusBar no form e adicione dois painéis a ela (propriedade Panels). Ajuste as propriedades do primeiro painel comoStyle = psOwnerDraw e 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.

Como converter decimal para romanos

function DecToRoman( Decimal: LongInt ): String;
{Converte um numero decimal em algarismos romanos}
const
Romans: Array[1..13] of String = ( 'I', 'IV', 'V', 'IX', 'X',
'XL', 'L', 'XC', 'C', 'CD', 'D', 'CM', 'M' );
Arabics: Array[1..13] of Integer =( 1, 4, 5, 9, 10, 40, 50, 90,
100, 400, 500, 900, 1000);
var
i: Integer;
scratch: String;
begin
  scratch := '';
  for i := 13 downto 1 do
  while ( Decimal >= Arabics[i] ) do
  begin
  Decimal := Decimal - Arabics[i];
  scratch := scratch + Romans[i];
  end;
  Result := scratch;
end;

Ativar a proteção de tela do Windows

Inclua na seção uses: Windows.

{ Ativa a proteção de tela do Windows, se estiver configurada. }
SendMessage(Application.Handle, WM_SYSCOMMAND, SC_SCREENSAVE, 0);

Adicionar o evento OnClick do DBGrid

Problema: meu programa precisa processar algo quando o usuário clicar no DBGrid em um determinado form. O problema é que o DBGrid não possui o evento OnClick. É possível adicionar este evento no DBGrid? Solução: é possível sim. Afinal é muito simples. Siga os passos abaixo para resolver seu problema:

Monte seu form normalmente, colocando o DBGrid e demais componentes. Vá na seção "private" da unit e declare a procedure abaixo:

private
  procedure DBGridClick(Sender: TObject);

Logo após a palavra "implementation", escreva a procedure:

implementation
{$R *.DFM}
 
procedure TForm1.DBGridClick(Sender: TObject);
begin
  ShowMessage('Clicou no DBGrid.');
end;

Coloque as instruções abaixo no evento OnCreate do Form:

procedure TForm1.FormCreate(Sender: TObject);
begin
  DBGrid1.ControlStyle :=
  DBGrid1.ControlStyle + [csClickEvents];
  TForm(DBGrid1).OnClick := DBGridClick;
end;

E pronto. Execute e teste.

Observações: o segredo principal desta dica está OnCreate do Form. A primeira instrução ativa o evento OnClick. A segunda instrução acessa o manipulador do evento OnClick. Para isto precisamos tratar o DBGrid como se fosse Form, pois o evento OnClick está declarado como protegido (protected) na classe TDBGrid.

Alterar as cores do título de um DBGrid em tempo execução

Procedure TForm1.DBGrid1TitleClick(Column: TColumn); 
var 
  I : integer; 
begin 
  for i:=0 to DBGrid1.Columns.count-1 do begin 
  DBGrid1.Columns[i].Title.Color := clBtnFace; 
  DBGrid1.Columns[i].Title.Font.Color := clBlack; 
  DBGrid1.Columns[i].Title.Font.Style := []; 
  end; 
  Column.Title.color := ClYellow; 
  Column.Title.Font.Style := [ fsBold, fsItalic]; 
  Column.Title.Font.Color := clRed; 
end;

Alterar o papel de parede (1)

program wallpapr;
 
uses Registry, WinProcs;
 
procedure SetWallpaper(sWallpaperBMPPath : String; bTile :
boolean );
var
reg : TRegIniFile;
begin
// Mudando o Registro HKEY_CURRENT_USER
// Control Panel\Desktop
// TileWallpaper (REG_SZ)
// Wallpaper (REG_SZ)
reg := TRegIniFile.Create('Control Panel\Desktop' );
with reg do begin
WriteString( '', 'Wallpaper',sWallpaperBMPPath );
if( bTile )then begin
WriteString( '', 'TileWallpaper', '1' );
end else begin
WriteString( '', 'TileWallpaper', '0' );
end;
end;
reg.Free;
// Mostrar que o parametro do sistema foi alterado
SystemParametersInfo( SPI_SETDESKWALLPAPER,0, Nil,
SPIF_SENDWININICHANGE );
end;
begin
SetWallpaper( 'c:\winnt\winnt.bmp', False );
end.

Alterar papel de parede (2)

procedure ChangeWallpaper(bitmap: string);
var
pBitmap : pchar;
begin
bitmap:=bitmap+#0; {bitmap contém um arquivo *.bmp}
pBitmap:=@bitmap[1];
SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, pBitmap,
SPIF_UPDATEINIFILE);
end;

Mudar o papel de parede (3)

Para testar o exemplo abaixo inclua no seu form um componente Button e no evento OnClick o código abaixo:

procedure TForm1.Button1Click(Sender: TObject);
begin
SystemParametersInfo(SPI_SETDESKWALLPAPER,0,
PChar('C:\windows\Arenito.bmp'),SPIF_SENDWININICHANGE);
end;

Alterar o ícone do botão iniciar do Windows

Variáveis globais do form:

var
Form1: TForm1;
Iniciar : hWnd;
OldBitmap : THandle;
NewImage : TPicture;

No Oncreate do Form:

procedure TForm1.FormCreate(Sender: TObject);
begin
NewImage:=TPicture.create;
NewImage.LoadFromFile('C:\Delphi3\Images\DEFAULT\OutOpen.BMP');
Iniciar :=
FindWindowEx(FindWindow('Shell_TrayWnd',nil),0,'Button',nil);
OldBitmap:=SendMessage(Iniciar,BM_SetImage,0,NewImage.Bitmap.Hand
le);
end;

No OnDestroy:

procedure TForm1.FormDestroy(Sender: TObject);
begin
SendMessage(Iniciar,BM_SetImage,0,OldBitmap);
NewImage.Free;
end;

Desabilitar o botão fechar o form

procedure TForm1.Button1Click(Sender: TObject);
var
hwndHandle : THANDLE;
hMenuHandle : HMENU;
begin
hwndHandle := FindWindow(nil, 'Sem título - Bloco de Notas');
if (hwndHandle <> 0) then
begin
hMenuHandle := GetSystemMenu(hwndHandle, FALSE);
if (hMenuHandle <> 0) then
DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND);
end;
end;

Desabilitar Teclas Ctrl+Alt+Del

Ai vai um codigo que peguei no site da Borland que trava as teclas Ctrl+Alt+Del, Alt+Tab e Ctrl+Esc.

var
OldValue : LongBool;
begin
{liga a trava}
SystemParametersInfo(97, Word(True), @OldValue, 0);
{desliga a trava}
SystemParametersInfo(97, Word(False), @OldValue, 0);
end;

Descobrindo se há impressora instalada

try
// Set printer so, for get information
JustTest := Printer.Orientation;
IsPrinterSetup := true;
except
on EPrinter do IsPrinterSetup := false;
end;
if not IsPrinterSetup then
begin
SayAboutIt;
ExitProgram;
End;

Desabilita o botão Fechar do Formulário

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;

Mudar a cor da linha de um DBGrid

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; .....);
begin
   if odd(field.DataSet.RecNo) then 
      DBGrid1.Canvas.Font.Color := clBlue 
   else DBGrid1.Canvas.Font.Color := clWhite; 
      DBGrid1.DefaultDrawDataCell(Rect, dbgrid1.columns[datacol].field, state);
end;

Inicializar vários EDITs em um formulário

procedure TForm1.Button1Click(Sender: TObject);
   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;

Obtendo a data do último dia do mês, ou último dia útil, de uma data informada

Function LastDayOfMonth (Data : TDateTime; lSabDom : Boolean) : TDateTime;
var
  Ano, Mes, Dia : word;
  AuxData : TDateTime;
  DiaDaSemana : Integer;
begin
  AuxData := FirstDayOfMonth (NextMonth (Data), False) - 1;
  if lSabDom Then begin
    DecodeDate (Auxdata, Ano, Mes, Dia);
    DiaDaSemana := DayOfWeek (AuxData);
    if DiaDaSemana = 1 Then
       Dia := Dia - 2
    else
    if DiaDaSemana = 7 Then
       Dec (Dia);
       AuxData := EnCodeDate (Ano, Mes, Dia);
    end;
    LastDayOfMonth := AuxData;
end;

Function NextMonth(Date: TDateTime): TDateTime; 
var 
Year, Month, Day: word; 
Begin 
DecodeDate (Date, Year, Month, Day); 
if MonthOf(Date)=12 then 
Begin 
Inc(Year); 
Month := 1; 
End 
else 
Inc(Month); 
NextMonth := EncodeDate (Year, Month, Day); 
End;

Obtendo data do primeiro dia útil do mês

Function FirstDayOfMonth (Data : TDateTime; lSabDom : Boolean) : TDateTime;
  var
  Ano, Mes, Dia : word;
  DiaDaSemana : Integer;
begin
  DecodeDate (Data, Ano, Mes, Dia);
  Dia := 1;
  if lSabDom Then begin
     DiaDaSemana := DayOfWeek (Data);
    if DiaDaSemana = 1 Then
      Dia := 2
  else
    if DiaDaSemana = 7 Then
      Dia := 3;
  end;
  FirstDayOfMonth := EncodeDate (Ano, Mes, Dia);
end;

Obtendo o extenso de uma data informada

Function DataExtenso (dData : TDateTime) : string;
var
Ano, Mes, Dia : word;
begin
DecodeDate(dData, Ano, Mes, Dia);
DataExtenso := StrZero(Dia,2,0) + ' de ' + MesExtenso(Mes) + ' de ' + IntToStr(Ano);
end;

Function MesExtenso (xMes : Variant) : string;
  Var
  Dia, Mes, Ano : Word;
begin
  Mes := 0;
  Case VarType (xMes) of
    VarDate : DecodeDate (xMes, Ano, Mes, Dia);
    VarString :
  Try
     Mes := StrToInt (xMes);
  Except
  End;
  else
  Try
    Mes := Round (xMes);
  Except
  End;
  end;
  case Mes of
    1: Result := 'Janeiro';
    2: Result := 'Fevereiro';
    3: Result := 'Março';
    4: Result := 'Abril';
    5: Result := 'Maio';
    6: Result := 'Junho';
    7: Result := 'Julho';
    8: Result := 'Agosto';
    9: Result := 'Setembro';
    10: Result := 'Outubro';
    11: Result := 'Novembro';
    12: Result := 'Dezembro';
  else
  Result := '';
  end;
end;

Exemplo de uso: Label1.caption:=DataExtenso(now);

Por hoje é só, espero que tenham gostado e até o próximo artigo.

 
Você precisa estar logado para dar um feedback. Clique aqui para efetuar o login
Receba nossas novidades
Ficou com alguma dúvida?