Componentes.Terceros.jvcl/official/3.32/examples/JediSurveyor/Reporter/MainFrm.pas

621 lines
20 KiB
ObjectPascal

{******************************************************************
JEDI-VCL Demo
Copyright (C) 2002 Project JEDI
Original author:
You may retrieve the latest version of this file at the JEDI-JVCL
home page, located at http://jvcl.sourceforge.net
The contents of this file are used with permission, subject to
the Mozilla Public License Version 1.1 (the "License"); you may
not use this file except in compliance with the License. You may
obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1_1Final.html
Software distributed under the License is distributed on an
"AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
implied. See the License for the specific language governing
rights and limitations under the License.
******************************************************************}
unit MainFrm;
{$I jvcl.inc}
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ImgList, StdActns, ActnList, Menus, ExtCtrls, ComCtrls, JvStatusBar,
JvComCtrls, JvSurveyIntf, JvDialogs, StdCtrls, JvListView, HTTPApp,
JvComponent, JvImageSquare {$IFDEF COMPILER6_UP}, HTTPProd, JvExComCtrls{$ENDIF};
type
TfrmMain = class(TForm)
Panel1: TPanel;
Splitter1: TSplitter;
sbStatus: TJvStatusBar;
tvItems: TJvTreeView;
mmMain: TMainMenu;
File1: TMenuItem;
Help1: TMenuItem;
alMain: TActionList;
acOpen: TAction;
acSaveReport: TAction;
acExit: TAction;
acAddResponse: TAction;
acOpen1: TMenuItem;
acSaveAs1: TMenuItem;
N1: TMenuItem;
acExit1: TMenuItem;
acAbout: TAction;
acHelp: TAction;
il16: TImageList;
About1: TMenuItem;
N4: TMenuItem;
Help2: TMenuItem;
Add2: TMenuItem;
acPrintPreview: TAction;
N5: TMenuItem;
Print1: TMenuItem;
N6: TMenuItem;
OpenSurveyDialog: TJvOpenDialog;
PrinterSetupDialog: TPrinterSetupDialog;
PrintDialog: TPrintDialog;
SaveReportDialog: TJvSaveDialog;
acLoadReport: TAction;
LoadReport1: TMenuItem;
N7: TMenuItem;
ppPrintPreview: TPageProducer;
Panel2: TPanel;
nbDetails: TNotebook;
lvGlobalStats: TListView;
lvItemStats: TJvListView;
reFreeForm: TRichEdit;
il24: TImageList;
View1: TMenuItem;
acComments: TAction;
Comments1: TMenuItem;
acDupeWarning: TAction;
acDupeWarning1: TMenuItem;
procedure FormCreate(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure acOpenExecute(Sender: TObject);
procedure acExitExecute(Sender: TObject);
procedure tvItemsCollapsing(Sender: TObject; Node: TTreeNode;
var AllowCollapse: Boolean);
procedure tvItemsChange(Sender: TObject; Node: TTreeNode);
procedure acAddResponseExecute(Sender: TObject);
procedure acPrinterSettingsExecute(Sender: TObject);
procedure acPrintPreviewExecute(Sender: TObject);
procedure acAboutExecute(Sender: TObject);
procedure acSaveReportExecute(Sender: TObject);
procedure acLoadReportExecute(Sender: TObject);
procedure ppPrintPreviewHTMLTag(Sender: TObject; Tag: TTag;
const TagString: string; TagParams: TStrings;
var ReplaceText: string);
procedure alMainUpdate(Action: TBasicAction; var Handled: Boolean);
procedure acCommentsExecute(Sender: TObject);
procedure acDupeWarningExecute(Sender: TObject);
private
FFilename: string;
FResponses: TStringlist;
FCurrentItem: IJvSurveyItem;
FSurvey: IJvSurvey;
procedure LoadView;
procedure LoadData(Node: TTreeNode);
function GetResponseValue(item: IJvSurveyItem; Index: integer): integer;
function AddItem(Parent: TTreeNode; item: IJvSurveyItem): TTreeNode;
procedure AddResponses(item: IJvSurveyItem; Index: integer; const SurveyTaker: IJvSurveyTaker);
procedure LoadFromFile(const Filename: string; ClearResponses: boolean);
procedure LoadFromResponse(const Filename: string);
procedure SaveReport(const Filename: string; Format: TJvSurveyFileFormat);
property Filename: string read FFilename write FFilename;
function GetReportHTMLContent: string;
function GetReportHTMLSummary: string;
procedure UpdateStatusBar;
public
end;
var
frmMain: TfrmMain;
resourcestring
SOpenSurveyTitle = 'Open Survey...';
SAddUserResponseTitle = 'Add User Response File(s)';
implementation
uses
JvSurveyUtils, JclStrings, Math, JvSimpleXML, JvJCLUtils, CommentsFrm;
{$R *.dfm}
resourcestring
SFmtInvalidResponseFile =
'The file "%s" is not compatible with the currently loaded survey: please select another response file.';
SFmtResponseAlreadyLoaded = 'Responses from the file "%s" or user "%s" has already been added to the report.';
SFmtUnmatchedSurveyType = 'SurveyTypes does not match (index %d)';
SFmtResponse = '%0:s\nResponse from %1:s:\n%0:s\n\n%2:s\n\n';
SFmtComment = '%0:s\nComments from %1:s:\n%0:s\n\n%2:s\n\n';
SFmtTemplateNotFound = 'Unable to find print template (%s)';
SAboutText = 'JEDI Surveyor Reporter, version 1.0';
SAboutTitle = 'About Reporter...';
SFmtHTMLTableSurveySummary =
'<table class="TableSurveySummary">' +
'<tr class="TRSurveySummary"><th class="THSurveySummary">Title</th><th class="THSurveySummary">ReleaseDate</th>' +
'<th class="THSurveySummary">ExpiryDate</th><th class="THSurveySummary">Responses</th><th class="THSurveySummary">Questions</th></tr>' +
'<tr class="TRSurveySummary"><td class="TDSurveySummary">%s</td><td class="TDSurveySummary">%s&nbsp;</td>' +
'<td class="TDSurveySummary">%s</td><td class="TDSurveySummary">%d</td><td class="TDSurveySummary">%d</td></tr></table>';
SHTMLNoItemsToDisplay =
'<h4>There are no items in this survey: nothing to display</h4>';
SFmtHTMLTableSurveyItemHeader =
'<h4>Item #%d</h4><table class="TableSurveyItemHeader"><tr class="TRSurveyItemHeader">' +
'<th class="THSurveyItemHeader">Title</th>' +
'<th class="THSurveyItemHeader">Description</th>' +
'<th class="THSurveyItemHeader">Type</th></tr>' +
'<tr class="TRSurveyItemHeader">' +
'<td class="TDSurveyItemHeader">%s&nbsp;</td>' +
'<td class="TDSurveyItemHeader">%s&nbsp;</td>' +
'<td class="TDSurveyItemHeader">%s&nbsp;</td></tr><tr><td colspan="3">';
SFmtHTMLTableSurveyItemDetail =
'<table class="TableSurveyItemDetail">' +
'<tr class="TRSurveyItemDetail"><th class="THSurveyItemDetail">Responses</th></tr>' +
'<tr class="TRSurveyItemDetail"><td class="TDSurveyItemDetail">%s&nbsp;</td></tr></table>';
SFmtHTMLTableSurveyItemFooter = '</td></tr></table>';
STableSurveyItemDetail =
'<table class="TableSurveyItemDetail"><tr class="TRSurveyItemDetail">' +
'<th class="THSurveyItemDetail">Choices</th><th class="THSurveyItemDetail">Responses</th></tr>';
SFmtHTMLTRSurveyItemDetail = '<tr class="TRSurveyItemDetail"><td class="TDSurveyItemDetail">%s&nbsp;</td>' +
'<td class="TDSurveyItemDetail">%s&nbsp;</td></tr>';
SHTMLSpacer = '&nbsp;';
SHTMLTableEnd = '</table>';
STableCommentHeader = '<table class="TableSurveyItemDetail"><tr colspan="3" class="TRSurveyItemDetail"><th class="THSurveyItemDetail">Comments</th></tr>';
SFmtTableCommentDetail = '<tr colspan="3" class="TRSurveyItemDetail"><td class="TDSurveyItemDetail">%s</td></tr>';
const
cSurveyItemImageIndex = 22;
cDelimChar = '=';
cDelimLength = 60;
cReportFileExt = '.jsr';
cPrintReportExt = '.htm';
cPrintTemplate = 'Data\SurveyTemplate.htt';
function MakeString(Ch: char; Count: integer): string;
begin
SetLength(Result, Count);
if Count > 0 then
FillChar(Result[1], Count, Ch);
end;
procedure TfrmMain.LoadFromFile(const Filename: string; ClearResponses: boolean);
var
i: integer;
begin
FSurvey.LoadFromFile(Filename);
self.Filename := Filename;
// clear any responses added to survey (but no to report)
if ClearResponses then
begin
FResponses.Clear;
for i := 0 to FSurvey.Items.Count - 1 do
FSurvey.Items[i].Responses := '';
end
else
// load any previous survey takers already added to the report
FResponses.CommaText := FSurvey.SurveyTaker.ID;
LoadView;
SaveReportDialog.Filename := ChangeFileExt(Filename, cReportFileExt);
end;
procedure TfrmMain.FormCreate(Sender: TObject);
begin
FSurvey := CreateSurvey;
FResponses := TStringlist.Create;
FResponses.Sorted := acDupeWarning.Checked;
nbDetails.PageIndex := 0;
end;
procedure TfrmMain.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
FResponses.Free;
FSurvey := nil;
end;
procedure TfrmMain.LoadView;
var
N: TTreeNode;
i: integer;
begin
N := tvItems.Items.GetFirstNode;
if N <> nil then
N.DeleteChildren;
N.Data := Pointer(FSurvey);
for i := 0 to FSurvey.Items.Count - 1 do
AddItem(N, FSurvey.Items[i]);
LoadData(N);
tvItems.FullExpand;
end;
function TfrmMain.AddItem(Parent: TTreeNode;
item: IJvSurveyItem): TTreeNode;
begin
Result := tvItems.Items.AddChildObject(Parent,
item.Title, Pointer(item));
Result.ImageIndex := cSurveyItemImageIndex;
Result.SelectedIndex := Result.ImageIndex;
end;
procedure TfrmMain.acOpenExecute(Sender: TObject);
begin
OpenSurveyDialog.Filter := SSurveyFileFilter;
OpenSurveyDialog.Filename := Filename;
OpenSurveyDialog.Title := SOpenSurveyTitle;
if OpenSurveyDialog.Execute then
LoadFromFile(OpenSurveyDialog.Filename, true);
end;
procedure TfrmMain.acExitExecute(Sender: TObject);
begin
Close;
end;
function TfrmMain.GetResponseValue(item: IJvSurveyItem;
Index: integer): integer;
var
S: TStringlist;
begin
Result := 0;
if item.SurveyType = stFreeForm then Exit;
S := TStringlist.Create;
try
S.Text := DecodeResponse(item.Responses, item.SurveyType);
if (Index < 0) or (Index >= S.Count) then Exit;
Result := StrToIntDef(S[Index], 0);
finally
S.Free;
end;
end;
procedure TfrmMain.LoadData(Node: TTreeNode);
var
li: TListItem;
S: TStringlist;
i: integer;
begin
FCurrentItem := nil;
if (Node = nil) or not FileExists(Filename) then Exit;
if Node.Parent = nil then // root
begin
nbDetails.PageIndex := 0;
lvGlobalStats.Items[0].SubItems[0] := FSurvey.Title;
lvGlobalStats.Items[1].SubItems[0] := DateToStr(FSurvey.ReleaseDate);
lvGlobalStats.Items[2].SubItems[0] := DateToStr(FSurvey.ExpiryDate);
lvGlobalStats.Items[3].SubItems[0] := IntToStr(FResponses.Count);
lvGlobalStats.Items[4].SubItems[0] := IntToStr(FSurvey.Items.Count);
end
else if Node.Data <> nil then // item
begin
FCurrentItem := IJvSurveyItem(Node.Data);
lvItemStats.Items.Clear;
if FCurrentItem.SurveyType <> stFreeForm then
begin
S := TStringlist.Create;
try
S.Text := DecodeChoice(FCurrentItem.Choices, FCurrentItem.SurveyType);
for i := 0 to S.Count - 1 do
begin
if S[i] = '' then Continue;
li := lvItemStats.Items.Add;
li.Caption := S[i];
li.SubItems.Add(IntToStr(GetResponseValue(FCurrentItem, i)));
end;
finally
S.Free;
end;
nbDetails.PageIndex := 1;
end
else
begin
nbDetails.PageIndex := 2;
reFreeForm.Lines.Text := DecodeString(FCurrentItem.Responses);
end;
end;
UpdateStatusBar;
end;
procedure TfrmMain.tvItemsCollapsing(Sender: TObject; Node: TTreeNode;
var AllowCollapse: Boolean);
begin
AllowCollapse := false;
end;
procedure TfrmMain.tvItemsChange(Sender: TObject; Node: TTreeNode);
begin
LoadData(Node);
end;
procedure TfrmMain.acAddResponseExecute(Sender: TObject);
var
i: integer;
begin
OpenSurveyDialog.Filter := SResponseFileFilter;
// OpenSurveyDialog.Filename := Filename;
OpenSurveyDialog.Title := SAddUserResponseTitle;
OpenSurveyDialog.Options := OpenSurveyDialog.Options + [ofAllowMultiSelect];
if OpenSurveyDialog.Execute then
begin
for i := 0 to OpenSurveyDialog.Files.Count - 1 do
LoadFromResponse(OpenSurveyDialog.Files[i]);
LoadData(tvItems.Selected);
end;
OpenSurveyDialog.Options := OpenSurveyDialog.Options - [ofAllowMultiSelect];
end;
procedure TfrmMain.LoadFromResponse(const Filename: string);
var
ASurvey: IJvSurvey;
i: integer;
begin
ASurvey := CreateSurvey;
ASurvey.LoadFromFile(Filename);
if ASurvey.ID <> FSurvey.ID then
raise
Exception.CreateFmt(SFmtInvalidResponseFile, [Filename]);
if (FResponses.IndexOf(ASurvey.SurveyTaker.ID) > -1) and acDupeWarning.Checked then
ShowMessageFmt(SFmtResponseAlreadyLoaded, [Filename, ASurvey.SurveyTaker.ID])
else
begin
FResponses.Add(ASurvey.SurveyTaker.ID);
for i := 0 to ASurvey.Items.Count - 1 do
AddResponses(ASurvey.Items[i], i, ASurvey.SurveyTaker);
end;
end;
procedure TfrmMain.AddResponses(item: IJvSurveyItem; Index: integer; const SurveyTaker: IJvSurveyTaker);
var
S, tmp: string;
function Decode(S: WideString): TList;
var
ST: TStringlist;
i: integer;
begin
Result := TList.Create;
ST := TStringlist.Create;
try
StrTokenToStrings(S, cRecordSeparator, ST);
for i := 0 to ST.Count - 1 do
Result.Add(Pointer(StrToIntDef(ST[i], 0)));
finally
ST.Free;
end;
end;
procedure MergeResponses(item1, item2: IJvSurveyItem);
var
S1, S2: TList;
i: integer;
tmp: string;
begin
S1 := Decode(item1.Responses);
S2 := Decode(item2.Responses);
S1.Count := Max(S1.Count, S2.Count);
S2.Count := Max(S1.Count, S2.Count);
for i := 0 to S2.Count - 1 do
S1[i] := Pointer(integer(S1[i]) + integer(S2[i]));
tmp := '';
for i := 0 to S1.Count - 1 do
tmp := tmp + IntToStr(integer(S1[i])) + cRecordSeparator;
if MyAnsiLastChar(tmp) = cRecordSeparator then
SetLength(tmp, Length(tmp) - 1);
item1.Responses := tmp;
S1.Free;
S2.Free;
end;
begin
if (Index < 0) or (Index >= FSurvey.Items.Count) then Exit;
if (FSurvey.Items[Index].SurveyType <> item.SurveyType) then
raise Exception.CreateFmt(SFmtUnmatchedSurveyType, [Index]);
if FSurvey.Items[Index].SurveyType = stFreeForm then
begin
S := trim(FSurvey.Items[Index].Responses);
tmp := Format(SFmtResponse, [MakeString(cDelimChar, cDelimLength), SurveyTaker.UserName, trim(item.Responses)]);
if (S = '') and (trim(item.Comments) <> '') then
S := tmp
else if trim(item.Responses) <> '' then
S := S + tmp;
FSurvey.Items[Index].Responses := S;
end
else
MergeResponses(FSurvey.Items[Index], item);
//add comments
S := trim(FSurvey.Items[Index].Comments);
tmp := Format(SFmtComment, [MakeString(cDelimChar, cDelimLength), SurveyTaker.UserName, trim(item.Comments)]);
if (S = '') and (trim(item.Comments) <> '') then
S := tmp
else if trim(item.Comments) <> '' then
S := S + tmp;
FSurvey.Items[Index].Comments := S;
end;
procedure TfrmMain.acPrinterSettingsExecute(Sender: TObject);
begin
PrinterSetupDialog.Execute;
end;
procedure TfrmMain.acPrintPreviewExecute(Sender: TObject);
var
S: string;
begin
S := ExtractFilePath(Application.ExeName) + cPrintTemplate;
if not FileExists(S) then
raise Exception.CreateFmt(SFmtTemplateNotFound, [S]);
ppPrintPreview.HTMLFile := S;
// generate and save report HTML file
with TStringlist.Create do
try
Text := ppPrintPreview.Content;
S := ChangeFileExt(S, cPrintReportExt);
SaveToFile(S);
// open in browser
OpenObject(S);
finally
Free;
end;
end;
procedure TfrmMain.acAboutExecute(Sender: TObject);
begin
Windows.MessageBox(GetActiveWindow, PChar(SAboutText), PChar(SAboutTitle), MB_OK or MB_ICONINFORMATION);
end;
procedure TfrmMain.acSaveReportExecute(Sender: TObject);
const
aFormat: array[1..3] of TJvSurveyFileFormat = (ffBinary, ffText, ffText);
begin
if SaveReportDialog.Execute then
SaveReport(SaveReportDialog.Filename, aFormat[SaveReportDialog.FilterIndex]);
end;
procedure TfrmMain.SaveReport(const Filename: string; Format: TJvSurveyFileFormat);
//var
// i: integer;
// X: TJvSimpleXML;
// elem:TJvSimpleXMLElem;
begin
FSurvey.SurveyTaker.UserName := '';
FSurvey.SurveyTaker.MailAddress := '';
// save all loaded respones as a comma-separated lsit
FSurvey.SurveyTaker.ID := FResponses.CommaText;
FSurvey.SaveToFile(Filename, Format);
end;
procedure TfrmMain.acLoadReportExecute(Sender: TObject);
begin
OpenSurveyDialog.Filter := SReportFileFilter;
OpenSurveyDialog.FileName := SaveReportDialog.Filename;
if OpenSurveyDialog.Execute then
LoadFromFile(OpenSurveyDialog.Filename, false);
end;
function TfrmMain.GetReportHTMLSummary: string;
begin
Result := Format(SFmtHTMLTableSurveySummary,
[FSurvey.Title, DateToStr(FSurvey.ReleaseDate), DateToStr(FSurvey.ExpiryDate),
FResponses.Count, FSurvey.Items.Count]);
end;
function TfrmMain.GetReportHTMLContent: string;
var
i, j: integer;
C, R: TStringlist;
function ConvertCRLFToBR(const S: string): string;
begin
Result := StringReplace(S, '\n', '<br>', [rfReplaceAll]);
Result := StringReplace(Result, #13#10, '<br>', [rfReplaceAll]);
end;
begin
if FSurvey.Items.Count = 0 then
begin
Result := SHTMLNoItemsToDisplay;
Exit;
end;
C := TStringlist.Create;
R := TStringlist.Create;
try
for i := 0 to FSurvey.Items.Count - 1 do
begin
FSurvey.Items[i].SortResponses;
// TODO: add comments
Result := Result + Format(SFmtHTMLTableSurveyItemHeader,
[i + 1, FSurvey.Items[i].Title, FSurvey.Items[i].Description, EncodeType(FSurvey.Items[i].SurveyType)]);
C.Text := DecodeChoice(FSurvey.Items[i].Choices, FSurvey.Items[i].SurveyType);
R.Text := DecodeResponse(FSurvey.Items[i].Responses, FSurvey.Items[i].SurveyType);
if FSurvey.Items[i].SurveyType = stFreeForm then
Result := Result + Format(SFmtHTMLTableSurveyItemDetail, [ConvertCRLFToBR(R.Text)])
else
begin
while C.Count > R.Count do
R.Add(SHTMLSpacer);
Result := Result + STableSurveyItemDetail;
for j := 0 to C.Count - 1 do
Result := Result + Format(SFmtHTMLTRSurveyItemDetail, [ConvertCRLFToBR(C[j]), ConvertCRLFToBR(R[j])]);
Result := Result + SHTMLTableEnd;
end;
C.Text := ConvertCRLFToBR(FSurvey.Items[i].Comments);
if C.Count > 0 then
begin
Result := Result + STableCommentHeader;
for j := 0 to C.Count - 1 do
Result := Result + Format(SFmtTableCommentDetail,[ConvertCRLFToBR(C[j])]);
Result := Result + SHTMLTableEnd;
end;
Result := Result + SFmtHTMLTableSurveyItemFooter;
end;
finally
R.Free;
C.Free;
end;
end;
procedure TfrmMain.ppPrintPreviewHTMLTag(Sender: TObject; Tag: TTag;
const TagString: string; TagParams: TStrings; var ReplaceText: string);
begin
if AnsiSameText(TagString, 'SURVEYTITLE') then // DO NOT LOCALIZE
ReplaceText := FSurvey.Title
else if AnsiSameText(TagString, 'SURVEYSUMMARY') then // DO NOT LOCALIZE
ReplaceText := GetReportHTMLSummary
else if AnsiSameText(TagString, 'SURVEYCONTENT') then // DO NOT LOCALIZE
ReplaceText := GetReportHTMLContent;
end;
procedure TfrmMain.alMainUpdate(Action: TBasicAction;
var Handled: Boolean);
const
// TODO: localize
cRequired: array[boolean] of PChar = (' Optional', ' Required');
cType: array[TJvSurveyType] of PChar = (' Exclusive', ' Multiple', ' Free Form');
begin
sbStatus.Panels[0].Width := Canvas.TextWidth(FFilename) + 8;
if sbStatus.Panels[0].Width < 100 then
sbStatus.Panels[0].Width := 100;
sbStatus.Panels[0].Text := ' ' + FFilename;
if FCurrentItem <> nil then
begin
acComments.Enabled := true;
sbStatus.Panels[1].Text := cType[FCurrentItem.SurveyType];
sbStatus.Panels[2].Text := cRequired[FCurrentItem.Required];
end
else
begin
acComments.Enabled := false;
sbStatus.Panels[1].Text := '';
sbStatus.Panels[2].Text := '';
end;
end;
procedure TfrmMain.UpdateStatusBar;
begin
alMain.UpdateAction(nil);
end;
procedure TfrmMain.acCommentsExecute(Sender: TObject);
begin
TfrmComments.Comments(FCurrentItem.Title, FCurrentItem.Comments);
end;
procedure TfrmMain.acDupeWarningExecute(Sender: TObject);
begin
acDupeWarning.Checked := not acDupeWarning.Checked;
FResponses.Sorted := acDupeWarning.Checked;
end;
end.