main.pas

在深度历险网站上发布的所有delphi程序原码。对初学delphi者很有用。

unit main;

interface

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

type
  TMainForm = class(TForm)
    dlgOpenPicture: TOpenPictureDialog;
    Panel1: TPanel;
    rgpStyle: TRadioGroup;
    btnOpen: TButton;
    btnWallpaper: TButton;
    btnExit: TButton;
    Panel2: TPanel;
    imgPreview: TImage;
    imgPattern: TImage;
    procedure btnOpenClick(Sender: TObject);
    procedure btnWallpaperClick(Sender: TObject);
    procedure btnExitClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    procedure ShowPattern;
  public
    { Public declarations }
  end;
  
var
  MainForm: TMainForm;
  
implementation

{$R *.DFM}

procedure TMainForm.btnOpenClick(Sender: TObject);
begin
  if dlgOpenPicture.Execute then
    imgPreview.Picture.LoadFromFile(dlgOpenPicture.Filename);
end;

procedure TMainForm.btnWallpaperClick(Sender: TObject);
var
  S: string;
begin
  S := dlgOpenPicture.Filename;
  if S = '' then Exit;

  { first, modify the value of registry keys for wallpaper styles }
  with TRegIniFile.Create('\Control Panel') do
    try
      { my own habit: always set TileWallPaper key to zero }
      WriteInteger('Desktop', 'TileWallPaper', 0);

      { set WallPaperStyle key to corresponding value:
        0 = Center
        1 = Tile
        2 = Fit to screen  }
      WriteInteger('Desktop', 'WallPaperStyle', rgpStyle.ItemIndex);
    finally
      Free;
    end;

  { second, change wallpaper }
  SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, PChar(S),
    SPIF_UPDATEINIFILE or SPIF_SENDWININICHANGE);
end;

procedure TMainForm.btnExitClick(Sender: TObject);
begin
  Close;
end;

procedure TMainForm.FormCreate(Sender: TObject);
begin
  ShowPattern;
end;

procedure TMainForm.ShowPattern;
type
  TPatternArray = array[0..7, 0..7] of Boolean;
  
  function ParsePatternString(sPattern: string; var aPattern: TPatternArray): Boolean;
  var
    X, Y, I, Value: Integer;
  begin
    Y := 0;
    while Length(sPattern) > 0 do
    begin
      I := Pos(' ', sPattern);
      if I <> 0 then
      begin
        Value := StrToIntDef(Copy(sPattern, 1, I - 1), 0);
        Delete(sPattern, 1, I);
      end else
      begin
        Value := StrToIntDef(sPattern, 0);
        sPattern := '';
      end;

      X := 7;
      while X >= 0 do
      begin
        aPattern[Y, X] := Boolean(Value and 1);
        Value := Value shr 1;
        dec(X);
      end;

      Inc(Y);
    end;
    Result := Y = 8; // successfully parsed
  end;

const
  { should be '(None)', but Windows NT 4.0 Traditional Chinese
    version translated it to '(礚)'. }
  NON_PATTERN_STR = '(None)';
var
  aPattern  : TPatternArray;
  sPattern  : string;       
  X, Y, W, H: Integer;      
begin
  with TRegIniFile.Create('\Control Panel') do
    try
      { the name of key should be 'Pattern', but Windows NT 4.0
      Traditional Chinese  version translated it to '摸