LinkBack URL
About LinkBacks
Convert Range To JPG (Resized)
Hello. I'm using Excel 2000. And I am self-taught in using VBA
(somewhat !).
I was trying to develop the means to save a specified range as a seperate,
external JPG file. After doing some research via the internet and some
experimentation, I came up with the code below. This code works fine --
except -- when used on the range I need, it produces a "squished", out
of proportion picture on the JPG file. In essence, the Chart that is added in
the code needs to be resized or rescaled prior to generating the JPG,
so that its appearance looks correct.
In attempting to to do something similar to this, I used the Macro Recorder
to add a Sheet, then add a Chart to a Workbook, and then manually resize
the Chart to the proportions I need. I then tried added the code generated
by the macro Recorder to the other code below, but it does not work -- it
does not resize the Chart as I need.
Could you review (rethink ?) my code below and help me in this ? What I'm
after is the means to resize the Chart using VBA (instead of manually)
so that the JPG file which is made from the Chart will be in the size
(proportions) I need.
Below will be the main code which solves 95% of the problem. After that code
is additional code I have tried, hoping it would resize the Chart. I include it
here, in that it may stimulate some of your thought, or perhaps I may the
syntax wrong and if the correct syntax is used,that might work.
I truly appreciate any help in this.
Thank you.
Wayne
'---------------------------------------
Code:
Sub CreateJPGfromRange()
Dim Fn As String
Dim TPath As String, PName As String
Dim pic_rng As Range
Dim ShTemp As Worksheet
Dim ChTemp As Chart
Dim PicTemp As Picture
Dim ss As ChartObject
Application.ScreenUpdating = False
'Establish the Current FilePath
TPath = ThisWorkbook.Path & "\"
'Obtain the Pictures Filename from a cell
PName = Range("M15").Value & ".jpg"
Fn = TPath & PName
'Choose the Sheet and Range
Set pic_rng = Worksheets("Sales1").Range("J33:X73")
Set ShTemp = Worksheets.
Add Charts.Add
'note it is after the line above that code needs to be added
'for resizing, rescaling of the Chart
ActiveChart.Location Where:=xlLocationAsObject, Name:=ShTemp.Name
Set ChTemp = ActiveChart pic_rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture ChTemp.Paste
Set PicTemp = Selection
With ChTemp.Parent
.Width = PicTemp.Width + 8
.Height = PicTemp.Height + 8
End With
ChTemp.Export FileName:=Fn, FilterName:="jpg"
Application.DisplayAlerts = False
ShTemp.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
'-------------------------------------
'Some code lines which did NOT work
'Perhaps they can be modified/tweaked to work properly
'Perhaps I do not have the right syntax ?
Code:
'ActiveSheet.Shapes("Chart 1").ScaleWidth 1.3, msoFalse, msoScaleFromTopLeft 'ActiveSheet.Shapes("Chart 1").ScaleHeight 3.62, msoFalse, msoScaleFromTopLeft
'-------------------------------------
'more code that did not resize the Chart
Code:
'For Each ss In ActiveSheet.ChartObjects
'ss.Activate
'ActiveChart.PlotArea.Height = 720
'ActiveChart.PlotArea.Width = 576 'Next
'-------------------------------------
'more code that did not resize the Chart
Code:
'ActiveChart.PlotArea.Height = 360
'ActiveChart.PlotArea.Width = 360
'-------------------------------------
Register To Reply
Bookmarks