API tools faq
paste
Advertisement
Guest User

Untitled

a guest
Feb 4th, 2016
181
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 20.41 KB | None | 0 0
raw download clone embed print report
  1. '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  2. ' Test script
  3. '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  4. Option Explicit
  5. On Error Resume Next
  6.  
  7. Dim template
  8. template = ";Automatically generated PRF file" & VbCrLF &_
  9. VbCrLF &_
  10. "; **************************************************************" & VbCrLF &_
  11. "; Section 1 - Profile Defaults" & VbCrLF &_
  12. "; **************************************************************" & VbCrLF &_
  13. VbCrLF &_
  14. "[General]" & VbCrLF &_
  15. "Custom=1" & VbCrLF &_
  16. "ProfileName=ОТДЕЛ КАЧЕСТВА (good)" & VbCrLF &_
  17. "DefaultProfile=No" & VbCrLF &_
  18. "OverwriteProfile=No" & VbCrLF &_
  19. "ModifyDefaultProfileIfPresent=FALSE" & VbCrLF &_
  20. "BackupProfile=No " & VbCrLF &_
  21. "DefaultStore=Service1" & VbCrLF &_
  22. VbCrLF &_
  23. "; **************************************************************" & VbCrLF &_
  24. "; Section 2 - Services in Profile" & VbCrLF &_
  25. "; **************************************************************" & VbCrLF &_
  26. VbCrLF &_
  27. "[Service List]" & VbCrLF &_
  28. "ServiceX=Microsoft Outlook Client" & VbCrLF &_
  29. "ServiceEGS=Exchange Global Section" & VbCrLF &_
  30. "Service1=Microsoft Exchange Server" & VbCrLF &_
  31. "ServiceEGS=Exchange Global Section" & VbCrLF &_
  32. "Service2=Outlook Address Book" & VbCrLF &_
  33. VbCrLF &_
  34. ";***************************************************************" & VbCrLF &_
  35. "; Section 3 - List of internet accounts" & VbCrLF &_
  36. ";***************************************************************" & VbCrLF &_
  37. VbCrLF &_
  38. "[Internet Account List]" & VbCrLF &_
  39. VbCrLF &_
  40. ";***************************************************************" & VbCrLF &_
  41. "; Section 4 - Default values for each service." & VbCrLF &_
  42. ";***************************************************************" & VbCrLF &_
  43. VbCrLF &_
  44. "[ServiceX]" & VbCrLF &_
  45. "CachedExchangeMode=0x00000002" & VbCrLF &_
  46. "CachedExchangeSlowDetect=TRUE" & VbCrLF &_
  47. VbCrLF &_
  48. "[ServiceEGS]" & VbCrLF &_
  49. "CachedExchangeConfigFlags=0x00000100" & VbCrLF &_
  50. "MailboxName=good@yatagan.ru" & VbCrLF &_
  51. "HomeServer=b5b6b60c7b8d4eed8c98078407159c32@yatagan.ru" & VbCrLF &_
  52. "RPCoverHTTPflags=0x002f" & VbCrLF &_
  53. "RPCProxyServer=exchange.atservers.net" & VbCrLF &_
  54. "RPCProxyPrincipalName=msstd:exchange.atservers.net" & VbCrLF &_
  55. "RPCProxyAuthScheme=0x0001" & VbCrLF &_
  56. VbCrLF &_
  57. "[Service1]" & VbCrLF &_
  58. "OverwriteExistingService=No" & VbCrLF &_
  59. "UniqueService=No" & VbCrLF &_
  60. "MailboxName=good@yatagan.ru" & VbCrLF &_
  61. "HomeServer=b5b6b60c7b8d4eed8c98078407159c32@yatagan.ru" & VbCrLF &_
  62. "AccountName=Microsoft Exchange Server" & VbCrLF &_
  63. VbCrLF &_
  64. ";***************************************************************" & VbCrLF &_
  65. "; Section 5 - Values for each internet account." & VbCrLF &_
  66. ";***************************************************************" & VbCrLF &_
  67. VbCrLF &_
  68. ";***************************************************************" & VbCrLF &_
  69. "; Section 6 - Mapping for profile properties" & VbCrLF &_
  70. ";***************************************************************" & VbCrLF &_
  71. VbCrLF &_
  72. "[Microsoft Exchange Server]" & VbCrLF &_
  73. "ServiceName=MSEMS" & VbCrLF &_
  74. "MDBGUID=5494A1C0297F101BA58708002B2A2517" & VbCrLF &_
  75. "MailboxName=PT_STRING8,0x6607" & VbCrLF &_
  76. "HomeServer=PT_STRING8,0x6608" & VbCrLF &_
  77. "OfflineAddressBookPath=PT_STRING8,0x660E" & VbCrLF &_
  78. "OfflineFolderPath=PT_STRING8,0x6610" & VbCrLF &_
  79. VbCrLF &_
  80. "[Exchange Global Section]" & VbCrLF &_
  81. "SectionGUID=13dbb0c8aa05101a9bb000aa002fc45a" & VbCrLF &_
  82. "MailboxName=PT_STRING8,0x6607" & VbCrLF &_
  83. "HomeServer=PT_STRING8,0x6608" & VbCrLF &_
  84. "RPCoverHTTPflags=PT_LONG,0x6623" & VbCrLF &_
  85. "RPCProxyServer=PT_UNICODE,0x6622" & VbCrLF &_
  86. "RPCProxyPrincipalName=PT_UNICODE,0x6625" & VbCrLF &_
  87. "RPCProxyAuthScheme=PT_LONG,0x6627" & VbCrLF &_
  88. "CachedExchangeConfigFlags=PT_LONG,0x6629" & VbCrLF &_
  89. VbCrLF &_
  90. "[Microsoft Mail]" & VbCrLF &_
  91. "ServiceName=MSFS" & VbCrLF &_
  92. "ServerPath=PT_STRING8,0x6600" & VbCrLF &_
  93. "Mailbox=PT_STRING8,0x6601" & VbCrLF &_
  94. "Password=PT_STRING8,0x67f0" & VbCrLF &_
  95. "RememberPassword=PT_BOOLEAN,0x6606" & VbCrLF &_
  96. "ConnectionType=PT_LONG,0x6603" & VbCrLF &_
  97. "UseSessionLog=PT_BOOLEAN,0x6604" & VbCrLF &_
  98. "SessionLogPath=PT_STRING8,0x6605" & VbCrLF &_
  99. "EnableUpload=PT_BOOLEAN,0x6620" & VbCrLF &_
  100. "EnableDownload=PT_BOOLEAN,0x6621" & VbCrLF &_
  101. "UploadMask=PT_LONG,0x6622" & VbCrLF &_
  102. "NetBiosNotification=PT_BOOLEAN,0x6623" & VbCrLF &_
  103. "NewMailPollInterval=PT_STRING8,0x6624" & VbCrLF &_
  104. "DisplayGalOnly=PT_BOOLEAN,0x6625" & VbCrLF &_
  105. "UseHeadersOnLAN=PT_BOOLEAN,0x6630" & VbCrLF &_
  106. "UseLocalAdressBookOnLAN=PT_BOOLEAN,0x6631" & VbCrLF &_
  107. "UseExternalToHelpDeliverOnLAN=PT_BOOLEAN,0x6632" & VbCrLF &_
  108. "UseHeadersOnRAS=PT_BOOLEAN,0x6640" & VbCrLF &_
  109. "UseLocalAdressBookOnRAS=PT_BOOLEAN,0x6641" & VbCrLF &_
  110. "UseExternalToHelpDeliverOnRAS=PT_BOOLEAN,0x6639" & VbCrLF &_
  111. "ConnectOnStartup=PT_BOOLEAN,0x6642" & VbCrLF &_
  112. "DisconnectAfterRetrieveHeaders=PT_BOOLEAN,0x6643" & VbCrLF &_
  113. "DisconnectAfterRetrieveMail=PT_BOOLEAN,0x6644" & VbCrLF &_
  114. "DisconnectOnExit=PT_BOOLEAN,0x6645" & VbCrLF &_
  115. "DefaultDialupConnectionName=PT_STRING8,0x6646" & VbCrLF &_
  116. "DialupRetryCount=PT_STRING8,0x6648" & VbCrLF &_
  117. "DialupRetryDelay=PT_STRING8,0x6649" & VbCrLF &_
  118. VbCrLF &_
  119. "[Personal Folders]" & VbCrLF &_
  120. "ServiceName=MSPST MS" & VbCrLF &_
  121. "Name=PT_STRING8,0x3001" & VbCrLF &_
  122. "PathToPersonalFolders=PT_STRING8,0x6700 " & VbCrLF &_
  123. "RememberPassword=PT_BOOLEAN,0x6701" & VbCrLF &_
  124. "EncryptionType=PT_LONG,0x6702" & VbCrLF &_
  125. "Password=PT_STRING8,0x6703" & VbCrLF &_
  126. VbCrLF &_
  127. "[Unicode Personal Folders]" & VbCrLF &_
  128. "ServiceName=MSUPST MS" & VbCrLF &_
  129. "Name=PT_UNICODE,0x3001" & VbCrLF &_
  130. "PathToPersonalFolders=PT_STRING8,0x6700 " & VbCrLF &_
  131. "RememberPassword=PT_BOOLEAN,0x6701" & VbCrLF &_
  132. "EncryptionType=PT_LONG,0x6702" & VbCrLF &_
  133. "Password=PT_STRING8,0x6703" & VbCrLF &_
  134. VbCrLF &_
  135. "[Outlook Address Book]" & VbCrLF &_
  136. "ServiceName=CONTAB" & VbCrLF &_
  137. VbCrLF &_
  138. "[LDAP Directory]" & VbCrLF &_
  139. "ServiceName=EMABLT" & VbCrLF &_
  140. "ServerName=PT_STRING8,0x6600" & VbCrLF &_
  141. "UserName=PT_STRING8,0x6602" & VbCrLF &_
  142. "UseSSL=PT_BOOLEAN,0x6613" & VbCrLF &_
  143. "UseSPA=PT_BOOLEAN,0x6615" & VbCrLF &_
  144. "DisableVLV=PT_LONG,0x6616" & VbCrLF &_
  145. "DisplayName=PT_STRING8,0x3001" & VbCrLF &_
  146. "ConnectionPort=PT_STRING8,0x6601" & VbCrLF &_
  147. "SearchTimeout=PT_STRING8,0x6607" & VbCrLF &_
  148. "MaxEntriesReturned=PT_STRING8,0x6608" & VbCrLF &_
  149. "SearchBase=PT_STRING8,0x6603" & VbCrLF &_
  150. VbCrLF &_
  151. "[Microsoft Outlook Client]" & VbCrLF &_
  152. "SectionGUID=0a0d020000000000c000000000000046" & VbCrLF &_
  153. "FormDirectoryPage=PT_STRING8,0x0270" & VbCrLF &_
  154. "WebServicesLocation=PT_STRING8,0x0271" & VbCrLF &_
  155. "ComposeWithWebServices=PT_BOOLEAN,0x0272" & VbCrLF &_
  156. "PromptWhenUsingWebServices=PT_BOOLEAN,0x0273" & VbCrLF &_
  157. "OpenWithWebServices=PT_BOOLEAN,0x0274" & VbCrLF &_
  158. "CachedExchangeMode=PT_LONG,0x041f" & VbCrLF &_
  159. "CachedExchangeSlowDetect=PT_BOOLEAN,0x0420" & VbCrLF &_
  160. VbCrLF &_
  161. "[Personal Address Book]" & VbCrLF &_
  162. "ServiceName=MSPST AB" & VbCrLF &_
  163. "NameOfPAB=PT_STRING8,0x001e3001" & VbCrLF &_
  164. "Path=PT_STRING8,0x001e6600" & VbCrLF &_
  165. "ShowNamesBy=PT_LONG,0x00036601" & VbCrLF &_
  166. VbCrLF &_
  167. "; ************************************************************************" & VbCrLF &_
  168. "; Section 7 - Mapping for internet account properties. DO NOT MODIFY." & VbCrLF &_
  169. "; ************************************************************************" & VbCrLF &_
  170. VbCrLF &_
  171. "[I_Mail]" & VbCrLF &_
  172. "AccountType=POP3" & VbCrLF &_
  173. ";--- POP3 Account Settings ---" & VbCrLF &_
  174. "AccountName=PT_UNICODE,0x0002" & VbCrLF &_
  175. "DisplayName=PT_UNICODE,0x000B" & VbCrLF &_
  176. "EmailAddress=PT_UNICODE,0x000C" & VbCrLF &_
  177. ";--- POP3 Account Settings ---" & VbCrLF &_
  178. "POP3Server=PT_UNICODE,0x0100" & VbCrLF &_
  179. "POP3UserName=PT_UNICODE,0x0101" & VbCrLF &_
  180. "POP3UseSPA=PT_LONG,0x0108" & VbCrLF &_
  181. "Organization=PT_UNICODE,0x0107" & VbCrLF &_
  182. "ReplyEmailAddress=PT_UNICODE,0x0103" & VbCrLF &_
  183. "POP3Port=PT_LONG,0x0104" & VbCrLF &_
  184. "POP3UseSSL=PT_LONG,0x0105" & VbCrLF &_
  185. "; --- SMTP Account Settings ---" & VbCrLF &_
  186. "SMTPServer=PT_UNICODE,0x0200" & VbCrLF &_
  187. "SMTPUseAuth=PT_LONG,0x0203" & VbCrLF &_
  188. "SMTPAuthMethod=PT_LONG,0x0208" & VbCrLF &_
  189. "SMTPUserName=PT_UNICODE,0x0204" & VbCrLF &_
  190. "SMTPUseSPA=PT_LONG,0x0207" & VbCrLF &_
  191. "ConnectionType=PT_LONG,0x000F" & VbCrLF &_
  192. "ConnectionOID=PT_UNICODE,0x0010" & VbCrLF &_
  193. "SMTPPort=PT_LONG,0x0201" & VbCrLF &_
  194. "SMTPUseSSL=PT_LONG,0x0202" & VbCrLF &_
  195. "ServerTimeOut=PT_LONG,0x0209" & VbCrLF &_
  196. "LeaveOnServer=PT_LONG,0x1000" & VbCrLF &_
  197. VbCrLF &_
  198. "[IMAP_I_Mail]" & VbCrLF &_
  199. "AccountType=IMAP" & VbCrLF &_
  200. ";--- IMAP Account Settings ---" & VbCrLF &_
  201. "AccountName=PT_UNICODE,0x0002" & VbCrLF &_
  202. "DisplayName=PT_UNICODE,0x000B" & VbCrLF &_
  203. "EmailAddress=PT_UNICODE,0x000C" & VbCrLF &_
  204. ";--- IMAP Account Settings ---" & VbCrLF &_
  205. "IMAPServer=PT_UNICODE,0x0100" & VbCrLF &_
  206. "IMAPUserName=PT_UNICODE,0x0101" & VbCrLF &_
  207. "IMAPUseSPA=PT_LONG,0x0108" & VbCrLF &_
  208. "Organization=PT_UNICODE,0x0107" & VbCrLF &_
  209. "ReplyEmailAddress=PT_UNICODE,0x0103" & VbCrLF &_
  210. "IMAPPort=PT_LONG,0x0104" & VbCrLF &_
  211. "IMAPUseSSL=PT_LONG,0x0105" & VbCrLF &_
  212. "; --- SMTP Account Settings ---" & VbCrLF &_
  213. "SMTPServer=PT_UNICODE,0x0200" & VbCrLF &_
  214. "SMTPUseAuth=PT_LONG,0x0203" & VbCrLF &_
  215. "SMTPAuthMethod=PT_LONG,0x0208" & VbCrLF &_
  216. "SMTPUserName=PT_UNICODE,0x0204" & VbCrLF &_
  217. "SMTPUseSPA=PT_LONG,0x0207" & VbCrLF &_
  218. "ConnectionType=PT_LONG,0x000F" & VbCrLF &_
  219. "ConnectionOID=PT_UNICODE,0x0010" & VbCrLF &_
  220. "SMTPPort=PT_LONG,0x0201" & VbCrLF &_
  221. "SMTPUseSSL=PT_LONG,0x0202" & VbCrLF &_
  222. "ServerTimeOut=PT_LONG,0x0209" & VbCrLF &_
  223. "CheckNewImap=PT_LONG,0x1100" & VbCrLF &_
  224. "RootFolder=PT_UNICODE,0x1101" & VbCrLF &_
  225. VbCrLF &_
  226. "[INET_HTTP]" & VbCrLF &_
  227. "AccountType=HOTMAIL" & VbCrLF &_
  228. "Account=PT_UNICODE,0x0002" & VbCrLF &_
  229. "HttpServer=PT_UNICODE,0x0100" & VbCrLF &_
  230. "UserName=PT_UNICODE,0x0101" & VbCrLF &_
  231. "Organization=PT_UNICODE,0x0107" & VbCrLF &_
  232. "UseSPA=PT_LONG,0x0108" & VbCrLF &_
  233. "TimeOut=PT_LONG,0x0209" & VbCrLF &_
  234. "Reply=PT_UNICODE,0x0103" & VbCrLF &_
  235. "EmailAddress=PT_UNICODE,0x000C" & VbCrLF &_
  236. "FullName=PT_UNICODE,0x000B" & VbCrLF &_
  237. "Connection Type=PT_LONG,0x000F" & VbCrLF &_
  238. "ConnectOID=PT_UNICODE,0x0010" & VbCrLF
  239.  
  240.  
  241. Dim objShell, fso
  242. Set objShell = WScript.CreateObject("WScript.Shell")
  243. Set fso = CreateObject("Scripting.FileSystemObject")
  244.  
  245. 'Check for valid windows version
  246. If Not CheckWindowsVersion Then
  247. ExitWithError("UnsupportedVersion")
  248. End If
  249.  
  250. 'Get Outlook Path
  251. Dim outlookPath
  252. outlookPath = GetOutlookPath
  253. If outlookPath = "" Then
  254. ExitWithError("OutlookNotFound")
  255. End If
  256.  
  257. 'Check that Outlook does not running
  258. Dim answer
  259. Do While True
  260. If CheckOutlookIsRunning Then
  261. answer = MsgBox(GetString("OutlookIsRunning"), vbRetryCancel ,GetString ("MessageCaption"))
  262. If answer = vbCancel Then
  263. WScript.Quit
  264. End If
  265. Else
  266. Exit Do
  267. End If
  268. Loop
  269.  
  270. 'Adjust Outlook registry settings
  271. AdjustSettings
  272.  
  273. ' Configure Autodiscover for Custom email address
  274. Dim customEmail
  275. customEmail = ""
  276.  
  277. If customEmail <> "" Then
  278. ConfigureAutodiscover customEmail
  279. End If
  280.  
  281. 'Create temporary file for Outlook profile
  282. Dim tempFile, tempFileName
  283. tempFileName = GetTempFileName
  284. If Err.Number <> 0 Then
  285. ExitWithError("ProfileCreateError")
  286. End If
  287. Set tempFile = fso.CreateTextFile(tempFileName, true, true)
  288. If Err.Number <> 0 Then
  289. ExitWithError("ProfileCreateError")
  290. End If
  291.  
  292. 'Write profile to file
  293. tempFile.Write(template)
  294. If Err.Number <> 0 Then
  295. ExitWithError("ProfileWriteError")
  296. End If
  297. tempFile.Close
  298.  
  299. 'Start Outlook
  300. objShell.Exec(outlookPath + " /importprf """ + tempFileName + """")
  301.  
  302. Function CheckWindowsVersion
  303.  
  304. On Error Resume Next
  305. Dim objWMI, colOS, objOS, version
  306. set objWMI = GetObject("winmgmts:\\.\root\cimv2")
  307. set colOS = objWMI.InstancesOf("Win32_OperatingSystem")
  308.  
  309. For Each objOS in colOS
  310. version = objOS.Version
  311. If objOS.OSType = 18 Then
  312. If Left(version, 1) > 5 Then
  313. ' Windows Vista or Windows Server 2008
  314. CheckWindowsVersion = True
  315. Exit Function
  316. ElseIf Left(version, 1) = 5 And Mid(version, 3, 1) = 2 Then
  317. If objOS.OtherTypeDescription = "R2" Then
  318. ' Windows Server 2003 R2
  319. CheckWindowsVersion = True
  320. Exit Function
  321. ElseIf objOS.ProductType = 1 Then
  322. ' Windows XP Professional x64 Edition
  323. CheckWindowsVersion = True
  324. Exit Function
  325. Else
  326. ' Windows Server 2003
  327. If objOS.ServicePackMajorVersion = 0 Then
  328. ' no any Service Pack
  329. CheckWindowsVersion = False
  330. Exit Function
  331. End If
  332. CheckWindowsVersion = True
  333. Exit Function
  334. End If
  335. ElseIf Left(version, 1) = 5 And Mid(version, 3, 1) = 1 Then
  336. 'Microsoft Windows XP
  337. If objOS.ServicePackMajorVersion > 1 Then
  338. ' SP2 or later
  339. CheckWindowsVersion = True
  340. Exit Function
  341. ElseIf objOS.ServicePackMajorVersion = 1 Then
  342. ' SP1, check for installed KB331320
  343. Err.Clear
  344. objShell.RegRead("HKLM\SOFTWARE\Microsoft\Updates\Windows XP\SP1\KB331320\")
  345. If Err.Number = 0 Then
  346. CheckWindowsVersion = True
  347. Exit Function
  348. End If
  349. End If
  350. End If
  351. End If
  352. Next
  353. CheckWindowsVersion = False
  354.  
  355. End Function
  356.  
  357. Function GetOutlookPath
  358.  
  359. On Error Resume Next
  360. Dim CLSID, path
  361.  
  362. ' First of all check simple location
  363. path = objShell.RegRead("HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\OUTLOOK.EXE\")
  364. If path <> "" Then
  365. GetOutlookPath = path
  366. Exit Function
  367. End If
  368.  
  369. CLSID = objShell.RegRead("HKLM\Software\Classes\Outlook.Application\CLSID\")
  370. If Err.Number <> 0 Then
  371. GetOutlookPath ""
  372. Exit Function
  373. End If
  374. path = objShell.RegRead("HKLM\Software\Classes\CLSID\" & CLSID & "\LocalServer32\")
  375.  
  376. ' Does need to check alternative path ?
  377. if path = "" Then
  378. path = objShell.RegRead("HKLM\SOFTWARE\Wow6432Node\Classes\CLSID\" & CLSID & "\LocalServer32\")
  379. End If
  380.  
  381. ' If we have an error path will be empty
  382. GetOutlookPath = path
  383.  
  384. End Function
  385.  
  386. Function CheckOutlookIsRunning
  387.  
  388. On Error Resume Next
  389. Dim objWMIService, processList
  390. Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
  391. Set processList = objWMIService.ExecQuery("Select * from Win32_Process Where Name = ""outlook.exe""")
  392. If processList.Count > 0 Then
  393. CheckOutlookIsRunning = True
  394. Exit Function
  395. End If
  396. CheckOutlookIsRunning = False
  397.  
  398. End Function
  399.  
  400. Sub AdjustSettings
  401.  
  402. objShell.RegWrite "HKCU\Software\Microsoft\Exchange\Client\Options\PickLogonProfile", "1", "REG_SZ"
  403.  
  404. End Sub
  405.  
  406. Function GetTempFileName
  407.  
  408. Dim tfolder, tname, tfile
  409. Const TemporaryFolder = 2
  410. Set tfolder = fso.GetSpecialFolder(TemporaryFolder)
  411. tname = fso.GetTempName
  412. tfile = fso.BuildPath(tfolder.Path, tname)
  413. GetTempFileName = tfile
  414.  
  415. End Function
  416.  
  417. Function ExitWithError(stringId)
  418.  
  419. MsgBox GetString(stringId), vbOKOnly, GetString("MessageCaption")
  420. WScript.Quit
  421.  
  422. End Function
  423.  
  424. Function GetString(stringId)
  425.  
  426. Dim messageCaption, outlookNotFound, outlookIsRunning, profileCreateError, profileWriteError, unsupportedVersion
  427. messageCaption = "Сценарий настройки профиля Outlook"
  428. outlookNotFound = "Невозможно определить путь установки Microsoft Outlook."
  429. outlookIsRunning = "Сценарий настройки определил, что Microsoft Outlook запущен. Пожалуйста, закройте программу и нажмите кнопку Повторить."
  430. profileCreateError = "Невозможно создать временный файл для профиля."
  431. profileWriteError = "Невозможно сохранить профиль во временный файл."
  432. unsupportedVersion = "Неподдерживаемая версия Microsoft Windows. " & vbLf & "" & vbLf & "Поддерживаются следующие версии Microsoft Windows: " & vbLf & " - Microsoft Windows XP с пакетом обновления 2;" & vbLf & " - Windows Server 2003 с пакетом обновления 1;" & vbLf & " - операционная система более поздней версии."
  433. Dim retStr
  434. Select Case stringId
  435. Case "MessageCaption"
  436. If messageCaption = "" Or Mid(messageCaption, 2, 1) = "4" Then
  437. retStr = "Outlook Profile Configuration Script"
  438. Else
  439. retStr = messageCaption
  440. End If
  441. Case "OutlookNotFound"
  442. If outlookNotFound = "" Or Mid(outlookNotFound, 2, 1) = "5" Then
  443. retStr = "Unable to locate Microsoft Outlook installation path."
  444. Else
  445. retStr = outlookNotFound
  446. End If
  447. Case "OutlookIsRunning"
  448. If outlookIsRunning = "" Or Mid(outlookIsRunning, 2, 1) = "6" Then
  449. retStr = "Configuration script has determined that Microsoft Outlook is running. Please shut down it and then click Retry."
  450. Else
  451. retStr = outlookIsRunning
  452. End If
  453. Case "ProfileCreateError"
  454. If profileCreateError = "" Or Mid(profileCreateError, 2, 1) = "7" Then
  455. retStr = "Unable to create a temporary file for profile."
  456. Else
  457. retStr = profileCreateError
  458. End If
  459. Case "profileWriteError"
  460. If profileWriteError = "" Or Mid(profileWriteError, 2, 1) = "8" Then
  461. retStr = "Unable to save profile into temporary file."
  462. Else
  463. retStr = profileWriteError
  464. End If
  465. Case "UnsupportedVersion"
  466. If unsupportedVersion = "" Or Mid(unsupportedVersion, 2, 1) = "9" Then
  467. retStr = "Unsupported version of Microsoft Windows. " & vbLf & "" & vbLf & "The following versions of Microsoft Windows are supported: " & vbLf & " - Microsoft Windows XP with Service Pack 2 " & vbLf & " - Windows Server 2003 with Service Pack 1 " & vbLf & " - or a later operating system"
  468. Else
  469. retStr = unsupportedVersion
  470. End If
  471. Case Else
  472. retStr = stringId
  473. End Select
  474. GetString = retStr
  475. End Function
  476.  
  477. Sub ConfigureAutodiscover(email)
  478.  
  479. On Error Resume Next
  480. Dim configTemplate
  481. configTemplate = "<?xml version=""1.0"" encoding=""utf-8""?>" & VbCrLF &_
  482. "<Autodiscover xmlns=""http://schemas.microsoft.com/exchange/autodiscover/responseschema/2006"">" & VbCrLF &_
  483. " <Response xmlns=""http://schemas.microsoft.com/exchange/autodiscover/outlook/responseschema/2006a"">" & VbCrLF &_
  484. " <Account>" & VbCrLF &_
  485. " <AccountType>email</AccountType>" & VbCrLF &_
  486. " <Action>redirectUrl</Action>" & VbCrLF &_
  487. " <RedirectUrl>https://exchange.atservers.net/autodiscoverproxy/autodiscover.xml</RedirectUrl>" & VbCrLF &_
  488. " </Account>" & VbCrLF &_
  489. " </Response>" & VbCrLF &_
  490. "</Autodiscover>" & VbCrLF
  491.  
  492. Dim folder
  493. Dim objEnv
  494. ' Get collection by using the Environment property.
  495. Set objEnv = objShell.Environment("Process")
  496. folder = objEnv("APPDATA") + "\Outlook\"
  497.  
  498. ' Check that Outlook is available
  499. Dim ver
  500. ver = objShell.RegRead("HKCR\Outlook.Application\CurVer\")
  501. If Err.Number <> 0 Then
  502. Exit Sub
  503. End If
  504.  
  505. ' Outlook.Application.XX -> XX
  506. ver = Right(ver, 2)
  507.  
  508. Dim mailDomain, configFilePath, configFile
  509. mailDomain = Mid(email, Instr(email, "@") + 1)
  510. If Not fso.FolderExists(folder) Then
  511. fso.CreateFolder(folder)
  512. End If
  513. configFilePath = folder & mailDomain & ".xml"
  514. Set configFile = fso.CreateTextFile(configFilePath, True)
  515. configFile.Write(configTemplate)
  516. configFile.Close
  517. objShell.RegWrite "HKCU\Software\Microsoft\Office\" & ver & ".0\Outlook\AutoDiscover\" & mailDomain, configFilePath, "REG_SZ"
  518. End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement
Public Pastes
Advertisement
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!