|
|
|
|
| Компьютерный форум OSzone.net » Программирование, базы данных и автоматизация действий » Скриптовые языки администрирования Windows » VBS/WSH/JS - [решено] Сохранение контактов Outlook 2010 |
|
|
VBS/WSH/JS - [решено] Сохранение контактов Outlook 2010
|
|
Новый участник Сообщения: 9 |
Доброго дня!!!
Используем в компании скрипт для формирования адресной книги. На всех клиентах отрабатывает нормально, но на Windows 8 в сочетании с Outlook 2010 (на быстром железе) проявилась проблема. Либо контакты записываются не полностью либо, либо вообще не записываются. Весь скрипт выкладывать не буду, он большой и часть его здесь будет совершенно лишней, поэтому вкратце о скрипте: Данный скрипт подключается к Outlook, удаляет папки с контактами подразделений, создает новые папки с подразделениями, подключается к файлику в формате csv и из него производит добавление адресов сотрудников в соответствующие подразделениям папки. Ну и собственно сам скрипт: Сам текст: Код:
 'Блок 3.2. Работа с MS Outlook
'Если профиль по умолчанию Outlook обнаружен начинаем работу
If InMot = 1 Then
msb = "Производиться обновление адресных книг Microsoft Outlook" & vbLf _
& "В процесссе обновления программа Microsoft Outlook будет закрыта"
MsPop msb, 1, 2, "Обновление адресных книг Microsoft Outlook", 0, 0
MotOpen = StartStop(0, 1)
'On Error Resume Next
WScript.Sleep 1000 ' Это засыпание скрипта очень важно! Без него объект Outlooka не успевает выгрузится и новый объект не создается
Set objOutlook = CreateObject("Outlook.Application")
Set objNameSpace = objOutlook.GetNamespace("MAPI")
Set ContOlFolder = objNameSpace.GetDefaultFolder(10)
Set OlDelFolder = objNameSpace.GetDefaultFolder(3)
ContDel 0
WScript.Sleep 1000
FoldAdd 0
WScript.Sleep 1000
ContAdd 0
End If
Код:
'Функция работы с почтовым клиентом,
'производит закрытие, открытие почтовых клиентов по ходу процессa обновления
'передаваемые параметры:
'st - параметр закрытия открытия (0-закрыть, 1-открыть, 2-закрыть без уведомлений);
'tp - тип клиента (0 - Mozilla Thunderbird, 1 - MS Outlook)
'в зависимости от передаваемого параметра st, возвращает:
' True - если программа была открыта и st = 0
' False - если программа была закрыта и st = 0
' "" - если st = 1
Function StartStop(st, tp)
If tp = 0 Then
ClName = "Mozilla Thunderbird"
Stname = "thunderbird.exe"
ElseIf tp = 1 Then
ClName = "Microsoft Outlook"
Stname = "outlook.exe"
End If
strFind = "SELECT * FROM Win32_Process WHERE Name = '" & Stname & "'"
If st = 0 Or st = 2 Then
'Проверяем открыта ли программа
OpenProg = 0
For Each objProc In objService.ExecQuery(strFind)
OpenProg = 1
Next
'Если открыта закрываем согласно заданного параметра StopClient
If OpenProg = 1 Then
If st = 0 Then
zok = "Программа " & ClName & " закрывается"
ms1 = "Выполняется обновление адресных книг. Программа " & ClName & " будет "
ms2 = "Для продолжения операции обновления нажмите кнопку ''Ok''. Для отмены закрытия" _
& " программы нажмите кнопку ''Отмена'', при этом операция обновления будет отменена."
If StopClient = 2 Then 'автоматически закрывающееся окно
msb = ms1 & "автоматически закрыта через " & Otvet & " сек." & VbLf & ms2
mscl = objShell.Popup(msb, Otvet, zok, vbOkCancel+vbQuestion+VbSystemModal)
ElseIf StopClient = 3 Then 'окно с ожиданием ответа пользователя
msb = ms1 & "закрыта." & VbLf & ms2
mscl = MsgBox(msb, vbOkCancel+vbQuestion+VbSystemModal, zok)
End If
If LogFile < 3 Then 'записываем данное событие в лог, если задано и параметр лога расширенный
If DebugLog = 1 Then AllMsg = AllMsg & msb & VbLf
End If
End If
If (mscl <= 1) or (StopClient = 1) Then
For Each objProc In objService.ExecQuery(strFind)
If tp = 1 Then 'если Outlook - завершаем корректно
If OsInf > 61 Then 'Если версия Windows 8.0 и выше срубаем Outlook
objProc.Terminate
Else
Set objOutlook = CreateObject("Outlook.Application")
objOutlook.Quit
'Set objOutlook = Nothing
End If
ElseIf tp = 0 Then 'если Mozilla - просто закрываем
objProc.Terminate
End If
Next
StartStop = True
Exit Function
ElseIf mscl > 1 Then 'пользователь отказался от обновления
msb = "Процесс обновления отменен, скрипт останавливается."
MsPop msb, 1, 3, "Отмена обновления", 2, 0
GoodBye
End If
Else 'если закрыта то и не надо
StartStop = False
Exit Function
End If
ElseIf st = 1 Then
StartProg = 0
'в зависимости от параметра StartClient определяем потребность в запуске
If StartClient = 2 Then
If tp = 0 Then
If MztOpen Then StartProg = 1
ElseIf tp = 1 Then
If MotOpen Then StartProg = 1
End If
ElseIf StartClient = 1 Then
StartProg = 1
End If
'запускаем программу
If StartProg = 1 Then
Strt = 0
If tp = 0 Then 'определяем путь к thunderbird.exe
'если Thunderbird был ранее найден в реестре проверим путь запуска
If InTbr = 1 And objFSO.FileExists(PthTnb) Then Strt = 1
If Not Strt = 1 Then 'если не был найден в реестре попробуем по стандартному пути
PthTnb = SpecFolder("PROGRAM_FILES") & "\" & ClName & "\" & Stname 'для 32bit
If Not objFSO.FileExists(PthTnb) Then 'для 64-bit другой путь
PthTnb = SpecFolder("PROGRAM_FILESX86") & "\" & ClName & "\" & Stname
If Not objFSO.FileExists(PthTnb) Then 'Thunderbird вероятно установлен в другую папку
msb = "Файл запуска " & ClName & " в стандартной папке не обнаружен." _
& VbLf & "Запустите " & ClName & " с помощью ярлыка, самостоятельно"
MsPop msb, 1, 2, "Невозможно запустить Mozilla Thunderbird автоматически", 0, 0
Exit Function
Else
Strt = 1
End If
Else
Strt = 1
End If
End If
End If
If Strt = 1 Or tp = 1 Then
msb = "Процесс обновления адресных книг завершен, запускаем " & ClName & "."
MsPop msb, 1, 2, "Запуск " & ClName, 0, 0
OpenProg = 0
While OpenProg = 0
If tp = 0 Then objShell.Exec(PthTnb)
If tp = 1 Then objShell.Run ("cmd /c start outlook")
WScript.Sleep 1000
For Each objProc In objService.ExecQuery(strFind)
OpenProg = 1
Next
Wend
End If
End If
End If
End Function
Код:
'Данная процедура удаляет папки Подразделений в папке Контакты Outlook
'Первый For задает количество проходов для удаления папок. Я хз... почему но с
'первого прохода все папки не удаляются, поэтому процедура загнана в цикл
'передаваемые параметры:
'filtip - тип файла адресных книг (0-подразделения, 1-контрагенты)
Sub ContDel(filtip)
DelFol = 1
Stp = 0
While DelFol = 1
DelFol = 0
For Each objOlFolders In ContOlFolder.Folders
'Перемещаем папки подразделений в корзину
MyFolder = objOlFolders.Name
If DeptName (MyFolder,"Ft",filtip) Then
MsPop "Удаляем папку " & MyFolder & "(проход " & Stp & ").", 1, 1, "Удаление папок контактов в Outlook", 0, 1
objOlFolders.ShowAsOutlookAB = False
Set OldContactsFoder = ContOlFolder.Folders(MyFolder)
On Error Resume Next
OldContactsFoder.MoveTo OlDelFolder
'в Outlook версиях старше 2007 наблюдается глюк удаления папок.
'если таковое наблюдается на данной машине производим очистку корзины
If Err.Number <> 0 Then
zok = "Требуется очистка корзины!!!"
msb = "Для корректного обновления адресных книг требуется очистить папку ''Удаленные''." & vbLf _
& "Нажмите ''Ok'' для выполнения очистки в автоматическом режиме. Для очистки в ручном режиме " _
& "нажмите кнопку ''Oтмена'' (при этом операция обновления будет отменена). Данное окно " _
& "закроется автоматически через " & Otvet & " сек. (будет выполнена очистка в автоматическом режиме)."
mscl = objShell.Popup(msb, Otvet, zok, vbOkCancel+vbQuestion+VbSystemModal)
If mscl <= 1 Then
Set nsp = objOutlook.Session
Set oDeletedItems = nsp.GetDefaultFolder(olFolderDeletedItems)
Set oItems = oDeletedItems.Items
'ниже закомментирован код удаления элементов
'For i = oItems.Count To 1 Step -1
' oItems.Item(i).Delete
'Next
Set oFolders = oDeletedItems.Folders
For i = oFolders.Count To 1 Step -1
oFolders.Item(i).Delete
Next
Set nsp = Nothing
Set oDeletedItems = Nothing
Set oItems = Nothing
ElseIf mscl > 1 Then 'пользователь выбрал вариант ручной очистки корзины
msb = "Выбран вариант ручной очистки корзины. Очистите корзину вручную, перезапустите процесс обновления."
MsPop msb, 1, 3, "Отмена обновления", 2, 0
GoodBye
End If
End If
DelFol = 1
End If
Next
Set OldContactsFoder = Nothing
'Если версия Outlook меньше 2010 необходимо производить очистку корзины, иначе удаленная папка с
'контактами отображается в общем списке контактов
If Mof <=12 Then
For Each objOlFolders In OlDelFolder.Folders
'При перемещении папок в корзину к имени файла могут добавляться цифры
'поэтому процедуру удаления папок из корзины делаем отдельно
MyFoldOr = objOlFolders.Name
MyFoldTr = Left (MyFoldOr, Len(MyFoldOr) - 1)
If DeptName (MyFoldOr,"Ft",filtip) Or DeptName (MyFoldTr,"Ft",filtip) Then
Set OldContactsFoder = OlDelFolder.Folders(MyFoldOr)
'On Error Resume Next
OldContactsFoder.Delete
MsPop "Папка " & MyFoldOr & " удалена из корзины.", 1, 1, "Очистка корзины Outlook", 0, 1
DelFol = 1
Set OldContactsFoder = Nothing
End If
Next
End If
Stp = Stp + 1
Wend
'Проверяем корректность удаления папок
If FoldTest (0,"") Then
msb = "Обнаружена неудаленная папка: " & MyFolder & "Скрипт останавливается."
MsPop msb, 0, 0, "Оутглюк", 2, 0
GoodBye
End If
End Sub
'Процедура создания папок
'передаваемые параметры:
'filtip - тип файла адресных книг (0-подразделения, 1-контрагенты)
Sub FoldAdd(filtip)
'Создаем массив для подсчета добавленных контактов в каждом подразделении
KCount = DeptName("","Dl",filtip) - 1'подсчитываем количество подразделений
ReDim arrContExp(KCount, 1)
'Создаем пустые папки с именами заводов и ставим галочку чтобы они отображались в адресах,
'заодно заполняем массив значениями кода региона
'подключаем файл со списком подразделений как массив
'CSV:Код региона(0); Наименование региона(1);
y = 0
If Filtip = 0 Then
DeptFile = OrgDeptFile
Else
DeptFile = KonDeptFile
End If
Set FoldDeptCsv = objFSO.OpenTextFile(DeptFile)
Do While not FoldDeptCsv.AtEndOfStream
arrFoldDeptCsv = Split(FoldDeptCsv.Readline, ";")
Set NewFolder = ContOlFolder.Folders.Add(arrFoldDeptCsv(1))
NewFolder.ShowAsOutlookAB = True
MsPop "Создаем пустую папку " & NewFolder.Name, 1, 1, "Создание папок контактов в Outlook", 0, 1
'Проверяем создалась ли папка
WScript.Sleep 1000
If Not (FoldTest (1, NewFolder.Name)) Then
msb = "Не обнаружена созданная папка: " & NewFolder.Name & ". Скрипт останавливается."
MsPop msb, 0, 0, "Оутглюк", 2, 0
GoodBye
End If
arrContExp(y, 0) = arrFoldDeptCsv(0)
y = y + 1
Loop
FoldDeptCsv.Close
Set NewFolder = Nothing
Set FoldDeptCsv = Nothing
End Sub
'Процедура добавления контактов Outlook в папки подразделений (контрагентов)
'в процессе добавления производится подсчет числа добавляемых контактов
'передаваемые параметры:
'filtip - тип файла адресных книг (0-подразделения, 1-контрагенты)
Sub ContAdd(filtip)
If Filtip = 0 Then
ContFile = OrgContFile
Else
ContFile = KonContFile
End If
'Подключаем csv файл с контактными данными пользователей как массив
'CSV:Изменение(0);Регион(1);Фамилия(2);Имя(3);Отчество(4);Должность(5);
'Подразделение(6);Организация(7);Телефон(8);Мобильный телефон(9);E-mail(10)
MsPop "Производится запуск процесса добавления контактов.", 1, 1, "Добавление контактов в Outlook", 0, 1
Set ContCsv = objFSO.OpenTextFile(ContFile)
Do While not ContCsv.AtEndOfStream
'Построчно читаем csv в массив значений
arrContCsv = Split(ContCsv.Readline, ";")
Em = Instr(arrContCsv(10),"@")
CodReg = StrEdt(arrContCsv(1))
If Em <> 0 And DeptName(Codreg,"Ct",filtip) Then
Foldreg = DeptName(Codreg,"Cn",filtip)
Set NewContactsFoder = ContOlFolder.Folders(Foldreg)
'Создаем новый контакт
Set NewContact = objOutlook.CreateItem(2)
'проверяем условие:
'если адреса контрагентов - что заполнено организация или ФИО
'если ФИО делаем обычный контакт, если Организация - сокращенный вариант
With NewContact
If filtip = 1 And StrEdt(arrContCsv(2)) = "" Then
.FullName = StrEdt(arrContCsv(7))
ElseIf InStr(StrEdt(arrContCsv(2))," ") > 0 Then
'если поле Фамилия содержит пробелы (т.е. состоит более чем из одного слова)
'так же делаем сокращенный вариант
.FullName = StrEdt(arrContCsv(2))
Else
.FullName = StrEdt(arrContCsv(3)) & " " & StrEdt(arrContCsv(2)) ' & " " & StrEdt(arrContCsv(4))
.FirstName = StrEdt(arrContCsv(2))
'.MiddleName = StrEdt(arrContCsv(4))
.LastName = StrEdt(arrContCsv(3))
End If
MsPop "Добавлем контакт " & NewContact.FullName & " в папку " & NewContactsFoder, 1, 1, NewContact.FullName, 0, 2
.Email1Address = StrEdt(arrContCsv(10))
.JobTitle = StrEdt(arrContCsv(5))
.CompanyName = StrEdt(arrContCsv(6))
.BusinessTelephoneNumber = StrEdt(arrContCsv(8))
If Right(StrEdt(arrContCsv(9)),10) <> "" Then
.MobileTelephoneNumber = "+7 " & Right(StrEdt(arrContCsv(9)),10)
End If
.Move NewContactsFoder
.Save()
End With
Set NewContactsFoder = Nothing
Set NewContact = Nothing
'На версии Windows 8 в сочетании с версией Outlook 2010 требуется больше времени на запись контакта
'Почему? я сам так и не понял. Данная цифра - 200 милисекунд получена экспериментальным путем.
'При данном параметре все отрабатывает хорошо
If OsInf > 61 And Mof > 13 Then
'WScript.Sleep 300
End If
'Считаем добавленный контакт
For z = 0 To KCount
If arrContExp(z, 0) = Codreg Then
x = arrContExp(z, 1)
arrContExp(z, 1) = x + 1
End If
Next
End If
Loop
ContCsv.Close
Set ContCsv = Nothing
StartStop 2, 1
'Подводим итоги
msb = ""
For z = 0 To KCount
Codreg = arrContExp(z, 0)
Kont = arrContExp(z, 1)
If DeptName(Codreg,"Ct",filtip) Then
msb = msb & DeptName(Codreg,"Cn",filtip) & ": добавлено " & Kont & " контакта(ов)"
If z < KCount Then msb = msb & vbLf 'для красивого лога
End If
Next
MsPop "Добавление контактов успешно завершено!" & vbLf & msb, 1, 7, "Контакты добавлены!", 0, 0
End Sub
Код:
If OsInf > 61 And Mof > 13 Then 'WScript.Sleep 300 End If Вообще я в программировании не очень силен, поэтому сразу извиняюсь если где косяк увидите... |
|
|
Отправлено: 09:57, 22-01-2014 |
|
Ветеран Сообщения: 27449
|
Профиль | Отправить PM | Цитировать Цитата DaffiSmik:
Код:
For Each objOlFolders In ContOlFolder.Folders Код:
For i = ContOlFolder.Folders.Count - 1 To 0 Step -1 |
|
|
Отправлено: 10:09, 22-01-2014 | #2 |
|
Новый участник Сообщения: 9
|
Профиль | Отправить PM | Цитировать Iska, Спасибо, учту, на всякий пожарный выкладываю весь скрипт целиком, если это поможет решению вопроса было бы здорово. В конечном итоге по большому счету все работает, кроме некоторых нюансов, все равно думал публиковать это решение с подробным описанием, вдруг кому пригодится, да все руки не доходят никак...
Да, еще пробовал ставить счетчик контактов, потом завершать скрипт по записи определенного количества контактов (50,100,150) при этом полностью убрал паузы после записи контакта, получилось что 114 записей производится без вопросов, а дальше не пишется, хотя подсчет контактов идет верный и в массив они пишутся и запоминаются. Попробовал вставлять увеличенную паузу по записи определенного количества контактов (25, 50, 100), слабо помогло часть контактов все равно не записалась, хоть время работы скрипта и сократил... Такое ощущение что сам Outlook не успевает их сохранять. |
|
Последний раз редактировалось DaffiSmik, 22-01-2014 в 10:46. Отправлено: 10:35, 22-01-2014 | #3 |
|
Ветеран Сообщения: 27449
|
Профиль | Отправить PM | Цитировать DaffiSmik, ну, я лично — пас, поскольку:
Цитата:
|
|
|
Отправлено: 11:14, 22-01-2014 | #4 |
|
Новый участник Сообщения: 9
|
Профиль | Отправить PM | Цитировать  просто уже который день гуглю, на мсдн была информация что много поменялось в работе с объектами Outlook начиная с 2010, а все примеры на vb.net и С++ но так как не программист то это для меня вообще темный лес и у меня есть подозрение что я неправильно работаю с объектом Outlook потому у ерунда такая получается...у меня же была более старая версия этого скрипта, которая отрабатывала замечательно, но была беда в том что по заданию планировщика сама 8-ка не давала прав на работу с объектом оутлок, ну и соответственно скрипт запускаемый по расписанию не отрабатывал... О, пока писал, идея появилась... в голове, сейчас сравню скрипты... Попробовал, действительно секунд за 20 выполнилось и все контакты на месте... так полез копать в чем беда... горе от ума... |
|
|
Последний раз редактировалось DaffiSmik, 22-01-2014 в 11:50. Отправлено: 11:39, 22-01-2014 | #5 |
|
Новый участник Сообщения: 9
|
Профиль | Отправить PM | Цитировать Ага нашел проблему:
во всех операционных системах до 8. перед началом работы с Outlook, он закрывался следующей командой: Код:
Set objOutlook = CreateObject("Outlook.Application")
objOutlook.Quit
Код:
Set objOutlook = CreateObject("Outlook.Application")
Set objNameSpace = objOutlook.GetNamespace("MAPI")
Set ContOlFolder = objNameSpace.GetDefaultFolder(10)
Set OlDelFolder = objNameSpace.GetDefaultFolder(3)
в 8-ке, если Outlook был запущен, команда выхода приведенная выше не отрабатывала (при условии что задание обновления запускается из планировщика, если запускать скрипт вручную то все отрабатывает нормально) соответственно следующая команда создания объекта приводила к ошибке и скрипт не выполнялся. Тогда я добавил блок: Код:
If OsInf > 61 Then 'Если версия Windows 8.0 и выше срубаем Outlook
objProc.Terminate
Else ....
Соответственно вопрос: как в 8-ке корректно закрыть работающий Outlook? Если Outlook работает при выполнении команды Set objOutlook = CreateObject("Outlook.Application") скрипт вываливается по ошибке. Есть еще какие-то варианты корректного закрытия Outlook? |
|
Отправлено: 12:48, 22-01-2014 | #6 |
|
Новый участник Сообщения: 9
|
Профиль | Отправить PM | Цитировать Спасибо всем кто принимал участие
разобрался окончательно и решил проблему.Действительно проблема была в неправильном закрытии Outlook'a - как следствие добавленные контакты и не сохранялись, что абсолютно логично (странно что сам этот момент не сразу понял). Решил проблему следующим способом - непосредственно перед запуском процедуры закрытия вставил счетчик, поправил скрипт в процедуре закрытия: Код:
If OsInf > 61 And NumStart = 0 Then 'Если версия Windows 8.0 и это первый запуск, срубаем Outlook
objProc.Terminate
NumStart = NumStart + 1
WScript.Sleep 10000
Else
Set objOutlook = CreateObject("Outlook.Application")
objOutlook.Quit
End If
Вопрос еще такой интересен ли сам скрипт кому-нибудь и имеет ли смысл его выкладывать и описывать? |
|
Отправлено: 13:05, 23-01-2014 | #7 |
|
Пользователь Сообщения: 85
|
Профиль | Отправить PM | Цитировать Цитата DaffiSmik:
За ранее благодарен.. |
|
|
Отправлено: 14:56, 07-04-2017 | #8 |
|
Участник сейчас на форуме |
 |
Участник вне форума |
 |
Автор темы |
 |
Сообщение прикреплено |
| |||||
| Название темы | Автор | Информация о форуме | Ответов | Последнее сообщение | |
| 2010 - Outlook - восстановление контактов | Seemanntech | Microsoft Office (Word, Excel, Outlook и т.д.) | 2 | 16-04-2013 13:40 | |
| 2010 - Windows 8 и Вопрос синхронизации контактов и глобального списка в Outlook 2010 | VVolf | Microsoft Office (Word, Excel, Outlook и т.д.) | 0 | 09-01-2013 17:46 | |
| 2010 - MS OutLook 2010 - отображение контактов в списке писем вместо E-Mail | flower | Microsoft Office (Word, Excel, Outlook и т.д.) | 1 | 22-05-2012 03:17 | |
| V. 5.5/2000/2003 - Синхронизация календарей и контактов Outlook 2010(Exch2003) | sever6159 | Microsoft Exchange Server | 0 | 01-02-2012 15:29 | |
| HTC Touch Cruise сохранение контактов на ПК | astra1970 | Мобильные ОС, смартфоны и планшеты | 5 | 28-09-2009 23:12 | |
|
|
Время: 18:26. | © OSzone.net 2001-
|
|
Powered by: vBulletin Copyright ©2000 - 2025, Jelsoft Enterprises Ltd. |
