Эта прога предназначена для массовой рассылки похожих писем через публичный сервер типа Mail.ru. Эта прога требуется в том случае, если порты аутентификации SMTP закрыты и прямая рассылка невозможна.

На вход проги поступают несколько шаблонов, указываемых ей в качестве входных параметров проги. Прога формирует итоговый BAT-Файл, с вызываемыми WSH-скриптами - именно такая схема рассылки на практике оказалась удобнее, чем пакетные задания в WSF-файле, ибо именно так удобнее сделать Terminate Job или Schedule job.

00001: Option Strict Off
00002: Module Module1
00003: 
00004:     Sub Main()
00005:         Dim BodyTemplate As String = ReadMyFile("BodyTemplate")
00006:         Dim WshTemplate As String = ReadMyFile("WshTemplate")
00007:         Dim Mail As String, ScriptName As String, MultiLineWsh As String, BodyWithSendkey As String, k As Integer, www As String
00008:         Dim XLS As New Microsoft.Office.Interop.Excel.Application
00009:         XLS.Workbooks.Open(My.MySettings.Default.Item("XLS"))
00010:         FileOpen(2, My.MySettings.Default.Item("OUTFilePath").ToString & "Packet.bat", OpenMode.Output, OpenAccess.Write, OpenShare.LockWrite)
00011:         Dim i As Integer, j As Integer = 0
00012:         For i = 1 To 1000
00013:             If XLS.Cells(i, 1).value = "" Then
00014:                 j += 1
00015:             Else
00016:                 'взяли мыло и www из XLS-файла
00017:                 www = XLS.Cells(i, My.MySettings.Default.Item("wwwColumn")).value
00018:                 Mail = XLS.Cells(i, My.MySettings.Default.Item("MailColumn")).value
00019:                 ScriptName = My.MySettings.Default.Item("OUTFilePath").ToString & Replace(www, ".", "_") & ".wsf"
00020:                 Print(2, "cscript """ & ScriptName & """" & vbCrLf)
00021:                 '
00022:                 FileOpen(1, ScriptName, OpenMode.Output, OpenAccess.Write, OpenShare.LockWrite)
00023:                 'вставили мыло в скрипт
00024:                 MultiLineWsh = ""
00025:                 MultiLineWsh = Replace(WshTemplate, "XXX", Mail)
00026:                 'обработка строк тела письма
00027:                 Dim A() As String = BodyTemplate.Split(vbCrLf)
00028:                 BodyWithSendkey = ""
00029:                 For k = 0 To A.Length - 1
00030:                     If InStr(A(k), "XXX") > 0 Then
00031:                         'если эта строка тела содержит XXX, то сюда надо вставить В ДРУГОМ регистре название,определенное в файле Excel
00032:                         BodyWithSendkey &= "WshShell.SendKeys """ & Replace(Replace(A(k), "XXX", ""), vbLf, "") & """" & vbCrLf
00033:                         'текст из Excela вставляем ТОЛЬКО в конец строки
00034:                         BodyWithSendkey &= "WshShell.SendKeys ""^+""" & vbCrLf
00035:                         BodyWithSendkey &= "WshShell.SendKeys """ & www & """" & vbCrLf
00036:                         BodyWithSendkey &= "WshShell.SendKeys ""^+""" & vbCrLf
00037:                         BodyWithSendkey &= "WshShell.SendKeys ""~""" & vbCrLf
00038:                     Else
00039:                         BodyWithSendkey &= "WshShell.SendKeys """ & Replace(A(k), vbLf, "") & """" & vbCrLf
00040:                     End If
00041:                 Next
00042:                 Print(1, Replace(MultiLineWsh, "YYY", BodyWithSendkey))
00043:                 FileClose(1)
00044:             End If
00045:             If j > 10 Then Exit For
00046:         Next
00047:         XLS.Workbooks.Close()
00048:         XLS.Quit()
00049:         XLS = Nothing
00050:         FileClose(2)
00051:     End Sub
00052: 
00053:     Private Function ReadMyFile(ByVal SetingName As String) As String
00054:         FileOpen(1, My.MySettings.Default.Item(SetingName), OpenMode.Input, OpenAccess.Read, OpenShare.Shared)
00055:         While Not EOF(1)
00056:             ReadMyFile &= LineInput(1) & vbCrLf
00057:         End While
00058:         FileClose(1)
00059:     End Function
00060: 
00061: End Module

< THANKS ME>