Artigos Delphi Dicas de 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 projeto, 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 mouse 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 projeto. Guarde o projeto da dll no mesmo diretó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


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;
Exemplos de como extrair os bitmaps da DLL

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;
  • ColoqueumButtonnoform
  • DigitenoeventoOnClickdoButtonocódigoabaixo: 
    
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


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

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;

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


var
Form1: TForm1;
Iniciar : hWnd;
OldBitmap : THandle;
NewImage : TPicture;
Variáveis globais 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 Oncreate do Form

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

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 código 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.