Solved

Edit vba function code to amend output image

Posted on 2013-01-16
11
667 Views
Last Modified: 2013-01-16
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
0
Comment
Question by:route217
  • 7
  • 3
11 Comments
 
LVL 33

Expert Comment

by:Norie
ID: 38781862
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
 

Author Comment

by:route217
ID: 38781878
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
 

Author Comment

by:route217
ID: 38782175
Hi imnorie

Was my previous reply helpful at all?
0
Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
LVL 85

Accepted Solution

by:
Rory Archibald earned 500 total points
ID: 38782249
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
 

Author Comment

by:route217
ID: 38782259
Hello genius - once again

Quick silly question - will I still need the get boiler room function...
0
 

Author Comment

by:route217
ID: 38782274
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
 
LVL 85

Expert Comment

by:Rory Archibald
ID: 38782304
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
 

Author Comment

by:route217
ID: 38782352
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
 
LVL 85

Expert Comment

by:Rory Archibald
ID: 38782373
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
 

Author Comment

by:route217
ID: 38782395
Many thanks Rorya - positive feedback as always...

I'll have to post a second question to cover the actual requirement..
0
 

Author Comment

by:route217
ID: 38782401
Ps ill use this code elsewhere diff project
0

Featured Post

Free Tool: Path Explorer

An intuitive utility to help find the CSS path to UI elements on a webpage. These paths are used frequently in a variety of front-end development and QA automation tasks.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

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…
Excel can be a tricky bit of software to get your head around. Whilst you’ll be able to eventually get to grips with the basic understanding of how to get by, there are a few Excel tips that not everybody will even know about let alone know how to d…
This Micro Tutorial will demonstrate in Google Sheets how to use the HYPERLINK function to create live links inside your spreadsheet.
Although Jacob Bernoulli (1654-1705) has been credited as the creator of "Binomial Distribution Table", Gottfried Leibniz (1646-1716) did his dissertation on the subject in 1666; Leibniz you may recall is the co-inventor of "Calculus" and beat Isaac…

680 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