Decedi começar a ajudar o forum ... Ca vai alguns comandos para os vossos projectos delphi :D 1. Desabilita o botão Fechar do Formulário (topo)
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;
2. Mudar a cor da linha de um DBGrid (topo)
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;
3. Inicializar vários EDITs em um formulário (topo)
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;
4. Nome do computador (topo)
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;
5. Trocar a resolução de vídeo (topo)
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;
6. Executar Pack em Tabelas Paradox (topo)
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;
7. Esconder a aplicação da barra de tarefas (topo)
var H : HWnd;
begin
H := FindWindow(Nil,'Project1');
if H <> 0 then
ShowWindow(H,SW_HIDE);
end;
8. Travar as teclas: Alt+Tab, Ctrl+Esc, Ctrl+Alt+Del (topo)
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;
9. Desconectar uma unidade de rede mapeada (topo)
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;
10. Retorna o IP da Máquina (topo)
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;
11. Retorna o Nome do Usuário logado na rede (topo)
function LogUser : String; //Declare Registry na clausula uses da unit
var Registro: TRegistry;
begin
Registro := TRegistry.Create;
Registro.RootKey := HKEY_LOCAL_MACHINE;
if Registro.OpenKey('Network\Logon', false) then
result := Registro.ReadString('username');
Registro.Free;
end;
12. Copiar um arquivo de um lugar para outro (topo)
Procedure CopyFile( Const sourcefilename, targetfilename: String );
Var S, T: TFileStream;
Begin
S := TFileStream.Create( sourcefilename, fmOpenRead );
try
T := TFileStream.Create( targetfilename, fmOpenWrite or fmCreate );
try
T.CopyFrom(S, S.Size );
finally
T.Free;
end;
finally
S.Free;
end;
end;
13. Capturar a tela em um TBitmap (topo)
function CaptureScreenRect( ARect: TRect ): TBitmap;
var ScreenDC: HDC;
begin
Result := TBitmap.Create;
with Result, ARect do
begin
Width := Right - Left;
Height := Bottom - Top;
ScreenDC := GetDC( 0 );
try
BitBlt( Canvas.Handle, 0, 0, Width, Height, ScreenDC, Left, Top, SRCCOPY );
finally
ReleaseDC( 0, ScreenDC );
end;
end;
end;
// Exemplo: Image1.picture.Assign(CaptureScreenRect(Rect(0,0,Width,Height)));
14. Saber qual a impressora padrão do Windows (topo)
function CorrentPrinter :String; //Declare a unit Printers na clausula uses
var
Device : array[0..255] of char;
Driver : array[0..255] of char;
Port : array[0..255] of char;
hDMode : THandle;
begin
Printer.GetPrinter(Device, Driver, Port, hDMode);
Result := Device+' na porta '+Port;
end;
15. Função de Criptografia de 32 Bits (topo)
Para criptografar passe como paramêtros 3 valores inteiros quaisquer.
Para referter a criptografia utilize os mesmos valores
{$R-} {$Q-}
function EncryptSTR(const InString:string; StartKey,MultKey,AddKey:Integer): string;
var I : Byte;
begin
Result := '';
for I := 1 to Length(InString) do
begin
Result := Result + CHAR(Byte(InString[I]) xor (StartKey shr 8));
StartKey := (Byte(Result[I]) + StartKey) * MultKey + AddKey;
end;
end;
function DecryptSTR(const InString:string; StartKey,MultKey,AddKey:Integer): string;
var I : Byte;
begin
Result := '';
for I := 1 to Length(InString) do
begin
Result := Result + CHAR(Byte(InString[I]) xor (StartKey shr 8));
StartKey := (Byte(InString[I]) + StartKey) * MultKey + AddKey;
end;
end;
{$R+} {$Q+}
16. Função ocultar a Barra de Tarefas (topo)
procedure SetTaskBar(Visible: Boolean);
var
wndHandle : THandle;
wndClass : array[0..50] of Char;
begin
StrPCopy(@wndClass[0],'Shell_TrayWnd');
wndHandle := FindWindow(@wndClass[0], nil);
If Visible = True then
ShowWindow(wndHandle, SW_RESTORE)
else ShowWindow(wndHandle, SW_HIDE);
end;
17. Função ocultar o Botão Iniciar (topo)
procedure EscondeIniciar(Visible:Boolean);
Var taskbarhandle, buttonhandle : HWND;
begin
taskbarhandle := FindWindow('Shell_TrayWnd', nil);
buttonhandle := GetWindow(taskbarhandle, GW_CHILD);
if Visible then
ShowWindow(buttonhandle, SW_RESTORE) {mostra o botão}
else ShowWindow(buttonhandle, SW_HIDE); {esconde o botão}
end;
18. Função para tornar o FORM Não-Retangular (topo)
procedure TForm1.FormResize;
var Region : HRGN;
begin
Region := CreateEllipticRgn(0,0,width,height);
SetWindowRgn(Handle, Region, True);
end;
19. Linha e coluna do curso em um MEMO (topo)
Procedure PosicaoMemo (M : TMemo; Var Linha, Coluna : Integer);
Begin
Linha := M.Perform (EM_LINEFROMCHAR, M.SelStart, 0);
Coluna := M.SelStart - M.Perform (EM_LINEINDEX, Linha, 0);
End;
20. Como deletar uma pasta com arquivos e subpastas dentro (topo)
procedure DeletaDir(const RootDir:string);
var
SearchRec: tSearchREC;
Erc:Integer;
Begin
try
{$I-}
ChDir(rootdir);
if IOResult <> 0 then
Exit;
FindFirst('*.*', faAnyFile, SearchRec);
Erc:=0;
while Erc=0 do
begin
if ((searchRec.Name <> '.') and (searchrec.Name<>'..')) then
if (SearchRec.Attr and faDirectory>0) then
DeletaDir(SearchRec.Name)
Else DeleteFile(Searchrec.Name);
Erc:=FindNext ( SearchRec);
Application.ProcessMessages;
end;
finally
If Length (RootDir)>3 then
Chdir('..');
end;
RmDir(rootDir);
{$I+}
End;
21. Função para ZERAR o valor de um campo Auto-Incremento (topo)
function ResetAutoInc(FileName: TFileName; Base: Longint): Boolean;
//FileName é o nome da tabela, incluindo o caminho. Base é novo valor para o campo.
begin
with TFileStream.Create(FileName, fmOpenReadWrite) do
Result := (Seek($49, soFromBeginning) = $49) and (Write(Base, 4) = 4);
end;
22. Função para formatar Disquetes (topo)
{implementation section}
....
const SHFMT_ID_DEFAULT = $FFFF;
// Formating options
SHFMT_OPT_QUICKFORMAT = $0000;
SHFMT_OPT_FULL = $0001;
SHFMT_OPT_SYSONLY = $0002;
// Error codes
SHFMT_ERROR = $FFFFFFFF;
SHFMT_CANCEL = $FFFFFFFE;
SHFMT_NOFORMAT = $FFFFFFFD;
function SHFormatDrive(Handle: HWND; Drive, ID, Options: Word): LongInt; stdcall; external 'shell32.dll' name 'SHFormatDrive'
procedure TForm1.button1Click(Sender: TObject);
var retCode: LongInt;
begin
retCode:= SHFormatDrive(Handle, 0, SHFMT_ID_DEFAULT, SHFMT_OPT_QUICKFORMAT);
if retCode < 0 then ShowMessage('Could not format drive');
end;
23. Fazendo uma janela filha de outra sem usar MDI (topo)
procedure TForm2.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params); { call the inherited first }
with Params do
begin
Style := Style or WS_CHILD; { add a style flag }
WndParent := Application.MainForm.Handle;
end;
end;
24. Abrindo e Fechando a bandeja do drive de CD-ROM (topo)
Para Abrir:
mciSendString('Set cdaudio door open wait', nil, 0, handle);
Para Fechar:
mciSendString('Set cdaudio door open wait', nil, 0, handle);
25. Obtendo a Data e a Hora de um Arquivo (topo)
function GetFileDate(Arquivo: String): String;
var FHandle: integer;
begin
FHandle := FileOpen(Arquivo, 0);
try
Result := DateTimeToStr(FileDateToDateTime(FileGetDate(FHandle)));
finally
FileClose(FHandle);
end;
end;
26. Testando a impressora se está OnLine (topo)
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;
27. Obtendo a letra do drive de CD-ROM (topo)
function FindFirstCDROMDrive: Char;
var
drivemap, mask: DWORD;
i: Integer;
root: String;
begin
Result := #0;
root := 'A:\';
drivemap := GetLogicalDrives;
mask := 1;
for i:= 1 To 32 Do
begin
if (mask and drivemap) <> 0 Then
if GetDriveType( PChar(root) ) = DRIVE_CDROM Then
begin
Result := root[1];
Break;
end;
mask := mask shl 1;
Inc( root[1] );
End;
End;
28. Obtendo o número serial do HD (topo)
function SerialNumber(FDrive:String) :String;
var
Serial:DWord;
DirLen,Flags: DWord;
DLabel : Array[0..11] of Char;
begin
Try
GetVolumeInformation(PChar(FDrive+':\'),dLabel,12,@Serial,DirLen,Flags,nil,0);
Result := IntToHex(Serial,8);
Except
Result :='';
end;
end;
29. Converte um número binário para inteiro (topo)
function BinToInt(Value: String): LongInt;
{Converte um numero binário em Inteiro}
var i,Size: Integer;
begin
Result := 0;
Size := Length(Value);
for i:=Size downto 0 do
if Copy(Value,i,1)='1' then
Result := Result+(1 shl i);
end;
30. Alterar atributos de um arquivo (topo)
var Attrib: integer;
begin
Attrib:=FileGetAttr('C:\ARQUIVO.XYZ');
if Attrib<>-1 then
begin
Attrib:=Attrib and not faReadOnly;
if FileSetAttr('C:\ARQUIVO.XYZ', Attrib)=0 then
Alteração Efetuada
else Windows code error;
end;
end;
31. Carregando um cursor animado (topo)
procedure TForm1.Button2Click(Sender: TObject);
const cnCursorID = 1;
begin
Screen.Cursors[cnCursorID]:=LoadCursorFromFile('drive:\caminho\arquivo.ani' );
Cursor := cnCursorID;
end;
32. Definindo o tamanho Mínimo e Máximo de um Formulário (topo)
procedure TForm1.WMGetMinMaxInfo(var MSG: TMessage);
begin
inherited;
with PMinMaxInfo(MSG.lparam)^ do
begin
ptMinTRackSize.X := 300;
ptMinTRackSize.Y := 150;
ptMaxTRackSize.X := 350;
ptMaxTRackSize.Y := 250;
end;
end;
