Как создать встречу в Outlook в общем календаре

[lioon]

Добрый день,

Из Excel нужно создать встречу в общем календаре, чтобы его видели все
пользователи подключенные к общему календарю допустим Общий_ календарь.ics

В свой календарь я могу добавить данную встречу без проблем данным кодом, но как его уговорить выбрать другой календарь - не соображу.

Sub app()
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.AppointmentItem

Set OutApp = New Outlook.Application
Set OutMail = OutApp.CreateItem(olAppointmentItem)

With OutMail
   .MeetingStatus = olMeeting
   .Location = " Место"
   .Subject = "Тема"
   .Start = "8:00 PM" & Format(Date)
   .End = "9:00 PM" & Format(Date)
   .Body = "Текст встречи"
   .Recipients.Add ("slv@ssst.ru")
  ' .Display
   .Send

End With
End Sub

[IgorGO]

в OutLook откройте "общий календарь",
добавте в него событие вручную,
запишите свои действия макрорекордером,
изучайте полученный код, там увидите, как обращаться к общему календарю

удачи!

[lioon]

К сожалению в outlook нет маркорекордера. Только редактор и запуск макросов.

[lioon]

По-моему данная ссылка должна проливать какой то свет на решение вопроса, но я всё равно пока не понял ничего: (

http://www.slipstick.com/developer/w...tlook-folders/

[lioon]

Нашел такой пример, но не удается его оживить

Public Sub CreateOutlookApptz()
   Sheets("Лист1").Select
    On Error GoTo Err_Execute
     
    Dim olApp As Outlook.Application
    Dim olAppt As Outlook.AppointmentItem
    Dim blnCreated As Boolean
    Dim olNs As Outlook.Namespace
    Dim CalFolder As Outlook.MAPIFolder
    Dim subFolder As Outlook.MAPIFolder
    Dim arrCal As String
     
    Dim i As Long
     
    On Error Resume Next
    Set olApp = Outlook.Application
     
    If olApp Is Nothing Then
        Set olApp = Outlook.Application
         blnCreated = True
        Err.Clear
    Else
        blnCreated = False
    End If
     
    On Error GoTo 0
     
    Set olNs = olApp.GetNamespace("MAPI")
    Set CalFolder = GetFolderPath(olFolderCalendar)
         
    i = 2
    Do Until Trim(Cells(i, 1).Value) = ""
    arrCal = Cells(i, 1).Value
    Set subFolder = CalFolder.Folders(arrCal)
     
    Set olAppt = subFolder.Items.Add(olAppointmentItem)
          
    MsgBox subFolder, vbOKCancel, "Folder Name"
 
    With olAppt
     
    'Define calendar item properties
        .Start = Cells(i, 6) + Cells(i, 7)     '+ TimeValue("9:00:00")
        .End = Cells(i, 8) + Cells(i, 9)       '+TimeValue("10:00:00")
        .Subject = Cells(i, 2)
        .Location = Cells(i, 3)
        .Body = Cells(i, 4)
        .BusyStatus = olBusy
        .ReminderMinutesBeforeStart = Cells(i, 10)
        .ReminderSet = True
        .Categories = Cells(i, 5)
        .Save
     
    End With
                 
        i = i + 1
        Loop
    Set olAppt = Nothing
    Set olApp = Nothing
     
    Exit Sub
     
Err_Execute:
    MsgBox "An error occurred - Exporting items to Calendar."
     
End Sub