Delete and Insert Pictures VBA

M

MAlhash

New Member
Joined
Mar 26, 2023
Messages
41
Office Version
  1. 365
Platform
  1. Windows
Hello every one !

I am trying to update my report by deleting the old phot and insert a new photo meanning , if (Case testRange.Value2 < 1#) then delete the old photo in the cell which is (Attach) and insert

picname = "C:\Users\MAlhashlamoun\Pictures\UNATTACH" & ".png" also for the other condition if Case testRange.Value2 >= 1#, delete the photo exisiting in the same cell and replace with picname = "C:\Users\MAlhashlamoun\Pictures\ATTACH" & ".png"

This is my code:


Sub Update_Click()

Application.ScreenUpdating = True

Dim testRange As Range
Dim picname As String


Set testRange = ActiveSheet.Range("O95")

If IsEmpty(testRange) Then
MsgBox "No value in cell O95"
Exit Sub
End If

Select Case True

Case Not IsNumeric(testRange.Value2)

MsgBox "Value in cell O95 is not numeric"
Exit Sub

Case testRange.Value2 < 1#

picname = "C:\Users\MAlhashlamoun\Pictures\UNATTACH" & ".png"



Case testRange.Value2 >= 1#

picname = "C:\Users\MAlhashlamoun\Pictures\ATTACH" & ".png"


End Select

On Error GoTo ErrNoPhoto

ActiveSheet.Pictures.Insert(picname).Select

With Selection


.Left = Range("R95").Left
.Top = Range("R95").Top

.ShapeRange.IncrementLeft 38
.ShapeRange.IncrementTop 5
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 20#
.ShapeRange.Width = 20#
.ShapeRange.Rotation = 0#

End With

Application.ScreenUpdating = True

Exit Sub

ErrNoPhoto:
MsgBox "Unable to Find Photo" 'Shows message box if picture not found
Exit Sub











End Sub
 

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).
Sort by date Sort by votes
When you insert the new picture you give it a name, for example "any_name".
Before inserting the new picture, delete the old one using the same name "any_name".

Note: If you already have an image on the sheet, you will need to delete it manually for the first time. Then the macro will delete it automatically.

Try the following code:

VBA Code: 
Sub Update_Click()
  Dim testRange As Range
  Dim picname As String
 
  Application.ScreenUpdating = True
  Set testRange = ActiveSheet.Range("O95")
 
  Select Case True
    Case IsEmpty(testRange)
      MsgBox "No value in cell O95"
      Exit Sub
    Case Not IsNumeric(testRange.Value2)
      MsgBox "Value in cell O95 is not numeric"
      Exit Sub
    Case testRange.Value2 < 1#
      picname = "C:\Users\MAlhashlamoun\Pictures\UNATTACH" & ".png"
    Case testRange.Value2 >= 1#
      picname = "C:\Users\MAlhashlamoun\Pictures\ATTACH" & ".png"
  End Select
 
  If Dir(picname) = "" Then
    MsgBox "Unable to Find Photo" 'Shows message box if picture not found
    Exit Sub
  End If
 
  'Before inserting the new picture, delete the old one.
  On Error Resume Next
     ActiveSheet.Pictures("any_name").Delete
  On Error GoTo 0
 
  ActiveSheet.Pictures.Insert(picname).Select
  With Selection
    .Name = "any_name"                  'Name the image with any name.
    .Left = Range("R95").Left
    .Top = Range("R95").Top
    .ShapeRange.IncrementLeft 38
    .ShapeRange.IncrementTop 5
    .ShapeRange.LockAspectRatio = msoFalse
    .ShapeRange.Height = 20#
    .ShapeRange.Width = 20#
    .ShapeRange.Rotation = 0#
  End With
  Application.ScreenUpdating = True
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------
 
Upvote 1
Solution
DanteAmor said:
When you insert the new picture you give it a name, for example "any_name".
Before inserting the new picture, delete the old one using the same name "any_name".

Note: If you already have an image on the sheet, you will need to delete it manually for the first time. Then the macro will delete it automatically.

Try the following code:

VBA Code: 
Sub Update_Click()
  Dim testRange As Range
  Dim picname As String
 
  Application.ScreenUpdating = True
  Set testRange = ActiveSheet.Range("O95")
 
  Select Case True
    Case IsEmpty(testRange)
      MsgBox "No value in cell O95"
      Exit Sub
    Case Not IsNumeric(testRange.Value2)
      MsgBox "Value in cell O95 is not numeric"
      Exit Sub
    Case testRange.Value2 < 1#
      picname = "C:\Users\MAlhashlamoun\Pictures\UNATTACH" & ".png"
    Case testRange.Value2 >= 1#
      picname = "C:\Users\MAlhashlamoun\Pictures\ATTACH" & ".png"
  End Select
 
  If Dir(picname) = "" Then
    MsgBox "Unable to Find Photo" 'Shows message box if picture not found
    Exit Sub
  End If
 
  'Before inserting the new picture, delete the old one.
  On Error Resume Next
     ActiveSheet.Pictures("any_name").Delete
  On Error GoTo 0
 
  ActiveSheet.Pictures.Insert(picname).Select
  With Selection
    .Name = "any_name"                  'Name the image with any name.
    .Left = Range("R95").Left
    .Top = Range("R95").Top
    .ShapeRange.IncrementLeft 38
    .ShapeRange.IncrementTop 5
    .ShapeRange.LockAspectRatio = msoFalse
    .ShapeRange.Height = 20#
    .ShapeRange.Width = 20#
    .ShapeRange.Rotation = 0#
  End With
  Application.ScreenUpdating = True
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------
Click to expand...

Thank you, sir, it worked perfectly. But sir i want this code to go through O95:O98 wich is related to R95:98
and from O104:O108
 
Upvote 0
MAlhash said:
But sir i want this code to go through O95:O98 wich is related to R95:98
and from O104:O108
Click to expand...

Ok, here is the code with the change, but you should comment it out from the original post.

VBA Code: 
Sub Update_Click()
  Dim c As Range
  Dim picname As String, aCell As String
 
  Application.ScreenUpdating = False
 
  For Each c In Range("O95:O98, O104:O108")
    aCell = c.Address(0, 0)
    Select Case True
      Case IsEmpty(c.Value)
        MsgBox "No value in cell: " & aCell
        Exit Sub
      Case Not IsNumeric(c.Value)
        MsgBox "Value is not numeric in cell: " & aCell
        Exit Sub
      Case c.Value < 1#
        picname = "C:\Users\MAlhashlamoun\Pictures\UNATTACH" & ".png"
        
      Case c.Value2 >= 1#
        picname = "C:\Users\MAlhashlamoun\Pictures\ATTACH" & ".png"
        
    End Select
   
    If Dir(picname) = "" Then
      MsgBox "Unable to Find Photo" 'Shows message box if picture not found
      Exit Sub
    End If
   
    'Before inserting the new picture, delete the old one.
    On Error Resume Next
      ActiveSheet.Pictures("name_" & aCell).Delete
    On Error GoTo 0
   
    ActiveSheet.Pictures.Insert(picname).Select
    With Selection
      .Name = "name_" & aCell                  'Name the image with any name.
      .Left = Range("R" & c.Row).Left
      .Top = Range("R" & c.Row).Top
      .ShapeRange.IncrementLeft 38
      .ShapeRange.IncrementTop 5
      .ShapeRange.LockAspectRatio = msoFalse
      .ShapeRange.Height = 20#
      .ShapeRange.Width = 20#
      .ShapeRange.Rotation = 0#
    End With
  Next
  Application.ScreenUpdating = True
End Sub


:cool:
 
Upvote 1
DanteAmor said:
Ok, here is the code with the change, but you should comment it out from the original post.

VBA Code: 
Sub Update_Click()
  Dim c As Range
  Dim picname As String, aCell As String
 
  Application.ScreenUpdating = False
 
  For Each c In Range("O95:O98, O104:O108")
    aCell = c.Address(0, 0)
    Select Case True
      Case IsEmpty(c.Value)
        MsgBox "No value in cell: " & aCell
        Exit Sub
      Case Not IsNumeric(c.Value)
        MsgBox "Value is not numeric in cell: " & aCell
        Exit Sub
      Case c.Value < 1#
        picname = "C:\Users\MAlhashlamoun\Pictures\UNATTACH" & ".png"
       
      Case c.Value2 >= 1#
        picname = "C:\Users\MAlhashlamoun\Pictures\ATTACH" & ".png"
       
    End Select
  
    If Dir(picname) = "" Then
      MsgBox "Unable to Find Photo" 'Shows message box if picture not found
      Exit Sub
    End If
  
    'Before inserting the new picture, delete the old one.
    On Error Resume Next
      ActiveSheet.Pictures("name_" & aCell).Delete
    On Error GoTo 0
  
    ActiveSheet.Pictures.Insert(picname).Select
    With Selection
      .Name = "name_" & aCell                  'Name the image with any name.
      .Left = Range("R" & c.Row).Left
      .Top = Range("R" & c.Row).Top
      .ShapeRange.IncrementLeft 38
      .ShapeRange.IncrementTop 5
      .ShapeRange.LockAspectRatio = msoFalse
      .ShapeRange.Height = 20#
      .ShapeRange.Width = 20#
      .ShapeRange.Rotation = 0#
    End With
  Next
  Application.ScreenUpdating = True
End Sub


:cool:
Click to expand...
Thank you, Sir. It works perfectly.
 
Upvote 0
Hello sir!

I have modified my code again. I have tried to insert hyperlinks for the photo, but I was not success.
I have two kind of photos which will appears regarding a condition. I will be clearer. If the user attached the document a picture which is name (ATTACH) will appear and if there is no attachment the picture with (UNATTACH) name will appear. All this work for me perfectly. my issue now is that I want to add the hyperlink to this picture "ATTACH", so when I click the picture, the document will open for me. I have arranged the hyperlinks path in a different cell. is it possible to merge the pictures with hyperlinks.

Here is the modified code:

Dim c As Range
Dim picname As String, aCell As String

Application.ScreenUpdating = False

For Each c In Range("AM95:AM98, AM104:AM107, AM113:AM117, AM123:AM126, AM132:AM135") ' its reading if there is attachment it will return 1.
aCell = c.Address(0, 0)
Select Case True
Case IsEmpty(c.Value)
MsgBox "No value in cell: " & aCell
Exit Sub
Case Not IsNumeric(c.Value)
MsgBox "Value is not numeric in cell: " & aCell
Exit Sub
Case c.Value < 1#
picname = "C:\Users\MAlhashlamoun\Pictures\UNATTACH" & ".png"

Case c.Value2 >= 1#
picname = "C:\Users\MAlhashlamoun\Pictures\ATTACH" & ".png"

End Select

If Dir(picname) = "" Then
MsgBox "Unable to Find Photo" 'Shows message box if picture not found
Exit Sub
End If

'Before inserting the new picture, delete the old one.
On Error Resume Next
ActiveSheet.Pictures("name_" & aCell).Delete
On Error GoTo 0

ActiveSheet.Pictures.Insert(picname).Select
With Selection
.Name = "name_" & aCell 'Name the image with any name.
.Left = Range("R" & c.Row).Left
.Top = Range("R" & c.Row).Top
.ShapeRange.IncrementLeft 26
.ShapeRange.IncrementTop 5
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 20#
.ShapeRange.Width = 20#
.ShapeRange.Rotation = 0#
End With
Next
Application.ScreenUpdating = True
End Sub


the hyper link path is showing in this way in the cells:
C:\Users\MAlhashlamoun\Desktop\New Microsoft Excel Worksheet.xlsx
C:\Users\MAlhashlamoun\Downloads\task-checklist.xlsx
C:\Users\MAlhashlamoun\Desktop\TO-DO-LIST-Latest .xlsm
C:\Users\MAlhashlamoun\Downloads\task-checklist.xlsx
C:\Users\MAlhashlamoun\Downloads\You_Exec_-_2023_Calender_Free.xlsx
C:\Users\MAlhashlamoun\Downloads\You_Exec_-_Issue_Tracker_Free.xlsx
C:\Users\MAlhashlamoun\Desktop\TO-DO-LIST-Latest .xlsm
C:\Users\MAlhashlamoun\Downloads\project-task-list-template.xlsx

please help me when i press on the attachment picture it should open for me the attachment directly.

Thank you
 

Attachments

  • attach.png
    attach.png
    112.9 KB · Views: 6
Upvote 0
That is a different requirement than the original post, you must create a new thread.

Note Code Tag:
In future please use code tags when posting code.​
How to Post Your VBA Code it makes your code easier to read and copy and it also maintains VBA formatting.​
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question
Adding Hyperlinks to pictures in Excel !
Replies
2
Views
598
MAlhash
M
M
  • Question
Excel Macro to insert picture into excel from SharePoint or website !
Replies
0
Views
292
MAlhash
M
M
  • Question
I want to merge two VBA Codes !
Replies
2
Views
355
MAlhash
M
N
  • Solved
VBA/Excel: Run-Time Error 1004
2
Replies
10
Views
1K
jolivanes
jolivanes
S
  • Solved
VBA Code - Center/Size picture across merged cells
Replies
2
Views
293
Spaztic
S

Forum statistics

Threads
1,215,071
Messages
6,122,963
Members
449,094
Latest member
Anshu121

Share this page

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