发信人: 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版直达快车
█┃印龍┃█
█┗━━┛█
██████ |
|