1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
| Const olFolderDeletedItems = 3
Const olFolderOutbox = 4
Const olFolderSentMail = 5
Const olFolderInbox = 6
Const olFolderCalendar = 9
Const olFolderContacts = 10
Const olFolderJournal = 11
Const olFolderNotes = 12
Const olFolderTasks = 13
Const olFolderDrafts = 16
Const olPublicFoldersAllPublicFolders = 18
Const olFolderConflicts = 19
Const olFolderSyncIssues = 20
Const olFolderLocalFailures = 21
Const olFolderServerFailures = 22
Const olFolderJunk = 23
Dim objOutlook
Dim objExplorer
Dim objNameSpace
Dim arrContCsv
Dim objOLAdress
Dim objOlFolders
Dim ContOlFolder
Dim NewContact
Dim ConOlItems
Dim BbFolder
Dim BoFolder
Dim IzFolder
Dim NNFolder
Dim OrFolder
Dim TlFolder
On Error Resume Next
Set ms = CreateObject("WScript.Shell")
Set fs = CreateObject("Scripting.FileSystemObject")
Set Wnet = CreateObject("WScript.Network")
Set objOutlook = CreateObject("Outlook.Application")
Set objNameSpace = objOutlook.GetNamespace("MAPI")
Set ContOlFolder = objNameSpace.GetDefaultFolder(10)
Set ConOlItems = ContOlFolder.Items
'Работаем с сетью и файловой системой
'Подключаем сетевую папку монтируем, как диск K:
Net_f = "\\192.168.0.11\Contacts"
Wnet.MapNetworkDrive "K:", Net_f, "True"
'Проверяем монтирование
If Err.Number <> 0 Then
MsgBox "Сетевая папка " & Net_f & " не найдена. Проверьте сетевые подключения. Скрипт останавливается", _
vbCritical, "Ошибка монтирования диска..."
Wnet.RemoveNetworkDrive "K:"
WScript.Quit
Else
ms.Popup "Подключена сетевая папка " & Net_f & " как диск K:",1 , "Монтирование сетевой папки", _
vbOkOnly+vbInformation
End If
'Тестовое подключение к csv
Set ContCsv = fs.OpenTextFile("K:\allcontacts.csv")
'Set ContCsv = fs.OpenTextFile("c:\konsib.local.csv")
If Err.Number = 0 Then
Do While ContCsv.AtEndOfStream <> True
'Построчно читаем csv в массив значений
arrContCsv = Split(ContCsv.Readline, ";")
'Проверяем, количество элементов массива
If UBound(arrContCsv) < 10 Then
MsgBox "Неверный формат файла данных. Загрузка данных отменена", _
vbCritical, "Ошибка файла данных..."
Wnet.RemoveNetworkDrive "K:"
WScript.Quit
Else
ContCsv.Close
Exit Do
End If
Loop
Else
MsgBox "Не удалось подключиться к файлу данных. Пригласите системного администратора"
Wnet.RemoveNetworkDrive "K:"
WScript.Quit
End If
'Удаляем папки Подразделений в папке Контакты
'Первый For задает количество проходов для удаления папок. Я хз... почему но с
'первого прохода второй For все папки не удаляет, поэтому если последующая проверка корректости
'папок блюется рекомендую увеличить конечный параметр DelFol
For DelFol = 1 To 5
For Each objOlFolders In ContOlFolder.Folders
'Удаляем папки подразделений
MyFolder = objOlFolders.Name
If GetName (MyFolder,0) Then
ms.Popup "Удаляем папку " & MyFolder, 1, "Удаление папок контактов в Outlook", _
vbOkOnly+vbInformation
objOlFolders.ShowAsOutlookAB = False
objOlFolders.Delete
End If
Next
Next
'Ждем 5 сек. чтобы отработало удаление папок
'WScript.Sleep 5000
'Проверяем корректность удаления папок
For Each objOlFolders In ContOlFolder.Folders
'Проверяем все ли папки удалились корректно, если нет - завершаем скрипт
MyFolder = objOlFolders.Name
If GetName (MyFolder,0) Then
MsgBox "Обнаружена неудаленная папка: " & MyFolder & "Скрипт останавливается."
Wnet.RemoveNetworkDrive "K:"
WScript.Quit
End If
Next
'Создаем пустые папки с именами подразделений и ставим галочку чтобы они отображались в адресах
Set BbFolder = ContOlFolder.Folders.Add("Подразделение 1")
BbFolder.ShowAsOutlookAB = True
ms.Popup "Создаем пустую папку " & BbFolder.Name, 1, "Создание папок контактов в Outlook", vbOkOnly+vbInformation
Set BoFolder = ContOlFolder.Folders.Add("Подразделение 2")
BoFolder.ShowAsOutlookAB = True
ms.Popup "Создаем пустую папку " & BoFolder.Name, 1, "Создание папок контактов в Outlook", vbOkOnly+vbInformation
Set IzFolder = ContOlFolder.Folders.Add("Подразделение 3")
IzFolder.ShowAsOutlookAB = True
ms.Popup "Создаем пустую папку " & IzFolder.Name, 1, "Создание папок контактов в Outlook", vbOkOnly+vbInformation
Set NNFolder = ContOlFolder.Folders.Add("Подразделение 4")
NNFolder.ShowAsOutlookAB = True
ms.Popup "Создаем пустую папку " & NNFolder.Name, 1, "Создание папок контактов в Outlook", vbOkOnly+vbInformation
Set OrFolder = ContOlFolder.Folders.Add("Подразделение 5")
OrFolder.ShowAsOutlookAB = True
ms.Popup "Создаем пустую папку " & OrFolder.Name, 1, "Создание папок контактов в Outlook", vbOkOnly+vbInformation
Set TlFolder = ContOlFolder.Folders.Add("Подразделение 6")
TlFolder.ShowAsOutlookAB = True
ms.Popup "Создаем пустую папку " & TlFolder.Name, 1, "Создание папок контактов в Outlook", vbOkOnly+vbInformation
'Обнуляем счетчики добавляемых контактов
Bbk = 0
Bok = 0
Izk = 0
Nnk = 0
Ork = 0
Tlk = 0
'Подключаем csv как массив
'CSV:Изменение(0);Регион(1);Фамилия(2);Имя(3);Отчество(4);Должность(5);
'Подразделение(6);Организация(7);Телефон(8);Мобильный телефон(9);E-mail(10)
Set ContCsv = fs.OpenTextFile("K:\allcontacts.csv")
Do While not ContCsv.AtEndOfStream
'Построчно читаем csv в массив значений
arrContCsv = Split(ContCsv.Readline, ";")
Em = Instr(arrContCsv(10),"@")
CodReg = StrEdt(arrContCsv(1))
If Em <> 0 And GetName(Codreg,1) Then
'Определяем код региона и отдаем его переменной Foldreg, заодно увеличиваем счетчик добавленных контактов
If CodReg = "22b" Then
Foldreg = BbFolder
Bbk = Bbk + 1
ElseIf CodReg = "22o" Then
Foldreg = BoFolder
Bok = Bok + 1
ElseIf CodReg = "18" Then
Foldreg = IzFolder
Izk = Izk + 1
ElseIf CodReg = "52" Then
Foldreg = NNFolder
Nnk = Nnk + 1
ElseIf CodReg = "57" Then
Foldreg = OrFolder
Ork = Ork + 1
ElseIf CodReg = "63" Then
Foldreg = TlFolder
Tlk = Tlk + 1
End If
Set NewContactsFoder = ContOlFolder.Folders(Foldreg)
'Создаем новый контакт
Set NewContact = objOutlook.CreateItem(2)
NewContact.FullName = StrEdt(arrContCsv(3)) & " " & StrEdt(arrContCsv(2)) ' & " " & StrEdt(arrContCsv(4))
NewContact.FirstName = StrEdt(arrContCsv(2))
'NewContact.MiddleName = StrEdt(arrContCsv(4))
NewContact.LastName = StrEdt(arrContCsv(3))
'NewContact.LastNameAndFirstName = StrEdt(arrContCsv(2)) & " " & StrEdt(arrContCsv(3)) & " " & StrEdt(arrContCsv(4))
NewContact.Email1Address = StrEdt(arrContCsv(10))
'NewContact.Email1DisplayName = StrEdt(arrContCsv(2)) & " " & StrEdt(arrContCsv(3)) & " " & StrEdt(arrContCsv(10))
NewContact.JobTitle = StrEdt(arrContCsv(5))
NewContact.CompanyName = StrEdt(arrContCsv(6))
NewContact.BusinessTelephoneNumber = StrEdt(arrContCsv(8))
If Right(StrEdt(arrContCsv(9)),10) <> "" Then
NewContact.MobileTelephoneNumber = "+7 " & Right(StrEdt(arrContCsv(9)),10)
End If
NewContact.Move NewContactsFoder
NewContact.Save()
End If
Loop
ms.Popup "Добавление контактов успешно завершено!" & vbLf & vbLf & BbFolder & ": добавлено " & Bbk & " контакта(ов)" _
& vbLf & BoFolder & ": добавлено " & Bok & " контакта(ов)" & vbLf & IzFolder & ": добавлено " & Izk & " контакта(ов)" _
& vbLf & NNFolder & ": добавлено " & Nnk & " контакта(ов)" & vbLf & OrFolder & ": добавлено " & Ork & " контакта(ов)" _
& vbLf & TlFolder & ": добавлено " & Tlk & " контакта(ов)", 7, "Контакты добавлены!", vbOkOnly+vbInformation
ContCsv.Close
Wnet.RemoveNetworkDrive "K:"
'=============================================================================
'=============================================================================
'Функция обработки строк:
Function StrEdt(St)
StrEdt = Mid(St,2,Len(St)-2)
End Function
'Функция для работы с папками, передается 2 параметра:
'Zn - передаваемый параметр в зависимости от Top
'Top - тип операции имеет следующие значения: 0 - проверка имени папки, 1 - проверка кода региона
Function GetName(Zn,Top)
If Top = 0 Then
If Zn = "Подразделение 1" Then
GetName = True
Exit Function
ElseIf Zn = "Подразделение 2" Then
GetName = True
Exit Function
ElseIf Zn = "Подразделение 3" Then
GetName = True
Exit Function
ElseIf Zn = "Подразделение 4" Then
GetName = True
Exit Function
ElseIf Zn = "Подразделение 5" Then
GetName = True
Exit Function
ElseIf Zn = "Подразделение 6" Then
GetName = True
Exit Function
Else
GetName = False
Exit Function
End If
ElseIf Top = 1 Then
If Zn = "22b" Then
GetName = True
Exit Function
ElseIf Zn = "22o" Then
GetName = True
Exit Function
ElseIf Zn = "18" Then
GetName = True
Exit Function
ElseIf Zn = "52" Then
GetName = True
Exit Function
ElseIf Zn = "57" Then
GetName = True
Exit Function
ElseIf Zn = "63" Then
GetName = True
Exit Function
Else
GetName = False
Exit Function
End If
End If
End Function |
(
