EXCEL Send ActiveWorkbook via E-mail with Outlook VBA

Mrrrr's Forum (VIEW ONLY)
Un forum care ofera solutii pentru unele probleme legate in general de PC. Pe langa solutii, aici puteti gasi si alte lucruri interesante // A forum that offers solutions to some PC related issues. Besides these, here you can find more interesting stuff.

Lista Forumurilor Pe Tematici

Mrrrr's Forum (VIEW ONLY) | Reguli | Inregistrare | Login

POZE MRRRR'S FORUM (VIEW ONLY)

Nu sunteti logat.

Nou pe simpatie:
Tanya_sexy la Simpatie.ro

Femeie
24 ani
Hunedoara
cauta Barbat
24 - 47 ani

Mrrrr's Forum (VIEW ONLY) / Tutoriale si Ghiduri Utile // Tutorials and useful guides / [EXCEL] Send ActiveWorkbook via E-mail with Outlook [VBA]

Moderat de TRaP, TonyTzu

Autor

Mesaj

Pagini: 1

Mrrrr
AdMiN

Inregistrat: acum 17 ani
Postari: 2186

I repeat what I mentioned in the title: this is made to work with Outlook.

Code below consists of 2 parts:
- part 1 is a function that concatenates a range of cells to 1 cell in a sheet called emails
- part 2 is a code that sends the active workbook attached and adds your default Outlook signature if you have one
- the code puts you as the .To person and adds all those addresses in emails sheet to .CC field
- the code also hides the emails sheet (it's very hidden, it can be shown only programatically with VBA code) - it can't be unhidden by a normal user who doesn't know VBA
- the attached file has the name of the file you are editing + "updated at dd-mm-yyyy, hour hh-mm"

Code:

Function TConcat(r As Range, Optional delim As String = "; ") As String
'if you add the delim in the above line, you don't need formula with delimiter, simply:
'=PERSONAL.XLSB!TConcat(A1:A40)
'otherwise, default delimiter was " ", and you need to specify delimiter in formula:
'=PERSONAL.XLSB!TConcat(A1:A40;"; ")
    For Each c In r
        If IsEmpty(c.Value) Then
        Else
            If Len(TConcat) = 0 Then
                TConcat = c.Value
            Else
                TConcat = TConcat & delim & c.Value
            End If
        End If
    Next
End Function

Sub SendActiveWBk(control As IRibbonControl)
'For Tips see: http://www.rondebruin.nl/win/s1/outlook/amail1.htm
'Working in Excel 2000-2016

    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody, signature As String
    
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExt As String
    Dim FileFullPath As String
    Dim MyWb As Workbook
    
    Set MyWb = ActiveWorkbook
    
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
End With

Worksheets("emails").Range("B1").Value = ""
Worksheets("emails").Visible = 2
TempFilePath = Environ$("temp") & "\"
TempFileName = Replace(MyWb.Name, ".xlsx", "")
FileExt = ".xlsx"
TempFileName = TempFileName & " updated at " & Format(Now, "dd.mm.yyyy" & " hour " & "hh.mm")
FileFullPath = TempFilePath & TempFileName & FileExt
MyWb.SaveCopyAs FileFullPath
Worksheets("emails").Visible = True
Worksheets("emails").Range("B1").Value = "=tconcat(A1:A500)"

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

' OUTLOOK SIGNATURE ##################################################################################################
    With OutMail
    .display
    End With
        signature = OutMail.HTMLbody
        
    On Error Resume Next
    With OutMail
        .To = "ema[i]il@e[/i]mail.com"
        .CC = MyWb.Worksheets("emails").Range("B1").Value
        .BCC = ""
        .Subject = "E-MAIL SUBJECT " & Date
        .HTMLbody = "<br></br><br></br><i>Have a nice day!<br></br><br></br>Best regards</i><br></br>" & signature
        .Attachments.Add FileFullPath
        'You can add a file like this
        '.Attachments.Add ("C:\test.txt")
        
        .display 'or use:
        '.Send
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
End With

End Sub

_______________________________________

pus acum 5 ani

TRaP
Moderator

Inregistrat: acum 6 ani
Postari: 739

The code above is made for a specific list of e-mails existing in a sheet of the active workbook.

For sending any workbook, without adding a predefined list of e-mails and a subject, below is the code.
All the code that was removed can still be found in the post above.

Sub Send_ActiveWBk_eMail()
'For Tips see: http://www.rondebruin.nl/win/s1/outlook/amail1.htm
'Working in Excel 2000-2016

Dim OutApp As Object
Dim OutMail As Object
Dim strbody, signature As String

Dim TempFilePath As String
Dim TempFileName As String
Dim FileExt As String
Dim FileFullPath As String
Dim MyWb As Workbook

Set MyWb = ActiveWorkbook

With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With

TempFilePath = Environ$("temp") & "\"
TempFileName = Replace(MyWb.Name, ".xlsx", "")
FileExt = ".xlsx"
TempFileName = TempFileName & " actualizat in " & Format(Now, "dd.mm.yyyy" & " la ora " & "hh.mm")
FileFullPath = TempFilePath & TempFileName & FileExt
MyWb.SaveCopyAs FileFullPath

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

' OUTLOOK SIGNATURE ##################################################################################################
With OutMail
.display
End With
signature = OutMail.HTMLbody

On Error Resume Next
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = ""
.HTMLbody = "<br></br><br></br>" & signature
.Attachments.Add FileFullPath
'You can add a file like this
'.Attachments.Add ("C:\test.txt")

.display 'or use:
'.Send
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With

End Sub

pus acum 3 ani

Pagini: 1

Mergi la