Here’s what my (partially obfuscated) desktop looks like:
I put information I need on my desktop so I’m a Windows+M key combination away from what I need. The Excel file sits in my XLStart directory so the calendar gets updated every day.
VBA from Excel to Desktop
In the Workbook_Open event, I have
|
1 2 3 4 5 6 7 8 9 10 11 12 |
Private Sub Workbook_Open() If Sheet8.Range("LastUpdate") <> Date Then Sheet8.Range("LastUpdate") = Date PrintDesktop Application.CalculateFull Me.Save End If Me.Close False End Sub |
It only updates it once per day, although it doesn’t really take that long to execute. In a standard module, I have:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 |
Declare Function SystemParametersInfo Lib "user32" _ Alias "SystemParametersInfoA" (ByVal uAction As Long, _ ByVal uParam As Long, ByVal lpvParam As Any, _ ByVal fuWinIni As Long) As Long Public Const SPI_SETDESKWALLPAPER = 20 Public Const SPIF_SENDWININICHANGE = &H2 Public Const SPIF_UPDATEINIFILE = &H1 Public Sub SetWallpaper(ByVal FileName As String) Dim x As Long x = SystemParametersInfo(SPI_SETDESKWALLPAPER, _ 0&, FileName, SPIF_SENDWININICHANGE Or SPIF_UPDATEINIFILE) End Sub Sub PrintDesktop() Dim rng As Range Dim Fname As String Dim oPic As IPictureDisp Set rng = Sheet8.Range("Print_Area") rng.CopyPicture xlScreen, xlBitmap Set oPic = PastePicture(xlBitmap) Fname = "C:\Documents and Settings\Dick.NEBRASKA\My Documents\MyWallpaper.bmp" SavePicture oPic, Fname SetWallpaper Fname End Sub |
The PastePicture call uses code from Stephen Bullen’s PastePicture.zip file.
Almost nothing in the file is my own – all stolen. In addition to Stephen’s PastePicture, the following code is borrowed:
The Calendar
The calendar for this month and next month is John Walkenbach’s Array Calendar (see also). For ‘next month’ I merely added 1 to the month in the DATE function throughout that formula.
Week Numbers
The week numbers along the right come from Ron de Bruin’s site. The formula in H27 is
=IF(LEN(B27)=0,””,INT((B27-DATE(YEAR(B27-WEEKDAY(B27-1)+4),1,3)+WEEKDAY(DATE(YEAR(B27-WEEKDAY(B27-1)+4),1,3))+5)/7))
It only shows the week number for weeks with a Monday (B27 in this case).
Highlighting Today and Holidays
The conditional formatting for the current month looks like this:
The first format inverts the colors for the current day. The second format checks the range HolVac to see if the date is a holiday – meaning a day I don’t work. In that range, I have the holidays my company offers plus I enter any scheduled vacation days. I show the holiday formulas below. The second format is repeated for ‘next month’.
Special Characters
Because I deal with German companies on a somewhat regular basis, I like to keep the ASCII codes for some German characters handy, and I do that across the bottom. To enter the special characters, hold down the Alt key and type the four digit number on the numeric keypad.
Holiday Formulas
The formulas for the holidays come from Chip Pearson’s Holiday Page and Chip’s Date and Time Page. In the following formulas, cell S1 contains the current year and S2 contains the next year.
New Year’s Day: =IF(WEEKDAY(DATE(S1,1,1))=7,DATE(S1,1,1)-1,IF(WEEKDAY(DATE(S1,1,1))=1,DATE(S1,1,1)+1,DATE(S1,1,1)))
Next New Year’s Day: =IF(WEEKDAY(DATE(S2,1,1))=7,DATE(S2,1,1)-1,IF(WEEKDAY(DATE(S2,1,1))=1,DATE(S2,1,1)+1,DATE(S2,1,1)))
Memorial Day: (array) =IF(SUM(IF(WEEKDAY(DATE($S$1,5,1)-1+ROW(INDIRECT("1:"&TRUNC(DATE($S$1,5,31)-DATE($S$1,5,1))+1)))=2,1,0))=5,DATE(YEAR(NOW()),5,1+((5-(2>=WEEKDAY(DATE(YEAR(NOW()),5,1))))*7)+(2-WEEKDAY(DATE(YEAR(NOW()),5,1)))),DATE(YEAR(NOW()),5,1+((4-(2>=WEEKDAY(DATE(YEAR(NOW()),5,1))))*7)+(2-WEEKDAY(DATE(YEAR(NOW()),5,1)))))
US Indpendence Day: =IF(WEEKDAY(DATE(S1,7,4))=7,DATE(S1,7,4)-1,IF(WEEKDAY(DATE(S1,7,4))=1,DATE(S1,7,4)+1,DATE(S1,7,4)))
Labor Day: =DATE(S1,9,1+((1-(2>=WEEKDAY(DATE(S1,9,1))))*7)+(2-WEEKDAY(DATE(S1,9,1))))
Thanksgiving: =DATE(S1,11,1+((4-(5>=WEEKDAY(DATE(S1,11,1))))*7)+(5-WEEKDAY(DATE(S1,11,1))))
Xmas Eve: =IF(WEEKDAY(DATE(S1,12,24))=7,DATE(S1,12,24)-1,IF(WEEKDAY(DATE(S1,12,24))=1,DATE(S1,12,24)-2,DATE(S1,12,24)))
Xmas: =IF(WEEKDAY(DATE(S1,12,25))=7,DATE(S1,12,25)-1,IF(WEEKDAY(DATE(S1,12,25))=1,DATE(S1,12,25)+1,DATE(S1,12,25)))
Update: Download DesktopPic.zip
How to find/configure the XLStart directory?
Well you’ve put it all together very well Dick. And, emm, nice colors too ;-)
Looks great! Is it possible to provide your XLS file for download ?
Thanks
Very nice, Dick, thanks. I improved the aesthetics a bit (to my mind, anyway) by using the same dark photo (of a Delta rocket launch from Cape Canaveral) that I’d been using as a desktop pic. I inserted it into Excel as a background and adjusted my columns to fit the picture size. I reversed all the type out in white vs. the stripey look. I don’t have the calendar currently, though I’ll probably add that later.
Now I just have to clean up my cluttered desktop so that I can see the numberws without moving files every time!
That sounds cool, chip. Send me a screen shot if you get the chance. Thanks.
Dick, I sent one last night to the email I found on the About page (dicks-clicks.com domain). If there’s a different one, let me know.
Dick,
I changed the path for where the “mywallpaper.bmp” should be saved. When I open the file it runs through the procedures but the bmp is not saved in the path, in fact, its not saved at all.
Do you have any idea why this happens?
Regards, Cor