G
Guest
I have a macro that works in Outlook 2003; however, it no longer works in
2007. A .cvs file is attached to an email and the macro is to put the
information from this file into the Outlook Calendar. It should delete
previous calendar entries within the same date range and replace with what is
in the new file. Could someone please help me convert my macro for 2007?
Below is my current code:
Sub ImportSchedule()
Const ForReading = 1, ForWriting = 2, ForAppending = 3
Dim myOlApp
Dim myItem
Dim myAttachments
Dim strBodyText
Dim CRLF
Dim CRTEST
Dim intTxtStartDate, intTxtEndDate, intExchVariable
Dim strExchangeVariable
Dim strExchNewVariable
Dim strLine
Dim intStart
Dim intBreak
Dim strMsg
Dim intAdded
Dim intFirstDate
Dim strResult
Dim sFoldername As String
Dim objPage
Dim fs As Object
Dim s, n
Dim AttachName As String
Dim objAppt
Dim myNameSpace
Dim arrParams
Dim myOlApplic
Dim myAppointments
Dim currentAppointment
Dim onMapi As NameSpace
Dim ofFolder As MAPIFolder
Dim Message, Title, Default, MyValue, Style
Dim Message2, Title2, Default2, MyValue2
Dim strStart, strEnd, nCount
Dim strCalStart, strCalEnd, strTextStart, strTextEnd
'------------Check Attachment to see if it's schedule.txt---------
Set myOlApp = CreateObject("Outlook.Application")
Set myItem = myOlApp.ActiveInspector.CurrentItem
Set myAttachments = myItem.Attachments
On Error Resume Next
AttachName = myAttachments.Item(1).DisplayName
If AttachName = "Schedule.txt" Then
myAttachments.Item(1).SaveAsFile "C:\" & _
myAttachments.Item(1).DisplayName
intFirstDate = 1
'^^^^^^^^^^^^Check Attachment to see if it's schedule.txt^^^^^^^^^
'---------------DELETE--------------------------------------------
'Set myOlApplic = CreateObject("Outlook.Application")
'Set myNameSpace = myOlApplic.GetNamespace("MAPI")
'Set myAppointments = myNameSpace.GetDefaultFolder _
' (olFolderCalendar).Items
'Set currentAppointment = myAppointments.Find("[Categories] = ""Staff Trak""")
'While TypeName(currentAppointment) <> "Nothing"
' currentAppointment.Delete
' Set currentAppointment = myAppointments.FindNext
'Wend
'^^^^^^^^^^^^^^^^^^DELETE^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
'----------Open schedule.txt file and read it storing values in
strLine------------
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile("C:\Schedule.txt")
Set strBodyText = f.OpenAsTextStream(ForReading, TristateFalse)
s = strBodyText.ReadAll
nCount = strBodyText.Count
Set onMapi = GetNamespace("MAPI")
If MsgBox("Will you currently be importing offline?", 3) = vbYes Then
If MsgBox("Will you be importing to a subfolder of the root
Calendar?", 3) = vbYes Then
Title = "Import Schedule (Working Offline)"
Message = "Please supply me with the name of your Root
Calendar Folder:"
Default = "Calendar"
MyValue = InputBox(Message, Title, Default)
Message2 = "Please supply me with the name of the Calander
you wish to import to:"
Title2 = "Import Schedule (Working Offline)"
Default2 = "Calendar"
MyValue2 = InputBox(Message2, Title2, Default2)
Set ofFolder = onMapi.Folders("Personal
Folders").Folders(MyValue).Folders(MyValue2)
Else
Message2 = "Please supply me with the name of the Calander
you wish to import to:"
Title2 = "Import Schedule (Working Offline)"
Default2 = "Calendar"
MyValue2 = InputBox(Message2, Title2, Default2)
Set ofFolder = onMapi.Folders("Personal
Folders").Folders(MyValue2)
End If
Else
Set ofFolder = onMapi.PickFolder
End If
If ofFolder Is Nothing Then
MsgBox "No Folder Selected, User Cancelled"
Else
MsgBox "Folder - " & ofFolder.Name & " was selected by the user"
Set myAppointments = ofFolder.Items
'/////////Need to get the start and end date of the report
strMsg = ""
intAdded = 0
strStart = ""
CRLF = ":::*" '--------------------->Carrige Return Line Feed
CRTEST = ","
'Get the first line of the paramaters
intStart = 1
intBreak = InStr(intStart, s, CRLF)
intTxtStartDate = ""
intTxtEndDate = ""
intExchVariable = ""
strStart = ""
strEnd = ""
strExchangeVariable = ""
If intBreak <> 0 Then
Do Until intBreak = 0
strLine = Mid(s, intStart, intBreak - intStart)
If strLine <> "" Then
If intStart = 1 Then
intTxtStartDate = InStr(1, strLine,
CRTEST) '1ST COMMA start of the report
intTxtEndDate = InStr(intTxtStartDate +
1, strLine, CRTEST) '2ND COMMA end of report start time
intExchVariable = InStr(intTxtEndDate +
1, strLine, CRTEST) '3RD COMMA end of report start time
intExchVariableEnd =
InStr(intExchVariable + 1, strLine, CRTEST) 'end of report
strStart = Mid(strLine, intTxtStartDate
+ 1, intTxtEndDate - (intTxtStartDate + 1)) + " 00:00:00 AM"
strEnd = Mid(strLine, intTxtEndDate + 1,
intExchVariable - (intTxtEndDate + 1)) + " 23:59:00 PM"
strExchangeVariable = Mid(strLine,
intExchVariable + 1, intBreak - (intTest + 4))
End If
Else
'exit at first blank line
Exit Do
End If
intStart = intBreak + 4
intBreak = InStr(intStart, s, CRLF)
Loop
End If
'////////////////
strExchNewVariable = "[Categories] = """ + strExchangeVariable +
""""
Set currentAppointment = myAppointments.Find(strExchNewVariable)
While TypeName(currentAppointment) <> "Nothing"
strCalStart = FormatDateTime(currentAppointment.Start,
vbGeneralDate)
strCalEnd = FormatDateTime(currentAppointment.Start,
vbGeneralDate)
strTextStart = FormatDateTime(strStart, vbGeneralDate)
strTextEnd = FormatDateTime(strEnd, vbGeneralDate)
If ((DateValue(strCalStart) >= DateValue(strTextStart)) And
(DateValue(strCalEnd) <= DateValue(strTextEnd))) Then
currentAppointment.Delete
End If
Set currentAppointment = myAppointments.FindNext
Wend
End If
CRLF = ":::*" '--------------------->Carrige Return Line Feed
strMsg = ""
intAdded = 0
'Get the first line of the paramaters
intStart = 1
intBreak = InStr(intStart, s, CRLF)
If intBreak <> 0 Then
Do Until intBreak = 0
strLine = Mid(s, intStart, intBreak - intStart)
strNoLine = InStr(1, strLine, "Nothing")
If strLine <> "" Then
'Do not want to bring in the 1st line, it now has the
start and enddate of report
If strNoLine = 0 Then
strResult = AddAppt(strLine, ofFolder)
'Sends values to AddAppt Function
strMsg = strMsg & CRLF & strResult
intAdded = intAdded + 1
End If
Else
'exit at first blank line
Exit Do
End If
intStart = intBreak + 4
intBreak = InStr(intStart, s, CRLF)
Loop
End If
'----------Open schedule.txt file and read it storing values in
strLine------------
'Else
' Exit Sub
End If
f.Delete 'Deletes saved file from C:\
myItem.Close (olDiscard) 'Closes the Inspector window
End Sub
Function AddAppt(strParams, ofFolder)
Dim objAppt As AppointmentItem
Dim arrParams
Dim varStart
Dim strMsg
Dim StartDate, EndDate
Dim check
On Error Resume Next
Set objAppt = ofFolder.Items.Add(olAppointmentItem)
'Set objAppt = Application.CreateItem(olAppointmentItem)
'This function will only work in VBScript 2.0 and later
arrParams = Split(strParams, ",") 'Reads the commas out of the file.
objAppt.Subject = arrParams(0)
'Determine whether an all day event or not
objAppt.AllDayEvent = arrParams(5)
If objAppt.AllDayEvent = True Then
'treats all-day events as single day
varStart = CDate(arrParams(1) & " 12:00 AM")
objAppt.Start = varStart
Else
objAppt.Start = arrParams(1) & " " & arrParams(2)
objAppt.End = arrParams(3) & " " & arrParams(4)
End If
objAppt.ReminderSet = arrParams(6)
If objAppt.ReminderSet = True Then
objAppt.ReminderMinutesBeforeStart = _
DateDiff("m", arrParams(7) & " " & arrParams(8), objAppt.Start)
End If
objAppt.Categories = arrParams(9)
objAppt.Body = arrParams(10)
objAppt.Location = arrParams(11)
objAppt.Save
objAppt.Close (g_Const_olSave)
End Function
2007. A .cvs file is attached to an email and the macro is to put the
information from this file into the Outlook Calendar. It should delete
previous calendar entries within the same date range and replace with what is
in the new file. Could someone please help me convert my macro for 2007?
Below is my current code:
Sub ImportSchedule()
Const ForReading = 1, ForWriting = 2, ForAppending = 3
Dim myOlApp
Dim myItem
Dim myAttachments
Dim strBodyText
Dim CRLF
Dim CRTEST
Dim intTxtStartDate, intTxtEndDate, intExchVariable
Dim strExchangeVariable
Dim strExchNewVariable
Dim strLine
Dim intStart
Dim intBreak
Dim strMsg
Dim intAdded
Dim intFirstDate
Dim strResult
Dim sFoldername As String
Dim objPage
Dim fs As Object
Dim s, n
Dim AttachName As String
Dim objAppt
Dim myNameSpace
Dim arrParams
Dim myOlApplic
Dim myAppointments
Dim currentAppointment
Dim onMapi As NameSpace
Dim ofFolder As MAPIFolder
Dim Message, Title, Default, MyValue, Style
Dim Message2, Title2, Default2, MyValue2
Dim strStart, strEnd, nCount
Dim strCalStart, strCalEnd, strTextStart, strTextEnd
'------------Check Attachment to see if it's schedule.txt---------
Set myOlApp = CreateObject("Outlook.Application")
Set myItem = myOlApp.ActiveInspector.CurrentItem
Set myAttachments = myItem.Attachments
On Error Resume Next
AttachName = myAttachments.Item(1).DisplayName
If AttachName = "Schedule.txt" Then
myAttachments.Item(1).SaveAsFile "C:\" & _
myAttachments.Item(1).DisplayName
intFirstDate = 1
'^^^^^^^^^^^^Check Attachment to see if it's schedule.txt^^^^^^^^^
'---------------DELETE--------------------------------------------
'Set myOlApplic = CreateObject("Outlook.Application")
'Set myNameSpace = myOlApplic.GetNamespace("MAPI")
'Set myAppointments = myNameSpace.GetDefaultFolder _
' (olFolderCalendar).Items
'Set currentAppointment = myAppointments.Find("[Categories] = ""Staff Trak""")
'While TypeName(currentAppointment) <> "Nothing"
' currentAppointment.Delete
' Set currentAppointment = myAppointments.FindNext
'Wend
'^^^^^^^^^^^^^^^^^^DELETE^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
'----------Open schedule.txt file and read it storing values in
strLine------------
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile("C:\Schedule.txt")
Set strBodyText = f.OpenAsTextStream(ForReading, TristateFalse)
s = strBodyText.ReadAll
nCount = strBodyText.Count
Set onMapi = GetNamespace("MAPI")
If MsgBox("Will you currently be importing offline?", 3) = vbYes Then
If MsgBox("Will you be importing to a subfolder of the root
Calendar?", 3) = vbYes Then
Title = "Import Schedule (Working Offline)"
Message = "Please supply me with the name of your Root
Calendar Folder:"
Default = "Calendar"
MyValue = InputBox(Message, Title, Default)
Message2 = "Please supply me with the name of the Calander
you wish to import to:"
Title2 = "Import Schedule (Working Offline)"
Default2 = "Calendar"
MyValue2 = InputBox(Message2, Title2, Default2)
Set ofFolder = onMapi.Folders("Personal
Folders").Folders(MyValue).Folders(MyValue2)
Else
Message2 = "Please supply me with the name of the Calander
you wish to import to:"
Title2 = "Import Schedule (Working Offline)"
Default2 = "Calendar"
MyValue2 = InputBox(Message2, Title2, Default2)
Set ofFolder = onMapi.Folders("Personal
Folders").Folders(MyValue2)
End If
Else
Set ofFolder = onMapi.PickFolder
End If
If ofFolder Is Nothing Then
MsgBox "No Folder Selected, User Cancelled"
Else
MsgBox "Folder - " & ofFolder.Name & " was selected by the user"
Set myAppointments = ofFolder.Items
'/////////Need to get the start and end date of the report
strMsg = ""
intAdded = 0
strStart = ""
CRLF = ":::*" '--------------------->Carrige Return Line Feed
CRTEST = ","
'Get the first line of the paramaters
intStart = 1
intBreak = InStr(intStart, s, CRLF)
intTxtStartDate = ""
intTxtEndDate = ""
intExchVariable = ""
strStart = ""
strEnd = ""
strExchangeVariable = ""
If intBreak <> 0 Then
Do Until intBreak = 0
strLine = Mid(s, intStart, intBreak - intStart)
If strLine <> "" Then
If intStart = 1 Then
intTxtStartDate = InStr(1, strLine,
CRTEST) '1ST COMMA start of the report
intTxtEndDate = InStr(intTxtStartDate +
1, strLine, CRTEST) '2ND COMMA end of report start time
intExchVariable = InStr(intTxtEndDate +
1, strLine, CRTEST) '3RD COMMA end of report start time
intExchVariableEnd =
InStr(intExchVariable + 1, strLine, CRTEST) 'end of report
strStart = Mid(strLine, intTxtStartDate
+ 1, intTxtEndDate - (intTxtStartDate + 1)) + " 00:00:00 AM"
strEnd = Mid(strLine, intTxtEndDate + 1,
intExchVariable - (intTxtEndDate + 1)) + " 23:59:00 PM"
strExchangeVariable = Mid(strLine,
intExchVariable + 1, intBreak - (intTest + 4))
End If
Else
'exit at first blank line
Exit Do
End If
intStart = intBreak + 4
intBreak = InStr(intStart, s, CRLF)
Loop
End If
'////////////////
strExchNewVariable = "[Categories] = """ + strExchangeVariable +
""""
Set currentAppointment = myAppointments.Find(strExchNewVariable)
While TypeName(currentAppointment) <> "Nothing"
strCalStart = FormatDateTime(currentAppointment.Start,
vbGeneralDate)
strCalEnd = FormatDateTime(currentAppointment.Start,
vbGeneralDate)
strTextStart = FormatDateTime(strStart, vbGeneralDate)
strTextEnd = FormatDateTime(strEnd, vbGeneralDate)
If ((DateValue(strCalStart) >= DateValue(strTextStart)) And
(DateValue(strCalEnd) <= DateValue(strTextEnd))) Then
currentAppointment.Delete
End If
Set currentAppointment = myAppointments.FindNext
Wend
End If
CRLF = ":::*" '--------------------->Carrige Return Line Feed
strMsg = ""
intAdded = 0
'Get the first line of the paramaters
intStart = 1
intBreak = InStr(intStart, s, CRLF)
If intBreak <> 0 Then
Do Until intBreak = 0
strLine = Mid(s, intStart, intBreak - intStart)
strNoLine = InStr(1, strLine, "Nothing")
If strLine <> "" Then
'Do not want to bring in the 1st line, it now has the
start and enddate of report
If strNoLine = 0 Then
strResult = AddAppt(strLine, ofFolder)
'Sends values to AddAppt Function
strMsg = strMsg & CRLF & strResult
intAdded = intAdded + 1
End If
Else
'exit at first blank line
Exit Do
End If
intStart = intBreak + 4
intBreak = InStr(intStart, s, CRLF)
Loop
End If
'----------Open schedule.txt file and read it storing values in
strLine------------
'Else
' Exit Sub
End If
f.Delete 'Deletes saved file from C:\
myItem.Close (olDiscard) 'Closes the Inspector window
End Sub
Function AddAppt(strParams, ofFolder)
Dim objAppt As AppointmentItem
Dim arrParams
Dim varStart
Dim strMsg
Dim StartDate, EndDate
Dim check
On Error Resume Next
Set objAppt = ofFolder.Items.Add(olAppointmentItem)
'Set objAppt = Application.CreateItem(olAppointmentItem)
'This function will only work in VBScript 2.0 and later
arrParams = Split(strParams, ",") 'Reads the commas out of the file.
objAppt.Subject = arrParams(0)
'Determine whether an all day event or not
objAppt.AllDayEvent = arrParams(5)
If objAppt.AllDayEvent = True Then
'treats all-day events as single day
varStart = CDate(arrParams(1) & " 12:00 AM")
objAppt.Start = varStart
Else
objAppt.Start = arrParams(1) & " " & arrParams(2)
objAppt.End = arrParams(3) & " " & arrParams(4)
End If
objAppt.ReminderSet = arrParams(6)
If objAppt.ReminderSet = True Then
objAppt.ReminderMinutesBeforeStart = _
DateDiff("m", arrParams(7) & " " & arrParams(8), objAppt.Start)
End If
objAppt.Categories = arrParams(9)
objAppt.Body = arrParams(10)
objAppt.Location = arrParams(11)
objAppt.Save
objAppt.Close (g_Const_olSave)
End Function