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\'; 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;
function QuotedField(const field : String) : String;
var
cadena : String;
begin
cadena := field;
if(field = '') or (field = 'NULL') then
cadena := 'null'
else
cadena := '''' + cadena + '''';
Result := cadena;
end;
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;
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;
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
Clientes[i] := ExtractFileName( lstFiles.Strings[i] );
end;
lstFiles.Free;
end;
procedure CreateMysqlScript(const APath: String; const AFile: String );
var
tblParadox : TTable;
i, d : integer;
FieldName : String;
FieldType : TFieldType;
FieldSize : integer;
Table : string;
MySqlType : String;
Pos : integer;
coma : string;
scrInsert : string;
fecha : TDateTime;
AFieldValue : AnsiString;
fieldList:string;
label
endfunction;
begin
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;
pos := AnsiPos('.', AFile);
if(pos > 0)
then Table := AnsiLowerCase(Copy(AFile, 1, pos - 1))
else Table := AnsiLowerCase(AFile);
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;
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';
if(d< tblParadox.FieldCount - 1) then coma := ','
else coma := '';
fieldList := fieldList + '`' + FieldName + '` ' + coma;
script.Add('`' + FieldName + '` ' + MySqlType + coma);
end;
script.Add(') ENGINE = MyISAM;');
script.Add('');
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;
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; scrInsert := scrInsert + ');';
script.Add(scrInsert);
tblParadox.Next;
end; tblParadox.Close;
tblParadox.Free;
endfunction:
end;
procedure ProcesoCliente(const dir: String; const PdxFile: String);
var
i : integer;
Pos : integer;
Table:string;
begin
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);
FreeOnTerminate:= TRUE;
end;
procedure TMiThread.Execute;
var
i:Integer;
begin
repeat
Beep;
Writeln('Entra'+thdirs[thidnext]+thPdxFilses[thidnext]);
ProcesoCliente(thdirs[thidnext], thPdxFilses[thidnext]);
thidnext:=thidnext+1;
until Terminated;
end;
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 := 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);
thdir.Add(dir);
thpath.Add(PdxFile);
end;
thdirs := thdir;
thPdxFilses := thpath;
MiThread.Execute;
thdirs.Free;
thPdxFilses.Free;
lstFiles.Free;
end;
begin
Writeln('Programa que genera scripts basados en tablas de Paradox a Mysql');
try
script := TStringList.Create;
errors := TStringList.Create;
if(ParamCount < 1) then
begin
end
else begin
SetLength(Clientes, ParamCount);
for index := 1 to ParamCount do
Clientes[index-1] := ParamStr(index);
end;
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.