Improve resolution range to pic

[Wil Moosa]

The following code works but 1) the resolution of the pic is not at it's best ánd 2) width and height are disformed. I tried a bit but it only got worse. Any suggestions to improve the code? Thank you.

Sub ExportDiagrammenFT()
Const FName As String = "C:\Test\TestImage.jpg"
Dim pic_rng As Range
Dim ShTemp As Worksheet
Dim ChTemp As Chart
Dim PicTemp As Picture

Application.ScreenUpdating = False
Set pic_rng = Worksheets("Grafieken_FT").Range("C1:O79")
Set ShTemp = Worksheets.Add
Charts.Add
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:="C:\Test\Functiemix VH " & _
        Format(Date, "dd-mm-yyyy") & ".jpg", FilterName:="jpg"

Application.DisplayAlerts = False
ShTemp.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

 

[Wil Moosa]

Solved it this way...

Sub ExportDiagrammenFT()
 Dim rng As Range
 Dim oWs As Worksheet
 Dim oRng As Range
 Dim oChrtO As ChartObject
 Dim lWidth As Long, lHeight As Long
  On Error Resume Next
 Set oWs = ActiveSheet
 Set oRng = Worksheets("Grafieken_FT").Range("C1:O79")
    On Error GoTo 0
    If Not rng Is Nothing Then
        rng.Select
    End If
 oRng.CopyPicture xlScreen, xlPicture
 lWidth = oRng.Width
 lHeight = oRng.Height
 Set oChrtO = oWs.ChartObjects.Add(Left:=0, Top:=0, Width:=lWidth, Height:=lHeight)
 oChrtO.Activate
 With oChrtO.Chart
  .Paste
  .Export Filename:="C:\Test\Functiemix VH " & _
        Format(Date, "dd-mm-yyyy") & ".jpg", FilterName:="jpg"
 End With
 oChrtO.Delete
Range("A1").Select

End Sub

 

[jolivanes]

I use this at times to sharpen a picture.

Sub Sharpen_Picture()
Dim shp As Excel.Picture
Sheets("Sheet1").Shapes("Picture 1").Select
'    If TypeName(Selection) = "Range" Then MsgBox "Select picture before you proceed.": Exit Sub
Set shp = Selection
    With shp.ShapeRange.Fill.PictureEffects
        .Insert(msoEffectSharpenSoften).EffectParameters(1).Value = 0.85     '0.5  Play with this number
    DoEvents
    End With
End Sub

Weet niet meer waar het vandaan komt maar het werkt.
Don't know the author but it works.

Picture needs to be saved after so it should be part of your code before you are in the "save picture" stage of the code.