VBA: Alle Termine eines mehrtägigen Zeitraums mit recurring

Moderator: ModerationP

VBA: Alle Termine eines mehrtägigen Zeitraums mit recurring

Beitragvon AndreaRatlos » 31. Mai 2019, 09:58

Hallo alle,

ich habe auf http://www.herber.de/forum/archiv/1332t ... rmine.html
unten anhängenden Code gefunden, der fabelhaft funktioniert - aber leider immer nur für genau einen Tag.
Auch bei Microsoft und anderswo konnte ich nur Beispiele finden, die sich auf einen einzigen Tag beziehen.

Um die Termine für mehrere Tage auszugeben, habe ich bisher nur die Lösung, Start und Ende in einer Schleife hochzuzählen und die Abfrage der Elemente für jeden Tag neu auszuführen, was extrem lange dauert.
Gibt es irgendeine andere Lösung?

Vielen Dank im voraus für Eure Hilfe!

Viele Grüße

Andrea


Code: Alles auswählen
Sub Read_Control_Terminrange_to_Excel()
'by Ramses - extremely modified by fcs 2013-10.04
  'Zeitraumabfrage über Startdatum = A1 und Enddatum = B1
  'Verweis auf Outlook 11 Library im VB-Editor muss gesetzt sein
  'Early Binding ab Outlook 2003 nicht möglich
  'weil die Rückgabewerte der ITEM-Indexes zufällig ist und von der
  'Installation abhängt !!
  Dim myR As Integer, i As Integer
  Dim startDate As Date, endDate As Date
  Dim myOlApp As Object, myOlSpace As Object, myOlFolder As Object
  Dim myOlAppointments As Object, myOlAppointment As Outlook.AppointmentItem
  Dim TerminPlatz As Range
  Dim RestrText As String
  Dim bolEintragen As Boolean
  'Termin Einträge
  Set TerminPlatz = Sheets("Druck_Kalender").Range("A4")
  myR = 0
  'Löscht Terminbereich
  TerminPlatz.Resize(12, 4).ClearContents
 
  'Datum abfragen
  With Sheets("Druck_Kalender").Range("B2")
    startDate = .Value
    endDate = .Value + 1
  End With
  'Datenbereich abfragen
  RestrText = "([Start] >= '" & VBA.Format(startDate - 1, "ddddd") _
      & "' AND [Start] < '" & VBA.Format(endDate, "ddddd") & "') OR ([Start] <= '" _
      & VBA.Format(startDate, "ddddd") _
      & "' AND [End] >= '" & VBA.Format(startDate, "ddddd") & "')"
  'Debug.Print RestrText
 
  'Deklaration
  Set myOlApp = CreateObject("Outlook.Application")
  Set myOlSpace = myOlApp.GetNamespace("MAPI")
  Set myOlFolder = myOlSpace.GetDefaultFolder(olFolderCalendar)
  Set myOlAppointments = myOlSpace.GetDefaultFolder(olFolderCalendar).Items
  myOlAppointments.Sort "[Start]"
  myOlAppointments.IncludeRecurrences = True
  Set myOlAppointment = myOlAppointments.Find(RestrText)
  While TypeName(myOlAppointment) <> "Nothing"
      bolEintragen = False
      With myOlAppointment
          Select Case .AllDayEvent
            Case True
              'ganztägige Termine - Urlaub, Dienstreisen etc
              If (.Start >= CDate(startDate) And .End <= CDate(endDate)) _
                  Or (.Start <= CDate(startDate) And .End >= CDate(endDate)) Then
                'Termindaten eintragen
                TerminPlatz.Offset(myR, 0) = "ganzer Tag"
                bolEintragen = True
              End If
            Case False
              'Termine mit Zeitangaben
              If (.Start >= CDate(startDate) And .End < CDate(endDate)) Then
                'Termindaten mit Begin und Ende am gleichen Tag
                TerminPlatz.Offset(myR, 0) = _
                    Format(.Start, "hh:mm") & " - " & Format(.End, "hh:mm")
                bolEintragen = True
              ElseIf Format(.Start, "DD.MM.YYYY") <> Format(.End, "DD.MM.YYYY") Then
                If Day(.Start) = Day(startDate) And Day(.End) = Day(endDate) Or _
                  Day(.Start) = Day(startDate - 1) And Day(.End) = Day(startDate) Then
                  'Termin mit Beginn vor und Ende nach Mitternacht
                  If Day(startDate) = Day(.Start) Then
                    TerminPlatz.Offset(myR, 0) = _
                        Format(.Start, "hh:mm") & " - " & Format(.End, "hh:mm")
                  Else
                    TerminPlatz.Offset(myR, 0) = _
                        "*00:00 - " & Format(.End, "hh:mm")
                  End If
                  bolEintragen = True
                ElseIf (CDate(Format(.Start, "YYYY-MM-DD")) <= startDate _
                    And CDate(Format(.End, "YYYY-MM-DD")) >= startDate) Then
                  'Termin über mehrere Tage mit Start und Ende Zeit
                  If startDate = CDate(Format(.Start, "YYYY-MM-DD")) Then
                    'Starttag
                    TerminPlatz.Offset(myR, 0) = _
                        Format(.Start, "hh:mm") & " - 00:00*"
                  ElseIf startDate = CDate(Format(.End, "YYYY-MM-DD")) Then
                    'Endetag
                    TerminPlatz.Offset(myR, 0) = _
                        "*00:00 - " & Format(.End, "hh:mm")
                  Else
                    TerminPlatz.Offset(myR, 0) = "mehrtägig"
                  End If
                  bolEintragen = True
                End If
              End If
          End Select
          If bolEintragen = True Then
            TerminPlatz.Offset(myR, 1) = .Subject
            myR = myR + 1
            If myR > 12 Then MsgBox "zu viele Termine - Format wird unschön"
          End If
      End With
      Set myOlAppointment = myOlAppointments.FindNext
  Wend
  'Variablen leeren
  Set myOlApp = Nothing
  Set myOlSpace = Nothing
  Set myOlFolder = Nothing
  Set myOlAppointments = Nothing
  Set myOlAppointment = Nothing
  MsgBox "Alle Termine  im Zeitraum vom " & Format(startDate, "DD.MM.YYYY hh:mm") _
    & " bis " & Format(endDate - TimeSerial(0, 1, 0), "DD.MM.YYYY hh:mm") & " eingelesen!"
End Sub
AndreaRatlos
 

Re: VBA: Alle Termine eines mehrtägigen Zeitraums mit recurr

Beitragvon Gast » 31. Mai 2019, 10:24

Hier noch der umgebastelte Code. Leider wie gesagt, extrem langsam wegen der vielen Abfragen ( Set myOlAppointment = myOlAppointments.Find(RestrText) )
Wäre toll, wenn jemand eine Idee hätte.

Code: Alles auswählen
Public Sub GetAppointment()

  Dim startDate As Date, endDate As Date
  Dim myOlApp As Object, myOlSpace As Object, myOlFolder As Object
  Dim myOlAppointments As Object
  Dim myOlAppointment As Outlook.AppointmentItem
  Dim RestrText As String
  Dim objPublicFolderRoot As Outlook.Folder
  Dim objCompanyFolder As Outlook.Folder

Dim strMonat(12) As String
Dim data As Date
Dim strMonatstrActTag(12, 31) As Integer
Dim strWochentag, strActMonat, strActTag As String
Dim intStartMonat, intJahr, intStartJahr, intMaxMonate As Integer
Dim intMonat, intSpalte As Integer
Dim strMsg As String
Dim cTitle As String
Dim col As String

Dim BetreffOrig As String
Dim Betreff As String
Dim i

 
 '8 Kollegen
Dim AlleKollegenFarbe(8)
Dim AlleKollegenBetreff(8)

   
  'Deklaration
  Set myOlApp = CreateObject("Outlook.Application")
  Set myOlSpace = myOlApp.GetNamespace("MAPI")
  Set myOlFolder = myOlSpace.GetDefaultFolder(olFolderCalendar)
 
 
 ' Set myOlAppointments = myOlSpace.GetDefaultFolder(olFolderCalendar).Items
  '***
  Set objPublicFolderRoot = myOlSpace.GetDefaultFolder(olPublicFoldersAllPublicFolders)
  Set objCompanyFolder = objPublicFolderRoot.Folders("Urlaub_Abwesenheit")
  Set myOlAppointments = objCompanyFolder.Items
  '***
 
  myOlAppointments.Sort "[Start]"
  myOlAppointments.IncludeRecurrences = True


cTitle = "Kalender erstellen"
'System.Cursor = wdCursorWait

  strMsg = "In welchem Jahr beginnt der Kalendar?"
  intStartJahr = InputBox(strMsg, cTitle, Year(Now))
 
  strMsg = "Mit welchem Monat soll der Kalender beginnen (1-12)?"
  intStartMonat = InputBox(strMsg, cTitle, Month("1/ 1/" & intStartJahr))
  'intStartMonat = 1
 
  strMsg = "Wie viele Monate sollen angezeigt werden (1-12)?"
  intMaxMonate = InputBox(strMsg, cTitle, "12")

   
   Dim msg As String
   msg = "<html><head>" & vbCr & "<style type='text/css'>" & vbCr & ".line {" & vbCr & "border-bottom: 1px dotted #000;" & vbCr & "}" & vbCr & "</style></head><body>"
 
' Daten abfragen
Do
  If intStartJahr = "" Then End
Loop While IsNumeric(intStartJahr) = False
Do
  If intStartJahr = "" Then End
Loop While (Not IsNumeric(intStartMonat)) Or 1 > intStartMonat Or intStartMonat > 12
Do
  If intStartJahr = "" Then End
Loop While IsNumeric(intMaxMonate) = False


intJahr = intStartJahr
' Datum des ersten Kalendertages ermitteln
data = "1/ " & Val(intStartMonat) & "/ " & intJahr
strWochentag = Weekday(data)

Dim intEndMonat, intEndJahr, int_berlauf As Integer
' Jahreswechsel berücksichtigen und korrekten Endmonat ermitteln
If intStartMonat + intMaxMonate - 1 > 12 Then
  int_berlauf = Int((intStartMonat + intMaxMonate - 1) / 12)
  intEndMonat = intStartMonat + intMaxMonate - 1 - 12 * int_berlauf
  intEndJahr = intStartJahr + int_berlauf
ElseIf intStartMonat + intMaxMonate - 1 = 12 Then
  intEndMonat = intStartMonat + intMaxMonate - 1
  intEndJahr = intStartJahr
Else
  intEndMonat = intStartMonat + intMaxMonate - 1
  intEndJahr = intStartJahr + Int((intStartMonat + intMaxMonate - 1) / 12)
End If



msg = msg & "<h1>" & "Kalenderübersicht von " & intStartMonat & " / " & intStartJahr & " bis " _
 & intEndMonat & " / " & intEndJahr & "</h1><br>" & vbCrLf & _
"<table><tr><td valign=top>" & vbCrLf

  intMonat = intStartMonat
  For intSpalte = 1 To intMaxMonate
    ' Jahreswechsel
    If intMonat = 13 Then
      intMonat = 1
      intJahr = intJahr + 1
    End If
       
    'Monatsnamen ermitteln
    strMonat(intMonat) = Format("1/" & intMonat & "/ " & intJahr, "mmmm")
 
msg = msg & "<table><tr><td><b>" & strMonat(intMonat) & "</b></td></tr>" & vbCrLf & _
           "<tr><td>" & vbCrLf & _
           "<table cellpadding=0 cellspacing=0>" & vbCrLf

   
    strActMonat = Format(data, "mm")
    ' Alle Tage eines Monats bearbeiten
    Do While Val(strActMonat) = intMonat
   
      strActTag = Format(data, "dd")
       
msg = msg & "<tr "
        col = "white"
        Select Case Weekday(data)
        Case vbSunday
           ' Sonntage werden hervorgehoben
          msg = msg & " bgcolor='#cccccc'"
          col = "#cccccc"
        Case vbSaturday
           msg = msg & " bgcolor='#cccccc'"
           col = "#cccccc"
        End Select
       
        msg = msg & "><td class='line'><nobr>" & Format(data, "d ddd") & "</nobr></td><td class='line'>"
     

'Array leer belegen
i = 1
While i <= UBound(AlleKollegenFarbe)
AlleKollegenFarbe(i) = col
AlleKollegenBetreff(i) = ""
i = i + 1
Wend
       

  startDate = CDate(data)
  endDate = DateAdd("d", 1, startDate)
 ' MsgBox (startDate & " - " & endDate)
 
  'Datenbereich abfragen
  RestrText = "([Start] >= '" & VBA.Format(startDate - 1, "ddddd") _
      & "' AND [Start] < '" & VBA.Format(endDate, "ddddd") & "') OR ([Start] <= '" _
      & VBA.Format(startDate, "ddddd") _
      & "' AND [End] >= '" & VBA.Format(startDate, "ddddd") & "')"
  'Debug.Print RestrText
 
  Debug.Print "start verbindung"
  Set myOlAppointment = myOlAppointments.Find(RestrText)
  Debug.Print "ende verbindung"
 
  While TypeName(myOlAppointment) <> "Nothing"

      bolEintragen = False
     
      With myOlAppointment
          Select Case .AllDayEvent
            Case True
              'ganztägige Termine - Urlaub, Dienstreisen etc
              If (.Start >= CDate(startDate) And .End <= CDate(endDate)) _
                  Or (.Start <= CDate(startDate) And .End >= CDate(endDate)) Then
                'Termindaten eintragen
                 bolEintragen = True
              End If
            Case False
              'Termine mit Zeitangaben
              If (.Start >= CDate(startDate) And .End < CDate(endDate)) Then
                'Termindaten mit Begin und Ende am gleichen Tag
                 bolEintragen = True
              ElseIf Format(.Start, "DD.MM.YYYY") <> Format(.End, "DD.MM.YYYY") Then
                If Day(.Start) = Day(startDate) And Day(.End) = Day(endDate) Or _
                  Day(.Start) = Day(startDate - 1) And Day(.End) = Day(startDate) Then
                  'Termin mit Beginn vor und Ende nach Mitternacht
                  bolEintragen = True
                ElseIf (CDate(Format(.Start, "YYYY-MM-DD")) <= startDate _
                    And CDate(Format(.End, "YYYY-MM-DD")) >= startDate) Then
                  'Termin über mehrere Tage mit Start und Ende Zeit
                  bolEintragen = True
                End If
              End If
          End Select
         
          If bolEintragen = True Then

BetreffOrig = myOlAppointment.Subject
Betreff = Trim(LCase(BetreffOrig))

If Betreff <> Replace(Betreff, "fröhlich", "") Then
If AlleKollegenBetreff(1) <> "" Then
Komma = ", "
Else
Komma = ""
End If
AlleKollegenBetreff(1) = AlleKollegenBetreff(1) & Komma & BetreffOrig
AlleKollegenFarbe(1) = "mediumpurple"


ElseIf Betreff <> Replace(Betreff, "ernst", "") Then
If AlleKollegenBetreff(2) <> "" Then
Komma = ", "
Else
Komma = ""
End If
AlleKollegenBetreff(2) = AlleKollegenBetreff(2) & Komma & BetreffOrig
AlleKollegenFarbe(2) = "orange"


ElseIf Betreff <> Replace(Betreff, "gross", "") Then
If AlleKollegenBetreff(3) <> "" Then
Komma = ", "
Else
Komma = ""
End If
AlleKollegenBetreff(3) = AlleKollegenBetreff(3) & Komma & BetreffOrig
AlleKollegenFarbe(3) = "magenta"


ElseIf Betreff <> Replace(Betreff, "gotthart", "") Then
If AlleKollegenBetreff(4) <> "" Then
Komma = ", "
Else
Komma = ""
End If
AlleKollegenBetreff(4) = AlleKollegenBetreff(4) & Komma & BetreffOrig
AlleKollegenFarbe(4) = "lightcoral"


ElseIf Betreff <> Replace(Betreff, "lieb", "") Then
If AlleKollegenBetreff(5) <> "" Then
Komma = ", "
Else
Komma = ""
End If
AlleKollegenBetreff(5) = AlleKollegenBetreff(5) & Komma & BetreffOrig
AlleKollegenFarbe(5) = "Turquoise"


ElseIf Betreff <> Replace(Betreff, "schön", "") Then
If AlleKollegenBetreff(6) <> "" Then
Komma = ", "
Else
Komma = ""
End If
AlleKollegenBetreff(6) = AlleKollegenBetreff(6) & Komma & BetreffOrig
AlleKollegenFarbe(6) = "yellow"


ElseIf Betreff <> Replace(Betreff, "mustermann", "") Then
If AlleKollegenBetreff(7) <> "" Then
Komma = ", "
Else
Komma = ""
End If
AlleKollegenBetreff(7) = AlleKollegenBetreff(7) & Komma & BetreffOrig
AlleKollegenFarbe(7) = "Blue"


ElseIf Betreff <> Replace(Betreff, "müller", "") Then
If AlleKollegenBetreff(8) <> "" Then
Komma = ", "
Else
Komma = ""
End If
AlleKollegenBetreff(8) = AlleKollegenBetreff(8) & Komma & BetreffOrig
AlleKollegenFarbe(8) = "green"
End If


          End If
     End With
   
 Set myOlAppointment = myOlAppointments.FindNext
 Wend
   
   
i = 1
While i <= UBound(AlleKollegenFarbe)
msg = msg & "<span style='color:" & AlleKollegenFarbe(i) & "' title='" & AlleKollegenBetreff(i) & "'>&FilledSmallSquare;</span>"
AlleKollegenFarbe(i) = col
AlleKollegenBetreff(i) = ""
i = i + 1
Wend

msg = msg & "</td></tr>" & vbCrLf
       
     data = data + 1
     strActMonat = Format(data, "mm")
   
    Loop
   
   
    ' nächster Monat
    intMonat = intMonat + 1
   
    msg = msg & "</table>" & vbCrLf & "</td></tr></table>" & vbCrLf
   
    If intMonat <= intMaxMonate Then
    msg = msg & "</td><td valign=top>" & vbCrLf
    End If
   
   
  Next intSpalte
 


    msg = msg & "</td></tr></table>" & vbCrLf & "</body></html>"



'*** Ausgabe in Textdatei

Dim Dateiname
Dateiname = "D:\kalender.html"

Set MyFSO = CreateObject("Scripting.FileSystemObject")
Set Datei = MyFSO.OpenTextFile(Dateiname, 2, True)
Datei.Write (msg)
Datei.Close


'*** Öffnen der Textdatei
Dim WshShell As Object
Set WshShell = CreateObject("Wscript.Shell")
WshShell.Run Dateiname


  Set myOlApp = Nothing
  Set myOlSpace = Nothing
  Set myOlFolder = Nothing
  Set myOlAppointments = Nothing
  Set myOlAppointment = Nothing

End Sub
Gast
 

Re: VBA: Alle Termine eines mehrtägigen Zeitraums mit recurr

Beitragvon mmarkus » 31. Mai 2019, 12:43

Hallo Andrea,
als erstes solltest du deinen Code mal in eine sinnvolle Form bringen.
Es ist doch eine Zumutung, wenn man sich durch so einen "Saucode" arbeiten soll, bei dem man nicht mit einem Blick klare Strukturen erkennen kann.

Danach solltest du auch noch mit eigenen Worten erklären, was der genaue Sinn ist, damit klar ist, was wirklich benötigt wird.
Grundsätzlich muss es ja das Ziel sein, mit einer einzigen Abfrage eine brauchbare Datenbasis zu erhalten und danach alle unnötigen Prüfen weg zu lassen.

Dann die wesentliche Frage - verstehst du den Code vollständig?
ms access what else
mmarkus
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 1578
Registriert: 16. Apr 2012, 16:07
Wohnort: Oberösterreich

Re: VBA: Alle Termine eines mehrtägigen Zeitraums mit recurr

Beitragvon Gast » 31. Mai 2019, 19:48

Danke, dass Du Dir die Zeit genommen hast, zu antworten. :-)
Ich habe die Lösung inzwischen selbst gefunden.

Viele Grüße

Andrea
Gast
 


Zurück zu Outlook Forum (provisorisch)

Wer ist online?

Mitglieder in diesem Forum: 0 Mitglieder und 4 Gäste