Last active
December 11, 2017 18:41
-
-
Save ship9599/b65c9c27012288b08fe0622dae82c27a to your computer and use it in GitHub Desktop.
Text file = sender address.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 '"jschipper@conestogacapital.com" '"cca@conestogacapital.com" '"ron@debruin.nl" | |
.CC = "jschipper@conestogacapital.com" | |
.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 | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment