Всем добрый день!
Использую данный код при создании писем в Outlook через VBA с форматированием для таблиц.
Код:
Option Explicit
Sub Send_Mail()
Dim oOutlApp As Object, objMail As Object
Dim sTo As String, sCC As String, sSubject As String, sBody As String, sTblBody As String, sAttachment As String
Dim rDataR As Range
Dim IsOultOpen As Boolean
Application.ScreenUpdating = False
On Error Resume Next
Set oOutlApp = GetObject(, "Outlook.Application")
If Err = 0 Then
IsOultOpen = True
Else
Err.Clear
Set oOutlApp = CreateObject("Outlook.Application")
End If
oOutlApp.Session.Logon
Set objMail = oOutlApp.CreateItem(0)
If Err.Number <> 0 Then Set oOutlApp = Nothing: Set objMail = Nothing: Exit Sub
With ActiveWorkbook.Sheets("Ëèñò2")
sTo = .Range("P30").value
sCC = .Range("P31").value
sSubject = .Range("P33").value
sBody = .Range("P32").value
sAttachment = .Range("P35").value
sBody = Replace(sBody, Chr(10), "<br />")
sBody = Replace(sBody, vbNewLine, "<br />")
sBody = "<span style=""font-size: 14px; font-family: Arial"">" & sBody & "</span>"
Set rDataR = .Range("B1:K28")
sTblBody = ConvertRngToHTM(rDataR)
sBody = Replace(sBody, "{TABLE}", sTblBody)
End With
With objMail
.To = sTo
.CC = sCC
.Subject = sSubject
.BodyFormat = 2
.HTMLBody = sBody
If sAttachment <> "" Then
.Attachments.Add sAttachment
End If
.display
End With
If IsOultOpen = False Then oOutlApp.Quit
Set oOutlApp = Nothing: Set objMail = Nothing
DoEvents
End Sub
Function ConvertRngToHTM(rng As Range)
Dim fso As Object, ts As Object
Dim sF As String, resHTM As String
Dim wbTmp As Workbook
sF = Environ("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
rng.Copy
Set wbTmp = Workbooks.Add(1)
With wbTmp.Sheets(1)
.Cells(1).PasteSpecial xlPasteColumnWidths
.Cells(1).PasteSpecial xlPasteValues
.Cells(1).PasteSpecial xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
'------------------------------------------
End With
With wbTmp.PublishObjects.Add( _
SourceType:=xlSourceRange, Filename:=sF, _
Sheet:=wbTmp.Sheets(1).Name, Source:=wbTmp.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sF).OpenAsTextStream(1, -2)
resHTM = ts.ReadAll
ts.Close
ConvertRngToHTM = Replace(resHTM, "align=center x:publishsource=", "align=left x:publishsource=")
wbTmp.Close False
Kill sF
Set ts = Nothing: Set fso = Nothing
Set wbTmp = Nothing
End Function
Function RangeToTextTable(rng As Range)
Dim lr As Long, lc As Long, arr
Dim res As String, rh()
Dim lSpaces As Long, s As String
arr = rng.value
If Not IsArray(arr) Then
ReDim arr(1 To 1, 1 To 1)
arr(1, 1) = rng.value
End If
ReDim rh(1 To UBound(arr, 2))
For lr = 1 To UBound(arr, 1)
For lc = 1 To UBound(arr, 2)
If Len(arr(lr, lc)) > rh(lc) Then
rh(lc) = Len(arr(lr, lc))
End If
Next
Next
For lr = 1 To UBound(arr, 1)
For lc = 1 To UBound(arr, 2)
s = arr(lr, lc)
lSpaces = rh(lc) - Len(s)
If lSpaces > 0 Then
s = s & Space(lSpaces)
End If
If lc = 1 Then
res = res & s
Else
res = res & vbTab & s
End If
Next
res = res & vbNewLine
Next
RangeToTextTable = res
End Function
Подскажите как в VBA добавить стандартную подпись при создании сообщения.
В приложенном примере, подпись добавляется с ячейки B13, мне нужно чтобы стандартная подпись добавлялась автоматически с Outlook.
Нашел следующий код для создания сообщения с подписью, но самому не получается добавить в первый код.
Код:
Sub Mail_Outlook_With_Signature_Html_2()
' Don't forget to copy the function GetBoiler in the module.
' Working in Office 2000-2016
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim SigString As String
Dim Signature As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "<H3><B>Dear Customer Ron de Bruin</B></H3>" & _
"Please visit this website to download the new version.<br>" & _
"Let me know if you have problems.<br>" & _
"<A HREF=""http://www.rondebruin.nl/tips.htm"">Ron's Excel Page</A>" & _
"<br><br><B>Thank you</B>"
'Change only Mysig.htm to the name of your signature
SigString = Environ("appdata") & _
"\Microsoft\Signatures\Mysig.htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
On Error Resume Next
With OutMail
.To = "ron@debruin.nl"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.HTMLBody = strbody & "<br>" & Signature
.Send 'or use .Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
Заранее спасибо!