User:Geoffjw1978/sandbox/paste-mod

'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ' ' ' It is not to be altered or distributed, ' except as part of an application. ' You are free to use it in any application, ' provided the copyright notice is left unchanged. ' 'Export contacts from Outlook: ' 1.Click the File tab. ' 2.Click Options. ' 3.Click Advanced. ' 4. Export ' 5. To a file. ' ' creates in DEFAULT draft folder (GMTsystems),  so drag to OTHER address, like c0ntact for sending. '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ' "c:\tmp\test_doc.txt" ' CSTR_BACKEND_PATH '

Option Compare Database Option Explicit

Public Const GSTR_SENDER_EMAIL As String = "GeoffmTurner@c0ntact.me.uk" Public Const GSTR_ERROR_EMAIL As String = "GEOFFmTURNER@GMTSYSTEMS.COM" Public Const GSTR_EMAIL_SUBJECT As String = "ML class of 97 drinks: 22/23 May, next Tue or Wed" Public Const GSTR_EMAIL_BODY As String = "D:\rsync\rsynced_vaio\vhtdocs\gmtsystems.com\events\ml\ml-2012.htm"

Public Const GSTR_ATTACH_IT As String = "false"  ' = "true" needs more work.. attachmentFile=bodyFile right now.

'Options in BODY: '       strHtmlBody = Replace(strHtmlBody, "[FIRST_NAME]", strFirst_Name) '       strHtmlBody = Replace(strHtmlBody, "[LAST_NAME]", strLast_Name) 'tbd:   strHtmlBody = Replace(strHtmlBody, "[SPOUSE]", strSpouse)

Public Sub junk_emails Call Create_Draft_Emails

End Sub

Public Sub Create_Draft_Emails(Optional strSQL As String) Dim db     As New clsRemote Dim rs     As New ADODB.Recordset Dim bRes As Boolean Dim intCheckTotal As Integer Dim strEmail_Outlook As String, strEmail As String, strFileName As String, strPath As String Dim strEmailSubject As String Dim strHC_Entity As String, strFirst_Name As String, strLast_Name As String, _ strEmail1 As String, _ strEmail2 As String, _ strEmail3 As String, _ strMiddle_Name As String ' Title strSQL = "select FirstName, MiddleName, LastName, EmailAddress,Email2Address, Email3Address, " & _ "User1, User2, User3, User4 " & _ "from Contacts where User1='ML97' " 'Tbl_Tmp_Validate_Email_Address intCheckTotal = 0 Set rs = db.GetRecordset(strSQL) rs.MoveFirst While Not rs.EOF strHC_Entity = "RBS" strFirst_Name = RTrim(rs.Fields(0).Value) & "" strMiddle_Name = RTrim(rs.Fields(1).Value) & "" strLast_Name = RTrim(rs.Fields(2).Value) & "" strEmail1 = rs.Fields(3).Value & "" strEmail2 = rs.Fields(4).Value & "" strEmail3 = rs.Fields(5).Value & "" If strMiddle_Name <> "" Then strMiddle_Name = " " & strMiddle_Name End If       strEmailSubject = GSTR_EMAIL_SUBJECT strFileName = GSTR_EMAIL_BODY strEmail_Outlook = """" & strFirst_Name & strMiddle_Name & " " & strLast_Name & """ " strEmail_Outlook = strEmail_Outlook & ConcatSmtpEmail(strEmail1, strEmail2, strEmail3) bRes = Create_Outlook_Email(strFileName, strEmail_Outlook, strFirst_Name, strEmailSubject, strLast_Name) If bRes = False Then GoTo FAILED_IN_OUTLOOK Else intCheckTotal = intCheckTotal + 1 End If       rs.MoveNext Wend MsgBox "Checksum, emails created: " & intCheckTotal EXIT_FUNCTION_FINALLY: Set rs = Nothing Exit Sub Catch: 'gt:todo: RaiseError written to a user-specific instance-specific log file on the shared drive... MsgBox "Send_All_Business_Approver_Letters: ERROR: " & Err.Description, vbOKOnly, vbError GoTo EXIT_FUNCTION_FINALLY

FAILED_IN_OUTLOOK: MsgBox "SHARP: Send_All_Business_Approver_Letters: ERROR: Could not produce letters in Outlook. Quitting Mail Shot.", vbOKOnly, vbError GoTo EXIT_FUNCTION_FINALLY

End Sub

Private Function Create_Outlook_Email(ByVal strFileName As String, _                                     ByVal strEmail_Outlook As String, _                                      ByVal strFirst_Name As String, _                                      ByVal strEmail_Subject As String, _                                      ByVal strLast_Name As String)

'   On Error GoTo Catch Dim SendToDistribution As String, CopyToDistribution As String, i As Integer, intSepCount As Integer Dim objOutlook As Outlook.Application, objOutlookMsg As Outlook.MailItem, objOutlookRecip As Outlook.Recipient Dim objOutlookAttach As Outlook.Attachment, nr As Long Dim Attachment As String Dim objFile As New FileSystemObject Dim objBodyFile As New FileSystemObject Dim strBodyFile As String Dim strHtmlBody As String Dim txtStream As TextStream If Not objFile.FileExists(strFileName) Then strEmail_Subject = "# ERR: " & strLast_Name & ", " & strFirst_Name & " ERROR: file not found: " & strFileName strEmail_Outlook = GSTR_ERROR_EMAIL Else If (Trim(strFirst_Name) = "") Then strEmail_Subject = strEmail_Subject Else strEmail_Subject = strFirst_Name & ", " & strEmail_Subject End If   End If    ' Create the Outlook session. '   Set objOutlook = CreateObject("Outlook.Application")

' Create the message. '   Set objOutlookMsg = objOutlook.CreateItem(olMailItem)

With objOutlookMsg ' Add the To recipient(s) to the message. Set objOutlookRecip = .Recipients.Add(strEmail_Outlook) objOutlookRecip.Type = olTo Set objOutlookRecip = .Recipients.Add("GEOFFmTURNER@GMTSYSTEMS.COM") objOutlookRecip.Type = olBCC 'TBD: Add the CC recipient(s) to the message. [ greyed out on form ] '       For i = LBound(CopyToDistribution) To UBound(CopyToDistribution) '           If Len(CopyToDistribution(i)) > 0 Then '               Set objOutlookRecip = .Recipients.Add(CopyToDistribution(i)) '               objOutlookRecip.Type = olCC '           End If '        Next ' Set the Subject, Body, and Importance of the message. .Subject = strEmail_Subject '       .SentOnBehalfOfName = "RiskSecretariat@rbs.com"   'test UAT address: "GBMApprovalAuthority@rbs.com" ' gt:TODO: get filename from SaveSettings param = email-body-html-filename ' strBodyFile = CSTR_BACKEND_PATH & "\emails\##email-body-html.txt" strBodyFile = GSTR_EMAIL_BODY Set txtStream = objBodyFile.OpenTextFile(strBodyFile, ForReading) strHtmlBody = txtStream.ReadAll txtStream.Close strHtmlBody = Replace(strHtmlBody, "[FIRST_NAME]", strFirst_Name) strHtmlBody = Replace(strHtmlBody, "[LAST_NAME]", strLast_Name) ' strHtmlBody = Replace(strHtmlBody, "[SPOUSE]", strSpouse) .HTMLBody = strHtmlBody

.Importance = olImportanceHigh .ReadReceiptRequested = True '   permission denied for all of these: '        .Sender.EmailAddress = GSTR_SENDER_EMAIL '       objOutlookMsg.SenderEmailAddress '.SenderEmailAddress = GSTR_SENDER_EMAIL '    .Sender.Name = "Geoff Turner" '.ReplyRecipients = "# Risk Secretariat" ' Add attachments to the message. '       If IsArray(Attachment) Then '           For i = LBound(Attachment) To UBound(Attachment) '               Set objOutlookAttach = .Attachments.Add(Attachment(i)) '           Next '       End If        If objFile.FileExists(strFileName) And GSTR_ATTACH_IT = "true" Then Set objOutlookAttach = .Attachments.Add(strFileName) End If       ' Resolve each Recipient's name. ' doesn't work on 2007, internet addressess... '       For Each objOutlookRecip In .Recipients '           On Error GoTo RESOLVE_ERR '               '            If Not objOutlookRecip.Resolve Then '               objOutlookMsg.Display  '- gt:todo: on some machines, spawns email&continues, on others, hangs w/err. '               '                Debug.Print "Outlook failed to resolve: " & strEmail_Outlook '               objOutlookRecip.Remove '               .Subject = "ERROR: Outlook failed to resolve: " & strEmail_Outlook '               Set objOutlookRecip = .Recipients.Add(GSTR_ERROR_EMAIL) '               objOutlookRecip.Type = olTo '               objOutlookRecip.Resolve '           End If                '        Next

RESUME_RESOLVE_ERR: 'On Error GoTo Catch

.Save '.Send  '  Don't send, just save in Drafts.

End With Create_Outlook_Email = True EXIT_FINALLY: Set objOutlookMsg = Nothing Set objOutlook = Nothing Set objFile = Nothing Exit Function Catch: Create_Outlook_Email = False MsgBox "Did you click NO instead of Yes?" & vbCrLf & " - If so, please retry, clicking Yes in Outlook. " & vbCrLf & vbCrLf & "SHARP: Create_Outlook_Email: ERROR: " & Err.Description, vbExclamation, "Error Sending Email" GoTo EXIT_FINALLY RESOLVE_ERR: Debug.Print "Outlook failed to resolve and threw err: " & strEmail_Outlook '               objOutlookRecip.Remove objOutlookMsg.Subject = "ERROR: Outlook failed to resolve and threw err: " & strEmail_Outlook Set objOutlookRecip = objOutlookMsg.Recipients.Add(GSTR_ERROR_EMAIL) objOutlookRecip.Type = olTo objOutlookRecip.Resolve GoTo RESUME_RESOLVE_ERR End Function

' Previous hardcoding of email text - kept incase of file deletion. '      .HTMLBody =  " " & _ '                   "" & _ '                   " " & _ '                    "Dear " & strFirst_Name & ", " & _ '                   " " & _ '                    "Further to recently receiving your CV, please find attached your approval authority letter. " & _ '                   " " & _ '                    "If the link below is not clicked then we will resend you the letter in case you have missed this email. " & _ '                   "" & _ '                   "I confirm receipt of the attached Approval Authority Letter" & _ '                   " " & _ '                    " " & _ '                    "Please click the link above. " & _ '                   " " & _ '                    "Thank you, " & _ '                   " " & _ '                    "Risk Secretariat " & _ '                   "    "

Private Function ConcatSmtpEmail(e1 As String, e2 As String, e3 As String) As String

' Description '  Adds to a list of email addresses to append up to 3 possible addresses for one person. '   Dim arrEmail As Variant, blnDashRequired As Boolean Dim i As Integer, j As Integer, idx As Integer Dim strSmtpEmail As String, strJoin As String LTrim (RTrim(e1)) LTrim (RTrim(e2)) LTrim (RTrim(e3)) ReDim arrEmail(5) As String strSmtpEmail = "" For j = 1 To 5 arrEmail(j) = "" Next j   i = 0 If Trim(e1) <> "" And Not IsNull(e1) Then i = i + 1 arrEmail(i) = e1   End If    If Trim(e2) <> "" And Not IsNull(e2) Then i = i + 1 arrEmail(i) = e2   End If    If Trim(e3) <> "" And Not IsNull(e3) Then i = i + 1 arrEmail(i) = e3   End If    If i = 0 Then strSmtpEmail = "<" & GSTR_ERROR_EMAIL & ">" Else strSmtpEmail = "<" & arrEmail(1) & ">" End If '   If blnDashRequired Then '       If arrEmail(2) <> "" Then '           strSmtpEmail = strSmtpEmail & " - " & arrEmail(2) '       End If '        idx = 3 '   Else '       idx = 2 '   End If    If i > 1 Then For j = 2 To i          strSmtpEmail = strSmtpEmail & "; <" & arrEmail(j) & ">" Next j   End If    ConcatSmtpEmail = strSmtpEmail

End Function