.ForceUpdateToAllAttendees = true

           oApptItem.Send

Set oFolder = oNameSpace.GetDefaultFolder(olFolderCalendar)

Sub СоздатьВстречи()
    
Dim oApp As Object  ' Outlook.Application
Dim appt As Object  ' Outlook.AppointmentItem
Dim sh2 As Excel.Worksheet
Dim sh5 As Excel.Worksheet


Prepare
  ' late bound constants
Const olAppointmentItem As Long = 1
Const olBusyStatus As Long = 2
Const olMeeting = 1

  ' get range of dates
Set sh2 = ThisWorkbook.Sheets("Расписание")
Set sh5 = ThisWorkbook.Sheets("Справочник")
  
sh2.Activate
sh2.Range("A1").Select
  
iendX = sh2.Cells(1000000, 2).End(xlUp).Row 'определяем все строки расписания

zDate1 = DateValue(Now) ' определяем текущую дату

  
Set FindzDate1 = Columns(1).Find(What:=zDate1, After:=Cells(1, 1), LookIn:=xlValues, _
                            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                            MatchCase:=False, SearchFormat:=False) 'ищем дату начала отчета
                            
istartX = FindzDate1.Row

Set oApp = GetOutlookApp

If oApp Is Nothing Then
    MsgBox "Outlook не доступен!", vbInformation
    Ended
    Exit Sub
End If

For Z = 29025 To 29037 ' цикл по строкам расписания с текущей даты до конца

If sh2.Cells(Z, 7).Interior.Color <> 65535 And sh2.Cells(Z, 7) <> "" Then ' если еще не отправляли встречу по этому уроку

    zDate = CVDate(sh2.Cells(Z, 1)) 'дата
    ZTime = CVDate(sh2.Cells(Z, 3)) 'время
    zLesson = sh2.Cells(Z, 5) 'вид урока
    zlevel = sh2.Cells(Z, 6) 'уровень
    zTeacher = sh2.Cells(Z, 7) 'преподаватель
    zLoc = sh2.Cells(Z, 4) & " класс" 'преподаватель
    
sh5.Activate
sh5.Range("A1").Select
    Set FindTeacher = Cells.Find(What:=zTeacher, After:=Cells(1, 1), LookIn:=xlValues, _
                        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                        MatchCase:=False, SearchFormat:=False)
    If Not FindTeacher Is Nothing Then zrow = FindTeacher.Row
    
    adTeacher = sh5.Cells(zrow, 2)
sh2.Activate
If zlevel = "ПробноеГ" Or zlevel = "ПробноеГ_пл" Then ZTime = CVDate(sh2.Cells(Z - 1, 3)) 'время

If zlevel = "ПробноеБ" Or zlevel = "ПробноеБ_пл" Or zlevel = "ПробноеБГ" Or zlevel = "ПробноеБГ_пл" Or zlevel = "ПробноеГ" Or zlevel = "ПробноеГ_пл" Then
    zlevel = "Пробное"
    GoTo 77
End If


        ZPosV = InStr(1, zLesson, "_", vbTextCompare) 'Вид: позиция "_"
        ZPosP = InStr(1, zlevel, "_", vbTextCompare) 'Подвид: позиция "_"
        If ZPosP <> 0 Then zNomerU = Right(zlevel, Len(zlevel) - ZPosP) 'определяем номер урока
        If ZPosV <> 0 Then
            'Вид: если есть "_"
            zlevel = Right(zLesson, Len(zLesson) - ZPosV)
            zLesson = Left(zLesson, ZPosV - 1)
        Else
            'Вид: если нет "_"
            If ZPosP <> 0 Then zlevel = Left(zlevel, ZPosP - 1) 'Подвид: если есть "_"
        End If
77:
Select Case zlevel

Case "индив"
IDur = 60

Case "восст"
IDur = 60

Case Else
IDur = 120

End Select

   Set appt = oApp.CreateItem(olAppointmentItem)

    With appt
     .Subject = sh2.Cells(Z, 5) & "_" & sh2.Cells(Z, 6)
     '.body = arrMsgs(i)
      .RequiredAttendees = adTeacher
      .Start = zDate + ZTime
      .Duration = IDur
      .MeetingStatus = olMeeting
      .Location = zLoc
      .Send

    End With
sh2.Cells(Z, 7).Interior.Color = 65535
End If
  
Next Z
Ended
End Sub


Function GetOutlookApp() As Object
' return Outlook.Application object
 On Error Resume Next
  Set GetOutlookApp = CreateObject("Outlook.Application")
End Function

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

Private Sub Workbook_Open()
Worksheets("Встречи-Продажи").Unprotect Password:="111"
End Sub

Private Sub Workbook_Open()Worksheets("Встречи-Продажи").Protect Password:="111", UserInterfaceOnly:=True, AllowFiltering:=TrueEnd Sub