Bild per zufall auswählen

[Date Murphy]

Hi,

ich habe sehr viele Hintergrundbilder in einem Ordner.

Wie kann ich zufällig nach einer bestimmten Zeit ein Bild

auswählen und es als Hintergrundbild anzeigen lassen ?

Danke schon mal für eure Tipps.

Gruß Date Murphy :D

[DaRoule]

Probier mal das hier:

function RandomePic(Dir, Ext: string): string;
// Ext=*.bmp;*.jpg;...
var SR : TSearchRec;
PicList : TStringList;
begin
if Dir[Length(Dir)]<>'\' then
Dir:=Dir+'\';
PicList:=TStringList.Create;
if FindFirst(Dir+Ext, faAnyFile, SR)=0 then
begin
repeat
Application.ProcessMessages;
if (Length(SR.Name)>0) AND (SR.Name[1]<>'.')
AND ((SR.Attr and faDirectory)=0) then
PicList.Add(Dir+SR.Name)
until FindNext(SR)<>0;
Result:=PicList.Strings[Random(PicList.Count)];
FindClose(SR);
PicList.Free;
end;
end;

Beispiel:

procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(RandomePic('E:\Internet\Privat\Bilder & Videos', '*.bmp'));
end;

Mfg DaRoule :cool:

[SAV]

Hallo, eine Frage. Geht das bei dir, wenn ich es starte schreibt er nur dan Dateiname des Bildes. Muß er nicht den Hindergrund wechseln. Oder mache ich was falsch.

[DaRoule]

Hi,

Sorry habe gemeint du willst das randomefile an ein Image weitergeben :mauer:

Habe du meinst ja den Desktophintergrund :D

Hier hast du den richtigen Code :

uses
ShlObj, ComObj;

function RandomePic(Dir, Ext: string): string;
// Ext=*.bmp;*.jpg;...
var SR : TSearchRec;
PicList : TStringList;
begin
if Dir[Length(Dir)]<>'' then
Dir:=Dir+'';
PicList:=TStringList.Create;
if FindFirst(Dir+Ext, faAnyFile, SR)=0 then
begin
repeat
Application.ProcessMessages;
if (Length(SR.Name)>0) AND (SR.Name[1]<>'.')
AND ((SR.Attr and faDirectory)=0) then
PicList.Add(Dir+SR.Name)
until FindNext(SR)<>0;
Result:=PicList.Strings[Random(PicList.Count)];
FindClose(SR);
PicList.Free;
end;
end;

function ChangeWallpaper(aFile: String): Boolean;
const
CLSID_ActiveDesktop: TGUID = '{75048700-EF1F-11D0-9888-006097DEACF9}';
var
hObj: IUnknown;
ADesktop: IActiveDesktop;
str: string;
wstr: PWideChar;
begin
hObj := CreateComObject(CLSID_ActiveDesktop);
ADesktop := hObj as IActiveDesktop;
wstr := AllocMem(MAX_PATH);
try
StringToWideChar(aFile, wstr, MAX_PATH);
ADesktop.SetWallpaper(wstr, 0);
ADesktop.ApplyChanges(AD_APPLY_ALL or AD_APPLY_FORCE);
finally
FreeMem(wstr);
end;
end;

Beispiel:

procedure TForm1.Button1Click(Sender: TObject);
begin
ChangeWallpaper(RandomePic('E:\Internet\Privat\Bilder & Videos', '*.bmp'));
end;

Mfg DaRoule ;)

[xOOn]

also api kenn ich keine die das mach bzw setzt
in der reg steht unter HKEY_CURRENT_USER\Control Panel\Desktop im eintrag Wallpaper das teil drinnen (WinXP)

@DaRoule
CLSID_ActiveDesktop: TGUID = '{75048700-EF1F-11D0-9888-006097DEACF9}';

funkt dein teil auch mit deaktiviertem Active Desktop ?

[SAV]

Komisch was machen ich den falsch, wenn ich auf den Button klicke kommt nur die Darstellungs Farbe raus aber die Bilder wechseln tut er nicht. Warum, was mache ich falsch. Die Bilder liegen bei mir in D:\Bilder.

[DaRoule]

Hi,

also wenn`s jetzt net klappt dann weise au net !

uses
ShlObj, ComObj;

{ Randome-Function für die Pic's }
function RandomePic(Dir, Ext: string): string;
// Ext=*.bmp;*.jpg;...
var
SR : TSearchRec;
PicList : TStringList;
begin
if Dir[Length(Dir)]<>'\\' then
Dir:=Dir+'\\';
PicList:=TStringList.Create;
if FindFirst(Dir+Ext, faAnyFile, SR)=0 then
begin
repeat
Application.ProcessMessages;
if (Length(SR.Name)>0) AND (SR.Name[1]<>'.') AND ((SR.Attr and faDirectory)=0) then
PicList.Add(Dir+SR.Name);
until FindNext(SR)<>0;
Result:=PicList.Strings[Random(PicList.Count)];
FindClose(SR);
PicList.Free;
end;
end;

{ Hintergrund für den ActiveDesktop }
function ChangeWallpaper(aFile: String): Boolean;
const
CLSID_ActiveDesktop: TGUID = '{75048700-EF1F-11D0-9888-006097DEACF9}';
var
hObj: IUnknown;
ADesktop: IActiveDesktop;
str: string;
wstr: PWideChar;
begin
hObj := CreateComObject(CLSID_ActiveDesktop);
ADesktop := hObj as IActiveDesktop;
wstr := AllocMem(MAX_PATH);
try
StringToWideChar(aFile, wstr, MAX_PATH);
ADesktop.SetWallpaper(wstr, 0);
ADesktop.ApplyChanges(AD_APPLY_ALL or AD_APPLY_FORCE);
finally
FreeMem(wstr);
end;
end;

{ Hintergrund Normal }
function ChangeBMPPic(aFile: String): Boolean;
var
sWallPaperBMPPath: string;
begin
sWallPaperBMPPath := RandomePic('E:\Internet\Privat\Bilder & Videos', '*.*');
if not SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, Pointer(sWallPaperBMPPath),
SPIF_SENDWININICHANGE) then
Result:=True
else
Result:=False;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
{ ActiveDesktop }
ChangeWallpaper(RandomePic('E:\Internet\Privat\Bilder & Videos', '*.*'));
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
{ Normal Hintergrund }
ChangeBMPPic(RandomePic('E:\Internet\Privat\Bilder & Videos', '*.*'));
end;

Have fun DaRoule :cool:

[SAV]

Super es hat geklappt Danke für die HILFE;