The macro requires an SMTP DLL I found on the internet by Dean Dusenberyat FreeVBCode.com
So without further ado, I present to you the source code for the VBA macro:
Option Explicit
' These lists are "|" delimited
Private Const CATEGORY_LIST As String = "Category 1"
Private Const USER_LIST As String = "USER_GROUP"
Private Const EXCHANGE_DOMAIN As String = "Document"
Private Const EXHANGE_MODE As Integer = BoExchangeMode.boRepositoryMode
Private Const PROMPT_COUNT As Integer = 0
Private Const PROMPT_1 As String = "Replace with prompt text string"
' Email address lists are semi-colon delimited
Private Const EMAIL_RECIPIENT As String = "billyjo.jimbob@yourdomain.com"
Private Const EMAIL_SUBJECT_USE_REPORT_NAME As Boolean = True
Private Const EMAIL_SUBJECT As String = "TEST:BO report automation"
Private Const EMAIL_MESSAGE As String = "Please ignore this test email"
Private Const EMAIL_DOC As Boolean = False
Private Const EMAIL_PDF As Boolean = True
' These generally will not change
Private Const EMAIL_FROM As String = "bo_admin@yourdomain.com"
Private Const EMAIL_FROM_DISPLAY As String = "BO Admin"
' Not used for now
'Private Const BO_REPOSITORY As String = "BO_REPOSIT"
'Private Const BO_PASSWORD As String = "PASSWORD"
'Private Const BO_REPOSITORY_SERVER As String = "BO_SERVER"
' Necessary variables for emailing
' ||===============================||
' || ||
' || DO NOT MODIFY!!! ||
' || ||
' ||===============================||
Private m_emailSubject As String
Private WithEvents poSendMail As vbSendMail.clsSendMail
'Private Const CONNECTION_STRING As String = "Provider=MSDAORA;User ID=" & BO_REPOSITORY & ";Password=" & BO_PASSWORD & ";Data Source=" & BO_REPOSITORY_SERVER
'Private Const EMAIL_LIST_QUERY As String = "SELECT i.EMAILADDRESS emailaddress FROM ipuser i,(select a.actor_name actor_name, " & _
"g.group_name group_name, count(*) dummy from (select distinct " & _
"aa.M_ACTOR_C_NAME actor_name, al.M_ACTL_N_FATLINKID " & _
"actor_link_id from obj_m_actor aa,obj_m_actorlink al " & _
"WHERE aa.M_ACTOR_N_TYPE = 16 and aa.M_ACTOR_N_ID = al.M_ACTL_N_ACTORID and " & _
"aa.M_ACTOR_N_STATUS <> 0 order by 2) a, (select distinct ga.M_ACTOR_C_NAME group_name, " & _
"gl.M_ACTL_N_ID group_link_id from obj_m_actor ga," & _
"obj_m_actorlink gl WHERE ga.M_ACTOR_N_TYPE = 1 " & _
"and ga.M_ACTOR_N_ID = gl.M_ACTL_N_ACTORID order by 2) g WHERE a.actor_link_id " & _
"= g.group_link_id group by g.group_name, a.actor_name order by 2, 1) u " & _
"WHERE u.group_name = '" & USER_LIST & "' AND i.USERLOGONNAME = u.actor_name " & _
"AND i.USERLOGONTYPE = 'NT'"
Private Sub SetPrompts(ByRef variables As busobj.variables)
Dim i As Integer
With variables
If PROMPT_COUNT > 0 Then
For i = 1 To PROMPT_COUNT
Select Case i
' |===================================|
' | Only modify this section below! |
' |===================================|
Case 1
.Item(PROMPT_1).Value = Get6MonthPreviousStartDate()
Case 2
Case 3
Case 4
' |=============================|
' | Do not modify below this! |
' |=============================|
End Select
Next
End If
End With
End Sub
Public Sub Automate()
Dim doc As New Document
Dim tempPath As String
Dim docName As String
Dim pdfName As String
Application.Interactive = False
Application.ActiveDocument.DocAgentOption.CategoryList = CATEGORY_LIST
Set doc = Application.ActiveDocument
tempPath = Application.GetInstallDirectory(boTemporaryDirectory)
docName = tempPath & doc.Name & ".rep"
pdfName = tempPath & doc.Name & ".pdf"
With doc
SetPrompts .variables
.Refresh
If EMAIL_DOC Or EMAIL_PDF Then
If EMAIL_DOC Then
Call doc.SaveAs(docName)
Else
docName = ""
End If
If EMAIL_PDF Then
Call doc.ExportAsPDF(pdfName)
Else
pdfName = ""
End If
If EMAIL_SUBJECT_USE_REPORT_NAME Then
m_emailSubject = doc.Name
End If
Email docName, pdfName
End If
.Send USER_LIST, False, , CATEGORY_LIST, EXHANGE_MODE, EXCHANGE_DOMAIN
End With
Application.Interactive = True
End Sub
Private Function Get6MonthPreviousStartDate() As String
Dim dtDate As Date
Dim nMonth As Integer
Dim nYear As Integer
nMonth = Month(Now)
nYear = Year(Now)
dtDate = CDate(CStr(nMonth) & "/1/" & CStr(nYear))
dtDate = DateAdd("m", -6, dtDate)
GetStartDate = Format(dtDate, "dd-mmm-yy")
End Function
Private Function GetPreviousFridayDate() As String
Dim nFridaySubtractor As Integer
Dim nMonth As Integer
Dim nYear As Integer
Dim nDay As Integer
Dim nWeekday As Integer
nMonth = Month(Now)
nYear = Year(Now)
nDay = Day(Now)
nWeekday = Weekday(Now)
Select Case nWeekday
Case 0
nFridaySubtractor = 1
Case 1
nFridaySubtractor = 2
Case 2
nFridaySubtractor = 3
Case 3
nFridaySubtractor = 4
Case 4
nFridaySubtractor = 5
Case 5
nFridaySubtractor = 1
Case 6
nFridaySubtractor = 0
End Select
dtDate = CDate(CStr(nMonth) & "/" & CStr(nDay - nFridaySubtractor) & "/" & CStr(nYear))
GetEndDate = Format(dtDate, "dd-mmm-yy")
End Function
Private Function GetPreviousFiscalQuarterStart(ByVal dtDate As Date) As String
Select Case GetQuarter(dtDate)
Case 1
GetPreviousFiscalQuarterStart = Format(CDate("01-Nov-" & CStr(DateAdd("yyyy", -1, Year(Now)))), "dd-mmm-yy")
Case 2
GetPreviousFiscalQuarterStart = Format(CDate("01-Feb-" & CStr(Year(Now))), "dd-mmm-yy")
Case 3
GetPreviousFiscalQuarterStart = Format(CDate("01-May-" & CStr(Year(Now))), "dd-mmm-yy")
Case 4
GetPreviousFiscalQuarterStart = Format(CDate("01-Aug-" & CStr(Year(Now))), "dd-mmm-yy")
End Select
End Function
Private Function GetPreviousFiscalQuarterEnd(ByVal dtDate As Date) As String
Select Case GetQuarter(dtDate)
Case 1
GetPreviousFiscalQuarterEnd = Format(CDate("31-Jan-" & CStr(Year(Now))), "dd-mmm-yy")
Case 2
GetPreviousFiscalQuarterEnd = Format(CDate("30-Apr-" & CStr(Year(Now))), "dd-mmm-yy")
Case 3
GetPreviousFiscalQuarterEnd = Format(CDate("31-Jul-" & CStr(Year(Now))), "dd-mmm-yy")
Case 4
GetPreviousFiscalQuarterEnd = Format(CDate("31-Oct-" & CStr(Year(Now))), "dd-mmm-yy")
End Select
End Function
Private Function GetQuarter(ByVal dtDate As Date) As Integer
Dim sDate As String
sDate = Format(dtDate, "dd-mmm")
Select Case True
Case dtDate >= "01-Nov" And dtDate <= "31-Jan"
GetQuarter = 1
Case dtDate >= "01-Feb" And dtDate <= "30-Apr"
GetQuarter = 2
Case dtDate >= "01-May" And dtDate <= "31-Jul"
GetQuarter = 3
Case dtDate >= "01-Aug" And dtDate <= "31-Oct"
GetQuarter = 4
End Select
End Function
' ||=======================||
' || Email generation code ||
' ||=======================||
Private Sub Email(ByVal docName As String, ByVal pdfName As String)
Dim list As String
Dim attachList As String
Set poSendMail = New clsSendMail
With poSendMail
If GetEmailList(list) Then
.SMTPHost = "localhost"
.From = EMAIL_FROM
.FromDisplayName = EMAIL_FROM_DISPLAY
.Recipient = list ' semi-colon (;) delimited list
.Subject = IIf(EMAIL_SUBJECT_USE_REPORT_NAME, m_emailSubject, EMAIL_SUBJECT)
If EMAIL_DOC Or EMAIL_PDF Then
Select Case True
Case EMAIL_DOC And Not EMAIL_PDF
attachList = docName
Case Not EMAIL_DOC And EMAIL_PDF
attachList = pdfName
Case EMAIL_DOC And EMAIL_PDF
attachList = docName & ";" & pdfName
End Select
.Attachment = attachList
End If
.Message = EMAIL_MESSAGE
.Send
End If
End With
End Sub
Private Function GetEmailList(ByRef list As String) As Boolean
' We'll just bypass this section for now.
' We are going to use a single user for now.
list = EMAIL_RECIPIENT
GetEmailList = True
' This code demonstrates how to get the email list from the repository.
' Note the very LARGE query above. (The query is in Oracle syntax,
' but should port since I tried to avoid using Oracle specific SQL)
' Dim rs As New ADODB.Recordset
' Dim tempString As String
' Dim i As Integer
'
' With rs
' .ActiveConnection = CONNECTION_STRING
' .CursorLocation = adUseClient
' .LockType = adLockBatchOptimistic
' .CursorType = adOpenKeyset
' .Source = EMAIL_LIST_QUERY
' .Open
' Set .ActiveConnection = Nothing
' End With
'
' rs.MoveFirst
' If Not rs.EOF Then
' For i = 1 To rs.RecordCount
' If i = 1 Then
' list = rs!emailaddress
' Else
' list = list & ";" & rs!emailaddress
' End If
' rs.MoveNext
' Next
' GetEmailList = True
' Else
' GetEmailList = False
' End If
'
' Set rs = Nothing
End Function
I added this in a module to get it to run:
Option Explicit
Public Sub RefreshReport()
Dim bca As New BCA_RefreshAndEmail_Class
bca.Automate
End Sub
Now, when you send to Broadcast Agent, all you need to do is select the macro. All else is handled!
Enjoy!
No comments:
Post a Comment