|
{******************************************************************************* 作者：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+'\卸载'+APPNAME+'.lnk'; SETFILENAME='\'+APPNAME+'\参数设置.lnk'; RUNFILENAME='\'+APPNAME+'\随机更换壁纸.lnk'; PROGDIR='\'+APPNAME; REGKEY='Software\WellSoft\Wallpaper'; REGKEY1='Software\Microsoft\Windows\CurrentVersion\Run'; 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; windir:pchar; sourcecode:TResourceStream; programfolder:pchar; ppidl:pitemidlist; 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\Desktop',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.
| 
中搜索 