Solved

Edit vba function code to amend output image

Posted on 2013-01-16
11
627 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
 
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
Enabling OSINT in Activity Based Intelligence

Activity based intelligence (ABI) requires access to all available sources of data. Recorded Future allows analysts to observe structured data on the open, deep, and dark web.

 

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

How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

Join & Write a Comment

Suggested Solutions

A little background as to how I came to I design this code: Around 5 years ago I designed an add-in that formatted Excel files to a corporate standard, applying different cell colours and font type depending on whether the cells contained inputs,…
How to quickly and accurately populate Word documents with Excel data, charts and images (including Automated Bookmark generation) David Miller (dlmille) Synopsis In this article you’ll learn how to use ExcelToWord! to copy data,charts, shapes …
Viewers will learn the basics of slicers and timelines for both PivotTables and standard Excel tables in Excel 2013.
This Micro Tutorial demonstrates how to create Excel charts: column, area, line, bar, and scatter charts. Formatting tips are provided as well.

759 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

19 Experts available now in Live!

Get 1:1 Help Now