change_image.vb

Sub printImage

Dim aniamlPic As Picture
Dim picLocation AS String
Dim animalName As String

animalName = Worksheets("Sheet1").Cells(2.2).Value
picLocation = ActiveWorkbook.Path & "\fotoFichas\" & P0001.JPG"

With Worksheets("Sheet1").Cells(2.3)
  Set aniamlPic = ActiveSheets.Picture.Insert(picLocation)
    aniamlPic.Top = .Top
    aniamlPic.Left = .Left
    aniamlPic.ShapeRange.LockAspectRatio = msoFalse
    aniamlPic.ShangeRange.Width = 140
    aniamlPic.Shape.Height = 100
  End With
  Worksheets("Sheet1").Cells(1.1).Select
End Sub
    
    
Sub ExportImage()
      
Dim sFilePath As String
Dim sView As String

'Captures current window view
sView = ActiveWindow.View

'Sets the current view to normal so there are no "Page X" overlays on the image
ActiveWindow.View = xlNormalView

'Temporarily disable screen updating
Application.ScreenUpdating = False

Set Sheet = ActiveSheet

'Set the file path to export the image to the user's desktop
'I have to give credit to Kyle for this solution, found it here:
'http://stackoverflow.com/questions/17551238/vba-how-to-save-excel-workbook-to-desktop-regardless-of-user
sFilePath = CreateObject("WScript.Shell").specialfolders("Desktop") & "\" & ActiveSheet.Name & ".png"

'Export print area as correctly scaled PNG image, courtasy of Winand
zoom_coef = 100 / Sheet.Parent.Windows(1).Zoom
Set area = Sheet.Range(Sheet.PageSetup.PrintArea)
area.CopyPicture xlPrinter
Set chartobj = Sheet.ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
chartobj.Chart.Paste
chartobj.Chart.Export sFilePath, "png"
chartobj.Delete

'Returns to the previous view
ActiveWindow.View = sView

'Re-enables screen updating
Application.ScreenUpdating = True

'Tells the user where the image was saved
MsgBox ("Export completed! The file can be found here:" & Chr(10) & Chr(10) & sFilePath)

End Sub
          
===============
sub copImage()
            dim sSheetName as string
dim oRangeToCopy as range
Dim oCht As Chart

sSheetName ="Sheet1" ' worksheet to work on
set  oRangeToCopy =Range("B2:H8") ' range to be copied

Worksheets(sSheetName).Range(oRangeToCopy).CopyPicture xlScreen, xlBitmap
set oCht =charts.add

with oCht
    .paste
    .Export FileName:="C:\SavedRange.jpg", Filtername:="JPG"
end with
end sub