camphillsetup.pas

一个用Delphi编写的很好的屏保程序

unit CamphillSetup;

interface
uses
  SysUtils,
  Messages,
  CommDlg,
  CommCtrl,
  Windows;

{This is implemented as an old-fashioned Dialog Box
created with a resource editor. This is because it
seems a bit excessive to drag the whole of the VCL into
this program just for the sake of a wee dialog. The program
compiles to 80kB which is big enough. If you add 'Forms'
to the uses list of this unit, it goes up to 319kB!}

const
  PolyCount = 6;
  MaxText = 60;

type
  TFontString = String[LF_FACESIZE];

  TSettings =
  record
    Speed: DWORD;
    WithText: Boolean;
    LookHeight, LookDist: Integer;
    Rainbow: Boolean;
    BackColour,
    BodyColour,
    TextColour: Cardinal;
    Text: String[MaxText];
    TextOutline,
    TextBold,
    TextItalic,
    TextRotating: Boolean;
    TextFont: TFontString;
    FontDepth: Integer;
    Polychrome: array[0..PolyCount-1] of Cardinal;
    CustomColours: array[0..15] of Cardinal;
  end;

procedure DoSetup(Window: hWnd);
procedure WriteSettings(const Settings: TSettings);
procedure ReadSettings(var Settings: TSettings);


implementation

{note that the colour swatches and corresponding buttons have the same ID numbers.
  All WMDrawItem messages come from the swatches because the buttons are not owner-draw
  All WMCommand messages come from the buttons because the swatches do not notify
}

const
  DefaultSettings: TSettings = (
    Speed: 50;
    WithText: True;
    LookHeight: 1000;
    LookDist: 13000;
    Rainbow: True;
    BackColour: $00505070;
    BodyColour: $00785040;
    TextColour: $00A06060;
    Text: 'The Sheiling School';
    TextOutline: false;
    TextBold: false;
    TextItalic: false;
    TextRotating: true;
    TextFont: 'Arial';
    FontDepth: 5;
    Polychrome: (
      $000000FF,
      $00008080,
      $0000FF00,
      $00808000,
      $00FF0000,
      $00800080)
  );


  RegKey = 'Software\ProductionRobots\SheilingSS';

  RegValue = 'Settings';

{$I Camphill.inc}

type
  TSetupDlg =
  class
    hDlg: hWnd;
    Settings: TSettings;
    function GetIntegerValue( ID: Integer): Integer;
    procedure SetIntegerValue( ID: Integer; Value: Integer);
    function GetBooleanValue( ID: Integer): Boolean;
    procedure SetBooleanValue( ID: Integer; Value: Boolean);
    function GetColourVal(ID: Integer): Cardinal;
    procedure SetColourVal(ID: Integer; Value: Cardinal);
    function GetStringValue(ID: Integer): String;
    procedure SetStringValue(ID: Integer; const Value: String);
    function GetComboStringValue(ID: Integer): String;
    procedure SetComboStringValue(ID: Integer; const Value: String);
    procedure SetupUD(ID, Lower, Upper, Step: Integer; Hex: Boolean);

    procedure WMInitDialog(var Msg: TWMInitDialog); message WM_INITDIALOG;
    procedure WMCommand(var Msg: TWMCommand); message WM_COMMAND;
    procedure WMDrawItem(var Msg: TWMDrawItem); message WM_DRAWITEM;
    procedure WMNotify(var Msg: TWMNotify); message WM_NOTIFY;
    constructor Create;
    procedure InitControls;
    procedure ChooseColour(ID: Integer);
    function Execute(hWnd: HWND): Boolean;
    property SpeedControl: Integer index IDC_SPEED read GetIntegerValue write SetIntegerValue;
    property WithTextControl: Boolean index IDC_WITHTEXT read GetBooleanValue write SetBooleanValue;
    property LookHeightControl: Integer index IDC_LOOKHEIGHT read GetIntegerValue write SetIntegerValue;
    property LookDistControl: Integer index IDC_LOOKDIST read GetIntegerValue write SetIntegerValue;
    property RainbowControl: Boolean index IDC_RAINBOW read GetBooleanValue write SetBooleanValue;
    property TextControl: String index IDC_TEXT read GetStringValue write SetStringValue;
    property TextOutlineControl: Boolean index IDC_OUTLINE read GetBooleanValue write SetBooleanValue;
    property TextBoldControl: Boolean index IDC_BOLD read GetBooleanValue write SetBooleanValue;
    property TextItalicControl: Boolean index IDC_ITALIC read GetBooleanValue write SetBooleanValue;
    property TextRotatingControl: Boolean index IDC_ROTATING read GetBooleanValue write SetBooleanValue;
    property TextFaceControl: String index IDC_FONTLIST read GetComboStringValue write SetComboStringValue;
    property FontDepthControl: Integer index IDC_FONTDEPTH read GetIntegerValue write SetIntegerValue;
    property ColourVal[ID: Integer]: Cardinal read GetColourVal write SetColourVal;
  end;

function DialogProc( hDlg: hWnd;
                     uMsg: UINT;
                   wParam: WPARAM;
                   lParam: LPARAM): BOOL; stdcall;
var
  This: TSetupDlg;
  Msg: TMessage;
begin
  if uMsg = WM_INITDIALOG then
  begin
    SetWindowLong(hDlg, DWL_USER, lParam);
    This:= TSetupDlg(lParam);
    This.hDlg:= hDlg
  end else
  begin
    This:= TSetupDlg(GetWindowLong(hDlg, DWL_USER))
  end;
  if Assigned(This) then
  begin
    Msg.Msg:= uMsg;
    Msg.wParam:= wParam;
    Msg.lParam:= lParam;
    Msg.Result:= 0;
    This.Dispatch(Msg);
    Result:= BOOL(Msg.Result)
  end else
  begin
    Result:= false
  end
end;

constructor TSetupDlg.Create;
begin
  inherited Create;
  ReadSettings(Settings)
end;

function TSetupDlg.Execute(hWnd: HWND): Boolean;
begin
  Result:= Boolean(DialogBoxParam(System.MainInstance,
                                  MakeIntResource(IDD_SETUP),
                                  hWnd, @DialogProc,
                                  Integer(Self)))
end;

function TSetupDlg.GetIntegerValue( ID: Integer): Integer;
procedure SignExtend( var I: Integer);
begin
  if (I and Integer($8000)) <> 0 then
    I:= I or Integer($FFFF0000)
end;
begin
  Result:= SendMessage(GetDlgItem(hDlg, ID), UDM_GETPOS, 0, 0);
  SignExtend(Result)
end;

procedure TSetupDlg.SetIntegerValue( ID: Integer; Value: Integer);
begin
  SendMessage(GetDlgItem(hDlg, ID), UDM_SETPOS, 0, Value)
end;

procedure TSetupDlg.SetupUD(ID, Lower, Upper, Step: Integer; Hex: Boolean);
var
  Wnd: HWND;
  Accel: TUDAccel;
const
  Base: array[Boolean] of Integer = (10, 16);
begin
  Wnd:= GetDlgItem(hDlg, ID);
  SendMessage(Wnd, UDM_SETRANGE, 0, MakeLong(Upper, Lower));
  Accel.nSec:= 0;
  Accel.nInc:= Step;
  SendMessage(Wnd, UDM_SETACCEL, 1, Integer(@Accel));
  SendMessage(Wnd, UDM_SETBASE, Base[Hex], 0)
end;

function EnumFontFamProc(
    var lpelf: TEnumLogFont;
    var lpntm: TNewTextMetric;
    FontType: Integer;
    Wnd: hWnd): Integer; stdcall;
var
  n: PChar;
begin
  if FontType = TRUETYPE_FONTTYPE then
  begin
    n:= lpelf.elfLogFont.lfFaceName;
    SendMessage(Wnd, CB_ADDSTRING, 0, Integer(n))
  end;
  Result:= 1
end;

procedure TSetupDlg.InitControls;
procedure InvalidateSwatch(ID: Integer);
begin
  InvalidateRect(GetDlgItem(hDlg, ID), nil, false)
end;

begin
  with Settings do
  begin
    SpeedControl:= Speed;
    WithTextControl:= WithText;
    LookHeightControl:= LookHeight;
    LookDistControl:= LookDist;
    RainbowControl:= Rainbow;
    TextControl:= Text;
    TextOutlineControl:= TextOutline;
    TextRotatingControl:= TextRotating;
    TextItalicControl:= TextItalic;
    FontDepthControl:= FontDepth;
    TextBoldControl:= TextBold;
    TextFaceControl:= TextFont;
    InvalidateSwatch(IDC_BACKCOLOUR);
    InvalidateSwatch(IDC_BODYCOLOUR);
    InvalidateSwatch(IDC_TEXTCOLOUR);
    InvalidateSwatch(IDC_POLYCHROME0);
    InvalidateSwatch(IDC_POLYCHROME1);
    InvalidateSwatch(IDC_POLYCHROME2);
    InvalidateSwatch(IDC_POLYCHROME3);
    InvalidateSwatch(IDC_POLYCHROME4);
    InvalidateSwatch(IDC_POLYCHROME5);
  end;
end;

procedure TSetupDlg.WMInitDialog(var Msg: TWMInitDialog);
var
  dc: hDC;
  ddl: hWnd;
begin
  SetupUD(IDC_SPEED, 0, 100, 5, false);
  SetupUD(IDC_LOOKDIST, 3000, 30000, 1000, false);
  SetupUD(IDC_LOOKHEIGHT, -8000, 8000, 1000, false);
  SetupUD(IDC_FONTDEPTH, 0, 10, 1, false);
  SendMessage(GetDlgItem(hDlg, IDC_TEXT), EM_SETLIMITTEXT, MaxText, 0);
  ddl:= GetDlgItem(hDlg, IDC_FONTLIST);
  dc:= GetDC(hDlg);
  EnumFontFamilies(dc, nil, @EnumFontFamProc, ddl);
  ReleaseDC(hDlg, dc);
  InitControls;
  Msg.Result:= 1
end;

procedure TSetupDlg.WMNotify(var Msg: TWMNotify);
begin
end;

procedure TSetupDlg.WMCommand(var Msg: TWMCommand);
begin
  case Msg.ItemID of
    IDCANCEL:
    begin
      EndDialog(hDlg, 0);
      Msg.Result:= 1
    end;
    IDOK:
    with Settings do
    begin
      Speed:= SpeedControl;
      WithText:= WithTextControl;
      LookHeight:= LookHeightControl;
      LookDist:= LookDistControl;
      Rainbow:= RainbowControl;
      Text:= TextControl;
      TextOutline:= TextOutlineControl;
      TextRotating:= TextRotatingControl;
      TextItalic:= TextItalicControl;
      TextBold:= TextBoldControl;
      FontDepth:= FontDepthControl;
      TextFont:= TextFaceControl;
      WriteSettings(Settings);
      EndDialog(hDlg, 1);
      Msg.Result:= 1
    end;
    IDC_DEFAULTS:
    begin
      Settings:= DefaultSettings;
      InitControls;
      Msg.Result:= 1
    end;
    IDC_BACKCOLOUR,
    IDC_BODYCOLOUR,
    IDC_TEXTCOLOUR,
    IDC_POLYCHROME0,
    IDC_POLYCHROME1,
    IDC_POLYCHROME2,
    IDC_POLYCHROME3,
    IDC_POLYCHROME4,
    IDC_POLYCHROME5:
    begin
      ChooseColour(Msg.ItemID);
      Msg.Result:= 1
    end;
  end
end;

function ModelSetup: Boolean;
var
  SetupDlg: TSetupDlg;
begin
  InitCommonControls;
  SetupDlg:= TSetupDlg.Create;
  try
    Result:= SetupDlg.Execute(0)
  finally
    SetupDlg.Free
  end
end;

procedure TSetupDlg.WMDrawItem(var Msg: TWMDrawItem);
var
  CR: TRect;
  Brush: HBRUSH;
  OldObj: HGDIOBJ;
begin
  with Msg.DrawItemStruct^ do
  begin
    GetClientRect(GetDlgItem(hDlg, Msg.Ctl), CR);
    Brush:= CreateSolidBrush(ColourVal[Msg.Ctl]);
    OldObj:= SelectObject(hdc, Brush);
    Rectangle(hdc, CR.Left, CR.Top, CR.Right, CR.Bottom);
    SelectObject(hdc, OldObj);
    DeleteObject(Brush)
  end;
end;

function TSetupDlg.GetBooleanValue(ID: Integer): Boolean;
begin
  Result:= SendMessage(GetDlgItem(hDlg, ID), BM_GETCHECK, 0, 0) = BST_CHECKED
end;

procedure TSetupDlg.SetBooleanValue(ID: Integer; Value: Boolean);
var
  wP: WPARAM;
begin
  if Value then
    wP:= BST_CHECKED
  else
    wP:= BST_UNCHECKED;
  SendMessage(GetDlgItem(hDlg, ID), BM_SETCHECK, wP, 0)
end;

procedure TSetupDlg.ChooseColour(ID: Integer);
var
  cc: TChooseColor;
begin
  with cc do
  begin
    lStructSize:= SizeOf(cc);
    hwndOwner:= hDlg;
    hInstance:= 0;
    rgbResult:= ColourVal[ID];
    lpCustColors:= @Settings.CustomColours[0];
    Flags:= CC_RGBINIT;
    lCustData:= 0;
    lpfnHook:= nil;
    lpTemplateName:= nil
  end;
  if ChooseColor(cc) then
  begin
    ColourVal[ID]:= cc.rgbResult;
    InvalidateRect(GetDlgItem(hDlg, ID), nil, false)
  end
end;

function TSetupDlg.GetColourVal(ID: Integer): Cardinal;
begin
  with Settings do
  case ID of
    IDC_BACKCOLOUR: Result:= BackColour;
    IDC_BODYCOLOUR: Result:= BodyColour;
    IDC_TEXTCOLOUR: Result:= TextColour;
    IDC_POLYCHROME0: Result:= Polychrome[0];
    IDC_POLYCHROME1: Result:= Polychrome[1];
    IDC_POLYCHROME2: Result:= Polychrome[2];
    IDC_POLYCHROME3: Result:= Polychrome[3];
    IDC_POLYCHROME4: Result:= Polychrome[4];
    IDC_POLYCHROME5: Result:= Polychrome[5];
  else
    Result:= 0
  end
end;

procedure TSetupDlg.SetColourVal(ID: Integer; Value: Cardinal);
begin
  with Settings do
  case ID of
    IDC_BACKCOLOUR: BackColour:= Value;
    IDC_BODYCOLOUR: BodyColour:= Value;
    IDC_TEXTCOLOUR: TextColour:= Value;
    IDC_POLYCHROME0: Polychrome[0]:= Value;
    IDC_POLYCHROME1: Polychrome[1]:= Value;
    IDC_POLYCHROME2: Polychrome[2]:= Value;
    IDC_POLYCHROME3: Polychrome[3]:= Value;
    IDC_POLYCHROME4: Polychrome[4]:= Value;
    IDC_POLYCHROME5: Polychrome[5]:= Value;
  end
end;

procedure DoSetup(Window: hWnd);
var
  SetupDlg: TSetupDlg;
begin
  InitCommonControls;
  SetupDlg:= TSetupDlg.Create;
  try
    SetupDlg.Execute(Window)
  finally
    SetupDlg.Free
  end
end;


function TSetupDlg.GetStringValue(ID: Integer): String;
var
  Buf: array[0..255] of Char;
begin
  GetWindowText(GetDlgItem(hDlg, ID), Buf, SizeOf(Buf) - 1);
  Result:= Buf
end;

procedure TSetupDlg.SetStringValue(ID: Integer; const Value: String);
begin
  SetWindowText(GetDlgItem(hDlg, ID), PChar(Value))
end;

function TSetupDlg.GetComboStringValue(ID: Integer): String;
var
  w: hWnd;
  Found: Integer;
  Buf: array[0..255] of Char;
  n: PChar;
begin
  w:= GetDlgItem(hDlg, ID);
  Found:= SendMessage(w, CB_GETCURSEL, 0, 0);
  if Found <> CB_ERR then
  begin
    n:= Buf;
    SendMessage(w, CB_GETLBTEXT, Found, Integer(n));
    Result:= Buf
  end else
  begin
    Result:= ''
  end
end;

procedure TSetupDlg.SetComboStringValue(ID: Integer; const Value: String);
var
  w: hWnd;
  Found: Integer;
begin
  w:= GetDlgItem(hDlg, ID);
  Found:= SendMessage(w, CB_FINDSTRINGEXACT, -1, Integer(PChar(Value)));
  if Found <> CB_ERR then
    SendMessage(w, CB_SETCURSEL, Found, 0)
end;

procedure WriteSettings(const Settings: TSettings);
var
  Key: HKey;
begin
  if RegCreateKey(HKEY_CURRENT_USER, PChar(RegKey), Key) = ERROR_SUCCESS then
    RegSetValueEx(Key, RegValue, 0, REG_BINARY, @Settings, Sizeof(Settings))
end;

procedure ReadSettings(var Settings: TSettings);
var
  Key: HKey;
  ValType: DWORD;
  Size: DWORD;
begin
  FillChar(Settings, SizeOf(Settings), 0);
  if RegOpenKey(HKEY_CURRENT_USER, PChar(RegKey), Key) = ERROR_SUCCESS then
  begin
    Size:= SizeOf(Settings);
    if RegQueryValueEx(Key, RegValue, nil, @ValType, @Settings, @Size) <> ERROR_SUCCESS then
      Settings:= DefaultSettings
  end else
  begin
    Settings:= DefaultSettings
  end
end;

end.