Control Outlook/Email address from module 2

[seca650]

I am completing a Word template from a form in Access. I am able to fill and save the new document.

I want to be able to send the just completed document via Outlook to a predetermined list of e-mail addresses. I am able to open outlook and attach the document using the "appWord.ActiveDocument.SendMail" command, however I do not have control over the distribution and subject line.

Thanks in advance

Ken

 

[VBslammer]

I would capture the document's name and path and automate Outlook to send it as an attachment. If you need help in automating Outlook let us know.

VBSlammer

"You just have to know which screws to turn." - Professor Bob

 

[seca650]

VBslammer;

My code is shown lower down. I am able to, using a form and checkbox, determine if a certain ttemplate should be sent to a distribution list.

My problem is that although I can create an email with my template attached, I still have to manually list the the e-mail addresses. I guess I need help automating Outlook.

Thanks

Ken

Private Sub Command27_Click()
Dim appWord As New Word.Application
Dim logname As String

DoCmd.SetWarnings False
With appWord
.Documents.Add "C:\Bak\log\blank.dot"
.ActiveDocument.ShowSpellingErrors = False
.Visible = True
End With
With appWord.Selection
.GoTo wdGoToBookmark, Name:="fldDATE_LOGGED"
.TypeText Forms!frmlog!DATE_LOGGED
.GoTo wdGoToBookmark, Name:="fldSNC_LOG_NO"
.TypeText Forms!frmlog!SNC_LOG_No
.GoTo wdGoToBookmark, Name:="fldSNC_Contact"
.TypeText Forms!frmlog!SNC_CONTACT
.GoTo wdGoToBookmark, Name:="fldSNC_PHONE"
.TypeText Forms!frmlog!SNC_PHONE
.GoTo wdGoToBookmark, Name:="fldBENTLEY_ID"
.TypeText Forms!frmlog!BENTLEY_ID
.GoTo wdGoToBookmark, Name:="fldBENTLEY_MODULE"
.TypeText Forms!frmlog!BENTLEY_MODULE
.GoTo wdGoToBookmark, Name:="fldPROB_BRIEF"
.TypeText Forms!frmlog!PROB_BRIEF
.GoTo wdGoToBookmark, Name:="fldPROB_DETAIL"
.TypeText Forms!frmlog!PROB_DETAIL
End With

logname = "C:\Bak\log\Sent\log" & SNC_LOG_No & ".DOC"
appWord.ActiveDocument.SaveAs logname

If Forms!frmlog!Check34 = True Then
appWord.ActiveDocument.SendMail
appWord.ActiveDocument.Close
' appWord.Quit
Else
appWord.Quit True
End If
Exit_Command27_Click:
Exit Sub

Err_Command27_Click:
MsgBox Err.Description
Resume Exit_Command27_Click
End Sub

 

[VBslammer]

Since you have the path of the document, you can call a routine to send it:

  logname = "C:\Bak\log\Sent\log" & SNC_LOG_No & ".DOC"
  appWord.ActiveDocument.SaveAs logname
  appWord.Quit

  If Forms!frmlog!Check34 = True Then
    SendDocAsAttachment logname, GetRecipientList()
  End If

Public Function SendDocAsAttachment(ByVal strFile As String, _
                                    ByVal strRecips As String) As Boolean
On Error GoTo ErrHandler
  Dim ol As Outlook.Application
  Dim msg As Outlook.MailItem
  Dim fldOut As Outlook.MAPIFolder
  Dim cbrMenu As Office.CommandBar
  Dim cbrTools As Office.CommandBarPopup
  Dim cbrSend As Office.CommandBarControl
  Dim lngCount As Long
  Dim blnOpen As Boolean
  
  If dir(strFile) <> "" Then
    
    On Error Resume Next
    Set ol = GetObject(, "Outlook.Application")
    
    If Err = 0 Then
      blnOpen = True
    Else
      Set ol = CreateObject("Outlook.Application")
    End If
    
    On Error GoTo ErrHandler
    
    Set msg = ol.CreateItem(olmailitem)
    
    With msg
      .To = strRecips
      .Attachments.Add strFile
      .Subject = "Please see attached file"
      .Body = "Here's the latest report" & vbCrLf
      .Send   'This just places mail in outbox
      
    End With
    
    [green]'if you want to send now, you have to 
    'manipulate the commandbars collection since
    'Outlook doesn't expose a method to do it.

    'open an explorer[/green]
    Call ol.Session.GetDefaultFolder(olFolderOutbox).GetExplorer.ShowPane(olFolderList, False)
    Set fldOut = ol.Session.GetDefaultFolder(olFolderOutbox)
    lngCount = fldOut.Items.count
    
    [green]'capture the send action menu[/green]
    Set cbrMenu = ol.ActiveExplorer.CommandBars("Menu Bar")
    Set cbrTools = cbrMenu.Controls("Tools")
    Set cbrSend = cbrTools.Controls("Send")
    
    [green]'Send now[/green]
    cbrSend.Execute
    
    If Not blnOpen Then
      Do While fldOut.Items.count >= lngCount
        DoEvents
      Loop
    End If
    
    SendDocAsAttachment = True
    
  End If

ExitHere:
  On Error Resume Next
  Set msg = Nothing
  Set cbrSend = Nothing
  Set cbrTools = Nothing
  Set cbrMenu = Nothing
  If Not blnOpen Then
    ol.Quit
  End If
  Set fldOut = Nothing
  Set ol = Nothing
  Exit Function
ErrHandler:
  MsgBox "Error (" & Err & ") - " & Err.Description
  Resume ExitHere
End Function

Function GetRecipientList() As String
On Error GoTo ErrHandler
  Dim rst As Recordset
  Dim strRecipients As String
  
  Set rst = CurrentDb.OpenRecordset("Contacts", dbOpenSnapshot)
  
  While Not rst.EOF
    strRecipients = strRecipients & rst.Fields("email") & ";"
    rst.MoveNext
  Wend
  
ExitHere:
  GetRecipientList = strRecipients
  Exit Function
ErrHandler:
  Debug.Print Err, Err.Description
  Resume ExitHere
End Function

You can also send multuple attachments with a slight modification using a ParamArray for the file arguments.

VBSlammer

"You just have to know which screws to turn." - Professor Bob

 

[seca650]

Thanks VBSlammer,

The program gets hung up on "Dim ol As Outlook.Application" I get an "Compile error User-defined type not defined"

Thanks

 

[PHV]

You have to reference the Microsoft Outlook Object Library:
menu Tools -> References...

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ222-2244

 

[VBslammer]

You'll have to reference the "Microsoft Outlook (version) Object Library" in the vba editor using [tt]Tools --> References[/tt]. Once you reference it, the mail objects will be available to your app.

Here's a trimmed down version of the function that accepts multiple attachments, and uses a separate method for grabbing the Outlook instance:

Public Function SendDocAsAttachment(ByVal strRecips As String, _
                                    ParamArray strAttachments() As Variant) As Boolean
On Error GoTo ErrHandler
  Dim ol As Outlook.Application
  Dim msg As Outlook.MailItem
  Dim fldOut As Outlook.MAPIFolder
  Dim cbrSend As Office.CommandBarControl
  Dim varFile As Variant
  Dim lngCount As Long
  Dim blnAlreadyOpen As Boolean
    
  Set ol = GetOutlookInstance(blnAlreadyOpen)
  
  On Error GoTo ErrHandler
  
  [green]'get the default outbox and number of items waiting for send[/green]
  Set fldOut = ol.Session.GetDefaultFolder(olFolderOutbox)
  lngCount = fldOut.Items.count
  
  Set msg = ol.CreateItem(olmailitem)
  With msg
    .To = strRecips
    For Each varFile In strAttachments
      If dir(varFile) <> "" Then
        .Attachments.Add varFile
      End If
    Next varFile
    .Subject = "Please see attached file(s)"
    .Body = "This is your weekly report mailout." & vbCrLf
    .Send   [green]'This just places mail in outbox[/green]
  End With

  [green]'capture the send action menu[/green]
  Set cbrSend = ol.ActiveExplorer.CommandBars("Menu Bar").Controls("Tools").Controls("Send")
  [green]'Send now[/green]
  cbrSend.Execute
  
  If Not blnAlreadyOpen Then
    Do While fldOut.Items.count > lngCount
      DoEvents
    Loop
  End If
  
  SendDocAsAttachment = True

ExitHere:
  On Error Resume Next
  Set msg = Nothing
  Set cbrSend = Nothing
  If Not blnAlreadyOpen Then
    ol.Quit
  End If
  Set fldOut = Nothing
  Set ol = Nothing
  Exit Function
ErrHandler:
  Debug.Print Err, Err.Description
  Resume ExitHere
End Function

Function GetOutlookInstance(ByRef blnAlreadyOpen As Boolean) As Outlook.Application
On Error Resume Next
  Dim ol As Outlook.Application
  
  Set GetOutlookInstance = GetObject(, "Outlook.Application")
  
  If Err = 0 Then
    blnAlreadyOpen = True
  Else
    Set GetOutlookInstance = CreateObject("Outlook.Application")
    blnAlreadyOpen = False
  End If
  
End Function

VBSlammer

"You just have to know which screws to turn." - Professor Bob

 

[VBslammer]

I left a remnant in the GetOutlookInstance() function that doesn't need to be there:

On Error Resume Next
  Dim ol As Outlook.Application   [red]<-- remove[/red]

VBSlammer

"You just have to know which screws to turn." - Professor Bob

 

[seca650]

VBslammer,

Thanks for this. I am able to run the code without error, except, where do I control the email addresses?.

When I step through the code and I get to the following section:

.To = strRecips

and I slide the cursor over this section, the text tip displays the the attached document with the full path.

Thanks
Ken

 

[VBslammer]

I forgot to point out that I changed the function signature in the second example. The way to call changed version is this:

blnSuccess = SendDocAsAttachment(GetRecipientList(), "C:\file1.doc", "C:\file2.doc", "C:\file3.doc")

blnSuccess = SendDocAsAttachment("boss@us.org;fred@us.org;betty@us.org", "C:\file1.doc")

You can add multiple documents as shown. You can use a function to retrieve the To: addresses, or you can hard-code them in a semi-colon delimited string.

VBSlammer

"You just have to know which screws to turn." - Professor Bob

 

[01Patrik]

Gave me a couple of hints on another matter, leading to a solved problem. Thx

// Patrik
______________________________

To the optimist, the glass is half full. To the pessimist, the glass is half empty. To the IT Professional, the glass is twice as big as it needs to be.