segunda-feira, 4 de fevereiro de 2019

Uso da cláusula HAVING

Quando usamos a clausula GROUP BY temos por vezes a tendencia em usar o HAVING para especificar uma condicao simples como especificado abaixo: 

SELECT 

  META_GB.COD_PROJINT, 

  META_GB.COD_METPADRAO, 

  METAPADRAO.DES_METPADRAO, 

  METAPADRAO.COD_UNIDMED, 

  UNIDMED.SIG_UNIDMED 

FROM 

  META_GB, 

  METAPADRAO, 

  UNIDMED 

WHERE 

  ( META_GB.COD_METPADRAO = METAPADRAO.COD_METPADRAO ) and 

  (METAPADRAO.COD_UNIDMED = UNIDMED.COD_UNIDMED) 

GROUP BY 

  META_GB.COD_PROJINT, 

  META_GB.COD_METPADRAO, 

  METAPADRAO.DES_METPADRAO, 

  METAPADRAO.COD_UNIDMED, 

  UNIDMED.SIG_UNIDMED 

HAVING ( META_GB.COD_PROJINT = :Param1 ) 



ao inves de usar a clausula having para condicionar coloque esta condicao na clausula WHERE como especificado abaixo 



SELECT 

  META_GB.COD_PROJINT, 

  META_GB.COD_METPADRAO, 

  METAPADRAO.DES_METPADRAO, 

  METAPADRAO.COD_UNIDMED, 

  UNIDMED.SIG_UNIDMED 

FROM 

  META_GB, 

  METAPADRAO, 

  UNIDMED 

WHERE 

  ( META_GB.COD_METPADRAO = METAPADRAO.COD_METPADRAO ) and 

  (METAPADRAO.COD_UNIDMED = UNIDMED.COD_UNIDMED) and 

  ( META_GB.COD_PROJINT = :Param1 ) 

GROUP BY 

  META_GB.COD_PROJINT, 

  META_GB.COD_METPADRAO, 

  METAPADRAO.DES_METPADRAO, 

  METAPADRAO.COD_UNIDMED, 

  UNIDMED.SIG_UNIDMED 



obs: caso a condicionante seja de grupo esta tem que ficar obrigatoriamente na clausula HAVING 

Sql relacionada com a primeira letra

query1.active := false;
query1.sql.clear;
query1.sql.add('select * from estrucpr where upper(portugues)like "LETRA%" ');
query1.active:= true;
PRIMEIRA LETRA "LETRA%"

ULTIMA LETRA "%LETRA"

QUE CONTENHA A LETRA "%LETRA%" 

Sql pesquisando utilizando um edit

query1.active := false;
query1.sql.clear;
query1.sql.add('select * from teste where nome = "' + edit1.Text + '"');
query1.active:= true;

Selecionando registros de uma tabela que não existam em outra tabela

(SELECT * FROM ,  

  WHERE . = . 

  AND . = 'AP' 

  MINUS 

(SELECT * FROM @remoto1, @remoto1 

  WHERE @remoto1. = @remoto1. 

  AND @remoto1. = 'AP' 



obs: todos os campos retornados no SELECT secundário deverá conter os mesmos campos do SELECT primário

Procura com mais de um Banco de Dados

edit1.text:= dbcombobox1.Text;
QueryPrinc.active := false;
QueryPrinc.sql.clear;
QueryPrinc.sql.add('select * from estrucpr where portugues = "' + edit1.Text + '"');
QueryPrinc.active:= true;

if DBcodEl.text=DBcodEl.text then
edit2.Text:= DBcodEl.Text;

QuerySin.active := false;
QuerySin.sql.clear;
QuerySin.sql.add(' select * from sinonimo where sin_est_id = "' + edit2.text + ' "');
QuerySin.active:= true;

 if DBcodEl.text=DBcodEl.text then
edit3.Text:= DBcodEl.Text;

QueryPropFis.active := false;
QueryPropFis.sql.clear;
QueryPropFis.sql.add('select * from FIQU_PRO where fiqu_id = "' + edit3.Text + '"');
QueryPropFis.active:= true;

Otimizações no SQL

As dicas abaixo foram testadas essencialmente com Oracle

1) Todas as vezes que for utilizar um SQL que possua condições de OR, é mais aconselhável e mais rápido utilizar IN, como no exemplo: 

AO INVÉS DE 

  Select * from projint where sit_projint = ‘AI’ or sit_projint = ‘EL’ 

COLOQUE 

  Select * from projint where sit_projint IN (‘AI’,‘EL’); 

2) Quando existem duas ou mais condições AND juntas, especifique primeiro sempre a que possui o maior limite de ocorrências 

AO INVÉS DE 

  select count(*) from pessoa where sit_pessoa = 11 AND cod_munic > 1100155 

COLOQUE 

  select count(*) from pessoa where cod_munic > 1100155 AND sit_pessoa = 11 

3) Quando existem duas ou mais condições OR juntas, especifique primeiro sempre a que possui o maior limite de ocorrências 

AO INVÉS DE 

  select count(*) from pessoa where cod_munic > 1100155 OR sit_pessoa = 11 

COLOQUE 

  select count(*) from pessoa where sit_pessoa = 11 OR cod_munic > 1100155 

4) Tenha cuidado com o sinal de <> 

AO INVÉS DE 

  select count(*) from pessoawhere cod_munic < > 1100155 

COLOQUE 

  select count(*) from pessoawhere cod_munic < 1100155 OR cod_munic > 1100155 

Extraindo o ano, mês ou dia de uma data via SQL

Select * from nome_tabela where extract(year from campo_data) = 2019

Você pode extrair o mês (MONTH) ou o dia (DAY). 

Excluindo registros de uma tabela

Desejo excluir registro de uma tabela que dependem da existência de outros de outra(s) tabela(s), como fazer? 

DELETE FROM  
 WHERE (, ,
  IN 
(SELECT , , 
 FROM a,
  WHERE a. = b. 
  AND b. = 'AP' ) 

Criando tabelas via SQL

Inclua na seção uses: dbTables

- Coloque um TButton no form;

- Escreve no OnClick do Button como abaixo:

procedure TForm1.Button1Click(Sender: TObject);
var
  Q: TQuery;
begin
  Q := TQuery.Create(Application);
  try
     Q.DatabaseName := 'SF';
     with Q.SQL do begin
        Add('Create Table Funcionarios');
        Add('( Codigo AutoInc,');
        Add(' Nome Char(30),');
        Add(' Salario Money,');
        Add(' Depto SmallInt,');
        Add(' Primary Key (Codigo) )');
     end;
     Q.ExecSQL;
  finally
     Q.Free;
  end;
end;

Consultar por mês de um campo data

Problema:

Tenho um cadastro de clientes com Codigo, Nome, DataNasc, etc.

Preciso fazer uma consulta onde apareceão apenas os clientes que fazem aniversário em determinado mês. Como fazer?

Solução:

Use uma Query como abaixo:

- Coloque no form os seguintes componentes:

  * TQuery

  * TDataSource

  * TDBGrid

  * TEdit

  * TButton

- Altere as propriedades dos componentes como abaixo:

  * Query1.DatabaseName = (alias)

  * DataSource1.DataSet = Query1

  * DBGrid1.DataSource = DataSource1

 - Coloque o código abaixo no evento OnClick de Button1:

  Query1.Close;
  Query1.SQL.Clear;
  Query1.SQL.Add('select * from dCli');
  Query1.SQL.Add('where extract(month from DataNasc) = :Mes');
  Query1.ParamByName('Mes').AsInteger := StrToInt(Edit1.Text);
  Query1.Open;
- Execute. Digite um número de 1 a 12 no Edit e clique no botão.

Consultando entre datas utilizando SQL

If DateTimePicker2.Date < DateTimePicker1.Date Then 
begin 
   ShowMessage('Intervalo de datas inválido, a data inicial é maior que a data final!'); 
   DateTimePicker2.Date := DateTimePicker1.Date; 
end 
Else 
begin 
   Inicio := DateToStr(DateTimePicker1.Date); 
   Final := DateToStr(DateTimePicker2.Date); 
   Query1.Close; 
   Query1.SQL.Clear; 
   Query1.SQL.Text := 'SELECT Nome,Empresa,FoneRes,FoneCom,Mala FROM Contatos WHERE     Data >=:pInicial and Data<=:pFinal ORDER BY Nome'; 
   Query1.ParamByName('pInicial').AsDateTime := StrToDate(Inicio); 
   Query1.ParamByName('pFinal').AsDateTime := StrToDate(Final); 
   Query1.Prepare; 
   Query1.Open; 
   DBGrid3D1.SetFocus 
end;

Label3.Caption := 'Total de contatos: ' + IntToStr(Query1.RecordCount) 

Consulta SQL que usa a data do sistema

Problema:

Preciso fazer uma consulta com SQL que me retorne todos os registros em que o valor de um campo do tipo data seja igual ou anterior à dada do sistema. Como fazer?

Solução:

Query.Close;
Query.SQL.Text := 'select * from Tabela where CampoData <= :Hoje';
Query.ParamByName('Hoje').AsDate := Date;
Query.Open;
Observações

Este exemplo foi testado com tabelas Paradox, mas deve funcionar na maioria dos bancos de dados com pouca ou nenhuma alteração

Como usar a cláusula UNION em um Query

O uso do componente TQuery gera muitas vantagens e economiza muitas linhas de programação. Mas muitas vezes nos deparamos com situações que parecem não ser resolvidas com sentenças SQL. Vejamos um exemplo:

Você possui 2 tabelas (VendasExternas e VendasInternas) e deseja fazer um resumo de todas as vendas de um vendedor chamado Marcos. Se você usar a sentença

SELECT Nome, Valor FROM VendasExternas, VendasInternas
WHERE Nome = 'Marcos'
você vai obter como resultado uma query com 4 campos (Nome, Valor, Nome_1 e Valor_1) e um resultado bem confuso para ser manipulado.

Para resolver o problema, você poderá usar a sentença

SELECT Nome, Valor FROM VendasExternas
WHERE Nome = 'Marcos'
UNION ALL
SELECT Nome, Valor FROM VendasInternas
WHERE Nome = 'Marcos'
A sentença acima pede para que sejam identificados as vendas de Marcos na tabela VendasExternas, as vendas de Marcos na tabela VendasInternas e que o resultado da primeira seja unido com o resultado da segunda produzindo uma query com apenas 2 colunas. 

Bloco PL/SQL para inserção de dados

Pergunta 
Criar um bloco pl/sql que insira um novo dep na tabela s_dept 

- use a sequencia s_dept_id para o campo id da tabela 

- solicite ao usuario o nome do dep 

- insira valores nulos p/ o campo region_id 

Resposta 
-> no banco de dados... 
create or replace 
procedure insere_departamento (v_nome char) is 
v_id number; 
begin 
  SELECT sequenciaID.NEXTVAL INTO v_id FROM DUAL; 
  insert into tabela (id,dep,region_id) 
  values (v_id,v_nome,null); 
end insere_departamento; 

-> no delphi... 

- coloque o objeto TStoredProc dentro do formulario que ira disparar esta procedure; 
- no evento que voce quiser que dispare coloque o seguinte codigo: 
 var 
  v_nome : String[50]; 
  begin 
{caso vc queira informar o nome do departamento atraves de uma caixa de dialogo} 
  V_nome := inputbox('Informe o nome do departamento.','Depto:',''); 
  .Params[0].AsString := v_nome; 
{caso vc queira buscar o nome atraves de um TEdit já preenchido} 
  .Params[0].AsString := .Text; 
  .ExecProc; 
  end; 
  

Alterando parcialmente o conteúdo da prop.SQL de uma Query

Vamos supor que você tenha uma instrução SQL em uma Query como a seguinte:

SELECT IDCliente, cli_Nome, cli_DataNasc, cli_Sexo
FROM Cliente
WHERE ( IDCliente < 1000 )
AND ( cli_Sexo = 'M' ) (*)
ORDER BY cli_Nome
Para alterar somente a quarta(*) linha do SQL você pode fazer assim:

with qryCliente do
  begin
  if Active then Close;
  SQL[3] := 'AND ( cli_UF = 'ES') OR ( cli_UF = 'RJ' )'; // ou SQL[3] := ' ';
  Open;
  end;

quinta-feira, 24 de agosto de 2017

Retorna a hora da criação de um diretório

function DirectoryTime(aDir: String): String; 
var 
      srFile: TSearchRec; 
begin 
      if FindFirst('C:WINDOWS',faDirectory,srFile)=0 then 
      begin 
           result := TimeToStr(FileDateToDateTime(srFile.Time)); 
      end; 
end; 

Programar meu aplicativo para abrir arquivos a partir do Windows Explorer

Inclua na seção uses: Registry

Problema:

Criei um editor de textos no Delphi. Agora gostaria que o Windows Explorer usasse este editor para abrir arquivos com a extensão .dpg e .dan. Como fazer?

Solução:

Para fazer isto será necessária a criação de algumas chaves no Registro do Windows. O exemplo abaixo cria todas as chaves necessárias.

- Coloque um TButton e no evento OnClick dele coloque o código abaixo:

procedure TForm1.Button1Click(Sender: TObject);
var
  Reg: TRegistry;
begin
  Reg := TRegistry.Create;
  try
  Reg.RootKey := HKEY_CLASSES_ROOT;
  Reg.LazyWrite := false;
  { Define o nome interno (ArquivoDaniel) e uma legenda que aparecerá no Windows Explorer (Arquivo do Daniel) }
  Reg.OpenKey('ArquivoDaniel', true);
  Reg.WriteString('', 'Arquivo do Daniel');
  Reg.CloseKey;
{ Define o comando a ser executado quando abrir um arquivo pelo Windows Explorer (NomeDoExe %1). O símbolo %1 indica que o arquivo a ser aberto será passado como primeiro parâmetro para o aplicativo - ParamStr(1). }
  Reg.OpenKey('ArquivoDaniel\shell\open\command', true);
  Reg.WriteString('', ParamStr(0) + ' %1'); { NomeDoExe %1 }
  Reg.CloseKey;
  { Define o ícone a ser usado no Windows Explorer:
  0 - primeiro ícone do EXE
  1 - segundo ícone do EXE, etc }
  Reg.OpenKey('ArquivoDaniel\DefaultIcon', true);
  Reg.WriteString('', ParamStr(0) + ',0'); { 0 = primeiro ícone }
  Reg.CloseKey;
  { Define as extensões de arquivos que serão abertos pelo meu aplicativo }
  { *.dpg }
  Reg.OpenKey('.dpg', true);
  Reg.WriteString('', 'ArquivoDaniel');
  Reg.CloseKey;
  { *.dan }
  Reg.OpenKey('.dan', true);
  Reg.WriteString('', 'ArquivoDaniel');
  Reg.CloseKey;
  finally
  Reg.Free;
  end;
end;
- Coloque um TMemo;

- No evento OnShow do Form coloque o código abaixo:

procedure TForm1.FormShow(Sender: TObject);
begin
  { Se o primeiro parâmetro for um nome de arquivo existente... }
  if FileExists(ParamStr(1)) then
  { Carrega o conteúdo do arquivo no memo }
  Memo1.Lines.LoadFromFile(ParamStr(1));
end;
*** Para testar ***

- Execute este programa;

- Clique no botão para criar as chaves no Registro do Windows;

- Feche o programa;

- Crie alguns arquivos com as extensões .dpg e .dan;

- Vá ao Windows Explorer e procure pelos arquivos criados;

- Experimente dar um duplo-clique sobre qualquer dos arquivos com uma das extensões acima.

Observações

Existem outros recursos que poderão ser configurados. Porém, para começar, este já é um bom exemplo. 

sábado, 19 de agosto de 2017

Mostrando a lista de último acesso dos arquivos aberto ultimamente

unit Uultimoacesso; 
{object Form1: TForm1 
Left = 230 
Top = 186 
Width = 435 
Height = 167 
Caption = 'Ultimo Acesso' 
Font.Charset = DEFAULT_CHARSET 
Font.Color = clWindowText 
Font.Height = -16 
Font.Name = 'Arial' 
Font.Style = [] 
PixelsPerInch = 96 
TextHeight = 18 
object Label1: TLabel 
Left = 6 
Top = 11 
Width = 53 
Height = 18 
Caption = 'Arquivo' 
end 
object Label2: TLabel 
Left = 6 
Top = 58 
Width = 101 
Height = 18 
Caption = 'Último Acesso' 
end 
object EdArquivo: TEdit 
Left = 6 
Top = 28 
Width = 281 
Height = 26 
TabOrder = 0 
end 
object BtSeleciona: TButton 
Left = 226 
Top = 82 
Width = 87 
Height = 31 
Caption = 'Seleciona' 
TabOrder = 1 
OnClick = BtSelecionaClick 
end 
object EdUltimoAcesso: TEdit 
Left = 6 
Top = 82 
Width = 204 
Height = 26 
TabOrder = 2 
end 
object ODSelecionaArquivo: TOpenDialog 
Left = 352 
Top = 8 
end 
end 

interface 
uses 
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
StdCtrls; 
type 
TForm1 = class(TForm) 
EdArquivo: TEdit; 
BtSeleciona: TButton; 
Label1: TLabel; 
Label2: TLabel; 
EdUltimoAcesso: TEdit; 
ODSelecionaArquivo: TOpenDialog; 
procedure BtSelecionaClick(Sender: TObject); 
private 
{ Private declarations } 
public 
{ Public declarations } 
end; 
var 
Form1: TForm1; 
implementation 
{$R *.DFM} 
procedure TForm1.BtSelecionaClick(Sender: TObject); 
var 
FileHandle : THandle; 
LocalFileTime : TFileTime; 
DosFileTime : DWORD; 
LastAccessdTime : TDateTime; 
FindData : TWin32FindData; 
NomeArquivo : array[0..255] of char; 
begin 
if OdSelecionaArquivo.Execute then 
begin 
EdArquivo.Text := OdSelecionaArquivo.FileName; 
StrPCopy(NomeArquivo,OdSelecionaArquivo.FileName); 
FileHandle := FindFirstFile(NomeArquivo, FindData); 
if FileHandle = INVALID_HANDLE_VALUE then 
begin 
Windows.FindClose(Handle); 
if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then 
begin 
FileTimetoLocalFileTime(FindData.ftLastWriteTime, LocalFileTime); 
FileTimeToDosDateTime(LocalFileTime, LongRec(DosFileTime).Hi, LongRec(DosFileTime).Lo); 
LastAccessdTime := FileDateToDateTime(DosFileTime); 
EdUltimoAcesso.Text := DateTimeToStr(LastAccessdTime); 
end; 
end; 
end; 
end; 
end. 

Listar Arquivos de Um Diretório

Uma dica sobre como listar qualquer tipo de arquivos de um diretório. o toque especial dessa procedure e que ela pode entrar em todos os diretórios que estão dentro do diretório inicial, para procurar arquivos do tipo especificado.

parametros da procedure:

diretorio inicial - diretório que a procedure começa a sua busca ex: c:\windows\ ou ainda c:\ mascara - mascara de arquivo ex: *.txt ou ainda *.* listtotaldir - quando true, ela fornece o caminho completo recursive - quando true, ativa a busca do arquivo dentro de outros diretórios, que estao dentro do diretório inicial

obs.:O form que ira chamar esta função deve possuir uma variavel global declarada da sequinte forma

listtemp2:Tstrings;


ele deve ser criada com o comando

listtemp2 := TstringList.Create;


depois de chamada a procedure o resultado final estara nesta variavel

procedure ListarArquivos(diretorioInicial, mascara: string; listtotaldir: boolean = false; recursive: boolean = true);
var
  i: integer;
  listatemp: TStrings;
  procedure ListarDiretorios(Folder: string; lista: Tstrings);
  var
    Rec: TSearchRec;
    i: integer;
    temps: string;
  begin
    lista.Clear;
    if SysUtils.FindFirst(Folder + '*', faDirectory, Rec) = 0 then
    try
      repeat
        lista.Add(rec.Name);
      until SysUtils.FindNext(Rec) <> 0;
    finally
      if lista.count <> 0 then
      begin
        // deleta o diretorio ..
        lista.Delete(1);
        // deleta o diretorio .
        lista.Delete(0);
        i := 0;
        //deleta os arquivos isto e fica apenas os diretorios
        if lista.count <> 0 then
        begin
          repeat
            temps := lista.Strings[i];
            temps := extractfileext(temps);
            if temps <> '' then
              lista.Delete(i)
            else
              inc(i);
          until i >= lista.Count;
        end;
      end;
    end;
  end;

  procedure ListarAtahos(Folder, mask: string; Lista: Tstrings);
  var
    Rec: TSearchRec;
  begin
    lista.Clear;
    if SysUtils.FindFirst(Folder + mask, faAnyFile, Rec) = 0 then
    try
      repeat
        lista.Add(rec.Name);
      until SysUtils.FindNext(Rec) <> 0;
    finally
      SysUtils.FindClose(Rec);
    end;
  end;

  procedure AddLIstInOther(ListSource, ListDestino: TStrings);
  var
    f: integer;
  begin
    for f := 0 to ListSource.Count - 1 do
    begin
      ListDestino.Add(ListSource.Strings[f]);
    end;
  end;
begin
  listatemp := TStringList.Create;
  ListarAtahos(diretorioInicial, mascara, listatemp);
  if listtotaldir = true then
  begin
    for i := 0 to listatemp.Count - 1 do
    begin
      listatemp.Strings[i] := diretorioInicial + listatemp.Strings[i];
    end;
  end;
  AddLIstInOther(listatemp, listtemp2);
  if recursive = true then
  begin
    ListarDiretorios(diretorioInicial, listatemp);
    for i := 0 to listatemp.Count - 1 do
    begin
      ListarArquivos(diretorioInicial + listatemp.Strings[i] + '\', mascara, listtotaldir, recursive);
    end;
  end;
  listatemp.Free;
end;



exemplo:
coloca-se um listbox, e um button no form.
depois declara-se a variavel global no form
ex:

var
  Form1: TForm;
  listtemp2: TStrings;



e no evento onclick do button a seguinte procedure


listtemp2 := TStringList.Create;
ListarArquivos('c:\windows\', '*.exe', true, true);
listbox1.items := listtemp2;
listtemp2.free;

Enviando um arquivo para a lixeira

uses ShellAPI;

Function DeleteFileWithUndo(sFileName : string ) : boolean;
var
fos : TSHFileOpStruct;
Begin
FillChar( fos, SizeOf( fos ), 0 );
With fos do
  begin
  wFunc := FO_DELETE;
  pFrom := PChar( sFileName );
  fFlags := FOF_ALLOWUNDO
  or FOF_NOCONFIRMATION
  or FOF_SILENT;
  end;
Result := ( 0 = ShFileOperation( fos ) );
end;
  

quinta-feira, 17 de agosto de 2017

Deletar um diretório inteiro de uma vez

Problemas para deletar um diretório com subdiretórios? Utilize a função abaixo:

Uses
  Shellapi, filectrl, //declare estas das units!!!

function DeleteFolder(FolderName: String; LeaveFolder: Boolean): Boolean;
var
  r: TshFileOpStruct;
begin
  Result := False;
  if not DirectoryExists(FolderName) then
  Exit;
  if LeaveFolder then
  FolderName := FolderName + ' *.* '
  else
  if FolderName[Length(FolderName)] = ' \ ' then
  Delete(FolderName,Length(FolderName), 1);
  FillChar(r, SizeOf(r), 0);
  r.wFunc := FO_DELETE;
  r.pFrom := PChar(FolderName);
  r.fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION;
  Result := ((ShFileOperation(r) = 0) and (not r.fAnyOperationsAborted));
end;
Usa-se Assim:

procedure TForm1.Button1Click(Sender: TObject);
begin
  deleteFolder('c:\temp',false);
end;
  

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;

quarta-feira, 16 de agosto de 2017

Criando diretório

Para criar um diretório você precisa usar a função ForceDirectories, o exemplo a baixo testa se não existe um diretório e cria o diretório apartir de uma variável string testando se o diretório já existe 

Unit

FileCtrl

procedure TForm1.Button1Click(Sender: TObject);
var
  Dir: string;
begin
Dir := 'C:\APPS\SALES\LOCAL';

if not DirectoryExists(Dir) then
  ForceDirectories(Dir);
  Label1.Caption := Dir + ' foi criado';
end;

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! 

Copiando Um Arquivo Com Um Gauge

Muitas vezes, quando temos a necessidade de copiar um arquivo de um lugar para outro, é interessante mostrar ao usuário o andamento da cópia.
Para tal, coloque em sua aplicação um gauge (optei por um gauge, mas poderia muito bem ser uma progressbar) e um botão para iniciar a cópia. No código onClick do botão, coloque este código. Neste exemplo, o programa cria um diretório de back-up cujo nome do mesmo é a data da cópia no formato AAAAMMDD. No nosso exemplo, chamei o gauge de ga_copia.

procedure Tfrm_Manut.bt_backupClick(Sender: TObject);
var
  strArqOrigem, // Nome do arquivo de origem da cópia
  strArqDestino: string; // Nome do arquivo de destino da cópia
  wDia,wMes,wAno: Word;
begin
  try
    // Aciona o indicativo de progresso da cópia
    ga_copia.Visible := True;
    ga_copia.Progress := 0;
    // Monta os nomes de arquivo - Primeiro recupera de um AdoConnection
    // o nome do arquivo a ser copiado
    strArqOrigem := dm_spark.ADO_Spark.Properties[7].Value;
    // Agora vai montar o nome do arquivo de destino.
    DecodeDate(Date, wAno, wMes, wDia);
    strArqDestino := 'C:\prodata\copia\' + FormatFloat('0000', WAno);
    strArqDestino := strArqDestino + FormatFloat('00', wMes);
    strArqDestino := strArqDestino + FormatFloat('00', wDia);
    strArqDestino := strArqDestino + '\' + ExtractFileName(strArqOrigem);
    // Desconecta o banco de dados
    dm_spark.ADO_Spark.Close;
    Repaint;
    // Inicia a cópia
    CopyFile(strArqOrigem, strArqDestino);
  finally
    // Reconecta o banco de dados
    dm_spark.ADO_Spark.Open;
    ga_copia.Visible := False;
  end;
end;



Agora que já definimos como e quando a cópia será disparada, vamos definir a procedure copyfile que é o motor da nossa cópia de arquivo. Esta procedure é que vai fazer a cópia e incrementar o Gauge.

procedure Tfrm_Manut.CopyFile(Source, Destination: string);
var
  FromF,ToF: file of byte;
  Buffer: array[0..4096] of char;
  NumRead: Integer;
  FileLength: LongInt;
  NewPath: string;
begin
  // Antes de copiar, verifica se já existe o diretório
  // Caso o diretório não exista, o mesmo vai ser criado
  NewPath := ExtractFilePath(Destination);
  if not DirectoryExists(NewPath) then
  begin
    CreateDir(NewPath);
  end
  else
  begin
    if FileExists(Destination) then
    begin
      if Application.MessageBox('O arquivo-destino da cópia de segurança já existe ' + #13#10 +
        'Deseja sobrepôr o mesmo com a nova cópia ?', 'Segurança',
        MB_YESNO + MB_ICONQUESTION) = MRNO then
        Exit;
    end;
  end;
  // Copia o arquivo
  // Abre o arquivo de origem e cria o arquivo destino
  AssignFile(FromF, Source);
  Reset(FromF);
  AssignFile(ToF, Destination);
  ReWrite(ToF);
  FileLength := FileSize(FromF);
  with ga_copia do
  begin
    MinValue := 0;
    MaxValue := FileLength;
    while FileLength > 0 do
    begin
      BlockRead(FromF, Buffer[0], SizeOf(Buffer), NumRead);
      FileLength := FileLength - NumRead;
      BlockWrite(ToF, Buffer[0], NumRead);
      AddProgress(NumRead);
    end;
    CloseFile(FromF);
    CloseFile(ToF);
  end;
end;