MarAllenMike
Member
- Outlook version
- Outlook 365 64 bit
- Email Account
- Office 365 Exchange
I posted this at excel forums as well, but I was hoping someone could help me understand sorting outlook appointments. Outlook sorts them like this but when I use the macro, it sorts them like this. Notice it only does it when the subject has PennDOT in it.
This is my macro.
This is my macro.
Code:
Sub LogThisWeeksAppointments()
Dim myStart As Date
Dim myEnd As Date
Dim oCalendar As Outlook.folder
Dim oItems As Outlook.Items
Dim oItemsInDateRange As Outlook.Items
Dim oFinalItems As Outlook.Items
Dim oAppt As Outlook.AppointmentItem
Dim strRestriction As String
myStart = Now
myEnd = DateAdd("D", 7, myStart)
'***Construct filter for the date range
strRestriction = "[Start] >= '" & _
Format$(myStart, "mm/dd/yyyy hh:mm AMPM") _
& "' AND [End] <= '" & _
Format$(myEnd, "mm/dd/yyyy hh:mm AMPM") & "'"
Set oCalendar = Application.Session.GetDefaultFolder(olFolderCalendar)
Set oItems = oCalendar.Items
oItems.IncludeRecurrences = True
'***Restrict the Items collection for the date range
Set oItemsInDateRange = oItems.Restrict(strRestriction)
Set oFinalItems = oItemsInDateRange.Restrict(strRestriction)
Dim objMsg As MailItem
Set objMsg = Application.CreateItem(olMailItem)
Dim Signature As String
Signature = objMsg.htmlBody
Dim htmlBody As String
Dim i As Integer
Dim AptStart As String, AptLocation As String, AptSubject As String
Dim Weekof As String
Weekof = Format(myStart, "MM/dd/YYYY")
'***Starts the HTML formatting for the body of the email with the Headers************
htmlBody = "<html><body><h2>This Weeks Bid Projects</h2><table style=""width:55%""><tr><th>Bid Date</th><th>County</th><th>Project Description</th></tr>"
'***Starts Excel and opens "empty" book for log*********************
Dim xlApp As Object
Set xlApp = CreateObject("excel.application")
With xlApp
.Visible = True
.EnableEvents = False
.DisplayAlerts = False
End With
Dim wbBID As Object
Set wbBID = xlApp.Workbooks.Open("U:\Excel\EmptyBook.xlsm")
xlApp.Application.Wait (Now + TimeValue("0:00:02"))
Dim wsLog As Worksheet
Set wsLog = wbBID.Sheets("Sheet1")
With wsLog.Range("A1:J1")
.Value = Array("BID DATE", "LOCATION", "BID DESCRIPTION", "A", "", "R", "", "J", "", "D")
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
wsLog.Range("E1, G1, I1").EntireColumn.ColumnWidth = 1
wsLog.Range("D1, F1, H1, J1").EntireColumn.ColumnWidth = 4.43
Dim StartPrime As Integer
Dim StartDate As Date
StartDate = myStart
oItemsInDateRange.Sort "[Start]"
i = 2
For Each oAppt In oItemsInDateRange
If DateDiff("D", StartDate, oAppt.Start) > 0 Then
i = i + 1
End If
If InStr(1, oAppt.Subject, "Weekly Projects") > 0 Then GoTo NextAppt
If InStr(1, oAppt.Subject, "Dropped") > 0 Then GoTo NextAppt
wsLog.Cells(i, 1) = oAppt.Start
wsLog.Cells(i, 2) = oAppt.Location
With wsLog.Cells(i, 3)
.Value = oAppt.Subject
StartPrime = InStr(1, oAppt.Subject, "Prime", vbTextCompare)
If StartPrime <> 0 Then
.Characters(Start:=StartPrime, Length:=5).Font.Color = RGB(255, 0, 0)
.Interior.Color = RGB(242, 242, 242)
End If
End With
wsLog.Cells(i, 4).BorderAround ColorIndex:=1, Weight:=xlThin
wsLog.Cells(i, 6).BorderAround ColorIndex:=1, Weight:=xlThin
wsLog.Cells(i, 8).BorderAround ColorIndex:=1, Weight:=xlThin
wsLog.Cells(i, 10).BorderAround ColorIndex:=1, Weight:=xlThin
htmlBody = htmlBody + "<tr><td>" & oAppt.Start & "</td><td>" & oAppt.Location & "</td><td>" & oAppt.Subject & "</td></tr>"
i = i + 1
StartDate = oAppt.Start
NextAppt:
Next
htmlBody = htmlBody + "</table></body></html>"
Weekof = Replace(Weekof, "/", "-")
Dim LogFile As String
LogFile = "M:\this week\" & Weekof & " Bidlist.xlsm"
wsLog.Range("A1:C1").EntireColumn.AutoFit
wsLog.Range("A1:B1").EntireColumn.HorizontalAlignment = xlCenter
wbBID.SaveAs LogFile
wbBID.Close
With objMsg
.Subject = "Projects for the Week of " & Weekof
.htmlBody = htmlBody
.Attachments.Add LogFile
.Display
End With
xlApp.Quit
Set xlApp = Nothing
End Sub
