Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Создание Reminder в Outlook - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин  
Мир MS Excel » Работа и общение » Работа / Фриланс » Создание Reminder в Outlook
Создание Reminder в Outlook
Oh_Nick Дата: Суббота, 02.10.2021, 16:16 | Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 225
Репутация: 0 ±
Замечаний: 0% ±

Excel 2019
Всем доброго времени суток!

На просторах интернета нашел следующий код, который создает напоминания в Outlook:

[vba]
Код
Sub Outloook_Reminders()
Sheets("renewals").Select
    Dim startRow As Long, endRow As Long, ctr As Long

    startRow = 2
    endRow = Cells(Rows.Count, 1).End(xlUp).Row
    
    For ctr = startRow To endRow
        With CreateObject("Outlook.application").createitem(1)
        On Error Resume Next
            .Start = DateValue(Range("C" & ctr)) + TimeValue(Range("C" & ctr))
            .Duration = CLng(Range("D" & ctr)) ' 30
            .Subject = CStr(Range("E" & ctr)) ' subject text
            .ReminderSet = True
            .Save
        End With
    Next
End Sub

[/vba]

Также имеется таблица на листе TaskBook. Нужно, чтобы Reminder создавался по заполнению этой таблицы

Вводится Header , Задача, Дата начала и Дата напоминания со времени. Т.е Reminder создается, но нужно, чтобы он создавался на определенную почту, которую мы введем в ячейку.

Помогите преобразить под эту таблицу.
К сообщению приложен файл: 9176493.xlsm(23.2 Kb)
 
Ответить
СообщениеВсем доброго времени суток!

На просторах интернета нашел следующий код, который создает напоминания в Outlook:

[vba]
Код
Sub Outloook_Reminders()
Sheets("renewals").Select
    Dim startRow As Long, endRow As Long, ctr As Long

    startRow = 2
    endRow = Cells(Rows.Count, 1).End(xlUp).Row
    
    For ctr = startRow To endRow
        With CreateObject("Outlook.application").createitem(1)
        On Error Resume Next
            .Start = DateValue(Range("C" & ctr)) + TimeValue(Range("C" & ctr))
            .Duration = CLng(Range("D" & ctr)) ' 30
            .Subject = CStr(Range("E" & ctr)) ' subject text
            .ReminderSet = True
            .Save
        End With
    Next
End Sub

[/vba]

Также имеется таблица на листе TaskBook. Нужно, чтобы Reminder создавался по заполнению этой таблицы

Вводится Header , Задача, Дата начала и Дата напоминания со времени. Т.е Reminder создается, но нужно, чтобы он создавался на определенную почту, которую мы введем в ячейку.

Помогите преобразить под эту таблицу.

Автор - Oh_Nick
Дата добавления - 02.10.2021 в 16:16
Oh_Nick Дата: Суббота, 02.10.2021, 17:15 | Сообщение № 2
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 225
Репутация: 0 ±
Замечаний: 0% ±

Excel 2019
Небольшой апдейт в файле:

Все хорошо создает , но теперь нужно привязать напоминания к определенной почте в колонке С и желательно, чтобы она через ; записывалась. Например 1@mail.ru; 2@mail.ru и тд.
К сообщению приложен файл: 8842311.xlsm(27.9 Kb)
 
Ответить
СообщениеНебольшой апдейт в файле:

Все хорошо создает , но теперь нужно привязать напоминания к определенной почте в колонке С и желательно, чтобы она через ; записывалась. Например 1@mail.ru; 2@mail.ru и тд.

Автор - Oh_Nick
Дата добавления - 02.10.2021 в 17:15
Oh_Nick Дата: Суббота, 02.10.2021, 18:04 | Сообщение № 3
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 225
Репутация: 0 ±
Замечаний: 0% ±

Excel 2019
Также нужно чтобы добавлял в календарь, но почему-то подсвечивает эту строчку:

[vba]
Код
Option Explicit

Sub CreateTasks()

    Dim olApp As Object
    Dim olTask As Object
    Dim LastRow As Long
    Dim i As Long
    Dim ctr As Long
    
    Set olApp = CreateObject("Outlook.Application")
    
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
    For i = 2 To LastRow
        If Cells(i, "A").Value <> "" Then
            Set olTask = olApp.createitem(3) 'olTaskItem
            With olTask
                [color=#FFFF00][i][b].Start = DateValue(Range("D" & ctr)) + TimeValue(Range("D" & ctr))[/b][/i][/color]
                .Subject = "Reminder - " & Cells(i, "A").Value
                .Body = Cells(i, "A").Value
                .Status = 1 'olTaskInProgress
                .Importance = 2 'olImportanceHigh
                .Duration = CLng(Range("G" & ctr)) ' 30
                .DueDate = Cells(i, "D").Value
                .ReminderSet = True
                .ReminderTime = Cells(i, "E").Value + TimeValue(Format(Cells(i, "F"), "HH:MM:SS"))
                .Save
            End With
        End If
    Next i
End Sub
[/vba]
 
Ответить
СообщениеТакже нужно чтобы добавлял в календарь, но почему-то подсвечивает эту строчку:

[vba]
Код
Option Explicit

Sub CreateTasks()

    Dim olApp As Object
    Dim olTask As Object
    Dim LastRow As Long
    Dim i As Long
    Dim ctr As Long
    
    Set olApp = CreateObject("Outlook.Application")
    
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
    For i = 2 To LastRow
        If Cells(i, "A").Value <> "" Then
            Set olTask = olApp.createitem(3) 'olTaskItem
            With olTask
                [color=#FFFF00][i][b].Start = DateValue(Range("D" & ctr)) + TimeValue(Range("D" & ctr))[/b][/i][/color]
                .Subject = "Reminder - " & Cells(i, "A").Value
                .Body = Cells(i, "A").Value
                .Status = 1 'olTaskInProgress
                .Importance = 2 'olImportanceHigh
                .Duration = CLng(Range("G" & ctr)) ' 30
                .DueDate = Cells(i, "D").Value
                .ReminderSet = True
                .ReminderTime = Cells(i, "E").Value + TimeValue(Format(Cells(i, "F"), "HH:MM:SS"))
                .Save
            End With
        End If
    Next i
End Sub
[/vba]

Автор - Oh_Nick
Дата добавления - 02.10.2021 в 18:04
Oh_Nick Дата: Суббота, 02.10.2021, 18:29 | Сообщение № 4
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 225
Репутация: 0 ±
Замечаний: 0% ±

Excel 2019
Вообщем остановился на таком коде и файле. В итоге необходимо добавить получателей и все (колонка B )

[vba]
Код
Sub Outloook_Reminders()
Sheets("ReminderBook").Select
     Dim startRow As Long, endRow As Long, ctr As Long
   
     startRow = 2
     endRow = Cells(Rows.Count, 1).End(xlUp).Row
     
     For ctr = startRow To endRow
        With CreateObject("Outlook.application").createitem(1)
        On Error Resume Next
            .Start = DateValue(Range("C" & ctr)) + TimeValue(Range("C" & ctr))
            .Duration = CLng(Range("D" & ctr)) ' 60
            .Subject = CStr(Range("A" & ctr)) ' subject text
            .ReminderSet = True
            .Save
        End With
     Next
End Sub
[/vba]
К сообщению приложен файл: 1849370.xlsm(27.7 Kb)


Сообщение отредактировал Oh_Nick - Суббота, 02.10.2021, 18:29
 
Ответить
СообщениеВообщем остановился на таком коде и файле. В итоге необходимо добавить получателей и все (колонка B )

[vba]
Код
Sub Outloook_Reminders()
Sheets("ReminderBook").Select
     Dim startRow As Long, endRow As Long, ctr As Long
   
     startRow = 2
     endRow = Cells(Rows.Count, 1).End(xlUp).Row
     
     For ctr = startRow To endRow
        With CreateObject("Outlook.application").createitem(1)
        On Error Resume Next
            .Start = DateValue(Range("C" & ctr)) + TimeValue(Range("C" & ctr))
            .Duration = CLng(Range("D" & ctr)) ' 60
            .Subject = CStr(Range("A" & ctr)) ' subject text
            .ReminderSet = True
            .Save
        End With
     Next
End Sub
[/vba]

Автор - Oh_Nick
Дата добавления - 02.10.2021 в 18:29
Oh_Nick Дата: Воскресенье, 03.10.2021, 15:55 | Сообщение № 5
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 225
Репутация: 0 ±
Замечаний: 0% ±

Excel 2019
В этом коде есть рассылка по почтам. Как ее вписать в этот код?

[vba]
Код
Option Explicit
Option Base 0

Sub OutTask_Manager()

Dim OutApp As Object  'Для обращений к приложению Outlook
Dim OutTsk As Object  'Для создания задачи в Outlook
Dim OutMan As Object  'Для работы с получателем задачи
Dim shtX As Worksheet 'Для обращения к конкретному листу
Dim RecR() As String  'Для хранения имён получателей
Dim i As Long         'Для перебора получателей
Dim X As Long         'Для перебора создаваемых задач

Set shtX = ThisWorkbook.Worksheets("TaskBook")
Set OutApp = CreateObject("Outlook.Application")
X = 2

Do While shtX.Cells(X, 1).Value <> 0
    Set OutTsk = OutApp.CreateItem(3)
    ReDim RecR(0)
    RecR = Split(shtX.Cells(X, 3).Value, "; ")
    'Если в столбце "Получатель" кто-то указан, то добавляем его.
    If UBound(RecR) >= 0 Then
        For i = 0 To UBound(RecR)
            If RecR(i) <> "" Then
                OutTsk.assign
                Set OutMan = OutTsk.Recipients.Add(RecR(i))
                OutMan.Resolve
                If Not OutMan.Resolved Then
                    MsgBox ("Не удаётся назначить задачу пользователю: " & RecR(i) & vbNewLine & "По закрытию этого окна программа продолжит перебор получателей и строк.")
                    GoTo NextRow
                End If
            End If
        Next i
    End If
    'Заполняем задачу содержанием.
    With OutTsk
        .Subject = shtX.Cells(X, 1).Value 'Заголовок задачи
        .Body = shtX.Cells(X, 2).Value 'Текст задачи
        .ReminderSet = True 'Включить напоминание
        Select Case shtX.Cells(X, 4).Value 'Выбираем важность
            Case "Низкая": .Importance = 0
            Case "Обычная": .Importance = 1
            Case "Высокая": .Importance = 2
        End Select
        .StartDate = DateAdd("h", 10, shtX.Cells(X, 5).Value) 'Когда начать задачу
        .DueDate = DateAdd("h", 10, shtX.Cells(X, 6).Value) 'Дата завершения
        .ReminderTime = DateAdd("n", shtX.Cells(X, 8).Value * 60 + shtX.Cells(X, 9).Value, shtX.Cells(X, 7).Value) 'Дата напоминания
        'В зависимости от содержания в столбце "Получатель" отправляем или сохраняем задачу.
        Select Case UBound(RecR)
            Case -1: .Save
            Case Else: .SEND
        End Select
    End With
NextRow:
    X = X + 1
    Set OutTsk = Nothing
    Set OutMan = Nothing
Loop
Set OutApp = Nothing
End Sub
[/vba]
 
Ответить
СообщениеВ этом коде есть рассылка по почтам. Как ее вписать в этот код?

[vba]
Код
Option Explicit
Option Base 0

Sub OutTask_Manager()

Dim OutApp As Object  'Для обращений к приложению Outlook
Dim OutTsk As Object  'Для создания задачи в Outlook
Dim OutMan As Object  'Для работы с получателем задачи
Dim shtX As Worksheet 'Для обращения к конкретному листу
Dim RecR() As String  'Для хранения имён получателей
Dim i As Long         'Для перебора получателей
Dim X As Long         'Для перебора создаваемых задач

Set shtX = ThisWorkbook.Worksheets("TaskBook")
Set OutApp = CreateObject("Outlook.Application")
X = 2

Do While shtX.Cells(X, 1).Value <> 0
    Set OutTsk = OutApp.CreateItem(3)
    ReDim RecR(0)
    RecR = Split(shtX.Cells(X, 3).Value, "; ")
    'Если в столбце "Получатель" кто-то указан, то добавляем его.
    If UBound(RecR) >= 0 Then
        For i = 0 To UBound(RecR)
            If RecR(i) <> "" Then
                OutTsk.assign
                Set OutMan = OutTsk.Recipients.Add(RecR(i))
                OutMan.Resolve
                If Not OutMan.Resolved Then
                    MsgBox ("Не удаётся назначить задачу пользователю: " & RecR(i) & vbNewLine & "По закрытию этого окна программа продолжит перебор получателей и строк.")
                    GoTo NextRow
                End If
            End If
        Next i
    End If
    'Заполняем задачу содержанием.
    With OutTsk
        .Subject = shtX.Cells(X, 1).Value 'Заголовок задачи
        .Body = shtX.Cells(X, 2).Value 'Текст задачи
        .ReminderSet = True 'Включить напоминание
        Select Case shtX.Cells(X, 4).Value 'Выбираем важность
            Case "Низкая": .Importance = 0
            Case "Обычная": .Importance = 1
            Case "Высокая": .Importance = 2
        End Select
        .StartDate = DateAdd("h", 10, shtX.Cells(X, 5).Value) 'Когда начать задачу
        .DueDate = DateAdd("h", 10, shtX.Cells(X, 6).Value) 'Дата завершения
        .ReminderTime = DateAdd("n", shtX.Cells(X, 8).Value * 60 + shtX.Cells(X, 9).Value, shtX.Cells(X, 7).Value) 'Дата напоминания
        'В зависимости от содержания в столбце "Получатель" отправляем или сохраняем задачу.
        Select Case UBound(RecR)
            Case -1: .Save
            Case Else: .SEND
        End Select
    End With
NextRow:
    X = X + 1
    Set OutTsk = Nothing
    Set OutMan = Nothing
Loop
Set OutApp = Nothing
End Sub
[/vba]

Автор - Oh_Nick
Дата добавления - 03.10.2021 в 15:55
Oh_Nick Дата: Воскресенье, 03.10.2021, 20:11 | Сообщение № 6
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 225
Репутация: 0 ±
Замечаний: 0% ±

Excel 2019
Закройте тему. Задам еще раз в бесплатной ветке вопрос.
 
Ответить
СообщениеЗакройте тему. Задам еще раз в бесплатной ветке вопрос.

Автор - Oh_Nick
Дата добавления - 03.10.2021 в 20:11
Мир MS Excel » Работа и общение » Работа / Фриланс » Создание Reminder в Outlook
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования Jobsora jooble
© 2010-2021 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!