字体和壁纸合并后再更改壁纸--《用delphi开发共享软件》-15.2桌面提示器

 

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[1,i];  //原始图片文件
  if pos(':',s)=0 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:=0;
      SourceConstantAlpha:=255-spTransparent.Value;//透明度
      AlphaFormat:=0;
  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(0,0,img.Picture.Graphic);//绘制到临时图片中
    ShowHint(img);//在临时图片中绘制 提示文字信息
    windows.AlphaBlend(imgTmp.Canvas.Handle,0,0,imgTmp.Width,imgTmp.Height,
                        img.Canvas.Handle,0,0,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(50);
    if Fileexists(sJPG) then  SetWallPaper(sJPG,2); //设置壁纸
    //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 -1 downto 1 do //计算文字行数
    if sgHint.Cells[1,i]<>'' then
      begin
        n:=i;
        Break;
      end;

  for i:=1 to n do //填加文字
    sHint:=sHint+sgHint.Cells[1,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:=1 to min(n,11) do //最多显示11行提示文字
    begin
      s2:=TextOfIndex(sHint,'^^',i);
      s2:=Trim(s2);
      w:=img.Canvas.TextWidth(s2);
      s:='~~'+inttostr(img.Width-w-5)+'~~'+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-5,i*h-1,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','0');
        Reg.WriteString('WallpaperStyle','2');
        Reg.WriteString('Wallpaper',StrFile);{向TileWallpaper 和Wallpaper串覆盖写入新值}
        Reg.WriteString('ConvertedWallpaper',StrFile);
        Reg.WriteString('OriginalWallpaper',StrFile);
        Reg.CloseKey;{将更改内容写入注册表并关闭}
        Systemparametersinfo(SPI_SETDESKWallpaper,0,Pchar(StrFile),
           SPIF_upDateINIFIle Or SPIF_SENDWININICHANGE); // or SPIF_SendChange);{向Windows发送消息，通知Windows更换壁纸}
      end;
  finally
    Reg.Free;
  end;
end;

 

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
    0: WPO.dwStyle := WPSTYLE_CENTER; {居中}
    1: WPO.dwStyle := WPSTYLE_TILE; {平铺}
    2: WPO.dwStyle := WPSTYLE_STRETCH; {拉伸}
  else WPO.dwStyle := WPSTYLE_CENTER;
  end;
  WPO.dwSize := SizeOf(WPO);
  DT.SetWallpaperOptions(WPO, 0);
  DT.SetWallPaper(PwideChar(WS),0);
  DT.ApplyChanges(AD_APPLY_ALL);
end;