PDA

View Full Version : VBA to centre range of images in cells



darb79
10-05-2016, 03:46 PM
I need to resize images that come from a filepath to 90% of size of cell they are being placed over then centre the image in the cell. Here is my VBA:

Sub AddPictures()
Dim myPic As Picture
Dim wkSheet As Worksheet
Dim myRng As Range
Dim myCell As Range
Dim rowCount As Long
Dim rowCount2 As Long


Set wkSheet = Sheets(1) ' -- Change to your sheet


'-- The usual way of finding used row count for specific column
rowCount2 = wkSheet.Cells(wkSheet.Rows.Count, "A").End(xlUp).Row


If rowCount2 <> 0 Then
Set myRng = wkSheet.Range("A2", wkSheet.Cells(wkSheet.Rows.Count, "A").End(xlUp))


For Each myCell In myRng.Cells
If Trim(myCell.Value) = "" Then
MsgBox "No file path"
ElseIf Dir(CStr(myCell.Value)) = "" Then
MsgBox myCell.Value & " Doesn't exist!"
Else
ActiveSheet.Shapes.AddPicture _
Filename:=myCell.Value, LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=myCell.Offset(ColumnOffset:=1).Left, Top:=myCell.Top, _
Width:=myCell.Width, Height:=myCell.Height
End If
Next myCell


Else
MsgBox "There is no file paths in your column"
End If

End Sub

mana
10-06-2016, 05:08 AM
I hope this will help.


Option Explicit

Sub test()
Dim c As Range
Dim L As Single, T As Single, W As Single, H As Single
Dim r As Long: r = 90

Set c = Range("C3")

With c.Offset(, 1)
L = .Left + .Width * (100 - r) / 100 / 2
T = .Top + .Height * (100 - r) / 100 / 2
H = .Height * r / 100
W = .Width * r / 100
End With

ActiveSheet.Shapes.AddShape msoShapeRectangle, L, T, W, H

End Sub