Rotina esgotando memória física

[fajo]

Olá,

estou dando manutenção num sistema de doações com Delphi 2007 e Firebird 2.0.3,

e recentemente me foi pedido para q eu elaborasse uma maneira de gerar parcelas automaticamente para os doadores até um determinado mês de um determinado ano, bom, até ai tudo bem, pois essa rotina já existe só q é executada pelas operadoras, quando necessário, então eu aproveitei essa rotina para fazer o q me pediram, só q a coisa não deu muito certo, quando mando executar, começa tudo bem, mas de repente "unable to allocate memory from operating system.", quando fui ver no Gerenciador de Tarefas do windows, um baita susto, o Firebird consumindo quase 1 GB de memória, assim tb como a aplicação, essa rotina é chamada em um laço para cada um dos registros de uma tabela(ClientDataSet):

function Tdm.F_Insere_Parcelas(V_Con: TSQLConnection; P_Id_Doa,
  P_Qtde_Parc: Integer; P_Mes_Inicial, ResCom, Frequencia: String): ShortString;
Var
  Q_Apaga_Doacoes, Q_Obtem_Doador, Q_Insere_Doacao:TSQLQuery;
  V_Dia_Venc, V_Cont, Contador, Freq:Integer;
  V_Venc_Inicial,V_Venc_Aux:TDateTime;
  V_Dt:String;

Begin
//  showmessage(inttostr(P_Id_Doa)+' '+inttostr(P_Qtde_parc)+' '+P_Mes_Inicial+' '+Rescom);
//  showmessage(inttostr(P_Qtde_Parc)+','+P_Mes_inicial+','+Frequencia);
  Q_Insere_Doacao := TSQLQuery.Create(nil);
  Q_Insere_Doacao.SQLConnection := V_Con;

  Q_Apaga_Doacoes := TSQLQuery.Create(nil);
  Q_Apaga_Doacoes.SQLConnection := V_Con;

  Q_Obtem_Doador := TSQLQuery.Create(nil);
  Q_Obtem_Doador.SQLConnection := V_Con;
  Q_Obtem_Doador.Close;
  Q_Obtem_Doador.SQL.Clear;
  if (ResCom = 'C') then
   begin
    Q_Obtem_Doador.SQL.Add('SELECT Tab_Doadores.Doa_Id, Tab_Doadores.Doa_Dia_Recebimento, Tab_Doadores.Doa_Valor_Parcela, Tab_Doadores.Doa_Operadora, Tab_Bairros.Bai_Fun_Id');
    Q_Obtem_Doador.SQL.Add('FROM Tab_Bairros INNER JOIN Tab_Doadores ON Tab_Bairros.Bai_Id = Tab_Doadores.Doa_Bairro_Com');
    Q_Obtem_Doador.SQL.Add('WHERE Tab_Doadores.Doa_Id = ' +  IntToStr(P_Id_Doa));
    Q_Obtem_Doador.SQL.Add('AND Tab_Bairros.Bai_Fun_Id Is Not Null');
    Q_Obtem_Doador.SQL.Add('AND Tab_Doadores.Doa_Status = '+asp+'A'+asp);
   end
  else
   begin
    Q_Obtem_Doador.SQL.Add('SELECT Tab_Doadores.Doa_Id, Tab_Doadores.Doa_Dia_Recebimento, Tab_Doadores.Doa_Valor_Parcela, Tab_Doadores.Doa_Operadora, Tab_Bairros.Bai_Fun_Id');
    Q_Obtem_Doador.SQL.Add('FROM Tab_Bairros INNER JOIN Tab_Doadores ON Tab_Bairros.Bai_Id = Tab_Doadores.Doa_Bairro');
    Q_Obtem_Doador.SQL.Add('WHERE Tab_Doadores.Doa_Id = ' +  IntToStr(P_Id_Doa));
    Q_Obtem_Doador.SQL.Add('AND Tab_Bairros.Bai_Fun_Id Is Not Null');
    Q_Obtem_Doador.SQL.Add('AND Tab_Doadores.Doa_Status = '+asp+'A'+asp);
   end;

  Q_Obtem_Doador.Open;

  If Q_Obtem_Doador.eof then
  Begin
   F_Insere_Parcelas := '0';
//   showmessage('Retornou 0');
  End
  Else
  Begin
      V_Dia_Venc := Q_Obtem_Doador.FieldByName('Doa_Dia_Recebimento').AsInteger;
//      showmessage(inttostr(V_Dia_Venc));
      V_Dt := IntToStr(V_Dia_Venc) + '/' + F_Replica(copy(P_Mes_Inicial,1,2),2,'0') + '/' + copy(P_Mes_Inicial,4,4);
      While F_Data_Valida(V_Dt) = False do
      Begin
        V_Dia_Venc := V_Dia_Venc - 1;
        V_Dt := IntToStr(V_Dia_Venc) + '/' + F_Replica(copy(P_Mes_Inicial,1,2),2,'0') + '/' + copy(P_Mes_Inicial,4,4);
      End;

      V_Venc_Inicial := StrToDate(V_Dt);

//     For V_Cont := 0 to P_Qtde_Parc -1 do
     if Frequencia = 'M' then
      V_Cont:=1
     else
     if Frequencia = 'B' then
      V_Cont:=2
     else
     if Frequencia = 'T' then
      V_Cont:=3
     else
     if Frequencia = 'Q' then
      V_Cont:=4
     else
     if Frequencia = 'S' then
      V_Cont:=6
     else
     if Frequencia = 'A' then
      V_Cont:=12;
    Contador := 0;
    Freq := 0;
    while Freq <= (P_Qtde_Parc - 1)  do
    Begin
    V_Venc_Aux := IncMonth(V_Venc_Inicial,Contador);
      if (F_Obtem_Dia_Util(V_Con,datetostr(V_Venc_Aux)) = 'N') and (DayOfTheMonth(V_Venc_Aux) = 1) then
         V_Venc_Aux := IncDay(V_Venc_Aux,1)
      else
      if F_Obtem_Dia_Util(V_Con,datetostr(V_Venc_Aux)) = 'N' then
         V_Venc_Aux := IncDay(V_Venc_Aux,-1)
      else
      if (DayOfTheMonth(V_Venc_Aux) = 1) and (DayOfWeek(V_Venc_Aux) = 1) then
         V_Venc_Aux := IncDay(V_Venc_Aux,1)
      else
      //Se for no domingo a data será decrementada em uma dia(Sábado)
      If DayOfWeek(V_Venc_Aux) = 1 then V_Venc_Aux := IncDay(V_Venc_Aux,-1);
//      If DayOfTheMonth(V_Venc_Aux) = 1 then V_Venc_Aux := IncDay(V_Venc_Aux,-1);

      If Not F_Existe_Doacao(V_Con,P_Id_Doa,V_Venc_Aux) then
      Begin
        Q_Apaga_Doacoes.Close;
        Q_Apaga_Doacoes.SQL.Clear;
        Q_Apaga_Doacoes.SQL.Add('DELETE FROM Tab_Doacoes');
        Q_Apaga_Doacoes.SQL.Add('WHERE Tab_Doacoes.Doc_Doa_Id=' +  IntToStr(P_Id_Doa));
        Q_Apaga_Doacoes.SQL.Add('AND Tab_Doacoes.Doc_Status_Doacao < 4');
        Q_Apaga_Doacoes.SQL.Add('AND Tab_Doacoes.Doc_Status_Impressao = 6');
        Q_Apaga_Doacoes.SQL.Add('AND Extract(year from Tab_Doacoes.Doc_Data_Operacao)= ' + FormatDateTime('yyyy', V_Venc_Aux));
        Q_Apaga_Doacoes.SQL.Add('AND Extract(month from Tab_Doacoes.Doc_Data_Operacao)= ' + FormatDateTime('mm', V_Venc_Aux));
        Q_Apaga_Doacoes.ExecSQL;

        Q_Insere_Doacao.Close;
        Q_Insere_Doacao.SQL.Clear;
        Q_Insere_Doacao.SQL.Add('INSERT INTO Tab_Doacoes');
        Q_Insere_Doacao.SQL.Add('(Doc_Doa_Id,Doc_Func_Operadora,Doc_Func_Mensageiro,Doc_Data_Operacao,Doc_Valor)');
        Q_Insere_Doacao.SQL.Add('VALUES');
        Q_Insere_Doacao.SQL.Add('(' + asp + IntToStr(P_Id_Doa) + asp +',');
        Q_Insere_Doacao.SQL.Add('' + asp + Q_Obtem_Doador.FieldByName('Doa_Operadora').AsString + asp +',');
        Q_Insere_Doacao.SQL.Add('' + asp + Q_Obtem_Doador.FieldByName('Bai_Fun_Id').AsString + asp + ',');
        Q_Insere_Doacao.SQL.Add(asp + FormatDateTime('mm/dd/yyyy',V_Venc_Aux) + asp + ',');
        Q_Insere_Doacao.SQL.Add('' + asp + Q_Obtem_Doador.FieldByName('Doa_Valor_Parcela').AsString + asp + ')');
        Q_Insere_Doacao.ExecSQL;
      End;
     Contador := Contador + V_Cont;
     Freq := Freq + 1;
    End;
    F_Insere_Parcelas := '1';
//    showmessage('Retornou 1');
  End;
  Freeandnil(Q_Insere_Doacao);
  Freeandnil(Q_Apaga_Doacoes);
  Freeandnil(Q_Obtem_Doador);

end;

Editado Setembro 30, 2008 por fajo

[Micheus]

Fajo, por gentileza edit seu post e coloque a tag

 <codigo> [/ CODE] (sem este espaço depois da barra). Um código deste tamanho, sem as tags, não é nada convidativo a uma avalição. ;)