unit uoutlook;

{$mode objfpc}{$H+}

{Startet ein nicht gestartetes Outlook indm zuerst versucht wird ein
 bereits offenes (aktives) Outlook zu finden und bei Misserfolg Outlook zu starten
try
 Outlook := GetActiveOleObject('Outlook.Application');
except
 Outlook := CreateOleObject('Outlook.Application');
end;

Leider klappt das nicht !!! deswegen ist diese Funktion mit einem define gesichert

Um die Option einzuschalten, den Punkt entfernen
}
{.$DEFINE STARTOUTLOOK}

interface

const
  //RecurrencyType
  olRecursDaily = 0;   //Stellt ein tägliches Serienmuster dar.
  olRecursMonthly = 2; //Stellt ein monatliches Serienmuster dar.
  olRecursMonthNth = 3;//Stellt ein "jeden n-ten Monat"-Serienmuster dar.
                       //Siehe RecurrencePattern.Instance-Eigenschaft.
  olRecursWeekly = 1;  //Stellt ein wöchentliches Serienmuster dar.
  olRecursYearly = 5;  //Stellt ein jährliches Serienmuster dar.
  olRecursYearNth = 6; //Stellt ein "jedes n-te Jahr"-Serienmuster dar.
                       //Siehe RecurrencePattern.Instance-Eigenschaft.

  olAppointmentItem = $00000001;

  olImportanceLow = 0;
  olImportanceNormal = 1;
  olImportanceHigh = 2;

  olText = 1;

  olCategoryColorBlack = 15;//Schwarz
  olCategoryColorBlue = 8;// Blau
  olCategoryColorDarkBlue = 23;// Dunkelblau
  olCategoryColorDarkGray = 14;// Dunkelgrau
  olCategoryColorDarkGreen = 20;// Dunkelgrün
  olCategoryColorDarkMaroon = 25;// Dunkles Kastanienbraun
  olCategoryColorDarkOlive = 22;// Dunkles Olivgrün
  olCategoryColorDarkOrange = 17;// Dunkelorange
  olCategoryColorDarkPeach = 18;// Pfirsich dunkel
  olCategoryColorDarkPurple = 24;// Dunkles Lila
  olCategoryColorDarkRed = 16;// Dunkelrot
  olCategoryColorDarkSteel = 12;// Dunkles Stahlblau
  olCategoryColorDarkTeal = 21;// Dunkles Blaugrün
  olCategoryColorDarkYellow = 19;// Dunkelgelb
  olCategoryColorGray = 13;// Grau
  olCategoryColorGreen = 5;// Grün
  olCategoryColorMaroon = 10;// Braun
  olCategoryColorNone = 0;// Keine Farbe zugewiesen.
  olCategoryColorOlive = 7;// Olivgrün
  olCategoryColorOrange = 2;// Orange
  olCategoryColorPeach = 3;// Pfirsichfarbe
  olCategoryColorPurple = 9;// Lila
  olCategoryColorRed = 1;// Rot
  olCategoryColorSteel = 11;// Stahlblau
  olCategoryColorTeal = 6;// Blaugrün
  olCategoryColorYellow = 4;// Gelb

  olCategoryShortcutKeyCtrlF10 = 10; //STRG+F10
  olCategoryShortcutKeyCtrlF11 = 11; //STRG+F11
  olCategoryShortcutKeyCtrlF12 = 12; //STRG+F12
  olCategoryShortcutKeyCtrlF2 = 2; //STRG+F2
  olCategoryShortcutKeyCtrlF3 = 3; //STRG+F3
  olCategoryShortcutKeyCtrlF4 = 4; //STRG+F4
  olCategoryShortcutKeyCtrlF5 = 5; //STRG+F5
  olCategoryShortcutKeyCtrlF6 = 6; //STRG+F6
  olCategoryShortcutKeyCtrlF7 = 7; //STRG+F7
  olCategoryShortcutKeyCtrlF8 = 8; //STRG+F8
  olCategoryShortcutKeyCtrlF9 = 9; //STRG+F9
  olCategoryShortcutKeyNone = 0; //Keine Tastenkombination angegeben.

  olFolderCalendar = 9; //The Calendar folder.
  olFolderContacts = 10; //The Contacts folder.
  olFolderDeletedItems = 3; //The Deleted Items folder.
  olFolderDrafts = 16; //The Drafts folder.
  olFolderInbox = 6; //The Inbox folder.
  olFolderJournal = 11; //The Journal folder.
  olFolderJunk = 23; //The Junk E-Mail folder.
  olFolderNotes = 12; //The Notes folder.
  olFolderOutbox = 4; //The Outbox folder.
  olFolderSentMail = 5; //The Sent Mail folder.
  olFolderSuggestedContacts = 30; //The Suggested Contacts folder.
  olFolderTasks = 13; //The Tasks folder.
  olFolderToDo = 28; //The To Do folder.
  olFolderRssFeeds = 25; //  The RSS Feeds folder.

  //Only available for an Exchange account:
  olPublicFoldersAllPublicFolders = 18;  // The All Public Folders folder in the Exchange Public Folders store.
  olFolderConflicts = 19;   //The Conflicts folder (subfolder of the Sync Issues folder)
  olFolderSyncIssues = 20;   //The Sync Issues folder
  olFolderLocalFailures = 21;   //The Local Failures folder (subfolder of the Sync Issues folder)
  olFolderServerFailures = 22;  //The Server Failures folder (subfolder of the Sync Issues folder)
  olFolderManagedEmail = 29;    //The top-level folder in the Managed Folders group.
                                //For more information on Managed Folders, see the Help in Microsoft Outlook.
type
  TOLAppointment = record
    calendername: string;
    subject: string;
    body: string;
    start: TDatetime;                    //Start des termins
    endofappt: TDatetime;                //Ende des termins
    duration: integer;
    ReminderSet: boolean;
    ReminderMinutesBeforeStart: integer;
    Location: string;
    Categories: string;
    CategoriesColor: integer;
    recurrency_RecurrenceType: integer;
    recurrency_duration: integer;
    recurrency_Ocurrencies: integer;           //Anzahl der Wiederholungen
    recurrency_PatternStartDate: TDateTime;
    recurrency_PatternEndDate: TDateTime;
    UserProperties_MySource: string;
    UserProperties_MyID: string
  end;




procedure OL_FillStandardApptRecord(rAppt: TOLAppointment);
function OL_GetMyRootFolder(const sStoreName: string): olevariant;
function OL_CreateNewAppointment(rAppt: TOLAppointment): olevariant;
function OL_TestReadAllAppointmentItems(const TheFolder: string = 'Kalender'): string;
function OL_DeleteAllAppsInFolder(const TheFolder: string = 'Kalender'): string;
function OL_CategoryExists(sCategoryName: string; bCreateMissingCategory: boolean = False;
  iCategoryColor: integer = olCategoryColorNone;
  iCategoryShortcutKey: integer = olCategoryShortcutKeyNone): boolean;
//function OL_CategoryExists(const sCategory: String):boolean;
function OL_ListCategories:string;

implementation

uses
  Classes, SysUtils, Variants, comobj;

{Füllt den Terminrecord mit Standardwerten}
procedure OL_FillStandardApptRecord(rAppt: TOLAppointment);
begin
  with rAppt do
  begin
    calendername := 'initcalendar';
    subject := 'no subject';
    body := 'standardbody';
    start := now;                    //Start des Termins
    endofappt := now;                //Ende des Termins
    duration := 10;
    //RequiredAttendees = "Name"
    //ResponseRequested = True
    //MeetingStatus = olMeeting
    ReminderSet := False;
    ReminderMinutesBeforeStart := 0;
    Location := 'No Location';
    Categories := 'No Categories';
    CategoriesColor:=olCategoryColorBlue;
    recurrency_RecurrenceType := 0;
    recurrency_duration := 0;
    recurrency_Ocurrencies := 0;           //Anzahl der Wiederholungen
    recurrency_PatternStartDate := now;
    recurrency_PatternEndDate := now;
    //recurrency_Interval = 3   'alle x Intervalle -- etwa alle drei Wochen als intervall
    UserProperties_MySource := 'MySource';
    UserProperties_MyID := 'MyID';
  end;
end;

{Testfunktion: Liest alle Outlooktermine aus dem Folder "Kalender" aus}
function OL_TestReadAllAppointmentItems(const TheFolder: string = 'Kalender'): string;
var
  Outlook: olevariant;
  NameSpace: olevariant;
  CalendarsRoot: olevariant;
  TopFolder: olevariant;
  CalendarFolder: olevariant;
  Termine: olevariant;
  Termin: olevariant;
  olVersion:string;

  //app: OleVariant;
  //filter: String;

  i: integer;
  s: string;
begin
  Result := ' CalendarFolder: ' + TheFolder + #13#10 + #13#10;

  {$ifdef STARTOUTLOOK}
  try
    Outlook := GetActiveOleObject('Outlook.Application');
  except
    Outlook := CreateOleObject('Outlook.Application');
  end;
  {$else}
  Outlook := CreateOleObject('Outlook.Application');
  {$endif}

  olVersion:=Outlook.Version;


  NameSpace := Outlook.GetNameSpace('MAPI');

  TopFolder := NameSpace.Folders[1];

  {Foldernamen der eigenen Situation anpassen}
  CalendarFolder := TopFolder.Folders(olevariant(TheFolder));
  //Termine := NameSpace.GetDefaultFolder(olFolderCalendars);


  //CalendarsRoot := NameSpace.GetDefaultFolder(olFolderCalendars);
  CalendarsRoot := OL_GetMyRootFolder(TheFolder);

  //Termine := NameSpace.GetDefaultFolder(9);

  Termine := CalendarsRoot.Items;

  if Termine.Count > 0 then
  begin
    Result:=result + 'Outlook Version: '+olVersion + #13#10;
    Result := Result + '  Bearbeite Termine: ' + IntToStr(Termine.Count) + #13#10;
    //for i := 1 to Termine.Items.Count do
    try
      for i := 1 to Termine.Count do
      begin
        Termin := Termine.Item(i);
        // Titel des Termins und Startdatum mit Zeit auslesen:
        //  memo1.lines.add(DateTimeToStr (Termin.Start) );


        Result := Result + DateTimeToStr(Termin.Start) + '  ';     //<<<<< unbekannter Fehler

        //result:=result + ' bis ' + DateTimeToStr (Termin.End)+ ': ';
        Result := Result + Termin.Subject + ', ';
        Result := Result + Termin.Location + ', ';
        // result:=result + Termin.Body;

        Result := Result + #13#10;
      end;
    finally

    end;

  end
  else
    Result := Result + 'No Appointments found' + #13#10;

  Outlook := Unassigned;
  NameSpace := Unassigned;
  CalendarsRoot := Unassigned;
  TopFolder := Unassigned;
  CalendarFolder := Unassigned;
  Termine := Unassigned;
  Termin := Unassigned;

end;

{Löscht alle Termine in einem bestimmten Folder}
function OL_DeleteAllAppsInFolder(const TheFolder: string): string;
var
  Outlook: olevariant;
  NameSpace: olevariant;
  CalendarsRoot: olevariant;
  TopFolder: olevariant;
  CalendarFolder: olevariant;
  Termine: olevariant;
  Termin: olevariant;

  //app: OleVariant;
  //filter: String;

  i: integer;
  s: string;
begin
  Result := ' Lösche Termine im Folder: ' + TheFolder + #13#10 + #13#10;

  {$ifdef STARTOUTLOOK}
  try
    Outlook := GetActiveOleObject('Outlook.Application');
  except
    Outlook := CreateOleObject('Outlook.Application');
  end;
  {$else}
  Outlook := CreateOleObject('Outlook.Application');
  {$endif}

  //KN NameSpace := Outlook.GetNameSpace('MAPI');

  //KN TopFolder := NameSpace.Folders[1];

  {Foldernamen der eigenen Situation anpassen}
  //CalendarFolder := TopFolder.Folders(olevariant(TheFolder));
  //Termine := NameSpace.GetDefaultFolder(olFolderCalendars);


  //CalendarsRoot := NameSpace.GetDefaultFolder(olFolderCalendars);
  CalendarsRoot := OL_GetMyRootFolder(TheFolder);
  if not VarIsNull(CalendarsRoot) and not VarIsEmpty(CalendarsRoot) then
  begin



  //Termine := NameSpace.GetDefaultFolder(9);
    Termine := CalendarsRoot.Items;

    Result := Result + #13#10+ 'Gefundene Items: '+ inttostr(CalendarsRoot.Items.Count) + #13#10;

    //for i := 1 to Termine.Items.Count do
    for i := CalendarsRoot.Items.Count downto 1 do
    begin

      //Termin := Termine.Item(i);

      // Titel des Termins und Startdatum mit Zeit auslesen:
      //  memo1.lines.add(DateTimeToStr (Termin.Start) );

      Result := Result + '  lösche Item ' + inttostr(i) + #13#10;
    //  result := result + DateTimeToStr(Termin.Start) + '  ';
      ////result:=result + ' bis ' + DateTimeToStr (Termin.End)+ ': ';
      //result := result + Termin.Subject + ', ';
      //result := result + Termin.Location + ', ';
      // result:=result + Termin.Body;



      //Termin.Delete;
      CalendarsRoot.Items[i].Delete;
      Result := Result + '      gelöscht' + #13#10;
    end;


  end;


  Outlook := Unassigned;
  NameSpace := Unassigned;
  CalendarsRoot := Unassigned;
  TopFolder := Unassigned;
  CalendarFolder := Unassigned;
  //OutlookCalendar:= Unassigned;
  //Appointments:= Unassigned;
  Termine := Unassigned;
  Termin := Unassigned;

end;


{ Prüft ob eine Kategorie existiert und falls nicht kann sie auch angelegt werden}
function OL_CategoryExists(sCategoryName: string; bCreateMissingCategory: boolean;
  iCategoryColor: integer; iCategoryShortcutKey: integer): boolean;
var
  Outlook: olevariant;
  olCategories: olevariant;
  olCategory: olevariant;
  olNameSpace: olevariant;
  i, NumItems: integer;
begin
  {$ifdef STARTOUTLOOK}
  try
    Outlook := GetActiveOleObject('Outlook.Application');
  except
    Outlook := CreateOleObject('Outlook.Application');
  end;
  {$else}
  Outlook := CreateOleObject('Outlook.Application');
  {$endif}

  olNameSpace := Outlook.GetNamespace('MAPI');
  olCategories := olNameSpace.Categories;
  //  numItems := olCategories.Count;
  //numItems := olNameSpace.Categories.Count;  // <<< Method Categories not supported by automation object
  numItems := olCategories.Count;
  {
  laut
  https://msdn.microsoft.com/en-us/library/office/ff863110.aspx
  sollte das eigentlich klappen
  }



  Result := False;

  if numItems > 0 then
  begin
    for i := 1 to numItems do
    begin
      //olCategory := olCategories.Item[i];
      olCategory := olNameSpace.Categories.Item[i];

      // olCategory.Name is the name of the category
      // olCategory.CategoryID is an internal, unique ID for the category
      if olCategory.Name = sCategoryName then
      begin
        Result := True;
        break;
      end;
      olCategory := Unassigned;
    end;
  end;

  if (not Result) then
  begin
    if bCreateMissingCategory then
    begin
      //------------------------------------------------
      // Kategorie erstellen: olCategories.Add
      // Name...string
      // Color..OlCategoryColor  (optional)
      // ShortcutKey.. OlCategoryShortcutKey (optional))
      //------------------------------------------------
      olCategories.Add(olevariant(sCategoryName), iCategoryColor,olCategoryShortcutKeyNone);
      //olCategories.Add(sCategoryName, iCategoryColor);
      Result := True;
    end;
  end;

  olCategory := Unassigned;
  olCategories := Unassigned;
  olNameSpace := Unassigned;
  Outlook := Unassigned;
end;

function OL_ListCategories: string;
var
  Outlook: olevariant;
  olCategories: olevariant;
  olCategory: olevariant;
  olNameSpace: olevariant;
  i, NumItems: integer;
begin
  Outlook := CreateOleObject('Outlook.Application');
  olNameSpace := Outlook.GetNamespace('MAPI');
  numItems := olNameSpace.Categories.Count;
  result:='';
  if numItems > 0 then
  begin
    for i := 1 to numItems do
    begin
      //olCategory := olCategories.Item[i];
      olCategory := olNameSpace.Categories.Item[i];

      result:=result+ olCategory.Name + ' ' + olCategory.CategoryID+ '   Color: ' + inttostr(olCategory.Color) + #13#10;

      // olCategory.Name is the name of the category
      // olCategory.CategoryID is an internal, unique ID for the category
      olCategory := Unassigned;
    end;
  end;
  {
  Private Sub ListCategoryIDs()
 Dim objNameSpace As NameSpace
 Dim objCategory As Category
 Dim strOutput As String

 ' Obtain a NameSpace object reference.
 Set objNameSpace = Application.GetNamespace("MAPI")

 ' Check if the Categories collection for the Namespace
 ' contains one or more Category objects.
 If objNameSpace.Categories.Count > 0 Then

 ' Enumerate the Categories collection.
 For Each objCategory In objNameSpace.Categories

 ' Add the name and ID of the Category object to
 ' the output string.
 strOutput = strOutput & objCategory.Name & _
 ": " & objCategory.CategoryID & vbCrLf
 Next
 End If

 ' Display the output string.
 MsgBox strOutput

 ' Clean up.
 Set objCategory = Nothing
 Set objNameSpace = Nothing

  }
    olCategory := Unassigned;
  olCategories := Unassigned;
  olNameSpace := Unassigned;
  Outlook := Unassigned;
end;



function OL_GetMyRootFolder(const sStoreName: string): olevariant;
var
  Outlook: olevariant;
  NameSpace: olevariant;
  CalendarsRoot: olevariant;
  CalendarsParent: olevariant;
  i: integer;
begin
  {$ifdef STARTOUTLOOK}
  try
    Outlook := GetActiveOleObject('Outlook.Application');
  except
    Outlook := CreateOleObject('Outlook.Application');
  end;
  {$else}
  Outlook := CreateOleObject('Outlook.Application');
  {$endif}

  NameSpace := Outlook.GetNameSpace('MAPI');
  CalendarsRoot := NameSpace.GetDefaultFolder(9);
  CalendarsParent := CalendarsRoot.Parent;

  for i := 1 to CalendarsParent.folders.Count do
  begin
    //memo1.lines.add(CalendarsParent.folders.Item(i).Name);

    if CalendarsParent.folders.Item(i).Name = sStoreName then
    begin
      Result := CalendarsParent.folders.Item(i);
      exit;
    end;
  end;

  //Wenn bis hier kein Folder gefunden wurde, erstelle einen neuen;
  //memo1.lines.add('lege kalender an :' + edit1.text);

  //result:= CalendarsParent.folders.Add(OLEVariant(sStoreName), 9);
  Result := CalendarsParent.folders.Add(olevariant(sStoreName), olFolderCalendar);

  Outlook := Unassigned;
  NameSpace := Unassigned;
  CalendarsRoot := Unassigned;
  CalendarsParent := Unassigned;
end;

{Legt einen neuen Termin an -- Daten dazu im übergebenen Record}
function OL_CreateNewAppointment(rAppt: TOLAppointment): olevariant;
var
  Outlook: olevariant;
  NameSpace: olevariant;
  MyCalendarsRoot: olevariant;
  Appointment: olevariant;
  myRecurrPatt: olevariant;
  prop: olevariant;
begin
  {$ifdef STARTOUTLOOK}
  try
    Outlook := GetActiveOleObject('Outlook.Application');
  except
    Outlook := CreateOleObject('Outlook.Application');
  end;
  {$else}
  Outlook := CreateOleObject('Outlook.Application');
  {$endif}

  NameSpace := Outlook.GetNameSpace('MAPI');
  MyCalendarsRoot := OL_GetMyRootFolder(rAppt.calendername);

  {if Contacts folder is found}
  if not VarIsNull(MyCalendarsRoot) and not VarIsEmpty(MyCalendarsRoot) then
  begin
    {create a new item}
    //appointment := MyCalendarsRoot.Items.Add(olAppointmentItem);
    appointment := MyCalendarsRoot.Items.Add;

    {define a subject and body of appointment}
    appointment.Subject := olevariant(rAppt.subject);
    appointment.Body := olevariant(rAppt.body);

    {location of appointment}
    appointment.Location := olevariant(rAppt.Location);

    {duration: 10 days starting from today}
    appointment.Start := rAppt.start;


    //appointment.Start:= DateToStr(rAppt.start) + ' ' + TimeToStr(rAppt.start);

    //appointment.End := Now()+1; {1 days for execution}
    //appointment.AllDayEvent := 1; {all day event}

    {set reminder}
    //appointment.ReminderMinutesBeforeStart := rAppt.ReminderMinutesBeforeStart;
    //appointment.ReminderSet := boolToInt(rAppt.ReminderSet);
    {set reminder in 20 minutes}
    //appointment.ReminderMinutesBeforeStart := 20;
    //appointment.ReminderSet := 1;

    {set a high priority}
    //appointment.Importance := olImportanceHigh;

    {add a few recipients}
    //appointment.Recipients.Add('person1@domain.com');
    //appointment.Recipients.Add('person2@domain.com');

    {change an organizer name}
    //appointment.Organizer := 'organizer@domain.com';

    //Nimmt dzt. keine Rücksicht auf mehrere Kategorien durch Komma getrennt
    if rAppt.Categories <> '' then
      if OL_CategoryExists(rAppt.Categories, true, rAppt.CategoriesColor) then
        appointment.Categories := olevariant(rAppt.Categories);

    //********** Recurrence Pattern ******************
    myRecurrPatt := appointment.GetRecurrencePattern;

    if rAppt.recurrency_RecurrenceType = -1 then
      myRecurrPatt.RecurrenceType := olRecursWeekly     ///'olRecursDaily
    else
      myRecurrPatt.RecurrenceType := rAppt.recurrency_RecurrenceType;

    //    If Nz(rs![DayOfWeekMask], "") <> "" Then
    //        'myRecurrPatt.DayOfWeekMask = rs![DayOfWeekMask]
    //    Else
    //        'myRecurrPatt.DayOfWeekMask = olMonday   '.DayOfWeekMask = olMonday Or olWednesday Or olFriday
    //    End If


    // Outlook.OlRecurrenceType.olRecursWeekly;

    myRecurrPatt.Duration := rAppt.recurrency_duration;
  //  myRecurrPatt.Occurrences := rAppt.recurrency_Ocurrencies;

    myRecurrPatt.PatternStartDate := rAppt.recurrency_PatternStartDate;
    myRecurrPatt.PatternEndDate := rAppt.recurrency_PatternEndDate;


    //********** User Properties ***************
    //https://msdn.microsoft.com/en-us/library/bb608929.aspx

    //prop := appointment.UserProperties.Add('MySource', olText, True);
    //prop.Value := olevariant(rAppt.UserProperties_MySource);
    //
    //prop := appointment.UserProperties.Add('MyID', olText, True);
    //prop.Value := olevariant(rAppt.UserProperties_MyID);

    //appointment.UserProperties.Add "MySource", olText
    //appointment.UserProperties("MySource").Value = sSource

    //appointment.UserProperties.Add( 'MyID', olText);
    //appointment.UserProperties("MyID").Value = sTheID


    {to save an appointment}
    appointment.Save;

    //{to display an appointment}
    //appointment.Display(True);

    //{to print a form}
    //appointment.PrintOut;
  end;

  Outlook := Unassigned;              //free all used resources
  NameSpace := Unassigned;
  MyCalendarsRoot := Unassigned;
  Appointment := Unassigned;
  myRecurrPatt := Unassigned;
  prop := Unassigned;
end;

end.