zoukankan      html  css  js  c++  java
  • 调用outlook来发送邮件

    背景

    大批量的进行添附文件和发送邮件,如果一个一个操作的话比较慢,所以打算用VBA来调用,进行发送邮件。

    subject:发送邮件的主题

    body:发送邮件的内容

    outlook指定アドレス:outlook可以登入多个邮件的账号,是指定用哪一个邮件进行发送

    环境:指定用测试环境还是真正的环境来进行测试。

    テストアドレス:是利用哪一个邮件进行测试

    需要引用outlook library

       

    全局常量定义

    Public Const sendMailAddresRow As Integer = 17
    Public Const sendMailAddresMaxRow As Integer = 10000
    

      

    クリアのクリックイベント

    Sub clear_Click()
        
        Dim sht As Object
        Set sht = ActiveSheet
        sht.Range("B17:E10000").Clear
    End Sub

    アドレス取得

    Sub getMailInfo_Click()
    
        Dim sht As Object
        Set sht = ActiveSheet
        Dim filepath As String
        filepath = sht.Range("C3")
       
        Dim arr()
        arr = Array(CStr(sht.Range("C4").Value), CStr(sht.Range("C5").Value))
        
        
        
        Dim index As Integer
        index = 17
        
        For j = 0 To UBound(arr)
            If arr(j) = "" Then
                Exit For
            End If
            Dim wb As Workbook
            Set wb = Workbooks.Open(filepath + "" + arr(j))
            For Each Sheet In wb.Sheets
                For i = 2 To 100000
                    If Sheet.Range("A" & i) = "" Then
                        Exit For
                    End If
                    If Sheet.Range("F" & i) <> "" Then
                        sht.Range("B" & index) = index - 16
                        sht.Range("C" & index) = Sheet.Range("A" & i)
                        sht.Range("D" & index) = Sheet.Range("F" & i)
                        index = index + 1
                    End If
                Next
            Next
            wb.Close
        Next
        
        
        Range("B17:D" & index - 1).Select
        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
        With Selection.Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With Selection.Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With Selection.Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        MsgBox "完了"
    End Sub
     

    发送邮件

    Sub openOutlook_Click()
        
        Dim sht As Object
        Set sht = ActiveSheet
        
        Dim filepath As String
        filepath = sht.Range("C6")
        Dim attachFileArr()
        attachFileArr = Array(CStr(sht.Range("C7").Value), CStr(sht.Range("C8").Value))
        
       
        Dim subject As String
        subject = sht.Range("I3")
        
        
        
        
        Dim address As String
        address = sht.Range("I7")
        
        
    On Error GoTo OpenOutlook_Error
        For i = sendMailAddresRow To sendMailAddresMaxRow
            If sht.Range("E" & i) = "乑" Then
                
                Dim objOutlookApp As Outlook.Application
                Set objOutlookApp = New Outlook.Application
                Dim objAccount As Account
                '邮件附件对象
    
                Dim objAttachment As Outlook.Attachment
                With objOutlookApp
                    For Each objAccount In .Session.Accounts
                        If objAccount.AccountType = olPop3 And objAccount.DisplayName = address Then
                            
                            Dim outlookApp As Outlook.Application
                            Dim outlookItem As Outlook.MailItem
                            
                            Set outlookApp = New Outlook.Application
                            Set outlookItem = outlookApp.CreateItem(olMailItem)
                            
                            body = readText(ThisWorkbook.Path & "" & sht.Range("I5"))
                            body = sht.Range("C" & i) & Chr(10) & "扴摉幰孠" & Chr(10) & Chr(10) & body
                            
                            
                            
                            Dim toAddres As String
                            If sht.Range("I9") = "dev" Then
                                toAddres = sht.Range("I11")
                            Else
                                toAddres = sht.Range("D" & i)
                            End If
                            
                            
                            With outlookItem
                                .To = toAddres
                                .subject = subject
                                .body = body
                                 For j = 0 To UBound(attachFileArr)
                                    If attachFileArr(j) <> "" Then
                                        .Attachments.Add filepath + "" + attachFileArr(j)
                                    End If
                                    
                                 Next
                                '.Attachments.Add "C:UsersDesktopaaXXX.pdf"
                                '.Attachments.Add "C:UsersJDesktopaaFFF.pdf"
                                '.Send  因为不直接发送邮件所以此处注释掉,如果注释掉则是直接发送邮件
                            End With
                            outlookItem.Display ' 显示outlook的发送邮件的界面
                        End If
                    Next
                End With
                
            End If
        Next
            
    SendMail_Exit:
        Exit Sub
    
    OpenOutlook_Error:
        MsgBox Err.Description
        Resume SendMail_Exit
    End Sub
    
    
    Function readText(filepath As String) As String
        Dim fso
        Dim f
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set f = fso.OpenTextFile(filepath)
        readText = f.ReadAll
    End Function
    

    效果

  • 相关阅读:
    平衡二叉树之RB树
    平衡二叉树之AVL树
    实现哈希表
    LeetCode Median of Two Sorted Arrays
    LeetCode Minimum Window Substring
    LeetCode Interleaving String
    LeetCode Regular Expression Matching
    PAT 1087 All Roads Lead to Rome
    PAT 1086 Tree Traversals Again
    LeetCode Longest Palindromic Substring
  • 原文地址:https://www.cnblogs.com/killclock048/p/14985011.html
Copyright © 2011-2022 走看看