Re: Image cannot be displayed in email body using vba
Any update on the request, please.
Re: Image cannot be displayed in email body using vba
Any update on the request, please.
Re: Image cannot be displayed in email body using vba
Hmm, good one but unable to run this code
Re: Image cannot be displayed in email body using vba
Sorry to reply late, Thank you so much, its working now.
one more help - as per my above code:
.HTMLBody = .HTMLBody & Cells(i, 4).Value & "," & _
"<br><br>" & Cells(i, 5).Value & _
"<br><br>" & Cells(i, 6).Value & _
"<br><br>" & Cells(i, 7).Value & _
"<br><br>" & Cells(i, 8).Value & _
"<br><br>" & Cells(i, 9).Value & _
"<br><br>" & "Regards<br>" & _
if cells(i, 9).value is blank, it should jump to next line regards.
am trying like this but its not working -
"If cells(i, 9).value = "" then
go to next
End if"
Pls help
Re: Image cannot be displayed in email body using vba
Any thoughts on this would be great help
Hi,
Am using vba macro for sending mass emails, where in everything looks good, but image is not loading properly and it should be placed at the end.
Any thoughts on this would be helpful.
Here is my code:
Sub EmbeddedHTMLGraphicDemo()
On Error Resume Next
' Outlook objects
Dim objApp As Outlook.Application
Dim l_Msg As MailItem
Dim colAttach As Outlook.Attachments
Dim l_Attach As Outlook.Attachment
Dim oSession As MAPI.Session
' CDO objects
Dim oMsg As MAPI.Message
Dim oAttachs As MAPI.Attachments
Dim oAttach As MAPI.Attachment
Dim colFields As MAPI.Fields
Dim oField As MAPI.Field
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim MyRange As Range
Dim i As Long
For i = 2 To Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
Dim strEntryID As String
' create new Outlook MailItem
Set objApp = CreateObject("Outlook.Application")
Set l_Msg = objApp.CreateItem(olMailItem)
' add graphic as attachment to Outlook message
' change path to graphic as needed
Set colAttach = l_Msg.Attachments
Set l_Attach = colAttach.Add("C:\Users\U700029\Desktop\mypic.jpg")
Set l_Msg = Nothing
' *** POSITION CRITICAL *** you must dereference the
' attachment objects before changing their properties
' via CDO
Set colAttach = Nothing
Set l_Attach = Nothing
' initialize CDO session
On Error Resume Next
Set oSession = CreateObject("MAPI.Session")
oSession.Logon "", "", False, False
' get the message created earlier
Set oMsg = oSession.GetMessage(strEntryID)
' set properties of the attached graphic that make
' it embedded and give it an ID for use in an <IMG> tag
Set oAttachs = oMsg.Attachments
Set oAttach = oAttachs.Item(1)
Set colFields = oAttach.Fields
Set oField = colFields.Add(CdoPR_ATTACH_MIME_TAG, "image/jpeg")
Set oField = colFields.Add(&H3712001E, "myident")
oMsg.Fields.Add "{0820060000000000C000000000000046}0x8514", 11, True
oMsg.Update
' get the Outlook MailItem again
Set l_Msg = objApp.GetNamespace("MAPI").GetItemFromID(strEntryID)
' add HTML content -- the <IMG> tag
l_Msg.HTMLBody = "<IMG align=baseline border=0 hspace=0 src=cid:myident>"
l_Msg.Display
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set Rng = Nothing
With OutMail
.SentOnBehalfOfName = "[email protected]"
.To = Cells(i, 1).Value
.CC = Cells(i, 2).Value
.Subject = Cells(i, 3).Value
.Attachments.Add Cells(i, 10).Value
.Attachments.Add Cells(i, 11).Value
.HTMLBody = .HTMLBody & Cells(i, 4).Value & "," & _
"<br><br>" & Cells(i, 5).Value & _
"<br><br>" & Cells(i, 6).Value & _
"<br><br>" & Cells(i, 7).Value & _
"<br><br>" & Cells(i, 8).Value & _
"<br><br>" & Cells(i, 9).Value & _
"<br><br>" & "Regards<br>" & _
"**************************************<br>" & _
"<b><A HREF=""[email protected]"">ghi</A></b>" & _
"<br><i>" & "Business" & "</br></i>" & _
"<br><b><A HREF=""https://google.com/support/portal"">Google Portal</A></b></br>" & " - " & "Login to review." & _
"<img src='cid:Mypic.jpg'" & "width='500' height='200'><br>"
.Display
With OutMail
.HTMLBody = .HTMLBody & l_Attach
End With
End With
Next
Set OutMail = Nothing
Set OutApp = Nothing
' clean up objects
Set oField = Nothing
Set colFields = Nothing
Set oMsg = Nothing
oSession.Logoff
Set oSession = Nothing
Set objApp = Nothing
Set l_Msg = Nothing
End Sub
Re: Concatenate multiple cells into one cell with separators using username
Thank you so much, its really helpful, just one more request, i have one more column in the beginning as "name", i should add this one.
now report is showing only userid and roles, it should show name, userid and roles.
can u help on this.
Hi All,
I have a request, where we have username in one col and roles in one col, for one user it may have multiple roles.
For Eg -
Username Roles
1234 abcd
1234 abcde
1234 abc
12345 abcdef
12345 abc
123456 abc
123456 abcd
123456 abcde
123456 abcdef
So my request is to get data of 1234 in one cell like - abcd; abcde; abc
Thank you
Re: Save email attachments and rename to my folder on desktop
Thank you so much Pike, its saving on the given path now.
Error for others is the pop up - "The macros in this project are disabled. Please refer to the online help or documentation of the host application to determine how to enable macros.
Re: Save email attachments and rename to my folder on desktop
Hi Pike,
I have done as you said, please revert for further corrections.
Thanks
Re: Save email attachments and rename to my folder on desktop
I got the code, its working now, the only thing is worrying me is, its not saving the files in given path, its saving in my documents.
And also its not working on other systems. Can u help:
Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strFileName As String
Dim objSubject As String
Dim strDeletedFiles As String
Dim dateFormat As String
' Get the path to your My Documents folder
'strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
On Error Resume Next
' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection
' The attachment folder needs to exist
' You can change this to another folder name of your choice
' Set the Attachment folder.
strFolderpath = "C:\Users\U700029\Desktop\Medstat"
dateFormat = Format(Now - 1, " yyyy-mm-dd")
' Check each selected item for attachments.
For Each objMsg In objSelection
'Set FileName to Subject
objSubject = objMsg.Subject
objSubject = Left(objMsg.Subject, Len(objMsg.Subject) - 12)
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
' Use a count down loop for removing items
' from a collection. Otherwise, the loop counter gets
' confused and only every other item is removed.
For i = lngCount To 1 Step -1
' Get the file name.
strFileName = objSubject
' Combine with the path to the Temp folder.
strFile = objSubject & dateFormat & ".xlsx"
Debug.Print strFile
' Save the attachment as a file.
objAttachments.item(i).SaveAsFile strFile
Next i
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
Display More
Re: Save email attachments and rename to my folder on desktop
Am pretty new to vba macros, may i know here wat do you mean by code tags.
Re: Save email attachments and rename to my folder on desktop
I got the code, its working now, the only thing is worrying me is, its not saving the files in given path, its saving in my documents.
And also its not working on other systems. Can u help:
Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strFileName As String
Dim objSubject As String
Dim strDeletedFiles As String
Dim dateFormat As String
' Get the path to your My Documents folder
'strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
On Error Resume Next
' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection
' The attachment folder needs to exist
' You can change this to another folder name of your choice
' Set the Attachment folder.
strFolderpath = "C:\Users\U700029\Desktop\Medstat"
dateFormat = Format(Now - 1, " yyyy-mm-dd")
' Check each selected item for attachments.
For Each objMsg In objSelection
'Set FileName to Subject
objSubject = objMsg.Subject
objSubject = Left(objMsg.Subject, Len(objMsg.Subject) - 12)
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
' Use a count down loop for removing items
' from a collection. Otherwise, the loop counter gets
' confused and only every other item is removed.
For i = lngCount To 1 Step -1
' Get the file name.
strFileName = objSubject
' Combine with the path to the Temp folder.
strFile = objSubject & dateFormat & ".xlsx"
Debug.Print strFile
' Save the attachment as a file.
objAttachments.item(i).SaveAsFile strFile
Next i
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
This is what i have created, but i require the file to be saved with Subject and Yesterday date:
Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strFileName As String
Dim objSubject As String
Dim strDeletedFiles As String
Dim dateFormat As String
Dim MsgSubject As String
' Get the path to your My Documents folder
'strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
On Error Resume Next
' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection
' The attachment folder needs to exist
' You can change this to another folder name of your choice
' Set the Attachment folder.
strFolderpath = "C:\Users\U700029\Desktop\Medstat"
dateFormat = Format(Now - 1, " yyyy-mm-dd")
' Check each selected item for attachments.
For Each objMsg In objSelection
'Set FileName to Subject
objSubject = objMsg.Subject
MsgSubject = objMsg.Subject
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
' Use a count down loop for removing items
' from a collection. Otherwise, the loop counter gets
' confused and only every other item is removed.
For i = lngCount To 1 Step -1
' Get the file name.
strFileName = objSubject
' Combine with the path to the Temp folder.
strFile = MsgSubject & dateFormat & ".xlsx"
Debug.Print strFile
' Save the attachment as a file.
objAttachments.item(i).SaveAsFile strFile
Next i
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
Any idea would be great.
Re: Save email attachments and rename to my folder on desktop
Can anyone reply pls.
Re: Save email attachments and rename to my folder on desktop
This code is not working, can u help:
Public Sub saveAttachtoDisk()
Dim itm As Outlook.MailItem
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim fso As Object
Dim oldName
Dim file As String
Dim DateFormat As String
Dim newName As String
Dim enviro As String
enviro = CStr(Environ("USERPROFILE"))
saveFolder = enviro & "C:\Users\U700029\Desktop\Docs\Gumma Reports\Daily\Medstat"
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
For Each itm In Selection
For Each objAtt In itm.Attachments
file = saveFolder & objAtt.DisplayName
objAtt.SaveAsFile file
'Get the file name
Set oldName = fso.GetFile(file)
DateFormat = Format(Date - 1, "yyyy-mm-dd")
newName = DateFormat & objAtt.DisplayName
oldName.Name = newName
Set objAtt = Nothing
Next
Next
Set fso = Nothing
End Sub
Display More
Re: Save email attachments and rename to my folder on desktop
Thank you Pike for your response,
However this code does not save with subject and yesterdays date, can u have a look:
public Sub saveAttachtoDisk()
Dim itm As Outlook.MailItem
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim fso As Object
Dim oldName
Dim file As String
Dim DateFormat As String
Dim newName As String
Dim enviro As String
enviro = CStr(Environ("USERPROFILE"))
saveFolder = enviro & "\Documents\Attachments"
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
For Each itm In Selection
For Each objAtt In itm.Attachments
file = saveFolder & objAtt.DisplayName
objAtt.SaveAsFile file
'Get the file name
Set oldName = fso.GetFile(file)
DateFormat = Format(oldName.DateLastModified, "yyyy-mm-dd ")
newName = DateFormat & objAtt.DisplayName
oldName.Name = newName
Set objAtt = Nothing
Next
Next
Set fso = Nothing
End Sub
Display More