Mega Code Archive
Send Report feature like Internet Explorer
<![CDATA[
Title: "Send Report" feature like Internet Explorer
Question: How can I have a special feature like Internet Explorer "Send Report" in my application.
Answer:
*********************************************************************
** This component was tested only with D7 but should work with D5. **
*********************************************************************
** USING: Indy components **
*********************************************************************
** How to use the component. **
** Just drop the component on a form and look at the following **
** pseudo code. **
** Of course, you need to fill some properties of the component **
*********************************************************************
procedure TForm1.Button1Click(Sender: TObject);
var
A: real;
begin
try
A := StrToInt(Trim(Edit1.Text)) / StrToInt(Trim(Edit2.Text));
except on E:Exception do
begin
RVSendException1.EException := E;
RVSendException1.Execute;
end;
end;
end;
*********************************************************************
unit RVSendException;
interface
uses
Classes, Forms, StdCtrls, ExtCtrls, Controls, Windows, Graphics,
Jpeg, SysUtils, Idmessage, IdSMTP, Dialogs;
type
TRVSendException = class(TComponent)
private
FEException: Exception;
FFileName: string;
FMemo: TMemo;
FTitle: string;
FSubTitle: string;
FServerName: string;
FServerPort: integer;
FNotificationEmail: string;
FCompanyName: string;
FContactName: string;
FContactEmail: string;
FIncScreenCapture: boolean;
procedure FScreenCapture;
procedure FClick(Sender: TObject);
protected
{ Protected declarations }
public
property EException: Exception read FEException write FEException;
constructor Create(AOwner: TComponent); override;
procedure Execute;
published
property Title: string read FTitle write FTitle;
property SubTitle: string read FSubTitle write FSubTitle;
property ServerName: string read FServerName write FServerName;
property ServerPort: integer read FServerPort write FServerPort;
property NotificationEmail: string read FNotificationEmail write FNotificationEmail;
property CompanyName: string read FCompanyName write FCompanyName;
property ContactName: string read FContactName write FContactName;
property ContactEmail: string read FContactEmail write FContactEmail;
property IncScreenCapture: boolean read FIncScreenCapture write FIncScreenCapture;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Test', [TRVSendException]);
end;
{ TRVSendException }
constructor TRVSendException.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
//Assign some default values
FEException := nil;
FTitle := 'Warning';
FSubTitle := 'Exception Informations';
FServerName := '127.0.0.1';
FServerPort := 25;
FNotificationEmail := 'abc@def.com';
FCompanyName := 'N/A';
FContactName := 'N/A';
FContactEmail :='abc@def.com';
FIncScreenCapture := True;
end;
procedure TRVSendException.Execute;
var
Frm : TForm;
Lbl : TLabel;
Bvl1: TBevel;
Bvl2: TBevel;
Btn1: TButton;
Btn2: TButton;
begin
if not Assigned(FEException) then
exit;
FFileName:= '';
//Create a form to display informations
Frm := TForm.Create(nil);
Frm.Width := 470;
Frm.Height := 244;
Frm.Caption := FTitle; //Set the caption of the form
Frm.Position := poScreenCenter;
LockWindowUpdate(Frm.Handle);
//SubTitle label
Lbl := TLabel.Create(Frm);
Lbl.Parent := Frm;
Lbl.Top := 15;
Lbl.Left := 10;
Lbl.Font.Style := [fsBold];
Lbl.Caption := FSubTitle;
Bvl1 := TBevel.Create(Frm);
Bvl1.Anchors := [akLeft, akTop, akRight];
Bvl1.Parent := Frm;
Bvl1.Shape := bsTopLine;
Bvl1.Top := 32;
Bvl1.Left := 10;
Bvl1.Width := 440;
Bvl1.Height := 13;
Bvl2 := TBevel.Create(Frm);
Bvl2.Anchors := [akLeft, akRight, akBottom];
Bvl2.Parent := Frm;
Bvl2.Shape := bsTopLine;
Bvl2.Top := 169;
Bvl2.Left := 10;
Bvl2.Width := 440;
Bvl2.Height := 13;
//Memo containing the error details
FMemo := TMemo.Create(Frm);
FMemo.Anchors := [akLeft, akTop, akRight, akBottom];
FMemo.Parent := Frm;
FMemo.Top := 41;
FMemo.Left := 10;
FMemo.Width :=440 ;
FMemo.Height := 120;
FMemo.Color := clBtnFace;
FMemo.ReadOnly := True;
FMemo.ScrollBars := ssVertical;
//Button to "NotSend" a report
Btn1 := TButton.Create(Frm);
Btn1.Name := 'NOTSEND';
Btn1.Anchors := [akRight, akBottom];
Btn1.Parent := Frm;
Btn1.Top := 181;
Btn1.Left := 197;
Btn1.Width := 125;
Btn1.Height := 25;
Btn1.OnClick := FClick;
Btn1.Caption := 'Ne pas envoyer rapport';
//Button to "Send" a report
Btn2 := TButton.Create(Frm);
Btn2.Name := 'SEND';
Btn2.Anchors := [akRight, akBottom];
Btn2.Parent := Frm;
Btn2.Top := 181;
Btn2.Left := 326;
Btn2.Width := 125;
Btn2.Height := 25;
Btn2.OnClick := FClick;
Btn2.Caption := 'Envoyer rapport';
if (FServerName = '') or (FNotificationEmail = '') or (FServerPort = 0) then
Btn2.Enabled := False;
//Fill the memo
FMemo.Lines.Clear;
FMemo.Lines.Add('Une erreur non contrle est survenue en utilisant l''application ' + Application.Title + '.');
FMemo.Lines.Add('');
FMemo.Lines.Add('Type d''exception: ' + FEException.ClassName);
FMemo.Lines.Add('Nom de l''application: ' + ExtractFileName(Application.ExeName));
FMemo.Lines.Add('Message d''erreur additionnel: ' + FEException.Message);
Frm.Hide;
Frm.Refresh;
LockWindowUpdate(0);
//Including or not a screen capture of the desktop
if FIncScreenCapture then
FScreenCapture;
Frm.ShowModal;
Frm.Free;
end;
*******************************************
** Send the report using Indy components **
*******************************************
procedure TRVSendException.FClick(Sender: TObject);
var
SMTP : TIdSMTP;
MailMessage: TIdMessage;
begin
if TButton(Sender).Name = 'SEND' then
begin
try
SMTP := TIdSMTP.Create(nil);
SMTP.Host := FServerName;
SMTP.Port := FServerPort;
MailMessage := TIdMessage.Create(nil);
MailMessage.Recipients.EMailAddresses := FNotificationEmail;
MailMessage.From.Name := FContactName;
MailMessage.Subject := 'Avesrtissement d''exception - ' + FCompanyName;
MailMessage.Priority := mpHighest;
MailMessage.Body.AddStrings(FMemo.Lines);
if (FIncScreenCapture) and (FFileName '') then
TIdAttachment.Create(MailMessage.MessageParts,FFileName);
if SMTP.Connected then
SMTP.Disconnect;
SMTP.Connect;
SMTP.Send(MailMessage);
SMTP.Disconnect;
except on E:Exception do
ShowMessage(E.Message);
end;
end;
TForm(TButton(Sender).Parent).Close;
end;
********************************************************
** Get a screenshot of the desktop to see the context **
********************************************************
procedure TRVSendException.FScreenCapture;
var
DC : HDC;
Bmp : TBitmap;
Jpg : TJPEGImage; //I use a JPG to have a minimum of bytes to send
Temp: String;
begin
DC := GetDC(GetDesktopWindow); //Get a desktophandle
Bmp := TBitmap.Create;
Jpg := TJPEGImage.Create;
Temp := GetEnvironmentVariable('TEMP');
try
Bmp.Width := GetDeviceCaps(DC,HORZRES); //Horz Size of the desktop
Bmp.Height := GetDeviceCaps(DC,VERTRES); //Vert Size of the desktop
BitBlt(Bmp.Canvas.Handle,0,0,Bmp.Width,Bmp.Height,DC,0,0,SRCCOPY);
Jpg.Assign(Bmp);
Jpg.CompressionQuality := 75;
if Temp '' then //Save the JPG in the TEMP directory
begin
FFileName := Temp + '\' + ChangeFileExt(ExtractFileName(Application.ExeName),'.JPG');
Jpg.SaveToFile(FFileName);
end;
finally
ReleaseDC(GetDesktopWindow,DC);
Jpg.Free;
Bmp.Free;
end;
end;
end.
]]>