Ich bin neu in diesem Forum und bedanke mich schon im Voraus für die Unterstützung.
Ich habe folgendes Thema zu lösen:
Aus einem Makro heraus den freigegeben Kalender (Outlook 2010) eines Users öffnen um dort in einer ersten Phase "händisch" einen Termin einzutragen.
(nb: in Phase 2 wäre angedacht, dass am aktuellen Tag & Zeit ein Termin erstellt wird und aus einem definierten Verzeichnis das neueste File als Beilage eingepflegt wird.
Aber zuerst einmal zu Phase 1
Mit nachfolgendem Code, wird der eingetragen Kalender (fett) geöffnet.
Ich möchte jedoch, dass anstelle des Textstrings der Name im aktiven Sheet aus Zelle G6 eingetragen und der entsprechende Kalender geöffnet wird.
Kann mir da jemand weiter helfen?
Ausschnitt aus dem Code:
Kalender öffnen
Dim myOlApp ' As Outlook.Application
Dim myNamespace ' As Outlook.NameSpace
Dim myRecipient ' As Outlook.Recipient
Dim CalendarFolder ' As Outlook.MAPIFolder
Const olFolderCalender = 9
Set myOlApp = CreateObject("Outlook.Application")
Set myNamespace = myOlApp.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient("Muster Fritz") 'hier sollte autom. ein Name aus dem Sheet eingetragen werden.
myRecipient.Resolve
If myRecipient.Resolved Then
' Call ShowCalendar(myNamespace, myRecipient)
MsgBox ("weiter gehts")
End If
Dim myCalendarFolder ' As Outlook.MAPIFolder
Set myCalendarFolder = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderCalender)
myCalendarFolder.Display
Kompletter Code des Makro "Rapport erstellen"
Sub Neuer_Rapport()
' Neuer_Rapport Makro
Application.ScreenUpdating = False
Workbooks.Add Template:= _
"C:\1_Daten\1_Projekte\14_Rapporting_automatisieren\Arbeitsrapport.xltx"
Windows("Erfassung Call.xlsx").Activate
Sheets("Calls_Interventionen").Select
Dim x As Long
x = Range("A65536").End(xlUp).Row
Rows(x).Select
Selection.Copy
Windows("Arbeitsrapport1").Activate
Sheets("Auftrag").Select
Range("A19").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Sheets("Hilfstabellen").Select
Range("H16").Select
Application.CutCopyMode = False
Selection.Copy
Range("H17").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
' Rapportnummer eintragen
Windows("Arbeitsrapport1").Activate
Sheets("Hilfstabellen").Select
Range("H7").Select
Selection.Copy
Windows("Erfassung Call.xlsx").Activate
x = Range("AD65536").End(xlUp).Row
Cells(x + 1, 30).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
' unnötige Rapportnummer löschen
' MUSS noch überarbeitet werden!
Windows("Erfassung Call.xlsx").Activate
x = Range("AB65536").End(xlUp).Row
Cells(x + 1, 28).Select
ActiveCell.Offset(0, 2).Select
Range(ActiveCell, ActiveCell.End(xlDown)).Select
Selection.ClearContents
x = Range("A65536").End(xlUp).Row
Cells(x + 1, 1).Select
'ActiveCell.ActiveCell.End(x1Down).Select
'ActiveSheet.Range("a1", ActiveSheet.Range("a1").End(xlDown)).Select
'ActiveCell.Clear
' Speichern unter
Windows("Arbeitsrapport1").Activate
Dim NeuerName As String, Speicherpfad As String
Speicherpfad = "C:\1_Daten\1_Projekte\14_Rapporting_automatisieren\Aufträge\"
NeuerName = Range("H17")
ActiveWorkbook.SaveAs Filename:=Speicherpfad & NeuerName & " " '& Date
' Kopieren für Outlootermin (Zwischenablage anschliessend für Termin-Body benutzen)
Sheets("Auftrag").Select
Range("Kalenderbetreff").Select
Selection.Copy
Sheets("Rapport").Select
Range("E6").Select
'ActiveWorkbook.RefreshAll
'Kalender öffnen
Dim myOlApp ' As Outlook.Application
Dim myNamespace ' As Outlook.NameSpace
Dim myRecipient ' As Outlook.Recipient
Dim CalendarFolder ' As Outlook.MAPIFolder
Const olFolderCalender = 9
Set myOlApp = CreateObject("Outlook.Application")
Set myNamespace = myOlApp.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient("Muster Fritz") 'hier sollte autom. ein Name _
_
aus dem Sheet eingetragen werden.
myRecipient.Resolve
If myRecipient.Resolved Then
' Call ShowCalendar(myNamespace, myRecipient)
MsgBox ("weiter gehts")
End If
Dim myCalendarFolder ' As Outlook.MAPIFolder
Set myCalendarFolder = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderCalender)
myCalendarFolder.Display
End Sub