delphi 优盘背景生成器源码

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtDlgs, XPMan, StdCtrls, FileCtrl, RzFilSys, ExtCtrls,jpeg,ShlObj;

type
TForm1 = class(TForm)
    Button1: TButton;
    Button3: TButton;
    XPManifest1: TXPManifest;
    OpenPictureDialog1: TOpenPictureDialog;
    Memo1: TMemo;
    Panel1: TPanel;
    Label2: TLabel;
    Label3: TLabel;
    RzDriveComboBox1: TRzDriveComboBox;
    Label1: TLabel;
    procedure Button1Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure RzDriveComboBox1Change(Sender: TObject);
private
    { Private declarations }
public
    { Public declarations }
end;

var
Form1: TForm1;
PicPath,UKeyPath:string;
implementation

{$R *.dfm}
function SelectFolderDialog(const Handle:integer;const Caption:string;
              const InitFolder:string;var SelectedFolder:string):boolean;
var
BInfo: _browseinfoA;
Buffer: array[0..MAX_PATH] of Char;
ID: IShellFolder;
Eaten, Attribute: Cardinal;
ItemID: PItemidlist;
begin
with BInfo do
begin
    HwndOwner := Handle;
    lpfn := nil;
    lpszTitle := Pchar(Caption);
    ulFlags := BIF_RETURNONLYFSDIRS+BIF_NEWDIALOGSTYLE;
    SHGetDesktopFolder(ID);
    ID.ParseDisplayName(0,nil,'\',Eaten,ItemID,Attribute);
    pidlRoot := ItemID;
    GetMem(pszDisplayName, MAX_PATH);
end;
if SHGetPathFromIDList(SHBrowseForFolder(BInfo), Buffer) then
begin
    SelectedFolder := Buffer;
    if Length(SelectedFolder)<>3 then
      SelectedFolder := SelectedFolder;
    result := True;
end
else begin
    SelectedFolder := '';
    result := False;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenPictureDialog1.Execute then
begin
    PicPath:=OpenPictureDialog1.FileName;
end;
end;

procedure TForm1.Button3Click(Sender: TObject);
var
attr:integer;
begin
if FileExists(PicPath) then
    begin
      if UKeyPath<>'' then
       begin
        Memo1.Lines.Add('IconArea_Image=BMJ'+ExtractFileExt(PicPath));
        if FileExists(UKeyPath+'BMJ'+ExtractFileExt(PicPath)) then
         begin
           DeleteFile(UKeyPath+'BMJ'+ExtractFileExt(PicPath));
         end;
        if FileExists(UKeyPath+'Desktop.ini') then
         begin
           DeleteFile(UKeyPath+'Desktop.ini');
         end;
        Memo1.Lines.SaveToFile(UKeyPath+'Desktop.ini');
        Memo1.Lines.Delete(Memo1.Lines.Count-1);
        CopyFile(PChar(PicPath),PChar(UKeyPath+'BMJ'+ExtractFileExt(PicPath)),True);
        Application.ProcessMessages;
        while FileExists(UKeyPath+'BMJ'+ExtractFileExt(PicPath))=False do
          begin
          end;
        attr := fileGetAttr(UKeyPath+'Desktop.ini');
        if not ( (attr and faHidden) = faHidden )then
          begin
          fileSetAttr(UKeyPath+'Desktop.ini',attr or faHidden);
          end;
        attr := fileGetAttr(UKeyPath+'BMJ'+ExtractFileExt(PicPath));
        if not ( (attr and faHidden) = faHidden )then
          begin
          fileSetAttr(UKeyPath+'BMJ'+ExtractFileExt(PicPath),attr or faHidden);
          end;
        Application.MessageBox('保存成功!', '提示', MB_OK +
        MB_ICONINFORMATION);
        PicPath:='';
       end
       else
       begin
        Application.MessageBox('未选择U盘路径,请选择!', '提示', MB_OK +
        MB_ICONINFORMATION);
       end;
    end
else
    begin
      Application.MessageBox('图片未选择或源文件不存在,请重新选择!', '提示', MB_OK +
        MB_ICONINFORMATION);
    end;
end;

procedure TForm1.RzDriveComboBox1Change(Sender: TObject);
begin
UKeyPath:=Copy(Trim(RzDriveComboBox1.Text),1,2);
end;

end.