Afficher fichier ics sous forme d'emploi du temps

Question

J'aimerais importer un fichier ics (qui correspond à l'agenda sur google) sur Excel. Je dois donc écrire un code vba qui permette d'ouvrir ce fichier sous forme d'emploi du temps. Cependant je n'ai jamais programmé, j'ai fait des recherches mais je ne sais pas comment commencer. Pourriez vous m'aider ? Merci...

pijaku · Answer

Pas évident... Je vais tenter quelque chose, mais en attendant, peux tu éditer ton message et supprimer le fichier joint. Ton fichier .txt contient une multitude d'adresses mails.....

pijaku · Answer

De rien...

Attention tout de même à ne jamais laisser d'info confidentielle sur un forum.

Bref.

J'ai réussit quelque chose, mais ce n'est pas super joli.

Regarde déjà ce que tu peux en faire au niveau format, couleurs, mise en forme etc...

Pour l'instant c'est plat...

Ce fichier fonctionne avec le fichier .txt. Aucune idée si cela fonctionne avec un fichier .ics. A la limite, tu peux tester.

La seule adaptation à faire est le nom du fichier en Constante :

Option Explicit

Const Fic As String = "\PROJET01-Exemple01-1.txt"

Après le reste du code devrait suivre.

Il convient également de sauvegarder le fichier ci-joint dans le même répertoire que ton fichier .txt.

Voici donc le fichier :

216contruirecalendrier.zip (11.99 Ko)

Et le code complet :

Option Explicit

Const Fic As String = "\PROJET01-Exemple01-1.txt"
Dim Mois As Integer, MoisEnCours As Integer

Sub Construire_Calendrier()
Dim CheminFic As String
Dim Num As Long, Lig As String, i As Long
Dim DateDepart As Date, TimeDepart As Date, DateFin As Date, TimeFin As Date
Dim Descrip As String, Lieu As String, Resu As String
Dim Flag As Boolean, CptInfos As Byte, Ligne As Long, Col As Integer

Mois = 0
Flag = False
CheminFic = ThisWorkbook.Path & Fic
 Num = FreeFile
 Open CheminFic For Input As #Num
 Do While Not EOF(1)
    Line Input #Num, Lig
    If Lig <> "" Then
      If Flag = True Then
        Flag = False
        If InStr(Lig, "@") > 0 Then Descrip = Descrip & " ; " & Lig
      End If
      Select Case Left(Lig, 6)
        Case "DTSTAR": DateDepart = Construi_Date(Lig, "Deb"): TimeDepart = Construi_Heure(Lig, "Deb"): CptInfos = CptInfos + 1
        Case "DTEND:": DateFin = Construi_Date(Lig, "fin"): TimeFin = Construi_Heure(Lig, "fin"): CptInfos = CptInfos + 1
        Case "DESCRI": Descrip = Split(Lig, ":")(1): Flag = True: CptInfos = CptInfos + 1
        Case "LOCATI": Lieu = Split(Lig, ":")(1): CptInfos = CptInfos + 1
        Case "SUMMAR": Resu = Split(Lig, ":")(1): CptInfos = CptInfos + 1
        Case Else
      End Select
      If MoisEnCours = 1 And Mois = 12 Then Mois = 0
      If MoisEnCours > Mois Then
        Col = Col + 3: Mois = MoisEnCours
      End If
      If CptInfos = 5 Then
        CptInfos = 0
        If Cells(1, Col) <> "" Then
            Ligne = Columns(Col).Find("*", , , , xlByColumns, xlPrevious).Row + 2
        Else
            Ligne = 1
        End If
        Cells(Ligne, Col) = DateDepart
        Cells(Ligne + 1, Col) = TimeDepart
        Cells(Ligne, Col + 1) = DateFin
        Cells(Ligne + 1, Col + 1) = TimeFin
        Cells(Ligne + 2, Col) = Descrip
        Cells(Ligne + 3, Col) = Lieu
        Cells(Ligne + 3, Col + 1) = Resu
      End If
    End If
 Loop
 Close Num
End Sub

Function Construi_Date(ByVal Texto As String, Typ As String) As Date
    If Typ = "Deb" Then Texto = Split(Right(Texto, Len(Texto) - 8), "T")(0) Else Texto = Split(Right(Texto, Len(Texto) - 6), "T")(0)
    Texto = Right(Texto, 2) & "/" & Mid(Texto, 5, 2) & "/" & Left(Texto, 4)
    If Typ = "Deb" Then MoisEnCours = Mid(Texto, 4, 2)
    Construi_Date = CDate(Texto)
End Function

Function Construi_Heure(ByVal Tex As String, T As String) As Date
    If T = "Deb" Then Tex = Split(Right(Tex, Len(Tex) - 8), "T")(1) Else Tex = Split(Right(Tex, Len(Tex) - 6), "T")(1)
    Tex = Left(Tex, 2) & ":" & Mid(Tex, 3, 2) & ":" & Right(Tex, 2)
    Construi_Heure = CDate(Tex)
End Function