Insert picture using Macro..

M

marc747

I have a macro that I use to insert pictures in excel but I am having
difficulty with the picture size, I would like the picture to keep the
Aspect Ratio but to have a maximum of 100 height and a maximum 100
width is this possible, any help is appreciated.
Thanks.
 
J

Joel

You need to get the larger of the width or height variable and adjust it to 100

pict.LockAspectRatio = msoTrue
if pict.width > pict.height then
pict.width = 100
else
pict.height = 100
end if
 
M

marc747

You need to get the larger of the width or height variable and adjust it to 100

pict.LockAspectRatio = msoTrue
if pict.width > pict.height then
   pict.width = 100
else
   pict.height = 100
end if





- Show quoted text -
Click to expand...

Thanks, you are great!.
Is there any way that I can center the pictures in the cell, because
when the width is > than the height it ia scaling it to 100 but then
it is being placed slightly on the cell in to the left.
thanks
 
M

marc747

Thanks, you are great!.
Is there any way that I can center the pictures in the cell, because
when the width is > than the height it ia scaling it to 100 but then
it is being placed slightly on the cell in to the left.
thanks- Hide quoted text -

- Show quoted text -
Click to expand...

Hi,
I am wondering if this will work! I tried but it seems that I am doing
something wrong can you help please.

pict.LockAspectRatio = msoTrue
if pict.width > pict.height then
pict.cropleft = 50
pict.cropright = 50
else
pict.height = 100
end if
 
J

Joel

You need to get the height and width of the cell is is going into to center
the cell

CellHeight = range("A1").Height
CellWidth = range("A1").Width

pict.LockAspectRatio = msoTrue
if pict.width > pict.height then
pict.width = 100
else
pict.height = 100
end if
WidthBorder = CellWidth - pict.width
pict.left = Range("A1").left + WidthBorder/2

HeightBorder = CellHeight - pict.height
pict.top = Range("A1").Top + HeightBorder/2
 
M

marc747

You need to get the height and width of the cell is is going into to center
the cell

CellHeight = range("A1").Height
CellWidth = range("A1").Width

pict.LockAspectRatio = msoTrue
if pict.width > pict.height then
   pict.width = 100
else
   pict.height = 100
end if
WidthBorder = CellWidth - pict.width
pict.left = Range("A1").left + WidthBorder/2

HeightBorder = CellHeight - pict.height
pict.top = Range("A1").Top + HeightBorder/2







- Show quoted text -
Click to expand...

Hi,
Is it possible to Crop the picture from left and right instead of
sizing it "pict.width = 100"
thanks.
 
J

Joel

CellHeight = Range("A1").Height
CellWidth = Range("A1").Width

pict.LockAspectRatio = msoTrue
If pict.Width > pict.Height Then
If pict.Width > 100 Then
Crop = (CellWidth - pict.Width) / 2
pict.PictureFormat.CropLeft = Crop
pict.PictureFormat.CropRight = Crop
End If
Else
If pict.Height > 100 Then
Crop = (CellWidth - pict.Width) / 2
pict.PictureFormat.CropTop = Crop
pict.PictureFormat.CropBottom = Crop
End If
End If
WidthBorder = CellWidth - pict.Width
pict.Left = Range("A1").Left + WidthBorder / 2

HeightBorder = CellHeight - pict.Height
pict.Top = Range("A1").Top + HeightBorder / 2
 
J

Joel

I made asmall eror

from
If pict.Height > 100 Then
Crop = (CellWidth - pict.Width) / 2
to
If pict.Height > 100 Then
Crop = (CellHeight - pict.Height) / 2
 
M

marc747

I made asmall eror

from
   If pict.Height > 100 Then
       Crop = (CellWidth - pict.Width) / 2
to
   If pict.Height > 100 Then
        Crop = (CellHeight - pict.Height) / 2






- Show quoted text -
Click to expand...

Hi,
Thanks, but it seems that I am doing something wrong. Below is the
Complete Macro that I have know can you look and see what I am doing
wrong.


Sub add_pictures()

Const PictureHeight = 120
DefaultPicture = "O:\MERCHGRP\AAB\pics\Mpics
\Picture_not_Available.jpg"

Application.ScreenUpdating = False

'delete pictures
For Each shp In ActiveSheet.Shapes
If shp.Type = msoPicture Then
shp.Delete
End If
Next shp

LastCol = Cells(4, Columns.Count).End(xlToLeft).Row
Rows(9).RowHeight = PictureHeight

For Each Cell In Range("B4:IV4")
If Cell <> "" Then
Cell.Offset(-3, 0).ClearContents
PictureFound = Dir(Cell.Value)
If PictureFound <> "" Then

Set pict = ActiveSheet.Pictures. _
Insert(Cell.Value)
pict.ShapeRange.LockAspectRatio = msoTrue
pict.ShapeRange.Height = PictureHeight
pictwidth = pict.Width
CellWidth = Cells(9, Cell.Column).Width
WidthBorder = CellWidth - pictwidth
pict.Left = Cells(9, Cell.Column).Left + (WidthBorder / 1.8)

PictHeight = pict.Height
CellHeight = Cells(9, Cell.Column).Height
HeightBorder = CellHeight - PictHeight
pict.Top = Cells(9, Cell.Column).Top + (HeightBorder / 1.8)


If pict.Width > pict.Height Then
Crop = (CellWidth - pict.Width) / 2
pict.PictureFormat.CropLeft = Crop
pict.PictureFormat.CropRight = Crop
End If

If pict.Height > pict.Width Then
Crop = (CellHeight - pict.Height) / 2
pict.PictureFormat.CropTop = Crop
pict.PictureFormat.CropBottom = Crop
End If



Else
Set pict = ActiveSheet.Pictures. _
Insert(DefaultPicture)
pict.ShapeRange.LockAspectRatio = msoTrue
pict.ShapeRange.Height = PictureHeight
pictwidth = pict.Width
CellWidth = Cells(9, Cell.Column).Width
WidthBorder = CellWidth - pictwidth
pict.Left = Cells(9, Cell.Column).Left + (WidthBorder / 1.8)

PictHeight = pict.Height
CellHeight = Cells(9, Cell.Column).Height
HeightBorder = CellHeight - PictHeight
pict.Top = Cells(9, Cell.Column).Top + (HeightBorder / 1.8)

End If
End If 'new line
Next Cell
Exit Sub 'new line


End Sub
 
J

Joel

Be a little bit clear about what is not working. It looks likeyou were only
croping the pictures that were found and not the default picture. I modified
the code below to fix this problem and to make the code common between the
pictures found and not found.


Sub add_pictures()

Const PictureHeight = 120
Folder = "O:\MERCHGRP\AAB\pics\Mpics\"
FName = "Picture_not_Available.jpg"
DefaultPicture = Folder & FName

Application.ScreenUpdating = False

'delete pictures
For Each shp In ActiveSheet.Shapes
If shp.Type = msoPicture Then
shp.Delete
End If
Next shp

LastCol = Cells(4, Columns.Count).End(xlToLeft).Row
Rows(9).RowHeight = PictureHeight

For Each Cell In Range("B4:IV4")
If Cell <> "" Then
Cell.Offset(-3, 0).ClearContents
PictureFound = Dir(Cell.Value)
If PictureFound <> "" Then

Set pict = ActiveSheet.Pictures. _
Insert(Cell.Value)
Else
Set pict = ActiveSheet.Pictures. _
Insert(DefaultPicture)
End If
pict.ShapeRange.LockAspectRatio = msoTrue
pict.ShapeRange.Height = PictureHeight
pictwidth = pict.Width
CellWidth = Cells(9, Cell.Column).Width
WidthBorder = CellWidth - pictwidth
pict.Left = Cells(9, Cell.Column).Left + (WidthBorder / 1.8)

PictHeight = pict.Height
CellHeight = Cells(9, Cell.Column).Height
HeightBorder = CellHeight - PictHeight
pict.Top = Cells(9, Cell.Column).Top + (HeightBorder / 1.8)


If pict.Width > pict.Height Then
Crop = (CellWidth - pict.Width) / 2
pict.PictureFormat.CropLeft = Crop
pict.PictureFormat.CropRight = Crop
Else
Crop = (CellHeight - pict.Height) / 2
pict.PictureFormat.CropTop = Crop
pict.PictureFormat.CropBottom = Crop
End If
End If 'new line
Next Cell
Exit Sub 'new line

End Sub
 
M

marc747

Be a little bit clear about what is not working.  It looks likeyou wereonly
croping the pictures that were found and not the defaultpicture.  I modified
the code below to fix this problem and to make the code common between the
pictures found and not found.

Sub add_pictures()

Const PictureHeight = 120
Folder = "O:\MERCHGRP\AAB\pics\Mpics\"
FName = "Picture_not_Available.jpg"
DefaultPicture = Folder & FName

Application.ScreenUpdating = False

'delete pictures
For Each shp In ActiveSheet.Shapes
   If shp.Type = msoPicture Then
      shp.Delete
   End If
Next shp

LastCol = Cells(4, Columns.Count).End(xlToLeft).Row
Rows(9).RowHeight = PictureHeight

For Each Cell In Range("B4:IV4")
   If Cell <> "" Then
      Cell.Offset(-3, 0).ClearContents
      PictureFound = Dir(Cell.Value)
      If PictureFound <> "" Then

         Set pict = ActiveSheet.Pictures. _
           Insert(Cell.Value)
       Else
                Set pict = ActiveSheet.Pictures. _
           Insert(DefaultPicture)
       End If
         pict.ShapeRange.LockAspectRatio = msoTrue
         pict.ShapeRange.Height = PictureHeight
         pictwidth = pict.Width
         CellWidth = Cells(9, Cell.Column).Width
         WidthBorder = CellWidth - pictwidth
         pict.Left = Cells(9, Cell.Column).Left + (WidthBorder / 1.8)

         PictHeight = pict.Height
         CellHeight = Cells(9, Cell.Column).Height
         HeightBorder = CellHeight - PictHeight
         pict.Top = Cells(9, Cell.Column).Top + (HeightBorder/ 1.8)

         If pict.Width > pict.Height Then
            Crop = (CellWidth - pict.Width) / 2
            pict.PictureFormat.CropLeft = Crop
            pict.PictureFormat.CropRight = Crop
         Else
            Crop = (CellHeight - pict.Height) / 2
            pict.PictureFormat.CropTop = Crop
            pict.PictureFormat.CropBottom = Crop
         End If
   End If 'new line
Next Cell
Exit Sub 'new line

End Sub




















- Show quoted text -
Click to expand...

Hi,
There is no need to crop the Default picture because it is a standerd
size made to fit, the other pictures are the one that when they were
created it was created all different sizes and propotions.
Thanks.
 
M

marc747

Be a little bit clear about what is not working.  It looks likeyou wereonly
croping the pictures that were found and not the defaultpicture.  I modified
the code below to fix this problem and to make the code common between the
pictures found and not found.

Sub add_pictures()

Const PictureHeight = 120
Folder = "O:\MERCHGRP\AAB\pics\Mpics\"
FName = "Picture_not_Available.jpg"
DefaultPicture = Folder & FName

Application.ScreenUpdating = False

'delete pictures
For Each shp In ActiveSheet.Shapes
   If shp.Type = msoPicture Then
      shp.Delete
   End If
Next shp

LastCol = Cells(4, Columns.Count).End(xlToLeft).Row
Rows(9).RowHeight = PictureHeight

For Each Cell In Range("B4:IV4")
   If Cell <> "" Then
      Cell.Offset(-3, 0).ClearContents
      PictureFound = Dir(Cell.Value)
      If PictureFound <> "" Then

         Set pict = ActiveSheet.Pictures. _
           Insert(Cell.Value)
       Else
                Set pict = ActiveSheet.Pictures. _
           Insert(DefaultPicture)
       End If
         pict.ShapeRange.LockAspectRatio = msoTrue
         pict.ShapeRange.Height = PictureHeight
         pictwidth = pict.Width
         CellWidth = Cells(9, Cell.Column).Width
         WidthBorder = CellWidth - pictwidth
         pict.Left = Cells(9, Cell.Column).Left + (WidthBorder / 1.8)

         PictHeight = pict.Height
         CellHeight = Cells(9, Cell.Column).Height
         HeightBorder = CellHeight - PictHeight
         pict.Top = Cells(9, Cell.Column).Top + (HeightBorder/ 1.8)

         If pict.Width > pict.Height Then
            Crop = (CellWidth - pict.Width) / 2
            pict.PictureFormat.CropLeft = Crop
            pict.PictureFormat.CropRight = Crop
         Else
            Crop = (CellHeight - pict.Height) / 2
            pict.PictureFormat.CropTop = Crop
            pict.PictureFormat.CropBottom = Crop
         End If
   End If 'new line
Next Cell
Exit Sub 'new line

End Sub




















- Show quoted text -
Click to expand...

Hi,
I just tried the last one you sent and it is giving an error at
"pict.PictureFormat.CropTop = Crop"
Thanks.
 
J

Joel

shaperange was missing

Sub add_pictures()

Const PictureHeight = 120
Folder = "O:\MERCHGRP\AAB\pics\Mpics\"
FName = "Picture_not_Available.jpg"
DefaultPicture = Folder & FName

Application.ScreenUpdating = False

'delete pictures
For Each shp In ActiveSheet.Shapes
If shp.Type = msoPicture Then
shp.Delete
End If
Next shp

LastCol = Cells(4, Columns.Count).End(xlToLeft).Row
Rows(9).RowHeight = PictureHeight

For Each Cell In Range("B4:IV4")
If Cell <> "" Then
Cell.Offset(-3, 0).ClearContents
PictureFound = Dir(Cell.Value)
If PictureFound <> "" Then

Set pict = ActiveSheet.Pictures. _
Insert(Cell.Value)
Else
Set pict = ActiveSheet.Pictures. _
Insert(DefaultPicture)
End If
pict.ShapeRange.LockAspectRatio = msoTrue
'pict.ShapeRange.Height = PictureHeight <=deleted
pictwidth = pict.Width
CellWidth = Cells(9, Cell.Column).Width
WidthBorder = CellWidth - pictwidth
pict.Left = Cells(9, Cell.Column).Left + (WidthBorder / 1.8)

PictHeight = pict.Height
CellHeight = Cells(9, Cell.Column).Height
HeightBorder = CellHeight - PictHeight
pict.Top = Cells(9, Cell.Column).Top + (HeightBorder / 1.8)


If pict.Width > pict.Height Then
Crop = (CellWidth - pict.Width) / 2
pict.ShapeRange.PictureFormat.CropLeft = Crop
pict.ShapeRange.PictureFormat.CropRight = Crop
Else
Crop = (CellHeight - pict.Height) / 2
pict.ShapeRange.PictureFormat.CropTop = Crop
pict.ShapeRange.PictureFormat.CropBottom = Crop
End If
End If 'new line
Next Cell
Exit Sub 'new line

End Sub
 
M

marc747

shaperange was missing

Sub add_pictures()

Const PictureHeight = 120
Folder = "O:\MERCHGRP\AAB\pics\Mpics\"
FName = "Picture_not_Available.jpg"
DefaultPicture = Folder & FName

Application.ScreenUpdating = False

'delete pictures
For Each shp In ActiveSheet.Shapes
   If shp.Type = msoPicture Then
      shp.Delete
   End If
Next shp

LastCol = Cells(4, Columns.Count).End(xlToLeft).Row
Rows(9).RowHeight = PictureHeight

For Each Cell In Range("B4:IV4")
   If Cell <> "" Then
      Cell.Offset(-3, 0).ClearContents
      PictureFound = Dir(Cell.Value)
      If PictureFound <> "" Then

         Set pict = ActiveSheet.Pictures. _
           Insert(Cell.Value)
       Else
                Set pict = ActiveSheet.Pictures. _
           Insert(DefaultPicture)
       End If
         pict.ShapeRange.LockAspectRatio = msoTrue
         'pict.ShapeRange.Height = PictureHeight   <=deleted
         pictwidth = pict.Width
         CellWidth = Cells(9, Cell.Column).Width
         WidthBorder = CellWidth - pictwidth
         pict.Left = Cells(9, Cell.Column).Left + (WidthBorder / 1.8)

         PictHeight = pict.Height
         CellHeight = Cells(9, Cell.Column).Height
         HeightBorder = CellHeight - PictHeight
         pict.Top = Cells(9, Cell.Column).Top + (HeightBorder/ 1.8)

         If pict.Width > pict.Height Then
            Crop = (CellWidth - pict.Width) / 2
            pict.ShapeRange.PictureFormat.CropLeft = Crop
            pict.ShapeRange.PictureFormat.CropRight = Crop
         Else
            Crop = (CellHeight - pict.Height) / 2
            pict.ShapeRange.PictureFormat.CropTop = Crop
            pict.ShapeRange.PictureFormat.CropBottom = Crop
         End If
   End If 'new line
Next Cell
Exit Sub 'new line

End Sub






- Show quoted text -
Click to expand...


Hi,
Thanks, How would I crop the Width more?
 
M

marc747

shaperange was missing

Sub add_pictures()

Const PictureHeight = 120
Folder = "O:\MERCHGRP\AAB\pics\Mpics\"
FName = "Picture_not_Available.jpg"
DefaultPicture = Folder & FName

Application.ScreenUpdating = False

'delete pictures
For Each shp In ActiveSheet.Shapes
   If shp.Type = msoPicture Then
      shp.Delete
   End If
Next shp

LastCol = Cells(4, Columns.Count).End(xlToLeft).Row
Rows(9).RowHeight = PictureHeight

For Each Cell In Range("B4:IV4")
   If Cell <> "" Then
      Cell.Offset(-3, 0).ClearContents
      PictureFound = Dir(Cell.Value)
      If PictureFound <> "" Then

         Set pict = ActiveSheet.Pictures. _
           Insert(Cell.Value)
       Else
                Set pict = ActiveSheet.Pictures. _
           Insert(DefaultPicture)
       End If
         pict.ShapeRange.LockAspectRatio = msoTrue
         'pict.ShapeRange.Height = PictureHeight   <=deleted
         pictwidth = pict.Width
         CellWidth = Cells(9, Cell.Column).Width
         WidthBorder = CellWidth - pictwidth
         pict.Left = Cells(9, Cell.Column).Left + (WidthBorder / 1.8)

         PictHeight = pict.Height
         CellHeight = Cells(9, Cell.Column).Height
         HeightBorder = CellHeight - PictHeight
         pict.Top = Cells(9, Cell.Column).Top + (HeightBorder/ 1.8)

         If pict.Width > pict.Height Then
            Crop = (CellWidth - pict.Width) / 2
            pict.ShapeRange.PictureFormat.CropLeft = Crop
            pict.ShapeRange.PictureFormat.CropRight = Crop
         Else
            Crop = (CellHeight - pict.Height) / 2
            pict.ShapeRange.PictureFormat.CropTop = Crop
            pict.ShapeRange.PictureFormat.CropBottom = Crop
         End If
   End If 'new line
Next Cell
Exit Sub 'new line

End Sub






- Show quoted text -
Click to expand...

Hi,
Thanks, How would I crop the Width more?
 
M

marc747

shaperange was missing

Sub add_pictures()

Const PictureHeight = 120
Folder = "O:\MERCHGRP\AAB\pics\Mpics\"
FName = "Picture_not_Available.jpg"
DefaultPicture = Folder & FName

Application.ScreenUpdating = False

'delete pictures
For Each shp In ActiveSheet.Shapes
   If shp.Type = msoPicture Then
      shp.Delete
   End If
Next shp

LastCol = Cells(4, Columns.Count).End(xlToLeft).Row
Rows(9).RowHeight = PictureHeight

For Each Cell In Range("B4:IV4")
   If Cell <> "" Then
      Cell.Offset(-3, 0).ClearContents
      PictureFound = Dir(Cell.Value)
      If PictureFound <> "" Then

         Set pict = ActiveSheet.Pictures. _
           Insert(Cell.Value)
       Else
                Set pict = ActiveSheet.Pictures. _
           Insert(DefaultPicture)
       End If
         pict.ShapeRange.LockAspectRatio = msoTrue
         'pict.ShapeRange.Height = PictureHeight   <=deleted
         pictwidth = pict.Width
         CellWidth = Cells(9, Cell.Column).Width
         WidthBorder = CellWidth - pictwidth
         pict.Left = Cells(9, Cell.Column).Left + (WidthBorder/ 1.8)

         PictHeight = pict.Height
         CellHeight = Cells(9, Cell.Column).Height
         HeightBorder = CellHeight - PictHeight
         pict.Top = Cells(9, Cell.Column).Top + (HeightBorder / 1.8)

         If pict.Width > pict.Height Then
            Crop = (CellWidth - pict.Width) / 2
            pict.ShapeRange.PictureFormat.CropLeft = Crop
            pict.ShapeRange.PictureFormat.CropRight = Crop
         Else
            Crop = (CellHeight - pict.Height) / 2
            pict.ShapeRange.PictureFormat.CropTop = Crop
            pict.ShapeRange.PictureFormat.CropBottom = Crop
         End If
   End If 'new line
Next Cell
Exit Sub 'new line

End Sub






- Show quoted text -
Click to expand...



Hi,
I am still trying to get this correct, Everything that yoou sent works
but I need to change a few thing because when I am testing is when I
find that something need to be different, I would appreciate for your
help.
The part of the macro that needs to be different is below, I want to
see if possible to make the macro to ( If Width > height then Crop to
same as height, If height is > width then Crop to same as Width)
Thanks.

****************

If pict.Width > pict.Height Then
Crop = (CellWidth - pict.Width) / 2
pict.ShapeRange.PictureFormat.CropLeft = Crop
pict.ShapeRange.PictureFormat.CropRight = Crop
Else
Crop = (CellHeight - pict.Height) / 2
pict.ShapeRange.PictureFormat.CropTop = Crop
pict.ShapeRange.PictureFormat.CropBottom = Crop
End If

******************
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Insert multiple objects at once ? 3
Insert Picture using Macro & Validation list 5
Automatically sending multiple parts of text from one word doc to another - is possible. 0
Publisher 2019 Format Picture window size too large to display OK button 0
Embed the same Excel multiple times 0
Place picture in Excel cell 0
Trying to resize pictures in excel all to the same size 4
Chop picture in VBA? 9

Top