Visual Basic - Visual Basic 6 en windows 10 y office 2016

Private Sub Cmd_Importar_Click()

Dim objXLApp As Excel.Application

Dim intLoopCounter As Integer

Dim Fila As Integer

Dim Tubo As String, RangoI As String, AnimalL1 As String, AnimalL2 As String, Animal As String, NombreCat As String

Dim AnimalN As Long, Categoria As Integer, CargaError As Integer, MError As Integer

Dim NFilaA As String

    'mouse aviso que trabaja

  On Error GoTo err_handler

    Frm_BArchivo.MousePointer = vbHourglass

    CargaError = 0

    MError = 0

    NFilaA = ""

    If Trim(Lbl_Ruta.Caption) = "" Then

        Mensaje = MsgBox("No ha especificado la ruta del Archivo a Importar.", 64, "INFORMACIÓN AL USUARIO")

        Exit Sub

    End If

    If Mid(Lbl_Ruta.Caption, Len(Lbl_Ruta.Caption) - 2) = "xls" Or Mid(Lbl_Ruta.Caption, Len(Lbl_Ruta.Caption) - 3) = "xlsx" Then

        CadenaRuta = Lbl_Ruta.Caption

        'Abro archivo Excel

        Set objXLApp = CreateObject("Excel.Application")

        'Set objXLApp = New Excel.Application

        With objXLApp

            .Workbooks.Open CadenaRuta

            .Workbooks(1).Worksheets(1).Select

            'Grd_Carga.Rows = CInt(.ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row) + 1

            For intLoopCounter = 2 To Frm_CargaAnimalesP!Grd_Animales.Rows

                Fila = intLoopCounter - 1

                Tubo = CLng(.Range("A" & intLoopCounter)) 'Tubo

                RangoI = .Range("B" & intLoopCounter) 'Clasificación

            Next intLoopCounter

            .Workbooks(1).Close False

            .Quit

        End With

        Set objXLApp = Nothing

        Frm_BArchivo.MousePointer = 0

        If MError = 1 Then

            Mensaje = MsgBox("Algunos animales no se cargaron por no cumplir las condiciones solicitadas." & Chr(13) & "Corresponden a las filas:" & NFilaA & " del archivo de Excel.", 64, "INFORMACIÓN AL USUARIO")

        End If

        Else

        Mensaje = MsgBox("No ha seleccionado un archivo con extensión xls o xlsx." & Chr(13) & "Intentelo nuevamente.", 64, "INFORMACIÓN AL USUARIO")

        Exit Sub

    End If

    Unload Me

err_handler:

   MsgBox "The code failed at line " & Erl & err.Description, vbCritical

End Sub

'Declarar objetos

Dim xls             As Object

Dim xlssheet        As Object

Dim xlswbook        As Object

Dim MLng1	    As Long

'Instanciar objetos

    Set xls = CreateObject("Excel.Application")

    Set xlswbook = xls.Workbooks.Add

        xls.Visible = True

    Set xlssheet = xlswbook.Sheets.Item(1)

    MLng1 = 1&

    xlssheet.Cells(MLng1, 1) = "RFC"

    xlssheet.Cells(MLng1, 2) = "CURP"

    xlssheet.Cells(MLng1, 3) = "NOM_EMP"

    xlssheet.Cells(MLng1, 4) = "CONCEPTO"

    xlssheet.Cells(MLng1, 5) = "IMPORTE"

    xlssheet.Cells(MLng1, 6) = "PERIODO"

    xlssheet.Cells(MLng1, 7) = "TMOV"

'Desinstanciar objetos

    Set xlssheet = Nothing

    Set xlswbook = Nothing

    Set xls      = Nothing