Impressao - definindo um intervalo tipo MS word

// Como criar um intervalo de paginas tipo word?

// Ex.:  imprimir as páginas = "4-6;10;11;1;8-9"

// Veja as rotinas "suadas" abaixo:

uses ARotinasUnit;

var

  PaginasValidas: array of Integer; // páginas para impressão... (quando usa intervalo)

// Ordena uma matriz numérica (a que contém os números das páginas válidas para impressão

procedure QuickSort(var A: array of Integer; const iLo, iHi: Integer);

var

  Lo, Hi, Mid, T: Integer;

begin

  Lo := iLo; Hi := iHi;

  Mid := A[(Lo + Hi) div 2];

  repeat

    while A[Lo] < Mid do Inc(Lo);

    while A[Hi] > Mid do Dec(Hi);

    if Lo <= Hi then

    begin

      T     := A[Lo];

      A[Lo] := A[Hi];

      A[Hi] := T;

      Inc(Lo); Dec(Hi);

    end;

  until Lo > Hi;

  if Hi > iLo then QuickSort(A, iLo, Hi);

  if Lo < iHi then QuickSort(A, Lo, iHi);

end;

// Esta rotina é útil para fazer telas se seleção de páginas usando faixas tipo a pré-impressão do Word. Pode-se escolher por exemplo:

// 1-4;6 = [1,2,3,4,6]     1;5;10-12 = [1,5,10,11,12]      PARES = [2,4,6... até TotalPaginas]    IMPARES = [1,3,5... até TotalPaginas]

procedure ListaPaginasValidas(const Intervalo: string; const TotalPaginas: Integer);

var

  I, I2, INr, Oc: Integer;

  Ant, V1, V2   : Integer;

  S, Faixa      : string;

  AOK           : array of integer; // array usado para filtrar só os distintos (não repetidos)

begin

  SetLength(PaginasValidas, TotalPaginas);

  if Trim(Intervalo) = '' then  // nada = TODAS

  begin

    for I := 0 to High(PaginasValidas) do PaginasValidas[I] := I + 1;

    Exit;

  end;

  SetLength(PaginasValidas, TotalPaginas);

  INr   := 0;

  Faixa := StrTran(Intervalo,',',';');  // troca vírgulas por ponto-e-virgulas

  Oc    := Ocorre(Faixa,';');

  if UpperCase(Faixa) = 'IMPARES' then

  begin

    SetLength(PaginasValidas, TotalPaginas div 2);

    for I := 1 to TotalPaginas do

      if Odd(I) then

      begin

        PaginasValidas[INr] := I;

        Inc(INr);

      end;

    Exit;

  end;

  if UpperCase(Faixa) = 'PARES' then

  begin

    SetLength(PaginasValidas, TotalPaginas div 2);

    for I := 2 to TotalPaginas do

      if not Odd(I) then

      begin

        PaginasValidas[INr] := I;

        Inc(INr);

      end;

    Exit;

  end;

  // Só tem uma página?

  if (Oc = 0) and (StrToIntDef(Faixa, 0) > 0) then

  begin

    SetLength(PaginasValidas, 1); // A matriz é única

    PaginasValidas[0] := StrToIntDef(Faixa, 0);

    Exit;

  end

  else

  begin

    if Copy(Faixa, Length(Faixa),1) <> ';' then Inc(Oc); // se não termina com ";" põe mais um para pegar o ultimo dos moicanos

    for I := 1 to Oc do

    begin

      S := Trim(Separa(Faixa, ';', I)); // pega o valor em questã

      if Pos('-',S) > 0 then // tem range (tracinho) 3-40, 1-20 ...

      begin

        V1 := StrToIntDef(Separa(S, '-', 1),0); // pega o valor inicial da faixa

        V2 := StrToIntDef(Separa(S, '-', 2),0); // pega o valor final   da faixa

        if V1 = 0 then Continue;                // se o valor 1 for zero não faz o loop

        for I2 := V1 to V2 do                   // percorre os dois valores e os coloca na matriz

        begin

          PaginasValidas[INr] := I2;

          Inc(INr);

        end;

      end   // Não tem "tracinho" (range) na string?

      else

      if StrToIntDef( S, 0 ) > 0 then               // o valor é positivo? ...

      begin

        PaginasValidas[INr] := StrToIntDef( S, 0 ); // ...Põe o bixo na matriz

        Inc(INr);

      end;

    end;

    if INr > 0 then SetLength(PaginasValidas, INr);

  end;

  // Coloca em ordem

  QuickSort(PaginasValidas, Low(PaginasValidas), High(PaginasValidas));

  // Tem que tirar os duplicados...

  SetLength(AOK, High(PaginasValidas) + 1);

  Ant := 0; INr := 0;

  for I := 0 to High(PaginasValidas) do  // pecorre a lista

    if PaginasValidas[I] <> Ant then     // se é diferente do anterior coloca na array temp.

    begin

      Ant     := PaginasValidas[I];

      AOK[INr]:= Ant;

      Inc(INr);

    end;

  SetLength(PaginasValidas, INr);

  for I := 0 to (INr - 1) do PaginasValidas[I] := AOK[I];  // passa da temp para a normal...

end;

// isto funciona com recursos de pesquisa binária para saber se determinada página está marcada para impressão

function ImprimeEstaPagina(const Pagina: Integer): Boolean;

var

  I, Min, Max, C: Integer;

begin

  if Pagina > MaxIntervalo then

  begin

    Result := True;

    Exit;

  end;

  Min   := 0;

  Max   := High(PaginasValidas) + 1;

  Result:= False;

  C     := 0;

  while True do

  begin

    I := ((Max - Min) div 2) + Min; // aqui tá o calculo magico

    if C = High( PaginasValidas ) then

    begin

      Result := (PaginasValidas[C] = Pagina);

      Break;

    end;

    Inc(C);

    if PaginasValidas[I] = Pagina then

    begin

      Result := True;

      Break;

    end;

    if Pagina > PaginasValidas[I] then

    begin

      Min := I;

      Continue;

    end;

    if Pagina < PaginasValidas[I] then Max := I;

  end;

end;

//////////////////// AQUI é O CLICK DO BOTÃO //////////////////

procedure TForm1.Button1Click(Sender: TObject);

var

  Intervalo: string;

  I        : Integer;

begin

  Intervalo := '3-6,1,10-11;9';

  ListaPaginasValidas(Intervalo, 20);

  for I := 1 to 20 do

    if ImprimeEstaPagina(I) then Memo1.Lines.Add('ESTA IMPRIME: ' + IntToStr(I))

end;