'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
Sub EMailSurveys()
'______________________________________________________________________________
' Code here assumes that ThisWorkbook is located in a directory
' named ..\yyyy mm\
Dim wbInterface As Workbook
Dim rngEMails As Range, rngCell As Range, rngNPCs As Range, rngMsg As Range
Dim strPS As String, strPath As String, strBranch As String, _
strFileName As String, strEmailMsg As String
Dim namAddresses As Name, namMessage As Name
Dim miNew As Outlook.MailItem
Dim objRecipient As Outlook.Recipient
Dim objCC As Outlook.Recipient
Dim objAttachment As Outlook.Attachment
Dim appOL As Outlook.Application
Dim lngClickYes As Long, lngWnd As Long, lngResponse As Long
Dim booIOpenedInterface As Boolean
' ______Get list of NPC's, e-mail addresses & e-mail
' message from Interface workbook_____
On Error Resume Next
Set wbInterface = Workbooks("Interface.xls")
Err.Clear
On Error GoTo ErrorNoInterface
If wbInterface Is Nothing Then
Set wbInterface = Workbooks.Open(gc_strMainPath & "Interface.xls")
booIOpenedInterface = True
Else
booIOpenedInterface = False
End If
Set namAddresses = wbInterface.Names("EmailAddresses")
Set rngEMails = wbInterface.Worksheets(WSNameFromAddress(namAddresses.RefersTo)).Range(AddrFromLongAddr(namAddresses.RefersTo))
Set namMessage = wbInterface.Names("EmailMessage")
Set rngMsg = wbInterface.Worksheets(WSNameFromAddress(namMessage.RefersTo)).Range(AddrFromLongAddr(namMessage.RefersTo))
strEmailMsg = rngMsg.Text
Set rngNPCs = rngEMails.Columns(1)
' ______set up other needed variables______
'Set appXL = Application
Set appOL = Outlook.Application
strPS = Application.PathSeparator
strPath = ThisWorkbook.Path
strBranch = HighestPathBranch(strPath)
If Right(strPath, 1) <> strPS Then strPath = strPath & strPS
' +---------------------------------------------------+
' | Nov 2003: the CLICKYES applet no longer needed |
' | with OUTLOOK 2003 for you don't get the |
' | annoying popup dialog for each message. |
' +---------------------------------------------------+
' ' _____Register a message to send_____ --------+
' lngClickYes = RegisterWindowMessage("CLICKYES_SUSPEND_RESUME") ' |
' ' |
' ' _____Find ClickYes Window by ClassName_____ |
' lngWnd = FindWindow("EXCLICKYES_WND", 0&) ' |===> For ClickYes Applet
' ' |
' ' _____Send the message to Resume ClickYes_____ |
' lngResponse = SendMessage(lngWnd, lngClickYes, 1, 0) ' --------+
' _____Create mail items and send 'em out.______
For Each rngCell In rngNPCs.Cells
If IsEmpty(rngCell.Offset(, 1)) Then GoTo FinDelAro
strFileName = "TAT Survey - " & strBranch & " - " & rngCell & ".xls"
' _____No file - skip to next_____
If Dir(strPath & strFileName) = "" Then GoTo FinDelAro
Application.StatusBar = "Creating mail item for " & rngCell
Set miNew = appOL.CreateItem(olMailItem)
With miNew
Set objRecipient = .Recipients.Add(rngCell.Offset(, 1).Value)
objRecipient.Type = OlMailRecipientType.olTo
If Not IsEmpty(rngCell.Offset(, 2)) Then
Set objCC = .Recipients.Add(rngCell.Offset(, 2).Value)
objCC.Type = OlMailRecipientType.olCC
End If
.Subject = "TAT Survey / Encuesta de TAT [" & strBranch & "] [" & rngCell & "]"
.Body = strEmailMsg
Set objAttachment = .Attachments.Add(strPath & strFileName)
For Each objRecipient In .Recipients
objRecipient.Resolve
Next objRecipient
.Display
End With
FinDelAro:
'"""""""""
Next rngCell
' _____Send the message to Suspend ClickYes_____
'lngResponse = SendMessage(lngWnd, lngClickYes, 0, 0)
Application.StatusBar = False
If booIOpenedInterface Then wbInterface.Close
Set wbInterface = Nothing
Set appOL = Nothing
Exit Sub
ErrorNoInterface:
'""""""""""""""""
MsgBox "Unable to find/open Interface workbook.", vbExclamation, "Critical Error"
End Sub
