DaffiSmik
22-01-2014, 09:57
Доброго дня!!!
Используем в компании скрипт для формирования адресной книги. На всех клиентах отрабатывает нормально, но на 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
Если я ставлю WScript.Sleep значение 700 то в принципе все отрабатывает и контакты добавляются, но у меня больше 300 контактов сотрудников и процедура занимает несколько минут. При том что у меня на ХР с 2003 офисом и полудохлым компом все пролетает за 30 сек. Первоначально на 8 возникали проблемы с подключением к объекту Outlook, вставил паузу вроде стало отрабатывать, тут эта проблема появилась...
Вообще я в программировании не очень силен, поэтому сразу извиняюсь если где косяк увидите...
Используем в компании скрипт для формирования адресной книги. На всех клиентах отрабатывает нормально, но на 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
Если я ставлю WScript.Sleep значение 700 то в принципе все отрабатывает и контакты добавляются, но у меня больше 300 контактов сотрудников и процедура занимает несколько минут. При том что у меня на ХР с 2003 офисом и полудохлым компом все пролетает за 30 сек. Первоначально на 8 возникали проблемы с подключением к объекту Outlook, вставил паузу вроде стало отрабатывать, тут эта проблема появилась...
Вообще я в программировании не очень силен, поэтому сразу извиняюсь если где косяк увидите...