Tweet
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
TOrdTyp=(otButton, otIcon, otDefButton);
TarrTyp=array[TOrdTyp] of Cardinal;
TMeinDlg=class(TObject)
private
class function Parser(const AiTyp: cardinal): TarrTyp;
class function MaxZeilenLaenge(ALbl: TLabel): integer;
class procedure Activate(Sender: TForm);
public
class function Anzeige(const AcText, AcCaption: String;
const AiTyp: Cardinal;
const AclFarbe: TColor = 0) : Integer;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
uses
Math, TypInfo;
class function TMeinDlg.Parser(const AiTyp: cardinal): TarrTyp;
begin
//Werte as AiTyp auf Eigenschaften zuweisen
//1. Byte Button, 2. Byte Icon, 3. Byte Default-Button
// 3. Byte bestimmen und auf otDefButton ablegen
Result[otDefButton] := (AiTyp shr 8) shl 8;
// Erste Differenz zum 3. Byte merken (zwischenspeichern)
Result[otButton] := AiTyp - Result[otDefButton];
// 2. Byte aus Zwischenspeicher bestimmen und auf otIcon ablegen
Result[otIcon] := (Result[otButton] shr 4) shl 4;
// 1. Byte aus zweiter Result bestimmen und auf otButton abelegen
Result[otButton] := Result[otButton] - Result[otIcon];
end;
class function TMeinDlg.MaxZeilenLaenge(ALbl: TLabel): integer;
var
LcText,
LcSub : string;
LiPos : integer;
begin
Result := 0;
LcText := ALbl.Caption;
LiPos := pos(#13, LcText);
While LiPos > 0 do
begin
LcSub := Trim(copy(LcText, 1, pred(LiPos)));
Result := Max(Result, ALbl.Canvas.TextWidth(LcSub));
delete(LcText, 1, LiPos);
LiPos := pos(#13, LcText);
end;
LcSub := Trim(LcText);
Result := Max(Result, ALbl.Canvas.TextWidth(LcSub));
end;
class procedure TMeinDlg.Activate(Sender: TForm);
var
LarrTyp : TarrTyp;
Li,
LiSize,
LiPos : integer;
Lbtn : TButton;
LLbl : TLabel;
begin
Sender.OnActivate := nil;
//Korrekturen: Delphi-Dialog bricht standardmäßig selbst Text um.
//Hier wird die Breite des Dialogs korrigiert
//Label mit Textinhalt holen. Label hat den Namen Message!
LLbl := Sender.FindComponent('Message') as TLabel;
//erforderliche Textbreite bestimmen
LiSize := MaxZeilenLaenge(LLbl);
//Dialogbreite auf 2/3 der Bildschirmgröße beschränkt
//Meldung bricht automatisch um
if (LiSize > LLbl.Width) and (LiSize < (Screen.Width/3)*2) then
//Dialog muß bezüglich der Breite korrigiert werden
begin
//Differenz merken
LiSize := LiSize - LLbl.Width;
//Textbreite korrigieren
Sender.Width := Sender.Width + LiSize;
//Wird über Autosize umgesetzt: LLbl.Width := LiSize;
Sender.Left := (Screen.Width - Sender.Width) div 2;
LLbl.WordWrap := False;
//Button-Position korrigieren
//Hier werden die Buttons repositioniert (Left-Eigenschaft korrigiert)
for Li := 0 to pred(Sender.ComponentCount) do
if Sender.Components[Li] is TButton then
//Button gefunden
begin
//Left-Wert um Hälfte der Vergrößerung aktualisieren
Lbtn := Sender.Components[Li] as TButton;
Lbtn.Left := Lbtn.Left + (LiSize div 2);
end;
end;
LarrTyp := Parser(Sender.Tag);
case LarrTyp[otButton] of
MB_RETRYCANCEL: //Buttons sind bei MessageBox zu Delphi gedreht, daher
//Defaultbutton tauschen
if LarrTyp[otDefButton] = MB_DEFBUTTON2 then
LarrTyp[otDefButton] := MB_DEFBUTTON1
else
LarrTyp[otDefButton] := MB_DEFBUTTON2
end;
case LarrTyp[otDefButton] of
//MB_DEFBUTTON1
MB_DEFBUTTON2: LiPos := 2;
MB_DEFBUTTON3: LiPos := 3;
MB_DEFBUTTON4: LiPos := 4;
else LiPos := 1;
end;
Li := 1;
While Li < LiPos do
begin
Sender.Perform(WM_NEXTDLGCTL, 0, 0);
inc(Li);
end;
MessageBeep(LarrTyp[otIcon]);
end;
class function TMeinDlg.Anzeige(const AcText, AcCaption: String;
const AiTyp: Cardinal;
const AclFarbe: TColor = 0) : Integer;
var
LDlg : TForm;
LnDlgTyp : TMsgDlgType;
LmButtons : TMsgDlgButtons;
LRecM : TMethod;
LarrTyp : TarrTyp;
begin
LarrTyp := TMeinDlg.Parser(AiTyp);
//Button bestimmen...
case LarrTyp[otButton] of
MB_ABORTRETRYIGNORE : LmButtons := mbAbortRetryIgnore;
MB_RETRYCANCEL : LmButtons := [mbRetry, mbCancel];
MB_OKCANCEL : LmButtons := mbOKCancel;
MB_YESNO : LmButtons := [mbYes, mbNo];
MB_YESNOCANCEL : LmButtons := mbYesNoCancel;
// mbYesAllNoAllCancel
// mbAbortIgnore
else LmButtons := [mbOK];
end;
//Icon bestimmen...
//mtWarning, mtError, mtInformation, mtConfirmation, mtCustom
case LarrTyp[otIcon] of
// MB_ICONHAND == MB_ICONERROR == MB_ICONSTOP
// MB_ICONQUESTION ==
// MB_ICONEXCLAMATION == MB_ICONWARNING
// MB_ICONASTERISK == MB_ICONINFORMATION
// MB_USERICON
//MB_ICONERROR ==
//MB_ICONSTOP ==
MB_ICONHAND : LnDlgTyp := mtError;
MB_ICONQUESTION : LnDlgTyp := mtConfirmation;
//MB_ICONEXCLAMATION ==
MB_ICONWARNING : LnDlgTyp := mtWarning;
//MB_ICONASTERISK ==
MB_ICONINFORMATION : LnDlgTyp := mtInformation;
//MB_USERICON : ???
else LnDlgTyp := mtInformation;
end;
LDlg := CreateMessageDialog(AcText, LnDlgTyp, LmButtons);
try
//OnActivate des MessageDialogs wird in dieser Unit durchlaufen!
// Methode TBescheid.Activate;
LRecM.Code := @TMeinDlg.Activate;
LRecM.Data := Ldlg;
SetMethodProp(Ldlg, 'OnActivate', LRecM);
Ldlg.Position := poScreenCenter;
if AcCaption <> EmptyStr then
Ldlg.Caption := AcCaption;
Ldlg.Tag := AiTyp;
//Farbe zuweisen
if AclFarbe <> 0 then
SetOrdProp(Ldlg, 'Color', AclFarbe);
//Falls Application minimiert, diesen zuerst anzeigen
ShowWindow(Application.Handle, SW_RESTORE);
Result := Ldlg.ShowModal;
finally
Ldlg.Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
TMeinDlg.Anzeige('Hier kommt mein Text', 'Hier die Überschrift', MB_ICONQUESTION or MB_YESNOCANCEL, clBlue);
TMeinDlg.Anzeige('Hier kommt noch ein Text', EmptyStr, MB_ABORTRETRYIGNORE or MB_YESNOCANCEL, clRed);
end;
end.
Comment