Sub MsgSaver(strPath As String, msgItem As Outlook.MailItem, lngCounter As Long, blnMulti As Boolean)
Dim intC As Integer
Dim intD As Integer
Dim strMsgSubj As String
Dim strMsgTo As String
Dim arrMsgTo() As String ' Added by Alan McGowan 6-11-15
Dim msgItemTo As String ' Added by Alan McGowan 6-11-15
Dim arrcount As Long ' Added by Alan McGowan 6-11-15
Dim msglink As String ' Added by Alan McGowan 17-11-15
Dim msg As Outlook.MailItem ' Added by Alan McGowan 17-11-15
Dim objTask As Outlook.TaskItem ' Added by Alan McGowan 20-11-15
Dim Signature As String ' Added by Alan McGowan 17-11-15
' Dim objInsp As Inspector ' Added by Alan McGowan 17-11-15
' Dim objDoc As Word.document ' Added by Alan McGowan 17-11-15
' Dim objSel As Word.Selection ' Added by Alan McGowan 17-11-15
' Set objInsp = objTask.GetInspector ' Added by Alan McGowan 20-11-15
' Set objDoc = objInsp.WordEditor ' Added by Alan McGowan 20-11-15
' Set objSel = objDoc.Windows(1).Selection ' Added by Alan McGowan 20-11-15
' Set msgitem.to to the first recipient if multiple recipients in to field
' Added by Alan McGowan 6-11-15
arrMsgTo = Split(msgItem.To, ";")
arrcount = UBound(arrMsgTo) - LBound(arrMsgTo) + 1
If arrcount = 1 Then
msgItemTo = msgItem.To
Else
msgItemTo = arrMsgTo(0) & " et al" ' uses the first recipient where there is multiple recipients
End If
'Set name to save message to
If UserForm1.CheckBox1.Value = True Then 'multiple emails being saved using a user specified name
If UserForm1.g_blnOutgoing = True Then
strMsgSubj = Format(msgItem.senton, "yyyy-mm-dd Hh.Nn.Ss") & " " & "[To " & msgItemTo & "]" & " " & UserForm1.TextBox9.Value & "_0" & lngCounter & ".msg"
Else 'incoming mail so use from field
strMsgSubj = Format(msgItem.senton, "yyyy-mm-dd Hh.Nn.Ss") & " " & "[From " & msgItem.SenderName & "]" & " " & UserForm1.TextBox9.Value & "_0" & lngCounter & ".msg"
End If
ElseIf blnMulti = True Then 'multiple emails being saved using the default name
strMsgSubj = msgItem.Subject
If UserForm1.g_blnOutgoing = True Then
strMsgSubj = Format(msgItem.senton, "yyyy-mm-dd Hh.Nn.Ss") & " " & "[To " & msgItemTo & "]" & " " & strMsgSubj & ".msg"
Else 'incoming mail so use from field
strMsgSubj = Format(msgItem.senton, "yyyy-mm-dd Hh.Nn.Ss") & " " & "[From " & msgItem.SenderName & "]" & " " & strMsgSubj & ".msg"
End If
Else 'single email using name given in textbox8
strMsgSubj = UserForm1.TextBox8.Value & ".msg"
End If
' cleans illegal characters from strMsgSubj. Added by Alan McGowan 6-11-15
clean_subj strMsgSubj
'Save new msg file to defined filename and location
msgItem.SaveAs strPath & strMsgSubj
UserForm1.Hide
' create notification email if option to do is selected. Added by Alan McGowan 17-11-15
If UserForm1.chkmarknotif.Value = True Then
Set msg = Application.CreateItem(olMailItem)
msg.Subject = "*** A Saved Email Requires Your Attention ***"
msg.Importance = olImportanceHigh
'get default signature
Signature = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(Signature, vbDirectory) <> vbNullString Then
Signature = Signature & Dir$(Signature & "*.htm")
Else:
Signature = ""
End If
Signature = CreateObject("Scripting.FileSystemObject").GetFile(Signature).OpenAsTextStream(1, -2).ReadAll
msg.HTMLBody = "<p style='font-size:12pt; font-family:calibri;'>" & "From: " & msgItem.sender & "<br>" & "Subject: " & msgItem.Subject & "<br>" & _
"Received: " & Format(msgItem.senton, "yyyy-mm-dd Hh.Nn.Ss") & "<p style='font-size:12pt; font-family:calibri;'>" & "Email location: " & "<a href=""" & _
strPath & """>" & strPath & "</a > " & "<br>" & "Link to message: " & "<a href=""" & strPath & strMsgSubj & _
""">" & strPath & strMsgSubj & "</a > " & "<p style='font-size:12pt; font-family:calibri;'>" & _
"An email requires your attention. Please review the message link above and action as appropriate. Thank you." & "<p>" & Signature & "</p>"
msg.Display
End If
' create new task if option to do is selected. Added by Alan McGowan 17-11-15
If UserForm1.chknewtask.Value = True Then
Set objTask = Application.CreateItem(olTaskItem)
objTask.Subject = msgItem.Subject
objTask.DueDate = Now + 3 ' sets due date to 3 days after saving email
objTask.ReminderSet = True
objTask.ReminderTime = Now + 2 ' sets reminder to 2 days after saving email
objTask.body = msgItem.body
' objDoc.Hyperlinks.Add objSel.Range, strPath & strMsgSubj, "", "", strPath & strMsgSubj, ""
objTask.Importance = olImportanceHigh
objTask.Display
End If
Set msg = Nothing
Set msgItem = Nothing
Set objTask = Nothing
End Sub