Problemas con Thread Memoria en Paradox

goedecke · #1 03-11-2012

Hola estoy intentando hacer una aplicación que corra en consola que lea de un archivo escrito en paradox 4.5 por medio de DBE y posteriormente me haga los Scripts de .SQL para migrar a MySQL sin embargo me marca un error de memoria en archivos mayores a 100 MB y no logro que me corra mas de un Thread a la vez agradeceria su amable ayuda

Código Delphi [-]
program DB2SQLReport;

{$APPTYPE CONSOLE}

{$R *.res}

uses
   System.SysUtils, System.Classes, Bde.DBTables, Data.DB, TypInfo, StrUtils, ShellApi;


const
  DEFAULT_IDIR = 'C:\Reports\';      // direc. por defecto donde se leeran los archivos
  DEFAULT_ODIR = 'C:\SQL\create\';
  VK_TAB = Chr(9);

 type

    TMiThread = class(TThread)
  protected
    procedure Execute; override;
  public
    constructor Create;
  end;
  


var
  WildCard : String;
  Clientes : array of String;
  index : integer;
  script : TStringList;
  errors : TStringList;
  registros : Integer;
  thidnext : Integer = 0;
  thPdxFilses, thdirs :TStringList;




// -------------------------------------------------------------------------------------
// esta fn. prepara un campo cadena , si es null retorna la palabra null, sin apostrofos
// sino le agrega los apostrofos y ademas si el datos tiene caracteres tales como: \ ' "
// le agrega su respectivo slash
function QuotedField(const field : String) : String;
var
  cadena : String;
begin
  cadena := field;
  if(field = '') {or (field = '')} or (field = 'NULL') then
    cadena := 'null'
  else
    cadena := '''' + cadena + '''';

  Result := cadena;
end;
// -------------------------------------------------------------------------------------
//fils the "list" TStrings with the subdirectories of the "directory" directory
 procedure GetSubDirectories(const directory : string; list : TStrings) ;
 var
   sr : TSearchRec;
 begin
   try
     if FindFirst(IncludeTrailingPathDelimiter(directory) + '*.*', faDirectory, sr) < 0 then
       Exit
     else
     repeat
       if ((sr.Attr and faDirectory <> 0) AND (sr.Name <> '.') AND (sr.Name <> '..')) then
         List.Add(IncludeTrailingPathDelimiter(directory) + sr.Name) ;
     until FindNext(sr) <> 0;
   finally
     FindClose(sr) ;
   end;
 end;
// -------------------------------------------------------------------------------------
procedure FindAll (const Path: String; Attr: Integer; List: TStrings);
var
   Res: TSearchRec;
   EOFound: Boolean;
begin
   EOFound:= False;
   if FindFirst(Path, Attr, Res) < 0 then
     exit
   else
     while not EOFound do begin
       List.Add(Res.Name) ;
       EOFound:= FindNext(Res) <> 0;
     end;
   FindClose(Res) ;
end;



// -------------------------------------------------------------------------------------
// esta fn. agrega slashes a la cadena
function AddSlash(const value : String) : String;
var
  cadena : String;
begin
  cadena := value;
  cadena := StringReplace(cadena, '\', '\\', [rfReplaceAll, rfIgnoreCase]);
  cadena := StringReplace(cadena, #39, '\'+#39, [rfReplaceAll, rfIgnoreCase]);
  Result := cadena;
end;

// -------------------------------------------------------------------------------------
// retorna un arreglo con los numeros de cliente leidos desde un directorio base
procedure getClientesByDir();
var
  i : integer;
  lstFiles : TStringList;

begin

    lstFiles := TStringList.Create;

    GetSubDirectories(DEFAULT_IDIR, lstFiles);
    SetLength(Clientes, lstFiles.Count);
    for i := 0 to lstFiles.Count - 1 Do
    begin
      //Writeln(lstFiles.Strings[i]);
      // agregar el directorio al arreglo
      Clientes[i] :=  ExtractFileName( lstFiles.Strings[i] );
    end;
    lstFiles.Free;
end;


// -------------------------------------------------------------------------------------
// retorna una cadena con la creacion de una tabla desde paradox
procedure CreateMysqlScript(const APath: String; const AFile: String );
var
  tblParadox : TTable;
  i, d : integer;
  FieldName : String;
  FieldType : TFieldType;
  FieldSize : integer;
//  Script : String;
  Table : string;
  MySqlType : String;
  Pos : integer;
  coma : string;
  scrInsert : string;
  fecha : TDateTime;
  AFieldValue : AnsiString;
  fieldList:string;
label
  endfunction;

begin

  // se trata de un archivo corrupto
  if(AnsiPos('_', AFile) > 0) then
    Exit;


  try
    tblParadox := TTable.Create(nil);
    tblParadox.DatabaseName := APath;
    tblParadox.TableName := AFile;
    tblParadox.Active := true;
  except
    on E : Exception do
       begin
         errors.Add('Exception class name = '+E.ClassName + ' Exception message = '+E.Message);
       end;
  end;

  // quitarle la extension
  pos := AnsiPos('.', AFile);
  if(pos > 0)
  then Table := AnsiLowerCase(Copy(AFile, 1, pos - 1))
  else Table := AnsiLowerCase(AFile);

  // leer los campos
  script.Add('DROP TABLE IF EXISTS `' + Table + '`;');
  script.Add('CREATE TABLE IF NOT EXISTS `' + Table + '`(');

  for d := 0 to tblParadox.FieldCount - 1 do
  begin
    FieldName := tblParadox.Fields[d].FieldName;
    FieldType := tblParadox.Fields[d].DataType;
    FieldSize := tblParadox.Fields[d].Size;
    case FieldType of
      ftString   : begin
        if(FieldSize > 5) then
          MySqlType := 'VARCHAR'
        else
          MySqlType := 'CHAR';
        MySqlType := MySqlType + '(' + IntToStr(FieldSize) + ')';
      end;
      ftSmallint : MySqlType := 'SMALLINT';
      ftFloat    : MySqlType := 'DECIMAL(11,2)';
      ftDate     : MySqlType := 'DATE';
    end;

    // SOLo para los casos de los campos Client y Branch
    if( AnsiUpperCase(FieldName) = 'CLIENT') OR (AnsiUpperCase(FieldName) = 'BRANCH') then
      MySqlType := 'SMALLINT UNSIGNED'
    else if( AnsiUpperCase(FieldName) = 'CONTADOR') OR (AnsiUpperCase(FieldName) = 'VentasNetas') OR (AnsiUpperCase(FieldName) = 'A') then
      MySqlType := 'TINYINT'
    else if( AnsiUpperCase(FieldName) = 'EXISTENCIA') then
      MySqlType := 'INT'
    else if( AnsiUpperCase(FieldName) = 'DIAS') OR (AnsiUpperCase(FieldName) = 'ANO') then
      MySqlType := 'SMALLINT UNSIGNED'
    else if( AnsiUpperCase(FieldName) = 'MES') OR (AnsiUpperCase(FieldName) = 'DIA') then
      MySqlType := 'TINYINT UNSIGNED';

    // AGREGAR la comita
    if(d< tblParadox.FieldCount - 1) then coma := ','
    else coma := '';
     // AGREGAR la comita

    fieldList := fieldList + '`' + FieldName + '` ' + coma;
   // script.Add('`' + FieldName + '` ' + MySqlType + coma);


    script.Add('`' + FieldName + '` ' + MySqlType + coma);
  end;
  script.Add(') ENGINE = MyISAM;');
  script.Add('');




  // ------------------------------------------------------------------------------------
  // crear los inserts
  while (NOT tblParadox.Eof) do
  begin
  registros := registros+1;
    scrInsert := 'INSERT INTO `' + Table + '`(' + fieldList + ') VALUES(';
    for i := 0 to tblParadox.FieldCount - 1 do
    begin
      if(i > 0) then scrInsert := scrInsert + ', ';
      FieldName := tblParadox.Fields[i].FieldName;
      // si es una fecha cmbiar el formato a yyyy/mm/dd
      if(tblParadox.Fields[i].DataType = ftDate) then
      begin
        fecha := tblParadox.FieldByName(FieldName).AsDateTime;
        AFieldValue := FormatDateTime('yyyy/mm/dd', fecha);
      end else
        AFieldValue := tblParadox.FieldByName(FieldName).AsAnsiString;

      scrInsert := scrInsert + QuotedField(AddSlash(AFieldValue));
    end; // for fields
    scrInsert := scrInsert + ');';
    script.Add(scrInsert);
    tblParadox.Next;
  end; // while records
  tblParadox.Close;
  tblParadox.Free;
  endfunction:

end; // CreateMysqlScript




// -------------------------------------------------------------------------------------
// crea un archivo de texto con el nombre del cliente + .sql
// que contiene la creacion del script
procedure ProcesoCliente(const dir: String; const PdxFile: String);
var
  i : integer;
  Pos : integer;
  Table:string;
begin
    // guardar el script en el archivo
    // limpiar el script para el siguinte cliente
      if(PdxFile = '') then ;

      registros :=0;
      script := TStringList.Create;
       script.Add('CREATE DATABASE IF NOT EXISTS `nissan_dwh`;');
       script.Add('USE `nissan_dwh`;');
      CreateMysqlScript(dir, PdxFile);

  pos := AnsiPos('.', PdxFile);
  if(pos > 0)
  then Table := AnsiLowerCase(Copy(PdxFile, 1, pos - 1))
  else Table := AnsiLowerCase(PdxFile);
     Writeln(VK_TAB + Table +' -> '+ IntToStr(registros));
     Writeln(DEFAULT_ODIR+Table+'.SQL');
      script.SaveToFile(DEFAULT_ODIR+Table+'.SQL');

      script.Free;

end;

constructor TMiThread.Create;
begin
  inherited Create(FALSE);
  // Aqui le indicamos que cuando la ejecucion del thread termine
  // debe liberar el objeto TMithread
  FreeOnTerminate:= TRUE;
end;

procedure TMiThread.Execute;
var
i:Integer;
begin
  repeat
    Beep;
    Writeln('Entra'+thdirs[thidnext]+thPdxFilses[thidnext]);

   ProcesoCliente(thdirs[thidnext], thPdxFilses[thidnext]);
    // Siempre que tengamos un bucle de este tipo, es conveniente usar algún
    // retardo para no abusar de la CPU. A lo mejor en tu código no es necesario.
   // Sleep(1000);
    thidnext:=thidnext+1;
  until Terminated;
end;

// -------------------------------------------------------------------------------------
// crea un archivo de texto con el nombre del cliente + .sql
// que contiene la creacion del script
procedure ProcessCliente(const Cliente: String);
var
  ScrFileName : String;
  i : integer;
  APdxFile, PdxFile : String;
  thdir, thpath, lstFiles : TStringList;
  dir : string;
  id1 : LongWord;
  pi, Pos : integer;
  AFile:string;
  Table:string;
  MiThread: TMiThread;
begin
    lstFiles := TStringList.Create;
    thdir := TStringList.Create;
    thpath := TStringList.Create;
    MiThread:= TMiThread.Create;
    // DIR
    // leer todos los archivos de paradox del directorio de este cliente
    dir := DEFAULT_IDIR ;
    FindAll( dir + '*.DB', faAnyFile, lstFiles);
    for i := 0 to lstFiles.Count - 1 Do
    begin
      PdxFile := lstFiles.Strings[i];

      if(PdxFile = '') then Continue;
      Writeln(VK_TAB + PdxFile);
      // ProcesoCliente(dir, PdxFile);         //Remplazado por Thread

             thdir.Add(dir);
             thpath.Add(PdxFile);


    end;
    thdirs := thdir;
    thPdxFilses := thpath;
    MiThread.Execute;
    thdirs.Free;
    thPdxFilses.Free;
    lstFiles.Free;
end;


// -------------------------------------------------------------------------------------
// MAIN
begin

  Writeln('Programa que genera scripts basados en tablas de Paradox a Mysql');
  try
    script := TStringList.Create;
    errors := TStringList.Create;

    { TODO -oUser -cConsole Main : Insert code here }
    // obtner los archivos en el directorio que se pasa como parametro
    if(ParamCount < 1) then
    begin
      // no indico parametros entonces poner valores por defecto.
      // en este caso buscar todos los numeros de clientes, los cuales se obtienen de los
      // directorios de los clientes ubicados en C:\SD\DB
     // getClientesByDir();
    end
    else begin
      SetLength(Clientes, ParamCount);
      for index := 1 to ParamCount do
        Clientes[index-1] := ParamStr(index);
    end;

    // procesar cada cliente

  //    Writeln('Procesando cliente: ' + Clientes[index]);
      ProcessCliente('DATA');

  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;

  errors.SaveToFile(DEFAULT_ODIR + 'pdxstruct_errors.log');
  script.Free;
  errors.Free;
    //         end;

end.

Casimiro Noteví · #2 03-11-2012

Cita:

Empezado por goedecke

me marca un error de memoria

Sería conveniente que nos copiaras exactamente el mensaje de error.

goedecke · #3 04-11-2012

First chance exception at $765CC41F. Exception class EOutOfMemory with message 'Out of memory'. Process DB2SQLReport.exe (3912)

Casimiro Noteví · #4 04-11-2012

Cita:

Empezado por goedecke

First chance exception at $765CC41F. Exception class EOutOfMemory with message 'Out of memory'. Process DB2SQLReport.exe (3912)

Sí, bien, pero ¿dónde sale ese error?, ¿en qué línea?, ¿lo has seguido con el depurador?, ¿qué comprobaciones has hecho?, ¿sólo ocurre con archivos de más de 100 Mb, pero con los de 99 Mb no hay ese problema?...

goedecke · #5 04-11-2012

Resulta que los TListString solo soportan 150,000 Lineas y yo estoy manejando en ciertos archivos mas de 1 Millon de registros

cambie este TListString a meterlo directamente en el archivo

Código Delphi [-] 
AssignFile(SQLFile, DEFAULT_ODIR+Table+'.SQL');
ReWrite(SQLFile);
WriteLn(SQLFile,'CREATE DATABASE IF NOT EXISTS `dwh`;');
WriteLn(SQLFile,'USE `dwh`;');
Etc.....

Con esto si se hace un poquito mas lenta la aplicación pero me deja meter archivos muy muy grandes.

Ahora bien me queda el punto del multi-thread

Aqui les dejo el código de como quedo:

Código Delphi [-]program DB2SQLReport;

{$APPTYPE CONSOLE}

{$R *.res}

uses
   System.SysUtils, System.Classes, Bde.DBTables, Data.DB, TypInfo, StrUtils, ShellApi;


const
  DEFAULT_IDIR = 'C:\Reports\';      // direc. por defecto donde se leeran los archivos
  DEFAULT_ODIR = 'C:\SQL\create\';
  VK_TAB = Chr(9);

 type

    TMiThread = class(TThread)
  protected
    procedure Execute; override;
  public
    constructor Create;
  end;
  {
  TMsgRecord = record
    thread : Integer;
   // msg    : string[30];
    dir : string;
    PdxFile : string;
    fin : Boolean;
  end;
   }


var
//  Path : String;
  WildCard : String;
  Clientes : array of String;
  index : integer;
  errors : TStringList;
  registros : Integer;
  thidnext : Integer = 0;
  thPdxFilses, thdirs :TStringList;


  //ThreadVar         // We must allow each thread its own instances
                  // of the passed record variable
  //msgPtr : ^TMsgRecord;


// -------------------------------------------------------------------------------------
// esta fn. prepara un campo cadena , si es null retorna la palabra null, sin apostrofos
// sino le agrega los apostrofos y ademas si el datos tiene caracteres tales como: \ ' "
// le agrega su respectivo slash
function QuotedField(const field : String) : String;
var
  cadena : String;
begin
  cadena := field;
  if(field = '') {or (field = '')} or (field = 'NULL') then
    cadena := 'null'
  else
    cadena := '''' + cadena + '''';

  Result := cadena;
end;
// -------------------------------------------------------------------------------------
//fils the "list" TStrings with the subdirectories of the "directory" directory
 procedure GetSubDirectories(const directory : string; list : TStrings) ;
 var
   sr : TSearchRec;
 begin
   try
     if FindFirst(IncludeTrailingPathDelimiter(directory) + '*.*', faDirectory, sr) < 0 then
       Exit
     else
     repeat
       if ((sr.Attr and faDirectory <> 0) AND (sr.Name <> '.') AND (sr.Name <> '..')) then
         List.Add(IncludeTrailingPathDelimiter(directory) + sr.Name) ;
     until FindNext(sr) <> 0;
   finally
     FindClose(sr) ;
   end;
 end;
// -------------------------------------------------------------------------------------
procedure FindAll (const Path: String; Attr: Integer; List: TStrings);
var
   Res: TSearchRec;
   EOFound: Boolean;
begin
   EOFound:= False;
   if FindFirst(Path, Attr, Res) < 0 then
     exit
   else
     while not EOFound do begin
       List.Add(Res.Name) ;
       EOFound:= FindNext(Res) <> 0;
     end;
   FindClose(Res) ;
end;



// -------------------------------------------------------------------------------------
// esta fn. agrega slashes a la cadena
function AddSlash(const value : String) : String;
var
  cadena : String;
begin
  cadena := value;
  cadena := StringReplace(cadena, '\', '\\', [rfReplaceAll, rfIgnoreCase]);
  cadena := StringReplace(cadena, #39, '\'+#39, [rfReplaceAll, rfIgnoreCase]);
  Result := cadena;
end;

// -------------------------------------------------------------------------------------
// retorna un arreglo con los numeros de cliente leidos desde un directorio base
procedure getClientesByDir();
var
  i : integer;
  lstFiles : TStringList;

begin

    lstFiles := TStringList.Create;

    GetSubDirectories(DEFAULT_IDIR, lstFiles);
    SetLength(Clientes, lstFiles.Count);
    for i := 0 to lstFiles.Count - 1 Do
    begin
      //Writeln(lstFiles.Strings[i]);
      // agregar el directorio al arreglo
      Clientes[i] :=  ExtractFileName( lstFiles.Strings[i] );
    end;
    lstFiles.Free;
end;

{
// -------------------------------------------------------------------------------------
// retorna una cadena con la creacion de una tabla desde paradox
procedure CreateMysqlScript(const APath: String; const AFile: String );
var
  tblParadox : TTable;
  i, d : integer;
  FieldName : String;
  FieldType : TFieldType;
  FieldSize : integer;
//  Script : String;
  Table : string;
  MySqlType : String;
  Pos : integer;
  coma : string;
  scrInsert : string;
  fecha : TDateTime;
  AFieldValue : AnsiString;
  fieldList:string;
label
  endfunction;

begin

  // se trata de un archivo corrupto
  if(AnsiPos('_', AFile) > 0) then
    Exit;


  try
    tblParadox := TTable.Create(nil);
    tblParadox.DatabaseName := APath;
    tblParadox.TableName := AFile;
    tblParadox.Active := true;
  except
    on E : Exception do
       begin
         errors.Add('Exception class name = '+E.ClassName + ' Exception message = '+E.Message);
       end;
  end;

  // quitarle la extension
  pos := AnsiPos('.', AFile);
  if(pos > 0)
  then Table := AnsiLowerCase(Copy(AFile, 1, pos - 1))
  else Table := AnsiLowerCase(AFile);

  // leer los campos
  script.Add('DROP TABLE IF EXISTS `' + Table + '`;');
  script.Add('CREATE TABLE IF NOT EXISTS `' + Table + '`(');

  for d := 0 to tblParadox.FieldCount - 1 do
  begin
    FieldName := tblParadox.Fields[d].FieldName;
    FieldType := tblParadox.Fields[d].DataType;
    FieldSize := tblParadox.Fields[d].Size;
    case FieldType of
      ftString   : begin
        if(FieldSize > 5) then
          MySqlType := 'VARCHAR'
        else
          MySqlType := 'CHAR';
        MySqlType := MySqlType + '(' + IntToStr(FieldSize) + ')';
      end;
      ftSmallint : MySqlType := 'SMALLINT';
      ftFloat    : MySqlType := 'DECIMAL(11,2)';
      ftDate     : MySqlType := 'DATE';
    end;

    // SOLo para los casos de los campos Client y Branch
    if( AnsiUpperCase(FieldName) = 'CLIENT') OR (AnsiUpperCase(FieldName) = 'BRANCH') then
      MySqlType := 'SMALLINT UNSIGNED'
    else if( AnsiUpperCase(FieldName) = 'CONTADOR') OR (AnsiUpperCase(FieldName) = 'VentasNetas') OR (AnsiUpperCase(FieldName) = 'A') then
      MySqlType := 'TINYINT'
    else if( AnsiUpperCase(FieldName) = 'EXISTENCIA') then
      MySqlType := 'INT'
    else if( AnsiUpperCase(FieldName) = 'DIAS') OR (AnsiUpperCase(FieldName) = 'ANO') then
      MySqlType := 'SMALLINT UNSIGNED'
    else if( AnsiUpperCase(FieldName) = 'MES') OR (AnsiUpperCase(FieldName) = 'DIA') then
      MySqlType := 'TINYINT UNSIGNED';

    // AGREGAR la comita
    if(d< tblParadox.FieldCount - 1) then coma := ','
    else coma := '';
     // AGREGAR la comita

    fieldList := fieldList + '`' + FieldName + '` ' + coma;
   // script.Add('`' + FieldName + '` ' + MySqlType + coma);


    script.Add('`' + FieldName + '` ' + MySqlType + coma);
  end;
  script.Add(') ENGINE = MyISAM;');
  script.Add('');




  // ------------------------------------------------------------------------------------
  // crear los inserts
  while (NOT tblParadox.Eof) do
  begin
  registros := registros+1;
    scrInsert := 'INSERT INTO `' + Table + '`(' + fieldList + ') VALUES(';
    for i := 0 to tblParadox.FieldCount - 1 do
    begin
      if(i > 0) then scrInsert := scrInsert + ', ';
      FieldName := tblParadox.Fields[i].FieldName;
      // si es una fecha cmbiar el formato a yyyy/mm/dd
      if(tblParadox.Fields[i].DataType = ftDate) then
      begin
        fecha := tblParadox.FieldByName(FieldName).AsDateTime;
        AFieldValue := FormatDateTime('yyyy/mm/dd', fecha);
      end else
        AFieldValue := tblParadox.FieldByName(FieldName).AsAnsiString;

      scrInsert := scrInsert + QuotedField(AddSlash(AFieldValue));
    end; // for fields
    scrInsert := scrInsert + ');';
    script.Add(scrInsert);
    tblParadox.Next;
  end; // while records
  tblParadox.Close;
  tblParadox.Free;
  endfunction:

end; // CreateMysqlScript
}



// -------------------------------------------------------------------------------------
// crea un archivo de texto con el nombre del cliente + .sql
// que contiene la creacion del script
procedure ProcesoCliente(const dir: String; const PdxFile: String);
var
  i : integer;
  tblParadox : TTable;
  a, d : integer;
  FieldName : String;
  FieldType : TFieldType;
  FieldSize : integer;
//  Script : String;
  Table : string;
  MySqlType : String;
  Pos : integer;
  coma : string;
  scrInsert : string;
  fecha : TDateTime;
  AFieldValue : AnsiString;
  fieldList:string;
   SQLFile : TextFile;
label
  endfunction;
begin

  // quitarle la extension
  pos := AnsiPos('.', PdxFile);
  if(pos > 0)
  then Table := AnsiLowerCase(Copy(PdxFile, 1, pos - 1))
  else Table := AnsiLowerCase(PdxFile);

     Writeln(VK_TAB + Table +' -> '+ DEFAULT_ODIR+Table+'.SQL');

//Aqui abro el archivo en el cual voy a meter el texto
 AssignFile(SQLFile, DEFAULT_ODIR+Table+'.SQL');
 ReWrite(SQLFile);

    // guardar el script en el archivo
    // limpiar el script para el siguinte cliente
      if(PdxFile = '') then ;
      Writeln('->'+PdxFile+'<-');
      registros :=0;
       WriteLn(SQLFile,'CREATE DATABASE IF NOT EXISTS `dwh`;');
       WriteLn(SQLFile,'USE `dwh`;');
      //CreateMysqlScript(dir, PdxFile);
      //Pongo aqui el Create SQL con el fin de contruir el Insert en la misma funcion


  // se trata de un archivo corrupto
  if(AnsiPos('_', PdxFile) > 0) then
    Exit;


  try
    tblParadox := TTable.Create(nil);
    tblParadox.DatabaseName := dir;
    tblParadox.TableName := PdxFile;
    tblParadox.Active := true;
  except
    on E : Exception do
       begin
         errors.Add('Exception class name = '+E.ClassName + ' Exception message = '+E.Message);
       end;
  end;


  // leer los campos
  WriteLn(SQLFile,'DROP TABLE IF EXISTS `' + Table + '`;');
  WriteLn(SQLFile,'CREATE TABLE IF NOT EXISTS `' + Table + '`(');

  for d := 0 to tblParadox.FieldCount - 1 do
  begin
    FieldName := tblParadox.Fields[d].FieldName;
    FieldType := tblParadox.Fields[d].DataType;
    FieldSize := tblParadox.Fields[d].Size;
    case FieldType of
      ftString   : begin
        if(FieldSize > 5) then
          MySqlType := 'VARCHAR'
        else
          MySqlType := 'CHAR';
        MySqlType := MySqlType + '(' + IntToStr(FieldSize) + ')';
      end;
      ftSmallint : MySqlType := 'SMALLINT';
      ftFloat    : MySqlType := 'DECIMAL(11,2)';
      ftDate     : MySqlType := 'DATE';
    end;

    // SOLo para los casos de los campos Client y Branch
    if( AnsiUpperCase(FieldName) = 'CLIENT') OR (AnsiUpperCase(FieldName) = 'BRANCH') then
      MySqlType := 'SMALLINT UNSIGNED'
    else if( AnsiUpperCase(FieldName) = 'CONTADOR') OR (AnsiUpperCase(FieldName) = 'VentasNetas') OR (AnsiUpperCase(FieldName) = 'A') then
      MySqlType := 'TINYINT'
    else if( AnsiUpperCase(FieldName) = 'EXISTENCIA') then
      MySqlType := 'INT'
    else if( AnsiUpperCase(FieldName) = 'DIAS') OR (AnsiUpperCase(FieldName) = 'ANO') then
      MySqlType := 'SMALLINT UNSIGNED'
    else if( AnsiUpperCase(FieldName) = 'MES') OR (AnsiUpperCase(FieldName) = 'DIA') then
      MySqlType := 'TINYINT UNSIGNED';

    // AGREGAR la comita
    if(d< tblParadox.FieldCount - 1) then coma := ','
    else coma := '';
     // AGREGAR la comita

    fieldList := fieldList + '`' + FieldName + '` ' + coma;
   // script.Add('`' + FieldName + '` ' + MySqlType + coma);


    WriteLn(SQLFile,'`' + FieldName + '` ' + MySqlType + coma);
  end;
  WriteLn(SQLFile,') ENGINE = MyISAM;');
  WriteLn(SQLFile,'');




  // ------------------------------------------------------------------------------------
  // crear los inserts
  while (NOT tblParadox.Eof) do
  begin
  registros := registros+1;
    scrInsert := 'INSERT INTO `' + Table + '`(' + fieldList + ') VALUES(';
    for a := 0 to tblParadox.FieldCount - 1 do
    begin
      if(a > 0) then scrInsert := scrInsert + ', ';
      FieldName := tblParadox.Fields[a].FieldName;
      // si es una fecha cmbiar el formato a yyyy/mm/dd
      if(tblParadox.Fields[a].DataType = ftDate) then
      begin
        fecha := tblParadox.FieldByName(FieldName).AsDateTime;
        AFieldValue := FormatDateTime('yyyy/mm/dd', fecha);
      end else
        AFieldValue := tblParadox.FieldByName(FieldName).AsAnsiString;

      scrInsert := scrInsert + QuotedField(AddSlash(AFieldValue));
    end; // for fields
    scrInsert := scrInsert + ');';
    WriteLn(SQLFile,scrInsert);
    tblParadox.Next;
  end; // while records
  tblParadox.Close;
  tblParadox.Free;
  endfunction:
//Termino SQL INSERT


  // Close the file
  CloseFile(SQLFile);

end;

constructor TMiThread.Create;
begin
  inherited Create(FALSE);
  // Aqui le indicamos que cuando la ejecucion del thread termine
  // debe liberar el objeto TMithread
  FreeOnTerminate:= TRUE;
end;

procedure TMiThread.Execute;
var
i:Integer;
begin
  repeat
    Beep;
    Writeln('Entra'+thdirs[thidnext]+thPdxFilses[thidnext]);

   ProcesoCliente(thdirs[thidnext], thPdxFilses[thidnext]);
    // Siempre que tengamos un bucle de este tipo, es conveniente usar algún
    // retardo para no abusar de la CPU. A lo mejor en tu código no es necesario.
   // Sleep(1000);
    thidnext:=thidnext+1;
  until Terminated;
end;
 {
function DoThread(Parameter : Pointer) : Integer;
begin
  // Set up a 0 return value
  Result := 0;

  // Map the pointer to the passed data
  // Note that each thread has a separate copy of msgPtr
  msgPtr := Parameter;

  // crear el thread
  // dormimos el thread por 3 segundos simulando
  // el proceso que tendrias que hacer por debajo del agua
  Writeln('Entra'+msgPtr.dir+msgPtr.PdxFile);

   ProcesoCliente(msgPtr.dir, msgPtr.PdxFile);
  msgPtr.fin := True;
  EndThread(0);
  //Application.ProcessMessages;
end;
}

// -------------------------------------------------------------------------------------
// crea un archivo de texto con el nombre del cliente + .sql
// que contiene la creacion del script
procedure ProcessCliente(const Cliente: String);
var
  ScrFileName : String;
  i : integer;
  APdxFile, PdxFile : String;
  thdir, thpath, lstFiles : TStringList;
  dir : string;
  id1 : LongWord;
  pi, Pos : integer;
  AFile:string;
  Table:string;
  MiThread: TMiThread;
begin
    lstFiles := TStringList.Create;
    thdir := TStringList.Create;
    thpath := TStringList.Create;
    MiThread:= TMiThread.Create;
    // DIR
    // leer todos los archivos de paradox del directorio de este cliente
    dir := DEFAULT_IDIR ;
    FindAll( dir + '*.DB', faAnyFile, lstFiles);
    for i := 0 to lstFiles.Count - 1 Do
    begin
      PdxFile := lstFiles.Strings[i];

      if(PdxFile = '') then Continue;
      Writeln(VK_TAB + PdxFile);
      // ProcesoCliente(dir, PdxFile);         //Remplazado por Thread

             thdir.Add(dir);
             thpath.Add(PdxFile);


    end;
    thdirs := thdir;
    thPdxFilses := thpath;
    MiThread.Execute;
    thdirs.Free;
    thPdxFilses.Free;
    lstFiles.Free;
end;


// -------------------------------------------------------------------------------------
// MAIN
begin

  Writeln('Programa que genera scripts basados en tablas de Paradox a Mysql');
  try
    errors := TStringList.Create;

    { TODO -oUser -cConsole Main : Insert code here }
    // obtner los archivos en el directorio que se pasa como parametro
    if(ParamCount < 1) then
    begin
      // no indico parametros entonces poner valores por defecto.
      // en este caso buscar todos los numeros de clientes, los cuales se obtienen de los
      // directorios de los clientes ubicados en C:\SD\DB
     // getClientesByDir();
    end
    else begin
      SetLength(Clientes, ParamCount);
      for index := 1 to ParamCount do
        Clientes[index-1] := ParamStr(index);
    end;

    // procesar cada cliente

  //    Writeln('Procesando cliente: ' + Clientes[index]);
      ProcessCliente('Clients');

  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;

  errors.SaveToFile(DEFAULT_ODIR + 'pdxstruct_errors.log');
  errors.Free;
    //         end;

end.

Casimiro Noteví · #6 04-11-2012

Cita:

Empezado por goedecke

Resulta que los TListString solo soportan 150,000 Lineas y yo estoy manejando en ciertos archivos mas de 1 Millon de registros

Hombre, tenías que haber empezado contando eso, no es que tenga un límite de 150000 líneas, es que realmente te estabas quedando sin memoria RAM, eso no es un fallo

Pero a quién se le ocurre meter un millón de registros en memoria RAM.
Normal que en un fichero en disco puedas guardarlas todas, teniendo espacio en el disco puedes guardar todas las que quieras, aunque lo que no entiendo es para qué lees de un fichero de texto y luego lo guardas en otro

Temas Similares
Tema	Autor	Foro	Respuestas	Último mensaje
problemas con Hilos (Thread)	jmlifi	Varios	2	26-02-2007 15:29:21
Problemas con Memoria Externa	santi33a	Windows	3	09-01-2007 23:43:55
Thread bendito thread...se me pierde la ventana	Seba.F1	API de Windows	5	02-02-2006 00:16:30
Problemas con la memoria de windows	escullar	Varios	7	08-07-2005 14:42:47
Problemas con memoria de windows	mar646	Varios	0	22-03-2005 09:30:38