Wallpapers slideshow with visual foxpro
As the code is made the exe works inside VFP only(_screen.visible=.t.).Must create a top level form hidden and add the systray object to make it working from anywhere.
Suggestions and Bug Reports are always Welcome
*Begin Code
Clea All
Local m.myvar
TEXT to m.myvar noshow
Summary help
The wallpaper is a screen backgroung image set by the system with the API SystemParametersInfo
This code set a folder of images and play them with a timer as a wallpaper sequentially or randomly.
Can set set at runtime the folder images source , the timer interval,..
Can change the wallpaper by a simple click in the menu.
All these can set in the systray menu.St must enable the application in the contextuel menu (first item).
Make an exe and run (change the link to copy in the start menu).
ENDTEXT
With _Screen
.AddProperty("ystart",.F.)
.AddProperty("yinterval",60000) &&time interval 1 mn
.AddProperty("ySource",Iif(Directory("E:\ywallpapers\wallpapers\")=.T.,"E:\ywallpapers\wallpapers\",Getdir() ))
.AddProperty("yhelp",m.myvar)
.AddProperty("yrandom",.F.)
.AddProperty("ystartW",.F.) &&lauch with windows start
.Addproperty("yenabled",.f.)
Endwith
Publi m.yrepi
=ystart()
Publi m.yrep
m.yrep=Addbs(Justpath(Sys(16,1)))
Set Defa To (yrep)
Set Safe Off
Set Date Long
_Screen.WindowState=1
Do ydeclare
*Create the external contextuel systray menu ymenu.mpr
Local m.myMPR
TEXT to m.myMPR noshow
DEFINE POPUP raccourci SHORTCUT RELATIVE FROM MROW(),MCOL()
DEFINE BAR 1 OF raccourci PROMPT "Enable wallpapers" ;
FONT "Courier New", 8 style "BI" COLOR G/W*, B/W*,,,,W+/GR ;
PICTURE home(1)+"graphics\icons\misc\CHECKMRK.ico"
DEFINE BAR 2 OF raccourci PROMPT "Stop Wallpaper" ;
FONT "Courier New", 8 style "BI" COLOR G/W*, B/W*,,,,W+/GR ;
PICTURE home(1)+"graphics\icons\misc\camera.ico"
DEFINE BAR 3 OF raccourci PROMPT "Set images source" ;
FONT "Courier New", 8 style "BI" COLOR G/W*, B/W*,,,,W+/GR ;
PICTURE home(1)+"graphics\icons\misc\misc15.ico"
DEFINE BAR 4 OF raccourci PROMPT "New Wallpaper" ;
FONT "Courier New", 8 style "BI" COLOR G/W*, B/W*,,,,W+/GR ;
PICTURE home(1)+"graphics\icons\misc\volume01.ico"
DEFINE BAR 5 OF raccourci PROMPT "Set new interval" ;
FONT "Courier New", 8 style "BI" COLOR G/W*, B/W*,,,,W+/GR ;
PICTURE home(1)+"graphics\icons\misc\misc18.ico"
DEFINE BAR 6 OF raccourci PROMPT "Summary help" ;
FONT "Courier New", 8 style "BI" COLOR G/W*, B/W*,,,,W+/GR ;
PICTURE home(1)+"graphics\icons\misc\binoculR.ico"
DEFINE BAR 7 OF raccourci PROMPT "Start with windows" ;
FONT "Courier New", 8 style "BI" COLOR G/W*, B/W*,,,,W+/GR ;
PICTURE home(1)+"graphics\icons\misc\lighton.ico"
DEFINE BAR 8 OF raccourci PROMPT "random wallpapers" ;
FONT "Courier New", 8 style "BI" COLOR G/W*, B/W*,,,,W+/GR ;
PICTURE home(1)+"graphics\icons\misc\clock02.ico"
DEFINE BAR 9 OF raccourci PROMPT "Exit"
ON SELECTION BAR 1 OF raccourci ;
DO _4al16sn4n
ON SELECTION BAR 2 OF raccourci ;
do _4al16sn4ro
ON SELECTION BAR 3 OF raccourci ;
do _4al16sn52
ON SELECTION BAR 4 OF raccourci ;
do _4al16sn53
ON SELECTION BAR 5 OF raccourci ;
DO _4al16sn4j
ON SELECTION BAR 6 OF raccourci ;
do _4al16sn4o
ON SELECTION BAR 7 OF raccourci ;
do _ylaunchW
ON SELECTION BAR 8 OF raccourci ;
do _yrandom
ON SELECTION BAR 9 OF raccourci oSystray.destroy()
ACTIVATE POPUP raccourci
*
PROCEDURE _4al16sn4n &&1-Enable wallpaper
if _screen.yenabled=.f.
_screen.yenabled=.t.
=ywallp() &&starting
messagebox("Wallpaper app enabled!",0+32+4096,'',1000)
else
Messagebox("Wallpaper already enabled and active!",0+32+4096,1000)
endi
PROCEDURE _4al16sn4ro &&2-Stop wallpaper
ytimer1.enabled=.f.
messagebox("Wallpapers stopped!",0+32+4096,'',1000)
*
PROCEDURE _4al16sn52 &&3-Set images source
local xsource
m.xsource=getdir()
if ! empty(m.xsource)
_screen.ysource=m.xsource
=ystart()
endi
*
PROCEDURE _4al16sn53 &&4-New wallpaper
=ywallp()
*
PROCEDURE _4al16sn4j &&5-Set new interval
local xinterval,y
y=trans(_screen.yinterval)
m.xinterval=int(val(inputbox("new interval in Mseconds","",m.y)))
if !m.xinterval>0
m.xinterval=60000
endi
_screen.yinterval=m.xinterval &&ms
*
PROCEDURE _4al16sn4o &&6-Summary help
messagebox(_screen.yhelp,0+32+4096,"Summary help")
procedure _ylaunchW &&set a start link or no in windows start For a Single User on a Specific Computer:
if file(m.yrep+"ywallpaper.lnk")
_screen.ystartW= ! _screen.ystartW
if _screen.ystartW=.f.
erase (getenv('APPDATA')+"\Microsoft\Windows\Start Menu\Programs\Startup\ywallpaper.lnk")
messagebox("start link erased!",0+32+4096,'',1000)
else
copy file (m.yrep+"ywallpaper.lnk") to (getenv('APPDATA')+"\Microsoft\Windows\Start Menu\Programs\Startup")
messagebox("start link set !",0+32+4096,'',1000)
endi
else
messagebox("create the app shortcut first(rightclick on..)",0+32+4096,'',1000)
endi
procedure _yrandom &&random wallpapers
_screen.yrandom = !_screen.yrandom
messagebox("Random Wallpapers = "+trans(_screen.yrandom),0+32+4096,'',1000)
procedure ydestroy &&9-exit
try
ytimer1.enabled=.f.
catch
endtry
oSystray.destroy()
clea events
endproc
ENDTEXT
Strtofile(m.myMPR,m.yrep+"ymenu.mpr")
Set Path To Home(1)+"samples\solution\toledo\"
Publi m.osystray
m.osystray = Createobject("ysystray")
m.osystray.AddIconToSystray()
Read Events && Wait for user input. it supposes mandatory the e command "clea events" is located on contextuel MPR menu
_Screen.WindowState=0
Set Safe On
Define Class ysystray As Systray Of "systray.vcx"
IconFile = Home() + "Graphics\Icons\Misc\misc15.ico"
TipText = "Ywallpaper"
MenuText = "ymenu.mpr"
MenuTextIsMPR = .T. && All work should done in the menu code, so no further code is needed here.
Procedure IconClickEvent
DoDefault() &&execute the ymenu.mpr as definded in menuText
Endproc
Procedure IconRightClickEvent &&code it the same with iconClickEvent() event
This.IconClickEvent
Endproc
Procedure Destroy && remove icon from systray,Exit Application
This.RemoveIconFromSystray()
Try
ytimer1.Enabled=.F.
Catch
Endtry
Clear Events
Endproc
Enddefine
Define Class ytimer As Timer
Enabled=.F.
Name="ytimer"
Procedure Init
This.Interval=_Screen.yinterval
Endproc
Procedure Timer
=ywallp()
Endproc
Enddefine
Procedure ystart
m.yrepi=_Screen.ysource
gnbre=Adir(gabase,m.yrepi+"*.*")
If gnbre=0
Messagebox ("no images in" +m.yrepi,16+4096,'Error')
Return .F.
Endi
Create Cursor ycurs (yimage c(250))
For i=1 To gnbre
If Inlist( Lower(Justext(m.yrepi+gabase(i,1) )),"png","jpg","bmp","gif")
Insert Into ycurs Values( m.yrepi+gabase(i,1))
Endi
Endfor
Sele ycurs
*brow
Locate
Endproc
Procedure ywallp
#Define SPI_SETDESKWALLPAPER 20
#Define SPIF_SENDWININICHANGE 1
#Define SPIF_UPDATEINIFILE 2
Local lcWallpaper, nFlag
nFlag = SPIF_UPDATEINIFILE + SPIF_SENDWININICHANGE
Sele ycurs
If Recno()>1
Clea Resources(yimage)
Endi
Local gnlower,gnUpper
If _Screen.yrandom=.F.
Try
Skip
Catch
Locate
Endtry
Else
gnlower = 1
gnUpper = Reccount()
Go Int((gnUpper - gnlower + 1) * Rand( ) + gnlower)
Endi
lcWallpaper=yimage &&set wallpaper
=yconvert(lcWallpaper) &&lcWallpaper is output
sleep(500)
= SystemParametersInfo (SPI_SETDESKWALLPAPER,;
0, @lcWallpaper, nFlag)
DoEvents
ytimer1.Interval=_Screen.yinterval
If _Screen.ystart=.F.
_Screen.ystart=.T.
ytimer1.Enabled=.T.
Endi
Endproc
Procedure yconvert &&convert any image to fullscreen bmp as wallpaper
Lparameters yimage
#Define CF_BITMAP 2
#Define IMAGE_BITMAP 0
Local m.lnWidth,m.lnHeight &&fullscreen
m.lnWidth=Sysmetric(1)
m.lnHeight=Sysmetric(2)
Local m.ext
m.ext="BMP"
lqEncoderClsID_BMP=0h00F47C55041AD3119A730000F81EF32E &&BMPFormat
*Save the graphic file to the clipboard
nBitmap=0
hbm=0
GdipCreateBitmapFromFile(Strconv(Allt(yimage)+0h00,5),@nBitmap)
GdipCreateHBITMAPFromBitmap(nBitmap,@hbm,0)
lhbmp=CopyImage(hbm, 0, lnWidth, lnHeight,0) &&resize
If OpenClipboard(0)!= 0
EmptyClipboard()
SetClipboardData(CF_BITMAP, lhbmp)
CloseClipboard()
Endif
*get the graphics from the local clipboard
OpenClipboard(0)
hBitmap = GetClipboardData(CF_BITMAP)
CloseClipboard()
*export as image file
Local lcoutputfile,lcoutputfile0,ubitmap
lcoutputfile0=Addbs(Sys(2023))+Juststem(yimage)+"."+m.ext
Erase Addbs(Sys(2023))+"*.bmp"
ubitmap=0
GdipCreateBitmapFromHBITMAP(hBitmap,2,@ubitmap)
lcoutputfile=Strconv(m.lcoutputfile0+Chr(0),5)
GdipSaveImageToFile(ubitmap,lcoutputfile,Eval("lqEncoderClsID_"+ext),Null)
sleep(100)
Procedure ydeclare
Declare Integer Sleep In kernel32 Integer
Declare Integer OpenClipboard In User32 Integer
Declare Integer CloseClipboard In User32
Declare Integer EmptyClipboard In User32
Declare Integer SetClipboardData In User32 Integer,Integer
Declare Integer GetClipboardData In User32 Integer
Declare Integer GdipSaveImageToFile In GDIPlus.Dll Integer,String,String @,String @
Declare Long GdipCreateHBITMAPFromBitmap In GDIPlus.Dll Long nativeImage, Long @, Long
Declare Long CopyImage In WIN32API Long hImage, Long, Long, Long , Long
Declare Long GdipCreateBitmapFromFile In GDIPlus.Dll String FileName, Long @nBitmap
Declare Integer GdipCreateBitmapFromHBITMAP In GDIPlus.Dll Integer, Integer, Integer @
Declare Integer ShellExecute In SHELL32.Dll Integer nWinHandle,;
STRING cOperation,;
STRING cFileName,;
STRING cParameters,;
STRING cDirectory,;
INTEGER nShowWindow
Declare Integer SystemParametersInfo In user32;
INTEGER uiAction, Integer uiParam,;
STRING @pvParam, Integer fWinIni
Endproc
*End Code
