Insert picture into cell Macro edit request

ipbr21054

Well-known Member
Joined
Nov 16, 2010
Messages
5,199
Office Version
  1. 2007
Platform
  1. Windows
Hi,
I am using the Macro code shown below.
Currently when i press the button a box pops up & i then need to browse to where the picture is.
I would like to be able to press the button where this time when the box pops up just take me to the folder.
The path for the folder is called C:\Users\Ian\Desktop

Also lets say there is a photo already in cell B9 but i want to change it, i have noticed that if i select this picture and run through the insert process it then puts the new inserted picture in the next cell as opposed the the selected B9 cell.

Is it possible that when i try to insert a picture show a Msgbox YES NO asking if i wish to replace it,YES to overwrite & No to exit code etc.




Code:
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("LP ME").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
 

Excel Facts

When did Power Query debut in Excel?
Although it was an add-in in Excel 2010 & Excel 2013, Power Query became a part of Excel in 2016, in Data, Get & Transform Data.
i have record this and it works fine without prompt for ask wich file too use

Sub Picturcelle()
'
' Picturcelle Makro
'
'
ActiveSheet.Pictures.Insert("C:\Users\Henri\Pictures\50 års.jpg").Select
Selection.ShapeRange.IncrementLeft -15.75
Selection.ShapeRange.IncrementTop -305.25
Selection.ShapeRange.ScaleWidth 0.5624999507, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 0.5625, msoFalse, msoScaleFromBottomRight
Selection.ShapeRange.IncrementLeft 61.5
Selection.ShapeRange.IncrementTop -312.75
Selection.ShapeRange.ScaleHeight 0.8592592593, msoFalse, _
msoScaleFromBottomRight
Selection.ShapeRange.ScaleWidth 0.5775862384, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 0.5775862069, msoFalse, _
msoScaleFromBottomRight
Range("I19").Select
End Sub
 
Upvote 0
That code inserts only one specific image anywhere on the screen.

My original works perfect but need to address the issues in the post.

many thanks for the effort
 
Upvote 0
Hi,
Just an update

Below is the current code in use.
After hours of constant editing as i couldnt find out why the sheet was all out of sync, i have found the issue.
The code works well all but one HUGE problem of which is when you sort a column say A-Z all the cells sort no problem at all but the photos look like they are inserted as a layer,meaning on top of the cells in column B

Only noticed this when i selected a few rows 7 changed the colors.
Sorting different columns would not break any of the row colors but the photos were all over the place.

Is the sort supposed to also sort the photos ?



Code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Not Application.Intersect(Target, Range("A3:E100")) Is Nothing Then
    Range("D3:D100").Font.Size = 20
    Range("D3:D100").Font.Size = 20
    Range("D3:D100").Name = "Calibri"
    Range("D3:D100").BorderAround xlContinuous, xlThin
    Range("D3:D100").BorderAround xlContinuous, xlThin
   [D13:D100] = [INDEX(UPPER(D13:D100),)]
End If
    Dim myStartCol As String
    Dim myEndCol As String
    Dim myStartRow As Long
    Dim myLastRow As Long
    Dim myRange As Range


    If Target.Cells.Count > 1 Then Exit Sub
    
    Application.ScreenUpdating = False
    
'   *** Specify columns to apply this to ***
    myStartCol = "A"
    myEndCol = "E"


'   *** Specify start row ***
    myStartRow = 3
    
'   Use first column to find the last row
    myLastRow = Cells(Rows.Count, myStartCol).End(xlUp).Row
    
'   Build range to apply this to
    Set myRange = Range(Cells(myStartRow, myStartCol), Cells(myLastRow, myEndCol))
    
'   Clear the color of all the cells in range
    myRange.Interior.ColorIndex = 6
    
'   Check to see if cell selected is outside of range
    If Intersect(Target, myRange) Is Nothing Then Exit Sub
    
'   Highlight the row and column that contain the active cell
    Range(Cells(Target.Row, myStartCol), Cells(Target.Row, myEndCol)).Interior.ColorIndex = 8
Target.Interior.Color = vbGreen
    Application.ScreenUpdating = True


End Sub
 
Upvote 0
Hi,
I am using the Macro code shown below.
Currently when i press the button a box pops up & i then need to browse to where the picture is.
I would like to be able to press the button where this time when the box pops up just take me to the folder.
The path for the folder is called C:\Users\Ian\Desktop

Also lets say there is a photo already in cell B9 but i want to change it, i have noticed that if i select this picture and run through the insert process it then puts the new inserted picture in the next cell as opposed the the selected B9 cell.

Is it possible that when i try to insert a picture show a Msgbox YES NO asking if i wish to replace it,YES to overwrite & No to exit code etc.




Code:
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("LP ME").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


Hi,
The reason for the issue with the sorting of A-Z was caused by the image being the same size or larger than the cell its inserted into.
In order to sort A-Z and fix the issue the image was made smaller & now works fine.

Below is the code which works well.

Code:
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("LPM").Pictures.Insert(fName)


With pic
    .ShapeRange.LockAspectRatio = msoFalse
    .Left = r.Left + 5
    .Top = r.Top + 5
    .Width = r.Width - 10
    .Height = r.Height - 10
    .Select
End With


If TypeName(Selection) = "Picture" Then
    Application.SendKeys "%a~"
    Application.CommandBars.ExecuteMso "PicturesCompress"
End If
End Sub
 
Upvote 0
Morning
The code in use at present is shown below of which just opens the documents folder.
I would like to have it open a specific folder and so i need to add the path to the code,the path is C:\Users\Ian\Desktop\SCREEN SHOTS

Code:
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("LPM").Pictures.Insert(fName)
 
With pic
    .ShapeRange.LockAspectRatio = msoFalse
    .Left = r.Left + 5
    .Top = r.Top + 5
    .Width = r.Width - 10
    .Height = r.Height - 10
    .Select
End With
 
If TypeName(Selection) = "Picture" Then
    Application.SendKeys "%a~"
    Application.CommandBars.ExecuteMso "PicturesCompress"
End If
End Sub

The code below will open the specific folder i require but i am unable to make the correct edit to put it into the code in use as shown above.

Please could you advise how i need to do this.

Have a nice day

Code:
Sub CompressPicture()Dim MyFolder As String
MyFolder = "C:\Users\Ian\Desktop\SCREEN SHOTS\"
ActiveWorkbook.FollowHyperlink MyFolder
End Sub
 
Upvote 0
Now all sorted.

Adding the code below before the fname part worked for me.

Code:
ChDir "C:\Users\Ian\Desktop\SCREEN SHOTS"
 
Upvote 0

Forum statistics

Threads
1,213,484
Messages
6,113,924
Members
448,533
Latest member
thietbibeboiwasaco

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top