msgshowunt.pas

一个自定义应用程序异常的类 delphi控件

  begin
    Btn := TButton.Create(self);
    Btn.parent := self;

    Btn.Width := 70;
    Btn.Top := nbtnTop;
    Btn.Left := frm1.Width - 270;
    Btn.Name := 'SB_YES';
    Btn.Caption := '是';
    Btn.OnClick := OnClickBtn;
    Btn.SetFocus;

    Btn := TButton.Create(self);
    Btn.parent := self;

    Btn.Width := 70;
    Btn.Top := nbtnTop;
    Btn.Left := frm1.Width - 180;
    Btn.Name := 'SB_NO';
    Btn.Caption := '否';
    Btn.OnClick := OnClickBtn;
    if defaultButton = 2 then
      Btn.SetFocus;

    Btn := TButton.Create(self);
    Btn.parent := self;

    Btn.Width := 70;
    Btn.Top := nbtnTop;
    Btn.Left := frm1.Width - 90;
    Btn.Name := 'SB_CANCEL';
    Btn.Cancel := true;
    Btn.Caption := '取 消';
    Btn.OnClick := OnClickBtn;
    if defaultButton = 3 then
      Btn.SetFocus;
  end;

  if Mst = SB_ErrorReport then
  begin

    Btn := TButton.Create(self);
    Btn.parent := self;
    Btn.Width := 70;
    Btn.Top := nbtnTop;
    Btn.Left := frm1.Width - 220;
    Btn.Name := 'SB_CANCEL';
    Btn.Cancel := true;
    Btn.Caption := '取 消';
    Btn.OnClick := OnClickBtn;
    Btn.SetFocus;

    Btn := TButton.Create(self);
    Btn.parent := self;
    Btn.Width := 120;
    Btn.Top := nbtnTop;
    Btn.Left := frm1.Width - 130;
    Btn.Name := 'SB_ERRORREPORT';
    Btn.Caption := '发送错误报告';
    Btn.OnClick := OnClickBtn;
    //    if defaultButton = 2 then
    Btn.SetFocus;

  end;

  if Mst = SB_OKOPTION then
  begin
    Btn := TButton.Create(self);
    Btn.parent := self;

    Btn.Width := 70;
    Btn.Top := nbtnTop;
    Btn.Left := frm1.Width - 180;
    Btn.Name := 'SB_OK';
    Btn.Caption := '确 定';
    Btn.OnClick := OnClickBtn;
    Btn.SetFocus;

    Btn := TButton.Create(self);
    Btn.parent := self;
    Btn.Width := 70;
    Btn.Top := nbtnTop;
    Btn.Left := frm1.Width - 90;
    Btn.Name := 'SB_OPTION';
    Btn.Caption := '详细>>>';
    Btn.OnClick := OnClickBtn;
    if defaultButton = 2 then
      Btn.SetFocus;
  end;

  if Mst = SB_About then
  begin
    Btn := TButton.Create(self);
    Btn.parent := self;

    Btn.Width := 70;
    Btn.Top := nbtnTop;
    Btn.Left := frm1.Width - 230;
    Btn.Name := 'SB_OK';
    Btn.Caption := '确 定';
    Btn.OnClick := OnClickBtn;
    Btn.SetFocus;

    Btn := TButton.Create(self);
    Btn.parent := self;
    Btn.Width := 120;
    Btn.Top := nbtnTop;
    Btn.Left := frm1.Width - 140;
    Btn.Name := 'SB_SYSINFO';
    Btn.Caption := '系统信息>>>';
    Btn.OnClick := OnClickBtn;
    if defaultButton = 2 then
      Btn.SetFocus;
  end;

end;

function ShowMsg(Text: string; ShowType: Integer = SB_OK; ShowTime: Integer =
  -1; Caption: string = ''; defButton: integer = -1; ShowIcon: integer = 1;
  OptionText: string = '详细的信息'): Integer;
var
  frm: TMsgShowFrm;
begin
  //  MsgShowFrm := nil;
  MsgShowFrm := TMsgShowFrm.Create(nil);
  MsgShowFrm.defaultButton := defButton;
  MsgShowFrm.btnTop := 110;
  MsgShowFrm.btnTopAutoSize := 0;
  if minWidth > 0 then
    MsgShowFrm.Constraints.MinWidth := minWidth;
  minWidth := 0;

  //  MsgShowFrm := frm;

  MessageBeep(64);
  //  StayOnTop(frm.Handle,True);
  try
    MsgShowFrm.LabMsg.Caption := Text;
    MsgShowFrm.LabMsg.AutoSize := True;
    if Caption = '' then
      MsgShowFrm.LabCap.Caption := Application.Title
    else
      MsgShowFrm.LabCap.Caption := Caption;

    MsgShowFrm.btnTopAutoSize := MsgShowFrm.LabMsg.Height - 12;

    MsgShowFrm.FMeoOption.Lines.Text := OptionText;
    MsgShowFrm.SType := ShowType;
    MsgShowFrm.SIcon := ShowIcon;
    MsgShowFrm.STime := ShowTime;
    if ShowTime <> -1 then
    begin
      //      MsgShowFrm.Timer1.Interval := ShowTime*1000;
      MsgShowFrm.oldcaption := MsgShowFrm.labcap.caption;
      MsgShowFrm.timeCount := 0;
      MsgShowFrm.Timer1.Enabled := True;
    end;
    //    if Assigned(MsgShowFrm) then
    MsgShowFrm.ShowModal;
  finally

    try
      if Assigned(MsgShowFrm) then
      begin
        ShowMsg := MsgShowFrm.VaResult;
        MsgShowFrm.free;
        MsgShowFrm := nil;
      end;
    except

    end;
  end;
end;

procedure TMsgShowFrm.OnClickBtn(Sender: TObject);
var
  fErrName: string;
begin
  Application.ProcessMessages;

  if TButton(Sender).name = 'SB_OK' then
  begin
    VaResult := IDOK;
    Close;
  end;
  if TButton(Sender).name = 'SB_CANCEL' then
  begin
    VaResult := IDCANCEL;
    Close;
  end;
  if TButton(Sender).name = 'SB_YES' then
  begin
    VaResult := IDYES;
    Close;
  end;
  if TButton(Sender).name = 'SB_NO' then
  begin
    VaResult := IDNO;
    Close;
  end;
  if (TButton(Sender).name = 'SB_OPTION')  then
  begin
    FMeoOption.Visible := not (FMeoOption.Visible);
    if FMeoOption.Visible then
      self.Height := btnTopAutoSize + 300
    else
      self.Height := btnTopAutoSize + 113;
  end;
  if (TButton(Sender).name = 'SB_SYSINFO') then
  begin
    FMeoOption.Visible := not (FMeoOption.Visible);
    if FMeoOption.Visible then
    begin
      self.Height := btnTopAutoSize + 300;
      GetSysInfo;
    end
    else
      self.Height := btnTopAutoSize + 113;
  end;

  if TButton(Sender).name = 'SB_ERRORREPORT' then
  begin
    fErrName := IncludeTrailingBackslash(GetCurrentDir) + 'ErrReport.htm';
    FMeoOption.Text :=
      '<html>' + #13#10 +
      '' + #13#10 +
      '<head>' + #13#10 +
      '<title>发送错误报告</title>' + #13#10 +
      '</head>' + #13#10 +
      '' + #13#10 +
      '<body>' + #13#10 +
      '<b>亲爱的中天一卡通科技有限公司技术部技术员,<br>' + #13#10 +
      '</b><br>' + #13#10 +
      '　　<font color="#808080" size="3"><i>您好，我在操作软件  　' +
      Application.Title + #13#10 +
      '时，发生错误，以下是详细的错误信息。<br>' + #13#10 +
      '　　希望能得到您及时的解答，谢谢。<br>' + #13#10 +
      '　　祝您工作愉快。</i></font>' + #13#10 +
      '<hr>' + #13#10 +
      '' + #13#10 +
      '<form method="POST" name="ReportError" action="' + 'http://www.jmsoft8.com' +
      '/report/Error.asp">' + #13#10 +
      '  <p align="center"><br>' + #13#10 +
      '  <textarea rows="15" name="nErrorPort" cols="80">'
      + LabMsg.Caption + #13#10 +
      '  </textarea><br><br>' + #13#10 +
      '  <input type="submit" value="提交错误报告" name="B1">&nbsp;&nbsp;&nbsp;<input type="reset" value="全部重写" name="B2"></p>' + #13#10
      + '</form>' + #13#10 + '' + #13#10 + '<hr>' + #13#10 +
      '<p align="right"><font color="#C0C0C0" size="3">' + #13#10 +
      '本错误报告由系统自动产生<br>' + DateTimeToStr(Now) + '</font></p>' +
      #13#10 +
      '' + #13#10 +
      '</body>' + #13#10 +
      '' + #13#10 +
      '</html>';
    FMeoOption.Lines.SaveToFile(fErrName);
    ShellExecute(Handle, '', PChar(fErrName), '', '', SW_MAXIMIZE);
    VaResult := IDCANCEL;
    Close;
  end;
end;

procedure TMsgShowFrm.TimeClosefrm;
begin
  Self.Hide;

  Application.ProcessMessages;
  if SType = SB_OK then
  begin
    VaResult := IDOK;
    Close;
  end;
  if SType = SB_OKCANCEL then
  begin
    VaResult := IDCANCEL;
    Close;
  end;
  if SType = SB_YESNO then
  begin
    VaResult := IDNO;
    Close;
  end;
  if (SType = SB_OKOPTION) or
    (SType = SB_ABOUT) then
  begin
    VaResult := IDOK;
    Close;
  end;

  if (SType = SB_YESNOCANCEL) or
    (SType = SB_ErrorReport) then
  begin
    VaResult := IDCANCEL;
    Close;
  end;
end;

procedure TMsgShowFrm.Timer1Timer(Sender: TObject);
begin
  LabCap.Caption := oldCaption + '(' + IntToStr(stime - timecount) + ')';
  timeCount := timeCount + 1;

  if timeCount > STime then
  begin
    Timer1.Enabled := false;
    TimeClosefrm;
  end;
end;

procedure TMsgShowFrm.setMinWidth(i: integer);
begin
  MinWidth := i;
end;

procedure TMsgShowFrm.lbHttpMouseEnter(Sender: TObject);
var
  fs : TFontStyles;
begin
//  lbHttp.Font.Color := clBlue;
//  lbHttp.Cursor := crHandPoint;
  inherited;
  fs := lbHttp.Font.Style;
  Include(fs,fsUnderline);
  lbHttp.Font.Style := fs;
end;

procedure TMsgShowFrm.lbHttpMouseLeave(Sender: TObject);
var
  fs : TFontStyles;
begin
//  lbHttp.Font.Color := clBlue;
//  lbHttp.Cursor := crHandPoint;
  inherited;
  fs := lbHttp.Font.Style;
  Exclude(fs,fsUnderline);
  lbHttp.Font.Style := fs;
end;

procedure TMsgShowFrm.lbHttpClick(Sender: TObject);
begin
  ShellExecute(Handle,'',PChar('http://www.jmsoft8.com'),'','',SW_SHOWMAXIMIZED);
end;

end.