首页  编辑  

壁纸随机更改

Tags: /超级猛料/OS.操作系统/Control Panel.控制面板/   Date Created:

]、。·ˉˇ¨〃々—~‖…’”〕〉》」』〗】∶!"'),.:;?]` {*******************************************************************************

 作者: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.