#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
