精华区 [关闭][返回]

当前位置:网易精华区>>讨论区精华>>编程开发>>● Delphi>>图形界面和窗体>>新年礼物:壁纸随机程序!

主题:新年礼物:壁纸随机程序!
发信人: kingron(金龍)
整理人: teleme(2001-01-18 16:43:06), 站内信件
program AltWallPaper;

uses
  windows,Sysutils,jpeg,graphics,classes,registry,messages,shlobj;

const
  WALLPAPERFILENAME='WallPaperK.BMP';
type
  TFindCallBack=procedure (const filename:string;const info:TSearchRec;var bQuit,bSub:boolean);

{$R *.RES}
var
  path:string;
  quit:boolean=false;
  filenames:tstrings;
  reg:tregistry;
  windir:pchar;

procedure Jpg2Bmp(const source,dest:string);
var
  MyJpeg: TJpegImage;
  bmp: Tbitmap;
begin
bmp:=TBitmap.Create;
MyJpeg:= TJpegImage.Create;
try
  myjpeg.LoadFromFile(source);
  bmp.Assign(myjpeg);
  bmp.SaveToFile(dest);
finally
  bmp.free;
  myjpeg.Free;
end;
end;

procedure FindFile(var quit:boolean;const path: String;const filename:string='*.*';
                   proc:TFindCallBack=nil;bSub:boolean=true;const bMsg:boolean=true);
var
  fpath: String;
  info: TsearchRec;

 procedure ProcessAFile;
 begin
  if (info.Name<>'.') and (info.Name<>'..') and ((info.Attr and faDirectory)<>faDirectory) then
  begin
  if assigned(proc) then
    proc(fpath+info.FindData.cFileName,info,quit,bsub);
  end;
 end;

 procedure ProcessADirectory;
 begin
  if (info.Name<>'.') and (info.Name<>'..') and ((info.attr and fadirectory)=fadirectory) then
    findfile(quit,fpath+info.Name,filename,proc,bsub,bmsg);
 end;

begin
if path[length(path)]<>'\' then
  fpath:=path+'\'
else
  fpath:=path;
try
  if 0=findfirst(fpath+filename,faanyfile and (not fadirectory),info) then
  begin
    ProcessAFile;
    while 0=findnext(info) do
      begin
        ProcessAFile;
        if quit then
          begin
            findclose(info);
            exit;
          end;
      end;
  end;
finally
  findclose(info);
end;
try
  if bsub and (0=findfirst(fpath+'*',faanyfile,info)) then
    begin
      ProcessADirectory;
      while findnext(info)=0 do
        ProcessADirectory;
    end;
finally
  findclose(info);
end;
end;

procedure Callback(const fn:string;const info:tsearchrec;var bquit,bSub:boolean);
var
 ext:string;
begin
 ext:=uppercase(extractfileext(fn));
 if (ext='.JPG') or (ext='.BMP') then
  filenames.Add(fn);
end;

function SelectDirectory(const Caption: string; const Root: WideString;
  out Directory: string): Boolean;
var
  lpbi:_browseinfo;
  buf:array [0..MAX_PATH] of char;
  id:ishellfolder;
  eaten,att:cardinal;
  rt:pitemidlist;
  initdir:pwidechar;
begin
  result:=false;
  lpbi.hwndOwner:=0;
  lpbi.lpfn:=nil;
  lpbi.lpszTitle:=pchar(caption);
  lpbi.ulFlags:=BIF_RETURNONLYFSDIRS;
  SHGetDesktopFolder(id);
  initdir:=pwchar(root);
  id.ParseDisplayName(0,nil,initdir,eaten,rt,att);
  lpbi.pidlRoot:=rt;
  getmem(lpbi.pszDisplayName,MAX_PATH);
  try
   result:=shgetpathfromidlist(shbrowseforfolder(lpbi),buf);
  except
   freemem(lpbi.pszDisplayName);
  end;
  if result then directory:=buf;
end;

function DirectoryExists(const Name: string): Boolean;
var
  Code: Integer;
begin
  Code := GetFileAttributes(PChar(Name));
  Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0);
end;

begin
  getmem(windir,MAX_PATH);
  getwindowsdirectory(windir,MAX_PATH);
  if strlen(windir)<>3 then
    strcat(windir,'\');
  filenames:=tstringlist.Create;
  reg:=tregistry.Create;
  if reg.OpenKey('Software\WellSoft\Wallpaper',true) then
  begin
    if reg.ValueExists('Path') then
      Path:=reg.ReadString('Path');
    if (paramstr(1)<>'/AutoRun') or not directoryexists(path) then
      if selectdirectory('用户可以自己定义图片(JPEG格式或者BMP格式)的目录。'+#13'请选择图片所在的目录:','',path) then
        reg.WriteString('Path',path);
  end;
  reg.CloseKey;
  if directoryexists(path) then
  begin
  findfile(quit,path,'*.*',Callback,true,false);
  randomize;
  path:=filenames.Strings[random(filenames.Count)];
  if Uppercase(extractfileext(path))='.JPG' then
    try
      SetFileAttributes(pchar(windir+WALLPAPERFILENAME),FILE_ATTRIBUTE_NORMAL);
      jpg2bmp(path,windir+WALLPAPERFILENAME);
    except
      MessageBox(0,'不能建立输出文件。'#13+'请检查文件格式是否正确或者检查磁盘!','错误',MB_OK+MB_ICONERROR);
    end
    else
      copyfile(pchar(path),pchar(windir+WALLPAPERFILENAME),false);
  if fileexists(windir+WALLPAPERFILENAME) then
  begin
    path:=windir+WALLPAPERFILENAME;
    if reg.OpenKey('Control Panel\Desktop',true) then
      begin
      reg.WriteString('WallPaper',pchar(path));
      systemparametersinfo(SPI_SETDESKWALLPAPER,0,pchar(path),0);
      end;
  end;
  end;
  reg.RootKey:=HKEY_LOCAL_MACHINE;
  if  reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Run',true) then
    reg.WriteString('随机更换壁纸',paramstr(0)+' /AutoRun');
  reg.CloseKey;
  filenames.Free;
  reg.Free;
  freemem(windir);
end.



----
██████
█┏━━┓█
█┃之金┃█   Delphi版直达快车
█┃印龍┃█
█┗━━┛█
██████
   

[关闭][返回]