Public
Sub
CreateLogCalendar()
Dim
Ns
As
Outlook.NameSpace
Dim
objApp
As
Outlook.Application
Dim
olAppt
As
Outlook.AppointmentItem
Dim
Item
As
Object
Set
Ns = Application.GetNamespace(
"MAPI"
)
Set
objApp = Application
Select
Case
TypeName(objApp.ActiveWindow)
Case
"Explorer"
Set
Item = objApp.ActiveExplorer.Selection.Item(1)
Case
"Inspector"
Set
Item = objApp.ActiveInspector.CurrentItem
End
Select
Set
calFolder = Ns.GetDefaultFolder(olFolderCalendar)
Set
olAppt = calFolder.Items.Add(olAppointmentItem)
With
olAppt
.Subject = Item.Subject
.Attachments.Add Item
.Start = Now + 7
.
End
= Now + 7
.ReminderSet =
False
.BusyStatus = olFree
.AllDayEvent =
True
.Display
<strong>
End
With
</strong>
Set
objApp =
Nothing
Set
Ns =
Nothing
End
Sub