I am needing assistance in implementing a code into my existing code to not add already scheduled appointments to the calendar. Basically I will be running this everyday, and everyday a new entry is added to the excel document. However, the code I have now will add appointments that were already added the previous days. I am looking for a way to not duplicate appointments.
ALSO! I am needing to find a way to make this code add the appointments to a SHARED calendar. Right now it only adds to my personal one. Any and all help is so very much appreciated.
Code:
Sub Appointments()
Dim OL As Outlook.Application, Appoint As Outlook.AppointmentItem, ES As Worksheet, _
r As Long, i As Long, WB As ThisWorkbook
Set WB = ThisWorkbook
Set ES = WB.Sheets("Sheet1")
r = ES.Cells(Rows.Count, 1).End(xlUp).Row
Set OL = New Outlook.Application
For i = 2 To r
If ES.Cells(i, 15) = "Bulk" Then
Set Appoint = OL.CreateItem(olAppointmentItem)
With Appoint
.Subject = ES.Cells(i, 13).Value
.Start = ES.Cells(i, 4).Value
.Duration = 60
.AllDayEvent = False
.Categories = ES.Cells(i, 16).Value & " Category"
.Body = ES.Cells(i, 12).Value
.Save
End With
End If
Next i
Set OL = Nothing
End Sub
I have not had a starting place on my request, so all help is appreciated.
Related
I'm really having trouble finding any answers for this problem. I have an Excel macro that filters a sheet (it's a basic order form), copies and emails a range using an Outlook object. The file worked for several weeks and ran quickly.
Now all of the sudden whenever the macro is run the Excel portion of filtering and copying works fine but when it gets to the email code Outlook locks up, and I get a popup from Excel saying it's waiting for Outlook to complete an OLE action. I end up having to kill the Outlook process. I've tried early and late bindings.
Sub EmailOrder()
Dim answer As Integer
Dim lastRow As String
Dim filteredRow
Dim emailApp As Outlook.Application
Dim emailItem As Outlook.MailItem
Dim exportRange As Range
Dim currentTime As String
Dim currentUserEmailAddress As String
answer = MsgBox("Click OK to send your order to the supply team", vbOKCancel)
If answer = vbOK Then
Worksheets("Sheet1").Activate
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
currentTable = "$A$1:$E$" & lastRow
'Filter out blanks
Range(currentTable).AutoFilter Field:=5, Criteria1:="<>"
Set exportRange = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set exportRange = Selection.SpecialCells(xlCellTypeVisible)
'Setup outlook objects and mail
Set emailApp = New Outlook.Application
Set emailItem = emailApp.CreateItem(olMailItem)
Set outSession = emailItem.Session.CurrentUser
currentUserEmailAddress = outSession.AddressEntry.GetExchangeUser().PrimarySmtpAddress
currentTime = Now
'Write email
With emailItem
.To = "redacted#gmail.com"
.CC = currentUserEmailAddress
.Subject = "Local Inventory Order " & currentTime
.HTMLBody = RangetoHTML(exportRange)
.Send
End With
'Close objects
Set emailApp = Nothing
Set emailItem = Nothing
MsgBox ("The order has been emailed to the supply team.")
End If
End Sub
The RangetoHTML function is from Ron de Bruin's website. Any help is appreciated.
EDIT: failed to mention that there have been other users of the sheet who reported it working for several weeks then stopping.
I have some code working to import data from Excel when a cell contains the word "Yes". I would like to include code to ignore any entries that have previously been imported when I run the code again.
Sub Permits()
Dim OL As Outlook.Application, Appoint As Outlook.AppointmentItem, ES As Worksheet, _
r As Long, i As Long, WB As ThisWorkbook
Set WB = ThisWorkbook
Set ES = WB.Sheets("Permits")
r = ES.Cells(Rows.Count, 1).End(xlUp).Row
Set OL = New Outlook.Application
For i = 2 To r
If ES.Cells(i, 10) = "Yes" Then
Set Appoint = OL.CreateItem(olAppointmentItem)
With Appoint
.Subject = ES.Cells(i, 3).Value
.Start = ES.Cells(i, 7) + ES.Cells(i, 8).Value
.ReminderSet = True
.ReminderMinutesBeforeStart = 60
.Body = "£" & ES.Cells(i, 6).Value
.Save
End With
End If
Next i
Set OL = Nothing
End Sub
You can mark processed rows with a green colour for example:
(edited as req, it looks for "Yes" in cell 11)
Option Explicit
Option Compare Text 'ignore case sensitivity when comparing strings
Sub Permits()
Dim OL As Outlook.Application, ES As Worksheet, _
r As Long, i As Long, WB As ThisWorkbook
Set WB = ThisWorkbook
Set ES = WB.Sheets("Permits")
Set OL = New Outlook.Application
r = ES.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To r
With ES.Cells(i, 10)
If .Value = "Yes" And .Offset(0, 1).Value <> "Yes" Then
.Offset(0, 1).Value = "Yes"
With OL.CreateItem(olAppointmentItem)
.Subject = ES.Cells(i, 3).Value
.Start = ES.Cells(i, 7) + ES.Cells(i, 8).Value
.ReminderSet = True
.ReminderMinutesBeforeStart = 60
.Body = "£" & ES.Cells(i, 6).Value
.Save
End With
End If
End With
Next i
Set OL = Nothing
Set WB = Nothing
Set ES = Nothing
End Sub
You could also create a separate column to mark them etc, edit as needed. Alternatively, you can keep the spreadsheet 'clean' and search for existing reminders with the same data.
I need your help to create a macro in Outlook 2010 which will store the From,To,Date,Subject,Flag in an excel after sending any mail form an account or receiving any mail in the inbox of that account.
In that process i tried to create the log first in excel after sending mail with some default value by using below code. But it is giving error "Compile Error, Sub or Function not defined" at line:
Windows("Access_Log.xlsx").Activate
The code goes as below:
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Workbooks.Open FileName:="\\Bmcstr01\grp\SRV\Allsrv\NEW Complaints Logger\GI Complaints\Spreadsheets\Archieve\Access_Log.xlsx"
Windows("Access_Log.xlsx").Activate
'Sheets("log").Activate
If Range("A1").Value = "" Then
n = 1
Else
n = Cells(Rows.Count, "A").End(xlUp).Row + 1
End If
Cells(n, "A").Value = Environ("username")
Cells(n, "b").Value = Date
Cells(n, "c").Value = Time
Cells(n, "d").Value = "Outlook"
Cells(n, "E").Value = "sent mail"
ActiveWorkbook.Save
ActiveWorkbook.Close
End Sub
It is written in ThisOutlookSession --> Application --> SendItem.
Any help to this code and the original requirement will be appreciated.
Thanks,
Maitreya
To access an Excel file from Outlook-VBA you first need create an Excel application:
Dim xlApp As Object
Set xlApp = CreateObject("Excel.Application")
if you don't want the Excel to show use
xlApp.Visible = False
to hide it. And then you can open an Excel file in that application:
Dim xlWb As Object
Set xlWb = xlApp.Workbooks.Open(FileName:="\\Bmcstr01\grp\SRV\Allsrv\NEW Complaints Logger\GI Complaints\Spreadsheets\Archieve\Access_Log.xlsx")
and then you can access a worksheet in that file:
Dim xlWs As Object
Set xlWs = xlWb.Worksheets("Sheet1") 'put your sheet name here
and then comes your code accessing this worksheet like
Const xlUp = -4162 'see explanation below
Dim n As Long
With xlWs
If .Range("A1").Value = "" Then
n = 1
Else
n = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End If
.Cells(n, "A").Value = Environ("username")
.Cells(n, "B").Value = Date
.Cells(n, "C").Value = Time
.Cells(n, "D").Value = "Outlook"
.Cells(n, "E").Value = "sent mail"
End With
xlWb.Close SaveChanges:=True 'close and save workbook
Edit//
Note that xlUp does not exist in Outlook. Therefore you need to use -4162 or define a constant for it Const xlUp = -4162 before you can use it.
I am trying to use the code below to update my Outlook calendar from an Excel sheet.
The code functions fine, but I need to save to a sub calendar rather than my default one.
I've tried a few work around's I found online,but none of them seem to work. For example Slapstick and also at the bottom of this page Ozgrid
Any help would be much appreciated.
Option Explicit
Sub AddToOutlook()
Dim OL As Outlook.Application
Dim olAppt As Outlook.AppointmentItem
Dim NS As Outlook.Namespace
Dim colItems As Outlook.Items
Dim olApptSearch As Outlook.AppointmentItem
Dim r As Long, sBody As String, sSubject As String, sLocation As String
Dim dStartTime As Date, dEndTime As Date, dReminder As String, dCatagory As Double
Dim sSearch As String, bOLOpen As Boolean
On Error Resume Next
Set OL = GetObject(, "Outlook.Application")
bOLOpen = True
If OL Is Nothing Then
Set OL = CreateObject("Outlook.Application")
bOLOpen = False
End If
Set NS = OL.GetNamespace("MAPI")
Set colItems = NS.GetDefaultFolder(olFolderCalendar).Items
For r = 2 To 394
If Len(Sheet1.Cells(r, 1).Value + Sheet1.Cells(r, 5).Value) = 0 Then
GoTo NextRow
sBody = Sheet1.Cells(r, 7).Value
sSubject = Sheet1.Cells(r, 3).Value
dStartTime = Sheet1.Cells(r, 1).Value + Sheet1.Cells(r, 2).Value
dEndTime = Sheet1.Cells(r, 1).Value + Sheet1.Cells(r, 5).Value
sLocation = Sheet1.Cells(r, 6).Value
dReminder = Sheet1.Cells(r, 4).Value
sSearch = "[Subject] = " & sQuote(sSubject)
Set olApptSearch = colItems.Find(sSearch)
If olApptSearch Is Nothing Then
Set olAppt = OL.CreateItem(olAppointmentItem)
olAppt.Body = sBody
olAppt.Subject = sSubject
olAppt.Start = dStartTime
olAppt.End = dEndTime
olAppt.Location = sLocation
olAppt.Catagory = dCatagory
olAppt.Close olSave
End If
NextRow:
Next r
If bOLOpen = False Then OL.Quit
End Sub
Function sQuote(sTextToQuote)
sQuote = Chr(34) & sTextToQuote & Chr(34)
End Function
To get access to a subfolder in your default calendar folder you can use:
Set colItems = NS.GetDefaultFolder(olFolderCalendar).Folders("TypeNameOfCalendarHere").Items
If it is on the same level as teh default folder you can use:
Set colItems = NS.GetDefaultFolder(olFolderCalendar).Parent.Folders("SharedCal").Items
Good resource here and here.
As described in the Ozgrid link, move the appointment created in the default calendar to the sub calendar.
You can reference a calendar with the entry ID.
Set oFolder = oNameSpace.GetFolderFromID("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx")
You can reference a sub Calendar of the default folder:
Set oFolder = NS.GetDefaultFolder(olFolderCalendar).folders("Name of sub calendar")
Once created in the default calendar move it to the non-default calendar
Set olApt = oApp.CreateItem(olAppointmentItem)
With olApt
' ..
.Save
.Move oFolder
End With
You may add to a non-default calendar.
Set subCalendar = NS.GetDefaultFolder(olFolderCalendar).folders("Name of sub calendar")
Set olAppt = subCalendar.items.Add
With olAppt
'...
.Save
End With
Each employee gets an updated contact list. I'm creating a macro in Excel that will delete all outlook contacts, then import all the contacts on that sheet into their main outlook contacts. Not all users are on the same outlook version, so I can't use Early Binding methods since the Outlook OBJ Library cannot be referenced between versions.
I managed to get my delete loop into late binding easily, but I'm having trouble getting the import code to work in late binding. Here is the working early binding method I currently have for the import:
Dim olApp As Outlook.Application
Dim olNamespace As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim olConItems As Outlook.Items
Dim olItem As Object
'Excel objects.
Dim wbBook As Workbook
Dim wsSheet As Worksheet
'Location in the imported contact list.
Dim lnContactCount As Long
Dim strDummy As String
'Turn off screen updating.
Application.ScreenUpdating = False
'Initialize the Excel objects.
Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets(1)
'Format the target worksheet.
With wsSheet
.Range("A1").CurrentRegion.Clear
.Cells(1, 1).Value = "Company / Private Person"
.Cells(1, 2).Value = "Street Address"
.Cells(1, 3).Value = "Postal Code"
.Cells(1, 4).Value = "City"
.Cells(1, 5).Value = "Contact Person"
.Cells(1, 6).Value = "E-mail"
With .Range("A1:F1")
.Font.Bold = True
.Font.ColorIndex = 10
.Font.Size = 11
End With
End With
wsSheet.Activate
'Initalize the Outlook variables with the MAPI namespace and the default Outlook folder of the current user.
Set olApp = New Outlook.Application
Set olNamespace = olApp.GetNamespace("MAPI")
Set olFolder = olNamespace.GetDefaultFolder(10)
Set olConItems = olFolder.Items
'Row number to place the new information on; starts at 2 to avoid overwriting the header
lnContactCount = 2
'For each contact: if it is a business contact, write out the business info in the Excel worksheet;
'otherwise, write out the personal info.
For Each olItem In olConItems
If TypeName(olItem) = "ContactItem" Then
With olItem
If InStr(olItem.CompanyName, strDummy) > 0 Then
Cells(lnContactCount, 1).Value = .CompanyName
Cells(lnContactCount, 2).Value = .BusinessAddressStreet
Cells(lnContactCount, 3).Value = .BusinessAddressPostalCode
Cells(lnContactCount, 4).Value = .BusinessAddressCity
Cells(lnContactCount, 5).Value = .FullName
Cells(lnContactCount, 6).Value = .Email1Address
Else
Cells(lnContactCount, 1) = .FullName
Cells(lnContactCount, 2) = .HomeAddressStreet
Cells(lnContactCount, 3) = .HomeAddressPostalCode
Cells(lnContactCount, 4) = .HomeAddressCity
Cells(lnContactCount, 5) = .FullName
Cells(lnContactCount, 6) = .Email1Address
End If
wsSheet.Hyperlinks.Add Anchor:=Cells(lnContactCount, 6), _
Address:="mailto:" & Cells(lnContactCount, 6).Value, _
TextToDisplay:=Cells(lnContactCount, 6).Value
End With
lnContactCount = lnContactCount + 1
End If
Next olItem
'Null out the variables.
Set olItem = Nothing
Set olConItems = Nothing
Set olFolder = Nothing
Set olNamespace = Nothing
Set olApp = Nothing
'Sort the rows alphabetically using the CompanyName or FullName as appropriate, and then autofit.
With wsSheet
.Range("A2", Cells(2, 6).End(xlDown)).Sort key1:=Range("A2"), order1:=xlAscending
.Range("A:F").EntireColumn.AutoFit
End With
'Turn screen updating back on.
Application.ScreenUpdating = True
MsgBox "The list has successfully been created!", vbInformation
End Sub
To use Late binding, you should declare all your Outlook-specific objects as Object:
Dim olApp As Object, olNamespace As Object, olFolder As Object, olConItems As Object
Then:
Set olApp = CreateObject("Outlook.Application")
This will make each computer create the olApp object from the Outlook library that is installed on it. It avoids you to set an explicit reference to Outlook14 in the workbook that you will distribute (remove that reference from the project before distributing the Excel file).
Hope this helps :)
All of your Outlook object declarations would first have to become non-Oulook related object declarations.
Dim olApp As Object
Dim olNamespace As Object
Dim olFolder As Object
Dim olConItems As Object
Dim olItem As Object
You will need a CreateObject function on the Outlook.Application object.
Set olApp = CreateObject("Outlook.Application")
Everything else should fall into place.