Private Sub UserForm_Initialize()
Mottakerliste.Clear
With Mottakerliste
.AddItem "bXXXX@sXXXXne.no"
.AddItem "seXXXXnt@oXXXd.no"
.AddItem "stXXXX9@haXXXXnken.no"
End With
End Sub
Private Sub Cancel_Click()
Unload Me
End Sub
Private Sub Send_Click()
Dim NSession As Object
Dim NUIWorkspace As Object
Dim NMailDb As Object
Dim NDocumentTemp As Object
Dim NUIDocumentTemp As Object
Dim NUIDocument As Object
Dim NRTItemBody As Object
Dim NRTStyle As Object, NRTStyleDefault As Object
Dim NRTItemAttachment As Object, embeddedAttachment As Object
Dim Subject As String
Dim SendTo As String, CopyTo As String, BlindCopyTo As String
Dim fileAttachment As String
Dim embedCells As Range
Dim FSO As Object
Dim tempFolder As String, tempCellsJPG As String
Dim Copy_and_Paste As Boolean
Dim kopi1 As String
Dim kopi2 As String
Dim kopi3 As String
Dim kopi4 As String
Dim mmottaker As String, kopitaker As String
MsgBox "For at dette skal gå i orden må jeg be om at du åpner mailen din, og har den oppe på den andre skjermen. Så trykker du OK"
If Mottakerliste.Value = "bacXXXXXX@sXXXne.no" Then
fileAttachment = "G:\HKCN-I Settlement\Kunder\Skagen\Failed trades\2014 Failed Trades\" & Format(Date, "mm mmmm") & "\" & Format(Date, "yyyymmdd") & " Failed trades" & ".xlsx"
End If
If Mottakerliste.Value = "seXXXent@odXXXnd.no" Then
fileAttachment = "G:\HKCN-I Settlement\Kunder\ODIN\Failed trades\2014\" & Format(Date, "mm mmmm") & "\" & "Failed trades " & Format(Date, "ddmmyyyy") & ".xlsx"
End If
If Mottakerliste.Value = "sXXXX@haXXXXken.no" Then
fileAttachment = "G:\HKCN-I Settlement\Kunder\Skagen\Failed trades\2014 Failed Trades\" & Format(Date, "mm mmmm") & "\" & Format(Date, "yyyymmdd") & " Failed trades" & ".xlsx"
End If
If checksturla = True Then kopi1 = "XXX@hanXXXXbaXXXen.no"
If checkmathilde = True Then kopi2 = "mXXX1@hXXXXXanken.no"
If checkanne = True Then kopi3 = "aXXXX7@hanXXXXXnken.no"
If checksturla = False Then kopi1 = ""
If checkmathilde = False Then kopi2 = ""
If checkanne = False Then kopi3 = ""
If customcopy.Value = "" Then
kopi4 = ""
Else
kopi4 = customcopy.Value
End If
kopitaker = kopi1 & "," & kopi2 & "," & kopi3 & "," & kopi4
BlindCopyTo = ""
Subject = "Falte Handler"
'--------- EDIT USER-DEFINED SETTINGS IN THIS SECTION ---------
'The Excel cells to be included in the email body as an image
'Set embedCells = ActiveSheet.Range("A1:C8")
'The file to be attached to the email, if it exists
SendTo = Mottakerliste.Value
CopyTo = kopitaker
BlindCopyTo = ""
Subject = "Ny Macro for mail test!"
Unload Me
'--------- END OF USER-DEFINED SETTINGS ---------
'Copy_and_Paste flag
'True = copy and paste Excel cells into email body using the clipboard
'False = save Excel cells as a temporary .jpg file and import into email body
'Copy_and_Paste = True
Set FSO = CreateObject("Scripting.FileSystemObject")
tempFolder = FSO.GetSpecialFolder(2)
'File name for temporary .jpg file containing Excel cells
'tempCellsJPG = tempFolder & "\" & Replace(FSO.GetTempName(), ".tmp", ".jpg")
Set NSession = CreateObject("Notes.NotesSession") 'OLE (late binding only) because we access Notes UI classes
Set NUIWorkspace = CreateObject("Notes.NotesUIWorkspace")
Set NMailDb = NSession.GetDatabase("", "")
NMailDb.OPENMAIL
'Create the default rich text style
Set NRTStyleDefault = NSession.CreateRichTextStyle
With NRTStyleDefault
.NotesColor = COLOR_BLACK
.FontSize = 10
.NotesFont = FONT_HELV
.Bold = False
.Italic = False
End With
Set NRTStyle = NSession.CreateRichTextStyle
'Create a temporary NotesDocument
Set NDocumentTemp = NMailDb.CreateDocument
With NDocumentTemp
.Form = "Memo"
'Add a rich text item to contain the email body text and file attachment
Set NRTItemBody = .CreateRichTextItem("Body")
With NRTItemBody
'--------- ADD/EDIT CODE IN THIS SECTION FOR THE EMAIL BODY TEXT ---------
'Compose the email body text
.AppendText "Hei"
.AddNewLine 2
With NRTStyle
.NotesFont = FONT_ROMAN
.FontSize = 14
.NotesColor = COLOR_BLUE
.Bold = True
End With
.AppendStyle NRTStyle
.AppendText ""
.AddNewLine 2
'Add placeholder text which will be replaced by the Excel cells
.AppendText ""
.AddNewLine 2
With NRTStyle
.NotesFont = FONT_HELV
.FontSize = 10
.NotesColor = COLOR_RED
.Italic = True
End With
.AppendStyle NRTStyle
.AppendText ""
'Same paragraph, default style
.AppendStyle NRTStyleDefault
.AppendText " Vedlagt følger oversikt over handler som ikke er gjort opp:"
If fileAttachment <> "" Then
.AddNewLine 2
.AppendText ""
.AddNewLine 1
.EmbedObject EMBED_ATTACHMENT, "", fileAttachment
.AddNewLine 1
End If
'--------- END OF EMAIL BODY TEXT SECTION --------
End With
.Save False, False
End With
'Display the temporary document in the UI
Application.Wait DateAdd("s", 2, Now)
On Error GoTo NotesUIfeil
[COLOR=#ff0000]Set NUIDocumentTemp = NUIWorkspace.EDITDOCUMENT(True, NDocumentTemp)[/COLOR]
'Copy the rich text to the clipboard, close the window, and delete the temp doc
With NUIDocumentTemp
[COLOR=#ff0000] .GOTOFIELD "Body"[/COLOR]
.SelectAll
.Copy
'The next 2 lines are not needed
'.Document.SaveOptions = "0" 'prevent prompt
'.Document.MailOptions = "0" 'prevent prompt
.Close 'therefore temp UI doc not saved
End With
NDocumentTemp.Remove True
'Compose the real email document
Application.Wait DateAdd("s", 2, Now)
[COLOR=#ff0000]Set NUIDocument = NUIWorkspace.COMPOSEDOCUMENT(NMailDb.Server, NMailDb.FilePath, "Memo")[/COLOR]
'Set NUIDocument = NUIWorkspace.ComposeDocument(, , "Memo") 'use local computer and current database
With NUIDocument
[COLOR=#ff0000] .FIELDSETTEXT "EnterSendTo", SendTo[/COLOR]
.FIELDSETTEXT "EnterCopyTo", CopyTo
.FIELDSETTEXT "BlindCopyTo", BlindCopyTo
.FIELDSETTEXT "Subject", Subject
'The memo now has everything except the rich text from the temporary UI document and the Excel cells image.
'The automatic signature (if defined in User Preferences) should be at the bottom of the memo. Now, we just
'paste the rich text and Excel cells into the body
.GOTOFIELD "Body"
.Paste
'Replace the placeholder text with the Excel cells image
.GOTOFIELD "Body"
.FINDSTRING ""
'.DESELECTALL 'Uncomment to leave the placeholder text in place (cells are inserted immediately before it)
If Copy_and_Paste Then
embedCells.CopyPicture xlBitmap
.Paste
Application.CutCopyMode = False
End If
On Error GoTo 0
'Set NotesDocument options to save and send the email without prompts when the Close method is called
.Document.SaveOptions = "1"
.Document.MailOptions = "1"
.Close
End With
MsgBox "Da skal alt ha gått i orden, og mailen er sendt. Er du usikker se i Sent Mail"
Exit Sub
NotesUIfeil:
MsgBox "Det ser ut til at Excel jobber for fort for Notes, Spør Sturla hva som kan ha skjedd!"
Exit Sub
End Sub
'Based on http://www.jpsoftwaretech.com/export-excel-range-to-a-picture-file/
Private Sub Save_Object_As_JPG(saveObject As Object, JPGfileName As String)
'Save a picture of an object as a JPG/JPEG file
'Arguments
'saveObject - any object in the CopyPicture method's 'Applies To' list, for example a Range or Shape
'JPGfileName - the file name (including folder path if required) to save the picture as
Dim temporaryChart As ChartObject
Application.ScreenUpdating = False
saveObject.CopyPicture xlScreen, xlPicture
Set temporaryChart = ActiveSheet.ChartObjects.Add(0, 0, saveObject.Width, saveObject.Height)
With temporaryChart
.Border.LineStyle = xlLineStyleNone 'No border
.Chart.Paste
.Chart.Export JPGfileName
.Delete
End With
Application.ScreenUpdating = True
Set temporaryChart = Nothing
End Sub
End Sub
