Results 1 to 2 of 2
  1. #1
    Join Date
    Dec 2005

    Question Unanswered: Adding Attachments to Emails thru Vb

    Recently we changed to Google Apps and for a while we could not have Access create automatic emails due to Google Apps not being a client, but a web based application. With Lotus Notes, we used a macro and the SendObject command so we could add attachments.

    We have now found out how to create emails thru Vb code in Access and use the RunCode command in the macro to start the process.

    It works fine but there is a problem. The macro creates a exported Excel file to location G:\Share\Loss Prevention\Access Applications\Location Verification Program\Report For Email\EFC Address Verification.xls

    I need to attach the Excel file to the created email, but I am struggling with proper code to accomplish this with. Does anyone know how to accomplish this? The current code is shown below -
    __________________________________________________ _______

    Option Compare Database

    Public strChromeURL As String

    Public Function GenerateGMailEmailCATAX2()

    Dim subject As String, Body As String

    'Create as many string variables as you need
    Dim toString As String
    Dim ccString As String
    Dim bccString As String
    Dim LPTK As String
    Dim LPName As String

    'Pull your data from your hidden forms and set them to variables
    'Use your variables to set relevant information in the subject, body, or e-mail addresses
    toString = Forms!Email_Addresses_Hidden!CATAXTo
    ccString = Forms!Email_Addresses_Hidden!CATAXCC
    bccString = Forms!Email_Addresses_Hidden!CATAXBCC
    LPTK = fOSUserName()
    LPName = fGetFullNameOfLoggedUser()

    'Use the below as a template. The %0a is a new line character for URL-encoding
    subject = "E-Sales Report"
    Body = "Attention:" & "%0a" & "%0a" & "Attached is the E-Sales report for ??/??/????" _
    & "%0a" & "%0a" & "%0a" & "%0a" & "Loss Prevention Associate: " & LPTK & " - " & LPName _

    'The below string has sends to two addresses in the to line.
    'If you want to send to more than two, you have to add another & someVariable & ", "
    strChromeURL = "" & toString & "&cc=" & ccString & "&bcc=" & bccString & "&su=" & subject & "&body=" & Body

    strChromePath = GetChromePath

    If strChromePath = "CHROME_NOT_FOUND" Then

    Call MsgBox("Unable to locate the GApps [Chrome] Browser!" & vbCrLf & vbCrLf & "Please copy the text below and paste it into the Address bar of the GApps [Chrome] Browser to compose the email message: " & vbCrLf & vdcrlf & strChromeURL, vbCritical, "Unable to locate the GApps [Chrome] Browser!")


    Dim kohlsMailURL As String
    kohlsMailURL = ""

    'This string opens GMail and logs on
    strRunString = Chr(34) & strChromePath & Chr(34) & " " & Chr(34) & kohlsMailURL & Chr(34)
    Call Shell(strRunString)

    'This sets the length of time to wait for GMail to load and log on
    'To change the length of time, change the integer below from 25 to however long you want it to wait
    TWait = Time
    TWait = DateAdd("s", 25, TWait)
    Do Until TNow >= TWait
    TNow = Time

    'This string opens a new message and generates the fields
    strRunString = Chr(34) & strChromePath & Chr(34) & " " & Chr(34) & strChromeURL & Chr(34)
    Call Shell(strRunString)

    End If

    MsgBox "The program has created a notification email that must be sent by the user. The completed Excel report has created today's copy at G:\Share\Loss Prevention\Access Applications\Location Verification Program\Report For Email\EFC Address Verification.xls. Attach a copy of this Excel file to this email before sending. It is your responsibility to make sure this email with attachment is sent ASAP!", vbOKOnly, "EFC Address Verification Program"

    End Function

    Public Function GetChromePath() As String

    'Setting Default value, in case no path is located
    GetChromePath = "CHROME_NOT_FOUND"

    Dim strSysDrive As String
    strSysDrive = Environ("SYSTEMDRIVE")

    Dim strUserName As String
    strUserName = Environ("USERNAME")

    Dim fso
    Dim file As String

    Set fso = CreateObject("Scripting.FileSystemObject")

    'Checking for default install path
    file = strSysDrive & "\Program Files\Google\Chrome\Application\chrome.exe" ' change to match the file w/Path
    If fso.FileExists(file) Then
    GetChromePath = file
    Exit Function
    End If

    'Checking user path in XP
    file = strSysDrive & "\Documents and Settings\" & strUserName & "\Local Settings\Application Data\Google\Chrome\Application\chrome.exe"
    If fso.FileExists(file) Then
    GetChromePath = file
    Exit Function
    End If

    'Checking user path in Vista (default in Winows 7 too)
    file = strSysDrive & "\Users\" & strUserName & "\AppData\Local\Google\Chrome\Application\chrome.e xe"
    If fso.FileExists(file) Then
    GetChromePath = file
    Exit Function
    End If

    'Checking alternate path in Windows 7
    file = strSysDrive & "\Users\" & strUserName & "\AppData\Local\Google\chrome.exe"
    If fso.FileExists(file) Then
    GetChromePath = file
    Exit Function
    End If

    Exit Function

    End Function

  2. #2
    Join Date
    Jul 2004
    South Dakota

    Have you ever tried using CDO to send emails from Gmail? I don't use Google Apps but I do this for my personal Gmail account. Thought I would share it in case it might work for you.

    Public Function SendEmail(pFrom As String, pTo As String, pSubj As String, _
        Optional pBody As String, Optional pAttach As String) As Boolean
        On Error GoTo ErrHandler
        Dim objMessage As Object
        Set objMessage = CreateObject("CDO.Message")
        objMessage.From = pFrom
        objMessage.To = pTo
        objMessage.Subject = pSubj
        objMessage.HTMLBody = pBody
        If pAttach <> "" Then objMessage.AddAttachment pAttach
        With objMessage.Configuration.Fields
            .Item("") = 2
            'Name or IP of Remote SMTP Server
            .Item("") = ""
            'Server port (typically 25)
            .Item("") = 465
            .Item("") = 1  'Use SSL for the connection
            .Item("") = 60
            .Item("") = 1  'basic (clear-text) authentication
            .Item("") = ""
            .Item("") = "yourpasswordhere"
        End With
        'if made it here then email was sent
        SendEmail = True
        Set objMessage = Nothing
        Exit Function
        SendEmail = False
        Resume ExitHere
    End Function

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts