Principal
FreeDOS
Linux
C++
   |- Guias
   |- Dicas
Delphi
   |- Ferramentas
   |- Dicas
Programas
Downloads

Dicas Delphi:

  1. Abrir programa apenas uma vez, notifica-lo caso já esteja aberto
  2. Retornar a pasta de instalação do Windows e do System
  3. Ordenar uma StringGrid
  4. Mostrar/Alterar as resoluções de Video
  5. Elevar um Numero N a um exponte Y
  6. Enviando Arquivo/Pasta para a Lixeira
  7. Verificar/Mudar estado das teclas
  8. Chamar um programa, e esperar sua finalização
  9. Criar Atalhos
  10. Retornar endereço IP do computador
  11. Retornar o HOST do IP especificado


Abrir programa apenas uma vez, notifica-lo caso já esteja aberto

Na UNIT do Projeto coloque o seguinte:
Uses
   Windows, ...//O que já estiver

Const WM_PREVHINST = 45632; //Constante que será passada
Var HprevHist : HWND; //Handle de janela

begin
  Application.Initialize;
  HprevHist := FindWindow(Nil, PChar('Project 01')); //Coloque esta linha
  if HprevHist = 0 then Begin
     Application.Title := 'Project 01';
     Application.CreateForm(TForm1, Form1);
     Application.Run;
  End
  Else
     postmessage(HPrevHIst,WM_PREVHINST,0,1); //Notifica
end.
Na Unit do Form principal coloque o seguinte:

Const WM_PREVHINST = 45632;

procedure TForm1.AppMessage(var Msg: TMsg; var Handled: Boolean);
begin
  if Msg.message = WM_PREVHINST then
  begin
    ShowMessage('OK');
    Handled := True;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Application.OnMessage := AppMessage;
end;
-> Declare a Procedure "AppMessage" em "Type" do "Form"


Retornar a pasta de instalação do Windows e do System


function WindowsDir : string; //Pasta Windows
var
   WinDir : array [0..144] of char;
begin
   GetWindowsDirectory (WinDir, 144);
   Result := StrPas(WinDir);
end;
function SystemDir : string; //Pasta System
var
   SysDir : array [0..144] of char;
begin
   GetSystemDirectory (SysDir, 144);
   Result := StrPas(SysDir);
end;

Ordenar uma StringGrid


Function SortGrid(var GenStrGrid : TStringGrid; ThatCol : Integer): Boolean;
Const
 TheSeparator = '@'; // Define o Separador
Var
 CountItem, I, J, K, ThePosition : Integer;
 MyList : TStringList;
 MyString, TempString : String;
Begin
 CountItem := GenStrGrid.RowCount; // Retorna o número de linhas da Grade
 MyList := TStringList.Create; //Cria a lista
 MyList.Sorted := False;
 Try
  Begin
   For I := 1 to (CountItem - 1) do
      MyList.Add(GenStrGrid.Rows[I].Strings[ThatCol] + TheSeparator + GenStrGrid.Rows[I].Text);
   Mylist.Sort; //Ordena a lista
   For K := 1 to Mylist.Count do
   Begin
      MyString := MyList.Strings[(K - 1)]; //Pega a String da linha (K - 1)
      ThePosition := Pos(TheSeparator, MyString); //Localiza a posição do Separador na String
      TempString := '';
      {Elimina o texto da coluna na qual nós temos ordenados a StringGrid}
      TempString := Copy(MyString, (ThePosition + 1), Length(MyString));
      MyList.Strings[(K - 1)] := '';
      MyList.Strings[(K - 1)] := TempString;
   End;
   For J := 1 to (CountItem - 1) do
      GenStrGrid.Rows[J].Text := MyList.Strings[(J - 1)]; //Recarrega a StringGrid
  end;
 finally
  MyList.Free; //Descarrega a Lista
 end;
end;

Mostrar/Alterar as resoluções de Video


Mostrar a resolução atual

messagedlg('Sua resolução é ' + inttostr(screen.Width) + 'x'
            + inttostr(screen.height), mtConfirmation, [mbOk], 0);
Mostrar todas as resoluções suportadas pela Pl. de video

//Insira um ListBox para funcionar

var
   i: Integer;
   DevMode: TDevMode;
   Cores: string;
begin
i := 0;
while EnumDisplaySettings(nil,i,Devmode) do
begin
   if (1 shl Devmode.dmBitsperPel = 65536) then
      cores:= 'HighColor'
   else if(1 shl Devmode.dmBitsperPel = 1) then
      cores:= 'TrueColor'
   else
      cores:= inttostr(1 shl Devmode.dmBitsperPel) + ' Cores';
   ListBox1.Items.Add(Format('%dx%d %s',[Devmode.dmPelsWidth, Devmode.dmPelsHeight, cores]));
   Inc(i);
end;
end;
Alterar a resolução

//Utilize o ListBox do codigo acima

var
   DevMode : TDevMode;
begin
   EnumDisplaySettings(nil,Listbox1.ItemIndex,Devmode);
   ChangeDisplaySettings(DevMode,0);
end;

Elevar um Numero N a um exponte Y


//Funciona em qualquer linguagem de programação
var
   Resultado: variant;
begin
   Resultado:=exp(Y*ln(X));
End;
//Y-> Expoente
//X->Numero a ser elevado

Enviando Arquivo/Pasta para a Lixeira


//Coloque em Uses: -- ShellAPI --

Function Enviar_Lixeira(Caminho : string ): boolean;
//Apaga PASTAS ou ARQUIVOS
var
   fos: TSHFileOpStruct;
begin
Result := False;
FillChar( fos, SizeOf( fos ), 0 );
With fos do
begin
   wFunc := FO_DELETE;
   pFrom := PChar(Caminho);
   fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION or FOF_SILENT;
end;
Result := ( 0 = ShFileOperation( fos ) );
end;

Verificar/Mudar estado das teclas


Verificar STATUS

Function Verificar_Status(Tecla: integer): String;
begin
   if GetKeyState(Tecla)=1 then
      result := 'LIGADA'
   else
      result := 'DESLIGADA'
End;
Mudar STATUS

Function Alterar_Status(Tecla: Integer; Status: string): boolean;
{Tecla deve ser uma das constantes do sistema
Status deve ser: 'LIGAR', 'DESLIGAR', 'MUDAR'}
var
   kbArray: TKeyboardstate;
begin
GetKeyboardState(kbArray);
if status = 'LIGAR' then
   kbArray[Tecla] := 1;
if status = 'DESLIGAR' then
   kbArray[Tecla] := 0;
if status = 'MUDAR' then
begin
   If(kbArray[Tecla] = 1) then
       kbArray[Tecla] := 0
   else
       kbArray[Tecla] := 1;
end;
SetKeyboardState(kbArray);
result:= true;
end;
//Exemplo
//Para ligar a tecla CAPSLOCK use:
//Alterar_Status(VK_CAPITAL; 'LIGAR')

Chamar um programa, e esperar sua finalização


Function Executar(Arquivo : String; Estado : Integer) : Integer;
var
   Programa : array [0..512] of char;
   CurDir : array [0..255] of char;
   WorkDir : String;
   StartupInfo : TStartupInfo;
   ProcessInfo : TProcessInformation;
   Resultado: dword;
begin
   StrPCopy (Programa, Arquivo);
   GetDir (0, WorkDir);
   StrPCopy (CurDir, WorkDir);
   FillChar (StartupInfo, Sizeof (StartupInfo), #0);
   StartupInfo.cb := sizeof (StartupInfo);
   StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
   StartupInfo.wShowWindow := Estado;
if not CreateProcess (nil, Programa, nil, nil, false, CREATE_NEW_CONSOLE or
NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo) then
   Result := -1
else
begin
   WaitForSingleObject (ProcessInfo.hProcess, Infinite);
   GetExitCodeProcess (ProcessInfo.hProcess, Resultado);
end;
result:= Resultado;
end;

//Estado é o tipo de janela que aparecerá, que pode ser:

//SW_SHOWNORMAL - Janela em modo normal
//SW_MAXIMIZE   - Janela maximizada
//SW_MINIMIZE   - Janela minimizada
//SW_HIDE       - Janela Escondida

Criar Atalhos



//Coloque em USES:
//ShlObj, ActiveX, ComObj, Registry;

//Depois, vá à seção type de sua unit e crie o seguinte tipo:
TShortcutPlace = (stDesktop, stStartMenu);

//Por último, coloque a seguinte função:

Function Criar_Atalho(FileName, Parameters, InitialDir, ShortcutName,
ShortcutFolder : String; Place : TShortcutPlace): Boolean;
var
   MyObject : IUnknown;
   MySLink : IShellLink;
   MyPFile : IPersistFile;
   Directory : String;
   WFileName : WideString;
   MyReg : TRegIniFile;
begin
   result:= false;
   MyObject := CreateComObject(CLSID_ShellLink);
   MySLink := MyObject as IShellLink;
   MyPFile := MyObject as IPersistFile;
   with MySLink do
   begin
      SetArguments(PCHAR(Parameters));
      SetPath(PChar(FileName));
      SetWorkingDirectory(PChar(InitialDir));
   end;
   MyReg := TRegIniFile.Create ('Software/MicroSoft/Windows/CurrentVersion/Explorer');
   if Place = stDesktop then
      Directory := MyReg.ReadString ('Shell Folders','Desktop','');
   if Place = stStartMenu then
   begin
      Directory := MyReg.ReadString('Shell Folders','Start Menu','') + '/' + ShortcutFolder;
      CreateDir(Directory);
   end;
   WFileName := Directory + '/' + ShortcutName + '.lnk';
   MyPFile.Save (PWChar (WFileName), False);
   MyReg.Free;
   result:= true;
end;

//Exemplo: Criar_Atalho('C:/windows/notepad.exe', '', '', 'Bloco de Notas',
//              'Programas/Bloco de Notas', stStartMenu)

Retornar endereço IP do computador


//Declare a Winsock na clausula uses da unit

Function GetLocalIP: string;
type
   TaPInAddr = array [0..10] of PInAddr;
   PaPInAddr = ^TaPInAddr;
var
   phe : PHostEnt;
   pptr : PaPInAddr;
   Buffer : array [0..63] of char;
   I : Integer;
   GInitData : TWSADATA;
begin
WSAStartup($101, GInitData);
   Result := '';
   GetHostName(Buffer, SizeOf(Buffer));
   phe :=GetHostByName(buffer);
   if phe = nil then
   begin
      Exit;
   end;
   pptr := PaPInAddr(Phe^.h_addr_list);
   I := 0;
   while pptr^[I] <> nil do
   begin
      result:=StrPas(inet_ntoa(pptr^[I]^));
      Inc(I);
   end;
WSACleanup;
end;

Retornar o HOST do IP especificado


Function GetHostName(strIPAddress : String) : String;
// Requer a Winsock declarada na clausula uses da unit
Var
   strHost : String;
   pszIPAddress : PChar;
   pReturnedHostEnt: PHostEnt;
   InternetAddr : u_long;
   GInitData : TWSADATA;
Begin
   strHost := '';
   If WSAStartup($101, GInitData) = 0 then
   Begin
      pszIPAddress := StrAlloc( Length( strIPAddress ) + 1 );
      StrPCopy( pszIPAddress, strIPAddress );
      InternetAddr := Inet_Addr(pszIPAddress);
      StrDispose( pszIPAddress );
      pReturnedHostEnt := GetHostByAddr( PChar(@InternetAddr),4, PF_INET );
      try
         strHost := pReturnedHostEnt^.h_name;
         WSACleanup;
         Result := strHost
      except
         Result := 'Host inválido ou não encontrado';
      end;
   end;
end;


Ultima atualização em 23/02/2003.
Criado por Max Velasques em 30/01/2002.

1