steamroller123
New Member
- Joined
- Jul 23, 2015
- Messages
- 3
Dear colleagues 
,
What I am trying to do is to combine 2 vba codes.
I have a vba that automatically prepares personal emails with attachments (newsletter). The thing is that I really need it with default outlook signature. So , another vba that I have is vba that opens new outlook message with signature.
You can see the files here.
This is the main file that I would like with outlook signature.
Sub Send_Files()
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
Dim strbody As String
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
Set rng = sh.Cells(cell.Row, 1).Range("F1:Z1")
If cell.Value Like "?*@?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Newsletter"
.Body = "Dear " & cell.Offset(0, -1).Value & vbNewLine & " " & vbNewLine & " " & vbNewLine & " " & cell.Offset(0, 1).Value & " " & cell.Offset(0, 2).Value
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.display 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
--------------------------------------------
For example I have this VBA that creates msg with new signature:
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Sub send()
Dim ret As Long
On Error GoTo aa
ret = ShellExecute(Application.hwnd, vbNullString, "Outlook", vbNullString, "C:\", SW_SHOWNORMAL)
If ret < 3 Then
MsgBox "Outlook is not found.", vbCritical, "SN's Customised Solutions"
End If
aa:
Dim oOutlook As Object
On Error Resume Next
Set oOutlook = GetObject(, "Outlook.Application")
On Error GoTo 0
If oOutlook Is Nothing Then
Else
'Call NameOfYourMailMacro
End If
ActiveWorkbook.save
Dim OutApp As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = " " & _
"" & _
""
On Error Resume Next
'
With OutMail
.Display
.To = "test@test.com"
.CC = ""
.BCC = ""
.Subject = ""
.HTMLBody = strbody & "<br>" & .HTMLBody
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
,What I am trying to do is to combine 2 vba codes.
I have a vba that automatically prepares personal emails with attachments (newsletter). The thing is that I really need it with default outlook signature. So , another vba that I have is vba that opens new outlook message with signature.
You can see the files here.
This is the main file that I would like with outlook signature.
Sub Send_Files()
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
Dim strbody As String
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
Set rng = sh.Cells(cell.Row, 1).Range("F1:Z1")
If cell.Value Like "?*@?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Newsletter"
.Body = "Dear " & cell.Offset(0, -1).Value & vbNewLine & " " & vbNewLine & " " & vbNewLine & " " & cell.Offset(0, 1).Value & " " & cell.Offset(0, 2).Value
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.display 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
--------------------------------------------
For example I have this VBA that creates msg with new signature:
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Sub send()
Dim ret As Long
On Error GoTo aa
ret = ShellExecute(Application.hwnd, vbNullString, "Outlook", vbNullString, "C:\", SW_SHOWNORMAL)
If ret < 3 Then
MsgBox "Outlook is not found.", vbCritical, "SN's Customised Solutions"
End If
aa:
Dim oOutlook As Object
On Error Resume Next
Set oOutlook = GetObject(, "Outlook.Application")
On Error GoTo 0
If oOutlook Is Nothing Then
Else
'Call NameOfYourMailMacro
End If
ActiveWorkbook.save
Dim OutApp As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = " " & _
"" & _
""
On Error Resume Next
'
With OutMail
.Display
.To = "test@test.com"
.CC = ""
.BCC = ""
.Subject = ""
.HTMLBody = strbody & "<br>" & .HTMLBody
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Last edited:
