home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue62 / outlook / Weblook / WebModule.pas < prev   
Encoding:
Pascal/Delphi Source File  |  2000-08-10  |  10.0 KB  |  275 lines
  1. unit WebModule;
  2.  
  3. interface
  4.  
  5. uses
  6.   Windows, Messages, SysUtils, Classes, HTTPApp;
  7.  
  8. Const
  9.   ciStartOfWeek = 1; { The leftmost day name in the HTML calendar: Sunday = 0, Monday = 1 }
  10.   ciFirstYear   = 1990;
  11.   ciLastYear    = 2020;
  12.   strPipeName   = '\\.\pipe\weblook_tdm_version_1';
  13.  
  14. type
  15.   TCalendarGrid = Array[0..6,1..6] of String;
  16.  
  17.   TWeblookWM = class(TWebModule)
  18.     procedure WeblookWMDefaultActionAction(Sender: TObject;
  19.       Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  20.     procedure WeblookWMCalendarAction(Sender: TObject;
  21.       Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  22.     procedure WeblookWMContactsAction(Sender: TObject;
  23.       Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  24.     procedure WeblookWMTasksAction(Sender: TObject; Request: TWebRequest;
  25.       Response: TWebResponse; var Handled: Boolean);
  26.     procedure WeblookWMNotesAction(Sender: TObject; Request: TWebRequest;
  27.       Response: TWebResponse; var Handled: Boolean);
  28.     procedure WeblookWMInboxAction(Sender: TObject; Request: TWebRequest;
  29.       Response: TWebResponse; var Handled: Boolean);
  30.     procedure WeblookWMTodayAction(Sender: TObject; Request: TWebRequest;
  31.       Response: TWebResponse; var Handled: Boolean);
  32.   private
  33.     { Private declarations }
  34.     iYear,iMonth   : Integer;
  35.     cgCalendarGrid : TCalendarGrid;
  36.     hPipe          : THandle;
  37.     Procedure CreateNamedPipe;
  38.     Function ReadPipeRequestResponse(strRequest : String) : String;
  39.   public
  40.     { Public declarations }
  41.   end;
  42.  
  43. var
  44.   WeblookWM: TWeblookWM;
  45.  
  46. implementation
  47.  
  48. uses HTMLTemplates;
  49.  
  50. {$R *.DFM}
  51.  
  52. Procedure ShowDebugMsg(Msg : String);
  53. Begin
  54.   { TIP: use this function for displaying a brief message on the screen! }
  55.   MessageBox(0,PChar('Thread #'+IntToStr(GetCurrentThreadID)+' at '+DateTimeToStr(Now)+':'#13+Msg),
  56.              PChar(ParamStr(0)),mb_Service_Notification+mb_TopMost+mb_OK);
  57. End;
  58.  
  59. procedure TWeblookWM.WeblookWMDefaultActionAction(Sender: TObject;
  60.   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  61. begin
  62.   Response.Content := '<HTML>Invalid DLL call.</HTML>';
  63. end;
  64.  
  65. Procedure TWeblookWM.CreateNamedPipe;
  66. Var iTries : Integer;
  67. Begin
  68.   iTries := 0;
  69.   While (iTries < 3) do Begin
  70.     Inc(iTries);
  71.     hPipe := CreateFile(strPipeName,Generic_Read Or Generic_Write,0,nil,Open_Existing,0,0);
  72.     If (hPipe <> Invalid_Handle_Value) Then Exit; { succesfully opened the pipe }
  73.     If (GetLastError = Error_Pipe_Busy) Then Begin
  74.       { the pipe is busy, so wait 5 seconds for it become available }
  75.       WaitNamedPipe(strPipeName,5*1000);
  76.     End
  77.     Else Raise Exception.Create('Cannot open pipe: '+SysErrorMessage(GetLastError)); { other error occurred }
  78.   End;
  79.   Raise Exception.Create('Timeout reached while opening pipe');
  80. End;
  81.  
  82. Function TWeblookWM.ReadPipeRequestResponse(strRequest : String) : String;
  83. Var
  84.   iBW,iBR   : Cardinal; { bytes written, bytes read }
  85.   cResponse : Array[0..1023] of Char; { 1kB }
  86.  
  87. Begin
  88.   CreateNamedPipe; { create the pipe for reading }
  89.   Result := '';
  90.   If (Not WriteFile(hPipe,Pointer(strRequest)^,Length(strRequest),iBW,nil)) Then { write the request }
  91.     Raise Exception.Create('Cannot write to pipe: '+SysErrorMessage(GetLastError));
  92.   If ReadFile(hPipe,cResponse,SizeOf(cResponse)-1,iBR,nil) Then Begin { read the response }
  93.     cResponse[iBR] := #0; { properly terminate the string }
  94.     Result := String(cResponse);
  95.   End
  96.   Else Raise Exception.Create('Cannot read from pipe: '+SysErrorMessage(GetLastError));
  97.   CloseHandle(hPipe);
  98. End;
  99.  
  100. procedure TWeblookWM.WeblookWMCalendarAction(Sender: TObject;
  101.   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  102. Var
  103.   iCol,iRow,iDay  : Integer;
  104.   strHTML,strRows : String;
  105.   wY,wM,wD        : Word;
  106.  
  107.   Function GetMonthLinkHTML(iMonth,iYear,iDelta : Integer) : String;
  108.   Begin
  109.     iMonth := iMonth+iDelta;
  110.     If (iMonth < 1) Then Begin
  111.       iMonth := 12;
  112.       Dec(iYear);
  113.     End
  114.     Else If (iMonth > 12) Then Begin
  115.       iMonth := 1;
  116.       Inc(iYear);
  117.     End;
  118.     { is the year in range? }
  119.     If (iYear >= ciFirstYear) And (iYear <= ciLastYear) Then
  120.       Result := '<A HREF="/scripts/weblook.dll/calendar?year='+IntToStr(iYear)+'&month='+IntToStr(iMonth)+'">'
  121.     Else Result := '';
  122.     If (iDelta < 0) Then Result := Result+'Previous'
  123.     Else If (iDelta > 0) Then Result := Result+'Next'
  124.     Else Result := Result+'Current';
  125.     If (iYear >= ciFirstYear) And (iYear <= ciLastYear) Then Result := Result+'</A>';
  126.   End;
  127.  
  128. begin
  129.   { check to see which month we should display }
  130.   DecodeDate(Date,wY,wM,wD);
  131.   Try
  132.     iYear := StrToInt(Request.QueryFields.Values['year']);
  133.     If (iYear < ciFirstYear) Or (iYear > ciLastYear) Then iYear := wY;
  134.     iMonth := StrToInt(Request.QueryFields.Values['month']);
  135.     If (iMonth < 1) Or (iMonth > 12) Then iMonth := wM;
  136.   Except
  137.     iYear := wY; { current month }
  138.     iMonth := wM;
  139.   End;
  140.   { clear the calendar grid by setting a non-blocking space for HTML table cells to display }
  141.   For iCol := 0 to 6 do Begin
  142.     For iRow := 1 to 6 do cgCalendarGrid[iCol,iRow] := ' ';
  143.   End;
  144.   { then fill in the day numbers in the calendar grid }
  145.   iCol := DayOfWeek(EncodeDate(iYear,iMonth,1))-1;
  146.   iCol := (iCol-ciStartOfWeek) mod 7;
  147.   If (iCol < 0) Then iCol := 7+iCol;
  148.   iRow := 1;
  149.   For iDay := 1 to MonthDays[IsLeapYear(iYear),iMonth] do Begin
  150.     cgCalendarGrid[iCol,iRow] := IntToStr(iDay)+'<BR>'+
  151.                                  ReadPipeRequestResponse('CALENDAR '+IntToStr(Trunc(EncodeDate(iYear,iMonth,iDay))));
  152.     Inc(iCol);
  153.     If (iCol > 6) Then Begin
  154.       iCol := 0;
  155.       Inc(iRow);
  156.     End;
  157.   End;
  158.   { finally generate the HTML code for the calendar }
  159.   strHTML := StringReplace(cstrCalendarHTML,'%month%',LongMonthNames[iMonth]+' '+IntToStr(iYear),[]);
  160.   { create the previous and next links }
  161.   strHTML := StringReplace(strHTML,'%prev%',GetMonthLinkHTML(iMonth,iYear,-1),[]);
  162.   strHTML := StringReplace(strHTML,'%next%',GetMonthLinkHTML(iMonth,iYear,+1),[]);
  163.   strHTML := StringReplace(strHTML,'%current%',GetMonthLinkHTML(wM,wY,0),[]);
  164.   { create the table content }
  165.   For iRow := 1 to 6 do Begin
  166.     strRows := strRows+'  <TR>'+CRLF;
  167.     For iCol := 0 to 6 do Begin
  168.       strRows := strRows+'    <TD WIDTH="102"><FONT SIZE="2" FACE="Arial, Helvetica, sans-serif">'+
  169.                  cgCalendarGrid[iCol,iRow]+'</FONT></TD>'+CRLF;
  170.     End;
  171.     strRows := strRows+'  </TR>'+CRLF;
  172.   End;
  173.   strHTML := StringReplace(strHTML,'%rows%',strRows,[]);
  174.   Response.Content := strHTML;
  175. end;
  176.  
  177. procedure TWeblookWM.WeblookWMContactsAction(Sender: TObject;
  178.   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  179. Var
  180.   iIndex,iCount : Integer;
  181.   strRows       : String;
  182.  
  183. begin
  184.   iCount := StrToInt(ReadPipeRequestResponse('CONTACT COUNT'));
  185.   For iIndex := 0 to iCount-1 do Begin
  186.     If ((iIndex mod 3) = 0) Then Begin
  187.       If (iIndex > 0) Then strRows := strRows+'  </TR>'+CRLF;
  188.       strRows := strRows+'  <TR VALIGN="TOP">'+CRLF;
  189.     End;
  190.     strRows := strRows+'    <TD WIDTH="33%"><FONT FACE="Arial, Helvetica, sans-serif" SIZE="2">'+CRLF+
  191.                ReadPipeRequestResponse('CONTACT '+IntToStr(iIndex))+CRLF+'</FONT></TD>'+CRLF;
  192.   End;
  193.   Response.Content := StringReplace(cstrContactsHTML,'%rows%',strRows,[]);
  194. end;
  195.  
  196. procedure TWeblookWM.WeblookWMTasksAction(Sender: TObject;
  197.   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  198. Var
  199.   iIndex,iCount : Integer;
  200.   strRows       : String;
  201.  
  202. begin
  203.   iCount := StrToInt(ReadPipeRequestResponse('TASK COUNT'));
  204.   For iIndex := 0 to iCount-1 do Begin
  205.     If ((iIndex mod 3) = 0) Then Begin
  206.       If (iIndex > 0) Then strRows := strRows+'  </TR>'+CRLF;
  207.       strRows := strRows+'  <TR VALIGN="TOP">'+CRLF;
  208.     End;
  209.     strRows := strRows+'    <TD WIDTH="33%"><FONT FACE="Arial, Helvetica, sans-serif" SIZE="2">'+CRLF+
  210.                ReadPipeRequestResponse('TASK '+IntToStr(iIndex))+CRLF+'</FONT></TD>'+CRLF;
  211.   End;
  212.   Response.Content := StringReplace(cstrTasksHTML,'%rows%',strRows,[]);
  213. end;
  214.  
  215. procedure TWeblookWM.WeblookWMNotesAction(Sender: TObject;
  216.   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  217. Var
  218.   iIndex,iCount : Integer;
  219.   strRows       : String;
  220.  
  221. begin
  222.   iCount := StrToInt(ReadPipeRequestResponse('NOTE COUNT'));
  223.   For iIndex := 0 to iCount-1 do Begin
  224.     strRows := strRows+'  <TR VALIGN="TOP">'+CRLF+
  225.                ReadPipeRequestResponse('NOTE '+IntToStr(iIndex))+
  226.                '  </TR>'+CRLF;
  227.   End;
  228.   Response.Content := StringReplace(cstrNotesHTML,'%rows%',strRows,[]);
  229. end;
  230.  
  231. procedure TWeblookWM.WeblookWMInboxAction(Sender: TObject;
  232.   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  233. Var
  234.   iIndex,iCount : Integer;
  235.   strRows       : String;
  236.  
  237. begin
  238.   iCount := StrToInt(ReadPipeRequestResponse('INBOX COUNT'));
  239.   For iIndex := 0 to iCount-1 do
  240.     strRows := strRows+ReadPipeRequestResponse('INBOX '+IntToStr(iIndex));
  241.   Response.Content := StringReplace(cstrInboxHTML,'%rows%',strRows,[]);
  242. end;
  243.  
  244. procedure TWeblookWM.WeblookWMTodayAction(Sender: TObject;
  245.   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  246. Var strHTML : String;
  247.  
  248.   Function CalcAppointmentCount(dtDate : TDateTime) : String;
  249.   Var
  250.     strTemp     : String;
  251.     iCount,iPos : Integer;
  252.  
  253.   Begin
  254.     iCount := -1;
  255.     strTemp := ReadPipeRequestResponse('CALENDAR '+IntToStr(Trunc(dtDate)));
  256.     { calculate how many <BR>'s there are on the string }
  257.     iPos := Pos('<BR>',strTemp);
  258.     While (iPos > 0) do Begin
  259.       Inc(iCount);
  260.       Delete(strTemp,1,iPos+3);
  261.       iPos := Pos('<BR>',strTemp);
  262.     End;
  263.     Result := IntToStr(iCount);
  264.   End;
  265.  
  266. begin
  267.   strHTML := StringReplace(cstrTodayHTML,'%date%',DateTimeToStr(Now),[]);
  268.   strHTML := StringReplace(strHTML,'%inbox%',ReadPipeRequestResponse('INBOX COUNT'),[]);
  269.   strHTML := StringReplace(strHTML,'%caltoday%',CalcAppointmentCount(Date),[]);
  270.   strHTML := StringReplace(strHTML,'%caltomorrow%',CalcAppointmentCount(Date+1),[]);
  271.   Response.Content := strHTML;
  272. end;
  273.  
  274. end.
  275.