Private Sub cmdExpDAOC_Click()

Dim rst As DAO.Recordset

Dim Archivo As String

Archivo = "D:\SGRADIOv3.0\SGRADIOv3.0\tmp_ACDAM\" & DLookup("Mes", "TSeleccionDeFechaGeneral") & " " & DLookup("Año", "TSeleccionDeFechaGeneral") & " " & DLookup("Emisora", "01TNomencladorEmisora") & " Derecho Autor Obras Completasv3.0.csv"

Set rst = CurrentDb.OpenRecordset("ProgramasEmitidosDerAut")

Open Archivo For Output As #1

'Write #1, "TituloTema", "NombreAutor", "NombreInterprete", "Sonatas", "Calculo base", "EmisoraR", "Programa"

While Not rst.EOF

'Write #1, rst![TituloTema] & ";" & rst![NombreAutor] & ";" & rst![NombreInterprete] & ";" & rst![Sonatas] & ";" & rst![Calculo base] & ";" & rst![EmisoraR] & ";" & rst![Programa]

Print #1, rst![TituloTema] & ";" & rst![NombreAutor] & ";" & rst![NombreInterprete] & ";" & rst![Sonatas] & ";" & rst![Programa] & ";" & rst![EmisoraR] & ";" & rst![CalculoBase]

rst.MoveNext

Wend

Close #1

rst.Close: Set rst = Nothing

MsgBox "El archivo " & Archivo & " ha sido creado con éxito.", vbInformation, "Creación de Archivo CSV"

    Dim CarpetaOrigen As String

    Dim RarFileName As String

    Dim Password As String

 

    ' Ruta de la carpeta que deseas comprimir

    CarpetaOrigen = "D:\SGRADIOv3.0\SGRADIOv3.0 INFORMACIONES\ACDAM\"

 

    ' Nombre y ubicación del archivo comprimido

 

    RarFileName = "D:\SGRADIOv3.0\tpm_SGRADIOv3.0 EXPORTA\" & DLookup("Emisora", "01TNomencladorEmisora") & " " & DLookup("Mes", "TSeleccionDeFechaGeneral") & " " & DLookup("Año", "TSeleccionDeFechaGeneral") & " ACDAMv3.0.rar"

 

    ' Contraseña para el archivo RAR

    Password = "sgs2024*"

 

    ' Comando para comprimir con WinRAR

    Dim Command As String

    Command = """C:\Program Files\WinRAR\WinRAR.exe"" a -hp" & Password & " """ & RarFileName & """ """ & CarpetaOrigen & """"

 

    DoCmd.Hourglass True

 

    Shell Command, vbNormalFocus

 

    WaitForRarCompletion 5 ' Espera 5 segundos

 

    DoCmd.Hourglass False

 

    MsgBox "La carpeta se ha comprimido correctamente.", vbInformation

    

cmdExpDAOC_Exit:

    Exit Sub

cmdExpDAOC_Err:

    MsgBox Error$

    Resume cmdExpDAOC_Exit

End Sub