Solved

Edit current vba or rewrite to send out going mail as jpg not hTMl

Posted on 2013-01-16
13
438 Views
Last Modified: 2013-01-18
Hi Experts

I have the following vba code (see below) - which currently works fine and emails all selected users a HTML image of a selected range of data...

The current vba also change the auto signature of who every use the code to the current users out going mail signature...

What I am trying to do or would like the experts assistance on is:

Either re- write current code or edit so when the macro run it send the image on the out going mail as I jpg

Retaining current strbody txt and out going mail

.To
.CC
.Subject

Functionality and also telling the user if they do not have a auto signature currently setup then set one up....


Sub Mail_Daily()
 
    Dim rng As Range
    Dim Outapp As Object
    Dim OutMail As Object
    Dim StrBody As String
    Dim StrBodySig As String
    Dim strpath As String
    Dim Test As String
    Dim sPath As String
    Dim Folder As Object
    Dim oFSO As Object
    Dim strExtension As String
    Dim SignaturePath As String
    Dim SignaturePathFound As String
   
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
 
    Set rng = Nothing
    On Error Resume Next
   
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
   
    Set rng = Sheets("Blackberry").Range("B4:H30").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
 
    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If
 
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
 
    Set Outapp = CreateObject("Outlook.Application")
    Set OutMail = Outapp.CreateItem(0)
       
        StrBody = "<p style='font-family:calibri;font-size:12'>" & "Dear All" & "<br><br>" & _
                  "Please find attached the Daily R&WO Performance Dashboard for - " & Format(Now, "dd mmmm yyyy") & "." & "<br>" & _
                  "Please find below an image developed for users viewing this email on a Blackberry device who are unable to open pdf attachments this image" & "<br>" & _
                  "shows the key metrics for each of the functional teams, highlighting Current Rolling Week and MTD figures and associated RAG statuses." & "<br>" & _
                  "<br>If you have any difficulties viewing the table above via a Blackberry device, please contact sender:- Details Below." & "<p style>"
               
        strpath = "C:\Documents and Settings\" & Environ("username") & "\Application Data\Microsoft\Signatures\"
 
        ' these go on every line and give the main information about the file
 
        ChDir strpath
 
            strExtension = Dir("*.htm")
            SignaturePathFound = "No"
                Do While strExtension <> ""
                SignaturePath = strpath & strExtension
            SignaturePathFound = "Yes"
        GoTo BreakLoop
        Loop
BreakLoop:
            If SignaturePathFound = "Yes" Then
                'MsgBox (SignaturePath)
               
            Else
        MsgBox ("You dont have an outlook signature set up - please update")
            End If
    strExtension = Dir
   
    On Error Resume Next
    With OutMail
        .To = ""
        .CC = ""
        .Subject = "Executive Summary Report - " & Format(Now, "dd mmmm yyyy") & ""
       
        If SignaturePathFound = "Yes" Then
            .HTMLBody = StrBody & RangetoHTML(rng) & GetBoiler(SignaturePath)
        Else
            .HTMLBody = StrBody & RangetoHTML(rng)
        End If
       
        .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"
 
    'Copy the range and create a new workbook to past the data in
    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
               .Rows(1).RowHeight = 42
               .Rows(5).RowHeight = 5
            .Rows(8).RowHeight = 5
        .Rows(10).RowHeight = 5
      .Rows(13).RowHeight = 5
    .Rows(16).RowHeight = 5
  .Rows(19).RowHeight = 5
      .Rows(22).RowHeight = 5
        .Rows(24).RowHeight = 5
            .Rows(26).RowHeight = 5
                                .Columns(1).ColumnWidth = 7.56
                 .Columns(2).ColumnWidth = 27.44
            .Columns(3).ColumnWidth = 9
        .Columns(4).ColumnWidth = 9
      .Columns(5).ColumnWidth = 0.5
    .Columns(6).ColumnWidth = 9
        .Columns(7).ColumnWidth = 9
         
         Range("A1:G28").Select
         With Selection.Font
        .Name = "Calibri"
        .Size = 8
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .TintAndShade = 0
    End With
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
 
    'Publish the sheet to a htm file
    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
 
    'Read all data from the htm file into RangetoHTML
    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=")
 
    'Close TempWB
    TempWB.Close savechanges:=False
 
    'Delete the htm file we used in this function
    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
 
End Function
 
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
0
Comment
Question by:route217
  • 9
  • 4
13 Comments
 
LVL 85

Expert Comment

by:Rory Archibald
ID: 38782857
Completely untested but try this:
Option Explicit
Dim container                 As Chart
Dim containerbook             As Workbook
Dim Sourcebook                As Workbook


Sub Mail_Daily()

   Dim rng                    As Range
   Dim Outapp                 As Object
   Dim OutMail                As Object
   Dim StrBody                As String
   Dim StrBodySig             As String
   Dim strpath                As String
   Dim Test                   As String
   Dim sPath                  As String
   Dim Folder                 As Object
   Dim oFSO                   As Object
   Dim strExtension           As String
   Dim SignaturePath          As String
   Dim SignaturePathFound     As String

   Application.DisplayAlerts = False
   Application.ScreenUpdating = False

   Set rng = Nothing
   On Error Resume Next

   Set rng = Selection.SpecialCells(xlCellTypeVisible)

   Set rng = Sheets("Blackberry").Range("B4:H30").SpecialCells(xlCellTypeVisible)
   On Error GoTo 0

   If rng Is Nothing Then
      MsgBox "The selection is not a range or the sheet is protected" & _
             vbNewLine & "please correct and try again.", vbOKOnly
      Exit Sub
   End If

   With Application
      .EnableEvents = False
      .ScreenUpdating = False
   End With

   Set Outapp = CreateObject("Outlook.Application")
   Set OutMail = Outapp.CreateItem(0)

   StrBody = "<p style='font-family:calibri;font-size:12'>" & "Dear All" & "<br><br>" & _
             "Please find attached the Daily R&WO Performance Dashboard for - " & Format(Now, "dd mmmm yyyy") & "." & "<br>" & _
             "Please find below an image developed for users viewing this email on a Blackberry device who are unable to open pdf attachments this image" & "<br>" & _
             "shows the key metrics for each of the functional teams, highlighting Current Rolling Week and MTD figures and associated RAG statuses." & "<br>" & _
             "<br>If you have any difficulties viewing the table above via a Blackberry device, please contact sender:- Details Below." & "<p style>"

   strpath = "C:\Documents and Settings\" & Environ("username") & "\Application Data\Microsoft\Signatures\"

   ' these go on every line and give the main information about the file

   ChDir strpath

   strExtension = Dir("*.htm")
   SignaturePathFound = "No"
   Do While strExtension <> ""
      SignaturePath = strpath & strExtension
      SignaturePathFound = "Yes"
      GoTo BreakLoop
   Loop
BreakLoop:
   If SignaturePathFound = "Yes" Then
      'MsgBox (SignaturePath)

   Else
      MsgBox ("You dont have an outlook signature set up - please update")
   End If
   strExtension = Dir

   On Error Resume Next
   With OutMail
      .To = ""
      .CC = ""
      .Subject = "Executive Summary Report - " & Format(Now, "dd mmmm yyyy") & ""

      If SignaturePathFound = "Yes" Then
         .HTMLBody = StrBody & GetBoiler(SignaturePath)
      Else
         .HTMLBody = StrBody
      End If
      .Attachments.Add RangeToJPEG(rng)
      .Display
   End With
   On Error GoTo 0

   With Application
      .EnableEvents = True
      .ScreenUpdating = True
   End With

   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
Function RangeToJPEG(rng As Range) As String
   Dim varReturn              As Variant
   Dim MyAddress              As String
   Dim SaveName               As Variant
   Dim MySuggest              As String
   Dim Hi                     As Integer
   Dim Wi                     As Integer

   Set Sourcebook = rng.Parent.Parent
   Set containerbook = Workbooks.Add(1)
   containerbook.Sheets(1).Name = "JPGcontainer"
   MySuggest = sShortname(rng.Worksheet.Name)
   Set container = CreateContainer(containerbook)
   MyAddress = rng.address
   If MyAddress <> "A1" Then
      SaveName = CreateObject("WScript.Shell").specialfolders("MyDocuments") & "\temp.jpg"
      If Dir(SaveName) <> "" Then Kill SaveName
      With rng
         .CopyPicture Appearance:=xlScreen, Format:=xlBitmap
         Hi = .Height + 4  'adjustment for gridlines
         Wi = .Width + 6   'adjustment for gridlines
      End With
      MakeAndSizeChart container, ih:=Hi, iv:=Wi
      With container
         .Paste
         .Export fileName:=SaveName, FilterName:="jpg"
         .Pictures(1).Delete
      End With
      Sourcebook.Activate
   End If
   RangeToJPEG = SaveName
   On Error Resume Next
   Application.StatusBar = False
   containerbook.Close False
End Function
Function sShortname(ByVal Original As String) As String
   Dim i                      As Integer
   sShortname = ""
   i = InStr(Trim$(Original), " ")
   If i = 0 Then
      sShortname = Original
   Else
      sShortname = left$(Original, i - 1)
   End If
End Function

Private Function CreateContainer(ByRef wbk As Workbook) As Chart
   Set container = wbk.Charts.Add
   With container
      .ChartType = xlColumnClustered
      .SetSourceData Source:=wbk.Worksheets(1).Range("A1")
      .Location Where:=xlLocationAsObject, Name:=wbk.Sheets(2).Name
   End With
   Set CreateContainer = ActiveChart
   CreateContainer.ChartArea.ClearContents
End Function

Sub MakeAndSizeChart(ByRef cht As Chart, ih As Integer, iv As Integer)
   Dim Hincrease              As Single
   Dim Vincrease              As Single
   Hincrease = ih / cht.ChartArea.Height
   cht.Parent.ShapeRange.ScaleHeight Hincrease, _
                                     msoFalse, msoScaleFromTopLeft
   Vincrease = iv / cht.ChartArea.Width
   cht.Parent.ShapeRange.ScaleWidth Vincrease, _
                                    msoFalse, msoScaleFromTopLeft
End Sub

Open in new window

0
 

Author Comment

by:route217
ID: 38782866
Let me test Rorya ans get back to u..
0
 

Author Comment

by:route217
ID: 38783082
Ok testing new code and its running and just hangs - no error message so far...
0
 
LVL 85

Accepted Solution

by:
Rory Archibald earned 500 total points
ID: 38783202
It shouldn't take that long. I noticed an error in your original code which I have now corrected (it now exits if there is no signature found - up to you if that's what you want)
Option Explicit

Dim container                 As Chart
Dim containerbook             As Workbook
Dim Sourcebook                As Workbook


Sub Mail_Daily()

   Dim rng                    As Range
   Dim Outapp                 As Object
   Dim OutMail                As Object
   Dim StrBody                As String
   Dim StrBodySig             As String
   Dim strpath                As String
   Dim Test                   As String
   Dim sPath                  As String
   Dim Folder                 As Object
   Dim oFSO                   As Object
   Dim strExtension           As String
   Dim SignaturePath          As String
   Dim SignaturePathFound     As String

   Application.DisplayAlerts = False
   Application.ScreenUpdating = False

   Set rng = Nothing
   On Error Resume Next

   Set rng = Selection.SpecialCells(xlCellTypeVisible)

   Set rng = Sheets("Blackberry").Range("B4:H30").SpecialCells(xlCellTypeVisible)
   On Error GoTo 0

   If rng Is Nothing Then
      MsgBox "The selection is not a range or the sheet is protected" & _
             vbNewLine & "please correct and try again.", vbOKOnly
      Exit Sub
   End If

   With Application
      .EnableEvents = False
      .ScreenUpdating = False
   End With

   Set Outapp = CreateObject("Outlook.Application")
   Set OutMail = Outapp.CreateItem(0)

   StrBody = "<p style='font-family:calibri;font-size:12'>" & "Dear All" & "<br><br>" & _
             "Please find attached the Daily R&WO Performance Dashboard for - " & Format(Now, "dd mmmm yyyy") & "." & "<br>" & _
             "Please find below an image developed for users viewing this email on a Blackberry device who are unable to open pdf attachments this image" & "<br>" & _
             "shows the key metrics for each of the functional teams, highlighting Current Rolling Week and MTD figures and associated RAG statuses." & "<br>" & _
             "<br>If you have any difficulties viewing the table above via a Blackberry device, please contact sender:- Details Below." & "<p style>"

   strpath = CreateObject("WScript.Shell").specialfolders("AppData") & "\Microsoft\Signatures\"

   ' these go on every line and give the main information about the file

   strExtension = Dir(strpath & "\*.htm")
   SignaturePathFound = "No"
   If strExtension = "" Then
      MsgBox ("You dont have an outlook signature set up - please update")
        Exit Sub
    Else
      SignaturePath = strpath & strExtension
    SignaturePathFound = "Yes"
   End If

   On Error Resume Next
   With OutMail
      .To = ""
      .CC = ""
      .Subject = "Executive Summary Report - " & Format(Now, "dd mmmm yyyy") & ""

      If SignaturePathFound = "Yes" Then
         .HTMLBody = StrBody & GetBoiler(SignaturePath)
      Else
         .HTMLBody = StrBody
      End If
      .Attachments.Add RangeToJPEG(rng)
      .Display
   End With
   On Error GoTo 0

   With Application
      .EnableEvents = True
      .ScreenUpdating = True
   End With

   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
Function RangeToJPEG(rng As Range) As String
   Dim varReturn              As Variant
   Dim MyAddress              As String
   Dim SaveName               As Variant
   Dim MySuggest              As String
   Dim Hi                     As Integer
   Dim Wi                     As Integer

   Set Sourcebook = rng.Parent.Parent
   Set containerbook = Workbooks.Add(1)
   containerbook.Sheets(1).Name = "JPGcontainer"
   MySuggest = sShortname(rng.Worksheet.Name)
   Set container = CreateContainer(containerbook)
   MyAddress = rng.Address
   If MyAddress <> "A1" Then
      SaveName = CreateObject("WScript.Shell").specialfolders("MyDocuments") & "\temp.jpg"
      If Dir(SaveName) <> "" Then Kill SaveName
      With rng
         .CopyPicture Appearance:=xlScreen, Format:=xlBitmap
         Hi = .Height + 4  'adjustment for gridlines
         Wi = .Width + 6   'adjustment for gridlines
      End With
      MakeAndSizeChart container, ih:=Hi, iv:=Wi
      With container
         .Paste
         .Export Filename:=SaveName, FilterName:="jpg"
         .Pictures(1).Delete
      End With
      Sourcebook.Activate
   End If
   RangeToJPEG = SaveName
   On Error Resume Next
   Application.StatusBar = False
   containerbook.Close False
End Function
Function sShortname(ByVal Original As String) As String
   Dim i                      As Integer
   sShortname = ""
   i = InStr(Trim$(Original), " ")
   If i = 0 Then
      sShortname = Original
   Else
      sShortname = Left$(Original, i - 1)
   End If
End Function

Private Function CreateContainer(ByRef wbk As Workbook) As Chart
   Set container = wbk.Charts.Add
   With container
      .ChartType = xlColumnClustered
      .SetSourceData Source:=wbk.Worksheets(1).Range("A1")
      .Location Where:=xlLocationAsObject, Name:=wbk.Sheets(2).Name
   End With
   Set CreateContainer = ActiveChart
   CreateContainer.ChartArea.ClearContents
End Function

Sub MakeAndSizeChart(ByRef cht As Chart, ih As Integer, iv As Integer)
   Dim Hincrease              As Single
   Dim Vincrease              As Single
   Hincrease = ih / cht.ChartArea.Height
   cht.Parent.ShapeRange.ScaleHeight Hincrease, _
                                     msoFalse, msoScaleFromTopLeft
   Vincrease = iv / cht.ChartArea.Width
   cht.Parent.ShapeRange.ScaleWidth Vincrease, _
                                    msoFalse, msoScaleFromTopLeft
End Sub

Open in new window

0
 

Author Comment

by:route217
ID: 38783330
Rorya

Can u kindly paste my error here please
0
 

Author Comment

by:route217
ID: 38786376
Hi Rorya

The macro is not opening up outlook allowing the user to see what is about to be mailed before sending....
0
IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

 
LVL 85

Expert Comment

by:Rory Archibald
ID: 38786457
It should either start Outlook or error on the CreateObject("Outlook.Application") line. Does it work if you start Outlook first?

Did this code work originally? I haven't altered any of the code to start Outlook or display the email.
0
 

Author Comment

by:route217
ID: 38786633
Worked originally when outlook was open...... Investigating...
0
 

Author Comment

by:route217
ID: 38786661
Ok getting compile error variable not defined on

Function RangeToJPEG(rng as Range) as string
0
 

Author Comment

by:route217
ID: 38786675
Ok fixed all errors... Outlook opens adds the HTML text but no image attachment..
0
 

Author Comment

by:route217
ID: 38786719
Ok error on my part...cannot copy code...

It works - with a slight problem... The jpg is an attachment not pasted into the body of email....

And also the current jpg attachment is blank image
0
 

Author Comment

by:route217
ID: 38787616
Hi Rorya

The jpg container worksheet is empty no data..
0
 
LVL 85

Expert Comment

by:Rory Archibald
ID: 38793581
Hi,
This must be a version difference - I have the same issue when testing in 2010 (and 2013). I'm afraid I don't have the time to look at it now and will be away until the beginning of February so unless it can wait until then, you'll need to post a new question I'm afraid.
0

Featured Post

IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

Introduction This Article briefly covers methods of calculating the NPV and IRR variants in Excel as well as the limitations in calculating and interpreting IRR results. Paraphrasing Richard Shockley, author of my favourite finance reference tex…
Introduction While answering a recent question (http:/Q_27311462.html), I created an alternative function to the Excel Concatenate() function that you might find useful.  I tested several solutions and share the results in this article as well as t…
Viewers will learn the basics of slicers and timelines for both PivotTables and standard Excel tables in Excel 2013.
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…

746 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

10 Experts available now in Live!

Get 1:1 Help Now