function GetIP:string;//--> Declare a Winsock na clausula uses da unit
var
WSAData: TWSAData;
HostEnt: PHostEnt;
Name:string;
begin
WSAStartup(2, WSAData);
SetLength(Name, 255);
Gethostname(PChar(Name), 255);
SetLength(Name, StrLen(PChar(Name)));
HostEnt := gethostbyname(PChar(Name));
with HostEnt^ do
Result:=Format('%d.%d.%d.%d',[Byte(h_addr^[0]),
Byte(h_addr^[1]),Byte(h_addr^[2]),Byte(h_addr^[3])]);
WSACleanup;
end;
function DesconectaRede(Unidade:Pchar;ForcaCancel:boolean):String;
begin
WNetCancelConnection2(Unidade,0,ForcaCancel);
Case GetLastError() of
1205: Result := 'Não foi possível abrir o perfil';
1206: Result := 'Perfil do usuário não encontrado ou inválido';
1208: Result := 'Ocorreu um Erro específico na rede';
2138: Result := 'Rede não encontrada ou fora do ar';
2250: Result := 'Mapeamento inválido ou não encontrado';
2401: Result := 'Existem muitos arquivos abertos';
else Result := 'Unidade disconectada com sucesso';
end;
end;
var OldValue : LongBool;
begin
SystemParametersInfo(97, Word(True), @OldValue, 0);
end;
Destravar as teclas: Alt+Tab, Ctrl+Esc, Ctrl+Alt+Del
var OldValue : LongBool;
begin
SystemParametersInfo(97, Word(False), @OldValue, 0);
end;
var H : HWnd;
begin
H := FindWindow(Nil,'Project1');
if H <> 0 then
ShowWindow(H,SW_HIDE);
end;
procedure ParadoxPack(Table : TTable);
var
TBDesc : CRTblDesc;
hDb: hDbiDb;
TablePath: array[0..dbiMaxPathLen] of char;
begin
FillChar(TBDesc,Sizeof(TBDesc),0);
with TBDesc do
begin
StrPCopy(szTblName,Table.TableName);
StrPCopy(szTblType,szParadox);
bPack := True;
end;
hDb := nil;
Check(DbiGetDirectory(Table.DBHandle, True, TablePath));
Table.Close;
Check(DbiOpenDatabase(nil,'STANDARD',dbiReadWrite,dbiOpenExcl,nil,0,nil,nil,hDb));
Check(DbiSetDirectory(hDb, TablePath));
Check(DBIDoRestructure(hDb,1,@TBDesc,nil,nil,nil,False));
Table.Open;
end;
function TrocaResolucao(X, Y: word): Boolean;
var lpDevMode: TDeviceMode;
begin
if EnumDisplaySettings(nil, 0, lpDevMode) then
begin
lpDevMode.dmFields := DM_PELSWIDTH Or DM_PELSHEIGHT;
lpDevMode.dmPelsWidth := X;
lpDevMode.dmPelsHeight:= Y;
Result := ChangeDisplaySettings(lpDevMode, 0) = DISP_CHANGE_SUCCESSFUL;
end;
end;
function NomeComputador : String;
var
lpBuffer : PChar;
nSize : DWord;
const Buff_Size = MAX_COMPUTERNAME_LENGTH + 1;
begin
nSize := Buff_Size;
lpBuffer := StrAlloc(Buff_Size);
GetComputerName(lpBuffer,nSize);
Result := String(lpBuffer);
StrDispose(lpBuffer);
end;
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;
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;
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;
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;
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.
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.
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;
