macro not always working? writing outlook calendar appointment

D

Dozo2000

New Member
Joined
Dec 8, 2016
Messages
24
When Outlook is open: both appointments of MB are created. (=good)
When Outlook is closed: one or no appointments are created. (=not good)

And then, even if Outlook is open, is creates no apoinments anymore. ( MsgBox says it did..)
Macro creates Outlook appoinmentments for MB if date in column U is in the future and checks if appoinmentment has already been created, so I don't get any double appoinments.
It uses word text selection to create a hyperlink to a file that is used in the sheet.
(I import an other sheet, the link of that sheet is written to column K and DK so I can use it again in the appointment)

I think the error is in opening, closing, setting outlook / apointment, but I can't figure it out.
(see code and file )http://www.westerdijk.net/OLAPP.xlsm


I'm hoping for some help! (i have been searching a long time now...)


Code: 
 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

Code: 
 sSearch = "[Subject] = " & sQuote(sSubject)
    Set olApptSearch = colItems.Find(sSearch)
    If olApptSearch Is Nothing Then
          
    ''Set OutApp = GetObject(, "Outlook.Application")
    Set olAppt = Outlook.Application.CreateItem(olAppointmentItem)
    olAppt.Display
    
    Set Selection = olAppt.GetInspector.WordEditor.Windows(1).Selection
 
Sort by date Sort by votes
I open Outlook, don't I? See first example part of my code.

On my laptop it is working fine, but my pc has this problem.
Strange, isn't it?
 
Upvote 0
Hi,

Make sure on your PC to have Tools>References>Microsoft Outlook Object Library

HTH
 
Upvote 0
I have checked that.
On my pc all the same libraries as on laptop, including Microsoft Outlook 16.0 Object Library.
 
Upvote 0
If it works on the laptop, the code concept is correct.
What Windows and Office versions do you have installed on the laptop and PC?
Do you have more than one Office version on the same machine?
 
Upvote 0
Both laptop and pc have Windows 10.
Both have Excel 2016 (office 2016).

At work ( here i want to use it ) on my pc, the same problem as on my home pc...
(also Windows 10 and Excel 2016).

Thanks for helping!
 
Upvote 0
I made a few modifications to the code, please test it:

Code: 
Option Explicit
Sub CalenderAppointment()
Dim olddate, OldWeekDay, newdate, sSearch, olapptsearch, olappt, dEndTime, warning
Dim excelLink As Excel.Hyperlink
Dim OutApp As Object 'Oultook.Application
Dim Appt As Object 'Outlook.AppointmentItem
Dim Selection As Object 'Word.Selection
Dim OL As Object, mystring, svw, bOLOpen, dStartTime, slocation, dReminder, sname, dcatagory
Dim NS As Object, i, r, company, link, pad, colitems, ssubject
mystring = "MB"
svw = "Mark"
i = 0
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
On Error GoTo 0
For r = 5 To 6
    If Len(Blad1.Cells(r, 21).Value) = 0 Then GoTo NextRow
    company = Blad1.Cells(r, 11)
    link = Blad1.Cells(r, 131).Value
    pad = Environ("USERPROFILE")
    link = Application.Substitute(link, "C:\Users\Temp", pad)
    Call Application.ActiveSheet.Hyperlinks.Add(Range("EB" & r), link, ScreenTip:= _
    "Open het bestand met basisgegevens van " & company, TextToDisplay:=company)
    Set excelLink = Excel.Range("EB" & r).Hyperlinks(1)
    Set NS = OL.GetNamespace("MAPI")
    Set colitems = NS.GetDefaultFolder(olFolderCalendar).Items
    ssubject = "[" & Blad1.Cells(r, 1) & "]  " & Blad1.Cells(r, 11) & " [" & Blad1.Cells(r, 22) & "]"
    dStartTime = Blad1.Cells(r, 21).Value + TimeValue("10:00:00")
    slocation = Blad1.Cells(r, 14)
    dReminder = 60
    sname = Blad1.Cells(r, 1)
    dcatagory = "Categorie Geel"
    If dStartTime > Date Then
    If Blad1.Cells(r, 18) <> 0 Then
    If sname = mystring Then
    olddate = dStartTime
    OldWeekDay = Weekday(olddate)
    If OldWeekDay = 1 Then
       newdate = olddate + 1
    ElseIf OldWeekDay = 2 Then
       newdate = olddate
    ElseIf OldWeekDay = 3 Then
       newdate = olddate + 3
    ElseIf OldWeekDay = 4 Then
      newdate = olddate + 2
    ElseIf OldWeekDay = 5 Then
      newdate = olddate + 1
    ElseIf OldWeekDay = 6 Then
      newdate = olddate
    ElseIf OldWeekDay = 7 Then
      newdate = olddate + 2
    End If
    sSearch = "[Subject] = " & sQuote(ssubject)
    Set olapptsearch = colitems.Find(sSearch)
    If olapptsearch Is Nothing Then
        Set olappt = Outlook.Application.CreateItem(olAppointmentItem)
        olappt.Display
        Set Selection = olappt.GetInspector.WordEditor.Windows(1).Selection
        dEndTime = newdate + TimeValue("11:00:00")
        Selection.TypeText ("Bellen met: " & Blad1.Cells(r, 15) & " over offerte (" & Blad1.Cells(r, 3) & ").")
        Selection.TypeText (vbNewLine & vbNewLine)
        Selection.TypeText ("Betreffende: " & Blad1.Cells(r, 23).Value & ".")
        Selection.TypeText (vbNewLine & vbNewLine)
        Selection.TypeText (Blad1.Cells(r, 11).Value & " - " & Blad1.Cells(r, 22).Value)
        Selection.TypeText (vbNewLine & vbNewLine)
        Selection.TypeText (vbNewLine & Blad1.Cells(r, 11).Value)
        Selection.TypeText (vbNewLine & Blad1.Cells(r, 12).Value)
        Selection.TypeText (vbNewLine & Blad1.Cells(r, 13).Value & " " & Blad1.Cells(r, 14))
        Selection.TypeText (vbNewLine & vbNewLine)
        Selection.TypeText (vbNewLine & Blad1.Cells(r, 15).Value)
        Selection.TypeText (vbNewLine & Blad1.Cells(r, 16).Value)
        Selection.TypeText (vbNewLine & vbNewLine & vbNewLine)
        Selection.TypeText ("Klik hier voor datasheet van: " & company & vbNewLine)
        Selection.Hyperlinks.Add Selection.Range, excelLink.Address, ScreenTip:= _
        "Open het bestand met basisgegevens van " & company, TextToDisplay:=excelLink.TextToDisplay
        olappt.Subject = ssubject
        olappt.Start = newdate
        olappt.End = dEndTime
        olappt.ReminderMinutesBeforeStart = dReminder
        olappt.Location = slocation
        olappt.Categories = dcatagory
        olappt.Close olSave
        i = i + 1
    End If
    End If
    End If
    End If
NextRow:
Next r
If bOLOpen = False Then OL.Quit
If olapptsearch Is Nothing Then warning = MsgBox("Reminders for " + svw + " created in Outlook calendar...", _
vbOKOnly + vbInformation, "AFSPRAKEN TOEGEVOEGD")
If i = 0 Then warning = MsgBox("No appointments added to Outlook Calendar!", _
vbOKOnly + vbCritical, "GEEN NIEUWE AFSPRAKEN GEVONDEN")
Set Selection = Nothing
Set olapptsearch = Nothing
Set olappt = Nothing
Set OL = Nothing
Set NS = Nothing
MsgBox "end of code"
End Sub
 
Upvote 0
When Outlook is closed: (this is what I want to be able with the macro)
It enters 1 appointment in the calendar, then I get an error:
Runtime Error 2147023170 (800706be): Automation Error The Remote Procedure Call Failed (i have it in Dutch, but I think this is the translation)

When Outlook is open:
Seems to work fine!
I can run it again and again, still fine.

I added some code to your latest modification:
Then it runs fine when Outlook is closed.
The added code opens (and closes) Outlook and Word(don't know if Word has to be open)

But then again, the code can only run once.
When I run it again, I get an error:
Error 462 while excecuting. The remote server does not exist.
[ Excel points to this line: Set olappt = Outlook.Application.CreateItem(olAppointmentItem) ]

Whit Outlook open, it runs fine.

Modified code: including code from Test if Outlook is open and open Outlook with VBA

Code: 
#Const LateBind = True
Const olMinimized As Long = 1
Const olMaximized As Long = 2
Const olFolderInbox As Long = 6
#If LateBind Then
Public Function OutlookApp( _
    Optional WindowState As Long = olMinimized, _
    Optional ReleaseIt As Boolean = False _
    ) As Object
    Static o As Object
#Else
Public Function OutlookApp( _
    Optional WindowState As Outlook.OlWindowState = olMinimized, _
    Optional ReleaseIt As Boolean _
) As Outlook.Application
    Static o As Outlook.Application
#End If
On Error GoTo ErrHandler
 
    Select Case True
        Case o Is Nothing, Len(o.Name) = 0
            Set o = GetObject(, "Outlook.Application")
            If o.Explorers.Count = 0 Then
InitOutlook:
                'Open inbox to prevent errors with security prompts
                o.Session.GetDefaultFolder(olFolderInbox).Display
                o.ActiveExplorer.WindowState = WindowState
            End If
        Case ReleaseIt
            Set o = Nothing
    End Select
    Set OutlookApp = o
 
ExitProc:
    Exit Function
ErrHandler:
    Select Case Err.Number
        Case -2147352567
            'User cancelled setup, silently exit
            Set o = Nothing
        Case 429, 462
            Set o = GetOutlookApp()
            If o Is Nothing Then
                Err.Raise 429, "OutlookApp", "Outlook Application does not appear to be installed."
            Else
                Resume InitOutlook
            End If
        Case Else
            MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Unexpected error"
    End Select
    Resume ExitProc
    Resume
End Function
#If LateBind Then
Private Function GetOutlookApp() As Object
#Else
Private Function GetOutlookApp() As Outlook.Application
#End If
On Error GoTo ErrHandler
    
    Set GetOutlookApp = CreateObject("Outlook.Application")
    
ExitProc:
    Exit Function
ErrHandler:
    Select Case Err.Number
        Case Else
            'Do not raise any errors
            Set GetOutlookApp = Nothing
    End Select
    Resume ExitProc
    Resume
End Function
Sub CalenderAppointment()
Dim olddate, OldWeekDay, newdate, sSearch, olapptsearch, olappt, dEndTime, warning
Dim excelLink As Excel.Hyperlink
''Dim OutApp As Object 'Oultook.Application
Dim Appt As Object 'Outlook.AppointmentItem
Dim Selection As Object 'Word.Selection
Dim OL As Object, mystring, svw, bOLOpen, dStartTime, slocation, dReminder, sname, dcatagory
Dim NS As Object, i, r, company, link, pad, colitems, ssubject
Dim OutApp  As Object
Set OutApp = OutlookApp()
Dim word As Object
Dim doc As Object
On Error Resume Next
Set word = GetObject(, "word.application") 'gives error 429 if Word is not open
If Err.Number = 429 Then
  Err.Clear
  Set word = CreateObject("Word.Application")
End If
If Not word Is Nothing Then
   word.Visible = True
    
Else
   MsgBox "Unable to retrieve Word."
End If
mystring = "MB"
svw = "Mark"
i = 0
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
On Error GoTo 0
For r = 4 To 6
    If Len(Blad1.Cells(r, 21).Value) = 0 Then GoTo NextRow
    company = Blad1.Cells(r, 11)
    link = Blad1.Cells(r, 131).Value
    pad = Environ("USERPROFILE")
    link = Application.Substitute(link, "C:\Users\Temp", pad)
    Call Application.ActiveSheet.Hyperlinks.Add(Range("EB" & r), link, ScreenTip:= _
    "Open het bestand met basisgegevens van " & company, TextToDisplay:=company)
    Set excelLink = Excel.Range("EB" & r).Hyperlinks(1)
    Set NS = OL.GetNamespace("MAPI")
    Set colitems = NS.GetDefaultFolder(olFolderCalendar).Items
    ssubject = "[" & Blad1.Cells(r, 1) & "]  " & Blad1.Cells(r, 11) & " [" & Blad1.Cells(r, 22) & "]"
    dStartTime = Blad1.Cells(r, 21).Value + TimeValue("10:00:00")
    slocation = Blad1.Cells(r, 14)
    dReminder = 60
    sname = Blad1.Cells(r, 1)
    dcatagory = "Categorie Geel"
    If dStartTime > Date Then
    If Blad1.Cells(r, 18) <> 0 Then
    If sname = mystring Then
    olddate = dStartTime
    OldWeekDay = Weekday(olddate)
    If OldWeekDay = 1 Then
       newdate = olddate + 1
    ElseIf OldWeekDay = 2 Then
       newdate = olddate
    ElseIf OldWeekDay = 3 Then
       newdate = olddate + 3
    ElseIf OldWeekDay = 4 Then
      newdate = olddate + 2
    ElseIf OldWeekDay = 5 Then
      newdate = olddate + 1
    ElseIf OldWeekDay = 6 Then
      newdate = olddate
    ElseIf OldWeekDay = 7 Then
      newdate = olddate + 2
    End If
    sSearch = "[Subject] = " & sQuote(ssubject)
    Set olapptsearch = colitems.Find(sSearch)
    If olapptsearch Is Nothing Then
        Set olappt = Outlook.Application.CreateItem(olAppointmentItem)
        olappt.Display
        Set Selection = olappt.GetInspector.WordEditor.Windows(1).Selection
        dEndTime = newdate + TimeValue("11:00:00")
        Selection.TypeText ("Bellen met: " & Blad1.Cells(r, 15) & " over offerte (" & Blad1.Cells(r, 3) & ").")
        Selection.TypeText (vbNewLine & vbNewLine)
        Selection.TypeText ("Betreffende: " & Blad1.Cells(r, 23).Value & ".")
        Selection.TypeText (vbNewLine & vbNewLine)
        Selection.TypeText (Blad1.Cells(r, 11).Value & " - " & Blad1.Cells(r, 22).Value)
        Selection.TypeText (vbNewLine & vbNewLine)
        Selection.TypeText (vbNewLine & Blad1.Cells(r, 11).Value)
        Selection.TypeText (vbNewLine & Blad1.Cells(r, 12).Value)
        Selection.TypeText (vbNewLine & Blad1.Cells(r, 13).Value & " " & Blad1.Cells(r, 14))
        Selection.TypeText (vbNewLine & vbNewLine)
        Selection.TypeText (vbNewLine & Blad1.Cells(r, 15).Value)
        Selection.TypeText (vbNewLine & Blad1.Cells(r, 16).Value)
        Selection.TypeText (vbNewLine & vbNewLine & vbNewLine)
        Selection.TypeText ("Klik hier voor datasheet van: " & company & vbNewLine)
        Selection.Hyperlinks.Add Selection.Range, excelLink.Address, ScreenTip:= _
        "Open het bestand met basisgegevens van " & company, TextToDisplay:=excelLink.TextToDisplay
        olappt.Subject = ssubject
        olappt.Start = newdate
        olappt.End = dEndTime
        olappt.ReminderMinutesBeforeStart = dReminder
        olappt.Location = slocation
        olappt.Categories = dcatagory
        olappt.Close olSave
        i = i + 1
    End If
    End If
    End If
    End If
NextRow:
Next r
If bOLOpen = False Then OL.Quit
If olapptsearch Is Nothing Then warning = MsgBox("Reminders for " + svw + " created in Outlook calendar...", _
vbOKOnly + vbInformation, "AFSPRAKEN TOEGEVOEGD")
If i = 0 Then warning = MsgBox("No appointments added to Outlook Calendar!", _
vbOKOnly + vbCritical, "GEEN NIEUWE AFSPRAKEN GEVONDEN")
Set Selection = Nothing
Set olapptsearch = Nothing
Set olappt = Nothing
Set OL = Nothing
Set NS = Nothing
MsgBox "end of code"
word.Visible = False
End Sub
Function sQuote(sTextToQuote)
    sQuote = Chr(34) & sTextToQuote & Chr(34)
End Function
Public Function UserName()
UserName = Environ$("UserName")
End Function
 
Upvote 0
· I ran the latest code and got the message saying that no appointments were added.
· Changed one record at the worksheet, ran it again and got the message that a reminder was created.
· Ran again, no appointment added. Changed record, reminder created.
· No run-time error popped up; I did not touch Outlook during the test.
· Maybe you should leave Outlook open.
 
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Question Question
Excel to Outlook Calendar as Appointments - Delete Duplicate Entries
Replies
0
Views
1K
Bwiles96
B
R
  • Solved
VBA in Excel to find free appointment in Outlook and display in an email
Replies
8
Views
4K
RockEd
R
T
  • Question Question
Outlook appointments using Excel
Replies
0
Views
1K
t0m_c
T
C
  • Question Question
VBA to Create and Delete Outlook Appointments not working
Replies
2
Views
746
cSciFiChick
C
Z
  • Solved
add appointment to shared outlook calendar
Replies
2
Views
2K
zoog25
Z

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top