Public R As Recordset
Public conexion As New ADODB.Connection
Public k, a, tarifa As Integer
Public flag As Boolean
Public tiempo, idmy, sql, f1, f2, ssql As String
Public Rsio As New ADODB.Recordset
Public Rs As New ADODB.Recordset
Public Rsx As New ADODB.Recordset
Public Rstj As New ADODB.Recordset
Public Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Public USER, Val As String
Public NUM, idp As Integer
Public BaseImponible, BaseImponible2 As Variant
Public datafile As Variant
Public Empresa, IdEmpresa As String
Sub Main()
    Conectar
End Sub

Sub Conectar()
On Error GoTo etqerror
    conexion.Open ("dsn=dsnToXml;user id =sa;pwd=;")
    
    'MsgBox "Conexion Exitosa", vbInformation, "Conexion"
    MDIForm1.Show

    
Exit Sub

etqerror:
    MsgBox "Error de Conexion " & " - " & Err.Number & Err.Description & " - " & Err.Source, vbCritical, "ToXml - Tx"
    
End Sub




Sub NNNToXML(sql As String)

On Error GoTo etterro

Cont = 0

If Form1.chkVentas = 1 Then
FileName = App.Path & "\AT" & Form1.Calendar1.Month & Form1.Calendar1.Year & ".XML"
Else
FileName = App.Path & "\REOC" & Form1.Calendar1.Month & Form1.Calendar1.Year & ".XML"
End If

Rsio.Open sql, conexion
Rsx.Open sql, conexion

f = FreeFile


'****si no hay resultados ********
    If Rsio.EOF = True And Rsio.BOF = True Then
    MsgBox "No existen Resultados para mostrar", vbInformation, "Toxml"
    Rsio.Close
    Exit Sub
    End If
'**********************************
Rsx.MoveNext
'Encabezado del Archivo

            Open FileName For Output As f
                    datafile = "<?xml version=*1.0* encoding=*ISO-8859-1* standalone=*yes*?>"
                    
                    Print #f, Replace(datafile, "*", """")
                    Print #f, "<iva>"
                    Print #f, "   <numeroRuc>" & IdEmpresa & "</numeroRuc>"
                    Print #f, "   <razonSocial>" & Empresa & "</razonSocial>"
                    Print #f, "   <anio>" & Form1.Calendar1.Year & "</anio>"
                    Print #f, "   <mes>" & Form1.Calendar1.Month & "</mes>"
                    
'Encabezado del Archivo
'**********************************
            
Dim i, j, k As Integer
    f1 = ""
    f2 = ""
    i = 1
    k = 0
    j = Rsio.Fields.Count
          Print #f, "<compras>" 'Este es el inicio de los tags de compras
    While Not Rsio.EOF
        f1 = ""
        f2 = ""
        i = i + 1
        MsfRows = i
        k = 0
            Print #f, "  <detalleCompras>" 'Este es el inicio de los tags de Detalle compras
        'Empiezan las etiquetas
        While k < j

            Select Case Rsio.Fields(k).Name
          
            
                Case Is = "tpIdProv"
                    'ssql = "select equivalencia from parametro where tipo = 'Compra' and  etiqueta = '" & Rsio(k) & "'"
                    ssql = "select equivalencia from parametro where etiqueta = '" & Rsio(k) & "' and proceso = 'C'"
                    filedata = Equivalencia(ssql)
                    Print #f, "    " & "<" & Rsio.Fields(k).Name & ">" & filedata & "</" & Rsio.Fields(k).Name & ">"
                    
                Case Is = "tipoComprobante"
                    'ssql = "select equivalencia from parametro where tipo = 'Compra' and  etiqueta = '" & Rsio(k) & "'"
                    ssql = "select equivalencia from parametro where etiqueta = '" & Rsio(k) & "' and proceso = 'C'"
                    filedata = Equivalencia(ssql)
                    Print #f, "    " & "<" & Rsio.Fields(k).Name & ">" & filedata & "</" & Rsio.Fields(k).Name & ">"
                 
                 Case Is = "establecimiento"
                    filedata = formateo(Rsio(k), "0", 3, "i")
                    f1 = f1 & Rsio(k)
                    Print #f, "    " & "<" & Rsio.Fields(k).Name & ">" & filedata & "</" & Rsio.Fields(k).Name & ">"
                    'Rsio.MoveNext
                    filedata = formateo(Rsx(k), "0", 3, "i")
                    f2 = f2 & Rsx(k)
                    'Rsio.MovePrevious
                    
                
                Case Is = "puntoEmision"
                    
                    filedata = formateo(Rsio(k), "0", 3, "i")
                    f1 = f1 & Rsio(k)
                    Print #f, "    " & "<" & Rsio.Fields(k).Name & ">" & filedata & "</" & Rsio.Fields(k).Name & ">"
                    'Rsio.MoveNext
                    filedata = formateo(Rsx(k), "0", 3, "i")
                    f2 = f2 & Rsx(k)
                    'Rsio.MovePrevious
                    
                Case Is = "secuencial"
                    If Rsio(k) = 2107 Then
                        MsgBox ("pILAS")
                    End If
                    filedata = formateo(Rsio(k), "0", 9, "i")
                    f1 = f1 & Rsio(k)
                    Print #f, "    " & "<" & Rsio.Fields(k).Name & ">" & filedata & "</" & Rsio.Fields(k).Name & ">"
                    'Rsio.MoveNext
                    filedata = formateo(Rsx(k), "0", 9, "i")
                    f2 = f2 & Rsx(k)
                    'Rsio.MovePrevious
                Case Is = "valRetServ100"
                'MsgBox "1"
                 Print #f, "    " & "<" & Rsio.Fields(k).Name & ">" & "" & Rsio(k) & "</" & Rsio.Fields(k).Name & ">"
                
                Case Is = "baseImponible"
                    datox = "" & Rsio(k)
                    If datox = "" Then datox = 0
                    BaseImponible = formateon(Round(datox, 2), 1, "###,###.00", "t")
                    datox = "" & Rsx(k)
                    If datox = "" Then datox = 0
                    BaseImponible2 = formateon(Round(datox, 2), 1, "###,###.00", "t")
                    valor = formateon("" & BaseImponible, 1, "###,###.99", "t")
                    Print #f, "    " & "<" & Rsio.Fields(k).Name & ">" & "" & BaseImponible & "</" & Rsio.Fields(k).Name & ">"
 
                
                Case Is = "codRetAir"
                    retencion = True
                    Val = "" & Rsio(k)
                    If Val = "" Then
                       
                                
                                fileret = "<air>" & vbCr & "</air>" & vbCr
                                fileret = fileret & "   <estabRetencion1>000</estabRetencion1> " & vbCr
                                fileret = fileret & "   <ptoEmiRetencion1>000</ptoEmiRetencion1>" & vbCr
                                fileret = fileret & "   <secRetencion1>0</secRetencion1>" & vbCr
                                fileret = fileret & "   <autRetencion1>000</autRetencion1> " & vbCr
                                fileret = fileret & "   <fechaEmiRet1>00/00/0000</fechaEmiRet1>  " & vbCr
                                fileret = fileret & "   <estabRetencion2>000</estabRetencion2>    " & vbCr
                                fileret = fileret & "   <ptoEmiRetencion2>000</ptoEmiRetencion2>   " & vbCr
                                fileret = fileret & "   <secRetencion2>0</secRetencion2>          " & vbCr
                                fileret = fileret & "   <autRetencion2>000</autRetencion2>         " & vbCr
                                fileret = fileret & "   <fechaEmiRet2>00/00/0000</fechaEmiRet2>       " & vbCr
                                fileret = fileret & "   <docModificado>0</docModificado>       " & vbCr
                                fileret = fileret & "   <estabModificado>000</estabModificado>            " & vbCr
                                fileret = fileret & "   <ptoEmiModificado>000</ptoEmiModificado>           " & vbCr
                                fileret = fileret & "   <secModificado>0</secModificado>           " & vbCr
                                fileret = fileret & "   <autModificado>000</autModificado>          "
                                'fileret = fileret & "</detalleCompras>"
                                Print #f, fileret
                    Else
                        'Se verificara si el siguiente registro tiene el mismo numero de factura para generar doble air
                        'Caso contrario iria un solo air y lo demas en 0
                    
                        
                        fileret = "<detalleAir>" & vbCr
                        'codigoretair
                        fileret = fileret & "   <" & Rsio.Fields(k).Name & ">" & "" & Rsio(k) & "</" & Rsio.Fields(k).Name & ">" & vbCr
                        k = k + 1
                        fileret = fileret & "   <baseImpAir>" & "" & BaseImponible & "</baseImpAir>" & vbCr '-- falta este campo
                        'porcentajeAir
                        filedata = formateon(Rsio(k), 100, "###,###.00", "t")
                        fileret = fileret & "   <" & Rsio.Fields(k).Name & ">" & "" & filedata & "</" & Rsio.Fields(k).Name & ">" & vbCr
                        k = k + 1
                        fileret = fileret & "   <" & Rsio.Fields(k).Name & ">" & "" & Rsio(k) & "</" & Rsio.Fields(k).Name & ">" & vbCr
                        k = k + 1
                        fileret = fileret & "   </detalleAir>" & vbCr
                        'k = k + 1
                        'esta es la parte de la retencion de los ultimos 5 campos
                        filedata = formateo(Rsio(k), "0", 3, "i")
                        fileair = fileair & "   <" & Rsio.Fields(k).Name & ">" & filedata & "</" & Rsio.Fields(k).Name & ">" & vbCr
                        k = k + 1
                        filedata = formateo(Rsio(k), "0", 3, "i")
                        fileair = fileair & "   <" & Rsio.Fields(k).Name & ">" & filedata & "</" & Rsio.Fields(k).Name & ">" & vbCr
                        k = k + 1
                        filedata = formateo(Rsio(k), "0", 9, "i")
                        fileair = fileair & "   <" & Rsio.Fields(k).Name & ">" & filedata & "</" & Rsio.Fields(k).Name & ">" & vbCr
                        k = k + 1
                        fileair = fileair & "   <" & Rsio.Fields(k).Name & ">" & "" & Rsio(k) & "</" & Rsio.Fields(k).Name & ">" & vbCr
                        k = k + 1
                        'fileair = fileair & "   <" & Rsio.Fields(k).Name & ">" & "" &  Rsio(k) & "</" & Rsio.Fields(k).Name & ">"& vbCr
                        'k = k + 1
                        
                         
                        
                        If f1 = f2 Then  ' las facturas son iguales
                        k = k - 7
                        'aqui hago la otra retencion
              
                        fileret = fileret & "<detalleAir>" & vbCr
                            fileret = fileret & "   <" & Rsio.Fields(k).Name & ">" & "" & Rsx(k) & "</" & Rsio.Fields(k).Name & ">" & vbCr
                        k = k + 1
                        fileret = fileret & "   <baseImpAir>" & "" & BaseImponible2 & "</baseImpAir>" & vbCr '-- falta este campo
                        'k = k + 1
                        filedata = formateon(Rsx(k), 100, "###,###.00", "t")
                        fileret = fileret & "   <" & Rsio.Fields(k).Name & ">" & "" & filedata & "</" & Rsio.Fields(k).Name & ">" & vbCr
                        k = k + 1
                        fileret = fileret & "   <" & Rsio.Fields(k).Name & ">" & "" & Rsx(k) & "</" & Rsio.Fields(k).Name & ">" & vbCr
                        k = k + 1
                        fileret = fileret & "</detalleAir>" & vbCr
                        
                        fileret = fileret & "<air>" & vbCr & "</air>"
                        
                                                'esta es la parte de la retencion de los ultimos 5 campos para la otra corrida
                        filedata = formateo("" & Rsx(k), "0", 3, "i")
                        fileair = fileair & "   <estabRetencion2>" & filedata & "</estabRetencion2>" & vbCr
                        k = k + 1
                        filedata = formateo("" & Rsx(k), "0", 3, "i")
                        fileair = fileair & "   <ptoEmiRetencion2>" & filedata & "</ptoEmiRetencion2>" & vbCr
                        k = k + 1
                        filedata = formateo("" & Rsx(k), "0", 9, "i")
                        fileair = fileair & "   <secRetencion2>" & filedata & "</secRetencion2>" & vbCr
                        k = k + 1
                        fileair = fileair & "   <autRetencion2>" & Rsio(k) & "</autRetencion2>" & vbCr
                        k = k + 1
                        fileair = fileair & "   <fechaEmiRet2>" & Rsio(k) & "</fechaEmiRet2>"
                        k = k + 1

                        Rsio.MoveNext

                        Else
                        
                        
                            fileair = fileair & "   <estabRetencion2>000</estabRetencion2>" & vbCr
                            fileair = fileair & "   <ptoEmiRetencion2>000</ptoEmiRetencion2>" & vbCr
                            fileair = fileair & "   <secRetencion2>0</secRetencion2>" & vbCr
                            fileair = fileair & "   <autRetencion2>000</autRetencion2>" & vbCr
                            fileair = fileair & "   <fechaEmiRet2>00/00/0000</fechaEmiRet2>"
                        
                        
                        End If
                        
                        Print #f, fileret
                        Print #f, fileair
                        
                        fileret = ""
                        fileair = ""
                    
                        Print #f, "   <docModificado>0</docModificado>"
                        Print #f, "   <estabModificado>000</estabModificado>"
                        Print #f, "   <ptoEmiModificado>000</ptoEmiModificado>"
                        Print #f, "   <secModificado>0</secModificado>"
                        Print #f, "   <autModificado>000</autModificado>"
                    End If
                    
                      k = k + k
                            
                Case Else
                    Print #f, "    " & "<" & Rsio.Fields(k).Name & ">" & "" & Rsio(k) & "</" & Rsio.Fields(k).Name & ">"
                    
                    
             End Select
                        
                         k = k + 1
                         Form1.Label1.Caption = j & " " & k
                         Form1.Refresh
        Wend
            'Si se retiene se imprime
            'If retencion Then
              '  Print #f, fileret
            'End If
                        
            Print #f, "  </detalleCompras>" 'Este es el fin de los tags de Detalle compras
        
            
        Rsio.MoveNext
        'MsgBox Rsx.BOF & " " & Rsx.EOF
    If Rsx.BOF = True Or Rsx.EOF = True Then
         MsgBox Rsx.BOF & " " & Rsx.EOF
         Rsx.MoveNext
       Else
        'Rsx.MoveNext
        'MsgBox Rsx.BOF & " " & Rsx.EOF
    End If
        'Fin de las Etiquetas, aqui debe evaluarse lo del tag de valores adicionales AIR
        
        
    Wend
       'Rsio.Close

     Print #f, "</compras>" 'Este es el fin de los tags de compras
     
Rsio.Close
Rsx.Close
     
     '**************
     ' Si va ventas*
     '**************
     
     If Form1.chkVentas.Value = 1 Then
     ' Si va ventas
        sql = "SELECT tpIdCliente, idCliente, tipoComprobante, count(idCliente) as numeroComprobantes, sum(baseImpGravx) AS baseNoGraIva, sum(montoIvax) as baseImpGrav"
        sql = sql & ", sum(valorRetIvax) as valorRetIva, sum(valorRetRentax) as valorRetRenta"
        sql = sql & " From Ventas"
        sql = sql & " Where idCliente <> ''"
        sql = sql & " GROUP BY tpIdCliente,idCliente, tipoComprobante"
        sql = sql & " ORDER BY tpIdCliente,idCliente, tipoComprobante"

     
     Rsio.Open sql, conexion
                 '****si no hay resultados ********
            If Rsio.EOF = True And Rsio.BOF = True Then
            'MsgBox "No existen Resultados para mostrar", vbInformation, "Toxml"
            Rsio.Close
            Exit Sub
            End If
            '**********************************

        i = 1
        k = 0
        j = Rsio.Fields.Count
                    Print #f, "<ventas>" 'Este es el inicio de los tags de compras
                    While Not Rsio.EOF

                         i = i + 1
                          MsfRows = i
                         k = 0
                         
                         
               
                        Print #f, "  <detalleVentas>" 'Este es el inicio de los tags de Detalle ventas
                        'Empiezan las etiquetas
                        While k < j
                        
                        Select Case Rsio.Fields(k).Name
                        
                        Case Is = "tpIdCliente"
                        ssql = "select equivalencia from parametro where etiqueta = '" & Rsio(k) & "' and proceso = 'v'"
                        filedata = Equivalencia(ssql)
                        Print #f, "    " & "<" & Rsio.Fields(k).Name & ">" & filedata & "</" & Rsio.Fields(k).Name & ">"
                        k = k + 1
                        
                       
                       Case Is = "tipoComprobante"
                        ssql = "select equivalencia from parametro where etiqueta = '" & Rsio(k) & "' and proceso = 'v'"
                        filedata = Equivalencia(ssql)
                        Print #f, "    " & "<" & Rsio.Fields(k).Name & ">" & filedata & "</" & Rsio.Fields(k).Name & ">"
                        k = k + 1
                       
                        
                        Case Else
                        Print #f, "    " & "<" & Rsio.Fields(k).Name & ">" & "" & Rsio(k) & "</" & Rsio.Fields(k).Name & ">"
                        k = k + 1
                        
            
                        End Select
                        Wend
                Rsio.MoveNext
                    Print #f, "  </detalleVentas>" 'Este es el inicio de los tags de Detalle ventas
                Wend
               Print #f, "  </ventas>"
     End If
     
     

     Print #f, "</iva>" ' solo por uun momento ojo
Close f

    

etterro:
 If Err.Number <> 0 Then
    MsgBox Err.Description
 Else
    MsgBox "Proceso terminado"
 End If

'Rsio.Close
'Rsx.Close
End Sub


' fileret = "<detalleAir>" & vbCr
'                        fileret = fileret & "    " & "<" & Rsio.Fields(k).Name & ">" & filedata & "</" & Rsio.Fields(k).Name & ">" & vbCr
'                        k = k + 1
'                        fileret = fileret & "    " & "<" & Rsio.Fields(k).Name & ">" & filedata & "</" & Rsio.Fields(k).Name & ">" & vbCr
'                        k = k + 1
'                        fileret = fileret & "    " & "<" & Rsio.Fields(k).Name & ">" & filedata & "</" & Rsio.Fields(k).Name & ">" & vbCr
'                        fileret = fileret & "</detalleAir>" & vbCr & "</air>" & vbCr
'                        k = k + 1
'                        filedata = formateo(Rsio(k), "0", 3, "i")
'                        fileret = fileret & "    " & "<" & Rsio.Fields(k).Name & ">" & filedata & "</" & Rsio.Fields(k).Name & ">" & vbCr
'                        k = k + 1
'                        filedata = formateo(Rsio(k), "0", 3, "i")
'                        fileret = fileret & "    " & "<" & Rsio.Fields(k).Name & ">" & filedata & "</" & Rsio.Fields(k).Name & ">" & vbCr
'                        k = k + 1
'                        filedata = formateo(Rsio(k), "0", 9, "i")
'                        fileret = fileret & "    " & "<" & Rsio.Fields(k).Name & ">" & filedata & "</" & Rsio.Fields(k).Name & ">" & vbCr
'                        k = k + 1
'                        fileret = fileret & "    " & "<" & Rsio.Fields(k).Name & ">" & "" &  Rsio(k) & "</" & Rsio.Fields(k).Name & ">" & vbCr
'                        k = k + 1
'                        fileret = fileret & "    " & "<" & Rsio.Fields(k).Name & ">" & "" &  Rsio(k) & "</" & Rsio.Fields(k).Name & ">" & vbCr
                        


Function Equivalencia(sql As String) As String
'Busca en la tabla de parametro que equivalencia lleva
Rs.Open sql, conexion
    If Rs.EOF = True And Rs.BOF = True Then
        Equivalencia = "SIN EQUIV."
        Rs.Close
        Exit Function
    Else
        Equivalencia = Rs(0)
        Rs.Close
    End If
End Function


Function formateo(dato As String, caracter As String, longitud As Integer, orientacion As String) As String
'llena un campo dependiendo de la longitud, que caracter y la orientacion
formateo = dato
    While Len(formateo) < longitud
        If orientacion = d Then
            formateo = formateo & caracter
        Else
            formateo = caracter & formateo
        End If
    Wend
End Function

Function formateon(dato As Variant, n As Integer, mascara As String, valor As String) As Variant
'Le va a dar un formato a un numero
    Select Case valor
        Case Is = "t"
            dato = Int(dato * 100)
            formateon = Format(dato, mascara)
        Case Else
            formateon = Format(dato * n, mascara)
        End Select
End Function



Sub llenalista(sql As String, lst As ListBox, padre As Integer, order As Integer)
   
        Rs.Open sql, conexion
        Rs.MoveFirst
         While Not Rs.EOF
          lst.AddItem Rs(0) & " " & UCase(Rs(1))
          Rs.MoveNext
         Wend
         Rs.Close
End Sub

