Exportation XLS en .ICS

Bonjour,

J’ai un fichier calendrier, que je souhaite transformer en un fichier ICS.

J’ai trouvé un script VBA qui fonctionne avec son fichier d’origine.

Voici le fichier original avec le script d'export en ICS :

J’ai ensuite créer un nouvel onglet « Calendrier-ics » dans mon classeur Excel.

Après plusieurs heures pour comprendre son fonctionnement et en allant sur le site indiqué ci-dessous (en anglais), ne sachant pas l’english à fond, il est difficile de comprendre ce qui est dit.

Lors du processus du script, l’erreur commence dans le For (S=Dt2…).

Sauriez-vous me dire ce qui ne va pas et ce que je dois changer ?

Merci d’avance.

Option Explicit

Sub Xprt_ics()
Dim Ttk As Variant, Hlg As Variant
Dim Txt As String, S As String
Dim lg As Integer, cl As Integer, i As Integer, j As Integer

Hlg = Array("SUMMARY:", "LOCATION:", "CATEGORIES:", "DESCRIPTION:", "STATUS:", "TRANSP:")
Txt = "BEGIN:VCALENDAR" & vbCrLf & _
      "VERSION:2.0" & vbCrLf & _

With Sheets(1)
    lg = .Cells(Rows.Count, 1).End(xlUp).Row + 2
    cl = .Cells(1, Columns.Count).End(xlToLeft).Column
    Ttk = .Range(.Cells(1, 1), .Cells(lg, cl)).Value
End With

For i = 2 To UBound(Ttk)
    Txt = Txt & "BEGIN:VEVENT" & vbCrLf
    **S = Dt2Txt(Ttk(i, 2)) & IIf(Ttk(i, 3) = "", "", H2UTC(Ttk(i, 2), Ttk(i, 3)))**
    Txt = Txt & "DTSTART:" & S & vbCrLf
    If Not Ttk(i, 4) = "" Then
        S = Dt2Txt(Ttk(i, 4)) & IIf(Ttk(i, 5) = "", "", H2UTC(Ttk(i, 4), Ttk(i, 5)))
        Txt = Txt & "DTEND:" & S & vbCrLf
    End If
    For j = 6 To 11
        If Not Ttk(i, j) = "" Then
            Txt = Txt & Hlg(j - 6) & Ttk(i, j) & vbCrLf
        End If
    Next j
    Txt = Txt & "END:VEVENT" & vbCrLf
Next i
Txt = Txt & "END:VCALENDAR"

lg = Ecrire_Txt(ActiveWorkbook.Path & "\Export_ics.ics", Txt)
If lg = 0 Then MsgBox "Export vers .ics = Ok"
End Sub

Function Dt2Txt(Dt As Variant) As String
On Error GoTo errhdlr
Dt2Txt = Year(CDate(Dt)) & Format(Month(CDate(Dt)), « 00 ») & Format(Day(CDate(Dt)), « 00 »)
Exit Function

errhdlr:
Dt2Txt = «  »
End Function

Function H2UTC(Dt As Variant, H As Variant) As String
Dim An As Integer
Dim DtL As Double, Dt1 As Double, Dt2 As Double

On Error GoTo errhdlr
DtL = CDbl(CDate(Dt)) + CDbl(CDate(H))
An = Year(CDate(Dt))
Dt1 = (DateSerial(An, 4, 1) - 1) - (((DateSerial(An, 4, 1) - 1) + 6) Mod 7)
Dt2 = (DateSerial(An, 11, 1) - 1) - (((DateSerial(An, 11, 1) - 1) + 6) Mod 7)

H2UTC = "T" & _
        Format(Hour(CDate(H) - IIf(DtL > Dt1 And DtL < Dt2, 2 / 24, 1 / 24)), "00") & _
        Format(Minute(CDate(H)), "00") & Format(Second(CDate(H)), "00") & "Z"
Exit Function
errhdlr:
H2UTC = «  »
End Function

Function Ecrire_Txt(Ndf As String, Txt As String) As Integer
Dim i As Integer

On Error GoTo errhdlr:
Ecrire_Txt = 0
i = FreeFile()
Open Ndf For Output As #i
Print #i, Txt
Close #i
Exit Function
errhdlr:
Close #i
Ecrire_Txt = -1
End Function