{--------------------------------------------------------}
{            Telemark - arquivamento
{--------------------------------------------------------}

unit tmTransf;
interface
uses dvcrt, dvwin, winprocs, strings,  windos, tmVars, tmMsg, tmArquiv;

procedure transfere;

implementation

{--------------------------------------------------------}
{               copia fichas de outro diretorio
{--------------------------------------------------------}

procedure  trazCopia (dirOrig, dirDest: string; opcaoApaga: boolean);
type
    strNome = string [12];
    pNomes = ^TNomes;
    TNomes = array [1..15000] of ^strNome;

var buf: pchar;
    lidos: word;
    nomeArq: string;
    buscado: TSearchRec;
    arq, arqSai: file;
    i, nNomes: integer;
    listaNomes: pNomes;

label erro;
begin
    new (listaNomes);
    nNomes := 0;
    getMem (buf, 64000);

    chdir (dirOrig);    {pega nome correto do diretorio}
    getDir (0, dirOrig);
    chdir (dirDest);
    getDir (0, dirDest);
    chdir (dirOrig);

    FindFirst ('*.FIC', FaArchive, buscado);
    while DosError = 0 do
        begin
            nNomes := nNomes + 1;
            new (listaNomes^[nNomes]);
            listaNomes^[nNomes]^ := strPas (buscado.name);
            FindNext(buscado);
        end;

    for i := 1 to nNomes do
        begin
            nomeArq := listaNomes^[i]^;
            dispose (listaNomes^[i]);
            writeln (nomeArq);

            chdir (dirOrig);
            assign (arq, nomeArq);
            {$I-} reset (arq, 1); {$I+}
            if ioresult <> 0 then  goto erro;

            {$I-} blockRead (arq, buf[0], filesize (arq), lidos);  {$I+}
            if ioresult <> 0 then  goto erro;

            {$I-} close (arq);  {$I+}
            if ioresult <> 0 then  goto erro;

            if lidos = 0 then goto erro;

            chdir (dirDest);

            assign (arqSai, nomeArq);
            {$I-} rewrite (arqSai, 1); {$I+}
            if ioresult <> 0 then  goto erro;

            {$I-} blockWrite (arqSai, buf[0], lidos);  {$I+}
            if ioresult <> 0 then  goto erro;

            {$I-} close (arqSai);  {$I+}
            if ioresult <> 0 then  goto erro;

            if opcaoApaga then
                begin
                     chdir (dirOrig);

                    {$I-}  erase (arq);  {$I+}
                    if ioresult <> 0 then
                        begin
                            mensagem ('TMERRAPA', 0);    {'Erro ao apagar o arquivo '}
                            sintWriteln (nomeArq);
                        end;
                end;

            if false then
                begin
            erro:
                    {$I-} close (arq);  {$I+}
                    if ioresult <> 0 then;
                    {$I+} close (arqSai); {$I+}
                    if ioresult <> 0 then;

                    mensagem ('TMERRCOP', 0);    {'Erro ao copiar o arquivo '}
                    sintWriteln (nomeArq);
                end;

            chdir (dirOrig);
        end;

    freeMem (buf, 64000);
    dispose (listaNomes);
end;

{--------------------------------------------------------}
{               copia fichas de outro diretorio
{--------------------------------------------------------}

procedure produzCopia (dirOrig, dirDest: string; opcaoApaga, opcaoTodos: boolean);
var buf: pchar;
    lidos: word;
    nomeArq: string;
    buscado: TSearchRec;
    arq, arqSai: file;
    i, nNomes: integer;

label erro;
begin
    chdir (dirOrig);    {pega nome correto do diretorio}
    getDir (0, dirOrig);
    chdir (dirDest);
    getDir (0, dirDest);
    chdir (dirOrig);

    getMem (buf, 64000);

    for i := 1 to cadastrados do
        with pessoas^[i]^ do
        if opcaoTodos or selecionado then
        begin
            writeln (nomeArq);

            chdir (dirOrig);
            assign (arq, nomeArq);
            {$I-} reset (arq, 1); {$I+}
            if ioresult <> 0 then  goto erro;

            {$I-} blockRead (arq, buf[0], filesize (arq), lidos);  {$I+}
            if ioresult <> 0 then  goto erro;

            {$I-} close (arq);  {$I+}
            if ioresult <> 0 then  goto erro;

            if lidos = 0 then goto erro;

            chdir (dirDest);

            assign (arqSai, nomeArq);
            {$I-} rewrite (arqSai, 1); {$I+}
            if ioresult <> 0 then  goto erro;

            {$I-} blockWrite (arqSai, buf[0], lidos);  {$I+}
            if ioresult <> 0 then  goto erro;

            {$I-} close (arqSai);  {$I+}
            if ioresult <> 0 then  goto erro;

            if opcaoApaga then
                begin
                     chdir (dirOrig);

                    {$I-}  erase (arq);  {$I+}
                    if ioresult <> 0 then
                        begin
                            mensagem ('TMERRAPA', 0);    {'Erro ao apagar o arquivo '}
                            sintWriteln (nomeArq);
                        end;
                end;

            if false then
                begin
            erro:
                    {$I-} close (arq);  {$I+}
                    if ioresult <> 0 then;
                    {$I+} close (arqSai); {$I+}
                    if ioresult <> 0 then;

                    mensagem ('TMERRCOP', 0);    {'Erro ao copiar o arquivo '}
                    sintWriteln (nomeArq);
                end;

            chdir (dirOrig);
        end;

    freeMem (buf, 64000);
end;

{--------------------------------------------------------}
{               procedimentos de exportacao
{--------------------------------------------------------}

procedure transfere;
var opcao, c, c2: char;
    dirAtual, dirExt: string;
    opcaoTodos, opcaoApaga: boolean;
begin
    mensagem ('TMDIRDST', 1);    {'Informe o nome do diretório externo'}
    sintReadln (dirExt);
    if dirExt = '' then
        begin
            mensagem ('TMDESIST', 1);    {'Desistiu'}
            exit;
        end;

    getdir (0, dirAtual);

    {$I-} chdir (dirExt);  {$I+}
    if ioresult <> 0 then
        begin
            mensagem ('TMDIRINV', 1);    {'Diretório inválido'}
            exit;
        end;

    getdir (0, dirExt);   {pega nome completo dele}
    chDir (dirAtual);

    mensagem ('TMTRAZGD', 0);    {'Qual opção: trazer ou guardar dados ? '}
    sintLeTecla (opcao, c2);
    writeln;
    opcao := upcase (opcao);
    if opcao = 'G' then
        begin
            mensagem ('TMTODSEL', 0);   {'Todos ou selecionados ? '}
            sintLeTecla (c, c2);
            writeln;
            if c = ESC then
                begin
                    mensagem ('TMDESIST', 1);    {'Desistiu'}
                    exit;
                end;
            opcaoTodos := true;
            if upcase(c) = 'S' then
                opcaoTodos := false;
        end
    else
    if opcao <> 'T' then
        begin
            mensagem ('TMDESIST', 1);    {'Desistiu'}
            exit;
        end;

    mensagem ('TMREMOVE', 0);    {'Remove arquivos depois de copiar ? '}
    sintLeTecla (c, c2);
    writeln;
    opcaoApaga := upcase(c) = 'S';

    if opcao = 'T' then
        trazCopia (dirExt, dirAtual, opcaoApaga)
    else
        produzCopia (dirAtual, dirExt, opcaoApaga, opcaoTodos);

    chDir (dirAtual);

    if opcaoApaga or (opcao = 'T') then
        leCadastro;
end;

end.
