Comandos para os seus projectos

[Lukas Ssaraiva]

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;

[Douglas Soares]

Ae Amigo, Parabens pelo Tópico, se eu for unir esses codigos num programa, já da pra fazer um keylogger! ashaushuas :lol:

Abraços!