Mail Range or Selection

[kripper]

Good Afternoon Excel Guru's.....

I am having a bit of an issue trying to make a macro created by Ron de Bruin work for me as I want it to, and I was hoping someone may have tried to reconfigure to do the same or would know how to configure it.

Basically I am using the script from Ron's site http://www.rondebruin.nl/win/s1/outlook/amail4.htm, and it works great, however, I am looking for a way to have the columns sized to the width I would like them to be when it creates the email.

Currently, it does not word wrap, and makes some columns extremely large, where others are very small.

I have spent the last several hours trying many different suggestions via web searches, by to no avail.

This Ron's code, exactly what I am using, except for the modifications of the email recipient, priority, etc.

Sub Mail_Range()'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim Source As Range
Dim Dest As Workbook
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim OutApp As Object
Dim OutMail As Object

Set Source = Nothing
On Error Resume Next
Set Source = Range("A1:K50").SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If Source Is Nothing Then
MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
Exit Sub
End If

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

Set wb = ActiveWorkbook
Set Dest = Workbooks.Add(xlWBATWorksheet)

Source.Copy
With Dest.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
End With

TempFilePath = Environ$("temp") & ""
TempFileName = "Selection of " & wb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
FileExtStr = ".xlsx": FileFormatNum = 51
End If

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

With Dest
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.to = "ron@debruin.nl"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Hi there"
.Attachments.Add Dest.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
.Close savechanges:=False
End With

Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

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

Hoping someone can assist me to get the columns to size as I need them to, not pre-formatted by excel or outlook.

Thanks
K.

 

[kpasa]

Just some clarification, are you wanting to format the columns in the xlsx attachment? Or are you trying to embed the table into the message itself?

 

[kripper]

Just some clarification, are you wanting to format the columns in the xlsx attachment? Or are you trying to embed the table into the message itself?

I am trying to embed the table into the message body, and when I do, I end up with each column at varying widths, and I am want to set teach column in the message at a specific width so as standardize the look and overall message.

 

[paulxmw]

Hi this is a pretty easy fix as long as your using a button to sent the emails simply use this code

Dim xlRng As Range   'Auto fit to cell
        Dim strCol1 As String ' add further columns as needed
        Dim strCol2 As String
        Dim strCol3 As String
        Dim strCol4 As String
        Dim strRange As String
        strCol1 = "A"
        strCol2 = "B"
        strCol2 = "C"
        strCol2 = "D"

then use Call macro from a module the macro is placed in e.g.

Call Send_Row_Or_Rows_2() ' macro name

Hope this helps Paul

 

[kripper]

Hi this is a pretty easy fix as long as your using a button to sent the emails simply use this code

Dim xlRng As Range   'Auto fit to cell
        Dim strCol1 As String ' add further columns as needed
        Dim strCol2 As String
        Dim strCol3 As String
        Dim strCol4 As String
        Dim strRange As String
        strCol1 = "A"
        strCol2 = "B"
        strCol2 = "C"
        strCol2 = "D"

then use Call macro from a module the macro is placed in e.g.

Call Send_Row_Or_Rows_2() ' macro name

Hope this helps Paul

Thanks for the reply Paul, however, tried it multiple ways, and without any success, columns within the email body still auto adjust to header title without word wrapping, making some columns 1" and others 6" to 10".

 

[paulxmw]

Hi

I had a mess around and came up with this

Private Sub CommandButton1_Click()


        
        Dim xlRng As Range   'Auto fit to cell
        Dim strCol1 As String
        Dim strCol2 As String
        Dim strCol3 As String
        Dim strCol4 As String
        Dim strRange As String
        strCol1 = "A"
        strCol2 = "B"
        strCol2 = "C"
        strCol2 = "D"
        strRange = strCol1 & ":" & strCol2
        Set xlRng = ActiveSheet.Columns(strRange)
        xlRng.AutoFit
        'Save
        Application.DisplayAlerts = False
        ActiveWorkbook.Save

    

Dim Source As Range
Dim Dest As Workbook
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim OutApp As Object
Dim OutMail As Object

Set Source = Nothing
On Error Resume Next
Set Source = Range("A1:K50").SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If Source Is Nothing Then
MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
Exit Sub
End If

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

Set wb = ActiveWorkbook
Set Dest = Workbooks.Add(xlWBATWorksheet)

Source.Copy
With Dest.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
End With

TempFilePath = Environ$("temp") & ""
TempFileName = "Selection of " & wb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
FileExtStr = ".xlsx": FileFormatNum = 51
End If

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

With Dest
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.to = "ron@debruin.nl"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Hi there"
.Attachments.Add Dest.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Send
End With
On Error GoTo 0
.Close savechanges:=False
End With

Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

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

hope its what your looking for

Paul