Given that this is a Word vba group I assume that you mean from a Word
document?

Dim ol As New Outlook.Application
Dim ci As AppointmentItem
Dim strDate As String
Dim strTime As String
Dim strDocName As String
Dim intPos As Integer
Dim datOutlookDate As Date

strDate = Date
strTime = Format((Time), "hh:mm")
datOutlookDate = CDate(strDate & " " & strTime)

'Find position of extension in filename
strDocName = ActiveDocument.Name
intPos = InStrRev(strDocName, ".")
If intPos = 0 Then

   'If the document has not yet been saved
   'Ask the user to provide a filename
   strDocName = InputBox("Please enter the name " & _
   "of your document in the format filename.doc", "Document not yet saved")
   'Save file with new extension
   ActiveDocument.SaveAs FileName:=strDocName, _
   FileFormat:=wdFormatDocument0
End If
strDocName = Left(strDocName, intPos - 1)

Set ci = ol.CreateItem(olAppointmentItem)
   ci.start = strDate
   ci.ReminderSet = False
   ci.AllDayEvent = True
   ci.Subject = strDocName
   ci.Location = InputBox("Location?")
   ci.Categories = InputBox("Category?")
   ci.Body = InputBox("Body Text?")
   ci.BusyStatus = olFree
   ci.GetRecurrencePattern.RecurrenceType = olRecursMonthly
   ci.Save
   Set ol = Nothing
End Sub