mainfrm.pas

jvcl driver development envionment

{******************************************************************

                       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;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, JvScrollBox, ComCtrls, JvProgressBar,
  JvBevel, Buttons, JvBitBtn, JvFooter, JvComponent, JvSurveyIntf,
  JvDialogs, ImgList, ActnList, JvActions, JvLinkLabel,
  JvRadioButton, JvCheckBox, JvMemo, Menus, JvExForms, JvExButtons,
  JvExExtCtrls, JvExControls, JvImageSquare;

type
  TfrmMain = class(TForm)
    pnlTop: TPanel;
    lblTitle: TLabel;
    JvFooter1: TJvFooter;
    btnPrev: TJvFooterBtn;
    btnNext: TJvFooterBtn;
    btnClose: TJvFooterBtn;
    sbSurvey: TJvScrollBox;
    OpenSurveyDialog: TJvOpenDialog;
    JediLogo: TJvImageSquare;
    il48: TImageList;
    alMain: TActionList;
    acStartPage: TAction;
    acPrevPage: TAction;
    acNextPage: TAction;
    acLoadSurvey: TAction;
    acSendMail: TJvSendMailAction;
    acGotoJVCL: TJvWebAction;
    acLastPage: TAction;
    acExit: TAction;
    JvBevel1: TJvBevel;
    lblProgress: TLabel;
    lblDescription: TJvLinkLabel;
    lblSurveyTitle: TLabel;
    btnOpen: TButton;
    popMultiple: TPopupMenu;
    acCheckAll: TAction;
    acUncheckAll: TAction;
    acInvert: TAction;
    acCheckFirst: TAction;
    acCheckLast: TAction;
    popExclusive: TPopupMenu;
    btnComment: TButton;
    acComment: TAction;
    acAbout: TAction;
    popSend: TPopupMenu;
    acSaveSurvey: TAction;
    SaveSurveyDialog: TJvSaveDialog;
    Save1: TMenuItem;
    procedure FormCreate(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure acStartPageExecute(Sender: TObject);
    procedure acLastPageExecute(Sender: TObject);
    procedure acExitExecute(Sender: TObject);
    procedure acPrevPageExecute(Sender: TObject);
    procedure alMainUpdate(Action: TBasicAction; var Handled: Boolean);
    procedure acNextPageExecute(Sender: TObject);
    procedure acLoadSurveyExecute(Sender: TObject);
    procedure lblDescriptionLinkClick(Sender: TObject; LinkNumber: Integer;
      LinkText: String);
    procedure acCheckAllExecute(Sender: TObject);
    procedure acUncheckAllExecute(Sender: TObject);
    procedure acInvertExecute(Sender: TObject);
    procedure acCheckFirstExecute(Sender: TObject);
    procedure acCheckLastExecute(Sender: TObject);
    procedure acCommentExecute(Sender: TObject);
    procedure sbSurveyContextPopup(Sender: TObject; MousePos: TPoint;
      var Handled: Boolean);
    procedure FormContextPopup(Sender: TObject; MousePos: TPoint;
      var Handled: Boolean);
    procedure acAboutExecute(Sender: TObject);
    procedure acSaveSurveyExecute(Sender: TObject);
  private
    FFilename,FTempSurveyFilename: string;
    FCompletedSurvey:boolean;
    FSurvey: IJvSurvey;
    FPageIndex: integer;
    edUserName, edUserEMail: TEdit;
    procedure DoExclusiveClick(Sender: TObject);
    procedure DoMultipleClick(Sender: TObject);

    procedure CreateEverything;
    procedure LoadSettings;
    procedure ReadCommandLine;
    procedure LoadSurvey(const AFilename: string);
    function GetTempSurveyFileName: string;
    procedure PromptForSurveyFile(const AFilename: string);
    procedure SaveSettings;
    procedure FreeEverything;
    procedure ClearScrollBox;
    procedure BuildExclusivePopUpMenu;
    procedure BuildMultiplePopUpMenu;

    function CheckPage(Index:integer): boolean;
    procedure StartPage;
    procedure EndPage;
    procedure CreateExclusivePage(Index:integer);
    procedure CreateMultiplePage(Index:integer);
    procedure CreateFreeFormPage(Index:integer);
    procedure SavePage;
    procedure UpdateProgress;
    procedure CreatePage(Index: integer);
    procedure DoSendMail(Sender: TObject);
    property Filename: string read FFilename write FFilename;
  public
  end;

var
  frmMain: TfrmMain;

resourcestring
  SMainFormCaptionFmt = 'JEDI Surveyor - (%s)';
  SDefaultSurveyName = 'No survey loaded!';
  SStartPageTitle = 'Welcome to the JEDI Surveyor';
  SStartPageDescription = 'The JEDI Surveyor is a tool to collect user input on various issues.' +
    ' Currently no survey is loaded. To load a survey, click the "Open" button and select a survey file from the dialog.';
  SEndPageTitle = 'Survey completed';
  SEndPageDescriptionFmt =
    'Click the "Send" button below to send an e-mail to %s (<link>mailto:%s</link>) with your answers. ' +
    'The results of the survey will be made available at the following location: <link>%s</link>. Enter a username and and e-mail address to help us keep track of participants (optional).';
  SExpiredSurveyCaption = 'Survey expired!';
  SExpiredSurveyTextFmt = 'This survey expired on %s, would you like to view it anyway?';
  SErrSurveyImplementationNotFound = 'Fatal Error: No IJvSurvey implementation found, cannot continue!';
  SUsername = '&Username:';
  SEmail = '&E-mail address:';
  SSend = '&Send';
  SSaveResponseCaption = 'Save responses';
  SSaveResponsePrompt = 'You haven''t completed the survey. Do you want to save your responses this far (responses are saved in the original survey file)?';
  SPageOfPageFmt = 'Page %d of %d';
  SDeleteResponseCaption = 'Delete response file';
  SFmtDeleteResponsePrompt = 'Do you want to delete the response file (%s)?';
  SAboutText = 'JEDI Surveyor version 1.0';
  SAboutTitle = 'About Surveyor...';

const
  cStartOffset = 24;
  cDefaultControlWidth = 125;

implementation

uses
  ComObj, Math, JclStrings, JclSysInfo,
  JvJCLUtils, JvSurveyUtils, CommentFrm;

{$R *.dfm}

function TextSize(Canvas: TCanvas; DefaultHeight:integer; const S: string): TSize;
var
  i: integer;
  T:TStringlist;
begin
  Result.cx := 0;
  Result.cy := 0;
  T := TStringlist.Create;
  try
    T.Text := S;
    for i := 0 to T.Count - 1 do
    begin
      Result.cx := Max(Result.cx, Canvas.TextWidth(T[i]));
      Inc(Result.cy, DefaultHeight);
    end;
  finally
    T.Free;
  end;
  if Result.cy <= 0 then Result.cy := DefaultHeight;
end;

{ TfrmMain }

procedure TfrmMain.CreatePage(Index: integer);
begin
  PopupMenu := nil;
  if (Index < 0) then
    StartPage
  else if (FSurvey.Items.Count > 0) and (Index >= FSurvey.Items.Count) then
    EndPage
  else
  begin
    lblTitle.Caption := FSurvey.Items[Index].Title;
    lblDescription.Caption := FSurvey.Items[Index].Description;
    case FSurvey.Items[Index].SurveyType of
      stExclusive:
        CreateExclusivePage(Index);
      stMultiple:
        CreateMultiplePage(Index);
      stFreeForm:
        CreateFreeFormPage(Index);
    end;
  end;
  UpdateProgress;
end;

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  CreateEverything;
  LoadSettings;
  ReadCommandLine;
end;

procedure TfrmMain.CreateEverything;
begin
  FPageIndex := -1;
  if Assigned(CreateSurvey) then
    FSurvey := CreateSurvey
  else
  begin
    ShowMessage(SErrSurveyImplementationNotFound);
    Application.Terminate;
    Close;
  end;
end;

procedure TfrmMain.FreeEverything;
begin
  FSurvey := nil;
end;

procedure TfrmMain.LoadSettings;
begin
  JediLogo.Anchors := [akRight, akTop];
  JediLogo.Action := acGotoJVCL;
  // TODO: load additional properties
end;

procedure TfrmMain.ReadCommandLine;
var
  S:string;
  i: integer;
begin
  S := '';
  for i := 1 to ParamCount do
    if FileExists(ExpandUNCFileName(ParamStr(i))) then
    begin
      S := ExpandUNCFileName(ParamStr(i));
      Break;
    end;
  if S <> '' then
    LoadSurvey(S)
  else
    StartPage;
end;

procedure TfrmMain.SaveSettings;
begin
  // TODO: save settings
end;

procedure TfrmMain.PromptForSurveyFile(const AFilename: string);
begin
  OpenSurveyDialog.Filename := AFilename;
  acLoadSurvey.Execute;
end;

procedure TfrmMain.LoadSurvey(const AFilename: string);
begin
  if FileExists(AFilename) then
  begin
    FSurvey.LoadFromFile(AFilename);
    FFilename := AFilename;
    StartPage;
    if (FSurvey.ExpiryDate < Date) and not YesNo(SExpiredSurveyCaption, Format(SExpiredSurveyTextFmt,[DateToStr(FSurvey.ExpiryDate)])) then
      PromptForSurveyFile(AFilename)
  end
  else
    PromptForSurveyFile(AFilename);
  Caption := Format(SMainFormCaptionFmt, [ExtractFileName(Filename)]);
  lblSurveyTitle.Caption := FSurvey.Title;
end;

procedure TfrmMain.StartPage;
begin
  SavePage;
  ClearScrollBox;
  FPageIndex := -1;
  lblTitle.Caption := SStartPageTitle;
  if (FSurvey.Items.Count < 1) then
    lblDescription.Caption := SStartPageDescription
  else
    lblDescription.Caption := FSurvey.Description;
  lblProgress.Visible := false;
end;

procedure TfrmMain.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  if not FCompletedSurvey and (FSurvey.Items.Count > 0) and YesNo(SSaveResponseCaption,SSaveResponsePrompt) then
  begin
    if FSurvey.SurveyTaker.ID = '' then
      FSurvey.SurveyTaker.ID := CreateClassID;
    FSurvey.SaveToFile(Filename,ffBinary);
  end
  else if FileExists(FTempSurveyFilename) and YesNo(SDeleteResponseCaption,Format(SFmtDeleteResponsePrompt,[FTempSurveyFilename])) then
    DeleteFile(FTempSurveyFilename);
  SaveSettings;
  FreeEverything;
end;

procedure TfrmMain.ClearScrollBox;
begin
  if (edUserName <> nil) and (edUserEMail <> nil) then
  begin
    FSurvey.SurveyTaker.UserName := edUserName.Text;
    FSurvey.SurveyTaker.MailAddress := edUserEMail.Text;
  end;
  while sbSurvey.ControlCount > 0 do
    sbSurvey.Controls[0].Free;
  edUserName := nil;
  edUserEMail := nil;
  PopupMenu := nil;
end;

procedure TfrmMain.EndPage;
begin
  SavePage;
  ClearScrollBox;
  FPageIndex := FSurvey.Items.Count;
  lblTitle.Caption := SEndPageTitle;
  lblDescription.Caption := Format(SEndPageDescriptionFmt, [FSurvey.Recipient, FSurvey.RecipientMail, FSurvey.ResultHRef]);
  edUserName := TEdit.Create(self);
  with edUserName do
  begin
    Parent := sbSurvey;
    SetBounds(18, 36, sbSurvey.ClientWidth - 36, Height);
    TabOrder := 0;
    Text := FSurvey.SurveyTaker.UserName;
  end;
  with TLabel.Create(self) do
  begin
    Parent := sbSurvey;
    SetBounds(18, 18, Width, Height);
    Caption := SUserName;
    FocusControl := edUserName;
  end;
  edUserEmail := TEdit.Create(self);
  with edUserEmail do
  begin
    Parent := sbSurvey;
    SetBounds(18, 84, sbSurvey.ClientWidth - 36, Height);
    TabOrder := 1;
    Text := FSurvey.SurveyTaker.MailAddress;
  end;
  with TLabel.Create(self) do
  begin
    Parent := sbSurvey;
    SetBounds(18, 66, Width, Height);
    Caption := SEMail;
    FocusControl := edUserEmail;
  end;

  with TButton.Create(self) do
  begin
    Parent := sbSurvey;
    SetBounds(sbSurvey.ClientWidth - 105 - Width, 126, Width, Height);
    Action := acSaveSurvey;
    Anchors := [akRight,akTop];
    TabOrder := 2;
    Enabled := FSurvey.ExpiryDate >= Date;
  end;
  with TButton.Create(self) do
  begin
    Parent := sbSurvey;
    SetBounds(sbSurvey.ClientWidth - 25 - Width, 126, Width, Height);
    Caption := SSend;
    Anchors := [akRight,akTop];
    OnClick := DoSendMail;
    TabOrder := 3;
    Enabled := FSurvey.ExpiryDate >= Date;
  end;

  PopUpMenu := popSend;
  UpdateProgress;
end;

procedure TfrmMain.acStartPageExecute(Sender: TObject);
begin
  CreatePage(-1);
end;

procedure TfrmMain.acLastPageExecute(Sender: TObject);
begin
  CreatePage(FSurvey.Items.Count);
end;

procedure TfrmMain.acExitExecute(Sender: TObject);
begin
  Close;
end;

procedure TfrmMain.acPrevPageExecute(Sender: TObject);
begin
  SavePage;
  Dec(FPageIndex);
  CreatePage(FPageIndex);
  UpdateProgress;
end;

procedure TfrmMain.acNextPageExecute(Sender: TObject);
begin
  SavePage;
  Inc(FPageIndex);
  CreatePage(FPageIndex);
  UpdateProgress;
end;