Send permission for vacation from excel form to outlook -- votingoptions and Appt.

[ARankin]

Hello,

I have very little knowledge of vba, and I have gotten by for the moment by copying and pasting strategically and trial-and-error to assembly what I want. For the moment, I have taken an excel form to request vacation that it linked to a macro to send the form via Outlook with the excel table and have a voting button where the manager can approve or deny the request. I would like to include the appointment on the calendar of the requestor (not the public calendar) when approved with the subject line as the title of the appointment. So far, I can do everything except create the appointment after approval with the subject line as the title.

Here is my vba code -- it is probably a bit silly since I copied and pasted from multiple sources, but every advice would be much appreciated.

Thanks,
Alex



Sub EmailAbsence()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim olApp As Outlook.Application, olMail As Outlook.MailItem
Set rng = Nothing
'ActiveSheet.Unprotect
On Error Resume Next
Set rng = Sheets("Absence").Range("A1:F27").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
'ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'strbody = "<font size=4><font face=arial><B>Hi" & _
' "<br><br><br></B></font size></font face>"
'SigString = Environ("appdata") & _
End With
On Error Resume Next
With OutMail
.To = "arankin@*****.be"
.CC = ""
.BCC = ""
.Subject = Sheets("Absence").Range("B5").Text & " " & Range(" B11").Text
.HTMLBody = RangetoHTML1(rng)
.Display
.Start = dteStart
.End = dteEnd
.ReminderSet = False
.VotingOptions = "Accepted ; Rejected"
.Subject = Sheets("Absence").Range("B5").Text & " " & Range(" B11").Text
.AllDayEvent = True
End With
myItem.Save
Display.Save
End Sub
Function RangetoHTML1(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML1 = ts.readall
ts.Close
RangetoHTML1 = Replace(RangetoHTML1, "align=center x publishsource=", "align=left x publishsource=")
TempWB.Close savechanges:=False
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim SigString As String
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "<font size=4><font face=arial><B>Hi" & _
"<br><br>Please find below the Team Leave Summary as requested.<br>" & _
"<br>Let me know if you have problems.<br></B></font size></font face>"
SigString = Environ("appdata") & _
src = Roaming \ Microsoft \ Signatures \ icapital1.txt
src = "icapital_files/image001.png"
src = "icapital_files/image002.png"
src = "icapital_files/image003.png"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
On Error Resume Next
With OutMail
Select Case
Case "Accepted"
End Select
dteStart = dteStart
dteEnd = dteEnd
Set objAppt = Application.CreateItem(olAppointmentItem)
With objAppt
.Start = dteStart
.End = dteEnd
.ReminderSet = False
.Subject = Sheets("Absence").Range("B5").Text & " " & Range(" B11").Text
.AllDayEvent = True
.BusyStatus = olOutOfOffice
.To = "arankin@*****.be"
.CC = ""
.BCC = ""
.Subject = Sheets("Absence").Range("B5").Text & " " & Range(" B11").Text
.Body = strbody & vbNewLine & vbNewLine & Signature
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Function

[skatonni]

... I would like to include the appointment on the calendar of the requestor (not the public calendar) when approved with the subject line as the title of the appointment. So far, I can do everything except create the appointment after approval with the subject line as the title.

Sounds like you want the manager to update another person's calendar. This would be a virus.

To debug the code you have that generates the request email, try using Option Explicit and as well removing the second instance of On Error Resume Next.

The requster can update his own calendar with this. Adjust it to fit your Subject line.


Sub Set_Absence_CurrentItem_Or_Selection()
Dim item As Object
Dim msg As mailItem
If Inspectors.count > 0 Then
' Assume the "active" inspector has the message to be saved

Set item = ActiveInspector.currentItem
If TypeOf item Is mailItem Then
Set msg = item
Debug.Print msg.Subject
Set_Absence msg

Else
MsgBox "The open item is not a mailitem. Open or select the approved vacation mail."

End If

Else

On Error GoTo errorhandler
Set item = ActiveExplorer.Selection(1)
On Error GoTo 0

If TypeOf item Is mailItem Then
Set msg = item
Debug.Print msg.Subject
Set_Absence msg
Else
MsgBox "The selection is not a mailitem. Open or select the approved vacation mail."
End If

End If
GoTo exitRoutine
'
errorhandler:
MsgBox "Errorhandler: Open or select the approved vacation mail."
GoTo exitRoutine
'
exitRoutine:
Set item = Nothing
Set msg = Nothing
End Sub
'
'
Sub Set_Absence(curritem As mailItem)
Dim olApt As AppointmentItem
Dim startDate As String
Dim endDate As String
'
' Based on a subject that looks like this
' Accepted: Start: yyyy mm dd End: yyyy mm dd
'
If Left(curritem.Subject, 16) = "Accepted: Start:" Then

Set olApt = Application.CreateItem(olAppointmentItem)

startDate = Mid(curritem.Subject, 18, 10)
endDate = Mid(curritem.Subject, 34, 10)
Debug.Print startDate
Debug.Print endDate

With olApt
.Start = CDate(startDate) + TimeValue("08:00:00")
.End = CDate(endDate) + TimeValue("17:30:00")
.Subject = curritem.Subject
.Location = "Not here"
.Body = "Approved Absence body."
.BusyStatus = olOutOfOffice
.ReminderMinutesBeforeStart = 120
.ReminderSet = True
.Display
End With

Set olApt = Nothing

Else

MsgBox "Open or select a mailitem with this subject format:" & vbCr & vbCr & _
"""Accepted: Start: yyyy mm dd End: yyyy mm dd"""

End If
End Sub