procedure TFrmPlay.mnDeskPicClick(Sender: TObject);
Var s:String; i:Integer;
begin
//s:=Path+'SetPic.exe';
//EnableDebugPrivilege(True);
//ShellExecute(GetDesktopWindow ,'open',Pchar(s), nil,Pchar(Path),SW_SHow); Exit;
i:=sgPic.Row;
s:=sgPic.Cells[,i]; //原始图片文件
if pos(':',s)= then s:=Path+s; //==相对路径
if FileExists(s) then MakeWallPic(s); //产生并设置壁纸
//SetWallPaper(s,2);
end;
procedure TFrmPlay.MakeWallPic(sPic:String); //合并新墙纸
Var sBMP,sJPG:String; img,imgTmp:TImage;
JpegImage:TJpegImage;
udtblender:TBlendFunction;//图片效果处理参数
begin
with udtblender do
begin
Blendop:=AC_SRC_OVER;
Blendflags:=;
SourceConstantAlpha:=-spTransparent.Value;//透明度
AlphaFormat:=;
end; //s:=WinPath+'\'+ChangeFileExt(ExtractFileName(sPic),'.JPG');
sBmp:=Path+'DeskPic\'+ChangeFileExt(ExtractFileName(sPic),'.BMP');
sJPG:=Path+'DeskPic\'+ChangeFileExt(ExtractFileName(sPic),'.JPG');
img:=TImage.Create(nil);
imgTmp:=TImage.Create(nil); //创建BMP图片
JpegImage:=TJpegImage.Create; //创建JPG图片
try
img.AutoSize :=True;
img.Picture.LoadFromFile(sPic); //装载原始图片 //img.Picture.Assign(nil);
LoadBMPJPG(img,sPic);
//imgTmp.Picture.Assign(img.Picture);
imgTmp.Width :=img.Width;
imgTmp.Height :=img.Height;
imgTmp.Canvas.Draw(,,img.Picture.Graphic);//绘制到临时图片中
ShowHint(img);//在临时图片中绘制 提示文字信息
windows.AlphaBlend(imgTmp.Canvas.Handle,,,imgTmp.Width,imgTmp.Height,
img.Canvas.Handle,,,img.Width,img.Height,
udtblender); //关键调用api imgTmp.Picture.Bitmap.SaveToFile(sBMP);//保存临时文件到磁盘 //保存最终的JPG的壁纸文件：
JpegImage.Assign(imgtmp.Picture.Graphic); //JpegImage.CompressionQuality:=100;
JpegImage.PixelFormat:=jf24Bit;
JpegImage.Compress;
JpegImage.SaveToFile(sJPG);
finally
img.Free;
imgTmp.Free;
JpegImage.Free; //edFile.Text :=sBMP;
if Fileexists(sBMP) then SetRegWallPaper(sBMP);//设置壁纸
sleep();
if Fileexists(sJPG) then SetWallPaper(sJPG,); //设置壁纸
//MyDeleteFile(sBMP); //==不需要了!??
end;
end; procedure TFrmPlay.ShowHint(img:TImage); //合成文字
Var i,n,h,w,size:Integer; s,s2,sHint,sfmt:String;
begin
sHint:=''; //需要回执的特殊格式的文字；
if chkShowDate.Checked then sHint:=MyDatestr(SysUtils.Date,True); //显示日期
if chkShowWeek.Checked then //显示星期
sHint:=sHint+' '+Days[DayofWeek(SysUtils.Date)];
if sHint<>'' then sHint:=sHint+'^^'; for i:=sgHint.RowCount - downto do //计算文字行数
if sgHint.Cells[,i]<>'' then
begin
n:=i;
Break;
end; for i:= to n do //填加文字
sHint:=sHint+sgHint.Cells[,i]+'^^'; n:=ItemsOfStr(sHint,'^^');
//img.Canvas.Font.Size:=24; //max(24,img.Height div 20) ;//==字体大小
img.Canvas.Font:=plHintFont.Font; h:=img.Canvas.TextHeight('jy');
{while h*10>img.Height do
begin
img.Canvas.Font.Size:=img.Canvas.Font.Size-1;
if img.Canvas.Font.Size<10 then Break;
h:=img.Canvas.TextHeight('jy');
end; }
//h:=img.Canvas.TextHeight('jy');
size:=img.Canvas.Font.Size;
SetFontSmooth(True); //设置文字平滑绘制 sFmt:=FontToStr(plHintFont.font)+';~~'+colortostr(pledgeColor.Font.Color)+';~~'+inttostr(spedgeWidth.Value);//合成特定格式
ShowFmtTxt(img.Canvas,' ~~0~~0~~0~~'+sFmt,'');
for i:= to min(n,) do //最多显示11行提示文字
begin
s2:=TextOfIndex(sHint,'^^',i);
s2:=Trim(s2);
w:=img.Canvas.TextWidth(s2);
s:='~~'+inttostr(img.Width-w-)+'~~'+intTostr(i*h-h);
// s:=s+'~~0~~楷体_BG2312;'+inttostr(h)+';255;255;255;fsItalic~~16;16;16;~~1';
s:=s+'~~0~~'+sFmt;
ShowFmtTxt(img.Canvas,s2+s,'');
if chkSHowLine.Checked then
DrawLineH3(img.Width-w-,i*h-,w,img.Canvas,plLineColor.Font.Color,dRight);
end;
SetFontSmooth(oldTFONTSMOOTHING); //恢复原来的文字平滑方式
end;
Procedure TFrmPlay.SetRegWallPaper(StrFile:String);
Var Reg:TRegistry;
begin
Reg:=Tregistry.Create;{创建Tregistry对象的实例}
Reg.Rootkey:= Hkey_Current_User;{设置根键名称}
try
if Reg.OpenKey('Control Panel\Desktop',False) then {打开Control Panel\Desktop 路径对应的主键}
begin
//ShowMessage('打开注册表成功');
Reg.WriteString('TileWallPaper','');
Reg.WriteString('WallpaperStyle','');
Reg.WriteString('Wallpaper',StrFile);{向TileWallpaper 和Wallpaper串覆盖写入新值}
Reg.WriteString('ConvertedWallpaper',StrFile);
Reg.WriteString('OriginalWallpaper',StrFile);
Reg.CloseKey;{将更改内容写入注册表并关闭}
Systemparametersinfo(SPI_SETDESKWallpaper,,Pchar(StrFile),
SPIF_upDateINIFIle Or SPIF_SENDWININICHANGE); // or SPIF_SendChange);{向Windows发送消息，通知Windows更换壁纸}
end;
finally
Reg.Free;
end;
end;
SetRegWallPaper通知windows改变壁纸
Procedure TFrmPlay.SetWallPaper(StrFile: String; Style: Integer);
Var DT: IActiveDesktop;
WPO: TWallpaperOpt;
WS: WideString;
begin
DT := CreateComObject(CLSID_ActiveDesktop) As IActiveDesktop;
WS := StrFile;
Case Style Of
: WPO.dwStyle := WPSTYLE_CENTER; {居中}
: WPO.dwStyle := WPSTYLE_TILE; {平铺}
: WPO.dwStyle := WPSTYLE_STRETCH; {拉伸}
else WPO.dwStyle := WPSTYLE_CENTER;
end;
WPO.dwSize := SizeOf(WPO);
DT.SetWallpaperOptions(WPO, );
DT.SetWallPaper(PwideChar(WS),);
DT.ApplyChanges(AD_APPLY_ALL);
end;
SetWallPaper用指定方式改变壁纸