Edit vba function code to amend output image

Hi Experts

I need edit the following function which currently produces a output in the form of a HTML image to .jpg how would you do this....
       
 
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
route217Asked:
Who is Participating?
 
Rory ArchibaldConnect With a Mentor Commented:
It's not really an amendment, it's completely different code. For instance:
Public Sub JPG_Snapshot(rng As Range)
   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 = ActiveWorkbook
   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 = Application.GetSaveAsFilename( _
                 InitialFileName:=MySuggest, filefilter:="JPG Files (*.jpg), *.jpg")
      If SaveName <> False Then
         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:=LCase(SaveName), FilterName:="jpg"
            .Pictures(1).Delete
         End With
         Sourcebook.Activate
      End If
   End If

   On Error Resume Next
   Application.StatusBar = False
   containerbook.Saved = True
   containerbook.Close
End Sub

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
 
NorieVBA ExpertCommented:
That code doesn't output an image, it converts a range to HTML.

What exactly are you trying you do?

What is it you want an image of and what are you doing with the image?
0
 
route217Author Commented:
Apologies firstly on my part..

I am trying to convert the range to jpg... Ready to email of the range of data as specified...

I want people with mobile phones to see the image...
0
Keep up with what's happening at Experts Exchange!

Sign up to receive Decoded, a new monthly digest with product updates, feature release info, continuing education opportunities, and more.

 
route217Author Commented:
Hi imnorie

Was my previous reply helpful at all?
0
 
route217Author Commented:
Hello genius - once again

Quick silly question - will I still need the get boiler room function...
0
 
route217Author Commented:
Hi Rorya

This is my full vba that I am currently using to email the image as  HTML via outlook..


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
 
Rory ArchibaldCommented:
The getboiler function adds boilerplate text to the email. If you want that, then keep it. Note that the code I posted will not embed the image into the email - you will need to add the saved graphic file as an attachment.
0
 
route217Author Commented:
So without sound to stupid...
If I kept the sub part of my code and inserted your newly created vba and left the get boiler room function...

It should do what I am looking for ????
0
 
Rory ArchibaldCommented:
Depends how you add it. ;)

The two processes are not at all the same - one sets the body of the email, the other will require attaching a file instead. I can't say whether either will actually work for your purposes (viewing on mobile phones).

To my mind your question is akin to: "I have some code that creates an email from a range, can you tweak it to create a Powerpoint presentation instead?"
Answer: No you can't just tweak it - it requires rewriting because the two things are fundamentally different. :)
0
 
route217Author Commented:
Many thanks Rorya - positive feedback as always...

I'll have to post a second question to cover the actual requirement..
0
 
route217Author Commented:
Ps ill use this code elsewhere diff project
0
All Courses

From novice to tech pro — start learning today.