Hi Guys, i've below code working perfectly. The VBA will draft me an email which will look up distribution list listed on the excel and attachment is saved in folder and attached together with the email. For email body, i've it copy a range from an excel sheet and paste as bitmap in the email body.
The question is i can't get the bitmap pic to paste on center on the email body. Appreciate any help!
CODE:
Option Explicit
Sub Email()
Dim objfile As FileSystemObject
Dim xNewFolder
Dim xDir As String, xMonth As String, xFile As String, xPath As String
Dim NameX As Name, xStp As Long
Dim xDate As Date, AWBookPath As String
Dim currentWB As Workbook, newWB As Workbook
Dim strEmailSentOnBehalfOfName As String, strEmailTo As String, strEmailCC As String, strEmailBCC As String, strDistroList As String
AWBookPath = ActiveWorkbook.Path & ""
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set currentWB = ActiveWorkbook
'***************** Minus 15 days to Capture Fiscal Month *******************
xDate = Date - Day(15)
'****************************** Select Sheets ******************************
Sheets(Array("A", "B", "C")).Copy
Set newWB = ActiveWorkbook
'***************************** Create Pathway ******************************
xDir = AWBookPath
xMonth = Format(xDate, "mmm yyyy") & ""
xFile = "ABC"
xPath = xDir & xMonth & xFile
'****************** Create Folder, Save, & Rewrite File ********************
Set objfile = New FileSystemObject
If objfile.FolderExists(xDir & xMonth) Then
If objfile.FileExists(xPath) Then
objfile.DeleteFile (xPath)
newWB.SaveAs Filename:=xPath, FileFormat:=xlOpenXMLWorkbook, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
Application.ActiveWorkbook.Close
Else
newWB.SaveAs Filename:=xPath, FileFormat:=xlOpenXMLWorkbook, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
Application.ActiveWorkbook.Close
End If
Else
xNewFolder = xDir & xMonth
MkDir xNewFolder
newWB.SaveAs Filename:=xPath, FileFormat:=xlOpenXMLWorkbook, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
Application.ActiveWorkbook.Close
End If
'***************************** Distro List ******************************
currentWB.Activate
Sheets("Distro").Visible = True
Sheets("Distro").Select
strEmailSentOnBehalfOfName = ""
strEmailTo = ""
strEmailCC = ""
strEmailBCC = ""
xStp = 1
Do Until xStp = 5
Cells(2, xStp).Select
Do Until ActiveCell = ""
strDistroList = ActiveCell.Value
If xStp = 1 Then strEmailSentOnBehalfOfName = strEmailSentOnBehalfOfName & strDistroList & ""
If xStp = 2 Then strEmailTo = strEmailTo & strDistroList & "; "
If xStp = 3 Then strEmailCC = strEmailCC & strDistroList & "; "
If xStp = 4 Then strEmailBCC = strEmailBCC & strDistroList & "; "
ActiveCell.Offset(1, 0).Select
Loop
xStp = xStp + 1
Loop
Range("A1").Select
'********************** Copy Area as Word to Paste ***********************
Const Sp_Ch As String = " "
Const wdPasteBitmap As Long = 9
Const wdPasteDeviceIndependentBitmap As Long = 5
Const wdPasteEnhancedMetafile As Long = 9
Const wdPasteHTML As Long = 10
Const wdPasteHyperlink As Long = 7
Const wdPasteMetafilePicture As Long = 3
Const wdPasteOLEObject As Long = 0
Const wdPasteRTF As Long = 1
Const wdPasteShape As Long = 8
Const wdPasteText As Long = 2
Const wd_PasteGIF As Long = 13
Const wd_PastePNG As Long = 14
Const wd_PasteJPG As Long = 15
Const olFolderInBox As Long = 6
Const olMailItem As Long = 0
Const wdInLine As Long = 0
Dim excSht As Excel.Worksheet
Dim excTbl As Excel.Range
Dim excChrt As Excel.ChartObject
Dim olkApp As Object
Dim olkMsg As Object
Dim olkDoc As Object
Dim olkEndOfDoc As Object
Dim WasOutlookOpenedByCode As Boolean
Set excSht = ThisWorkbook.Worksheets("Body")
Set excTbl = excSht.Range("B2:M36")
On Error Resume Next
Set olkApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If olkApp Is Nothing Then
Set olkApp = CreateObject("Outlook.Application")
olkApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInBox).Display
WasOutlookOpenedByCode = True
End If
'***************************** Draft Email ******************************
Set olkMsg = olkApp.CreateItem(olMailItem)
With olkMsg
.Subject = Left(xFile, 33)
.SentOnBehalfOfName = strEmailSentOnBehalfOfName
.To = strEmailTo
.CC = strEmailCC
.BCC = strEmailBCC
.Body = ""
.Attachments.Add xPath
.Display '***** Instead of Display can set to Auto Send *****
Set olkDoc = .GetInspector.WordEditor
End With
GetEndOfDoc(olkDoc).InsertParagraph
excTbl.Copy
GetEndOfDoc(olkDoc).PasteSpecial Placement:=wdInLine, DataType:=wdPasteBitmap
For Each excChrt In excSht.ChartObjects
With excChrt
Select Case Right(.Name, Len(.Name) - InStr(1, .Name, Sp_Ch, vbBinaryCompare))
Case 1, 2, 12 - 20
GetEndOfDoc(olkDoc).InsertParagraph
GetEndOfDoc(olkDoc).InsertParagraph
.CopyPicture xlScreen, xlBitmap
GetEndOfDoc(olkDoc).PasteSpecial Placement:=wdInLine, DataType:=wdPasteBitmap
Case Else
End Select
End With
Next excChrt
If WasOutlookOpenedByCode Then
End If
Set olkDoc = Nothing
Set olkMsg = Nothing
Set olkApp = Nothing
Set excTbl = Nothing
Set excSht = Nothing
End Sub
Private Function GetEndOfDoc(Wrd_Doc As Object) As Object
With Wrd_Doc
Set GetEndOfDoc = .Range(.Range.End - 1, .Range.End)
Sheets("Draft").Select
Cells(1, 1).Select
End With
End Function
The question is i can't get the bitmap pic to paste on center on the email body. Appreciate any help!
CODE:
Option Explicit
Sub Email()
Dim objfile As FileSystemObject
Dim xNewFolder
Dim xDir As String, xMonth As String, xFile As String, xPath As String
Dim NameX As Name, xStp As Long
Dim xDate As Date, AWBookPath As String
Dim currentWB As Workbook, newWB As Workbook
Dim strEmailSentOnBehalfOfName As String, strEmailTo As String, strEmailCC As String, strEmailBCC As String, strDistroList As String
AWBookPath = ActiveWorkbook.Path & ""
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set currentWB = ActiveWorkbook
'***************** Minus 15 days to Capture Fiscal Month *******************
xDate = Date - Day(15)
'****************************** Select Sheets ******************************
Sheets(Array("A", "B", "C")).Copy
Set newWB = ActiveWorkbook
'***************************** Create Pathway ******************************
xDir = AWBookPath
xMonth = Format(xDate, "mmm yyyy") & ""
xFile = "ABC"
xPath = xDir & xMonth & xFile
'****************** Create Folder, Save, & Rewrite File ********************
Set objfile = New FileSystemObject
If objfile.FolderExists(xDir & xMonth) Then
If objfile.FileExists(xPath) Then
objfile.DeleteFile (xPath)
newWB.SaveAs Filename:=xPath, FileFormat:=xlOpenXMLWorkbook, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
Application.ActiveWorkbook.Close
Else
newWB.SaveAs Filename:=xPath, FileFormat:=xlOpenXMLWorkbook, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
Application.ActiveWorkbook.Close
End If
Else
xNewFolder = xDir & xMonth
MkDir xNewFolder
newWB.SaveAs Filename:=xPath, FileFormat:=xlOpenXMLWorkbook, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
Application.ActiveWorkbook.Close
End If
'***************************** Distro List ******************************
currentWB.Activate
Sheets("Distro").Visible = True
Sheets("Distro").Select
strEmailSentOnBehalfOfName = ""
strEmailTo = ""
strEmailCC = ""
strEmailBCC = ""
xStp = 1
Do Until xStp = 5
Cells(2, xStp).Select
Do Until ActiveCell = ""
strDistroList = ActiveCell.Value
If xStp = 1 Then strEmailSentOnBehalfOfName = strEmailSentOnBehalfOfName & strDistroList & ""
If xStp = 2 Then strEmailTo = strEmailTo & strDistroList & "; "
If xStp = 3 Then strEmailCC = strEmailCC & strDistroList & "; "
If xStp = 4 Then strEmailBCC = strEmailBCC & strDistroList & "; "
ActiveCell.Offset(1, 0).Select
Loop
xStp = xStp + 1
Loop
Range("A1").Select
'********************** Copy Area as Word to Paste ***********************
Const Sp_Ch As String = " "
Const wdPasteBitmap As Long = 9
Const wdPasteDeviceIndependentBitmap As Long = 5
Const wdPasteEnhancedMetafile As Long = 9
Const wdPasteHTML As Long = 10
Const wdPasteHyperlink As Long = 7
Const wdPasteMetafilePicture As Long = 3
Const wdPasteOLEObject As Long = 0
Const wdPasteRTF As Long = 1
Const wdPasteShape As Long = 8
Const wdPasteText As Long = 2
Const wd_PasteGIF As Long = 13
Const wd_PastePNG As Long = 14
Const wd_PasteJPG As Long = 15
Const olFolderInBox As Long = 6
Const olMailItem As Long = 0
Const wdInLine As Long = 0
Dim excSht As Excel.Worksheet
Dim excTbl As Excel.Range
Dim excChrt As Excel.ChartObject
Dim olkApp As Object
Dim olkMsg As Object
Dim olkDoc As Object
Dim olkEndOfDoc As Object
Dim WasOutlookOpenedByCode As Boolean
Set excSht = ThisWorkbook.Worksheets("Body")
Set excTbl = excSht.Range("B2:M36")
On Error Resume Next
Set olkApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If olkApp Is Nothing Then
Set olkApp = CreateObject("Outlook.Application")
olkApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInBox).Display
WasOutlookOpenedByCode = True
End If
'***************************** Draft Email ******************************
Set olkMsg = olkApp.CreateItem(olMailItem)
With olkMsg
.Subject = Left(xFile, 33)
.SentOnBehalfOfName = strEmailSentOnBehalfOfName
.To = strEmailTo
.CC = strEmailCC
.BCC = strEmailBCC
.Body = ""
.Attachments.Add xPath
.Display '***** Instead of Display can set to Auto Send *****
Set olkDoc = .GetInspector.WordEditor
End With
GetEndOfDoc(olkDoc).InsertParagraph
excTbl.Copy
GetEndOfDoc(olkDoc).PasteSpecial Placement:=wdInLine, DataType:=wdPasteBitmap
For Each excChrt In excSht.ChartObjects
With excChrt
Select Case Right(.Name, Len(.Name) - InStr(1, .Name, Sp_Ch, vbBinaryCompare))
Case 1, 2, 12 - 20
GetEndOfDoc(olkDoc).InsertParagraph
GetEndOfDoc(olkDoc).InsertParagraph
.CopyPicture xlScreen, xlBitmap
GetEndOfDoc(olkDoc).PasteSpecial Placement:=wdInLine, DataType:=wdPasteBitmap
Case Else
End Select
End With
Next excChrt
If WasOutlookOpenedByCode Then
End If
Set olkDoc = Nothing
Set olkMsg = Nothing
Set olkApp = Nothing
Set excTbl = Nothing
Set excSht = Nothing
End Sub
Private Function GetEndOfDoc(Wrd_Doc As Object) As Object
With Wrd_Doc
Set GetEndOfDoc = .Range(.Range.End - 1, .Range.End)
Sheets("Draft").Select
Cells(1, 1).Select
End With
End Function