Brenton.neill
New member
- Joined
- Jan 9, 2018
- Messages
- 3
- Reaction score
- 0
- Points
- 0
Hi guys
I have been trying to get this sorted for a few months now just seeing if anyone can hep
I am tryin to export emails that have the subject 'Appointment' to my excel spreadsheet.
they provide me with the following details name, date, time, type, location just like below,
I keep track of members appointments through a excel spreadsheet.
They provide the following information to me in a email,
Name - bob
Date - 20 Dec 2017
Time - 15:00
Type - Upper Body
Location - Hospital
I have attached a spreadsheet I use to keep track.
I have multiple people emailing me appointments, When the appointment has passed I am trying to work out a code to delete this.
With the code I am want it to continue to re add appointments from the top once old appointments have been deleted if possible
The code at the moment when it does work keeps deleting the existing appointment on row 99 for the new appointment
the rows I use are from 99 - 112
I am getting the following error
I have been trying to get this sorted for a few months now just seeing if anyone can hep
I am tryin to export emails that have the subject 'Appointment' to my excel spreadsheet.
they provide me with the following details name, date, time, type, location just like below,
I keep track of members appointments through a excel spreadsheet.
They provide the following information to me in a email,
Name - bob
Date - 20 Dec 2017
Time - 15:00
Type - Upper Body
Location - Hospital
I have attached a spreadsheet I use to keep track.
I have multiple people emailing me appointments, When the appointment has passed I am trying to work out a code to delete this.
With the code I am want it to continue to re add appointments from the top once old appointments have been deleted if possible
The code at the moment when it does work keeps deleting the existing appointment on row 99 for the new appointment
the rows I use are from 99 - 112
Code:
[COLOR=#333333][FONT=monospace]Sub GetInBoxFolderDetailsIfSubject()
Dim a, b, c, e, ec, i As Long, j As Long
'Early Binding: Tools > References > Microsoft Outlook xx.0 Object Library > OK
'Dim oApp As Outlook.Application, oM As Outlook.MailItem
'Dim oNS As Namespace, oG As Outlook.MAPIFolder 'Usual method.
'Late Binding:
Dim oApp As Object, oM As Object, oNS As Object, oG As Object
Set oApp = CreateObject("Outlook.Application")
Set oNS = oApp.GetNamespace("MAPI")
Set oG = oNS.GetDefaultFolder(6) 'olFolderInbox=6
Set oM = oApp.CreateItem(0) 'olMailItem=0
If oG.Items.Count = 0 Then GoTo EndSub
ReDim a(1 To oG.Items.Count, 1 To 6)
For i = 1 To oG.Items.Count
Set oM = oG.Items(i)
If TypeName(oM) <> "MailItem" Then GoTo NextI
With oM
If .Subject = "Appointment" Then
.Subject = "Deleted - Appointment"
.Save
j = j + 1
b = Split(.Body, vbCrLf)
For Each e In b
c = Split(e, " - ")
For Each ec In c
Select Case ec
Case "Name": a(j, 1) = c(1)
Case "Date": a(j, 2) = c(1)
Case "Time": a(j, 3) = c(1)
Case "Type": a(j, 4) = c(1)
Case "C/A": a(j, 5) = c(1)
Case "Location": a(j, 6) = c(1)
End Select
Next ec
Next e
End If
End With
NextI:
Next i
If j = 0 Then Exit Sub
Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(UBound(a), UBound(a, 2)).Value = a
Sheet1.[A99].Resize(UBound(a), UBound(a, 2)).Value = a
'Delete Appointments
For j = 1 To oG.Items.Count
Set oM = oG.Items(j)
If TypeName(oM) <> "MailItem" Then GoTo NextJ
If oM.Subject = "Deleted - Appointment" Then oM.Delete
NextJ:
Next j
EndSub:
Set oM = Nothing
Set oG = Nothing
Set oNS = Nothing
Set oApp = Nothing
End Sub[/FONT][/COLOR]
[/LEFT]Run time error 287
Click debug and it’s coming up with
B = Split(.Body, vbCrLf)
Click debug and it’s coming up with
B = Split(.Body, vbCrLf)
Last edited by a moderator:
