Question

我希望自动通过电子邮件自动发送当前由我手动执行的excel文件

我具有以下流程结构：任务计划程序-> .bat文件-> VBA脚本-> Excel公式

这意味着我的任务计划程序将命中.bat文件，这将触发VB文件执行代码，这会将SQL DB中的数据转储到Excel文件中，然后Excel文件中的公式将准备图表和图形以及所有计算

这是我的VB文件代码：

    Macro1
Private Sub Macro1()

Set objExcel  = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open("C:\Users\kursekar\Documents\Work\Apps\ReferralStrApp\StdztnRefRepTrial.xlsx")
objExcel.Visible = False
Set Conn = CreateObject("ADODB.Connection")
Set RS   = CreateObject("ADODB.Recordset") 
Dim SQL
Dim Sconnect
Sconnect = "Provider=SQLOLEDB.1;Password='25LaurelRoad';User ID='CPSMDIT\kursekar';Data Source='analyzer';Initial Catalog='analyzer_str';Integrated Security=SSPI; Persist Security Info=True;"
Conn.Open Sconnect

SQL = "WITH cte_REFERRALS_REPORTS(referralnum, refer_from, refer_from_name, refer_from_id, refer_to, refer_to_name, refer_to_id) AS (SELECT referralnum, refer_from, CASE WHEN refer_from_id = 'R' THEN RdicF.refname WHEN refer_from_id = 'P' THEN PdicF.provname END AS refer_from_name, refer_from_id, refer_to, "
SQL = SQL & "CASE WHEN refer_to_id = 'R' THEN RdicT.refname WHEN refer_to_id = 'P' THEN PdicT.provname END AS refer_to_name, refer_to_id FROM referral_t r Left Join refcode_t RdicF ON  r.refer_from = CASE WHEN r.refer_from_id='R' THEN RdicF.refcode ELSE NULL END Left Join refcode_t RdicT ON  r.refer_to = CASE WHEN r.refer_to_id = 'R' THEN RdicT.refcode ELSE NULL END "
SQL = SQL & "Left Join provcode_t PdicF ON r.refer_from  = CASE WHEN r.refer_from_id = 'P' THEN PdicF.provcode ELSE NULL END Left Join provcode_t PdicT ON r.refer_to = CASE WHEN r.refer_to_id = 'P' THEN PdicT.provcode ELSE NULL END ) SELECT chgslipno , a.acctno, patfname, patlname, appt_date, a.enccode, pr.provname "
SQL = SQL & ",a.provcode, rfc.refname, a.refcode, r1.refer_from as r1_ref_from, r1.refer_from_id as r1_ref_from_id, r1.refer_from_name as r1_ref_from_name, a.referral1 as r1_refnum, r2.refer_from as r2_ref_from, r2.refer_from_id as r2_ref_from_id, r2.refer_from_name as r2_ref_from_name,a.referral2, prgrc.provgrpdesc,s.specdesc, a.prov_dept, pos.posdesc,pr.cred "
SQL = SQL & "FROM apptmt_t a Left JOIN patdemo_t p ON a.acctno = p.acctno LEFT JOIN provcode_t pr ON pr.provcode = a.provcode LEFT JOIN refcode_t rfc ON a.refcode = rfc.refcode LEFT JOIN (SELECT*FROM cte_REFERRALS_REPORTS) r1 ON a.referral1 = r1.referralnum LEFT JOIN (SELECT*FROM cte_REFERRALS_REPORTS) r2 "
SQL = SQL & "on a.referral2 = r2.referralnum LEFT JOIN provgrpprov_t prgrpr on a.provcode = prgrpr.provcode LEFT JOIN provgrpcode_t prgrc on prgrpr.provgrpcode = prgrc.provgrpcode LEFT JOIN specialty_t s on pr.speccode = s.speccode LEFT JOIN poscode_t pos on a.poscode = pos.poscode "
SQL = SQL & "WHERE UPPER(a.enccode) in ('CON','APE','COB','CONZ','HAC','HFUI','MMN','NCG','NCHF','NCPF','NHFU','NMC','NOB','NP','NP15','NPE','NPI','NPOV','NPS','NPSV','NPV','OVN','IMC','NP30') AND UPPER(a.appt_status)='ARR' AND appt_date >= '2017-01-01' "
SQL = SQL & "ORDER BY a.acctno"

Set Sheet = objWorkbook.ActiveSheet
Sheet.Activate

RS.Open SQL, Conn
 Sheet.Range("A2").CopyFromRecordset RS

RS.Close
Conn.Close

objExcel.DisplayAlerts = False
'Release memory
'Set objFSO = Nothing
'Set objFolder = Nothing
'Set objFile = Nothing
objWorkbook.Save
objExcel.DisplayAlerts = True
objWorkbook.Close
objExcel.Workbooks.Close
objExcel.Quit

'Set objExcel = Nothing
MsgBox ("Saved")
End Sub

Answer 1

这在很大程度上取决于您要如何发送电子邮件。您使用的是Outlook，还是试图通过gmail，yahoo或私有smtp服务器发送它？

无论如何，我将把vba代码发送到excel文件的模块中。 bat文件调用Macro1更新工作簿，然后在工作簿中的模块内部运行宏代码。确保代码在模块中，而不在任何工作表或工作簿中。如果您使用Outlook来发送电子邮件，则模块中的代码应如下所示，并在库引用中加载了Outlook Application模块：

Sub Email_Active_Workbook()
'Working in Excel 2000-2016
    Dim OutApp As Object
    Dim OutMail As Object

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .to = "email@address"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .Body = "Hi there"
        .Attachments.Add ActiveWorkbook.FullName
        .Send   'or use .Display
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

它改编自：https://www.rondebruin.nl/win/s1/outlook/amail1.htm

如果通过Outlook发送，该站点也值得参考：https://wellsr.com/vba/2018/excel/vba-send-email-from-excel/

这： https://powerspreadsheets.com/send-email-excel-vba/

然后在objWorkbook.save行下方的VB文件Macro1中添加：

objExcel.Application.Run "StdztnRefRepTrial.xlsx!Email_Active_Workbook"

如果通过smtp服务器进行发送，则变得稍微复杂一些，因为您需要确保已加载CDO库，并且该库取决于邮件服务器的安全设置。该线程提供了VBA在PC上发送电子邮件的工作示例，可以轻松地适应您的需求：Send email with workbook from VBA macro on both Windows and Mac

如果需要SSL，它将变得更加复杂。有关更多详细信息，请参见本网站，尤其是指向Github的SSL代码链接：https://www.makeuseof.com/tag/send-emails-excel-vba/

编辑

我完全同意前面的评论，这不是完成报告SQL数据的最佳方法。这可以快速解决，但是使用SSRS发送这些报告应该是您的主要重点。我希望这不是关键任务数据，否则如果您在无人照管的情况下遇到错误，将不会发送电子邮件。

Answer 2

我知道这是个老问题。我这样做只是为了将来VB和SO的新手，他们可能会根据客户的想象需求遇到类似或相同的问题。

我在SO的一位受人尊敬的VB开发人员的帮助下粘贴了我的整个代码和代码的解决方案。在下面的此给定链接下，可以找到相同的问题及其解决方案：

https://codereview.stackexchange.com/questions/219371/write-to-excel-from-sql-db-using-vba-script/219378#219378

如何通过VBA脚本通过电子邮件发送整个Excel文件

2 个答案: