vbscript 从Excel发送电子邮件 - VBA

Posted 2021-05-21

Sub Email_Inputs()

Dim myFile As String, Text As String, textline As String

Dim D_1 As String, D_2 As String, D_3 As String
Dim email1 As String, pmname1 As String ', senddisplay As String

myFile = "F:\Ultimus_FTP\Script Files\MFTrades_Email_To.txt"

    Open myFile For Input As #1

        Do Until EOF(1)
            Line Input #1, textline
            Text = Text & textline
        
        Loop

    Close #1

D_1 = InStr(Text, "email_ultimus:")
'D_2 = InStr(Text, "email_name:")
'D_3 = InStr(Text, "send_display:")

email1 = Mid(Text, D_1 + 11)
'pmname1 = Mid(Text, D_2 + 12)
'senddisplay = Mid(Text, D_3 + 13)

email1 = Left(email1, InStr(email1, "*") - 1)
'pmname1 = Left(pmname1, InStr(pmname1, "*") - 1)
'senddisplay = Left(senddisplay, InStr(senddisplay, "*") - 1)

'Using 20 as max string goes out / smaller value than difference to next line
'Range("J10").Value = email1  ' + 11) ', 30)
'Range("J11").Value = pmname1

Call Email_Ultimus(email1) ', senddisplay)

End Sub

Sub Email_Ultimus(email1 As String)
'Sub Mail_Sheet_Outlook_Body()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2016
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim strFolderPath, HTMLPath, Fname, Signature, SigString, title, IPath As String
    Dim spathE, HTMLPathE, spathP, HTMLPathP As String
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    'Adding new worksheet
    Dim ws As Worksheet
    Set ws = Worksheets("Pivot_Tables") 'Worksheets.Add
    Dim rngSmall As String
    Dim rngSMid As String
    Dim dyear As String
    
    dyear = Format(Now, "yyyy")
    
' Get the path to your My Documents folder
    strFolderPath = "F:\Ultimus_FTP\_Files\MF_Trades\Excel\Summary_Files\" & dyear & "\" '
    spathE = "F:\Ultimus_FTP\_Files\MF_Trades\Excel\" '
    spathP = "F:\Ultimus_FTP\_Files\MF_Trades\PDFs\"
    HTMLPathE = "Raw Historical Data: <a href='file://" & spathE & "'>" & "Excel" & "</a> | "
    HTMLPathP = HTMLPathE & "<a href='file://" & spathP & "'>" & "PDFs" & "</a><br> "
    HTMLPath = "=============================" & "</a><br>" & _
                "Historical: <a href='file://" & strFolderPath & "'>" & "Summary MF Flow Files" & "</a><br>" & HTMLPathP _
            & "============================="
     
'' Get the path to your My Documents folder
'    spathE = "F:\Ultimus_FTP\_Files\MF_Trades\Excel\" '
'    HTMLPathE = "<a href='file://" & strFolderPath & "'>" & "Historical Ultimus MF Transactions" & "</a><br>" _
'            & "============================="
'
'' Get the path to your My Documents folder
'    spathP = "F:\Ultimus_FTP\_Files\MF_Trades\" '
'    HTMLPathP = "<a href='file://" & strFolderPath & "'>" & "Historical Ultimus MF Transactions" & "</a><br>" _
'            & "============================="

     ' Get PivotData for the quantity of chairs in the warehouse.
     rngSmall = Format(ws.PivotTables("CCASX_1").GetPivotData("GrossAmount"), "Currency") ', "Warehouse", "Chairs")
     rngSMid = Format(ws.PivotTables("CCSMX_1").GetPivotData("GrossAmount"), "Currency")  ', "Warehouse", "Chairs")
     

    Set rng = Nothing
    Set rng = ActiveSheet.UsedRange
    'You can also use a sheet name
    'Set rng = Sheets("YourSheet").UsedRange
    
    'Make a copy of the file/Open it/Mail it/Delete it
    'If you want to change the file name then change only TempFileName
    TempFilePath = "F:\Ultimus_FTP\_Files\MF_Trades\Newest\"
    TempFileName = "PostingDetails"
    FileExtStr = ".pdf"


'Change only Mysig.htm to the name of your signature
    SigString = Environ("appdata") & _
                "\Microsoft\Signatures\Work.htm"

    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If

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

Dim DateMod As String
DateMod = FileDateTime("F:\Ultimus_FTP\_Files\MF_Trades\Newest\Excel_PostingDetails.xls")
DateMod = Left(DateMod, InStr(DateMod, " ") - 1)

    On Error Resume Next
    With OutMail
        .To = email1 '"[e-mail]" '"[e-mail]" '"[e-mail]"
        .CC = "[e-mail]"
        .BCC = ""
        '.Subject = "Daily MF Transaction Summary"
        .Subject = "Daily MF Flows - Small: " & rngSmall & " | SMid: " & rngSMid & " - (" & DateMod & ")"
        .HTMLBody = "<HTML><BODY>" & HTMLPath & RangetoHTML(rng) & "</BODY></HTML>" & .HTMLBody & Signature
'        .HTMLBody = "<HTML><BODY><P STYLE='font-family:Arial;font-size:10pt'>" & HTMLPath & vbNewLine & RangetoHTML(rng) & "<br></BODY></HTML>" & .HTMLBody '& Signature
        '.HTMLBody = vbNewLine & RangetoHTML(rng)
'        .HTMLBody = "*Fund Flows Automatically Scripted into Moxy" & vbNewLine & RangetoHTML(rng)
        .Attachments.Add TempFilePath & TempFileName & FileExtStr
        '.Attachments.Add = ("F:\Ultimus_FTP\_Files\MF_Trades\Newest\Excel_PostingDetails.pdf")
        .Send   'or use .Display
    End With
    On Error GoTo 0

'Kill TempFile

'Call Convert_CSV_IDC

'Call Test_Kill
    'ActiveWorkbook.Close False
    'Application.Close
    
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub


Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues ', , False, False
        .Cells(1).PasteSpecial xlPasteFormats ', , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         FileName:=TempFile, _
         sheet:=TempWB.Sheets(1).name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close SaveChanges:=False

    'Delete the htm file we used in this function
     Kill TempFile
     'Kill TempWB

    'Set TempFile = Nothing
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function