Code Modification Help Needed

[lcodd6]

I need help modifying this code. When I use this code I need it to resize the picture to fit into the selected cell but keep the same aspect ratio. Also, is it possible to have the code compress the picture to reduce the file size?

Sub piccy()
Dim sFile As Variant, r As Range
sFile = Application.GetOpenFilename(FileFilter:="Pic Files (*.jpg;*.bmp), *.jpg;*.bmp", Title:="Browse to select a picture")
If sFile = False Then Exit Sub
On Error Resume Next
Set r = Application.InputBox("Click in the cell to hold the picture", Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
If r.Count > 1 Then Exit Sub
ActiveSheet.Pictures.Insert (sFile)
With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
.LockAspectRatio = True
.Top = r.Top
.Left = r.Left
.Height = r.RowHeight
End With
End Sub

 

[Kenneth Hobson]

When pasting code, please do so between code tags. Click the # icon on the toolbar to insert them.

You can not "fit" in a cell AND keep the ratios the same as a general rule. It can be done for one cell or a few if not in same row or column. Doing so for many in a column is likely not possible since the pics may have different ratios.

Since you used Insert, picsize should not be an issue as it links the file rather than embed. I have seen compress done using Application.SendKeys() but using it is seldom a good idea. That method also depends on your Excel version. You would be better off making copies of the files and using a 3rd party program to reduce file size.

 

[lcodd6]

[CODE][CODE][CODE]

[/CODE][/CODE][/CODE]

When pasting code, please do so between code tags. Click the # icon on the toolbar to insert them.

You can not "fit" in a cell AND keep the ratios the same as a general rule. It can be done for one cell or a few if not in same row or column. Doing so for many in a column is likely not possible since the pics may have different ratios.

Since you used Insert, picsize should not be an issue as it links the file rather than embed. I have seen compress done using Application.SendKeys() but using it is seldom a good idea. That method also depends on your Excel version. You would be better off making copies of the files and using a 3rd party program to reduce file size.

Can you help me modify this code to "fit into the cell?

[COLOR=#333333][COLOR=#333333][COLOR=#333333]Sub piccy()[/COLOR][/COLOR][/COLOR]
[COLOR=#333333][COLOR=#333333][COLOR=#333333]Dim sFile As Variant, r As Range[/COLOR][/COLOR][/COLOR]
[COLOR=#333333][COLOR=#333333][COLOR=#333333]sFile = Application.GetOpenFilename(FileFilter:="Pic Files (*.jpg;*.bmp), *.jpg;*.bmp", Title:="Browse to select a picture")[/COLOR][/COLOR][/COLOR]
[COLOR=#333333][COLOR=#333333][COLOR=#333333]If sFile = False Then Exit Sub[/COLOR][/COLOR][/COLOR]
[COLOR=#333333][COLOR=#333333][COLOR=#333333]On Error Resume Next[/COLOR][/COLOR][/COLOR]
[COLOR=#333333][COLOR=#333333][COLOR=#333333]Set r = Application.InputBox("Click in the cell to hold the picture", Type:=8)[/COLOR][/COLOR][/COLOR]
[COLOR=#333333][COLOR=#333333][COLOR=#333333]On Error GoTo 0[/COLOR][/COLOR][/COLOR]
[COLOR=#333333][COLOR=#333333][COLOR=#333333]If r Is Nothing Then Exit Sub[/COLOR][/COLOR][/COLOR]
[COLOR=#333333][COLOR=#333333][COLOR=#333333]If r.Count > 1 Then Exit Sub[/COLOR][/COLOR][/COLOR]
[COLOR=#333333][COLOR=#333333][COLOR=#333333]ActiveSheet.Pictures.Insert (sFile)[/COLOR][/COLOR][/COLOR]
[COLOR=#333333][COLOR=#333333][COLOR=#333333]With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)[/COLOR][/COLOR][/COLOR]
[COLOR=#333333][COLOR=#333333][COLOR=#333333].LockAspectRatio = True[/COLOR][/COLOR][/COLOR]
[COLOR=#333333][COLOR=#333333][COLOR=#333333].Top = r.Top[/COLOR][/COLOR][/COLOR]
[COLOR=#333333][COLOR=#333333][COLOR=#333333].Left = r.Left[/COLOR][/COLOR][/COLOR]
[COLOR=#333333][COLOR=#333333][COLOR=#333333].Height = r.RowHeight[/COLOR][/COLOR][/COLOR]
[COLOR=#333333][COLOR=#333333][COLOR=#333333]End With[/COLOR][/COLOR][/COLOR]
[COLOR=#333333][COLOR=#333333][COLOR=#333333]End Sub[/COLOR][/COLOR][/COLOR]

 

[Kenneth Hobson]

Sure, just remove your LockAspectRatio and set the width as I show below. You can link or not using AddPicture(). e.g.

Sub Main()
  Dim pic As Shape, r As Range, fPath As String

  fPath = "x:\pics\"
  
  On Error Resume Next
  For Each r In Range("A2", Range("A" & Rows.Count).End(xlUp))
    Set pic = ActiveSheet.Shapes.AddPicture(Filename:=fPath & r.Value2 & ".jpg", _
      LinkToFile:=msoFalse, SaveWithDocument:=msoCTrue, _
      ******=r.Offset(, 1).Left, *****=r.Offset(, 1).Top, _
      *******=r.Width, ********=r.RowHeight)
    'Debug.Print pic.Name
  Next r
End Sub

Since the forum is obfuscating parts, see Main() in: https://www.dropbox.com/s/f6atwnu81spirsy/InsertAndResize2.xlsm?dl=0