bdouglas1011
New Member
I have a macro that converts an excel over to HTML then it adds it to body of email within Outlook.
The problem on Iphone once you add your attachments IOS automatically downloads as plain text. You then have to scroll to end of message and download the rest and then wait for everything to reset so It views on the phone properly. I have tried several different scenarios and I wonder if this can be done with in the Macro.
If I copy everything and when I Paste the Information and Choose the Paste (Picture(U)) it will come through properly and still have some more to download but the actual body comes through just as it should on the Iphone.
I have Included my Code I use and hope there is a way to past it this way into the body of Outlook.
The problem on Iphone once you add your attachments IOS automatically downloads as plain text. You then have to scroll to end of message and download the rest and then wait for everything to reset so It views on the phone properly. I have tried several different scenarios and I wonder if this can be done with in the Macro.
If I copy everything and when I Paste the Information and Choose the Paste (Picture(U)) it will come through properly and still have some more to download but the actual body comes through just as it should on the Iphone.
I have Included my Code I use and hope there is a way to past it this way into the body of Outlook.
Code:
'-----------------------------------------------------
'Looks to see if Outlook is open and If not open it
'--------------------------------------------------------
#Const LateBind = True
Const olMinimized As Long = 1
Const olMaximized As Long = 2
Const olFolderInbox As Long = 6
#If LateBind Then
Public Function OutlookApp( _
Optional WindowState As Long = olMinimized, _
Optional ReleaseIt As Boolean = False _
) As Object
Static o As Object
#Else
Public Function OutlookApp( _
Optional WindowState As Outlook.OlWindowState = olMinimized, _
Optional ReleaseIt As Boolean _
) As Outlook.Application
Static o As Outlook.Application
#End If
On Error GoTo ErrHandler
Select Case True
Case o Is Nothing, Len(o.Name) = 0
Set o = GetObject(, "Outlook.Application")
If o.Explorers.Count = 0 Then
InitOutlook:
o.Session.GetDefaultFolder(olFolderInbox).Display
o.ActiveExplorer.WindowState = WindowState
End If
Case ReleaseIt
Set o = Nothing
End Select
Set OutlookApp = o
ExitProc:
Exit Function
ErrHandler:
Select Case Err.Number
Case -2147352567
Set o = Nothing
Case 429, 462
Set o = GetOutlookApp()
If o Is Nothing Then
Err.Raise 429, "OutlookApp", "Outlook Application does not appear to be installed."
Else
Resume InitOutlook
End If
Case Else
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Unexpected error"
End Select
Resume ExitProc
Resume
End Function
#If LateBind Then
Private Function GetOutlookApp() As Object
#Else
Private Function GetOutlookApp() As Outlook.Application
#End If
On Error GoTo ErrHandler
Set GetOutlookApp = CreateObject("Outlook.Application")
ExitProc:
Exit Function
ErrHandler:
Select Case Err.Number
Case Else
Set GetOutlookApp = Nothing
End Select
Resume ExitProc
Resume
End Function
Sub MyMacroThatUseOutlook()
Dim OutApp As Object
Set OutApp = OutlookApp()
'-------------------------------------------------------------
'Create pic of logo on worksheet - Logo is placed within Chart
'--------------------------------------------------------------
Call createJpg("Morning Report", "A1:c3", "MorningReport")
End Sub
Sub createJpg(MorningReport As String, nameRange As String, nameFile As String)
'-----------------------------------------------------
'UNPROTECTS SHEET FOR MACRO
'-----------------------------------------------------
ActiveSheet.Unprotect Password:="Financial3"
ThisWorkbook.Activate
Worksheets("Morning Report").Activate
Dim plage As Range
Set plage = ThisWorkbook.Worksheets("Morning Report").Range("A1:c3")
plage.CopyPicture
With ThisWorkbook.Worksheets("Morning Report").ChartObjects.Add(plage.Left, plage.Top, plage.Width, plage.Height)
.Activate
.Chart.Paste
.Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
End With
Worksheets("Morning Report").ChartObjects(Worksheets("Morning Report").ChartObjects.Count).Delete
Set plage = Nothing
Call CovercopypasteOutlook
End Sub
Sub CovercopypasteOutlook()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim Signature As String
Dim RetVal As Long
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set rng = Nothing
Set rng = ActiveSheet.Range("a1:k46")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
'****************************************************************
'Message to confirm ready to email
'****************************************************************
RetVal = MsgBox("ARE YOU SURE EVERYTHING IS CORRECT AND COMPLETED?", vbYesNoCancel, "Confirm")
Select Case RetVal
Case vbYes
Case vbNo
Exit Sub
Case vbCancel
Exit Sub
End Select
'**********************************************
.Display
End With
Signature = OutMail.HTMLBody
With OutMail
.To = "[EMAIL="RSSDataReports@gyrodata.com"]RSSDataReports@gyrodata.com[/EMAIL]"
.CC = ""
.BCC = ""
.Subject = Range("c5") & " - " & Range("c6") & " - " & Range("c7") & " - " & Range("c8") & " County, " & Range("c9") & " - " & Range("c10") & " - " & " Morning Report "
Dim TempFilePath As String
TempFilePath = Environ$("temp") & "\"
.Attachments.Add TempFilePath & "MorningReport.jpg"
.HTMLBody = "<img src='cid:MorningReport.jpg'" & "width='200' height='75'><br>" & RangetoHTML(rng) & vbNewLine & Signature
.Attachments.Add ActiveWorkbook.FullName
ThisWorkbook.Save
.Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
TempWB.Close savechanges:=False
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
'--------------------------------------------------
'Save morning report document in job folder As PDF
'--------------------------------------------------
Dim MyPath As String
MyPath = ActiveWorkbook.Path & "\Morning Reports\"
ChDir MyPath
Sheets("Morning Report").Range("A1:k46").ExportAsFixedFormat Type:=xlTypePDF, Filename:=MyPath & "[URL="file://\\Morning"]\\Morning[/URL] Report" & "_" & Format(Now(), "mm.dd.yy") & ".PDF", Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
'----------------------------------------------------
'Protect Sheet when done
'---------------------------------------------------
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:="Financial3"
End Function