Discussion :

[Emi1988]

Bonjour à tous,
Malgré mes recherches je ne trouve pas de solution, j'espère donc que quelqu'un pourra résoudre mon problème.
J'ai fait à l'aide d'une vidéo YouTube un code VBA pour créer un rdv .ics à partir d'un fichier excel.
Voici la vidéo :

Le fichier se créé sans problème mais ne prend pas en compte les informations concernant la date de début du rdv et la date de fin.

Voici le code en question et je joints le fichier Excel pour que ce soit plus parlant.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
Sub RDV()
On Error GoTo Erreur
Dim fichier As String
ligne = ActiveCell.Row
Range("E" & ligne).Select
Niv = ActiveCell.Offset(0, 1).Value 'recupère le niveau
fichier = ThisWorkbook.Path & "\" & Niv & ".ics" 'enregistre le fichier ics au même endroit que le tableau excel
DTdeb = Split(ActiveCell.Offset(0, 3).Value, "/") 'recupère la date de début de formation
DTfin = Split(ActiveCell.Offset(0, 4).Value, "/") 'recupère la date de fin de formation
DTSTART = DTdeb(0) & DTdeb(1) & DTdeb(2)
DTEND = DTfin(0) & DTfin(1) & DTfin(2)
 
Set f = CreateObject("ADODB.Stream")
With f
.Charset = "utf-8"
.Open
.WriteText "BEGIN:VCALENDAR" & vbCrLf 'vbCrLf=retour à la ligne
.WriteText "VERSION 2.0" & vbCrLf
.WriteText "PRODID:-//EXCEL//FR" & vbCrLf
.WriteText "BEGIN:VEVENT" & vbCrLf
.WriteText "DTSTART:" & DTSART & "T" & vbCrLf
.WriteText "DTEND:" & DTEND & "T" & vbCrLf
.WriteText "SUMMARY:" & Niv & vbCrLf
.WriteText "DESCRIPTION:" & ActiveCell.Offset(0, 7).Value & vbCrLf
.WriteText "LOCATION:" & ActiveCell.Offset(0, 8).Value & vbCrLf
.WriteText "END:VEVENT" & vbCrLf
.WriteText "END:VCALENDAR"
.SaveToFile fichier, 2
.Close
End With
Exit Sub
Erreur:
MsgBox "Il y a un problème avec cette ligne"
End Sub

[curt]

Bonsoir Emi1988,

tu as oublié une partie. Essaie ça :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
Function deux(tps)
deux = Right("00" & tps, 2)
End Function
 
Sub rdv()
 
On Error GoTo Erreur
 
Dim fichier As String
 
    ligne = ActiveCell.Row
    Range("E" & ligne).Select
    NP = ActiveCell.Value & "_" & ActiveCell.Offset(0, 1).Value
    fichier = ThisWorkbook.Path & "\" & NP & ".ics"
    DT = Split(ActiveCell.Offset(0, 3).Value, "/")
    debut = ActiveCell.Offset(0, 5).Value
    fin = ActiveCell.Offset(0, 6).Value
    DTSTART = DT(2) & DT(1) & DT(0) & "T" & deux(Hour(debut)) & deux(Minute(debut)) & "00"
    DTEND = DT(2) & DT(1) & DT(0) & "T" & deux(Hour(fin)) & deux(Minute(fin)) & "00"
 
    Set f = CreateObject("adodb.stream")
 
    With f
        .Charset = "utf-8"
        .Open
        .WriteText "BEGIN:VCALENDAR" & vbCrLf
        .WriteText "VERSION 2.0" & vbCrLf
        .WriteText "PRODID:-//EXCEL//FR" & vbCrLf
        .WriteText "BEGIN:VEVENT" & vbCrLf
        .WriteText "DTSTART:" & DTSTART & vbCrLf
        .WriteText "DTEND:" & DTEND & vbCrLf
        .WriteText "SUMMARY:" & Niv & vbCrLf
        .WriteText "DESCRIPTION:" & ActiveCell.Offset(0, 7).Value & vbCrLf
        .WriteText "LOCATION:" & ActiveCell.Offset(0, 8).Value & vbCrLf
        .WriteText "END:VEVENT" & vbCrLf
        .WriteText "END:VCALENDAR"
        .SaveToFile fichier, 2
        .Close
 
    End With
    Exit Sub
 
Erreur:
    MsgBox "Il y a un problème avec cette ligne"
 
End Sub

Curt

[Emi1988]

Super ça fonctionne,
Merci beaucoup pour ton aide
Bon WE