sorry.
Sub cmdPublishCalendar_Click
Const olFolderCalendar = 9
' #### BEGIN USER OPTIONS ####
' Target folder or URL
strTarget = "target here"
' Title for top of calendar
strTitle = ""
' Background graphic
strGraphicPath = "C:\Winnt\Santa Fe Stucco.bmp"
' Use graphic Y/N?
blnUseGraphic = False
' number of months to publish
intMonths = 12
' print user's default Calendar
blnPrintDefaultCal = False
' path to other calendar; only valid
' if blnPrintDefaultCal = False
strCalFolderPath = "Personal Folders\Calendar"
' ##### END USER OPTIONS ####
' if trailing \, strip it
If Right(strTarget, 1) = "\" Then
strTarget = Left(strTarget, Len(strTarget) - 1)
End If
'Create instances Outlook, WebPub and fso
On Error Resume Next
Set oOutlApp = CreateObject("Outlook.Application")
If oOutlApp Is Nothing Then
MsgBox "Could not access Outlook - shutting down"
Else
Set oWebPub = CreateObject("InternetExplorer.Application")
'WebPub.cWebPub
If oWebPub Is Nothing Then
MsgBox "Could not access WebPub - Shutting down"
Else
Set fso = CreateObject("Scripting.FileSystemObject")
If fso Is Nothing Then
MsgBox "Could not access FileSystemObject - shutting down"
Set oWebPub = Nothing
Set oOutlApp = Nothing
Exit Sub
End If
' Navigate to folder to be published
If blnPrintDefaultCal Then
Set objNS = oOutlApp.GetNamespace("MAPI")
Set objCalFolder = objNS.GetDefaultFolder(olFolderCalendar)
Else
Set objCalFolder = GetMAPIFolder(strCalFolderPath)
End If
If objCalFolder Is Nothing Then
MsgBox "Could not get Calendar folder - shutting down"
Else
Set objExpl = oOutlApp.Explorers.Add(objCalFolder, 2)
objExpl.Activate
'Calculate the first and last days of the month
dteStart = CDate(Month(Date) & "/1/" & Year(Date))
dteEnd = DateAdd("m", intMonths, dteStart) 'Add a month
dteEnd = DateAdd("d", -1, dteEnd) 'Subtract a day
' remove old version of calendar
' so you can publish unattended
intPos = InStrRev(strTarget, "\")
strCalFile = Mid(strTarget, intPos + 1)
strCalFile = strTarget & "\" & strCalFile & ".htm"
If fso.FileExists(strCalFile) Then
fso.DeleteFile strCalFile
End If
'Publish calendar to strTarget
oWebPub.Create CStr(strTitle), _
CStr(strGraphicPath), _
CBool(blnUseGraphic ), _
CDate(dteStart), _
CDate(dteEnd), _
True, _
True, _
CStr(strTarget)
'WebPub.Create method parameters:
'sTitle - Title displayed at the top of the page
'sGraphic - Path to a graphic file to use for
BACKGROUND
' attribute
'bUseGraphic - True=Use 'sGraphic' param, False=Ignore
'dtStartDate - Start of date range to publish
'dtEndDate - End of date range to publish
'bDetails - Publish appointment details
'bShowInBrowser - Display in default browser after
publishing
'sSiteName - Local path to store published calendar
If Not objExpl Is Nothing Then
objExpl.Close
End If
End If
End If
End If
'Release objects
Set oWebPub = Nothing
Set oOutlApp = Nothing
Set fso = Nothing
End Sub
Function GetMAPIFolder(strName)
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
arrName = Split(strName, "\")
Set objFolders = objNS.Folders
blnFound = False
For I = 0 To UBound(arrName)
For Each objFolder In objFolders
If objFolder.Name = arrName(I) Then
Set objFolders = objFolder.Folders
blnFound = True
Exit For
Else
blnFound = False
End If
Next
If blnFound = False Then
Exit For
End If
Next
If blnFound = True Then
Set GetMAPIFolder = objFolder
End If
Set objApp = Nothing
Set objNS = Nothing
Set objFolder = Nothing
Set objFolders = Nothing
Set objExpl = Nothing
End Function
