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.