Esta unidad forma parte de un programa mucho mas extenso. Es por ello que algunos objetos no los tendras, pero lo puedes adaptar a lo que quieras y te dá las claves para realizar dicha exportación.
Código Delphi
[-]
unit ExportaXLS;
interface
Uses Grids;
procedure ExportarXLS(const Tabla : TStringGrid; const Fichero : String);
implementation
uses ComObj, Graphics, CARATULAS, Dlg_MensajeTransaccion,
Configuracion, SysUtils, StrUtils, UtilidadSTR, UtilidadFiles;
procedure ExportarXLS(const Tabla : TStringGrid; const Fichero : String);
label Comienza;
const xlCenter = $FFFFEFF4;
xlJustify = $FFFFEFDE;
xlBottom = $FFFFEFF5;
xlLeft = $FFFFEFDD;
xlRight = $FFFFEFC8;
xlTop = $FFFFEFC0;
var
Excel, WorkBook, WorkSheet, Range : Variant;
RangoIni, RangoFin : string;
F, C : Integer; Row : Integer; ConPrecios : Boolean; procedure FuenteParaLaHoja(const NomFuente : string; TamFuente : Integer);
begin
RangoIni:='A1';
RangoFin:='E'+IntToStr(Tabla.RowCount+6);
Range:=WorkSheet.Range[RangoIni,RangoFin];
Range.Font.Name:=NomFuente;
Range.Font.Size:=TamFuente;
end;
procedure PonCabecera;
var
c : Integer;
begin
RangoIni:='A'+IntToStr(F);
RangoFin:='E'+IntToStr(F);
Range:=WorkSheet.Range[RangoIni,RangoFin];
Range.Font.Size:=12; Range.Font.Bold:=True; Range.Font.Underline:=True; Range.Interior.Color:=clSilver; Range.VerticalAlignment:=xlTop;
Range.HorizontalAlignment:=xlCenter;
for C:=1 to Tabla.ColCount do
WorkSheet.Cells[F, C]:=Tabla.Cells[C-1,0];
end;
procedure FormatoConcepto;
var
Celda : string;
begin
WorkSheet.Cells[F, C]:=Tabla.Cells[C-1,Row];
Celda:=Tabla.Cells[C-2,Row];
if (Pos('*',Celda)>0)Or(Pos('@',Celda)>0) then
Begin WorkSheet.Cells[F, C].Font.Bold:=True; if Pos('@',Celda)>0 then WorkSheet.Cells[F, C].Font.Color:=clGreen else WorkSheet.Cells[F, C].Font.Color:=clBlue; if Pos('**',Celda)>0 then begin
WorkSheet.Cells[F, C].VerticalAlignment := xlBottom;
WorkSheet.Cells[F, C].HorizontalAlignment:=xlRight;
end
end;
end;
procedure FormatoTotal;
var
Celda : string;
begin
Celda:=Tabla.Cells[C-4,Row];
if Pos('*',Celda)>0 then WorkSheet.Cells[F, C].Font.Bold:=True; if (Config.Impresora.Total)and(Pos('***',Celda)>0) then WorkSheet.Cells[F, C]:=Tabla.Cells[C-1,Row]
Else
if (Config.Impresora.SubTotales)and(Celda='**') then WorkSheet.Cells[F, C]:=Tabla.Cells[C-1,Row]
else
if (Celda='*')and(Config.Impresora.Total) then WorkSheet.Cells[F, C]:=Tabla.Cells[C-1,Row]
else
if Config.Impresora.Totales then WorkSheet.Cells[F, C]:=Tabla.Cells[C-1,Row];
end;
var
Dir, FileTemp : string;
begin
ConPrecios:=ConfirmaPregunta('¿ PONER PRECIOS A LA HOJA DE CÁLCULO?' )=0;
try
Excel := CreateOleObject('Excel.Application');
Workbook := Excel.Workbooks.Add(-4167);
WorkSheet := WorkBook.WorkSheets[1]; WorkSheet.Name := 'PRESUPUESTO';
FuenteParaLaHoja('Arial',10);
F:=2; WorkSheet.Cells[F, 1].ColumnWidth:=9; WorkSheet.Cells[F, 2].ColumnWidth:=7; WorkSheet.Cells[F, 3].ColumnWidth:=90; WorkSheet.Cells[F, 4].ColumnWidth:=14; WorkSheet.Cells[F, 5].ColumnWidth:=16;
C:=3; WorkSheet.Cells[F, C]:='PRESUPUESTO Nº : '+Caratula.LabeledEdit1.Text;
WorkSheet.Cells[F, C].Font.Size:=14; WorkSheet.Cells[F, C].Font.Bold:=True; WorkSheet.Cells[F, C].Font.Color:=clRed; WorkSheet.Cells[F, C].Font.Underline:=True; Inc(F,2);
WorkSheet.Cells[F, C]:='Ref. : '+Caratula.LabeledEdit2.Text;
WorkSheet.Cells[F, C].Font.Size:=12; WorkSheet.Cells[F, C].Font.Color:=clBlue; WorkSheet.Cells[F, C].VerticalAlignment:=xlTop; WorkSheet.Cells[F, C].HorizontalAlignment:=xlJustify;
Inc(F,2);
C:=1;
PonCabecera;
Inc(F);
WorkSheet.Cells[F,1].Select; Excel.ActiveWindow.FreezePanes := True;
RangoIni:='A'+IntToStr(F);
RangoFin:='A'+IntToStr(F+Tabla.RowCount);
Range:=WorkSheet.Range[RangoIni,RangoFin];
Range.VerticalAlignment:=xlTop;
Range.HorizontalAlignment:=xlCenter;
Range.NumberFormat:='###.###,##';
RangoIni:='B'+IntToStr(F);
RangoFin:='B'+IntToStr(F+Tabla.RowCount);
Range:=WorkSheet.Range[RangoIni,RangoFin];
Range.VerticalAlignment:=xlTop;
Range.HorizontalAlignment:=xlCenter;
RangoIni:='C'+IntToStr(F);
RangoFin:='C'+IntToStr(F+Tabla.RowCount);
Range:=WorkSheet.Range[RangoIni,RangoFin];
Range.VerticalAlignment:=xlTop;
Range.HorizontalAlignment:=xlLeft;
Range.WrapText:=True;
RangoIni:='D'+IntToStr(F);
RangoFin:='E'+IntToStr(F+Tabla.RowCount);
Range:=WorkSheet.Range[RangoIni,RangoFin];
Range.VerticalAlignment:=xlBottom;
Range.HorizontalAlignment:=xlRight;
Range.WrapText:=True; Range.NumberFormat:='###.###,## €';
DlgTransaccion.Barra.ValorMax:=Tabla.RowCount;
DlgTransaccion.Show;
for Row:=1 To Tabla.RowCount-1 do
begin
DlgTransaccion.Barra.Progress:=Row;
C:=1; WorkSheet.Cells[F, C]:=AnsiReplaceStr(Tabla.Cells[C-1,Row],'.','');
C:=2; WorkSheet.Cells[F, C]:= Tabla.Cells[C-1,Row];
C:=3; FormatoConcepto; if ConPrecios then begin
C:=4; if Config.Impresora.Pu then
WorkSheet.Cells[F, C]:=Tabla.Cells[C-1,Row];
C:=5; FormatoTotal;
end;
Inc(F);
end;
DlgTransaccion.Close; try Dir:=ExtractFilePath(Fichero);
FileTemp:=DameFicheroTemp(Dir,'EXPORTACION PRESUPUESTO','.XLS');
WorkBook.SaveAs(FileTemp);
Excel.Quit;
if not CopiaFichero(FileTemp,Fichero) then
MensageError('No se pudo copiar el fichero :'#13+Fichero);
BorraFichero(FileTemp); except Excel.Quit;
DlgTransaccion.Close;
Exit;
end;
finally DlgTransaccion.Close;
Excel.Quit;
end
end;
end.
Espero que sea de ayuda.
Adjunto fichero.