unit CalPopup;

interface

uses
	Windows, Classes, Controls, Graphics, Forms, SysUtils, ExtCtrls, Dialogs;

type
	TPopup = class(TForm)
		procedure frmDblClick(Sender: TObject);
		procedure frmPaint(Sender: TObject);
		procedure frmOnContextPopup(Sender: TObject; MousePos: TPoint; var Handled: Boolean);
		procedure FormCreate(Sender: TObject);
		procedure frmOnShow(Sender: TObject);
		procedure FormMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
		procedure FormDestroy(Sender: TObject);
	private     
		fAppt: TStrings;
		fStoreID, fEntryID, fTitle, fFontName, fWav, fImagePath, Ext: String;
		fRC, fFontSize, fTimeTill: Integer;
		fBGColor, fBorderColor, fFontColor: TColor;
		fUseImage, fSetup, fReminder, fFitImage: Boolean;
		Timer: TTimer;
		procedure OnTimer(Sender: TObject); virtual;
		procedure SetImagePath(Value: String);
		procedure LoadReg;      
    procedure SetStrings(Value: TStrings);
	public
		Function Execute: Boolean;
	published
		property Setup: Boolean read fSetup write fSetup;
		property IsReminder: Boolean read fReminder write fReminder;
		Property StoreID: String read fStoreID write fStoreID;
		Property EntryID: String read fEntryID write fEntryID;
		property Title: string read fTitle write fTitle;
		property Appt: TStrings read fAppt write SetStrings;
		Property TimeTill: Integer read fTimeTill write fTimeTill;
		property BGColor: TColor read fBGColor write fBGColor;
		property BorderColor: TColor read fBorderColor write fBorderColor;
		property RoundCorners: Integer read fRC write fRC;
		property FontName: string read fFontName write fFontName;
		property FontColor: TColor read fFontColor write fFontColor;
		property FontSize: Integer read fFontSize write fFontSize;
		Property ImagePath: String read fImagePath write SetImagePath;
		Property FitImage: Boolean read fFitImage write fFitImage;
		Property Wav: String read fWav write fWav;
	end;   

const
  RegPath = '\Software\The Coolmon Project\Calender';

var
	Popup: TPopup;

implementation
              
{$R *.dfm}

Uses
	OutlookXP, PNGImage, Jpeg, MMSystem, Registry;

Function TPopup.Execute: Boolean;
begin
	Result := (ShowModal = mrOK);
end;

procedure TPopup.SetStrings(Value: TStrings);
begin
  fAppt.Clear;
  fAppt.Assign(Value);
end;

procedure TPopup.FormCreate(Sender: TObject);
var
	ExtendedStyle: Integer;
begin
	ExtendedStyle := GetWindowLong(self.Handle, GWL_EXSTYLE);
	SetWindowLong(self.Handle, GWL_EXSTYLE, ExtendedStyle or WS_EX_TOOLWINDOW and not WS_EX_APPWINDOW);

  fAppt := TStringList.Create;

	LoadReg;
end;

procedure TPopup.LoadReg;
var         
	Reg: TRegistry;
begin
	fFontColor := clWhite;

	if fSetup then
		Exit;

	Reg := TRegistry.Create;
  with Reg do
	try
		if OpenKey(RegPath, False) then
		begin
      if fReminder then
      begin
        fBGColor := StringToColor(ReadString('rBGColor'));
        fBorderColor := StringToColor(ReadString('rBorderColor'));
        fFontName := ReadString('rFontName');
        fFontSize := ReadInteger('rFontSize');
        fFontColor := StringToColor(ReadString('rFontColor'));
        fRC := ReadInteger('rRoundCorners');
        if UpperCase(ReadString('UseBGImage')) = 'TRUE' then
        begin
          SetImagePath(ReadString('rBGImage'));
          if UpperCase(ReadString('rFitImage')) = 'TRUE' then
            fFitImage := True;
        end;
      end
        else
      begin
        fBGColor := StringToColor(ReadString('TTBGColor'));
        fBorderColor := StringToColor(ReadString('TTBorderColor'));
        fFontName := ReadString('TTFontName');
        fFontSize := ReadInteger('TTFontSize');
        fFontColor := StringToColor(ReadString('TTFontColor'));
        fRC := ReadInteger('TTRoundCorners');
      end;

      CloseKey;
		end;
	finally
		Reg.Free;
	end;
end;

procedure TPopup.frmDblClick(Sender: TObject);
begin
	self.Close;
end;

procedure TPopup.frmPaint(Sender: TObject);
var
	i, tw, th, p1, p2, tmp: Integer;
	IMG: TGraphic;
	strMin, strTime: String;
	aPoint: TPoint;
begin
	if fReminder then
	begin
		strTime := 'Time is ' + FormatDateTime('h:mm am/pm', Now);
		strMin := 'Due in ' + IntToStr(fTimeTill) + ' Minutes';

		With Canvas do
		begin
			Font.Name := fFontName;
			Font.Size := fFontSize;
			Font.Color := fFontColor;
			Font.Style := [fsBold];
			tw := TextWidth(fTitle);
			th := TextHeight(fTitle);
			self.Width := tw + 30;
			self.Height := th*3 + 40;
			self.Left := (Screen.Width - Width) div 2;
			self.Top := (Screen.Height - Height) div 2;
			Brush.Color := fBGColor;
			Pen.Color := fBorderColor;
			RoundRect(0, 0, Width, Height, fRC, fRC);
			Brush.Style := bsClear;
		end;

		If fUseImage then
		try
			If Ext = '.BMP' then
				IMG := TBitmap.Create
			else if Ext = '.PNG' then
				IMG := TPNGObject.Create
			else
				IMG := TJPEGImage.Create;

      IMG.LoadFromFile(fImagePath);
      If fFitImage then
        Canvas.StretchDraw(Bounds(0, 0, Width, Height), IMG)
      else
        Canvas.Draw(0, 0, IMG);
    finally
      FreeAndNil(IMG);
    end;

		p1 := (Width - tw) div 2;
		p2 := (Height - th) div 2;
		Canvas.TextOut(p1, p2, fTitle);

		tw := Canvas.TextWidth(strTime);
		p1 := (Width - tw) div 2;
		Canvas.TextOut(p1, 5, strTime);

		tw := Canvas.TextWidth(strMin);
		p1 := (Width - tw) div 2;
		Canvas.TextOut(p1, Height -th -5, strMin);
	end
		else
	begin
		with Canvas do
		begin                  
			Font.Name := fFontName;
			Font.Size := fFontSize;
			Font.Color := fFontColor;
			Brush.Color := fBGColor;
			Brush.Style := bsSolid;
			Pen.Color := fBorderColor;
			RoundRect(0 , 0, Width, Height, fRC, fRC);
			Brush.Style := bsClear;
			Pen.Color := fFontColor;
			Font.Style := [fsBold];
			tw := TextWidth(fTitle) + 20;
			TextOut(10, 4, fTitle);
			Font.Style := [];
			th := TextHeight(fTitle);
      for i := 0 to fAppt.Count -1 do
      begin
        tmp := TextWidth(fAppt[i]) + 10;
        if tmp > tw then
          tw := tmp;
        MoveTo(8, th+6);
        LineTo(Width - 8, th+6);
        TextOut(5, ((th+1)*i)+(th+8), fAppt[i]);
      end;
		end;
                
		Width := tw;
    if fAppt.Count > 0 then
		  Height := th * (fAppt.Count + 1) +13
    else
      Height := th + 9;

		GetCursorPos(aPoint);
		if aPoint.Y - Height + 3 < 0 then
			Top := 2
		else
			Top := aPoint.Y - Height + 3;
		if aPoint.X + (Width div 2) > Screen.Width then
			Left := Screen.Width - Width - 2
		else if aPoint.X - (Width div 2) < 0 then
			Left := 2
		else
			Left := aPoint.X - (Width div 2);

		Timer := TTimer.Create(self);
		Timer.Interval := 30 * 1000;
		Timer.OnTimer := OnTimer;
		Timer.Enabled := True;
	end;
end;         

procedure TPopup.OnTimer(Sender: TObject);
begin
	FreeAndNil(Timer);

	self.Close;
end;

procedure TPopup.frmOnContextPopup(Sender: TObject; MousePos: TPoint; var Handled: Boolean);
var
	Ol: TOutlookApplication;
	NmSpace: NameSpace;
	Appt: AppointmentItem;
	fileName, Profile, Pass: String;
	cFile: TextFile;
begin
	If Not fReminder or (fEntryID = '') then
	begin
		self.Close;
		exit;
	end;
	fileName := 'Calender.txt';
	Profile := '';
	Pass := '';

	try
		Ol := TOutlookApplication.Create(Nil);
		Ol.Connect;
		NmSpace := Ol.GetNamespace('MAPI');
		If FileExists(fileName) then
		begin
			AssignFile(cFile, fileName);
			Reset(cFile);
			try
				ReadLn(cFile, Profile);
				ReadLn(cFile, Pass);
			finally
				CloseFile(cFile);
			end;
		end;
		NmSpace.Logon(Profile, Pass, False, False);

		Appt := NmSpace.GetItemFromID(fEntryID, fStoreID) as _AppointmentItem;
		Appt.Display(False);
  finally
		Appt := Nil;
		NmSpace.Logoff;
		Ol.Disconnect;
		FreeAndNil(Ol);
	end;

	self.Close;
end;

procedure TPopup.frmOnShow(Sender: TObject);
begin
  SetWindowPos(self.Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE);

	try
		If (fWav <> '') and ( FileExists(fWav) ) then
			PlaySound(PChar(fWav), 0, SND_ASYNC);
	except
	end;
end;       

Procedure TPopup.SetImagePath(Value: String);
begin
	If Not FileExists(Value) then
		Exit;

	Ext := UpperCase(ExtractFileExt(Value));
	If (Ext = '.BMP') or (Ext = '.PNG') or (Ext = '.JPG') or (Ext = '.JPEG') then
	begin
		fImagePath := Value;
		fUseImage := True;
	end;
end;

Procedure TPopup.FormMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
	if not fReminder then
		self.Close;
end;

procedure TPopup.FormDestroy(Sender: TObject);
begin
	FreeAndNil(Timer);
  fAppt.Free;
end;

end.
