locked
Access 2010 Using Outlook 2010 to send multiple attachments RRS feed

  • Question

  • Hello. I have an access 2010 database that was using groupwise to send emails. I have the code set up to and it works to send email notification without attachements. I just cannot get the code to work to send multiple attachments. Here is the current code.

    Public Sub SendSQLEmail(AddressTo As Variant, Header As String, Message As String, Optional PriorityHigh As Boolean, Optional AddressCC As Variant, Optional AddressBCC As Variant, _
                                Optional FileAttach As Variant, Optional MessageFromText As Variant)
        '  Procedure added February 2010 to handle HTML emails . . . due to Groupwise Version 8
        Dim strFrom As String
        Dim fHTML As Boolean
        Dim iHTML As Integer
        Dim strTo As String
        Dim strCC As String
        Dim strBCC As String
        Dim strODBC  As String
        Dim qdf As QueryDef
        Dim sSQL As String
        Dim strHTML As String
        Dim bAttachment As Boolean
        Dim varAttach(5) As Variant
        Dim i As Integer
        Dim k As Integer
    
        
           
            If IsMissing(FileAttach) = True Then
                bAttachment = False
            Else
                bAttachment = True
                '  parse out the names
                k = 0
                Do
                    i = InStr(FileAttach, "~")
                    If i = 0 Then
                        varAttach(k) = FileAttach
                    Else
                        varAttach(k) = Left(FileAttach, i - 1)
                        FileAttach = Mid(FileAttach, i + 1)
                    End If
                    k = k + 1
                    If k > 5 Then Exit Do
                Loop Until i = 0
            End If
    
        
        '  Has the from been specified?
        If IsMissing(MessageFromText) = True Then
            
            strFrom = GetUserEmailFromGID(GetUSERID)
        Else
            strFrom = CStr(MessageFromText)
        End If
        
        '  Is there HTML in the body of the message
        If Left(Message, 1) = "<" Then
            fHTML = True
            iHTML = -1
            strHTML = "Y"
        Else
            fHTML = False
            iHTML = 0
            strHTML = "N"
        End If
        
          For Each varAttach In Split(FileAttach, ";")
              varAttach = Trim(varAttach)
              If Len(varAttach) > 0 Then
                  .Attachments.Add (varAttach)
              End If
        
        strTo = ParseVariantTo(AddressTo)
        strCC = ParseVariantTo(AddressCC)
        strBCC = ParseVariantTo(AddressBCC)
        
        Dim db As Database
        Dim rs As Recordset
        
        Set db = ServerDB
        Set rs = db.OpenRecordset("EmailSQL", dbOpenDynaset, dbSeeChanges)
       
       On Error GoTo ErrHandler:
       
        '  Add the user as a CC to the email so they will see it in their mail box
        If Len(strCC) = 0 Then
            strCC = strFrom
        Else
            strCC = strCC + "," + strFrom
        End If
        '  Handle any apostrophes in the string
        Header = SQLApostropheString(Header)
        Message = SQLApostropheString(Message)
        '  use the sql pASS THROUGH TO TAKE CARE OF APOSTROPHES IN THE sql sTRINGS
       
        Set rs = Nothing
        Set db = Nothing
        
        '************
        '  SQL PASS THROUGH
        
        '  set the ODBC Connection
        '  TO DO - Get connection string from database table ODBC
        strODBC = "ODBC;DSN=EmailSQL;SRVR=fr01apttbco2;DATABASE=CentralizedProcesses;UID=HREMail;PWD=hr39email;"
        
        '  Problem - the string generated in the variable sSQL will run in a SQL Server query window just fine,
        '  but fails in this pass through query?? - back to adding to the table above.
        
        '  Header - Message - To
        '  Header - Message - To
        sSQL = "exec cp_InsertHREmail " + "'" + Header + "'" + "," + "'" + Message + "'" + "," + "'" + strTo + "'" + ","
        '  From - CC - BCC - Attachments
        sSQL = sSQL + "'" + strFrom + "'" + "," + "'" + strCC + "'" + "," + "'" + strBCC + "'" + "," + "''"
        
        Set db = Currentdb
        Set qdf = db.CreateQueryDef("")
        '  Connect to SQL Server
        qdf.Connect = strODBC
        qdf.ReturnsRecords = False
        qdf.SQL = sSQL
        db.QueryTimeout = 2000 ' 4 minutes
        qdf.ODBCTimeout = 1000
        qdf.Execute
        
        Set qdf = Nothing
        Set db = Nothing
        '**********************************
        Exit Sub
        
    ErrHandler:
        Dim strErr As String
        
        strErr = "Error Sending Email: "
        strErr = strErr + CStr(Err.Number)
        strErr = strErr + " - "
        strErr = strErr + CStr(Err.Description)
        strErr = strErr + " - "
        strErr = strErr + CStr(Err.HelpContext)
        strErr = strErr + " - "
        strErr = strErr + CStr(Err.Source)
        
        
        MsgBox strErr, vbCritical, "Error!"
        
    
    End Sub

    Any help on this would be appreciated. I need to get this working by Friday, February 21 as GroupWise is going away.

    Deanna

    Saturday, February 15, 2014 11:13 PM