mainfrm.pas

jvcl driver development envionment

procedure TfrmMain.alMainUpdate(Action: TBasicAction;
  var Handled: Boolean);
begin
  acPrevPage.Enabled := (FPageIndex >= 0);
  acNextPage.Enabled := (Filename <> '') and (FSurvey.Items.Count > 0)
    and (FPageIndex < FSurvey.Items.Count) and CheckPage(FPageIndex);
  lblProgress.Visible := (FPageIndex >= 0) and (FPageIndex <= FSurvey.Items.Count);

  acLoadSurvey.Visible := FPageIndex = -1;
  acComment.Visible := (FPageIndex >= 0) and (FPageIndex < FSurvey.Items.Count);
  acLoadSurvey.Enabled := acLoadSurvey.Visible;
  acSaveSurvey.Enabled := FPageIndex = FSurvey.Items.Count;
  lblSurveyTitle.Visible := not acLoadSurvey.Visible;
end;

function TfrmMain.CheckPage(Index:integer): boolean;

  function HasCheckedItems: boolean;
  var
    i: integer;
  begin
    if (FSurvey.Items[Index].SurveyType = stFreeForm) or not FSurvey.Items[Index].Required then
      Result := true
    else
    begin
      with sbSurvey do
        for i := 0 to ControlCount - 1 do
          if ((Controls[i] is TRadioButton) and TRadioButton(Controls[i]).Checked) or
            ((Controls[i] is TCheckBox) and TCheckBox(Controls[i]).Checked) then
          begin
            Result := true;
            Exit;
          end;
      Result := false;
    end;
  end;
begin
  Result := (Index < 0) or (Index >= FSurvey.Items.Count) or HasCheckedItems;
end;

procedure TfrmMain.CreateExclusivePage(Index:integer);
var
  i, j, X, Y, AWidth: integer;
  ASize: TSize;
  RB: TJvRadioButton;
  S: TStringlist;
begin
  ClearScrollBox;
  X := cStartOffset;
  Y := cStartOffset;
  AWidth := cDefaultControlWidth;
  S := TStringlist.Create;
  try
//    S.CommaText := FSurvey.Items[Index].Choices;
    S.Text := DecodeChoice(FSurvey.Items[Index].Choices,stExclusive);
    j := 0;
    for i := 0 to S.Count - 1 do
    begin
      if S[i] = '' then Continue;
      RB := TJvRadioButton.Create(Self);
      RB.Caption := DecodeString(S[i]);
      ASize := TextSize(Canvas, RB.Height, RB.Caption);
      AWidth := Max(AWidth, ASize.cx + 32);
      RB.SetBounds(X, Y, AWidth, ASize.cy);
      RB.Checked := IsChecked(FSurvey.Items[Index], j);
      Inc(Y, ASize.cy + 4);
      if Y >= sbSurvey.ClientHeight - ASize.cy - cStartOffset then
      begin
        Y := cStartOffset;
        Inc(X, AWidth + cStartOffset);
      end;
      RB.Parent := sbSurvey;
//      if i = 0 then
//        ActiveControl := RB;
      Inc(j);
    end;
  finally
    S.Free;
  end;
  BuildExclusivePopUpMenu;
  PopupMenu := popExclusive;
end;

procedure TfrmMain.CreateFreeFormPage(Index:integer);
var RE:TJvMemo;
begin
  ClearScrollBox;
  RE := TJvMemo.Create(self);
  with RE do
  begin
    WordWrap := false;
    Parent := sbSurvey;
    SetBounds(cStartOffset, cStartOffset,
      sbSurvey.ClientWidth - cStartOffset * 2, sbSurvey.ClientHeight - cStartOffset * 2);
    Anchors := [akLeft..akBottom];
//    PlainText := true;
    ScrollBars := ssBoth;
    if FSurvey.Items[FPageIndex].Responses = '' then
      Lines.Text := DecodeChoice(FSurvey.Items[Index].Choices,stFreeForm)
    else
      Lines.Text := DecodeResponse(FSurvey.Items[Index].Responses,stFreeForm);
    ActiveControl := RE;
  end;
end;

procedure TfrmMain.CreateMultiplePage(Index:integer);
var
  i, j, X, Y, AWidth: integer;
  CB: TJvCheckBox;
  ASize: TSize;
  S: TStringlist;
begin
  ClearScrollBox;
  X := cStartOffset;
  Y := cStartOffset;
  AWidth := cDefaultControlWidth;
  S := TStringlist.Create;
  try
//    S.CommaText := FSurvey.Items[Index].Choices;
    S.Text := DecodeChoice(FSurvey.Items[Index].Choices,stMultiple);
    j := 0;
    for i := 0 to S.Count - 1 do
    begin
      if S[i] = '' then Continue;
      CB := TJvCheckBox.Create(Self);
      CB.Caption := S[i];
      ASize := TextSize(Canvas, CB.Height, CB.Caption);
      AWidth := Max(AWidth, ASize.cx + 32);
      CB.SetBounds(X, Y, AWidth, ASize.cy);
      CB.Checked := IsChecked(FSurvey.Items[Index], j);
      Inc(Y, ASize.cy + 4);
      if Y >= sbSurvey.ClientHeight - ASize.cy - cStartOffset then
      begin
        Y := cStartOffset;
        Inc(X, AWidth + cStartOffset);
      end;
      CB.Parent := sbSurvey;
      if i = 0 then
        ActiveControl := CB;
      Inc(j);
    end;
  finally
    S.Free;
  end;
  BuildMultiplePopUpMenu;
  PopupMenu := popMultiple;
end;

procedure TfrmMain.acLoadSurveyExecute(Sender: TObject);
begin
  if OpenSurveyDialog.Execute then
    LoadSurvey(OpenSurveyDialog.Filename)
  else
    StartPage;
end;

function TfrmMain.GetTempSurveyFileName: string;

  function DefaultStr(const S, Default: string): string;
  begin
    Result := S;
    if Result = '' then
      Result := Default;
  end;
begin
  // create a file name from the input filename, username, current date and time
  // and add a path
  Result := ChangeFileExt(ExtractFileName(Filename), '') +
    DefaultStr(GetLocalUserName,GetLocalComputerName) +
    FormatDateTime('yyyyMMddhhnnss', Now) + cResponseFileExt;
  //  ShowMessage(Result);
end;

procedure TfrmMain.SavePage;
var
  i: integer;S:string;
begin
  if (FPageIndex < 0) or (FPageIndex >= FSurvey.Items.Count) then Exit;
  S := '';
  with sbSurvey do
    for i := 0 to ControlCount - 1 do
    begin
      if Controls[i] is TRadioButton then
        S := S + Format('%d', [Ord(TRadioButton(Controls[i]).Checked)]) + cRecordSeparator
      else if Controls[i] is TCheckBox then
        S := S + Format('%d', [Ord(TCheckBox(Controls[i]).Checked)]) + cRecordSeparator
      else if Controls[i] is TCustomMemo then
        S := TCustomMemo(Controls[i]).Lines.Text
      else if Controls[i] is TCustomEdit then
        S := TCustomEdit(Controls[i]).Text;
    end;
  if MyAnsiLastChar(S) = cRecordSeparator then SetLength(S,Length(S)-1);
  FSurvey.Items[FPageIndex].Responses := S;
end;

procedure TfrmMain.UpdateProgress;
begin
  if FPageIndex >= 0 then
    lblProgress.Caption := Format(SPageOfPageFmt, [FPageIndex + 1, FSurvey.Items.Count + 1])
  else
    lblProgress.Caption := '';
end;

procedure TfrmMain.DoSendMail(Sender: TObject);
begin
  acSendMail.MailOptions.Recipients := FSurvey.RecipientMail;
  acSendMail.MailOptions.Subject := FSurvey.Title;
  if edUserName <> nil then
    FSurvey.SurveyTaker.UserName := edUserName.Text;
  if edUserEMail <> nil then
    FSurvey.SurveyTaker.MailAddress := edUserEMail.Text;
  // create and attach response file
  acSendMail.MailOptions.Attachments.Clear;
  if FTempSurveyFilename = '' then
    FTempSurveyFilename := GetTempSurveyFileName;
  if FSurvey.SurveyTaker.ID = '' then
    FSurvey.SurveyTaker.ID := CreateClassID;
  FSurvey.SaveToFile(FTempSurveyFilename,ffBinary);
  acSendMail.MailOptions.Attachments.Add(FTempSurveyFilename);

  acSendMail.MailOptions.ShowDialogs := true; // not acSendMail.Mail.UserLogged;
  if acSendMail.Execute then
    FCompletedSurvey := true;
end;

procedure TfrmMain.lblDescriptionLinkClick(Sender: TObject;
  LinkNumber: Integer; LinkText: String);
begin
  OpenObject(LinkText);
end;

procedure TfrmMain.acCheckAllExecute(Sender: TObject);
var i:integer;
begin
  for i := 0 to sbSurvey.ControlCount - 1 do
    if sbSurvey.Controls[i] is TCheckBox then
      TCheckBox(sbSurvey.Controls[i]).Checked := true;
end;

procedure TfrmMain.acUncheckAllExecute(Sender: TObject);
var i:integer;
begin
  for i := 0 to sbSurvey.ControlCount - 1 do
    if sbSurvey.Controls[i] is TCheckBox then
      TCheckBox(sbSurvey.Controls[i]).Checked := false;
end;

procedure TfrmMain.acInvertExecute(Sender: TObject);
var i:integer;
begin
  for i := 0 to sbSurvey.ControlCount - 1 do
    if sbSurvey.Controls[i] is TCheckBox then
      TCheckBox(sbSurvey.Controls[i]).Checked := not TCheckBox(sbSurvey.Controls[i]).Checked;
end;

procedure TfrmMain.acCheckFirstExecute(Sender: TObject);
var i:integer;
begin
  for i := 0 to sbSurvey.ControlCount - 1 do
    if sbSurvey.Controls[i] is TRadioButton then
    begin
      TCheckBox(sbSurvey.Controls[i]).Checked := true;
      Exit;
    end;
end;

procedure TfrmMain.acCheckLastExecute(Sender: TObject);
var i:integer;
begin
  for i := sbSurvey.ControlCount - 1 downto 0 do
    if sbSurvey.Controls[i] is TRadioButton then
    begin
      TCheckBox(sbSurvey.Controls[i]).Checked := true;
      Exit;
    end;
end;

procedure TfrmMain.DoExclusiveClick(Sender:TObject);
begin
  with (Sender as TMenuItem) do
  begin
    TRadioButton(Tag).Checked := true;
    Checked := true;
  end;
end;

procedure TfrmMain.BuildExclusivePopUpMenu;
var i:integer;m:TMenuItem;R:TRadioButton;
begin
  popExclusive.Items.Clear;
  for i := 0 to sbSurvey.ControlCount - 1 do
    if sbSurvey.Controls[i] is TRadioButton then
    begin
      R := TRadioButton(sbSurvey.Controls[i]);
      m := TMenuItem.Create(popExclusive);
      m.AutoHotkeys := maManual;
      m.Checked := R.Checked;
//      m.AutoCheck := true;  // only availale in D6+
      m.RadioItem := true;
      m.GroupIndex := 1;
      m.Caption := R.Caption;
      m.Tag     := integer(R);
      m.OnClick := DoExclusiveClick;
      popExclusive.Items.Add(m);
      if popExclusive.Items.Count < 10 then
        m.ShortCut := ShortCut(Ord('0') + popExclusive.Items.Count,[ssCtrl])
    end;
  // add standard items:
  m := TMenuItem.Create(popExclusive);
  m.Caption := '-';
  popExclusive.Items.Add(m);

  m := TMenuItem.Create(popExclusive);
  m.Action := acCheckFirst;
  popExclusive.Items.Add(m);

  m := TMenuItem.Create(popExclusive);
  m.Action := acCheckLast;
  popExclusive.Items.Add(m);
end;

procedure TfrmMain.DoMultipleClick(Sender:TObject);
begin
  with (Sender as TMenuItem) do
  begin
    TCheckBox(Tag).Checked := not TCheckBox(Tag).Checked;
    Checked := not Checked;
  end;
end;

procedure TfrmMain.BuildMultiplePopUpMenu;
var i:integer;m:TMenuItem;C:TCheckBox;
begin
  popMultiple.Items.Clear;
  for i := 0 to sbSurvey.ControlCount - 1 do
    if sbSurvey.Controls[i] is TCheckBox then
    begin
      C := TCheckBox(sbSurvey.Controls[i]);
      m := TMenuItem.Create(popMultiple);
      m.AutoHotkeys := maManual;
      m.Checked := C.Checked;
//      m.AutoCheck := true;
      m.Caption := C.Caption;
      m.Tag     := integer(C);
      m.OnClick := DoMultipleClick;
      popMultiple.Items.Add(m);
      if popMultiple.Items.Count < 10 then
        m.ShortCut := ShortCut(Ord('0') + popMultiple.Items.Count,[ssCtrl])
    end;
  // add standard items:
  m := TMenuItem.Create(popMultiple);
  m.Caption := '-';
  popMultiple.Items.Add(m);

  m := TMenuItem.Create(popMultiple);
  m.Action := acCheckAll;
  popMultiple.Items.Add(m);

  m := TMenuItem.Create(popMultiple);
  m.Action := acUnCheckAll;
  popMultiple.Items.Add(m);

  m := TMenuItem.Create(popMultiple);
  m.Caption := '-';
  popMultiple.Items.Add(m);

  m := TMenuItem.Create(popMultiple);
  m.Action := acInvert;
  popMultiple.Items.Add(m);
end;

procedure TfrmMain.acCommentExecute(Sender: TObject);
var S:string;
begin
  S := FSurvey.Items[FPageIndex].Comments;
  if TfrmComment.Comment(FSurvey.Items[FPageIndex].Title,S) then
      FSurvey.Items[FPageIndex].Comments := S;
end;

procedure TfrmMain.sbSurveyContextPopup(Sender: TObject; MousePos: TPoint;
  var Handled: Boolean);
begin
  //
end;

procedure TfrmMain.FormContextPopup(Sender: TObject; MousePos: TPoint;
  var Handled: Boolean);
begin
  if (PopupMenu <> nil) then
  begin
    if (MousePos.X < 0) or (MousePos.Y < 0) then
    begin
      GetCursorPos(MousePos);
//      MousePos := ScreenToClient(MousePos);
      if (MousePos.X < Left) or (MousePos.X > Left + Width) or
        (MousePos.Y < Top) or (MousePos.Y > Top + Height) then
          MousePos := Point(Left + Width div 2, Top + Height div 2);
      PopupMenu.Popup(MousePos.X,MousePos.Y);
      Handled := true;
    end;
  end;
end;

procedure TfrmMain.acAboutExecute(Sender: TObject);
begin
  Windows.MessageBox(GetActiveWindow,PChar(SAboutText),PChar(SAboutTitle),MB_OK or MB_ICONINFORMATION);
end;

procedure TfrmMain.acSaveSurveyExecute(Sender: TObject);
const
  cSurveyFormat:array[boolean] of TJvSurveyFileFormat = (ffText,ffBinary);
begin
  if FTempSurveyFilename = '' then
    FTempSurveyFilename := GetTempSurveyFileName;
  SaveSurveyDialog.FileName := FTempSurveyFilename;
  if SaveSurveyDialog.Execute then
  begin
    FTempSurveyFilename := SaveSurveyDialog.Filename;
    if FSurvey.SurveyTaker.ID = '' then
      FSurvey.SurveyTaker.ID := CreateClassID;
    FSurvey.SaveToFile(FTempSurveyFilename,cSurveyFormat[SaveSurveyDialog.FilterIndex = 1]);
    FCompletedSurvey := true;
  end;
end;

end.