Importation Calendrier Outlook et Format

[Calvus]

Bonjour le Forum,

J'ai trouvé sur le net un fichier permettant l'importation d'un calendrier Outlook.
Le code fonctionne bien, sauf que je n'arrive pas à trouver le bon format pour utiliser la fonction Find.
En tout cas j'imagine que le problème vient du format.

Le but est de trouver la ligne correspondant à l'horaire de début de la date importée.

Merci

 

[Lone-wolf]

Bonjour Calvus

Un essai comme ceci, si j'ai bien compris

Dim DateStart As Date, Numcellule As Long, CurApp
Dim plage As Range, cel As Range

DateStart = currentAppointment.Start
CurApp = currentAppointment
Numcellule = 6

For each CurApp In myAppointments
Range("B" & Numcellule) = CurApp.Subject
Range("D" & Numcellule) = CurApp.End
Numcellule = Numcellule + 1
set plage = Range("a6:a28")
For each cel in plage
If DateStart Like "*" & cel.Offset(0, 0).Value Then _
cel.offset(0, 2) = DateStart
Next cel
Next CurApp

 

[Lone-wolf]

Et Manu... Et Manu... tu fait la gueule ou quoi???

 

[Calvus]

Bonsoir Lone-Wolf , le forum,

Ça ne fonctionne pas hélas.. Du moins ce n'est pas le résultat escompté.
Ce que j'aimerais, c'est qu'un rendez-vous pris dans Outlook à 11h soit inscrit dans les cellules équivalentes (soit B10 à D10 dans l'exemple)
Un rendez-vous à 14h30 soit inscrit de même manière (B17 à D17)
Idem pour les dates de fin, de façon à pouvoir colorer la plage par la suite.
Retrouver le visuel du calendrier en fait.

Et Manu... Et Manu... tu fait la gueule ou quoi???

Mais non ! Je n'étais pas là simplement

A bientôt

 

[Lone-wolf]

Hi !

Là ça devient compliqué pour mes neurones.

 

[Calvus]

Tu penses que c'est possible ?

 

[Lone-wolf]

Je pense que oui, puisque depuis excel on peut créer des rendez-vous.

 

[Calvus]

Re,

TROP Content ! J'ai trouvé en me basant sur une partie de ton code. Tu m'as mis sur la bonne voie. ! Voici le code :

Option Explicit


Sub ContactDateCheck()
' mes rendez vous Outlook du jour
    Dim myOlApp As Outlook.Application
    Dim myNamespace As Outlook.Namespace
    Dim myContacts As Outlook.Items
    Dim myItems As Outlook.Items
    Dim myItem As Object
  
    Set myOlApp = CreateObject("Outlook.Application")
    Set myNamespace = myOlApp.GetNamespace("MAPI")
'   Set MesRDV = myNamespace.GetDefaultFolder(olFolderCalendar).Items

Dim strDate As Variant, strRestriction As Variant
Dim myAppointments As Object, currentAppointment As Object
    strDate = Range("D3")
    strRestriction = "(([Start] >= '" & strDate & " 12:00 am' AND [Start] <= '" & strDate & " 11:59 pm')"
    strRestriction = strRestriction & " OR ([End] > '" & strDate & " 12:00 am' AND [End] <= '" & strDate & " 11:59 pm')"
    strRestriction = strRestriction & " OR ([Start] < '" & strDate & " 12:00 am' AND [End] > '" & strDate & " 11:59 pm'))"
    strRestriction = strRestriction & " AND [Duration] > 0"
  
    If strDate = "" Then strRestriction = "[Start] = 1"    'no result
    Set myAppointments = myNamespace.GetDefaultFolder(olFolderCalendar).Items.Restrict(strRestriction)
    myAppointments.Sort "[Start]"
    ' myAppointments.IncludeRecurrences = True
Dim CurApp
Dim DateStart As Date, DateEnd As Date
    DateStart = strDate
Dim plage As Range, cel As Range
          
For Each currentAppointment In myAppointments
    If currentAppointment.Class = olAppointment And currentAppointment.Start >= DateStart Then
      
        DateStart = currentAppointment.Start
        DateEnd = currentAppointment.End
      
            Set plage = Range("a6:a28")
                For Each cel In plage
                    If TimeSerial(Hour(cel), Minute(cel), 0) = TimeSerial(Hour(DateStart), Minute(DateStart), 0) Then
                        cel.Offset(0, 1) = currentAppointment.Subject
                        cel.Offset(0, 2) = Right(DateStart, 8)
                    End If
                        If TimeSerial(Hour(cel), Minute(cel), 0) = TimeSerial(Hour(DateEnd), Minute(DateEnd), 0) Then
                            cel.Offset(0, 1) = currentAppointment.Subject
                            cel.Offset(0, 2) = Right(DateEnd, 8)
                        End If
            Next cel
    End If
Next
End Sub

Il y a juste la déclaration des variables dont je ne suis pas sûr. Du coup j'ai mis Variant, car ça ne fonctionnait pas avec Range ou Date.

Ne me reste plus qu'à trouver comment on peut colorer la plage de rendez vous trouvé, pour chaque rendez vous.

A bientôt

 

[Lone-wolf]

Bonjour Calvus , le Forum

Si tu te base d'après cette ligne : If TimeSerial(Hour(cel), Minute(cel), 0) = TimeSerial(Hour(DateStart), Minute(DateStart), 0) Then
cel.Interior.Color = RGB(195, 255, 0) par exemple

 

[Lone-wolf]

Re

En PJ. Un classeur que j'avais fait pour créer des RDV. Dans le classeur, il y à déjà des noms inscrits. Fait une recherche, double-clique sur l'adresse mail dans la listbox (tu peux aussi afficher le rdv avec le bouton "Afficher"). Dans le 2ème formulaire, tu peux annuler le rdv en cliquand sur l'mage correspondante, ajouter une couleur en cliquand sur la petite flèche "Classer". Clique ensuite sur "Envoyer"; là outlook s'ouvre avec le rdv programmé.

 

[Calvus]

Bonjour Lone-Wolf , le forum,

Si tu te base d'après cette ligne : If TimeSerial(Hour(cel), Minute(cel), 0) = TimeSerial(Hour(DateStart), Minute(DateStart), 0) Then
cel.Interior.Color = RGB(195, 255, 0) par exemple

Merci, mais ce que je voulais, c'était colorer les plages de cellules pendant tout le rv, et ce sur une période d'une semaine.
C'est donc fait maintenant. Si quelqu'un veut le code, je peux le transmettre.

Merci pour l'envoi de ton fichier, que je n'arrive malheureusement pas à ouvrir.
Ça bug sur PtrSafe, me disant qu'il est attendu Sub ou fonction..

A bientôt

 

[Lone-wolf]

Re

Enlève les PtrSafe pour voir.

 

[Calvus]

Hello Lone-Wolf,

Dommage, ça ne fonctionne pas. Le fichier a l'air sympa pourtant.