{--------------------------------------------------------}
{               cartaVox - rotinas utilitarias
{--------------------------------------------------------}

unit carUtil;
interface

uses winProcs, winDos, winTypes, shellApi,
     dvcrt, strings, dvWin, winsock,
     carVars, carMsg;

function existeArq (nomearq: string): boolean;
function novoNomeCarta (var nbase: integer; diret, extensao: string): string;
function executaProg (nomeProg, nomeDir, nomeArq: string): boolean;
procedure esperaProgVoltar;
function semAcentos (s: string): string;
function maiusc (s: string): string;

function buscaNaCarta (ncar: integer; texto: string): string;
function convIso (s: string): string;
procedure removeIso (var s: string);
procedure procurar (var ncar: integer);
procedure procuraDeNovo (var ncar: integer);
procedure poeAreaTransf (ncar: integer);

implementation

{--------------------------------------------------------}
{                  ve se arquivo existe
{--------------------------------------------------------}

function existeArq (nomearq: string): boolean;
var existe: boolean;
    arq: file;
begin
    assign (arq, nomearq);
    {$I-}  reset (arq); {$i+}
    existe := ioresult = 0;
    if existe then close (arq);
    existeArq := existe;
end;

{-------------------------------------------------------------}
{               cria um novo nome para carta
{-------------------------------------------------------------}

function novoNomeCarta (var nbase: integer; diret, extensao: string): string;
var
    result, i: integer;
    s: string;
    arq: file;
    dirAtual: string;

begin
    getDir (0, dirAtual);
    {$I-}  chdir (diret);  {$I+}
    if ioresult <> 0 then
        begin
            novoNomeCarta := '';
            exit;
        end;
    chDir (dirAtual);

    if diret [length(diret)] = '\' then
           delete (diret, length(diret), 1);

    repeat
        nbase := nbase + 1;
        str (nbase, s);
        assign (arq, diret + '\' + s + '.' + extensao);

        {$I-} reset (arq);  {$I+}
        result := ioresult;
        {$I-} close (arq);  {$I+}
        if ioresult <> 0 then ;
    until result <> 0;

    novoNomeCarta := diret + '\' + s + '.' + extensao;
end;

{-------------------------------------------------------------}
{                       executa um programa
{-------------------------------------------------------------}

function executaProg (nomeProg, nomeDir, nomeArq: string): boolean;
var
    pprog, pdir, pparam: array [0..100] of char;
    erro: tHandle;

begin
    executaProg := true;
    strPcopy (pprog, nomeProg);
    strPCopy (pdir, nomeDir);
    strPcopy (pparam, nomeArq);

    GetWindowText(crtWindow, meuNome, 100);

    erro := ShellExecute(crtWindow, 'open', pprog, pparam, pdir, SW_SHOWNORMAL);
    if erro < 32 then
        begin
            textBackground (RED);
            mensagem ('CTNAOEXE', 0);  {'Não foi possível executar esse programa, erro #'}
            sintWriteInt (erro);
            textBackground (RED);
            writeln;
            executaProg := false;
        end;
end;

{--------------------------------------------------------}
{        espera o titulo da janela ficar o mesmo
{--------------------------------------------------------}

procedure esperaProgVoltar;
var nomeNovo: array [0..100] of char;
    i: integer;
begin
    i := 0;
    repeat
        delay (1000);   { nao remova este delay }
        GetWindowText (getFocus, nomeNovo, 100);
        i := i + 1;
    until (strComp (meuNome, nomeNovo) <> 0) or (i > 10);

    repeat
        delay (1000);
        GetWindowText (getFocus, nomeNovo, 100);
    until strComp (meuNome, nomeNovo) = 0;
end;

{--------------------------------------------------------}
{             elimina acentos de uma cadeia
{--------------------------------------------------------}

type
    TABDIGIT = array [1..14] of char;

const
    acentuaveis: set of char = ['A','E','I','O','U','C', 'N',
                                'a','e','i','o','u','c', 'n'];
const
    crases:   TABDIGIT = (#$c0, #$c8, #$cc, #$d2, #$d9, 'C',  'N',
                          #$e0, #$e8, #$ec, #$f2, #$f9, 'C',  'N');

    agudos :  TABDIGIT = (#$c1, #$c9, #$cd, #$d3, #$da, #$c7, 'N',
                          #$e1, #$e9, #$ed, #$f3, #$fa, #$e7, 'N');

    circunfs: TABDIGIT = (#$c2, #$ca, #$ce, #$d4, #$db, 'C',  'N',
                          #$e2, #$ea, #$ee, #$f4, #$fb, 'C',  'N');

    tils:     TABDIGIT = (#$c3, 'E',  'I',  #$d5, 'U',  'C',  #$d1,
                          #$e3, 'E',  'I',  #$f5, 'U',  'C',  #$f1);

    tremas:   TABDIGIT = (#$c4, #$cb, #$cf, #$d6, #$dc, 'C',  'N',
                          #$e4, #$eb, #$ef, #$f6, #$fc, 'C',  'N');

{--------------------------------------------------------}

function semAcentos (s: string): string;
const
    tabMaiuscPC: array [#$80..#$ff] of char = (

    'C','U','E','A','A','A','A','C','E','E','E','I','I','I','A','A',
    'E','þ','þ','O','O','O','U','U','Y','O','U','þ','þ','þ','þ','þ',
    'A','I','O','U','N','N','þ','þ','þ','þ','þ','þ','þ','þ','þ','þ',
    'þ','þ','þ','þ','þ','þ','þ','þ','þ','þ','þ','þ','þ','þ','þ','þ',
    'A','A','A','A','A','A','‘','C','E','E','E','E','I','I','I','I',
    'þ','N','O','O','O','O','O','X','þ','U','U','U','U','Y','þ','þ',
    'A','A','A','A','A','A','‘','C','E','E','E','E','I','I','I','I',
    'þ','N','O','O','O','O','O','X','þ','U','U','U','U','Y','þ','þ');

var
    s2: string;
    i: integer;

begin
    move (s, s2, length(s)+1);
    for i := 1 to length (s2) do
        if s2[i] in ['a'..'z'] then
            s2[i] := upcase (s2[i])
        else
        if s2[i] >= #$80 then
            s2[i] := tabMaiuscPC [s2[i]];

    semAcentos := s2;
end;

{-------------------------------------------------------------}
{                 transforma cadeia em maiusculos
{-------------------------------------------------------------}

function maiusc (s: string): string;
var i: integer;
    s2: string;
begin
    s2 := '';
    for i := 1 to length (s) do
        s2 := s2 + upcase (s[i]);
    maiusc := s2;
end;

{--------------------------------------------------------}
{               busca uma cadeia na carta
{--------------------------------------------------------}

function buscaNaCarta (ncar: integer; texto: string): string;
var s: string;
    i: integer;
    cartaRec: text;
label pula, achou;
begin
    buscaNaCarta := '';

    assign (cartaRec, regLido [ncar]^.nomArqCarta);
    {$I-}  reset (cartaRec);  {$I+}
    if ioresult <> 0 then
        begin
            mensagem ('CTCARSUM', 1);  {'Erro no disco: carta sumiu'}
            exit;
        end;

    s := 'a';
    while (s <> '') and (not eof (cartaRec)) do
        begin
            readln (cartaRec, s);
            if length (s) < length (s) then
                goto pula;
            for i := 1 to length (texto) do
                if upcase (texto[i]) <> upcase (s[i]) then
                    goto pula;

            buscaNaCarta := copy (s, length(texto) + 1, length (s) - length(texto));
            goto achou;
pula:;
        end;

achou:

    close (cartaRec);
end;

{-------------------------------------------------------------}
{                   converte cadeia em formato ISO
{-------------------------------------------------------------}

function convIso (s: string): string;
var i: integer;
    sai: string;

    function conv16 (c: char): integer;
    begin
        if c in ['0'..'9'] then  conv16 := ord (c) - ord ('0')
        else
        if c in ['A'..'F'] then  conv16 := ord (c) - ord ('A') + 10
        else
        if c in ['a'..'f'] then  conv16 := ord (c) - ord ('a') + 10
        else
            conv16 := 0;
    end;

begin
    sai := '';
    i := 1;
    if s[length(s)] = '=' then
        delete (s, length (s), 1);

    while i <= length (s) do
        begin
            if s[i] = '=' then
                begin
                    sai := sai + chr ((conv16 (s[i+1]) shl 4) + conv16 (s[i+2]));
                    i := i + 3;
                end
            else
                begin
                    sai := sai + s[i];
                    i := i + 1;
                end;
        end;
    convIso := sai;
end;

{-------------------------------------------------------------}
{       remove especificacoes ISO de assuntos e nomes
{-------------------------------------------------------------}

procedure removeIso (var s: string);
var i, p, p2: integer;
    saida: string;

    function trocar (s: string): string;
    var i: integer;
    begin
        delete (s, 1, 2);
        while (s <> '') and (s[1] <> '?') do delete (s, 1, 1);
        delete (s, 1, 1);
        while (s <> '') and (s[1] <> '?') do delete (s, 1, 1);
        delete (s, 1, 1);
        delete (s, length(s)-1, 2);
        s := convIso (s);
        for i := 1 to length (s) do
            if s[i] = '_' then s[i] := ' ';
        trocar := s;
    end;

begin
    p := pos ('=?', s);
    if p = 0 then exit;

    p2 := 1;
    saida := '';
    while p2 <> 0 do
        begin
            saida := saida + copy (s, 1, p-1);
            delete (s, 1, p-1);
            p2 := pos ('?=', s);
            if p2 <> 0 then
                begin
                    saida := saida + trocar (copy (s, 1, p2+1));
                    delete (s, 1, p2+1);
                end
            else
                saida := saida + s;
        end;

    s := saida;

    while (s <> '') and (s[1] = ' ') do
        delete (s, 1, 1);
end;

{--------------------------------------------------------}
{              procurar no cabeçalho da carta
{--------------------------------------------------------}

procedure procuraDeNovo (var ncar: integer);
var
    n: integer;
    s: string;
    carta: text;
label proxima, achou;
begin
    for n := ncar + 1 to numRegs do
        begin
            assign (carta, regLido [n]^.nomArqCarta);
            {$I-}  reset (carta);  {$I+}
            if ioresult = 0 then
                begin
                    s := 'a';
                    while (s <> '') and (not eof (carta)) do
                        begin
                            {$I-} readln (carta, s);  {$I+}
                            if ioresult <> 0 then goto proxima;
                            s := maiusc (semAcentos (s));
                            if pos (textoBusc, s) <> 0 then
                                goto achou;
                        end;
        proxima:
                    close (carta);
               end;
            end;

    mensagem ('CTNACHEI', 1);    {'Não achei'}
    exit;

achou:
    mensagem ('CTACHEI', 1);     {'Achei'}
    ncar := n;
    close (carta);
end;

{--------------------------------------------------------}

procedure procurar (var ncar: integer);
begin
    mensagem ('CTINFPRO', 1);    {'Informe o texto a procurar no cabeçalho da carta'}
    sintReadln (textoBusc);
    textoBusc := maiusc (semAcentos (textoBusc));

    procuraDeNovo (ncar);
end;

{--------------------------------------------------------}
{          poe endereço na área de transferência
{--------------------------------------------------------}

procedure poeAreaTransf (ncar: integer);
var nome: string;
begin
    nome := buscaNaCarta (ncar, 'From:');
    while (nome <> '') and (nome[1] = ' ') do
        delete (nome, 1, 1);
    nome := nome + #$0d + #$0a + #$0;

    putClipboard (@nome[1]);
    sintBip;
end;

end.