Dicas de Delphi - Arquivos, Diretórios e Discos

Obter a letra do drive onde está o Windows

Inclua na seção uses: Windows 
Problema:

Como saber em qual unidade de disco (drive) o Windows está
instalado?

Solução:

Esta função retorna a letra do drive onde está instalado o
Windows:

function GetWindowsDrive: Char;
var
  S: string;
begin
  SetLength(S, MAX_PATH);
  if GetWindowsDirectory(PChar(S), MAX_PATH) > 0 then
    Result := string(S)[1]
  else
    Result := #0;
end;

{ Exemplo de uso: }

procedure TForm1.Button1Click(Sender: TObject);
begin
  Caption := GetWindowsDrive;
end;

Autor: Daniel P. Guimarães
Home-page: www.tecnobyte.com.br

Início

Obter tamanho de um arquivo

Inclua na seção uses: SysUtils 
{ A função abaixo retorna o tamanho do arquivo, ou -1
  se o arquivo não for encontrado }

function tbFileSize(const FileName: string): integer;
var
  SR: TSearchRec;
  I: integer;
begin
  I := FindFirst(FileName, faArchive, SR);
  try
    if I = 0 then
      Result := SR.Size
    else
      Result := -1;
  finally
    FindClose(SR);
  end;
end;

Autor: Daniel P. Guimarães
Home-page: www.tecnobyte.com.br

Início

Criar sub-diretório no diretório do EXE

Inclua na seção uses: FileCtrl, SysUtils 
Problema:

Gostaria de criar um sub-diretório dentro do diretório 
onde se encontra o EXE de minha aplicação. Como fazer?

Solução: 

Primeiramente vamos conhecer algumas funções do Delphi
que precisaremos usá-las:

ParamStr(Indice) - Retorna valores passados 
na linha de comando quando executamos o programa. Se o valor 
de Indice for 0 (zero) será retornado o caminho+nome do EXE. 

ExtractFilePath(NomeArq) - Retorna o caminho (path) do 
nome de arquivo informado. 
  Exemplo: 
    S := 'C:\NomeDir\Programa.exe';
    ExtractFilePath(S); { retorna: 'C:\NomeDir\' }

DirectoryExists(CaminhoDir) - Retorna true se o diretório 
informado existe. False em caso contrário.

CreateDir(CaminhoDir) - Tenta criar o diretório informado.
Se conseguir, retorna true. Caso contrário retorna false.

Agora que sabemos como trabalham estas funções, vamos
escrever uma função que precisamos para criar um 
sub-diretório conforme proposto.

function CriaSubDir(const NomeSubDir: string): boolean;
var
  Caminho: string;
begin
  Caminho := ExtractFilePath(ParamStr(0)) + NomeSubDir;
  if DirectoryExists(Caminho) then
    Result := true
  else
    Result := CreateDir(Caminho);
end;

Exemplo de uso:

- Chame a função no evento OnCreate do form:

procedure TForm1.FormCreate(Sender: TObject);
begin
  if not CriaSubDir('MeuSubDir') then
    ShowMessage('Não foi possível criar o sub-diretório MeuSubDir.');
end;

Autor: Daniel P. Guimarães
Home-page: www.tecnobyte.com.br

Início

Definir data/hora de um arquivo

Inclua na seção uses: SysUtils 
{ Esta função altera a data e hora de um arquivo. Se obter
  sucesso retorna true, caso contrário retorna false. }

function DefineDataHoraArq(NomeArq: string; DataHora: TDateTime): boolean;
var
  F: integer;
begin
  Result := false;
  F := FileOpen(NomeArq, fmOpenWrite or fmShareDenyNone);
  try
    if F > 0 then
      Result := FileSetDate(F, DateTimeToFileDate(DataHora)) = 0;
  finally
    FileClose(F);
  end;
end;

{ Exemplo de uso 1: Usa a data atual do sistema (Now) }

if DefineDataHoraArq('c:\teste\logo.bmp', Now) then
  ShowMessage('Data/Hora do arquivo definida com sucesso.')
else
  ShowMessage('Não foi possível definir data/hora do arquivo.');

{ Exemplo de uso 2: Usa uma data fixa }
var
  DataHora: TDateTime;
begin
  { Define a data para 5-Fev-1999 e a hora para 10:30 }
  DataHora := EncodeDate(1999, 2, 5) + EncodeTime(10, 30, 0, 0);

  if DefineDataHoraArq('c:\teste\logo.bmp', DataHora) then
    ShowMessage('Data/Hora do arquivo definida com sucesso.')
  else
    ShowMessage('Não foi possível definir data/hora do arquivo.');
end;

Autor: Daniel P. Guimarães
Home-page: www.tecnobyte.com.br

Início

Executar um programa e aguardar sua finalização antes de continuar

Inclua na seção uses: Windows 
{ Esta função faz isto. }

function ExecAndWait(const FileName, Params: string;
  const WindowState: Word): boolean;
var
  SUInfo: TStartupInfo;
  ProcInfo: TProcessInformation;
  CmdLine: string;
begin
  { Coloca o nome do arquivo entre aspas. Isto é necessário devido
    aos espaços contidos em nomes longos }
  CmdLine := '"' + Filename + '"' + Params;
  FillChar(SUInfo, SizeOf(SUInfo), #0);
  with SUInfo do  begin
    cb := SizeOf(SUInfo);
    dwFlags := STARTF_USESHOWWINDOW;
    wShowWindow := WindowState;
  end;
  Result := CreateProcess(nil, PChar(CmdLine), nil, nil, false,
    CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, nil,
    PChar(ExtractFilePath(Filename)), SUInfo, ProcInfo);

  { Aguarda até ser finalizado }
  if Result then begin
    WaitForSingleObject(ProcInfo.hProcess, INFINITE);
    { Libera os Handles }
    CloseHandle(ProcInfo.hProcess);
    CloseHandle(ProcInfo.hThread);
  end;
end;

- Exemplo de uso:

ExecAndWait('c:\windows\notepad.exe', '', SW_SHOW);

Observações

Não se esqueça de informar o caminho (path) do arquivo completo. Esta função foi desenvolvida para Delphi 32 bits (2, 3, 4,...).

Autor: Daniel P. Guimarães
Home-page: www.tecnobyte.com.br

Início

Obter os atributos de um arquivo/diretório

Inclua na seção uses: Windows 
{ No form:
  - Coloque um memo;
  - Coloque um edit;
  - Coloque um botão e escreva seu OnClick como abaixo: }

procedure TForm1.Button1Click(Sender: TObject);
var
  Attr: DWord;
begin
  Memo1.Clear;
  Attr := GetFileAttributes(PChar(Edit1.Text));
  if Attr > 0 then
    with Memo1.Lines do begin
      if (Attr and FILE_ATTRIBUTE_ARCHIVE) > 0 then
        Add('Archive');
      if (Attr and FILE_ATTRIBUTE_COMPRESSED) > 0 then
        Add('Compressed');
      if (Attr and FILE_ATTRIBUTE_DIRECTORY) > 0 then
        Add('Directory');
      if (Attr and FILE_ATTRIBUTE_HIDDEN) > 0 then
        Add('Hidden');
      if (Attr and FILE_ATTRIBUTE_NORMAL) > 0 then
        Add('Normal');
      if (Attr and FILE_ATTRIBUTE_OFFLINE) > 0 then
        Add('OffLine');
      if (Attr and FILE_ATTRIBUTE_READONLY) > 0 then
        Add('ReadOnly');
      if (Attr and FILE_ATTRIBUTE_SYSTEM) > 0 then
        Add('System');
      if (Attr and FILE_ATTRIBUTE_TEMPORARY) > 0 then
        Add('Temporary');
  end;
end;

Autor: Daniel P. Guimarães
Home-page: www.tecnobyte.com.br

Início

Obter o espaço total e livre de um disco

Inclua na seção uses: Windows 
{ - Coloque um memo (TMemo) no form;
  - Coloque um botão e altere seu OnClick como abaixo: }

procedure TForm1.Button1Click(Sender: TObject);
var
  SetoresPorAgrup, BytesPorSetor, AgrupLivres,
  TotalAgrup: DWord;
begin
  Memo1.Clear;
  if GetDiskFreeSpace('C:\', SetoresPorAgrup,
      BytesPorSetor, AgrupLivres, TotalAgrup) then
  with Memo1.Lines do begin
    Add('Setores por agrupamento: ' + IntToStr(SetoresPorAgrup));
    Add('Bytes por setor: ' + IntToStr(BytesPorSetor));
    Add('Agrupamentos livres: ' + IntToStr(AgrupLivres));
    Add('Total de agrupamentos: ' + IntToStr(TotalAgrup));
    Add('----- Resumo -----');
    Add('Total de bytes: ' +
      IntToStr(TotalAgrup * SetoresPorAgrup * BytesPorSetor));
    Add('Bytes livres: ' +
      IntToStr(AgrupLivres * SetoresPorAgrup * BytesPorSetor));
  end;
end;

{ O exemplo acima retorna as medidas em Bytes, Setores e
  Agrupamentos. Se preferir algo mais simples,
  use funções do Delphi. Veja: }

Memo1.Lines.Add('Total de bytes: ' + IntToStr(DiskSize(3)));
Memo1.Lines.Add('Bytes livres: ' + IntToStr(DiskFree(3)));

{ Onde o parâmetro (3) é o número da unidade, sendo
  1=A, 2=B, 3=C, ... }

Observações

Para usar as funções DiskSize e DiskFree coloque SysUtils em uses.

Autor: Daniel P. Guimarães
Home-page: www.tecnobyte.com.br

Início

Obter o tipo de um drive (removível, fixo, CD-ROM, unidade de rede, etc)

Inclua na seção uses: Windows, Dialogs 
{ - Coloque um edit (Edit1) e um botão no form;
  - Altere o OnClick do botão conforme abaixo: }

procedure TForm1.Button1Click(Sender: TObject);
var
  S: string;
  Tipo: byte;
begin
  Tipo := GetDriveType(PChar(Edit1.Text[1] + ':\'));
  case Tipo of
    0: S := 'Tipo indeterminado';
    1: S := 'Drive não existe';
    DRIVE_REMOVABLE: S := 'Disco removível';
    DRIVE_FIXED: S := 'Disco Fixo';
    DRIVE_REMOTE: S := 'Unidade de rede';
    DRIVE_CDROM: S := 'CD-ROM';
    DRIVE_RAMDISK: S := 'RAM Disk';
  else
    S := 'Erro';
  end;
  ShowMessage(S);
end;

{ Para pegar o tipo da unidade atual troque...}
  Tipo := GetDriveType(PChar(Edit1.Text[1] + ':\'));
{ por }
  Tipo := GetDriveType(nil);

Observações

Para testar digite a letra do drive no Edit1 e clique no botão. A unit Dialogs foi colocada no uses apenas por causa da procedure ShowMessage. Para exibir todas as unidades existentes e seus respectivos tipos, use a função tbGetDrives (da pergunta 64) em conjunto com este exemplo.

Autor: Daniel P. Guimarães
Home-page: www.tecnobyte.com.br

Início

Obter informações de um volume/disco (label, serial, sistema de arquivos, etc)

Inclua na seção uses: Windows, System 
{ - Coloque um memo (TMemo) no form;
  - Coloque um botão e escreve seu evento
    OnClick como abaixo: }

procedure TForm1.Button1Click(Sender: TObject);
var
  SLabel, SSysName: PChar;
  Serial, FileNameLen, X: DWord;
begin
  Memo1.Clear;
  GetMem(SLabel, 255);
  GetMem(SSysName, 255);
  try
    GetVolumeInformation('C:\', SLabel, 255,
      @Serial, FileNameLen, X, SSysName, 255);
    with Memo1.Lines do begin
      Add('Nome do volume (Label): ' + string(SLabel));
      Add('Número Serial: ' + IntToHex(Serial, 8));
      Add('Tamanho máximo p/ nome arquivo: ' +
        IntToStr(FileNameLen));
      Add('Sistema de Arquivos: ' + string(SSysName));
    end;
  finally
    FreeMem(SLAbel, 255);
    FreeMem(SSysName, 255);
  end;
end;

Autor: Daniel P. Guimarães
Home-page: www.tecnobyte.com.br

Início

Alterar o nome de volume (Label) de um disco

Inclua na seção uses: Windows 
{ Da unidade C: }
SetVolumeLabel('c:\', 'NovoLabel');

{ Da unidade atual: }
SetVolumeLabel(nil, 'NovoLabel');

Autor: Daniel P. Guimarães
Home-page: www.tecnobyte.com.br

Início

Saber quais as unidades de disco (drives) estão presentes

Inclua na seção uses: Windows 
{ A função abaixo retorna uma string contendo
  as letras de unidades de discos presentes. }

function tbGetDrives: string;
var
  Drives: DWord;
  I: byte;
begin
  Result := '';
  Drives := GetLogicalDrives;
  if Drives <> 0 then
    for I := 65 to 90 do
      if ((Drives shl (31 - (I - 65))) shr 31) = 1 then
        Result := Result + Char(I);
end;

{ Para saber se uma determinada unidade está presente,
  basta fazer algo como: }
if Pos('A', tbGetDrives) > 0 then
  ShowMessage('Unidade A: presente.')
else
  ShowMessage('Unidade A: ausente.');

Observações

A string retornada pela função tbGetDrives está sempre em letras maiúsculas.

Autor: Daniel P. Guimarães
Home-page: www.tecnobyte.com.br

Início

Formatar um disquete através de um programa Delphi

{ Coloque o código abaixo imediatamente abaixo da palavra
  implementation: }

const
  SHFMT_ID_DEFAULT = $FFFF;

  { Opções de formatação }
  SHFMT_OPT_QUICKFORMAT = $0000; { Formatação rápida }
  SHFMT_OPT_FULL = $0001;        { Formatação completa }
  SHFMT_OPT_SYSONLY = $0002;     { Copia sistema }

  { Códigos de errros }
  SHFMT_ERROR = $FFFFFFFF; { Ocorreu erro }
  SHFMT_CANCEL = $FFFFFFFE; { Foi cancelado }
  SHFMT_NOFORMAT = $FFFFFFFD; { Não formatou }

function SHFormatDrive(Handle: HWND; Drive, ID, Options: Word):
  LongInt; stdcall; external 'shell32.dll' name 'SHFormatDrive'

{ Coloque um botão no form e altere o evento OnClick dele
  conforme abaixo: }

procedure TForm1.Button3Click(Sender: TObject);
var
  Erro: DWord;
  Msg: string;
begin
  Erro := SHFormatDrive(Handle, 0, SHFMT_ID_DEFAULT, SHFMT_OPT_QUICKFORMAT);
  case Erro of
    SHFMT_ERROR:    Msg := 'Ocorreu um erro.';
    SHFMT_CANCEL:   Msg := 'A formatação foi cancelada.';
    SHFMT_NOFORMAT: Msg := 'Não foi possível formatar.';
  else
    Msg := 'Disco formatado com sucesso.';
  end;
  ShowMessage(Msg);
end;

Observações

Para formatação completa troque SHFMT_OPT_QUICKFORMAT por SHFMT_OPT_FULL. O segundo parâmetro (zero no exemplo) indica a unidade, sendo que A é 0 (zero), B é 1, etc.

Autor: Daniel P. Guimarães
Home-page: www.tecnobyte.com.br

Início

Copiar arquivos usando o Shell do Windows

Inclua na seção uses: ShellApi 
{ - Coloque um botão no form e altere o evento OnClick
    deste botão conforme abaixo: }
   
procedure TForm1.Button1Click(Sender: TObject);
var
  Dados: TSHFileOpStruct;
begin
  FillChar(Dados,SizeOf(Dados), 0);
  with Dados do
  begin
    wFunc := FO_COPY;
    pFrom := PChar('c:\teste\*.txt');
    pTo   := PChar('a:\');
    fFlags:= FOF_ALLOWUNDO;
  end;
  SHFileOperation(Dados);
end;

Observações

Esta forma de copiar arquivos oferecem várias vantagens. O Shell avisa para pôr um próximo disco quando o atual estiver cheio. Mostra a barra de progresso. Pode copiar arquivos usando máscara de uma forma extremamente simples.

Autor: Daniel P. Guimarães
Home-page: www.tecnobyte.com.br

Início

Enviar um arquivo para a lixeira

Inclua na seção uses: ShellApi 
{ Coloque a procedure abaixo na seção implementation }

procedure ArqParaLixeira(const NomeArq: string; var MsgErro: string);
var
  Op: TSHFileOpStruct;
begin
  MsgErro := '';
  if not FileExists(NomeArq) then begin
    MsgErro := 'Arquivo não encontrado.';
    Exit;
  end;
  FillChar(Op, SizeOf(Op), 0);
  with Op do begin
    wFunc := FO_DELETE;
    pFrom := PChar(NomeArq);
    fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION or FOF_SILENT;
  end;
  if ShFileOperation(Op) <> 0 then
    MsgErro := 'Não foi possível enviar o arquivo para a lixeira.';
end;

{ - Coloque um botão no Form;
  - Altere o evento OnClick do botão conforme abaixo: }

procedure TForm1.Button1Click(Sender: TObject);
var
  S: string;
begin
  ArqParaLixeira('c:\Diretorio\Teste.doc', S);
  if S = '' then
    ShowMessage('O arquivo foi enviado para a lixeira.')
  else
    ShowMessage(S);
end;

Autor: Daniel P. Guimarães
Home-page: www.tecnobyte.com.br

Início

Copiar arquivos usando curingas (*.*)

{ - Coloque um Button no Form;
  - Altere o evento OnClick deste Button conforme abaixo: }

procedure TForm1.Button2Click(Sender: TObject);
var
  SR: TSearchRec;
  I: integer;
  Origem, Destino: string;
begin
  I := FindFirst('c:\Origem\*.*', faAnyFile, SR);
  while I = 0 do begin
    if (SR.Attr and faDirectory) <> faDirectory then begin
      Origem := 'c:\Origem\' + SR.Name;
      Destino := 'c:\Destino\' + SR.Name;
      if not CopyFile(PChar(Origem), PChar(Destino), true) then
        ShowMessage('Erro ao copiar ' + Origem + ' para ' + Destino);
    end;
    I := FindNext(SR);
  end;
end;

Observações

No exemplo acima, se o arquivo já existir no destino, a função falha (não copia). Para que a função possa sobreescrever o arquivo destino (caso exista), altere o último parâmetro de CopyFile para false. CUIDADO! Se um arquivo for sobreescrito, estará perdido para sempre!

Autor: Daniel P. Guimarães
Home-page: www.tecnobyte.com.br

Início

Copiar arquivos

{ - Coloque um Button no Form;
  - Altere o evento OnClick deste Button conforme abaixo: }

procedure TForm1.Button2Click(Sender: TObject);
var
  Origem, Destino: string;
begin
  Origem := 'c:\Origem\NomeArq.txt';
  Destino := 'c:\Destino\NomeArq.txt';
  if not CopyFile(PChar(Origem), PChar(Destino), true) then
    ShowMessage('Erro ao copiar ' + Origem + ' para ' + Destino);
end;

Observações

No exemplo acima, se o arquivo já existir no destino, a função falha (não copia). Para que a função possa sobreescrever o arquivo destino (caso exista), altere o último parâmetro de CopyFile para false. CUIDADO! Se um arquivo for sobreescrito, estará perdido para sempre!

Autor: Daniel P. Guimarães
Home-page: www.tecnobyte.com.br

Início

Excluir arquivos usando curingas (*.*)

{ - Coloque um Button no Form;
  - Altere o evento OnClick do Button conforme abaixo: }

procedure TForm1.Button2Click(Sender: TObject);
var
  SR: TSearchRec;
  I: integer;
begin
  I := FindFirst('c:\Teste\*.*', faAnyFile, SR);
  while I = 0 do begin
    if (SR.Attr and faDirectory) <> faDirectory then
      if not DeleteFile('c:\Teste\' + SR.Name) then
        ShowMessage('Não consegui excluir c:\Teste\' + SR.Name);
    I := FindNext(SR);
  end;
end;

Observações

No exemplo acima todos os arquivos do diretório c:\Teste serão excluídos. CUIDADO! Arquivos excluídos desta forma não vão para a lixeira.

Autor: Daniel P. Guimarães
Home-page: www.tecnobyte.com.br

Início

Verificar se uma unidade de disco (disk-drive) está preparada

Inclua na seção uses: System, SysUtils 
{ - Crie um novo projeto;
  - Na seção implementation da Unit1 digite a função abaixo: }

function DriveOk(Drive: Char): boolean;
var
  I: byte;
begin
  Drive := UpCase(Drive);
  if not (Drive in ['A'..'Z']) then
    raise Exception.Create('Unidade incorreta');
  I := Ord(Drive) - 64;
  Result := DiskSize(I) >= 0;
end;

{ - Coloque no Form1 um TEdit (Edit1)
  - Coloque no Form1 um TButton
  - Altere o evento OnClick do Button1 conforme abaixo: }

procedure TForm1.Button1Click(Sender: TObject);
begin
  if DriveOk(Edit1.Text[1]) then
    ShowMessage('Drive OK')
  else
    ShowMessage('Drive não preparado');
end;

Observações

Para testar você deverá executar o exemplo e digitar no Edit a letra do drive a ser testado (não precisa os dois-pontos). Após digitar, clique no Button1.

Autor: Daniel P. Guimarães
Home-page: www.tecnobyte.com.br

Início

Verificar se um diretório existe

Inclua na seção uses: FileCtrl, Dialogs 
if DirectoryExists('C:\MEUSDOCS') then
  ShowMessage('O diretório existe')
else
  ShowMessage('O diretório não existe');

Autor: Daniel P. Guimarães
Home-page: www.tecnobyte.com.br

Início

Verificar se um arquivo existe

Inclua na seção uses: SysUtils, Dialogs 
if FileExists('c:\carta.doc') then
  ShowMessage('O arquivo existe')
else
  ShowMessage('O arquivo não existe');

Autor: Daniel P. Guimarães
Home-page: www.tecnobyte.com.br

Início

Página atualizada em 23 de janeiro de 2012
Todos os direitos reservados
www.tecnobyte.com.br