मास मेलिंग बनाने के उदाहरण का उपयोग करके VBA के साथ Microsoft आउटलुक को स्वचालित करना

 Set fd = xlApp.FileDialog(msoFileDialogFilePicker) With fd .AllowMultiSelect = False .Title = "   " .Filters.Add " ", "*.txt", 1 If .Show = -1 Then For Each vrtSelectedItem In .SelectedItems Path2To = vrtSelectedItem Next vrtSelectedItem Else Exit Sub End If End With Set fd = Nothing 

 Set fd = xlApp.FileDialog(msoFileDialogFilePicker) With fd .AllowMultiSelect = True .Title = ",   " .Filters.Add " ", "*.*", 1 If .Show = -1 Then i = 0 ReDim Preserve Path2Att(i) For Each vrtSelectedItem In .SelectedItems Path2Att(i) = vrtSelectedItem i = i + 1 ReDim Preserve Path2Att(i) Next vrtSelectedItem Else Exit Sub End If End With Set fd = Nothing 

 Function ReadTXTfile(ByVal filename As String) As String Set FSO = CreateObject("scripting.filesystemobject") Set ts = FSO.OpenTextFile(filename, 1, True): ReadTXTfile = ts.ReadAll: ts.Close Set ts = Nothing: Set FSO = Nothing End Function Function ReadTXTfile2Arr(ByVal filename As String) As Variant Const OpenFileForReading = 1 Const OpenFileForWriting = 2 Const OpenFileForAppending = 8 Const vbSplitAll = -1 Dim S As Variant Set FSO = CreateObject("Scripting.FileSystemObject") Set FSOFile = FSO.GetFile(filename) Set TextStream = FSOFile.OpenAsTextStream(OpenFileForReading) Do While Not TextStream.AtEndOfStream S = S & TextStream.ReadLine & vbNewLine Loop TextStream.Close ReadTXTfile2Arr = Split(S, vbNewLine, vbSplitAll, vbTextCompare) Set TextStream = Nothing Set FSOFile = Nothing Set FSO = Nothing End Function 

 Attribute VB_Name = "Module" Function ReadTXTfile(ByVal filename As String) As String Set FSO = CreateObject("scripting.filesystemobject") Set ts = FSO.OpenTextFile(filename, 1, True): ReadTXTfile = ts.ReadAll: ts.Close Set ts = Nothing: Set FSO = Nothing End Function Function ReadTXTfile2Arr(ByVal filename As String) As Variant Const OpenFileForReading = 1 Const OpenFileForWriting = 2 Const OpenFileForAppending = 8 Const vbSplitAll = -1 Dim S As Variant Set FSO = CreateObject("Scripting.FileSystemObject") Set FSOFile = FSO.GetFile(filename) Set TextStream = FSOFile.OpenAsTextStream(OpenFileForReading) Do While Not TextStream.AtEndOfStream S = S & TextStream.ReadLine & vbNewLine Loop TextStream.Close ReadTXTfile2Arr = Split(S, vbNewLine, vbSplitAll, vbTextCompare) Set TextStream = Nothing Set FSOFile = Nothing Set FSO = Nothing End Function Public Sub Autosender() '      (   ), '     '    ( ) Dim Path2Body As String Dim Path2To As String Dim Path2Att() As String Dim Item2To() As String Dim TxtSubj As String Dim txtBody As Variant Dim i Dim k Dim vrtSelectedItem As Variant Dim fd As FileDialog Dim olMailMessage As Outlook.MailItem Dim xlApp As New Excel.Application GenerateThis = False TxtSubj = InputBox(" ", "") If Len(Trim(TxtSubj)) = 0 Then Exit Sub End If Set fd = xlApp.FileDialog(msoFileDialogFilePicker) With fd .AllowMultiSelect = False .Title = "   " .Filters.Add " ", "*.txt", 1 If .Show = -1 Then For Each vrtSelectedItem In .SelectedItems Path2Body = vrtSelectedItem Next vrtSelectedItem Else Exit Sub End If End With Set fd = Nothing Set fd = xlApp.FileDialog(msoFileDialogFilePicker) With fd .AllowMultiSelect = False .Title = "   " .Filters.Add " ", "*.txt", 1 If .Show = -1 Then For Each vrtSelectedItem In .SelectedItems Path2To = vrtSelectedItem Next vrtSelectedItem Else Exit Sub End If End With Set fd = Nothing Set fd = xlApp.FileDialog(msoFileDialogFilePicker) With fd .AllowMultiSelect = True .Title = ",   " .Filters.Add " ", "*.*", 1 If .Show = -1 Then i = 0 ReDim Preserve Path2Att(i) For Each vrtSelectedItem In .SelectedItems Path2Att(i) = vrtSelectedItem i = i + 1 ReDim Preserve Path2Att(i) Next vrtSelectedItem Else Exit Sub End If End With Set fd = Nothing Set xlApp = Nothing txtBody = ReadTXTfile(Path2Body) Item2To = ReadTXTfile2Arr(Path2To) DoEvents '   'Debug.Print " " 'Debug.Print "-----------------" 'For i = 0 To UBound(Item2To) - 1 ' Debug.Print Item2To(i) 'Next i 'Debug.Print " " 'Debug.Print "-----------------" 'For i = 0 To UBound(Path2Att) - 1 ' Debug.Print Path2Att(i) 'Next i 'Debug.Print " " 'Debug.Print "-----------" 'Debug.Print TxtSubj 'Debug.Print " " 'Debug.Print "-----------" 'Debug.Print txtBody For i = 0 To UBound(Item2To) - 1 Set olMailMessage = Application.CreateItem(olMailItem) With olMailMessage DoEvents .To = Item2To(i) .Subject = TxtSubj .Body = txtBody For k = 0 To UBound(Path2Att) - 1 .Attachments.Add Path2Att(k), olByValue DoEvents Next k .Send End With Set olMailMessage = Nothing Next i MsgBox ".", vbInformation + vbOKOnly, "" End Sub