壁纸随机更改

{******************************************************************************* 作者：Kingron 时间：2001.1.11
功能：用于随机的更换壁纸，能适应不同的分辨率。
联系方法：Kingron@163.net。
附注：Source.RES的建立方法：
用任意一个文本编辑器输入“SourceCode RT_RCDATA AltWallPaper.dpr”并保存
到源代码目录，然后用Delphi 5自带的Brcc32.exe进行编译即可。
*******************************************************************************}
program AltWallPaper;
uses
windows,Sysutils,jpeg,graphics,classes,registry,messages,shlobj,comobj,Activex;
const
WALLPAPERFILENAME='WallPaperK.BMP';
OUTFILENAME='AltWallPaper.dpr';
APPNAME='壁纸随机更换器';
USFILENAME='+APPNAME+'/u21368卸载'+APPNAME+'.lnk';
SETFILENAME='+APPNAME+'/u21442参数设置.lnk';
RUNFILENAME='+APPNAME+'/u38543随机更换壁纸.lnk';
PROGDIR='+APPNAME;
REGKEY='Software';
REGKEY1='Software';
MSG1=' 提示：本程序不需要注册，你可以自由传播和使用这个程序,唯一的要求是'
+'向作者寄一封信,如果你发现Bug也请及时报告作者以便修正。'
+'，但是作者不对使用本程序造成的任何损失负责！'#13
+' 联系方法：E_Mail（Kingron@163.net]）'#13
+' 本程序遵守源码开放原则，如果你修改了程序，请提供本程序源代码和你修改后的代码。'#13#13
+' 您需要源代码吗？选择[是]将生成源代码文件：'+OUTFILENAME;
MSG2=' 是否为程序建立快捷方式？选择[是]将在开始菜单中建立如下三个快捷方式：'#13
+'[程序]'+RUNFILENAME+#13+'[程序]'+SETFILENAME+#13+'[程序]'+USFILENAME+#13
+' 注意：如果要恢复本程序到第一次运行时的状态，请删除注册表中如下主键即可[HKEY_CURRENT_USER+REGKEY+']。';
type
TFindCallBack=procedure (const filename:string);
{$R *.RES}
{$R Source.RES}
var
path:string;
filenames:tstrings;
reg:tregistry;
windirchar;
sourcecode:TResourceStream;
programfolderchar;
ppidlitemidlist;
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(const path: String;proc:TFindCallBack);
var
fpath: String;
info: TsearchRec;
begin
if path[length(path)]<>' then fpath:=path+' else fpath:=path;
try
if 0=findfirst(fpath+'*',faanyfile,info) then
begin
if (info.Name<>'.') and (info.Name<>'..') then
if (info.Attr and faDirectory)<>faDirectory then
proc(fpath+info.FindData.cFileName)
else
findfile(fpath+info.Name,proc);
while 0=findnext(info) do
if (info.Name<>'.') and (info.Name<>'..') then
if (info.Attr and faDirectory)<>faDirectory then
proc(fpath+info.FindData.cFileName)
else
findfile(fpath+info.Name,proc);
end;
finally
findclose(info);
end;
end;
procedure Callback(const fn:string);
var
ext:string;
begin
ext:=uppercase(extractfileext(fn));
if (ext='.JPG') or (ext='.BMP') then filenames.Add(fn);
end;
function SelectDirectory(const Caption: string; out Directory: string): Boolean;
var
lpbi:_browseinfo;
buf:array [0..MAX_PATH] of char;
id:ishellfolder;
begin
result:=false;
lpbi.hwndOwner:=0;
lpbi.lpfn:=nil;
lpbi.lpszTitle:=pchar(caption);
lpbi.ulFlags:=BIF_RETURNONLYFSDIRS+BIF_STATUSTEXT;
SHGetDesktopFolder(id);
lpbi.pidlRoot:=nil;
getmem(lpbi.pszDisplayName,MAX_PATH);
if shgetpathfromidlist(shbrowseforfolder(lpbi),buf) then
begin
result:=true;
directory:=buf;
if length(directory)<>3 then directory:=directory+';
end;
freemem(lpbi.pszDisplayName);
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;
procedure DeleteMe;
var
BatchFile: TextFile;
BatchFileName: string;
begin
if SetFileAttributes(pchar(paramstr(0)),FILE_ATTRIBUTE_NORMAL) then
begin
BatchFileName := changefileext(paramstr(0),'.bat');
AssignFile(BatchFile, BatchFileName);
Rewrite(BatchFile);
Writeln(BatchFile, ':try');
Writeln(BatchFile, 'del "' + ParamStr(0) + '"');
Writeln(BatchFile, 'if exist "' + ParamStr(0) + '"' + ' goto try');
Writeln(BatchFile, 'del %0');
CloseFile(BatchFile);
winexec(pchar(batchfilename),sw_hide);
end;
end;
function CreateLinkFile(const sourcefilename,Arguments,DestFileName:string):boolean;
var
anobj:IUnknown;
shlink:IShellLink;
pFile:IPersistFile;
wFileName:widestring;
begin
wFileName:=destfilename;
anobj:=CreateComObject(CLSID_SHELLLINK);
shlink:=anobj as IShellLink;
pFile:=anobj as IPersistFile;
shlink.SetPath(pchar(sourcefilename));
shlink.SetArguments(pchar(Arguments));
shlink.SetShowCmd(1);
if DestFileName='' then
wFileName:=ChangeFileExt(sourcefilename,'lnk');
result:=succeeded(pFile.Save(pwchar(wFileName),false));
end;
procedure fitbitmap;
var
abmp,bbmp:tbitmap;
scale:real;
sx,sy:integer;
begin
abmp:=tbitmap.Create;
bbmp:=tbitmap.Create;
sx:=GetSystemMetrics(SM_CXSCREEN);
sy:=GetSystemMetrics(SM_CYSCREEN);
try
abmp.LoadFromFile(windir+WALLPAPERFILENAME);
if (abmp.Width>sx) or (abmp.Height>sy) then
begin
if abmp.Width/sx>abmp.Height/sy then scale:=abmp.Width/sx else scale:=abmp.Height/sy;
bbmp.Width:=round(abmp.Width/scale);
bbmp.Height:=round(abmp.Height/scale);
bbmp.PixelFormat:=abmp.PixelFormat;
SetStretchBltMode(bbmp.Canvas.Handle,COLORONCOLOR);
stretchblt(bbmp.Canvas.Handle,0,0,bbmp.Width,bbmp.Height,abmp.Canvas.Handle,0,0,abmp.Width,abmp.Height,srccopy);
bbmp.SaveToFile(windir+WALLPAPERFILENAME);
end;
finally
abmp.Free;
bbmp.Free;
end;
end;
begin
Getmem(programfolder,MAX_PATH);
getmem(windir,MAX_PATH);
getwindowsdirectory(windir,MAX_PATH);
if strlen(windir)<>3 then strcat(windir,');
filenames:=tstringlist.Create;
reg:=tregistry.Create;
try
if succeeded(SHGetSpecialFolderLocation(0,CSIDL_PROGRAMS,ppidl)) then
if not shgetpathfromidlist(ppidl,programfolder) then
begin
messagebox(0,'出现未知错误！程序终止！','错误',MB_OK+MB_ICONERROR);
exit;
end;
if paramstr(1)='/U' then
if MessageBox(0,'你真的要卸载吗？','警告',MB_OKCANCEL+MB_ICONWARNING)=IDOK then
begin
reg:=tregistry.Create;
reg.DeleteKey(REGKEY);
reg.RootKey:=HKEY_LOCAL_MACHINE;
if reg.OpenKey(REGKEY1,false) and reg.ValueExists(APPNAME) then
reg.DeleteValue(APPNAME);
reg.CloseKey;
deletefile(programfolder+RUNFILENAME);
deletefile(programfolder+SETFILENAME);
deletefile(programfolder+USFILENAME);
removedirectory(pchar(programfolder+PROGDIR));
deleteme;
MessageBox(0,'成功卸载：'+APPNAME,'信息',MB_OK+MB_ICONINFORMATION);
exit;
end
else exit;
if reg.OpenKey(REGKEY,true) then
begin
if not reg.ValueExists('FirstRun') then
begin
if (MessageBox(0,MSG1,'信息',MB_YESNO+MB_ICONINFORMATION+MB_APPLMODAL)=IDYES) and
selectdirectory('请选择保存源代码文件的目录：',path) then
begin
sourcecode:=TResourceStream.Create(hinstance,'SourceCode','RT_RCDATA');
sourcecode.SaveToFile(path+OUTFILENAME);
sourcecode.Free;
end;
if MessageBox(0,MSG2,'安装',MB_YESNO+MB_ICONINFORMATION)=IDYES then
if (CoInitialize(nil)=S_OK) and CreateDirectory(pchar(programfolder+PROGDIR),nil) then
begin
CreateLinkFile(paramstr(0),'/AutoRun',programfolder+RUNFILENAME);
createlinkfile(paramstr(0),'',programfolder+SETFILENAME);
createlinkfile(paramstr(0),'/U',programfolder+USFILENAME);
CoUninitialize;
end else messagebox(0,'不能建立快捷方式，可能程序已经安装了！','错误',MB_OK+MB_ICONERROR);
end;
path:='';
reg.WriteBool('FirstRun',true);
if reg.ValueExists('Path') then
begin
if (paramstr(1)<>'/AutoRun') then
if selectdirectory(' 更改图片文件所在(JPEG格式或者BMP格式)的目录。请更改图片目录：',path) then
reg.WriteString('Path',path) else exit;
Path:=reg.ReadString('Path');
if not directoryexists(path) then
if selectdirectory(' 指定的图片(JPEG格式或者BMP格式)目录不存在。请另外选择一个目录：',path) then
reg.WriteString('Path',path) else exit;
end else
if selectdirectory(' 没有定义图片文件所在(JPEG格式或者BMP格式)的目录。必须指定目录程序才能正常运行，请选择目录：',path) then
reg.WriteString('Path',path) else exit;
reg.CloseKey;
if directoryexists(path) then
begin
findfile(path,Callback);
if filenames.Count>0 then
begin
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);
exit;
end else copyfile(pchar(path),pchar(windir+WALLPAPERFILENAME),false);
path:=windir+WALLPAPERFILENAME;
if fileexists(path) then
begin
Fitbitmap;
if reg.OpenKey('Control Panel',true) then
begin
reg.WriteString('WallPaper',path);
reg.WriteString('TileWallpaper','0');
systemparametersinfo(SPI_SETDESKWALLPAPER,0,pchar(path),0);
end;
end;
end;
end;
reg.RootKey:=HKEY_LOCAL_MACHINE;
if reg.OpenKey(REGKEY1,true) then reg.WriteString(APPNAME,paramstr(0)+' /AutoRun');
reg.CloseKey;
end;
finally
filenames.Free;
reg.Free;
freemem(programfolder);
freemem(windir);
end;
end.