Macro to Insert and resize picture

[lcodd6]

[FONT=&quot]I need some help writing a macro.[/FONT]
[FONT=&quot]I am trying to create a macro that will insert a picture into the current selected cell and compress the picture to reduce the file size and to fit inside the cell. I plan to add a button that once clicked it will perform this operation. Any help to write this code would be greatly appreciated. [/FONT]
[FONT=&quot]I am using Excel 2013[/FONT]

 

[yky]

Sub insert_pic()
'This script inserts 'D:\test\myFile.jpg" into the active cell and shrink the size of picture by 10%
'It also adjust the cell height to fit the picture
Const factor=0.9 'shrink factor
Const Path_Prefix = "D:\test\" 'set path prefix
Dim myFile As String
Dim p As Object

'insert picture
Set p = ActiveSheet.Shapes.AddPicture(Filename:=Path_Prefix & myFile & ".jpg", LinkToFile:=False, SaveWithDocument:=True, Left:=ActiveCell.Left, _ Top:=ActiveCell.Top, Width:=-1, Height:=-1)

'shrink picture
p.Width = ActiveCell.Width * factor
'adjust row height
If ActiveCell.RowHeight < p.Height / factor Then
ActiveCell.RowHeight = p.Height / factor
End If
'center picture
p.Left = ActiveCell.Left + (ActiveCells.Width - p.Width) / 2
p.Top = ActiveCell.Top + (ActiveCell.Height - p.Height) / 2
End Sub

 

[tonyyy]

Another approach...

Sub CompressPicture()
Dim fName As String
Dim pic As Picture
Dim r As Range

fName = Application.GetOpenFilename( _
        FileFilter:="Images (*.jpg;*.gif;*.png),*.jpg;*.gif;*.png", _
        Title:="Please select an image...")
If fName = "False" Then Exit Sub

Set r = ActiveCell
Set pic = Worksheets("Sheet1").Pictures.Insert(fName)

With pic
    .ShapeRange.LockAspectRatio = msoFalse
    .Left = r.Left
    .Top = r.Top
    .Width = r.Width
    .Height = r.Height
    .Select
End With

If TypeName(Selection) = "Picture" Then
    Application.SendKeys "%a~"
    Application.CommandBars.ExecuteMso "PicturesCompress"
End If
End Sub

Note that making the picture "fit inside the cell" will likely cause some distortion. And the compression function will use the current selections in the Compress Pictures dialog.

Cheers,

tonyyy

 

[lcodd6]

I really nice this code but is there anyway to modify this code to resize and keep the same aspect ratio?

Sub AddMyPicture()

Dim sh As Shape
Dim sPath As String

With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False

If .Show Then
sPath = .SelectedItems(1)
End If
End With

ActiveSheet.Shapes.AddPicture Filename:=sPath, LinkToFile:=0, SaveWithDocument:=-1, _
Left:=ActiveCell.Left, Top:=ActiveCell.Top, Width:=ActiveCell.Width, Height:=ActiveCell.Height



End Sub

 

[lcodd6]

I really nice this code but is there anyway to modify this code to resize and keep the same aspect ratio?

Sub AddMyPicture()

Dim sh As Shape
Dim sPath AsString

With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect =False

If.Show Then
sPath =.SelectedItems(1)
EndIf
EndWith

ActiveSheet.Shapes.AddPicture Filename:=sPath, LinkToFile:=0, SaveWithDocument:=-1, _
Left:=ActiveCell.Left, Top:=ActiveCell.Top, Width:=ActiveCell.Width, Height:=ActiveCell.Height



EndSub

Sorry, this is the one I'm trying to modify to fit into the cell but keep the same aspect ratio. For some reason this program to not fitting the picture in the cell.

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

 

[JShilt]

Trying to do something similar I use the following code.

Sub Insert_Picture_Click()





        
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .ButtonName = "Submit"
        .Title = "Select an image file"
        .Filters.Clear
        .Filters.Add "JPG", "*.JPG"
        .Filters.Add "JPEG File Interchange Format", "*.JPEG"
        .Filters.Add "Graphics Interchange Format", "*.GIF"
        .Filters.Add "Portable Network Graphics", "*.PNG"
        .Filters.Add "Tag Image File Format", "*.TIFF"
        .Filters.Add "All Pictures", "*.*"






        If .Show = -1 Then
            Dim img As Object
        Set img = ActiveSheet.Shapes.AddPicture(.SelectedItems(1), _
    linktofile:=msoFalse, savewithdocument:=msoCTrue, Left:=ActiveCell.Left, Top:=ActiveCell.Top, Width:=-1, Height:=-1)




            'Set image sizes in points (72 point per inch)
            img.Width = 150


        Else
            MsgBox ("Cancelled.")
        End If
    End With


End Sub

I have one sheet that this works without issue. But in a different sheet using the same code (I exported the module and then imported the module) I get the following error.

Run-time error '1004':
The specified value is out of range.

The Debug points to the following line,

        Set img = ActiveSheet.Shapes.AddPicture(.SelectedItems(1), _
    linktofile:=msoFalse, savewithdocument:=msoCTrue, Left:=ActiveCell.Left, Top:=ActiveCell.Top, Width:=-1, Height:=-1)

Why would this work in one workbook and not another?

 

[JShilt]

I figured this one out. The issue was that I had the worksheet locked. I had to unlock the sheet and then lock it again.

 

[SomeOrdinaryIndian]

Another approach...

Sub CompressPicture()
Dim fName As String
Dim pic As Picture
Dim r As Range

fName = Application.GetOpenFilename( _
        FileFilter:="Images (*.jpg;*.gif;*.png),*.jpg;*.gif;*.png", _
        Title:="Please select an image...")
If fName = "False" Then Exit Sub

Set r = ActiveCell
Set pic = Worksheets("Sheet1").Pictures.Insert(fName)

With pic
    .ShapeRange.LockAspectRatio = msoFalse
    .Left = r.Left
    .Top = r.Top
    .Width = r.Width
    .Height = r.Height
    .Select
End With

If TypeName(Selection) = "Picture" Then
    Application.SendKeys "%a~"
    Application.CommandBars.ExecuteMso "PicturesCompress"
End If
End Sub

Note that making the picture "fit inside the cell" will likely cause some distortion. And the compression function will use the current selections in the Compress Pictures dialog.

Cheers,

tonyyy

Hey, could you update the code to select multiple photos? Looking for some help here VBA for inserting multiple photos from a specified folder