Insert picture into cell Macro edit request

[ipbr21054]

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.

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

 

[Hjemmet]

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

 

[ipbr21054]

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

 

[ipbr21054]

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 ?

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

 

[ipbr21054]

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.

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.

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

 

[ipbr21054]

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

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

Sub CompressPicture()Dim MyFolder As String
MyFolder = "C:\Users\Ian\Desktop\SCREEN SHOTS\"
ActiveWorkbook.FollowHyperlink MyFolder
End Sub

 

[ipbr21054]

Now all sorted.

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

ChDir "C:\Users\Ian\Desktop\SCREEN SHOTS"