brentonneill
12-28-2017, 03:15 AM
Hi guys,
2125121251
I get a lot of appointments from my members at work I have attached the spreadsheet with the code I am using on it but for some reason it doesn't work on my work computer.
I have a code that extracts data from a email when the subject says appoitment
It comes up with a Run time error 287
Click debug and it’s coming up with
B = Split(.Body, vbCrLf)
I also am trying to work out when a appointment has been deleted from the top to get the next appointment to replace it
As the spreadsheet is big and I track a lot of things at work I am talking about area 97 - 112
Also when it deletes the appointment it deletes the whole area lines and all can this be stoped as I only want it to delete the appointment row when the date has passed.
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 5)
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 "Location": a(j, 5) = 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
Sub DelRows()
Dim u As Range, ur As Range, r As Range, c As Range
Dim ws
Set ws = Worksheets("E22B")
Set r = ws.Range("B99:B110", ws.Cells(Rows.Count, "B").End(xlUp))
For Each c In r
If Date > c Then
Set u = c.Rows(c.Row)
If ur Is Nothing Then
Set ur = c
Else: Set ur = Union(ur, c)
End If
End If
Next c
If Not ur Is Nothing Then ur.EntireRow.Delete xlUp
End Sub
2125121251
I get a lot of appointments from my members at work I have attached the spreadsheet with the code I am using on it but for some reason it doesn't work on my work computer.
I have a code that extracts data from a email when the subject says appoitment
It comes up with a Run time error 287
Click debug and it’s coming up with
B = Split(.Body, vbCrLf)
I also am trying to work out when a appointment has been deleted from the top to get the next appointment to replace it
As the spreadsheet is big and I track a lot of things at work I am talking about area 97 - 112
Also when it deletes the appointment it deletes the whole area lines and all can this be stoped as I only want it to delete the appointment row when the date has passed.
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 5)
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 "Location": a(j, 5) = 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
Sub DelRows()
Dim u As Range, ur As Range, r As Range, c As Range
Dim ws
Set ws = Worksheets("E22B")
Set r = ws.Range("B99:B110", ws.Cells(Rows.Count, "B").End(xlUp))
For Each c In r
If Date > c Then
Set u = c.Rows(c.Row)
If ur Is Nothing Then
Set ur = c
Else: Set ur = Union(ur, c)
End If
End If
Next c
If Not ur Is Nothing Then ur.EntireRow.Delete xlUp
End Sub