Table - criando e alterando estrutura

Top Previous Next

{

Unit com funcoes e rotinas para CRIAR/ALTERAR estruturas de arquivos DBase

para funcionar é necessário um componentes DQuery (TQuery com alguns recursos adicionais)

e também as funções de ARotinas e ARotinas2

Autor Irresponsável: Flávio Junior

1º Release : 30 de maio de 2001

Qualquer bug envie um email para vai@para.boston.com.br

>\\\!/<

!_"""_!

(O) (o)

------ooo-----ooo------------------------------------------------------------------------}

unit DBRotinas;

interface

// fazem parte da AlterStru:

procedure InsereCampo(const Nome: string; const Tipo: char; const Tamanho, Decimais: Byte);

procedure LimpaCampos;

function AlterStru(const Alias, Tabela: string; LimpaMatriz: Boolean = True): Byte;

// outras rotinas para tabelas

function GetAliasPath(const Alias: string): string;

implementation

uses SysUtils, Classes, DBTables, ARotinasUnit, ARotinas2Unit, DQuery, AlterandoEstruturaUnit;

// Para pegar a estrutura de um DBF sem usar nenhuma unit, ou componente:

type

TDBFColuna = record

Nome : string;

Tipo : char;

Tamanho : Byte;

Decimais: Byte;

end;

TDBFEstrutura = record

Colunas : array[1..200] of TDBFColuna;

NumeroCampos : Byte;

RecordCount : Integer;

TamanhoRegistros: Integer;

Data : TDateTime;

end;

var

DBFEstrutura: TDBFEstrutura; // este é o da tabela.

UserCampos : TDBFEstrutura; // este é o usuario que insere.

// Captura a estrutura de um DBF

function GetStru(const ArquivoDBF: string): Boolean;

var

Header, J: Integer;

Banco : file of Char;

// vars temp

I : Longint;

St: string;

F : string[1];

// funcoes internas

// le do arquivo um ou mais NUMEROS

function LeInt(const N: Integer): Longint;

var

C: Char;

I: Integer;

L: Int64;

begin

Result := 0;

L := 1;

for I:= 1 to N do

begin

Read(Banco,C);

Result:= Result + L * Ord(C);

L:= L * 256;

end;

// le do arquivo um ou mais CHAR

function LeChar(const N: Integer): string;

var

C: Char;

I: Integer;

begin

Result:='';

for I:= 1 to N do

begin

Read(Banco, C);

Result:= Result + C;

end;

begin

Result := False;

{$I-}

AssignFile(Banco, ArquivoDBF);

Reset(Banco);

{$I+}

if IOResult <> 0 then Exit;

// o primeiro caracter do cabecalho é ignorado.

F := LeChar(1);

// pega data que foi criado a estrutura

I := LeInt(1) - 100; St := IntToStr(I);

I := LeInt(1); St := IntToStr(I) + '/' + St;

DBFEstrutura.Data := StrToDate(St);

// Pega qtd registro, tamanho dos registros e numero de campos

DBFEstrutura.RecordCount := LeInt(4);

Header:= LeInt(2);

DBFEstrutura.TamanhoRegistros := LeInt(2);

St := LeChar(20);

DBFEstrutura.NumeroCampos := Round((Header - 2) / 32) - 1;

// pega dados dos campos

with DBFEstrutura do

for J:= 1 to DBFEstrutura.NumeroCampos do

begin

St := LeChar(11);

if Pos(#0,St) > 0 then St := Copy(St, 1, Pos(#0,St)-1); // limpa sujeira

Colunas[J].Nome := UpperCase(St);

Read(Banco, DBFEstrutura.Colunas[J].Tipo );

DBFEstrutura.Colunas[J].Tipo := Upcase(DBFEstrutura.Colunas[J].Tipo);

St := LeChar(4);

Colunas[J].Tamanho := LeInt(1);

Colunas[J].Decimais := LeInt(1);

St := LeChar(14);

end;

CloseFile(Banco);

Result := True;

end;

// Insere os campos na matriz da AlterStru

procedure InsereCampo(const Nome: string; const Tipo: char; const Tamanho, Decimais: Byte);

begin

with UserCampos do

begin

Inc(NumeroCampos);

Colunas[NumeroCampos].Nome := UpperCase(Nome);

Colunas[NumeroCampos].Tipo := Upcase(Tipo);

Colunas[NumeroCampos].Tamanho := Tamanho;

Colunas[NumeroCampos].Decimais:= Decimais;

// para o AlterStru comparar corretamente, se for do tipo DATE tem que ser tamanho 8!

if Upcase(Tipo) = 'D' then

begin

Colunas[NumeroCampos].Tamanho := 8;

Colunas[NumeroCampos].Decimais:= 0;

end;

if Upcase(Tipo) = 'C' then Colunas[NumeroCampos].Decimais:= 0;

end;

// zera a matriz de campos

procedure LimpaCampos;

begin

UserCampos.NumeroCampos := 0;

end;

// Só para DBF:

// exemplo: AlterStru('Frente', 'Produtos') <--- não precisa da extensão da tabela (ele sempre põe DBF).

// retornos: ( 0 = ok, 1-2 = algo foi feito, >3 = erro!

// 0 = Nada feito, mas tudo ok.

// 1 = Tabela alterada;

// 2 = Tabela criada

// 3 = Erro no GetStru

// 4 = Erro ao criar tabela

// 5 = Erro na matriz usuário

// 6 = Não é possivel mudar tipos de campos

// 7 = Tamanho de campo invalido

function AlterStru(const Alias, Tabela: string; LimpaMatriz: Boolean = True): Byte;

var

Arquivo, Pasta, Mensagem: string;

S : string;

I, J : Integer; // usado em For's

SaoIguais: Boolean; // Define se as tabelas são iguais

BMove : TBatchMove; // BatchMove usado para a conversao

OTable, DTable: TTable; // tables usadas para conversào O = Origem, D = Destino

function CriaTabela: Byte; // foi colocado numa funcao por que era nessario chamar esta rotinas 2x

var

Query: TDQuery; // Usado para criar tabela

I : Integer;

begin

// monta o SQL:

S := 'create table "' + ChangeFileExt(Tabela, '.dbf') + '" (';

with UserCampos do

for I := 1 to NumeroCampos do

begin

S := S + Colunas[I].Nome;

case Colunas[I].Tipo of

'C': S := S + ' char(' + IntToStr(Colunas[I].Tamanho) + '),';

'N': S := S + ' decimal('+ IntToStr(Colunas[I].Tamanho) + ',' + IntToStr(Colunas[I].Decimais) + '),';

'D': S := S + ' date,';

end;

Delete(S,Length(S),1);

S := S + ')';

// cria tabela via DQuery:

Query := TDQuery.Create(nil);

Query.DatabaseName := Alias;

if Query.Execute(S) then Result := 2 else Result := 4;

Query.Free;

end;

begin

Result := 0;

if Pos('\',Alias) > 0 then Pasta := DirBarra(Alias) else Pasta := GetAliasPath( Alias );

Arquivo := ChangeFileExt(Tabela, '.dbf');

Mensagem := 'Tabela: "' + Tabela + '"; Campo: "';

S := '';

// Verifica se todos os campos estão ok...

for I := 1 to UserCampos.NumeroCampos do

begin

// tamanho não deve passar de 10 caracteres

if Length(UserCampos.Colunas[I].Nome) > 10 then S := 'Nome do campo ultrapassa 10 caracteres';

// se for CHAR deve tem tamanho minimo de 1

if (UserCampos.Colunas[I].Tipo = 'C') and

((UserCampos.Colunas[I].Tamanho > 200) or (UserCampos.Colunas[I].Tamanho < 1)) then S := 'Tamanho inválido';

// se for DECIMAL deve tem tamanho minimo de 2

if (UserCampos.Colunas[I].Tipo = 'N') then

begin

if (UserCampos.Colunas[I].Tamanho < 1) then S := 'Tamanho numérico inválido';

if (UserCampos.Colunas[I].Decimais > 0) then

if (UserCampos.Colunas[I].Tamanho - UserCampos.Colunas[I].Decimais) < 2 then S := 'Tamanho numérico inválido (decimais)';

end;

if S <> '' then

begin

msgErro(Mensagem + UserCampos.Colunas[I].Nome + '"'#13 + S);

Result := 5;

if LimpaMatriz then UserCampos.NumeroCampos := 0;

Exit;

end;

// etapa 1 - se arquivo não existe, cria um novo baseado na extrutura

if not FileExists( Pasta + Arquivo ) then

begin

Result := CriaTabela;

if LimpaMatriz then UserCampos.NumeroCampos := 0;

Exit;

end;

// etapa 2 - pega estrutura do arquivo para comparar com a matriz

if not GetStru( Pasta + Arquivo ) then

begin

Result := 3;

if LimpaMatriz then UserCampos.NumeroCampos := 0;

Exit;

end;

// etapa 3 - compara o arquivo pré-existente com a matriz se igual cai fora

SaoIguais := True;

// se o numero de campos for igual, deve verificar se existe alguma diferenca

// em ordem (uma mais pra cima ou pra baixo), ou tamanho do campo (maior ou menor)

if UserCampos.NumeroCampos = DBFEstrutura.NumeroCampos then

for I:= 1 to UserCampos.NumeroCampos do

begin

// caso 1 dos campos tenha nome, tamanho ou decimais diferentes da tabela original

// vai ter que mudar a extrutura...

if (UserCampos.Colunas[I].Nome <> DBFEstrutura.Colunas[I].Nome ) or

(UserCampos.Colunas[I].Tamanho <> DBFEstrutura.Colunas[I].Tamanho ) or

(UserCampos.Colunas[I].Decimais <> DBFEstrutura.Colunas[I].Decimais) then

SaoIguais := False; // Não faz um break aqui por causa o if abaixo que verifica se um outro campo alterou o tipo

if (UserCampos.Colunas[I].Tipo <> DBFEstrutura.Colunas[I].Tipo) and (SaoIguais) then

begin

msgErro(Mensagem + UserCampos.Colunas[I].Nome + '"'#13 + 'Não é possivel alterar o tipo de campo');

Result := 6;

Break;

end;

if Result = 6 then

begin

if LimpaMatriz then UserCampos.NumeroCampos := 0;

Exit; // tabelas iguais mas o tipo foi alterado (C => D, D => N)

end;

// etapa 4 - se o numero de campos for diferente, OU, tabelas não possuem os mesmo campos... mudar estrutura!

if (UserCampos.NumeroCampos <> DBFEstrutura.NumeroCampos) or (not SaoIguais) then

begin

// faz backups

GerenciaBackup( Pasta, Arquivo );

// cria tabela

I := CriaTabela;

if (I = 4) or (I = 5) then // 4 = erro ao criar tabela, 5 = Erro na matriz

begin

if (I = 4) then msgErro('Erro ao criar tabela ' + Tabela);

Result := I;

if LimpaMatriz then UserCampos.NumeroCampos := 0;

Exit;

end;

// cria tabelas para a transferencia de tecnologia

OTable := TTable.Create(nil); OTable.DatabaseName := Alias; OTable.TableType := ttDbase;

DTable := TTable.Create(nil); DTable.DatabaseName := Alias; DTable.TableType := ttDbase;

OTable.TableName := ChangeFileExt(Tabela, '.000'); OTable.Active := True;

DTable.TableName := ChangeFileExt(Tabela, '.dbf'); DTable.Active := True;

// batch move

BMove := TBatchMove.Create(nil);

BMove.Source := OTable;

BMove.Destination := DTable;

BMove.Mode := batAppend;

// carrega o Mappings com os campos que são iguais no origem e destino

for I := 1 to DBFEstrutura.NumeroCampos do

for J := 1 to UserCampos.NumeroCampos do

if DBFEstrutura.Colunas[I].Nome = UserCampos.Colunas[J].Nome then BMove.Mappings.Add(DBFEstrutura.Colunas[I].Nome);

// transfere...

AlterandoEstruturaForm := TAlterandoEstruturaForm.Create(nil);

with AlterandoEstruturaForm do

begin

Show;

OrigemLabel.Caption := UpperCase( OTable.TableName );

DestinoLabel.Caption := UpperCase( DTable.TableName );

DoEvents;

BMove.Execute;

// questao de visual...

Delay(1000);

if BMove.MovedCount > 0 Then

RegistroLabel.Caption := FormatFloat('#,##',BMove.MovedCount) + ' registros.'

else

RegistroLabel.Caption := 'tabela vazia';

Delay(1000);

end;

// free all objects

Result := 1;

AlterandoEstruturaForm.Free;

BMove.Free;

OTable.Free;

DTable.Free;

end;

// zera a estrutura

if LimpaMatriz then UserCampos.NumeroCampos := 0;

end;

//////////////////////////////////////// OUTRAS ROTINAS /////////////////////////////////

function GetAliasPath(const Alias: string): string;

var

Params: TStringList;

begin

Params := TStringList.Create;

Session.GetAliasParams( Alias, Params);

Result := DirBarra(Params.Values['PATH']);

Params.Free;

end;

end.