Makro za Outlook-proces slanja jedne excel tabele iz određenog sheeta

Code:

Option Explicit

' Code: Send E-mail without Security Warnings
' OUTLOOK 2003 VBA CODE FOR 'ThisOutlookSession' MODULE
' (c) 2005 Wayne Phillips (http://www.everythingaccess.com)
' Written 07/05/2005
' Last updated v1.4 - 26/03/2008
'
' Please read the full tutorial here:
' http://www.everythingaccess.co...-mail-without-Security-Warning
'
' Please leave the copyright notices in place - Thank you.

Private Sub Application_Startup()

    'IGNORE - This forces the VBA project to open and be accessible using automation
    '         at any point after startup

End Sub

' FnSendMailSafe
' --------------
' Simply sends an e-mail using Outlook/Simple MAPI.
' Calling this function by Automation will prevent the warnings
' 'A program is trying to send a mesage on your behalf...'
' Also features optional HTML message body and attachments by file path.
'
' The To/CC/BCC/Attachments function parameters can contain multiple items by seperating
' them by a semicolon. (e.g. for the strTo parameter, '[email protected]; [email protected]' is
' acceptable for sending to multiple recipients.
'
Public Function FnSendMailSafe(strTo As String, _
                                strCC As String, _
                                strBCC As String, _
                                strSubject As String, _
                                strMessageBody As String, _
                                Optional strAttachments As String) As Boolean

' (c) 2005 Wayne Phillips - Written 07/05/2005
' Last updated 26/03/2008 - Bugfix for empty recipient strings
' http://www.everythingaccess.com
'
' You are free to use this code within your application(s)
' as long as the copyright notice and this message remains intact.

On Error GoTo ErrorHandler:

    Dim MAPISession As Outlook.NameSpace
    Dim MAPIFolder As Outlook.MAPIFolder
    Dim MAPIMailItem As Outlook.MailItem
    Dim oRecipient As Outlook.Recipient
    
    Dim TempArray() As String
    Dim varArrayItem As Variant
    Dim strEmailAddress As String
    Dim strAttachmentPath As String
    
    Dim blnSuccessful As Boolean

    'Get the MAPI NameSpace object
    Set MAPISession = Application.Session
    
    If Not MAPISession Is Nothing Then

      'Logon to the MAPI session
      MAPISession.Logon , , True, False

      'Create a pointer to the Outbox folder
      Set MAPIFolder = MAPISession.GetDefaultFolder(olFolderOutbox)
      If Not MAPIFolder Is Nothing Then

        'Create a new mail item in the "Outbox" folder
        Set MAPIMailItem = MAPIFolder.Items.Add(olMailItem)
        If Not MAPIMailItem Is Nothing Then
          
          With MAPIMailItem

            'Create the recipients TO
                TempArray = Split(strTo, ";")
                For Each varArrayItem In TempArray
                
                    strEmailAddress = Trim(varArrayItem)
                    If Len(strEmailAddress) > 0 Then
                        Set oRecipient = .Recipients.Add(strEmailAddress)
                        oRecipient.Type = olTo
                        Set oRecipient = Nothing
                    End If
                
                Next varArrayItem
            
            'Create the recipients CC
                TempArray = Split(strCC, ";")
                For Each varArrayItem In TempArray
                
                    strEmailAddress = Trim(varArrayItem)
                    If Len(strEmailAddress) > 0 Then
                        Set oRecipient = .Recipients.Add(strEmailAddress)
                        oRecipient.Type = olCC
                        Set oRecipient = Nothing
                    End If
                
                Next varArrayItem
            
            'Create the recipients BCC
                TempArray = Split(strBCC, ";")
                For Each varArrayItem In TempArray
                
                    strEmailAddress = Trim(varArrayItem)
                    If Len(strEmailAddress) > 0 Then
                        Set oRecipient = .Recipients.Add(strEmailAddress)
                        oRecipient.Type = olBCC
                        Set oRecipient = Nothing
                    End If
                
                Next varArrayItem
            
            'Set the message SUBJECT
                .Subject = strSubject
            
            'Set the message BODY (HTML or plain text)
                If StrComp(Left(strMessageBody, 6), "<HTML>", vbTextCompare) = 0 Then
                    .HTMLBody = strMessageBody
                Else
                    .Body = strMessageBody
                End If

            'Add any specified attachments
                TempArray = Split(strAttachments, ";")
                For Each varArrayItem In TempArray
                
                    strAttachmentPath = Trim(varArrayItem)
                    If Len(strAttachmentPath) > 0 Then
                        .Attachments.Add strAttachmentPath
                    End If
                
                Next varArrayItem

            .Send 'No return value since the message will remain in the outbox if it fails to send

            Set MAPIMailItem = Nothing
            
          End With

        End If

        Set MAPIFolder = Nothing
      
      End If

      MAPISession.Logoff
      
    End If
    
    'If we got to here, then we shall assume everything went ok.
    blnSuccessful = True
    
ExitRoutine:
    Set MAPISession = Nothing
    FnSendMailSafe = blnSuccessful
    
    Exit Function
    
ErrorHandler:
    MsgBox "An error has occured in the user defined Outlook VBA function FnSendMailSafe()" & vbCrLf & vbCrLf & _
            "Error Number: " & CStr(Err.Number) & vbCrLf & _
            "Error Description: " & Err.Description, vbApplicationModal + vbCritical
    Resume ExitRoutine

End Function

Code:

Option Explicit

' ACCESS VBA MODULE: Send E-mail without Security Warning
' (c) 2005 Wayne Phillips (http://www.everythingaccess.com)
' Written 07/05/2005
' Last updated v1.3 - 11/11/2005
'
' Please read the full tutorial & code here:
' http://www.everythingaccess.co...-mail-without-Security-Warning
'
' Please leave the copyright notices in place - Thank you.

'This is a test function - replace the e-mail addresses with your own before executing!!
'(CC/BCC can be blank strings, attachments string is optional)

Sub FnTestSafeSendEmail(strEmailTo As String, strSubject As String, strBody As String, strAttachment As String, Optional strEmailCC, Optional strEmailBCC As String)
    Dim blnSuccessful As Boolean
    Dim strHTML As String
        
'    strHTML = "<html>" & _
'               "<body>" & _
'               "My <b><i>HTML</i></b> message text!" & _
'               "</body>" & _
'               "</html>"
'    blnSuccessful = FnSafeSendEmail("[email protected]", _
'                                    "My Message Subject", _
'                                    strHTML)
    
  blnSuccessful = FnSafeSendEmail(strEmailTo, strSubject, strBody, strAttachment, _
                                  IIf(strEmailCC <> "", strEmailCC, ""), IIf(strEmailBCC <> "", strEmailBCC, ""))
    'A more complex example...
    'blnSuccessful = FnSafeSendEmail("[email protected]; [email protected]", _
                                         "My Message Subject", _
                                         strHTML, _
                                         "C:\MyAttachmentFile1.txt; C:\MyAttachmentFile2.txt", _
                                         "[email protected]", _
                                         "[email protected]")
    If blnSuccessful Then
    
        ' msgbox "E-mail message sent successfully!"
        
    Else
    
        MsgBox "Failed to send e-mail to " & strEmailTo
    
    End If

End Sub


'This is the procedure that calls the exposed Outlook VBA function...
Public Function FnSafeSendEmail(strTo As String, _
                    strSubject As String, _
                    strMessageBody As String, _
                    Optional strAttachmentPaths As String, _
                    Optional strCC As String, _
                    Optional strBCC As String) As Boolean

    Dim objOutlook As Object ' Note: Must be late-binding.
    Dim objNameSpace As Object
    Dim objExplorer As Object
    Dim blnSuccessful As Boolean
    Dim blnNewInstance As Boolean
    
    'Is an instance of Outlook already open that we can bind to?
    On Error Resume Next
    Set objOutlook = GetObject(, "Outlook.Application")
    On Error GoTo 0
    
    If objOutlook Is Nothing Then
    
        'Outlook isn't already running - create a new instance...
        Set objOutlook = CreateObject("Outlook.Application")
        blnNewInstance = True
        'We need to instantiate the Visual Basic environment... (messy)
        Set objNameSpace = objOutlook.GetNamespace("MAPI")
        Set objExplorer = objOutlook.Explorers.Add(objNameSpace.Folders(1), 0)
        objExplorer.CommandBars.FindControl(, 1695).Execute
                
        objExplorer.Close
                
        Set objNameSpace = Nothing
        Set objExplorer = Nothing
        
    End If

    blnSuccessful = objOutlook.FnSendMailSafe(strTo, strCC, strBCC, _
                                                strSubject, strMessageBody, _
                                                strAttachmentPaths)
                                
    If blnNewInstance = True Then objOutlook.Quit
    Set objOutlook = Nothing
    
    FnSafeSendEmail = blnSuccessful
    
End Function

Code:

        Call FnTestSafeSendEmail(txtEmail, emailSubject, _
                                 emailBody, Application.CurrentProject.Path & "\blablabla.xls", "", "")