Monitor Flashing

[Glenn9999]

Some more code I thought I'd share. This code repeatedly cycles colors on the whole monitor at the refresh rate that is returned by the XP API. Again something I'm not sure might be too useful from a utility standpoint (I do see sites that mention doing this to LCD monitors to try and unstick pixels). At best, it is a good burn-in test for a monitor.

Demonstrates in Delphi:

1) Basic threading.

2) Key and mouse controls.

3) Sending and dealing with messages (interprocess communication).

The app won't start at the true refresh rate for Windows 98/ME (the API doesn't support it, I think you have to use DirectX on that platform), but will start at a 60hz refresh rate, which hopefully should be sufficient to start from in adjusting that.

unit lcdunit;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    TimeIndicator: TLabel;
    Timer1: TTimer;
    procedure FormCreate(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure FormDblClick(Sender: TObject);
    procedure ScreenThread;
    procedure Terminate;
    procedure FormClick(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
  public
    { Public declarations }
  protected
    procedure UpdateScreen(var WinMsg:TMessage); message WM_USER+1;
  end;

const
  adjust: Longint = 5;
var
  Form1: TForm1;
  start_freq: Longint;
  freq: Longint;
  Processing: Boolean;
  screen_id: DWord;
  Screen_Delay: Integer;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
var
  DevMode: TDevMode;
begin
  { set form size to screen size }
  Form1.Width := Screen.Width;
  Form1.Height := Screen.Height;
  { bring window to foreground }
  SetForegroundWindow(Handle);
  SetActiveWindow(Application.Handle);
  ShowCursor(false);
  { try to start screen frequency to be same as vertical refresh of monitor }
  EnumDisplaySettings(nil, 0, DevMode);
  if DevMode.dmDisplayFrequency = 0 then
    start_freq := 16       { ms for 60hz }
  else
    start_freq := (1000 div DevMode.dmDisplayFrequency);
  Processing := false;
end;

procedure TForm1.Terminate;
  { terminates all threads and then the application }
  begin
    Processing := false;
    ShowCursor(True);
    WaitForSingleObject(screen_id, INFINITE);
    Application.Terminate;
  end;

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if key in [vk_up, vk_right] then
    begin
      if freq < 100 then
        begin
          inc(freq, adjust);
          TimeIndicator.Caption := IntToStr(freq) + ' ms';
        end;
      TimeIndicator.Visible := true;
      Timer1.Enabled := true;
    end
  else
    if key in [vk_down, vk_left] then
      begin
        if freq-adjust > 0 then
          begin
            dec(freq, adjust);
            TimeIndicator.Caption := IntToStr(freq) + ' ms';
          end;
        TimeIndicator.Visible := true;
        Timer1.Enabled := true;
      end
    else
      Terminate;
end;

procedure TForm1.UpdateScreen(var WinMsg:TMessage);
  begin
    Form1.Color := WinMsg.LParam;
    TimeIndicator.Color := Form1.Color;
  end;

procedure TForm1.ScreenThread;
  { process screen.  Keep changing screen from Red -> Green -> Blue }
const
  ColorList: array[1..3] of TColor = (clRed, clGreen, clBlue);
var
  colortype: integer;
begin
  sleep(1000); { to let the user see a pure black screen }
  while Processing do
    for colortype := 1 to 3 do
      begin
        PostMessage(Form1.Handle, WM_USER+1, 0, Integer(ColorList[colortype]));
        sleep(freq);
      end;
  EndThread(0);
end;

procedure TForm1.FormDblClick(Sender: TObject);
  begin
    Memo1.Visible := false;
    processing := true;
    freq := start_freq;
    TimeIndicator.Caption := IntToStr(freq) + ' ms';
    TimeIndicator.Left := Screen.Width - TimeIndicator.Width - 50;
    TimeIndicator.Top := Screen.Height - TimeIndicator.Height - 20;
    BeginThread(nil, 0, Addr(TForm1.ScreenThread), nil, 0, screen_id);
  end;

procedure TForm1.FormClick(Sender: TObject);
 { single click, we do not want to respond if we have not started processing
   via double-click }
begin
  if Processing then Terminate;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
{ timer is triggered to make the TimeIndicator disappear after 2 seconds }
begin
  TimeIndicator.Visible := false;
  Timer1.Enabled := false;
end;

end.

[gunsmokingman]

Thank you for posting this code.

[Oziyn]

COOL

Im gonna play around with it!

EDIT: Turn it on and just stare at it for 30 seconds. You WILL die.

Edited August 5, 2009 by Oziyn