Einzelnen Beitrag anzeigen

FarAndBeyond
(Gast)

n/a Beiträge
 
#8

AW: NotifyWindow, dynamisches Fenster in nur einer Prozedur inklusive Events und AA

  Alt 14. Nov 2015, 21:30
So ist das noch besser:

- ErrorLog gepimpt ... grins
- keine Globale mehr
- Meldungsfenster mit ScrollFunktion

Naja, ein Meldungsfenster eben, nicht mehr und nicht weniger...

Delphi-Quellcode:
Unit uNotifyWindow;

Interface
 Uses Windows, Messages, Forms, Classes, SysUtils, Graphics, Controls, StdCtrls;

 Type
  NotifyWindow = Class
   Class Procedure KeyDown (Sender: TObject; Var Key: Word; Shift: TShiftstate);

    Public
     Class Procedure Show (WindowTitle: String; WindowText: String);
  End;

 Type
  WheelMemo = Class(TMemo)
   Class Procedure WheelUp (Sender: TObject; Shift: TShiftState; MousePos: TPoint; Var Handled: Boolean);
   Class Procedure WheelDown (Sender: TObject; Shift: TShiftState; MousePos: TPoint; Var Handled: Boolean);
   Class Procedure KeyDown (Sender: TObject; Var Key: Word; Shift: TShiftstate);
   Class Procedure NoMenu (Sender: TObject; MousePos: TPoint; Var Handled: Boolean);

    Protected
     Procedure WMSetFocus (Var MSG: TWMSETFOCUS); Message WM_SETFOCUS;
  End;

Implementation


Procedure ErrorLog(ErrorInfo: String);
  Var
   LoadErrorLog : TStringlist;
   SaveErrorInfo: TStringlist;
   ErrorLog : String;

  Procedure Free_LoadErrorLog;
   Begin
    Try
     FreeAndNil(LoadErrorLog);
    Except
     Exit;
    End;
   End;

  Procedure Free_SaveErrorInfo;
   Begin
    Try
     FreeAndNil(SaveErrorInfo);
    Except
     Exit;
    End;
   End;

  Function ErrorLogExists : Boolean;
   Begin
    Try
     Result:= False;
      If FileExists('ErrorLog.txt')
      Then
       Begin
        Try
         LoadErrorLog:= TStringlist.Create;
         LoadErrorLog.LoadFromFile('ErrorLog.txt');
         ErrorLog:= LoadErrorLog.Text;
         Result:= True;
        Finally
         Free_LoadErrorLog;
        End;
       End;
    Except
     Exit;
    End;
   End;

 Begin
  Try
   Try
    SaveErrorInfo:= TStringlist.Create;
     SaveErrorInfo.Add(DateTimeToStr(Now));
     SaveErrorInfo.Add(ErrorInfo);
     
      If ErrorLogExists
      Then
       Begin
        SaveErrorInfo.Add(' ');
        SaveErrorInfo.Add(Trim(ErrorLog));
       End;

     SaveErrorInfo.SaveToFile('ErrorLog.txt');
   Finally
    Free_SaveErrorInfo;
   End;
  Except
   Exit;
  End;
 End;


Procedure Close_ErrorWindow(AForm: TForm);
 Begin
  Try
   AForm.Close;
  Except
   ErrorLog('uNotifyWindow: Close_ErrorWindow Failed');
   Exit;
  End;
 End;


Procedure WheelMemo.WMSetFocus(Var MSG: TWMSETFOCUS);
 Begin
  Try
   If MSG.Msg = WM_SETFOCUS
   Then HideCaret(Self.Handle)
   Else Inherited;
  Except
   ErrorLog('uNotifyWindow: WheelMemo.WMSetFocus Failed');
   Exit;
  End;
 End;


Class Procedure WheelMemo.NoMenu(Sender: TObject; MousePos: TPoint; Var Handled: Boolean);
 Begin
  Try
   Handled:= True;
  Except
   ErrorLog('uNotifyWindow: WheelMemo.NoMenu Failed');
   Exit;
  End;
 End;


Class Procedure WheelMemo.WheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; Var Handled: Boolean);
 Begin
  Try
   If Sender Is WheelMemo
   Then WheelMemo(Sender).Perform(EM_SCROLL,SB_LINEDOWN,0);
  Except
   ErrorLog('uNotifyWindow: WheelMemo.WheelDown Failed');
   Exit;
  End;
 End;


Class Procedure WheelMemo.WheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; Var Handled: Boolean);
 Begin
  Try
   If Sender Is WheelMemo
   Then WheelMemo(Sender).Perform(EM_SCROLL,SB_LINEUP,0);
  Except
   ErrorLog('uNotifyWindow: WheelMemo.WheelUp Failed');
   Exit;
  End;
 End;


Class Procedure WheelMemo.KeyDown(Sender: TObject; Var Key: Word; Shift: TShiftstate);
 Begin
  Try
   Key:= 0;
  Except
   ErrorLog('uNotifyWindow: WheelMemo.KeyDown Failed');
   Exit;
  End;
 End;


Class Procedure NotifyWindow.KeyDown(Sender: TObject; Var Key: Word; Shift: TShiftstate);

  Function GetKey(Keycode: Integer) : Boolean;
   Begin
    GetKey:= GetAsyncKeyState(KeyCode) <> 0;
   End;

  Function OK_Pressed : Boolean;
   Begin
    OK_Pressed:= GetKey(VK_LControl) And GetKey(VK_LMenu) And GetKey(Ord('O')) And GetKey(Ord('K'));
   End;

 Begin
  Try
   If OK_Pressed
   Then TForm(Sender).Close;
  Except
   ErrorLog('uNotifyWindow: NotifyWindow.KeyDown Failed');
   Close_ErrorWindow(TForm(Sender));
   Exit;
  End;
 End;


Class Procedure NotifyWindow.Show(WindowTitle: String; WindowText: String);
  Var
   ErrorWindow: TForm;
   MEMO : WheelMemo;
   PRG : WheelMemo;
   PRESS : TLabel;
   OK : TLabel;

  Procedure Free_ErrorWindow;
   Begin
    Try
     FreeAndNil(ErrorWindow);
    Except
     Exit;
    End;
   End;

  Procedure AAFont(ObjFont: TFont);
    Var
     LogFont: TLogFont;
   Begin
    Try
     GetObject(ObjFont.Handle, SizeOf(TLogFont),@LogFont);
     LogFont.lfQuality:= ANTIALIASED_QUALITY;
     ObjFont.Handle:= CreateFontIndirect(LogFont);
    Except
     ErrorLog('uNotifyWindow: NotifyWindow.Show: AAFont Failed');
     Exit;
    End;
   End;

 Begin
  Try
   Try
    ErrorWindow := TForm.Create(Nil);
    ErrorWindow.Height := 418;
    ErrorWindow.Width := 580;
    ErrorWindow.BorderStyle := bsSingle;
    ErrorWindow.BorderIcons := [];
    ErrorWindow.Color := 898061;
    ErrorWindow.FormStyle := fsStayOnTop;
    ErrorWindow.Left := (Screen.Width - ErrorWindow.Width) Div 2;
    ErrorWindow.Top := (Screen.Height - ErrorWindow.Height) Div 2;
    ErrorWindow.KeyPreview := True;
    ErrorWindow.DoubleBuffered:= True;
    ErrorWindow.OnKeyDown := NotifyWindow.KeyDown;

    MEMO := WheelMemo.Create(ErrorWindow);
    MEMO.Alignment := taLeftJustify;
    MEMO.BorderStyle := bsSingle;
    MEMO.Color := 898061;
    MEMO.Font.Color := clBlack;
    MEMO.Font.Size := 14;
    MEMO.Font.Name := 'Verdana';
    MEMO.Font.Style := [fsBold];
    MEMO.Height := 280;
    MEMO.Width := ErrorWindow.Width-52;
    MEMO.Left := 23;
    MEMO.Top := 77;
    MEMO.ReadOnly := True;
    MEMO.HideSelection := True;
    MEMO.ScrollBars := ssNone;
    MEMO.Parent := ErrorWindow;
    MEMO.Text := WindowText;
    MEMO.DoubleBuffered := True;
    MEMO.Cursor := crArrow;
    MEMO.OnKeyDown := WheelMemo.KeyDown;
    MEMO.OnMouseWheelDown:= WheelMemo.WheelDown;
    MEMO.OnMouseWheelUp := WheelMemo.WheelUp;
    MEMO.OnContextPopup := WheelMemo.NoMenu;

    PRG := WheelMemo.Create(ErrorWindow);
    PRG.Alignment := taLeftJustify;
    PRG.BorderStyle := bsNone;
    PRG.Color := 898061;
    PRG.Font.Color := clBlue;
    PRG.Font.Size := 18;
    PRG.Font.Name := 'Arial';
    PRG.Font.Style := [fsBold];
    PRG.Height := 66;
    PRG.Width := ErrorWindow.Width-52;
    PRG.Left := 23;
    PRG.Top := 5;
    PRG.ReadOnly := True;
    PRG.HideSelection := True;
    PRG.ScrollBars := ssNone;
    PRG.Parent := ErrorWindow;
    PRG.Text := WindowTitle;
    PRG.DoubleBuffered := True;
    PRG.Cursor := crArrow;
    PRG.OnKeyDown := WheelMemo.KeyDown;
    PRG.OnMouseWheelDown:= WheelMemo.WheelDown;
    PRG.OnMouseWheelUp := WheelMemo.WheelUp;
    PRG.OnContextPopup := WheelMemo.NoMenu;

    PRESS := TLabel.Create(ErrorWindow);
    PRESS.Caption := 'PRESS OK';
    PRESS.Transparent:= True;
    PRESS.Font.Color := clBlue;
    PRESS.Font.Name := 'Arial';
    PRESS.Font.Size := 14;
    PRESS.Font.Style := [fsBold];
    PRESS.AutoSize := True;
    PRESS.Left := 24;
    PRESS.Top := 363;
    PRESS.Parent := ErrorWindow;

    OK := TLabel.Create(ErrorWindow);
    OK.Caption := 'CTRL + ALT + O + K';
    OK.Transparent:= True;
    OK.Font.Color := clBlue;
    OK.Font.Name := 'Arial';
    OK.Font.Size := 14;
    OK.Font.Style := [fsBold];
    OK.AutoSize := True;
    OK.Left := 335;
    OK.Top := 363;
    OK.Parent := ErrorWindow;

    AAFont(PRG.Font);
    AAFont(MEMO.Font);
    AAFont(OK.Font);
    AAFont(PRESS.Font);

    ErrorWindow.ShowModal;
   Finally
    Free_ErrorWindow;
   End;
  Except;
   ErrorLog('uNotifyWindow: NotifyWindow.Show Failed');
   Exit;
  End;
 End;

End.
  Mit Zitat antworten Zitat