Add image and resize on protected sheet

amorales75pr

New Member
Joined
Sep 2, 2016
Messages
7
Hi;

First I will like you to excuse me for my English cause it is not my first language. I am trying to add and image in a form so the user can click on a button and browse the computer for the image. I have add the button and a macro for temporarily unlock and lock the form and browsing for the image in the computer but because not all images are the same size, when add it some block other cells in the form.

I will like the image to be added with in a range of cells so it will always be in the same place and to have the same size always, does not matter if the are out of proportion(does not have to maintain proportion).

Thanks and this is what I have so far:


Sub Insert_Picture() Sheet1.Unprotect Password:="xxxxx"
Dim MyWidth As Double
Dim MyHeight As Double
Dim Image As Object
' Para definir la imagen

'----------------------------------------------------------
'- check for existing picture
If ActiveSheet.Pictures.Count > 0 Then
rsp = MsgBox("There is an existing picture. " & vbCr _
& "Ya hay una imagen. ¿Desea sustituirla?", vbYesNoCancel)
If rsp = vbCancel Then Exit Sub
If rsp = vbYes Then
ActiveSheet.Pictures(1).Delete
End If
End If
'-----------------------------------------------------------
'- get new picture
Application.Dialogs(xlDialogInsertPicture).Show
'- may not have inserted a picture
If ActiveSheet.Pictures.Count > 0 Then
'- resize
MyWidth = ActiveSheet.Range("b8:b25").Left
MyHeight = ActiveSheet.Range("b8:w8").Top
Selection.Top = 110
Selection.Left = 20
Selection.Width = 170
Selection.Height = 75

Else
MsgBox ("Ninguna imagen ha sido añadida.")
End If
Sheet1.Protect Password:="xxxxx"
End Sub
 

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.
Something like this:
Code:
Sub Insert_Picture()Sheet1.Unprotect Password:="xxxxx"
Dim MyWidth As Double
Dim MyHeight As Double
Dim Image As Object
' Para definir la imagen


'----------------------------------------------------------
'- check for existing picture
If ActiveSheet.Pictures.Count > 0 Then
rsp = MsgBox("There is an existing picture. " & vbCr _
& "Ya hay una imagen. ¿Desea sustituirla?", vbYesNoCancel)
If rsp = vbCancel Then Exit Sub
If rsp = vbYes Then
ActiveSheet.Pictures(1).Delete
End If
End If
'-----------------------------------------------------------
'- get new picture
Application.Dialogs(xlDialogInsertPicture).Show
'- may not have inserted a picture
If ActiveSheet.Pictures.Count > 0 Then
'- resize
MyWidth = ActiveSheet.Range("b8:w8").Width
MyHeight = Sheet1.Range("b8:b25").Height
Selection.Top = ActiveSheet.Range("b8").Top
Selection.Left = ActiveSheet.Range("b8").Left
Selection.Width = MyWidth
Selection.Height = MyHeight


Else
MsgBox ("Ninguna imagen ha sido añadida.")
End If
Sheet1.Protect Password:="xxxxx"
End Sub
 
Upvote 0
Thanks for your interest and help it almost... works for Height but does not control Width. I try using your code and changing "MyWidth = ActiveSheet.Range("b8:w8").Width" to "MyWidth = Sheet1.Range("b8:w8").Width" but id did not work either.

We are closer to the solution I believe.
 
Upvote 0
This should work. I added the LockAspectRatio = msoFalse, which should stretch the image to your desired Width and Height
Code:
Sub Insert_Picture()
Sheet1.Unprotect Password:="xxxxx"
Dim MyWidth As Double
Dim MyHeight As Double
Dim Image As Object
' Para definir la imagen




'----------------------------------------------------------
'- check for existing picture
If ActiveSheet.Pictures.Count > 0 Then
rsp = MsgBox("There is an existing picture. " & vbCr _
& "Ya hay una imagen. ¿Desea sustituirla?", vbYesNoCancel)
If rsp = vbCancel Then Exit Sub
If rsp = vbYes Then
ActiveSheet.Pictures(1).Delete
End If
End If
'-----------------------------------------------------------
'- get new picture
Application.Dialogs(xlDialogInsertPicture).Show
'- may not have inserted a picture
If ActiveSheet.Pictures.Count > 0 Then
'- resize
MyWidth = ActiveSheet.Range("b8:w8").Width
MyHeight = ActiveSheet.Range("b8:b25").Height
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.Top = ActiveSheet.Range("b8").Top
Selection.Left = ActiveSheet.Range("b8").Left
Selection.Width = MyWidth
Selection.Height = MyHeight




Else
MsgBox ("Ninguna imagen ha sido añadida.")
End If
Sheet1.Protect Password:="xxxxx"
End Sub
 
Upvote 0

Forum statistics

Threads
1,223,099
Messages
6,170,107
Members
452,302
Latest member
TaMere

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