Option Explicit
' global constants
Const gksWS = "Hoja1"
Const gkiName = 1
Const gkiImage = 2
Const gkiRatio = 3
Const gksPath = "\"
Const gksSuffix = "_copy"
Const gksExtension = ".jpg"
Const gknUnknownFactor = 26.46
' global declarations
Dim cell As Range
Dim gsPicture As String, gnWidth As Single, gnHeight As Single
Sub LoadImages()
' constants
' declarations
Dim I As Integer, pic As Object, nWidthW As Single, nHeightW As Single
' start
' clear shapes (images) in col gkiImage
With Worksheets(gksWS)
For I = .Shapes.Count To 1 Step -1
If .Shapes(I).Type = msoLinkedPicture Then
If .Shapes(I).Left >= .Cells(1, gkiImage).Left And _
.Shapes(I).Left < .Cells(1, gkiImage + 1).Left Then .Shapes(I).Delete
End If
Next I
End With
' process
I = 1
With Worksheets(gksWS)
Do Until .Cells(I, gkiName).Value = ""
' filename
gsPicture = ActiveWorkbook.Path & gksPath & _
.Cells(I, gkiName).Value & gksExtension
If Dir(gsPicture) <> "" Then
' where
Set cell = .Cells(I, gkiImage)
' aspect ratio
Set pic = LoadPicture(gsPicture)
nWidthW = pic.Width / gknUnknownFactor
nHeightW = pic.Height / gknUnknownFactor
Select Case nWidthW / nHeightW
Case Is > cell.Width / cell.Height
gnWidth = cell.Width
gnHeight = nHeightW * gnWidth / nWidthW
.Cells(I, gkiRatio).Value = (pic.Width / gknUnknownFactor) / cell.Width
Case Is <= cell.Width / cell.Height
gnHeight = cell.Height
gnWidth = nWidthW * gnHeight / nHeightW
.Cells(I, gkiRatio).Value = (pic.Height / gknUnknownFactor) / cell.Height
End Select
' insert
.Shapes.AddPicture gsPicture, True, True, _
cell.Left, cell.Top, gnWidth, gnHeight
End If
I = I + 1
Loop
End With
' end
Set pic = Nothing
Set cell = Nothing
Beep
End Sub
Sub SaveImages()
' constants
' declarations
Dim I As Integer, J As Integer, cht As Chart
' start
' process
I = 1
With Worksheets(gksWS)
For I = .Shapes.Count To 1 Step -1
If .Shapes(I).Type = msoLinkedPicture Then
If .Shapes(I).Left >= .Cells(1, gkiImage).Left And _
.Shapes(I).Left < .Cells(1, gkiImage + 1).Left Then
' cell
J = .Shapes(I).TopLeftCell.Row
Set cell = .Cells(J, gkiImage)
' filename
gsPicture = ActiveWorkbook.Path & gksPath & _
.Cells(J, gkiName).Value & gksSuffix & gksExtension
If Dir(gsPicture) <> "" Then Kill gsPicture
' copy image
.Shapes(I).CopyPicture
' create chart
Debug.Print I; J, .Shapes(I).Width; .Shapes(I).Height
Set cht = .ChartObjects.Add(1, 1, _
.Shapes(I).Width * .Cells(J, gkiRatio).Value, _
.Shapes(I).Height * .Cells(J, gkiRatio).Value).Chart
' paste on chart
cht.Paste
cht.ChartArea.Border.LineStyle = 0
' export image & clean up
cht.Export gsPicture
cht.Parent.Delete
Application.CutCopyMode = False
End If
End If
Next I
End With
' end
Set cht = Nothing
Set cell = Nothing
Beep
End Sub
