Exportation XLS en .ICS
P
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