Buscar por:

Importa Excel com Delphi

Código

//Insira os seguintes componentes no form:

//ADOConnection, Name:ADOConn

//ADOQuery, Name:ADOQuery

unit Importa;

//OPenDialog, Name:DSelecionaArquivo, Filter:Excel|*.xls

//Edit, Name:EArquivo

//ListBox, Name:DListaPasta

//Botão, name:bSelecionaArquivo, Caption: Selecina

//Botão, Name:BImportar, Caption:Importar

//Botão, Name:BSair, Caption:Sair

interface

uses

  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

  Dialogs, Comobj, StdCtrls, DB, ADODB, Buttons, ExtCtrls, Registry, Printers, Grids,

  Math, ShlObj, ActiveX, DateUtils, ClipBrd, Shellapi, Winsock, Tlhelp32;

type

  TForm1 = class(TForm)

    eArquivo: TEdit;

    btnArquivo: TButton;

    ADOConn: TADOConnection;

    ADOQuery: TADOQuery;

    DSelecionaArquivo: TOpenDialog;

    DListaPasta: TListBox;

    Label1: TLabel;

    btnImportar: TButton;

    btnSair: TButton;

    Label2: TLabel;

    procedure btnArquivoClick(Sender: TObject);

    procedure btnImportarClick(Sender: TObject);

    procedure DListaPastaClick(Sender: TObject);

    procedure btnSairClick(Sender: TObject);

  private

    { Private declarations }

  public

    { Public declarations }

  end;

var

  Form1: TForm1;

implementation

{$R *.dfm}

var

  Excel, Sheet: OleVariant;

  caminho, Planilha, pasta, teste: string;

  i: Integer;

  arq: TextFile;

  //função pra remover aspas simples

function RemoveChar(Texto: string; CHR: char): string;

var

  cont: integer;

begin

  Result := '';

  for cont := 1 to Length(Texto) do

    begin

      if (Texto[cont] <> CHR) then

        Result := Result + Texto[cont];

    end;

end;

//retira caracteres especiais $

function RetiraChar(s: string): string; // Retira caracteres $:

var

  i: integer;

  a: string;

begin

  Result := '';

  for i := 1 to length(s) do

    begin

      a := copy(s, i, 1);

      if (a <> '$') then

        begin

          result := Result + a;

        end;

    end;

end;

function IniciaDirArq(dirNome: string; arqNome: string): string;

// Cria diretorio na pasta raiz do sistema

begin

  pasta := ExtractFilePath(Application.ExeName) + '' + dirNome + '';

  CreateDirectory(PAnsiChar(pasta), nil);

  pasta := pasta + arqNome;

  AssignFile(arq, pasta);

  Rewrite(arq);

end;

function Esquerda(valor: string; T: integer): string;

// Acresenta zeros em uma string a esquerda

begin

  while length(valor) < T do

    valor := ' ' + valor;

  Esquerda := valor;

end;

//Finaliza processo do excel

function Fecha_exe(ExeFileName: string): Integer;

const

  PROCESSSO_FINALIZA = $0001;

var

  ContinuaLoop: BOOL;

  FAquivo: THandle;

  FProcessoEntrada: TProcessEntry32;

begin

  Result := 0;

  FAquivo := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);

  FProcessoEntrada.dwSize := SizeOf(FProcessoEntrada);

  ContinuaLoop := Process32First(FAquivo, FProcessoEntrada);

  while Integer(ContinuaLoop) <> 0 do

    begin

      if ((UpperCase(ExtractFileName(FProcessoEntrada.szExeFile)) =

        UpperCase(ExeFileName)) or (UpperCase(FProcessoEntrada.szExeFile) =

        UpperCase(ExeFileName))) then

        Result := Integer(TerminateProcess(

          OpenProcess(PROCESSSO_FINALIZA,

          BOOL(0), FProcessoEntrada.th32ProcessID), 0));

      ContinuaLoop := Process32Next(FAquivo, FProcessoEntrada);

    end;

  CloseHandle(FAquivo);

end;

procedure TForm1.btnArquivoClick(Sender: TObject);

var

  strConn: string;

begin

  DSelecionaArquivo.Execute;

  eArquivo.Text := DSelecionaArquivo.FileName;

  caminho := eArquivo.Text;

  //chama conexão OLE com excel

  strConn := 'Provider=Microsoft.Jet.OLEDB.4.0;Data Source=' + DSelecionaArquivo.FileName +

    ';Extended Properties=Excel 8.0;Persist Security Info=False';

  ADOConn.Connected := False;

  ADOConn.ConnectionString := strConn;

  ADOConn.Open;

  ADOConn.GetTableNames(DListaPasta.Items, True);

  ADOConn.Close;

end;

procedure TForm1.btnImportarClick(Sender: TObject);

begin

  if Trim(caminho) <> '' then

    begin

      try

        Excel := CreateOleObject('Excel.Application');

        Excel.WorkBooks.Open(caminho);

        Excel.Visible := false;

        Sheet := Excel.Workbooks[1].WorkSheets[planilha];

      except

        ShowMessage('Ocorreu um erro ao abrir o arquivo.');

        EArquivo.SetFocus;

      end;

    end;

  IniciaDirArq('Importado', 'ImportadodoExcel.txt');

  i := 2;

  teste := Sheet.Cells[I, 1];

  while Sheet.Cells[I, 1].Value <> '' do

    begin

      Write(arq,

        Esquerda(Sheet.Cells[I, 1], 50) + //Código

        Esquerda(Sheet.Cells[I, 2], 10) + //Ano/Modelo

        Esquerda(Sheet.Cells[I, 3], 5) + //Revisão

        Esquerda(Sheet.Cells[I, 4], 50) + //Trocas

        Esquerda(Sheet.Cells[I, 5], 3) + //TM

        Esquerda(Sheet.Cells[I, 6], 20) + //Referência

        Esquerda(Sheet.Cells[I, 7], 6) + //Qtde

        Esquerda(Sheet.Cells[I, 8], 10) + //PCL

        Esquerda(Sheet.Cells[I, 9], 10) + //C Impo

        Esquerda(Sheet.Cells[I, 10], 10) + //C arred)

        CHR(13) + CHR(10));

      i := i + 1;

    end;

  CloseFile(arq);

  if Sheet.Cells[2, 1].Value = '' then

    begin

      ShowMessage('Arquivo vazio. Nem um dados Importado!')

    end;

  Fecha_exe('excel.exe');

end;

procedure TForm1.DListaPastaClick(Sender: TObject);

begin

  //pega o nome da sheet do excel e limpa os caracteres

  planilha := RemoveChar(RetiraChar(DListaPasta.Items.Strings[DListaPasta.ItemIndex]), #39);

end;

procedure TForm1.btnSairClick(Sender: TObject);

begin

  Fecha_exe('excel.exe');

  close;

end;

end.