Option Explicit
Public Enum eTGrilla
[DataGrid] = 1
[MSHFlexGrid] = 2
[MSFlexGrid] = 3
End Enum
Public Function mFn_GrillaToXls(ObjGrilla As Object, _
TipoGRilla As eTGrilla, _
Optional IniFillGrilla As Long = -1, _
Optional IniColGrilla As Long = -1, _
Optional FinFillGrilla As Long = -1, _
Optional FinColGrilla As Long = -1, _
Optional IniFillXls As Long = 1, _
Optional FinColXls As Long = 1, _
Optional FullPathNameFileXLS As String = "Archivo.xls", _
Optional NameSheet As String = "Hoja") As Boolean
'***********************************************************************************
'* Funcion que Migra de Una grilla a un archivo de Excel
'***********************************************************************************
' variables Excel
Dim xlsApli As Excel.Application
Dim xlsWorkB As Excel.Workbook
Dim xlsSheet As Excel.Worksheet
'Variables Locales
Dim Columna As Long
Dim Fila As Long
'Fin de Variables
Set xlsApli = New Excel.Application
Set xlsApli = CreateObject("Excel.Application")
Set xlsWorkB = xlsApli.Workbooks.Add
Set xlsSheet = xlsWorkB.Worksheets.Add
If FullPathNameFileXLS = "Archivo.xls" Then FullPathNameFileXLS = App.Path & "\" & FullPathNameFileXLS
xlsSheet.Name = NameSheet
mFn_GrillaToXls = False
On Local Error GoTo GrillaToXlsError
For Fila = IIf(InicioFila = -1, ObjGrilla.FixedRows - 1, InicioFila) To IIf(FinalFila = -1, ObjGrilla.FixedRows - 1, FinalFila)
For Columna = IIf(InicioColumna = -1, ObjGrilla.FixedCols - 1, InicioColumna) To IIf(FinalColumna = -1, ObjGrilla.FixedCols - 1, FinalColumna)
Select Case eTGrilla
Case MSHFlexGrid Or MSFlexGrid
xlsSheet.Cells(IniFillXls, FinColXls) = ObjGrilla.TextMatrix(Fila, Columna)
Case DataGrid
ObjGrilla.Col = Columna
ObjGrilla.Row = Fila
xlsSheet.Cells(IniFillXls, FinColXls) = ObjGrilla.Text
End Select
FinColXls = FinColXls + 1
Next Fila
IniFillXls = IniFillXls + 1
Next Fila
xlsWorkB.SaveAs FullPathNameFileXLS
xlsWorkB.Close
xlsApli.Quit
mFn_GrillaToXls = True
Exit Function
GrillaToXlsError:
MsgBox Err.Number & " : " & Err.Description
End Function