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 : 119690148.xlsm (23,1 Ko)
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 ?
Merci d’avance.
Ci-dessous le script:
Option Explicit
’ format ics selon la norme : RFC 2445: Internet Calendaring and Scheduling Core Object Specification (iCalendar)
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 & _
"PRODID:-//tatiak.canalblog.com//AGENDA++ v2.xx//FR" & 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